From e874799cc476664a97eaa859816d2cbc16ce0959 Mon Sep 17 00:00:00 2001 From: VisruthSK <67435125+VisruthSK@users.noreply.github.com> Date: Wed, 29 Oct 2025 09:19:55 -0700 Subject: [PATCH 01/14] Started work on moving to new theme --- .github/workflows/pkgdown.yaml | 53 +++++++++++++++++ README.md | 2 +- _pkgdown.yml | 103 +++++++++++++++++++++++++++++++++ 3 files changed, 157 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/pkgdown.yaml create mode 100644 _pkgdown.yml diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml new file mode 100644 index 000000000..57714488a --- /dev/null +++ b/.github/workflows/pkgdown.yaml @@ -0,0 +1,53 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib actions#where-to-find-help +on: + pull_request: + # build dev site on merged pushes + push: + branches: [main, master] + # build full site on releases + release: + types: [published] + workflow_dispatch: + +name: pkgdown.yaml + +jobs: + pkgdown: + runs-on: ubuntu-latest + # Only restrict concurrency for non-PR jobs + concurrency: + group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} + cancel-in-progress: true + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::pkgdown, local::., stan-dev/pkgdown-config + + - name: Build site + run: | + pkgdown::build_site_github_pages( + lazy = FALSE, # change to TRUE if runner times out. + run_dont_run = TRUE, + new_process = TRUE + ) + shell: Rscript {0} + + - name: Deploy to GitHub pages 🚀 + uses: JamesIves/github-pages-deploy-action@v4 + with: + clean: false + branch: gh-pages + folder: docs \ No newline at end of file diff --git a/README.md b/README.md index 7e63ba1e0..2692261e3 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# rstanarm +# rstanarm [![CRAN\_Status\_Badge](https://www.r-pkg.org/badges/version/rstanarm?color=blue)](https://cran.r-project.org/package=rstanarm) diff --git a/_pkgdown.yml b/_pkgdown.yml new file mode 100644 index 000000000..af659473f --- /dev/null +++ b/_pkgdown.yml @@ -0,0 +1,103 @@ +url: https://mc-stan.org/rstanarm + +destination: "." + +template: + package: pkgdownconfig + +navbar: + title: "rstanarm" + + structure: + left: [home, vignettes, functions, news, pkgs, stan] + right: [search, bluesky, forum, github, lightswitch] + + components: + pkgs: + text: Other Packages + menu: + - text: bayesplot + href: https://mc-stan.org/bayesplot + - text: cmdstanr + href: https://mc-stan.org/cmdstanr + - text: loo + href: https://mc-stan.org/loo + - text: posterior + href: https://mc-stan.org/posterior + - text: projpred + href: https://mc-stan.org/projpred + - text: rstan + href: https://mc-stan.org/rstan + - text: rstantools + href: https://mc-stan.org/rstantools + - text: shinystan + href: https://mc-stan.org/shinystan + +articles: + - title: "Getting Started" + desc: > + These vignettes provide a preliminary introduction to rstanarm and + discuss the prior distributions available. + contents: + - rstanarm + - priors + - title: "Modeling functions" + desc: > + These vignettes provide instructions on how to use the modeling + functions in rstanarm. + contents: + - binomial + - count + - continuous + - aov + - lm + - betareg + - polr + - glmer + - jm + - title: "Additional tutorials on specific modeling techniques and applications" + desc: > + These vignettes provide additional tutorials on using rstanarm + for specific purposes once you are comfortable using the package + in general. + contents: + - mrp + - pooling + - ab-testing + +reference: + - title: "About rstanarm" + desc: > + These pages provides a summary of the functionality available in rstanarm. + contents: + - rstanarm-package + - available-models + - available-algorithms + - title: "Fitting models" + desc: > + Functions for model fitting. + contents: + - starts_with("stan_") + - priors + - title: "Methods" + desc: > + Functions to work with fitted model objects. + contents: + - stanreg-objects + - ends_with("stanreg") + - starts_with("posterior_") + - ps_check + - ends_with("stanmvreg") + - ends_with("stanjm") + - title: "Additional documentation" + desc: > + Misc. other help pages. + contents: + - rstanarm-datasets + - example_model + - example_jm + - stanreg_list + - adapt_delta + - QR-argument + - neg_binomial_2 + - rstanarm-deprecated \ No newline at end of file From f2e7a7755be9dc390115374352527eb3c00a7ca1 Mon Sep 17 00:00:00 2001 From: VisruthSK <67435125+VisruthSK@users.noreply.github.com> Date: Wed, 29 Oct 2025 09:46:16 -0700 Subject: [PATCH 02/14] Add linebreak --- .github/workflows/pkgdown.yaml | 1 - _pkgdown.yml | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 57714488a..877722477 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -1,7 +1,6 @@ # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples # Need help debugging build failures? Start at https://github.com/r-lib actions#where-to-find-help on: - pull_request: # build dev site on merged pushes push: branches: [main, master] diff --git a/_pkgdown.yml b/_pkgdown.yml index af659473f..1585e97b2 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -100,4 +100,4 @@ reference: - adapt_delta - QR-argument - neg_binomial_2 - - rstanarm-deprecated \ No newline at end of file + - rstanarm-deprecated From 13cabcf39ed25a8ba469c3e18765c10c62901a04 Mon Sep 17 00:00:00 2001 From: VisruthSK <67435125+VisruthSK@users.noreply.github.com> Date: Wed, 29 Oct 2025 16:07:54 -0700 Subject: [PATCH 03/14] Changed documentation slightly [ci skip] --- NAMESPACE | 1 - R/pp_validate.R | 2 +- _pkgdown.yml | 1 + 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 1f93e3581..1ec35c551 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -190,7 +190,6 @@ export(student_t) export(waic) if(getRversion()>='3.3.0') importFrom(stats, sigma) else importFrom(lme4,sigma) - import(Rcpp) import(bayesplot) import(methods) diff --git a/R/pp_validate.R b/R/pp_validate.R index ab3fe09a5..d284c3a72 100644 --- a/R/pp_validate.R +++ b/R/pp_validate.R @@ -92,7 +92,7 @@ #' } #' } #' @importFrom ggplot2 rel geom_point geom_segment scale_x_continuous element_line -#' +#' @keywords internal pp_validate <- function(object, nreps = 20, seed = 12345, ...) { # based on Samantha Cook's BayesValidate::validate quant <- function(draws) { diff --git a/_pkgdown.yml b/_pkgdown.yml index 1585e97b2..877cfb7c0 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -101,3 +101,4 @@ reference: - QR-argument - neg_binomial_2 - rstanarm-deprecated + - logit From 8b40d94f6e54ed71fed9353be5d8aa6f08506c6b Mon Sep 17 00:00:00 2001 From: VisruthSK <67435125+VisruthSK@users.noreply.github.com> Date: Mon, 1 Dec 2025 12:52:39 -0800 Subject: [PATCH 04/14] Redocumented. Updated pp_validate docs as well as Gelman links --- NAMESPACE | 1 + man/pp_validate.Rd | 1 + man/rstanarm-datasets.Rd | 2 +- man/rstanarm-package.Rd | 6 +++--- 4 files changed, 6 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 1ec35c551..1f93e3581 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -190,6 +190,7 @@ export(student_t) export(waic) if(getRversion()>='3.3.0') importFrom(stats, sigma) else importFrom(lme4,sigma) + import(Rcpp) import(bayesplot) import(methods) diff --git a/man/pp_validate.Rd b/man/pp_validate.Rd index 5027f3f6e..0a2672a50 100644 --- a/man/pp_validate.Rd +++ b/man/pp_validate.Rd @@ -85,3 +85,4 @@ distribution. \code{\link[bayesplot:bayesplot-colors]{color_scheme_set}} to change the color scheme of the plot. } +\keyword{internal} diff --git a/man/rstanarm-datasets.Rd b/man/rstanarm-datasets.Rd index 7659f5091..70c617b01 100644 --- a/man/rstanarm-datasets.Rd +++ b/man/rstanarm-datasets.Rd @@ -189,7 +189,7 @@ generalizations. \emph{Journal of the American Statistical Association} Gelman, A. and Hill, J. (2007). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models.} Cambridge University Press, - Cambridge, UK. \url{https://stat.columbia.edu/~gelman/arm/} + Cambridge, UK. \url{https://sites.stat.columbia.edu/gelman/arm/} Spiegelhalter, D., Thomas, A., Best, N., & Gilks, W. (1996) BUGS 0.5 Examples. MRC Biostatistics Unit, Institute of Public health, Cambridge, UK. diff --git a/man/rstanarm-package.Rd b/man/rstanarm-package.Rd index e608213ee..acaae097f 100644 --- a/man/rstanarm-package.Rd +++ b/man/rstanarm-package.Rd @@ -197,11 +197,11 @@ mixed-Effects models using lme4. \emph{Journal of Statistical Software}. Gelman, A., Carlin, J. B., Stern, H. S., Dunson, D. B., Vehtari, A., and Rubin, D. B. (2013). \emph{Bayesian Data Analysis.} Chapman & Hall/CRC - Press, London, third edition. \url{https://stat.columbia.edu/~gelman/book/} + Press, London, third edition. \url{https://sites.stat.columbia.edu/gelman/book/} Gelman, A. and Hill, J. (2007). \emph{Data Analysis Using Regression and Multilevel/Hierarchical Models.} Cambridge University Press, - Cambridge, UK. \url{https://stat.columbia.edu/~gelman/arm/} + Cambridge, UK. \url{https://sites.stat.columbia.edu/gelman/arm/} Stan Development Team. \emph{Stan Modeling Language Users Guide and Reference Manual.} \url{https://mc-stan.org/users/documentation/}. @@ -242,7 +242,7 @@ User-friendly Bayesian regression modeling: A tutorial with rstanarm and shinyst Authors: \itemize{ - \item Jonah Gabry \email{jsg2201@columbia.edu} + \item Jonah Gabry \email{jgabry@gmail.com} } Other contributors: From 7d25386ebfe25bc618ca9cc3ed25772608143702 Mon Sep 17 00:00:00 2001 From: VisruthSK <67435125+VisruthSK@users.noreply.github.com> Date: Wed, 3 Dec 2025 01:38:47 -0800 Subject: [PATCH 05/14] Removed red logo [no ci] --- R/doc-rstanarm-package.R | 2 +- R/stan_betareg.R | 229 +++++++----- R/stan_biglm.R | 85 +++-- R/stan_clogit.R | 158 +++++--- R/stan_gamm4.R | 584 ++++++++++++++++++------------ R/stan_glm.R | 405 +++++++++++---------- R/stan_glmer.R | 413 +++++++++++---------- R/stan_jm.R | 765 ++++++++++++++++++++++----------------- R/stan_lm.R | 140 ++++--- R/stan_mvmer.R | 237 +++++++----- R/stan_nlmer.R | 292 ++++++++------- R/stan_polr.R | 179 ++++++--- man/figures/logo.svg | 96 ----- man/figures/stanlogo.png | Bin 16172 -> 0 bytes 14 files changed, 2019 insertions(+), 1566 deletions(-) delete mode 100644 man/figures/logo.svg delete mode 100644 man/figures/stanlogo.png diff --git a/R/doc-rstanarm-package.R b/R/doc-rstanarm-package.R index 542e213b6..9abc30957 100644 --- a/R/doc-rstanarm-package.R +++ b/R/doc-rstanarm-package.R @@ -37,7 +37,7 @@ #' #' @description #' \if{html}{ -#' \figure{stanlogo.png}{options: width="50" alt="https://mc-stan.org/about/logo/"} +#' \figure{logo.svg}{options: width="50" alt="https://mc-stan.org/about/logo/"} #' \emph{Stan Development Team} #' } #' diff --git a/R/stan_betareg.R b/R/stan_betareg.R index d4bb3b03d..d8b907dca 100644 --- a/R/stan_betareg.R +++ b/R/stan_betareg.R @@ -1,31 +1,31 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian beta regression models via Stan #' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Beta regression modeling with optional prior distributions for the +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' Beta regression modeling with optional prior distributions for the #' coefficients, intercept, and auxiliary parameter \code{phi} (if applicable). #' #' @export #' @templateVar armRef (Ch. 3-6) #' @templateVar pkg betareg #' @templateVar pkgfun betareg -#' @templateVar sameargs model,offset,weights +#' @templateVar sameargs model,offset,weights #' @templateVar rareargs na.action #' @templateVar fun stan_betareg #' @templateVar fitfun stan_betareg.fit @@ -43,24 +43,24 @@ #' @template args-algorithm #' @template args-adapt_delta #' @template args-QR -#' -#' @param link Character specification of the link function used in the model +#' +#' @param link Character specification of the link function used in the model #' for mu (specified through \code{x}). Currently, "logit", "probit", #' "cloglog", "cauchit", "log", and "loglog" are supported. -#' @param link.phi If applicable, character specification of the link function -#' used in the model for \code{phi} (specified through \code{z}). Currently, +#' @param link.phi If applicable, character specification of the link function +#' used in the model for \code{phi} (specified through \code{z}). Currently, #' "identity", "log" (default), and "sqrt" are supported. Since the "sqrt" #' link function is known to be unstable, it is advisable to specify a #' different link function (or to model \code{phi} as a scalar parameter #' instead of via a linear predictor by excluding \code{z} from the #' \code{formula} and excluding \code{link.phi}). -#' @param prior_z Prior distribution for the coefficients in the model for +#' @param prior_z Prior distribution for the coefficients in the model for #' \code{phi} (if applicable). Same options as for \code{prior}. -#' @param prior_intercept_z Prior distribution for the intercept in the model +#' @param prior_intercept_z Prior distribution for the intercept in the model #' for \code{phi} (if applicable). Same options as for \code{prior_intercept}. -#' @param prior_phi The prior distribution for \code{phi} if it is \emph{not} -#' modeled as a function of predictors. If \code{z} variables are specified -#' then \code{prior_phi} is ignored and \code{prior_intercept_z} and +#' @param prior_phi The prior distribution for \code{phi} if it is \emph{not} +#' modeled as a function of predictors. If \code{z} variables are specified +#' then \code{prior_phi} is ignored and \code{prior_intercept_z} and #' \code{prior_z} are used to specify the priors on the intercept and #' coefficients in the model for \code{phi}. When applicable, \code{prior_phi} #' can be a call to \code{exponential} to use an exponential distribution, or @@ -68,23 +68,23 @@ #' half-t, or half-Cauchy prior. See \code{\link{priors}} for details on these #' functions. To omit a prior ---i.e., to use a flat (improper) uniform #' prior--- set \code{prior_phi} to \code{NULL}. -#' -#' @details The \code{stan_betareg} function is similar in syntax to -#' \code{\link[betareg]{betareg}} but rather than performing maximum -#' likelihood estimation, full Bayesian estimation is performed (if -#' \code{algorithm} is \code{"sampling"}) via MCMC. The Bayesian model adds +#' +#' @details The \code{stan_betareg} function is similar in syntax to +#' \code{\link[betareg]{betareg}} but rather than performing maximum +#' likelihood estimation, full Bayesian estimation is performed (if +#' \code{algorithm} is \code{"sampling"}) via MCMC. The Bayesian model adds #' priors (independent by default) on the coefficients of the beta regression #' model. The \code{stan_betareg} function calls the workhorse #' \code{stan_betareg.fit} function, but it is also possible to call the #' latter directly. -#' +#' #' @seealso The vignette for \code{stan_betareg}. #' \url{https://mc-stan.org/rstanarm/articles/} -#' -#' @references Ferrari, SLP and Cribari-Neto, F (2004). Beta regression for +#' +#' @references Ferrari, SLP and Cribari-Neto, F (2004). Beta regression for #' modeling rates and proportions. \emph{Journal of Applied Statistics}. #' 31(7), 799--815. -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' ### Simulated data @@ -96,54 +96,55 @@ #' y <- rbeta(N, mu * phi, (1 - mu) * phi) #' hist(y, col = "dark grey", border = FALSE, xlim = c(0,1)) #' fake_dat <- data.frame(y, x, z) -#' +#' #' fit <- stan_betareg( -#' y ~ x | z, data = fake_dat, -#' link = "logit", -#' link.phi = "log", +#' y ~ x | z, data = fake_dat, +#' link = "logit", +#' link.phi = "log", #' algorithm = "optimizing" # just for speed of example -#' ) +#' ) #' print(fit, digits = 2) #' } stan_betareg <- - function(formula, - data, - subset, - na.action, - weights, - offset, - link = c("logit", "probit", "cloglog", "cauchit", "log", "loglog"), - link.phi = NULL, - model = TRUE, - y = TRUE, - x = FALSE, - ..., - prior = normal(autoscale=TRUE), - prior_intercept = normal(autoscale=TRUE), - prior_z = normal(autoscale=TRUE), - prior_intercept_z = normal(autoscale=TRUE), - prior_phi = exponential(autoscale=TRUE), - prior_PD = FALSE, - algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE) { - + function( + formula, + data, + subset, + na.action, + weights, + offset, + link = c("logit", "probit", "cloglog", "cauchit", "log", "loglog"), + link.phi = NULL, + model = TRUE, + y = TRUE, + x = FALSE, + ..., + prior = normal(autoscale = TRUE), + prior_intercept = normal(autoscale = TRUE), + prior_z = normal(autoscale = TRUE), + prior_intercept_z = normal(autoscale = TRUE), + prior_phi = exponential(autoscale = TRUE), + prior_PD = FALSE, + algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE + ) { if (!requireNamespace("betareg", quietly = TRUE)) { stop("Please install the betareg package before using 'stan_betareg'.") } if (!has_outcome_variable(formula)) { stop("LHS of formula must be specified.") } - + mc <- match.call(expand.dots = FALSE) data <- validate_data(data, if_missing = environment(formula)) mc$data <- data mc$model <- mc$y <- mc$x <- TRUE - + # NULLify any Stan specific arguments in mc mc$prior <- mc$prior_intercept <- mc$prior_PD <- mc$algorithm <- mc$adapt_delta <- mc$QR <- mc$sparse <- mc$prior_dispersion <- NULL - + mc$drop.unused.levels <- TRUE mc[[1L]] <- quote(betareg::betareg) mc$control <- betareg::betareg.control(maxit = 0, fsmaxit = 0) @@ -155,60 +156,91 @@ stan_betareg <- Z <- model.matrix(br, model = "precision") weights <- validate_weights(as.vector(model.weights(mf))) offset <- validate_offset(as.vector(model.offset(mf)), y = Y) - + # check if user specified matrix for precision model - if (length(grep("\\|", all.names(formula))) == 0 && - is.null(link.phi)) + if ( + length(grep("\\|", all.names(formula))) == 0 && + is.null(link.phi) + ) { Z <- NULL - + } + algorithm <- match.arg(algorithm) link <- match.arg(link) link_phi <- match.arg(link.phi, c(NULL, "log", "identity", "sqrt")) - - stanfit <- - stan_betareg.fit(x = X, y = Y, z = Z, - weights = weights, offset = offset, - link = link, link.phi = link.phi, - ..., - prior = prior, prior_z = prior_z, - prior_intercept = prior_intercept, - prior_intercept_z = prior_intercept_z, - prior_phi = prior_phi, prior_PD = prior_PD, - algorithm = algorithm, adapt_delta = adapt_delta, - QR = QR) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) - if (is.null(link.phi) && is.null(Z)) + + stanfit <- + stan_betareg.fit( + x = X, + y = Y, + z = Z, + weights = weights, + offset = offset, + link = link, + link.phi = link.phi, + ..., + prior = prior, + prior_z = prior_z, + prior_intercept = prior_intercept, + prior_intercept_z = prior_intercept_z, + prior_phi = prior_phi, + prior_PD = prior_PD, + algorithm = algorithm, + adapt_delta = adapt_delta, + QR = QR + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } + if (is.null(link.phi) && is.null(Z)) { link_phi <- "identity" + } sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) - X <- X[ , !sel, drop = FALSE] + X <- X[, !sel, drop = FALSE] if (!is.null(Z)) { sel <- apply(Z, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) - Z <- Z[ , !sel, drop = FALSE] + Z <- Z[, !sel, drop = FALSE] } - fit <- - nlist(stanfit, algorithm, data, offset, weights, - x = X, y = Y, z = Z %ORifNULL% model.matrix(y ~ 1), - family = beta_fam(link), family_phi = beta_phi_fam(link_phi), - formula, model = mf, terms = mt, call = match.call(), - na.action = attr(mf, "na.action"), contrasts = attr(X, "contrasts"), - stan_function = "stan_betareg") + fit <- + nlist( + stanfit, + algorithm, + data, + offset, + weights, + x = X, + y = Y, + z = Z %ORifNULL% model.matrix(y ~ 1), + family = beta_fam(link), + family_phi = beta_phi_fam(link_phi), + formula, + model = mf, + terms = mt, + call = match.call(), + na.action = attr(mf, "na.action"), + contrasts = attr(X, "contrasts"), + stan_function = "stan_betareg" + ) out <- stanreg(fit) if (algorithm == "optimizing") { out$log_p <- stanfit$log_p out$log_g <- stanfit$log_g } - out$xlevels <- lapply(mf[,-1], FUN = function(x) { + out$xlevels <- lapply(mf[, -1], FUN = function(x) { xlev <- if (is.factor(x) || is.character(x)) levels(x) else NULL xlev[!vapply(xlev, is.null, NA)] }) out$levels <- br$levels - if (!x) + if (!x) { out$x <- NULL - if (!y) + } + if (!y) { out$y <- NULL - if (!model) + } + if (!model) { out$model <- NULL - + } + structure(out, class = c("stanreg", "betareg")) } @@ -219,8 +251,11 @@ beta_fam <- function(link = "logit") { if (link == "loglog") { out <- binomial("cloglog") out$linkinv <- function(eta) { - 1 - pmax(pmin(-expm1(-exp(eta)), 1 - .Machine$double.eps), - .Machine$double.eps) + 1 - + pmax( + pmin(-expm1(-exp(eta)), 1 - .Machine$double.eps), + .Machine$double.eps + ) } out$linkfun <- function(mu) log(-log(mu)) } else { @@ -228,12 +263,15 @@ beta_fam <- function(link = "logit") { } out$family <- "beta" out$variance <- function(mu, phi) mu * (1 - mu) / (phi + 1) - out$dev.resids <- function(y, mu, wt) + out$dev.resids <- function(y, mu, wt) { stop("'dev.resids' function should not be called") - out$aic <- function(y, n, mu, wt, dev) + } + out$aic <- function(y, n, mu, wt, dev) { stop("'aic' function should not have been called") - out$simulate <- function(object, nsim) + } + out$simulate <- function(object, nsim) { stop("'simulate' function should not have been called") + } return(out) } @@ -242,11 +280,14 @@ beta_phi_fam <- function(link = "log") { out <- poisson(link) out$family <- "beta_phi" out$variance <- function(mu, phi) mu * (1 - mu) / (phi + 1) - out$dev.resids <- function(y, mu, wt) + out$dev.resids <- function(y, mu, wt) { stop("'dev.resids' function should not be called") - out$aic <- function(y, n, mu, wt, dev) + } + out$aic <- function(y, n, mu, wt, dev) { stop("'aic' function should not have been called") - out$simulate <- function(object, nsim) + } + out$simulate <- function(object, nsim) { stop("'simulate' function should not have been called") + } return(out) } diff --git a/R/stan_biglm.R b/R/stan_biglm.R index b9602fccf..6171a9e82 100644 --- a/R/stan_biglm.R +++ b/R/stan_biglm.R @@ -1,31 +1,31 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian regularized linear but big models via Stan -#' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' This is the same model as with \code{\link{stan_lm}} but it utilizes the #' output from \code{\link[biglm]{biglm}} in the \pkg{biglm} package in order to #' proceed when the data is too large to fit in memory. -#' +#' #' @export #' @param biglm The list output by \code{\link[biglm]{biglm}} in the \pkg{biglm} #' package. -#' @param xbar A numeric vector of column means in the implicit design matrix +#' @param xbar A numeric vector of column means in the implicit design matrix #' excluding the intercept for the observations included in the model. #' @param ybar A numeric scalar indicating the mean of the outcome for the #' observations included in the model. @@ -39,18 +39,18 @@ #' @template args-prior_PD #' @template args-algorithm #' @template args-adapt_delta -#' -#' @details The \code{stan_biglm} function is intended to be used in the same +#' +#' @details The \code{stan_biglm} function is intended to be used in the same #' circumstances as the \code{\link[biglm]{biglm}} function in the \pkg{biglm} -#' package but with an informative prior on the \eqn{R^2} of the regression. -#' Like \code{\link[biglm]{biglm}}, the memory required to estimate the model -#' depends largely on the number of predictors rather than the number of -#' observations. However, \code{stan_biglm} and \code{stan_biglm.fit} have -#' additional required arguments that are not necessary in +#' package but with an informative prior on the \eqn{R^2} of the regression. +#' Like \code{\link[biglm]{biglm}}, the memory required to estimate the model +#' depends largely on the number of predictors rather than the number of +#' observations. However, \code{stan_biglm} and \code{stan_biglm.fit} have +#' additional required arguments that are not necessary in #' \code{\link[biglm]{biglm}}, namely \code{xbar}, \code{ybar}, and \code{s_y}. -#' If any observations have any missing values on any of the predictors or the +#' If any observations have any missing values on any of the predictors or the #' outcome, such observations do not contribute to these statistics. -#' +#' #' @return The output of both \code{stan_biglm} and \code{stan_biglm.fit} is an #' object of \code{\link[rstan:stanfit-class]{stanfit-class}} rather than #' \code{\link{stanreg-objects}}, which is more limited and less convenient @@ -58,19 +58,30 @@ #' design matrix into memory. Without the full design matrix,some of the #' elements of a \code{\link{stanreg-objects}} object cannot be calculated, #' such as residuals. Thus, the functions in the \pkg{rstanarm} package that -#' input \code{\link{stanreg-objects}}, such as +#' input \code{\link{stanreg-objects}}, such as #' \code{\link{posterior_predict}} cannot be used. -#' -stan_biglm <- function(biglm, xbar, ybar, s_y, ..., - prior = R2(stop("'location' must be specified")), - prior_intercept = NULL, prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL) { +#' +stan_biglm <- function( + biglm, + xbar, + ybar, + s_y, + ..., + prior = R2(stop("'location' must be specified")), + prior_intercept = NULL, + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL +) { if (!requireNamespace("biglm", quietly = TRUE)) { stop("Please install the biglm package to use this function.") } - if (!inherits(biglm, "biglm") || is.null(biglm$qr) || - !inherits(biglm$qr, "bigqr") || is.null(biglm$terms)) { + if ( + !inherits(biglm, "biglm") || + is.null(biglm$qr) || + !inherits(biglm$qr, "bigqr") || + is.null(biglm$terms) + ) { stop("'biglm' must be of S3 class biglm as defined by the biglm package.") } @@ -80,16 +91,26 @@ stan_biglm <- function(biglm, xbar, ybar, s_y, ..., R <- sqrt(biglm$qr$D) * R if (identical(attr(biglm$terms, "intercept"), 1L)) { b <- b[-1] - R <- R[-1,-1] + R <- R[-1, -1] has_intercept <- TRUE } else { has_intercept <- FALSE } - stan_biglm.fit(b, R, SSR = biglm$qr$ss, N = biglm$n, xbar, ybar, s_y, - has_intercept, ..., - prior = prior, prior_intercept = prior_intercept, - prior_PD = prior_PD, algorithm = match.arg(algorithm), - adapt_delta = adapt_delta) + stan_biglm.fit( + b, + R, + SSR = biglm$qr$ss, + N = biglm$n, + xbar, + ybar, + s_y, + has_intercept, + ..., + prior = prior, + prior_intercept = prior_intercept, + prior_PD = prior_PD, + algorithm = match.arg(algorithm), + adapt_delta = adapt_delta + ) } - diff --git a/R/stan_clogit.R b/R/stan_clogit.R index cb68dc3bc..7d747d0da 100644 --- a/R/stan_clogit.R +++ b/R/stan_clogit.R @@ -1,23 +1,23 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Conditional logistic (clogit) regression models via Stan #' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' A model for case-control studies with optional prior distributions for the #' coefficients, intercept, and auxiliary parameters. #' @@ -37,15 +37,15 @@ #' @template args-QR #' @template args-sparse #' @template args-dots -#' +#' #' @param formula,data,subset,na.action,contrasts Same as for \code{\link[lme4]{glmer}}, #' except that any global intercept included in the formula will be dropped. #' \emph{We strongly advise against omitting the \code{data} argument}. Unless #' \code{data} is specified (and is a data frame) many post-estimation #' functions (including \code{update}, \code{loo}, \code{kfold}) are not #' guaranteed to work properly. -#' @param strata A factor indicating the groups in the data where the number of -#' successes (possibly one) is fixed by the research design. It may be useful +#' @param strata A factor indicating the groups in the data where the number of +#' successes (possibly one) is fixed by the research design. It may be useful #' to use \code{\link{interaction}} or \code{\link[survival]{strata}} to #' create this factor. However, the \code{strata} argument must not rely on #' any object besides the \code{data} \code{\link{data.frame}}. @@ -53,30 +53,30 @@ #' terms are included in the \code{formula}. See \code{\link{decov}} for #' more information about the default arguments. Ignored when there are no #' group-specific terms. -#' -#' @details The \code{stan_clogit} function is mostly similar in syntax to +#' +#' @details The \code{stan_clogit} function is mostly similar in syntax to #' \code{\link[survival]{clogit}} but rather than performing maximum #' likelihood estimation of generalized linear models, full Bayesian #' estimation is performed (if \code{algorithm} is \code{"sampling"}) via #' MCMC. The Bayesian model adds priors (independent by default) on the #' coefficients of the GLM. -#' -#' The \code{data.frame} passed to the \code{data} argument must be sorted by +#' +#' The \code{data.frame} passed to the \code{data} argument must be sorted by #' the variable passed to the \code{strata} argument. -#' +#' #' The \code{formula} may have group-specific terms like in #' \code{\link{stan_glmer}} but should not allow the intercept to vary by the #' stratifying variable, since there is no information in the data with which #' to estimate such deviations in the intercept. -#' +#' #' @seealso The vignette for Bernoulli and binomial models, which has more #' details on using \code{stan_clogit}. #' \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' dat <- infert[order(infert$stratum), ] # order by strata -#' post <- stan_clogit(case ~ spontaneous + induced + (1 | education), +#' post <- stan_clogit(case ~ spontaneous + induced + (1 | education), #' strata = stratum, #' data = dat, #' subset = parity <= 2, @@ -84,27 +84,38 @@ #' chains = 2, iter = 500) # for speed only #' #' nd <- dat[dat$parity > 2, c("case", "spontaneous", "induced", "education", "stratum")] -#' # next line would fail without case and stratum variables +#' # next line would fail without case and stratum variables #' pr <- posterior_epred(post, newdata = nd) # get predicted probabilities -#' +#' #' # not a random variable b/c probabilities add to 1 within strata -#' all.equal(rep(sum(nd$case), nrow(pr)), rowSums(pr)) +#' all.equal(rep(sum(nd$case), nrow(pr)), rowSums(pr)) #' } #' @importFrom reformulas findbars -stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NULL, - ..., - strata, prior = normal(autoscale=TRUE), - prior_covariance = decov(), prior_PD = FALSE, - algorithm = c("sampling", "optimizing", - "meanfield", "fullrank"), - adapt_delta = NULL, QR = FALSE, sparse = FALSE) { - +stan_clogit <- function( + formula, + data, + subset, + na.action = NULL, + contrasts = NULL, + ..., + strata, + prior = normal(autoscale = TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE +) { algorithm <- match.arg(algorithm) data <- validate_data(data, if_missing = environment(formula)) call <- match.call(expand.dots = TRUE) mf <- match.call(expand.dots = FALSE) - m <- match(c("formula", "data", "subset", "na.action", "strata"), - table = names(mf), nomatch = 0L) + m <- match( + c("formula", "data", "subset", "na.action", "strata"), + table = names(mf), + nomatch = 0L + ) mf <- mf[c(1L, m)] names(mf)[length(mf)] <- "weights" mf$data <- data @@ -114,8 +125,9 @@ stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NUL } has_bars <- length(findbars(formula)) > 0 if (has_bars) { - if (is.null(prior_covariance)) + if (is.null(prior_covariance)) { stop("'prior_covariance' can't be NULL.", call. = FALSE) + } mf[[1L]] <- quote(lme4::glFormula) mf$control <- make_glmerControl() glmod <- eval(mf, parent.frame()) @@ -123,14 +135,14 @@ stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NUL mf <- glmod$fr Y <- mf[, as.character(glmod$formula[2L])] group <- glmod$reTrms - group$strata <- glmod$strata <- as.factor(mf[,"(weights)"]) + group$strata <- glmod$strata <- as.factor(mf[, "(weights)"]) group$decov <- prior_covariance } else { validate_glm_formula(formula) mf[[1L]] <- as.name("model.frame") mf$drop.unused.levels <- TRUE mf <- eval(mf, parent.frame()) - group <- list(strata = as.factor(mf[,"(weights)"])) + group <- list(strata = as.factor(mf[, "(weights)"])) mt <- attr(mf, "terms") X <- model.matrix(mt, mf, contrasts) Y <- array1D_check(model.response(mf, type = "any")) @@ -139,7 +151,7 @@ stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NUL if (is.factor(Y)) { Y <- fac2bin(Y) } - + ord <- order(group$strata) if (any(diff(ord) <= 0)) { stop("Data must be sorted by 'strata' (in increasing order).") @@ -148,8 +160,9 @@ stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NUL weights <- double(0) mf <- check_constant_vars(mf) mt <- attr(mf, "terms") - if (is.empty.model(mt)) + if (is.empty.model(mt)) { stop("Predictors specified.", call. = FALSE) + } xint <- match("(Intercept)", colnames(X), nomatch = 0L) if (xint > 0L) { X <- X[, -xint, drop = FALSE] @@ -158,16 +171,30 @@ stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NUL attr(mt, "intercept") <- 0L } f <- binomial(link = "logit") - stanfit <- stan_glm.fit(x = X, y = Y, weights = weights, - offset = offset, family = f, - prior = prior, - prior_PD = prior_PD, - algorithm = algorithm, adapt_delta = adapt_delta, - group = group, QR = QR, sparse = sparse, ...) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) + stanfit <- stan_glm.fit( + x = X, + y = Y, + weights = weights, + offset = offset, + family = f, + prior = prior, + prior_PD = prior_PD, + algorithm = algorithm, + adapt_delta = adapt_delta, + group = group, + QR = QR, + sparse = sparse, + ... + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } f$link <- "clogit" - f$linkinv <- function(eta, g = group$strata, - successes = aggregate(Y, by = list(g), FUN = sum)$x) { + f$linkinv <- function( + eta, + g = group$strata, + successes = aggregate(Y, by = list(g), FUN = sum)$x + ) { denoms <- unlist(lapply(1:length(successes), FUN = function(j) { mark <- g == levels(g)[j] log_clogit_denom(sum(mark), successes[j], eta[mark]) @@ -176,28 +203,47 @@ stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NUL } f$linkfun <- log f$mu.eta <- function(eta) stop("'mu.eta' should not have been called") - fit <- nlist(stanfit, algorithm, family = f, formula, data, offset, weights, - x = X, y = Y, model = mf, terms = mt, call, - na.action = attr(mf, "na.action"), - contrasts = contrasts, - stan_function = "stan_clogit", - glmod = if(has_bars) glmod) + fit <- nlist( + stanfit, + algorithm, + family = f, + formula, + data, + offset, + weights, + x = X, + y = Y, + model = mf, + terms = mt, + call, + na.action = attr(mf, "na.action"), + contrasts = contrasts, + stan_function = "stan_clogit", + glmod = if (has_bars) glmod + ) out <- stanreg(fit) out$xlevels <- .getXlevels(mt, mf) - class(out) <- c(class(out), if(has_bars) "lmerMod", "clogit") + class(out) <- c(class(out), if (has_bars) "lmerMod", "clogit") return(out) } log_clogit_denom <- function(N_j, D_j, eta_j) { - if (D_j == 1 && N_j == NROW(eta_j)) return(log_sum_exp(eta_j)); - if (D_j == 0) return(0) + if (D_j == 1 && N_j == NROW(eta_j)) { + return(log_sum_exp(eta_j)) + } + if (D_j == 0) { + return(0) + } if (N_j == D_j) { - if (D_j == 1) return(eta_j[N_j]) + if (D_j == 1) { + return(eta_j[N_j]) + } return(sum(eta_j[(N_j - 1):(N_j + 1)])) - } - else { + } else { N_jm1 <- N_j - 1 - return( log_sum_exp2(log_clogit_denom(N_jm1, D_j, eta_j), - log_clogit_denom(N_jm1, D_j - 1, eta_j) + eta_j[N_j]) ) + return(log_sum_exp2( + log_clogit_denom(N_jm1, D_j, eta_j), + log_clogit_denom(N_jm1, D_j - 1, eta_j) + eta_j[N_j] + )) } } diff --git a/R/stan_gamm4.R b/R/stan_gamm4.R index 0583cb823..7d76c1531 100644 --- a/R/stan_gamm4.R +++ b/R/stan_gamm4.R @@ -1,27 +1,27 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2016 Simon N. Wood # Copyright (C) 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian generalized linear additive models with optional group-specific #' terms via Stan -#' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' Bayesian inference for GAMMs with flexible priors. -#' +#' #' @export #' @templateVar fun stan_gamm4 #' @templateVar pkg gamm4 @@ -37,38 +37,38 @@ #' @template args-adapt_delta #' @template args-QR #' @template args-sparse -#' -#' @param formula,random,family,data,knots,drop.unused.levels Same as for +#' +#' @param formula,random,family,data,knots,drop.unused.levels Same as for #' \code{\link[gamm4]{gamm4}}. \emph{We strongly advise against #' omitting the \code{data} argument}. Unless \code{data} is specified (and is #' a data frame) many post-estimation functions (including \code{update}, #' \code{loo}, \code{kfold}) are not guaranteed to work properly. -#' @param subset,weights,na.action Same as \code{\link[stats]{glm}}, +#' @param subset,weights,na.action Same as \code{\link[stats]{glm}}, #' but rarely specified. -#' @param ... Further arguments passed to \code{\link[rstan:stanmodel-method-sampling]{sampling}} (e.g. +#' @param ... Further arguments passed to \code{\link[rstan:stanmodel-method-sampling]{sampling}} (e.g. #' \code{iter}, \code{chains}, \code{cores}, etc.) or to #' \code{\link[rstan:stanmodel-method-vb]{vb}} (if \code{algorithm} is \code{"meanfield"} or #' \code{"fullrank"}). #' @param prior_covariance Cannot be \code{NULL}; see \code{\link{decov}} for #' more information about the default arguments. #' -#' @details The \code{stan_gamm4} function is similar in syntax to -#' \code{\link[gamm4]{gamm4}} in the \pkg{gamm4} package. But rather than performing +#' @details The \code{stan_gamm4} function is similar in syntax to +#' \code{\link[gamm4]{gamm4}} in the \pkg{gamm4} package. But rather than performing #' (restricted) maximum likelihood estimation with the \pkg{lme4} package, -#' the \code{stan_gamm4} function utilizes MCMC to perform Bayesian -#' estimation. The Bayesian model adds priors on the common regression -#' coefficients (in the same way as \code{\link{stan_glm}}), priors on the +#' the \code{stan_gamm4} function utilizes MCMC to perform Bayesian +#' estimation. The Bayesian model adds priors on the common regression +#' coefficients (in the same way as \code{\link{stan_glm}}), priors on the #' standard deviations of the smooth terms, and a prior on the decomposition -#' of the covariance matrices of any group-specific parameters (as in +#' of the covariance matrices of any group-specific parameters (as in #' \code{\link{stan_glmer}}). Estimating these models via MCMC avoids #' the optimization issues that often crop up with GAMMs and provides better -#' estimates for the uncertainty in the parameter estimates. -#' +#' estimates for the uncertainty in the parameter estimates. +#' #' See \code{\link[gamm4]{gamm4}} for more information about the model #' specicification and \code{\link{priors}} for more information about the #' priors on the main coefficients. The \code{formula} should include at least #' one smooth term, which can be specified in any way that is supported by the -#' \code{\link[mgcv]{jagam}} function in the \pkg{mgcv} package. The +#' \code{\link[mgcv]{jagam}} function in the \pkg{mgcv} package. The #' \code{prior_smooth} argument should be used to specify a prior on the unknown #' standard deviations that govern how smooth the smooth function is. The #' \code{prior_covariance} argument can be used to specify the prior on the @@ -77,30 +77,30 @@ #' group-specific terms to implement the departure from linearity in the smooth #' terms, but that is not the case for \code{stan_gamm4} where the group-specific #' terms are exactly the same as in \code{\link{stan_glmer}}. -#' +#' #' The \code{plot_nonlinear} function creates a ggplot object with one facet for #' each smooth function specified in the call to \code{stan_gamm4} in the case -#' where all smooths are univariate. A subset of the smooth functions can be +#' where all smooths are univariate. A subset of the smooth functions can be #' specified using the \code{smooths} argument, which is necessary to plot a #' bivariate smooth or to exclude the bivariate smooth and plot the univariate -#' ones. In the bivariate case, a plot is produced using +#' ones. In the bivariate case, a plot is produced using #' \code{\link[ggplot2]{geom_contour}}. In the univariate case, the resulting -#' plot is conceptually similar to \code{\link[mgcv]{plot.gam}} except the -#' outer lines here demark the edges of posterior uncertainty intervals +#' plot is conceptually similar to \code{\link[mgcv]{plot.gam}} except the +#' outer lines here demark the edges of posterior uncertainty intervals #' (credible intervals) rather than confidence intervals and the inner line #' is the posterior median of the function rather than the function implied -#' by a point estimate. To change the colors used in the plot see +#' by a point estimate. To change the colors used in the plot see #' \code{\link[bayesplot:bayesplot-colors]{color_scheme_set}}. -#' -#' @references -#' Crainiceanu, C., Ruppert D., and Wand, M. (2005). Bayesian analysis for +#' +#' @references +#' Crainiceanu, C., Ruppert D., and Wand, M. (2005). Bayesian analysis for #' penalized spline regression using WinBUGS. \emph{Journal of Statistical -#' Software}. \strong{14}(14), 1--22. +#' Software}. \strong{14}(14), 1--22. #' \url{https://www.jstatsoft.org/article/view/v014i14} -#' +#' #' @seealso The vignette for \code{stan_glmer}, which also discusses #' \code{stan_gamm4}. \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' # from example(gamm4, package = "gamm4"), prefixing gamm4() call with stan_ @@ -110,7 +110,7 @@ #' dat$fac <- fac <- as.factor(sample(1:20, 400, replace = TRUE)) #' dat$y <- dat$y + model.matrix(~ fac - 1) %*% rnorm(20) * .5 #' -#' br <- stan_gamm4(y ~ s(x0) + x1 + s(x2), data = dat, random = ~ (1 | fac), +#' br <- stan_gamm4(y ~ s(x0) + x1 + s(x2), data = dat, random = ~ (1 | fac), #' chains = 1, iter = 500) # for example speed #' print(br) #' plot_nonlinear(br) @@ -118,162 +118,235 @@ #' } #' } stan_gamm4 <- - function(formula, - random = NULL, - family = gaussian(), - data, - weights = NULL, - subset = NULL, - na.action, - knots = NULL, - drop.unused.levels = TRUE, - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_smooth = exponential(autoscale = FALSE), - prior_aux = exponential(autoscale=TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE) { - - data <- validate_data(data, if_missing = list()) - family <- validate_family(family) - - if (length(mgcv::interpret.gam(formula)$smooth.spec) == 0) { - stop("Formula must have at least one smooth term to use stan_gamm4.", call. = FALSE) - } - - if (!is.null(random)) { - fake.formula <- as.character(mgcv::interpret.gam(formula)$fake.formula) - form <- paste(fake.formula[2], fake.formula[1], fake.formula[3], - "+", random[2], collapse = " ") - glmod <- lme4::glFormula(as.formula(form), data, family = gaussian, - subset, weights, na.action, - control = make_glmerControl( - ignore_x_scale = prior$autoscale %ORifNULL% FALSE - ) - ) - data <- glmod$fr - weights <- validate_weights(glmod$fr$weights) - } - else { - weights <- validate_weights(weights) - glmod <- NULL - } - - if (family$family == "binomial") { - data$temp_y <- rep(1, NROW(data)) # work around jagam bug - temp_formula <- update(formula, temp_y ~ .) - jd <- mgcv::jagam(formula = temp_formula, family = gaussian(), data = data, - file = tempfile(fileext = ".jags"), weights = NULL, - na.action = na.action, offset = NULL, knots = knots, - drop.unused.levels = drop.unused.levels, diagonalize = TRUE) - + function( + formula, + random = NULL, + family = gaussian(), + data, + weights = NULL, + subset = NULL, + na.action, + knots = NULL, + drop.unused.levels = TRUE, + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_smooth = exponential(autoscale = FALSE), + prior_aux = exponential(autoscale = TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE + ) { + data <- validate_data(data, if_missing = list()) + family <- validate_family(family) + + if (length(mgcv::interpret.gam(formula)$smooth.spec) == 0) { + stop( + "Formula must have at least one smooth term to use stan_gamm4.", + call. = FALSE + ) + } + if (!is.null(random)) { - y <- data[, as.character(formula[2L])] + fake.formula <- as.character(mgcv::interpret.gam(formula)$fake.formula) + form <- paste( + fake.formula[2], + fake.formula[1], + fake.formula[3], + "+", + random[2], + collapse = " " + ) + glmod <- lme4::glFormula( + as.formula(form), + data, + family = gaussian, + subset, + weights, + na.action, + control = make_glmerControl( + ignore_x_scale = prior$autoscale %ORifNULL% FALSE + ) + ) + data <- glmod$fr + weights <- validate_weights(glmod$fr$weights) } else { - y <- eval(formula[[2L]], data) + weights <- validate_weights(weights) + glmod <- NULL } - - if (binom_y_prop(y, family, weights)) { - y1 <- as.integer(as.vector(y) * weights) - y <- cbind(y1, y0 = weights - y1) - weights <- double(0) + + if (family$family == "binomial") { + data$temp_y <- rep(1, NROW(data)) # work around jagam bug + temp_formula <- update(formula, temp_y ~ .) + jd <- mgcv::jagam( + formula = temp_formula, + family = gaussian(), + data = data, + file = tempfile(fileext = ".jags"), + weights = NULL, + na.action = na.action, + offset = NULL, + knots = knots, + drop.unused.levels = drop.unused.levels, + diagonalize = TRUE + ) + + if (!is.null(random)) { + y <- data[, as.character(formula[2L])] + } else { + y <- eval(formula[[2L]], data) + } + + if (binom_y_prop(y, family, weights)) { + y1 <- as.integer(as.vector(y) * weights) + y <- cbind(y1, y0 = weights - y1) + weights <- double(0) + } + } else { + jd <- mgcv::jagam( + formula = formula, + family = gaussian(), + data = data, + file = tempfile(fileext = ".jags"), + weights = NULL, + na.action = na.action, + offset = NULL, + knots = knots, + drop.unused.levels = drop.unused.levels, + diagonalize = TRUE + ) + y <- jd$jags.data$y } - } else { - jd <- mgcv::jagam(formula = formula, family = gaussian(), data = data, - file = tempfile(fileext = ".jags"), weights = NULL, - na.action = na.action, offset = NULL, knots = knots, - drop.unused.levels = drop.unused.levels, diagonalize = TRUE) - y <- jd$jags.data$y - } - # there is no offset allowed by gamm4::gamm4 - offset <- validate_offset(as.vector(model.offset(jd$pregam$model)), y = y) - X <- jd$jags.data$X - mark <- which(colnames(X) != "") - colnames(X) <- colnames(jd$pregam$X) <- jd$pregam$term.names - S <- lapply(jd$pregam$smooth, FUN = function(s) { - ranks <- s$rank - start <- s$first.para - out <- list() - for (r in seq_along(ranks)) { - end <- start + ranks[r] - 1L - out[[r]] <- X[,start:end, drop = FALSE] - start <- end + 1L + # there is no offset allowed by gamm4::gamm4 + offset <- validate_offset(as.vector(model.offset(jd$pregam$model)), y = y) + X <- jd$jags.data$X + mark <- which(colnames(X) != "") + colnames(X) <- colnames(jd$pregam$X) <- jd$pregam$term.names + S <- lapply(jd$pregam$smooth, FUN = function(s) { + ranks <- s$rank + start <- s$first.para + out <- list() + for (r in seq_along(ranks)) { + end <- start + ranks[r] - 1L + out[[r]] <- X[, start:end, drop = FALSE] + start <- end + 1L + } + return(out) + }) + if (any(sapply(S, length) > 1)) { + S <- unlist(S, recursive = FALSE) } + names(S) <- names(jd$pregam$sp) + X <- X[, mark, drop = FALSE] + + for (s in seq_along(S)) { + # sometimes elements of S are lists themselves that need to be unpacked + # before passing to stan_glm.fit (https://github.com/stan-dev/rstanarm/issues/362) + if (is.list(S[[s]])) { + S[[s]] <- do.call(cbind, S[[s]]) + } + } + X <- c(list(X), S) + + if (is.null(prior)) { + prior <- list() + } + if (is.null(prior_intercept)) { + prior_intercept <- list() + } + if (is.null(prior_aux)) { + prior_aux <- list() + } + if (is.null(prior_smooth)) { + prior_smooth <- list() + } + + if (is.null(random)) { + group <- list() + prior_covariance <- list() + } else { + group <- glmod$reTrms + group$decov <- prior_covariance + } + algorithm <- match.arg(algorithm) + + stanfit <- stan_glm.fit( + x = X, + y = y, + weights = weights, + offset = offset, + family = family, + prior = prior, + prior_intercept = prior_intercept, + prior_aux = prior_aux, + prior_smooth = prior_smooth, + prior_PD = prior_PD, + algorithm = algorithm, + adapt_delta = adapt_delta, + group = group, + QR = QR, + ... + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } + if (family$family == "Beta regression") { + family$family <- "beta" + } + X <- do.call(cbind, args = X) + if (is.null(random)) { + Z <- Matrix::Matrix(nrow = NROW(y), ncol = 0, sparse = TRUE) + } else { + Z <- pad_reTrms( + Ztlist = group$Ztlist, + cnms = group$cnms, + flist = group$flist + )$Z + colnames(Z) <- b_names(names(stanfit), value = TRUE) + } + XZ <- cbind(X, Z) + + # make jam object with point estimates, see ?mgcv::sim2jam + mat <- as.matrix(stanfit) + mark <- 1:ncol(X) + jd$pregam$Vp <- cov(mat[, mark, drop = FALSE]) + jd$pregam$coefficients <- colMeans(mat[, mark, drop = FALSE]) + jd$pregam$sig2 <- if ("sigma" %in% colnames(mat)) { + mean(mat[, "sigma"]) + } else { + 1 + } + eta <- X %*% t(mat[, mark, drop = FALSE]) + mu <- rowMeans(family$linkinv(eta)) + eta <- rowMeans(eta) + w <- as.numeric(jd$pregam$w * family$mu.eta(eta)^2 / family$variance(mu)) + XWX <- t(X) %*% (w * X) + jd$pregam$edf <- rowSums(jd$pregam$Vp * t(XWX)) / jd$pregam$sig2 + class(jd$pregam) <- c("jam", "gam") + fit <- nlist( + stanfit, + family, + formula, + offset, + weights, + x = XZ, + y = y, + data, + terms = jd$pregam$terms, + model = if (is.null(random)) jd$pregam$model else glmod$fr, + call = match.call(expand.dots = TRUE), + algorithm, + glmod = glmod, + stan_function = "stan_gamm4" + ) + out <- stanreg(fit) + out$jam <- jd$pregam + class(out) <- c(class(out), "gamm4", if (!is.null(glmod)) "lmerMod") return(out) - }) - if (any(sapply(S, length) > 1)) S <- unlist(S, recursive = FALSE) - names(S) <- names(jd$pregam$sp) - X <- X[,mark, drop = FALSE] - - for (s in seq_along(S)) { - # sometimes elements of S are lists themselves that need to be unpacked - # before passing to stan_glm.fit (https://github.com/stan-dev/rstanarm/issues/362) - if (is.list(S[[s]])) - S[[s]] <- do.call(cbind, S[[s]]) - } - X <- c(list(X), S) - - if (is.null(prior)) prior <- list() - if (is.null(prior_intercept)) prior_intercept <- list() - if (is.null(prior_aux)) prior_aux <- list() - if (is.null(prior_smooth)) prior_smooth <- list() - - if (is.null(random)) { - group <- list() - prior_covariance <- list() - } - else { - group <- glmod$reTrms - group$decov <- prior_covariance - } - algorithm <- match.arg(algorithm) - - stanfit <- stan_glm.fit(x = X, y = y, weights = weights, - offset = offset, family = family, - prior = prior, prior_intercept = prior_intercept, - prior_aux = prior_aux, prior_smooth = prior_smooth, - prior_PD = prior_PD, algorithm = algorithm, - adapt_delta = adapt_delta, group = group, QR = QR, ...) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) - if (family$family == "Beta regression") family$family <- "beta" - X <- do.call(cbind, args = X) - if (is.null(random)) Z <- Matrix::Matrix(nrow = NROW(y), ncol = 0, sparse = TRUE) - else { - Z <- pad_reTrms(Ztlist = group$Ztlist, cnms = group$cnms, - flist = group$flist)$Z - colnames(Z) <- b_names(names(stanfit), value = TRUE) } - XZ <- cbind(X, Z) - - # make jam object with point estimates, see ?mgcv::sim2jam - mat <- as.matrix(stanfit) - mark <- 1:ncol(X) - jd$pregam$Vp <- cov(mat[,mark, drop = FALSE]) - jd$pregam$coefficients <- colMeans(mat[,mark, drop = FALSE]) - jd$pregam$sig2 <- if ("sigma" %in% colnames(mat)) mean(mat[,"sigma"]) else 1 - eta <- X %*% t(mat[,mark,drop = FALSE]) - mu <- rowMeans(family$linkinv(eta)) - eta <- rowMeans(eta) - w <- as.numeric(jd$pregam$w * family$mu.eta(eta) ^ 2 / family$variance(mu)) - XWX <- t(X) %*% (w * X) - jd$pregam$edf <- rowSums(jd$pregam$Vp * t(XWX)) / jd$pregam$sig2 - class(jd$pregam) <- c("jam", "gam") - fit <- nlist(stanfit, family, formula, offset, weights, - x = XZ, y = y, data, terms = jd$pregam$terms, - model = if (is.null(random)) jd$pregam$model else glmod$fr, - call = match.call(expand.dots = TRUE), - algorithm, glmod = glmod, - stan_function = "stan_gamm4") - out <- stanreg(fit) - out$jam <- jd$pregam - class(out) <- c(class(out), "gamm4", if (!is.null(glmod)) "lmerMod") - return(out) -} #' @rdname stan_gamm4 #' @export @@ -283,64 +356,83 @@ stan_gamm4 <- #' include all smooth terms. #' @param prob For univarite smooths, a scalar between 0 and 1 governing the #' width of the uncertainty interval. -#' @param facet_args An optional named list of arguments passed to +#' @param facet_args An optional named list of arguments passed to #' \code{\link[ggplot2]{facet_wrap}} (other than the \code{facets} argument). -#' @param alpha,size For univariate smooths, passed to +#' @param alpha,size For univariate smooths, passed to #' \code{\link[ggplot2]{geom_ribbon}}. For bivariate smooths, \code{size/2} is #' passed to \code{\link[ggplot2]{geom_contour}}. -#' +#' #' @return \code{plot_nonlinear} returns a ggplot object. -#' +#' #' @importFrom ggplot2 aes_ aes_string facet_wrap ggplot geom_contour geom_line geom_ribbon labs scale_color_gradient2 -#' -plot_nonlinear <- function(x, smooths, ..., - prob = 0.9, facet_args = list(), - alpha = 1, size = 0.75) { +#' +plot_nonlinear <- function( + x, + smooths, + ..., + prob = 0.9, + facet_args = list(), + alpha = 1, + size = 0.75 +) { validate_stanreg_object(x) - if (!is(x, "gamm4")) + if (!is(x, "gamm4")) { stop("Plot only available for models fit using the stan_gamm4 function.") + } on.exit(message("try plot(x$jam) instead")) scheme <- bayesplot::color_scheme_get() - + XZ <- x$x - XZ <- XZ[,!grepl("_NEW_", colnames(XZ), fixed = TRUE)] + XZ <- XZ[, !grepl("_NEW_", colnames(XZ), fixed = TRUE)] labels <- sapply(x$jam$smooth, "[[", "label") xnames <- sapply(x$jam$smooth, "[[", "vn") names(x$jam$smooth) <- labels names(xnames) <- labels fs <- sapply(x$jam$smooth, FUN = "inherits", what = "fs.interaction") - + if (!missing(smooths)) { found <- smooths %in% labels if (all(!found)) { - stop("All specified terms are invalid. Valid terms are: ", - paste(grep(",", labels, fixed = TRUE, value = TRUE, invert = TRUE), - collapse = ", ")) + stop( + "All specified terms are invalid. Valid terms are: ", + paste( + grep(",", labels, fixed = TRUE, value = TRUE, invert = TRUE), + collapse = ", " + ) + ) } else if (any(!found)) { - warning("The following specified terms were not found and ignored: ", - paste(smooths[!found], collapse = ", ")) + warning( + "The following specified terms were not found and ignored: ", + paste(smooths[!found], collapse = ", ") + ) } labels <- smooths[found] fs <- fs[found] if (!is.matrix(xnames)) xnames <- xnames[found] + } else { + smooths <- 1:length(labels) } - else smooths <- 1:length(labels) - + B <- as.matrix(x)[, colnames(XZ), drop = FALSE] original <- x$jam$model - + bivariate <- any(grepl(",", labels, fixed = TRUE)) if (bivariate && !any(fs)) { if (length(labels) > 1) { on.exit(NULL) - stop("Multivariate functions can only be plotted one at a time; specify 'smooths'.") + stop( + "Multivariate functions can only be plotted one at a time; specify 'smooths'." + ) } - if (length(xnames) > 2) + if (length(xnames) > 2) { stop("Only univariate and bivariate functions can be plotted currently.") + } xrange <- range(original[, xnames[1]]) yrange <- range(original[, xnames[2]]) - xz <- expand.grid(seq(from = xrange[1], to = xrange[2], length.out = 100), - seq(from = yrange[1], to = yrange[2], length.out = 100)) + xz <- expand.grid( + seq(from = xrange[1], to = xrange[2], length.out = 100), + seq(from = yrange[1], to = yrange[2], length.out = 100) + ) colnames(xz) <- xnames[1:2] plot_data <- data.frame(x = xz[, 1], y = xz[, 2]) nd <- original @@ -354,45 +446,47 @@ plot_nonlinear <- function(x, smooths, ..., xz <- XZ[, grepl(labels, colnames(XZ), fixed = TRUE), drop = FALSE] plot_data$z <- apply(linear_predictor.matrix(b, xz), 2, FUN = median) return( - ggplot(plot_data, aes_(x = ~x, y = ~y, z = ~z)) + - geom_contour(aes_string(color = "..level.."), size = size/2) + - labs(x = xnames[1], y = xnames[2]) + - scale_color_gradient2(low = scheme[[1]], - mid = scheme[[3]], - high = scheme[[6]]) + - bayesplot::theme_default() + ggplot(plot_data, aes_(x = ~x, y = ~y, z = ~z)) + + geom_contour(aes_string(color = "..level.."), size = size / 2) + + labs(x = xnames[1], y = xnames[2]) + + scale_color_gradient2( + low = scheme[[1]], + mid = scheme[[3]], + high = scheme[[6]] + ) + + bayesplot::theme_default() ) } - + df_list <- lapply(x$jam$smooth[smooths], FUN = function(s) { incl <- s$first.para:s$last.para b <- B[, incl, drop = FALSE] - if (inherits(s, "fs.interaction")) { # see mgcv:::plot.fs.interaction - xx <- original[,s$base$term] - fac <- original[,s$fterm] + if (inherits(s, "fs.interaction")) { + # see mgcv:::plot.fs.interaction + xx <- original[, s$base$term] + fac <- original[, s$fterm] out <- by(data.frame(fac, xx), list(fac), FUN = function(df) { - df <- df[order(df[,2]),] + df <- df[order(df[, 2]), ] names(df) <- c(s$fterm, s$base$term) xz <- mgcv::PredictMat(s, df) f <- linear_predictor.matrix(b, xz) data.frame( - predictor = df[,2], - lower = apply(f, 2, quantile, probs = (1 - prob) / 2), - upper = apply(f, 2, quantile, probs = prob + (1 - prob) / 2), + predictor = df[, 2], + lower = apply(f, 2, quantile, probs = (1 - prob) / 2), + upper = apply(f, 2, quantile, probs = prob + (1 - prob) / 2), middle = apply(f, 2, median), - term = paste(s$label, df[,1], sep = ".") + term = paste(s$label, df[, 1], sep = ".") ) }) do.call(rbind, args = out) - } - else { + } else { xz <- XZ[, incl, drop = FALSE] x <- original[, s$term] ord <- order(x) x <- x[ord] - xz <- xz[ord, , drop=FALSE] + xz <- xz[ord, , drop = FALSE] if (!is.null(s$by.level)) { - fac <- original[,s$by][ord] + fac <- original[, s$by][ord] mark <- fac == s$by.level x <- x[mark] xz <- xz[mark, , drop = FALSE] @@ -400,29 +494,39 @@ plot_nonlinear <- function(x, smooths, ..., f <- linear_predictor.matrix(b, xz) data.frame( predictor = x, - lower = apply(f, 2, quantile, probs = (1 - prob) / 2), - upper = apply(f, 2, quantile, probs = prob + (1 - prob) / 2), + lower = apply(f, 2, quantile, probs = (1 - prob) / 2), + upper = apply(f, 2, quantile, probs = prob + (1 - prob) / 2), middle = apply(f, 2, median), term = s$label ) } }) plot_data <- do.call(rbind, df_list) - - facet_args[["facets"]] <- ~ term - if (is.null(facet_args[["scales"]])) + + facet_args[["facets"]] <- ~term + if (is.null(facet_args[["scales"]])) { facet_args[["scales"]] <- "free" - if (is.null(facet_args[["strip.position"]])) + } + if (is.null(facet_args[["strip.position"]])) { facet_args[["strip.position"]] <- "left" + } - on.exit(NULL) - ggplot(plot_data, aes_(x = ~ predictor)) + - geom_ribbon(aes_(ymin = ~ lower, ymax = ~ upper), - fill = scheme[[1]], color = scheme[[2]], - alpha = alpha, size = size) + - geom_line(aes_(y = ~ middle), color = scheme[[5]], - size = 0.75 * size, lineend = "round") + - labs(y = NULL) + - do.call(facet_wrap, facet_args) + + on.exit(NULL) + ggplot(plot_data, aes_(x = ~predictor)) + + geom_ribbon( + aes_(ymin = ~lower, ymax = ~upper), + fill = scheme[[1]], + color = scheme[[2]], + alpha = alpha, + size = size + ) + + geom_line( + aes_(y = ~middle), + color = scheme[[5]], + size = 0.75 * size, + lineend = "round" + ) + + labs(y = NULL) + + do.call(facet_wrap, facet_args) + bayesplot::theme_default() } diff --git a/R/stan_glm.R b/R/stan_glm.R index 8693b093c..3292a6c0c 100644 --- a/R/stan_glm.R +++ b/R/stan_glm.R @@ -1,23 +1,23 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian generalized linear models via Stan #' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' Generalized linear modeling with optional prior distributions for the #' coefficients, intercept, and auxiliary parameters. #' @@ -25,7 +25,7 @@ #' @templateVar armRef (Ch. 3-6) #' @templateVar pkg stats #' @templateVar pkgfun glm -#' @templateVar sameargs model,offset,weights +#' @templateVar sameargs model,offset,weights #' @templateVar rareargs na.action,contrasts #' @templateVar fun stan_glm, stan_glm.nb #' @templateVar fitfun stan_glm.fit @@ -46,7 +46,7 @@ #' @template args-sparse #' @template reference-gelman-hill #' @template reference-muth -#' +#' #' @param family Same as \code{\link[stats]{glm}}, except negative binomial GLMs #' are also possible using the \code{\link{neg_binomial_2}} family object. #' @param y In \code{stan_glm}, logical scalar indicating whether to @@ -70,35 +70,35 @@ #' implausible then there may be something wrong, e.g., severe model #' misspecification, problems with the data and/or priors, computational #' issues, etc. -#' -#' @details The \code{stan_glm} function is similar in syntax to -#' \code{\link[stats]{glm}} but rather than performing maximum likelihood -#' estimation of generalized linear models, full Bayesian estimation is +#' +#' @details The \code{stan_glm} function is similar in syntax to +#' \code{\link[stats]{glm}} but rather than performing maximum likelihood +#' estimation of generalized linear models, full Bayesian estimation is #' performed (if \code{algorithm} is \code{"sampling"}) via MCMC. The Bayesian #' model adds priors (independent by default) on the coefficients of the GLM. #' The \code{stan_glm} function calls the workhorse \code{stan_glm.fit} #' function, but it is also possible to call the latter directly. -#' -#' The \code{stan_glm.nb} function, which takes the extra argument -#' \code{link}, is a wrapper for \code{stan_glm} with \code{family = +#' +#' The \code{stan_glm.nb} function, which takes the extra argument +#' \code{link}, is a wrapper for \code{stan_glm} with \code{family = #' \link{neg_binomial_2}(link)}. -#' +#' #' @seealso The various vignettes for \code{stan_glm} at #' \url{https://mc-stan.org/rstanarm/articles/}. -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' ### Linear regression #' mtcars$mpg10 <- mtcars$mpg / 10 #' fit <- stan_glm( -#' mpg10 ~ wt + cyl + am, -#' data = mtcars, +#' mpg10 ~ wt + cyl + am, +#' data = mtcars, #' QR = TRUE, #' # for speed of example only (default is "sampling") #' algorithm = "fullrank", -#' refresh = 0 -#' ) -#' +#' refresh = 0 +#' ) +#' #' plot(fit, prob = 0.5) #' plot(fit, prob = 0.5, pars = "beta") #' plot(fit, "hist", pars = "sigma") @@ -107,237 +107,262 @@ #' head(wells) #' wells$dist100 <- wells$dist / 100 #' fit2 <- stan_glm( -#' switch ~ dist100 + arsenic, -#' data = wells, -#' family = binomial(link = "logit"), +#' switch ~ dist100 + arsenic, +#' data = wells, +#' family = binomial(link = "logit"), #' prior_intercept = normal(0, 10), #' QR = TRUE, #' refresh = 0, #' # for speed of example only -#' chains = 2, iter = 200 +#' chains = 2, iter = 200 #' ) #' print(fit2) #' prior_summary(fit2) -#' +#' #' # ?bayesplot::mcmc_areas #' plot(fit2, plotfun = "areas", prob = 0.9, #' pars = c("(Intercept)", "arsenic")) -#' +#' #' # ?bayesplot::ppc_error_binned -#' pp_check(fit2, plotfun = "error_binned") -#' -#' -#' ### Poisson regression (example from help("glm")) +#' pp_check(fit2, plotfun = "error_binned") +#' +#' +#' ### Poisson regression (example from help("glm")) #' count_data <- data.frame( #' counts = c(18,17,15,20,10,20,25,13,12), #' outcome = gl(3,1,9), #' treatment = gl(3,3) #' ) #' fit3 <- stan_glm( -#' counts ~ outcome + treatment, -#' data = count_data, +#' counts ~ outcome + treatment, +#' data = count_data, #' family = poisson(link="log"), #' prior = normal(0, 2), #' refresh = 0, #' # for speed of example only -#' chains = 2, iter = 250 -#' ) +#' chains = 2, iter = 250 +#' ) #' print(fit3) -#' +#' #' bayesplot::color_scheme_set("viridis") #' plot(fit3) #' plot(fit3, regex_pars = c("outcome", "treatment")) #' plot(fit3, plotfun = "combo", regex_pars = "treatment") # ?bayesplot::mcmc_combo #' posterior_vs_prior(fit3, regex_pars = c("outcome", "treatment")) -#' +#' #' ### Gamma regression (example from help("glm")) #' clotting <- data.frame(log_u = log(c(5,10,15,20,30,40,60,80,100)), #' lot1 = c(118,58,42,35,27,25,21,19,18), #' lot2 = c(69,35,26,21,18,16,13,12,12)) #' fit4 <- stan_glm( -#' lot1 ~ log_u, -#' data = clotting, +#' lot1 ~ log_u, +#' data = clotting, #' family = Gamma(link="log"), #' iter = 500, # for speed of example only #' refresh = 0 -#' ) +#' ) #' print(fit4, digits = 2) -#' +#' #' fit5 <- update(fit4, formula = lot2 ~ log_u) -#' +#' #' # ?bayesplot::ppc_dens_overlay #' bayesplot::bayesplot_grid( -#' pp_check(fit4, seed = 123), +#' pp_check(fit4, seed = 123), #' pp_check(fit5, seed = 123), #' titles = c("lot1", "lot2") -#' ) -#' -#' +#' ) +#' +#' #' ### Negative binomial regression #' fit6 <- stan_glm.nb( -#' Days ~ Sex/(Age + Eth*Lrn), -#' data = MASS::quine, -#' link = "log", +#' Days ~ Sex/(Age + Eth*Lrn), +#' data = MASS::quine, +#' link = "log", #' prior_aux = exponential(1.5, autoscale=TRUE), #' chains = 2, iter = 200, # for speed of example only #' refresh = 0 -#' ) -#' +#' ) +#' #' prior_summary(fit6) #' bayesplot::color_scheme_set("brightblue") #' plot(fit6) #' pp_check(fit6, plotfun = "hist", nreps = 5) # ?bayesplot::ppc_hist -#' +#' #' # 80% interval of estimated reciprocal_dispersion parameter #' posterior_interval(fit6, pars = "reciprocal_dispersion", prob = 0.8) #' plot(fit6, "areas", pars = "reciprocal_dispersion", prob = 0.8) #' } #' } stan_glm <- - function(formula, - family = gaussian(), - data, - weights, - subset, - na.action = NULL, - offset = NULL, - model = TRUE, - x = FALSE, - y = TRUE, - contrasts = NULL, - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale=TRUE), - prior_PD = FALSE, - algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), - mean_PPD = algorithm != "optimizing" && !prior_PD, - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE) { - - algorithm <- match.arg(algorithm) - family <- validate_family(family) - validate_glm_formula(formula) - data <- validate_data(data, if_missing = environment(formula)) - - call <- match.call(expand.dots = TRUE) - mf <- match.call(expand.dots = FALSE) - m <- match(c("formula", "subset", "weights", "na.action", "offset"), - table = names(mf), nomatch = 0L) - mf <- mf[c(1L, m)] - mf$data <- data - mf$drop.unused.levels <- TRUE - mf[[1L]] <- as.name("model.frame") - mf <- eval(mf, parent.frame()) - mf <- check_constant_vars(mf) - mt <- attr(mf, "terms") - Y <- array1D_check(model.response(mf, type = "any")) - if (is.empty.model(mt)) - stop("No intercept or predictors specified.", call. = FALSE) - X <- model.matrix(mt, mf, contrasts) - contrasts <- attr(X, "contrasts") - weights <- validate_weights(as.vector(model.weights(mf))) - offset <- validate_offset(as.vector(model.offset(mf)), y = Y) - if (binom_y_prop(Y, family, weights)) { - y1 <- as.integer(as.vector(Y) * weights) - Y <- cbind(y1, y0 = weights - y1) - weights <- double(0) - } - - if (prior_PD) { - # can result in errors (e.g. from poisson) if draws from prior are weird - mean_PPD <- FALSE - } + function( + formula, + family = gaussian(), + data, + weights, + subset, + na.action = NULL, + offset = NULL, + model = TRUE, + x = FALSE, + y = TRUE, + contrasts = NULL, + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale = TRUE), + prior_PD = FALSE, + algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), + mean_PPD = algorithm != "optimizing" && !prior_PD, + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE + ) { + algorithm <- match.arg(algorithm) + family <- validate_family(family) + validate_glm_formula(formula) + data <- validate_data(data, if_missing = environment(formula)) - stanfit <- stan_glm.fit( - x = X, - y = Y, - weights = weights, - offset = offset, - family = family, - prior = prior, - prior_intercept = prior_intercept, - prior_aux = prior_aux, - prior_PD = prior_PD, - algorithm = algorithm, - mean_PPD = mean_PPD, - adapt_delta = adapt_delta, - QR = QR, - sparse = sparse, - ... - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) - if (family$family == "Beta regression") { - family$family <- "beta" - } + call <- match.call(expand.dots = TRUE) + mf <- match.call(expand.dots = FALSE) + m <- match( + c("formula", "subset", "weights", "na.action", "offset"), + table = names(mf), + nomatch = 0L + ) + mf <- mf[c(1L, m)] + mf$data <- data + mf$drop.unused.levels <- TRUE + mf[[1L]] <- as.name("model.frame") + mf <- eval(mf, parent.frame()) + mf <- check_constant_vars(mf) + mt <- attr(mf, "terms") + Y <- array1D_check(model.response(mf, type = "any")) + if (is.empty.model(mt)) { + stop("No intercept or predictors specified.", call. = FALSE) + } + X <- model.matrix(mt, mf, contrasts) + contrasts <- attr(X, "contrasts") + weights <- validate_weights(as.vector(model.weights(mf))) + offset <- validate_offset(as.vector(model.offset(mf)), y = Y) + if (binom_y_prop(Y, family, weights)) { + y1 <- as.integer(as.vector(Y) * weights) + Y <- cbind(y1, y0 = weights - y1) + weights <- double(0) + } + + if (prior_PD) { + # can result in errors (e.g. from poisson) if draws from prior are weird + mean_PPD <- FALSE + } + + stanfit <- stan_glm.fit( + x = X, + y = Y, + weights = weights, + offset = offset, + family = family, + prior = prior, + prior_intercept = prior_intercept, + prior_aux = prior_aux, + prior_PD = prior_PD, + algorithm = algorithm, + mean_PPD = mean_PPD, + adapt_delta = adapt_delta, + QR = QR, + sparse = sparse, + ... + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } + if (family$family == "Beta regression") { + family$family <- "beta" + } + + sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) + X <- X[, !sel, drop = FALSE] - sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) - X <- X[ , !sel, drop = FALSE] + fit <- nlist( + stanfit, + algorithm, + family, + formula, + data, + offset, + weights, + x = X, + y = Y, + model = mf, + terms = mt, + call, + na.action = attr(mf, "na.action"), + contrasts = contrasts, + stan_function = "stan_glm" + ) - fit <- nlist(stanfit, algorithm, family, formula, data, offset, weights, - x = X, y = Y, model = mf, terms = mt, call, - na.action = attr(mf, "na.action"), - contrasts = contrasts, - stan_function = "stan_glm") - - out <- stanreg(fit) - if (algorithm == "optimizing") { - out$log_p <- stanfit$log_p - out$log_g <- stanfit$log_g - out$psis <- stanfit$psis - out$ir_idx <- stanfit$ir_idx - out$diagnostics <- stanfit$diagnostics + out <- stanreg(fit) + if (algorithm == "optimizing") { + out$log_p <- stanfit$log_p + out$log_g <- stanfit$log_g + out$psis <- stanfit$psis + out$ir_idx <- stanfit$ir_idx + out$diagnostics <- stanfit$diagnostics + } + out$compute_mean_PPD <- mean_PPD + out$xlevels <- .getXlevels(mt, mf) + if (!x) { + out$x <- NULL + } + if (!y) { + out$y <- NULL + } + if (!model) { + out$model <- NULL + } + + return(out) } - out$compute_mean_PPD <- mean_PPD - out$xlevels <- .getXlevels(mt, mf) - if (!x) - out$x <- NULL - if (!y) - out$y <- NULL - if (!model) - out$model <- NULL - - return(out) -} #' @rdname stan_glm #' @export -#' @param link For \code{stan_glm.nb} only, the link function to use. See +#' @param link For \code{stan_glm.nb} only, the link function to use. See #' \code{\link{neg_binomial_2}}. -#' -stan_glm.nb <- - function(formula, - data, - weights, - subset, - na.action = NULL, - offset = NULL, - model = TRUE, - x = FALSE, - y = TRUE, - contrasts = NULL, - link = "log", - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale=TRUE), - prior_PD = FALSE, - algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), - mean_PPD = algorithm != "optimizing", - adapt_delta = NULL, - QR = FALSE) { - - if ("family" %in% names(list(...))) - stop("'family' should not be specified.") - mc <- call <- match.call() - if (!"formula" %in% names(call)) - names(call)[2L] <- "formula" - mc[[1L]] <- quote(stan_glm) - mc$link <- NULL - mc$family <- neg_binomial_2(link = link) - out <- eval(mc, parent.frame()) - out$call <- call - out$stan_function <- "stan_glm.nb" - return(out) -} +#' +stan_glm.nb <- + function( + formula, + data, + weights, + subset, + na.action = NULL, + offset = NULL, + model = TRUE, + x = FALSE, + y = TRUE, + contrasts = NULL, + link = "log", + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale = TRUE), + prior_PD = FALSE, + algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), + mean_PPD = algorithm != "optimizing", + adapt_delta = NULL, + QR = FALSE + ) { + if ("family" %in% names(list(...))) { + stop("'family' should not be specified.") + } + mc <- call <- match.call() + if (!"formula" %in% names(call)) { + names(call)[2L] <- "formula" + } + mc[[1L]] <- quote(stan_glm) + mc$link <- NULL + mc$family <- neg_binomial_2(link = link) + out <- eval(mc, parent.frame()) + out$call <- call + out$stan_function <- "stan_glm.nb" + return(out) + } diff --git a/R/stan_glmer.R b/R/stan_glmer.R index dfa9c27f6..e82211944 100644 --- a/R/stan_glmer.R +++ b/R/stan_glmer.R @@ -1,26 +1,26 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian generalized linear models with group-specific terms via Stan -#' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Bayesian inference for GLMs with group-specific coefficients that have +#' +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' Bayesian inference for GLMs with group-specific coefficients that have #' unknown covariance matrices with flexible priors. -#' +#' #' @export #' @templateVar armRef (Ch. 11-15) #' @templateVar fun stan_glmer, stan_lmer, stan_glmer.nb @@ -39,226 +39,263 @@ #' @template args-sparse #' @template reference-gelman-hill #' @template reference-muth -#' +#' #' @param formula,data Same as for \code{\link[lme4]{glmer}}. \emph{We -#' strongly advise against omitting the \code{data} argument}. Unless -#' \code{data} is specified (and is a data frame) many post-estimation -#' functions (including \code{update}, \code{loo}, \code{kfold}) are not +#' strongly advise against omitting the \code{data} argument}. Unless +#' \code{data} is specified (and is a data frame) many post-estimation +#' functions (including \code{update}, \code{loo}, \code{kfold}) are not #' guaranteed to work properly. #' @param family Same as for \code{\link[lme4]{glmer}} except it is also #' possible to use \code{family=mgcv::betar} to estimate a Beta regression #' with \code{stan_glmer}. #' @param subset,weights,offset Same as \code{\link[stats]{glm}}. -#' @param na.action,contrasts Same as \code{\link[stats]{glm}}, but rarely +#' @param na.action,contrasts Same as \code{\link[stats]{glm}}, but rarely #' specified. -#' @param ... For \code{stan_glmer}, further arguments passed to -#' \code{\link[rstan:stanmodel-method-sampling]{sampling}} (e.g. \code{iter}, \code{chains}, -#' \code{cores}, etc.) or to \code{\link[rstan:stanmodel-method-vb]{vb}} (if \code{algorithm} is -#' \code{"meanfield"} or \code{"fullrank"}). For \code{stan_lmer} and +#' @param ... For \code{stan_glmer}, further arguments passed to +#' \code{\link[rstan:stanmodel-method-sampling]{sampling}} (e.g. \code{iter}, \code{chains}, +#' \code{cores}, etc.) or to \code{\link[rstan:stanmodel-method-vb]{vb}} (if \code{algorithm} is +#' \code{"meanfield"} or \code{"fullrank"}). For \code{stan_lmer} and #' \code{stan_glmer.nb}, \code{...} should also contain all relevant arguments #' to pass to \code{stan_glmer} (except \code{family}). #' -#' @details The \code{stan_glmer} function is similar in syntax to -#' \code{\link[lme4]{glmer}} but rather than performing (restricted) maximum -#' likelihood estimation of generalized linear models, Bayesian estimation is -#' performed via MCMC. The Bayesian model adds priors on the +#' @details The \code{stan_glmer} function is similar in syntax to +#' \code{\link[lme4]{glmer}} but rather than performing (restricted) maximum +#' likelihood estimation of generalized linear models, Bayesian estimation is +#' performed via MCMC. The Bayesian model adds priors on the #' regression coefficients (in the same way as \code{\link{stan_glm}}) and #' priors on the terms of a decomposition of the covariance matrices of the #' group-specific parameters. See \code{\link{priors}} for more information #' about the priors. -#' -#' The \code{stan_lmer} function is equivalent to \code{stan_glmer} with -#' \code{family = gaussian(link = "identity")}. -#' -#' The \code{stan_glmer.nb} function, which takes the extra argument -#' \code{link}, is a wrapper for \code{stan_glmer} with \code{family = +#' +#' The \code{stan_lmer} function is equivalent to \code{stan_glmer} with +#' \code{family = gaussian(link = "identity")}. +#' +#' The \code{stan_glmer.nb} function, which takes the extra argument +#' \code{link}, is a wrapper for \code{stan_glmer} with \code{family = #' \link{neg_binomial_2}(link)}. -#' -#' @return A list with classes \code{stanreg}, \code{glm}, \code{lm}, +#' +#' @return A list with classes \code{stanreg}, \code{glm}, \code{lm}, #' and \code{lmerMod}. The conventions for the parameter names are the #' same as in the lme4 package with the addition that the standard #' deviation of the errors is called \code{sigma} and the variance-covariance #' matrix of the group-specific deviations from the common parameters is #' called \code{Sigma}, even if this variance-covariance matrix only has #' one row and one column (in which case it is just the group-level variance). -#' -#' -#' @seealso The vignette for \code{stan_glmer} and the \emph{Hierarchical +#' +#' +#' @seealso The vignette for \code{stan_glmer} and the \emph{Hierarchical #' Partial Pooling} vignette. \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' # see help(example_model) for details on the model below -#' if (!exists("example_model")) example(example_model) +#' if (!exists("example_model")) example(example_model) #' print(example_model, digits = 1) #' } #' @importFrom lme4 glFormula #' @importFrom Matrix Matrix t -stan_glmer <- - function(formula, - data = NULL, - family = gaussian, - subset, - weights, - na.action = getOption("na.action", "na.omit"), - offset, - contrasts = NULL, - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale=TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE) { - - call <- match.call(expand.dots = TRUE) - mc <- match.call(expand.dots = FALSE) - data <- validate_data(data) #, if_missing = environment(formula)) - family <- validate_family(family) - mc[[1]] <- quote(lme4::glFormula) - mc$control <- make_glmerControl( - ignore_lhs = prior_PD, - ignore_x_scale = prior$autoscale %ORifNULL% FALSE - ) - mc$data <- data - mc$prior <- mc$prior_intercept <- mc$prior_covariance <- mc$prior_aux <- - mc$prior_PD <- mc$algorithm <- mc$scale <- mc$concentration <- mc$shape <- - mc$adapt_delta <- mc$... <- mc$QR <- mc$sparse <- NULL - glmod <- eval(mc, parent.frame()) - X <- glmod$X - if ("b" %in% colnames(X)) { - stop("stan_glmer does not allow the name 'b' for predictor variables.", - call. = FALSE) - } - - if (prior_PD && !has_outcome_variable(formula)) { - y <- NULL - } else { - y <- glmod$fr[, as.character(glmod$formula[2L])] - if (is.matrix(y) && ncol(y) == 1L) { - y <- as.vector(y) +stan_glmer <- + function( + formula, + data = NULL, + family = gaussian, + subset, + weights, + na.action = getOption("na.action", "na.omit"), + offset, + contrasts = NULL, + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale = TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE + ) { + call <- match.call(expand.dots = TRUE) + mc <- match.call(expand.dots = FALSE) + data <- validate_data(data) #, if_missing = environment(formula)) + family <- validate_family(family) + mc[[1]] <- quote(lme4::glFormula) + mc$control <- make_glmerControl( + ignore_lhs = prior_PD, + ignore_x_scale = prior$autoscale %ORifNULL% FALSE + ) + mc$data <- data + mc$prior <- mc$prior_intercept <- mc$prior_covariance <- mc$prior_aux <- + mc$prior_PD <- mc$algorithm <- mc$scale <- mc$concentration <- mc$shape <- + mc$adapt_delta <- mc$... <- mc$QR <- mc$sparse <- NULL + glmod <- eval(mc, parent.frame()) + X <- glmod$X + if ("b" %in% colnames(X)) { + stop( + "stan_glmer does not allow the name 'b' for predictor variables.", + call. = FALSE + ) } - } - offset <- model.offset(glmod$fr) %ORifNULL% double(0) - weights <- validate_weights(as.vector(model.weights(glmod$fr))) - if (binom_y_prop(y, family, weights)) { - y1 <- as.integer(as.vector(y) * weights) - y <- cbind(y1, y0 = weights - y1) - weights <- double(0) - } - - if (is.null(prior_covariance)) - stop("'prior_covariance' can't be NULL.", call. = FALSE) - group <- glmod$reTrms - group$decov <- prior_covariance - algorithm <- match.arg(algorithm) - stanfit <- stan_glm.fit(x = X, y = y, weights = weights, - offset = offset, family = family, - prior = prior, prior_intercept = prior_intercept, - prior_aux = prior_aux, prior_PD = prior_PD, - algorithm = algorithm, adapt_delta = adapt_delta, - group = group, QR = QR, sparse = sparse, - mean_PPD = !prior_PD, - ...) - - add_classes <- "lmerMod" # additional classes to eventually add to stanreg object - if (family$family == "Beta regression") { - add_classes <- c(add_classes, "betareg") - family$family <- "beta" + if (prior_PD && !has_outcome_variable(formula)) { + y <- NULL + } else { + y <- glmod$fr[, as.character(glmod$formula[2L])] + if (is.matrix(y) && ncol(y) == 1L) { + y <- as.vector(y) + } + } + + offset <- model.offset(glmod$fr) %ORifNULL% double(0) + weights <- validate_weights(as.vector(model.weights(glmod$fr))) + if (binom_y_prop(y, family, weights)) { + y1 <- as.integer(as.vector(y) * weights) + y <- cbind(y1, y0 = weights - y1) + weights <- double(0) + } + + if (is.null(prior_covariance)) { + stop("'prior_covariance' can't be NULL.", call. = FALSE) + } + group <- glmod$reTrms + group$decov <- prior_covariance + algorithm <- match.arg(algorithm) + stanfit <- stan_glm.fit( + x = X, + y = y, + weights = weights, + offset = offset, + family = family, + prior = prior, + prior_intercept = prior_intercept, + prior_aux = prior_aux, + prior_PD = prior_PD, + algorithm = algorithm, + adapt_delta = adapt_delta, + group = group, + QR = QR, + sparse = sparse, + mean_PPD = !prior_PD, + ... + ) + + add_classes <- "lmerMod" # additional classes to eventually add to stanreg object + if (family$family == "Beta regression") { + add_classes <- c(add_classes, "betareg") + family$family <- "beta" + } + sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) + X <- X[, !sel, drop = FALSE] + Z <- pad_reTrms( + Ztlist = group$Ztlist, + cnms = group$cnms, + flist = group$flist + )$Z + colnames(Z) <- b_names(names(stanfit), value = TRUE) + + fit <- nlist( + stanfit, + family, + formula, + offset, + weights, + x = cbind(X, Z), + y = y, + data, + call, + terms = NULL, + model = NULL, + na.action = attr(glmod$fr, "na.action"), + contrasts, + algorithm, + glmod, + stan_function = "stan_glmer" + ) + out <- stanreg(fit) + class(out) <- c(class(out), add_classes) + + return(out) } - sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) - X <- X[ , !sel, drop = FALSE] - Z <- pad_reTrms(Ztlist = group$Ztlist, cnms = group$cnms, - flist = group$flist)$Z - colnames(Z) <- b_names(names(stanfit), value = TRUE) - - fit <- nlist(stanfit, family, formula, offset, weights, - x = cbind(X, Z), y = y, data, call, terms = NULL, model = NULL, - na.action = attr(glmod$fr, "na.action"), contrasts, algorithm, glmod, - stan_function = "stan_glmer") - out <- stanreg(fit) - class(out) <- c(class(out), add_classes) - - return(out) -} #' @rdname stan_glmer #' @export -stan_lmer <- - function(formula, - data = NULL, - subset, - weights, - na.action = getOption("na.action", "na.omit"), - offset, - contrasts = NULL, - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale=TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE) { - if ("family" %in% names(list(...))) { - stop( - "'family' should not be specified. ", - "To specify a family use stan_glmer instead of stan_lmer." - ) +stan_lmer <- + function( + formula, + data = NULL, + subset, + weights, + na.action = getOption("na.action", "na.omit"), + offset, + contrasts = NULL, + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale = TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE + ) { + if ("family" %in% names(list(...))) { + stop( + "'family' should not be specified. ", + "To specify a family use stan_glmer instead of stan_lmer." + ) + } + mc <- call <- match.call(expand.dots = TRUE) + if (!"formula" %in% names(call)) { + names(call)[2L] <- "formula" + } + mc[[1L]] <- quote(stan_glmer) + mc$REML <- NULL + mc$family <- "gaussian" + out <- eval(mc, parent.frame()) + out$call <- call + out$stan_function <- "stan_lmer" + return(out) } - mc <- call <- match.call(expand.dots = TRUE) - if (!"formula" %in% names(call)) - names(call)[2L] <- "formula" - mc[[1L]] <- quote(stan_glmer) - mc$REML <- NULL - mc$family <- "gaussian" - out <- eval(mc, parent.frame()) - out$call <- call - out$stan_function <- "stan_lmer" - return(out) -} #' @rdname stan_glmer #' @export -#' @param link For \code{stan_glmer.nb} only, the link function to use. See +#' @param link For \code{stan_glmer.nb} only, the link function to use. See #' \code{\link{neg_binomial_2}}. -#' -stan_glmer.nb <- - function(formula, - data = NULL, - subset, - weights, - na.action = getOption("na.action", "na.omit"), - offset, - contrasts = NULL, - link = "log", - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale=TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE) { - - if ("family" %in% names(list(...))) - stop("'family' should not be specified.") - mc <- call <- match.call(expand.dots = TRUE) - if (!"formula" %in% names(call)) - names(call)[2L] <- "formula" - mc[[1]] <- quote(stan_glmer) - mc$REML <- mc$link <- NULL - mc$family <- neg_binomial_2(link = link) - out <- eval(mc, parent.frame()) - out$call <- call - out$stan_function <- "stan_glmer.nb" - return(out) -} +#' +stan_glmer.nb <- + function( + formula, + data = NULL, + subset, + weights, + na.action = getOption("na.action", "na.omit"), + offset, + contrasts = NULL, + link = "log", + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale = TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE + ) { + if ("family" %in% names(list(...))) { + stop("'family' should not be specified.") + } + mc <- call <- match.call(expand.dots = TRUE) + if (!"formula" %in% names(call)) { + names(call)[2L] <- "formula" + } + mc[[1]] <- quote(stan_glmer) + mc$REML <- mc$link <- NULL + mc$family <- neg_binomial_2(link = link) + out <- eval(mc, parent.frame()) + out$call <- call + out$stan_function <- "stan_glmer.nb" + return(out) + } diff --git a/R/stan_jm.R b/R/stan_jm.R index b1f0ee2d6..b8aac1a54 100644 --- a/R/stan_jm.R +++ b/R/stan_jm.R @@ -1,27 +1,27 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University # Copyright (C) 2016, 2017 Sam Brilleman -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian joint longitudinal and time-to-event models via Stan -#' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Fits a shared parameter joint model for longitudinal and time-to-event +#' +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' Fits a shared parameter joint model for longitudinal and time-to-event #' (e.g. survival) data under a Bayesian framework using Stan. -#' +#' #' @export #' @template args-dots #' @template args-prior_PD @@ -30,31 +30,31 @@ #' @template args-max_treedepth #' @template args-QR #' @template args-sparse -#' -#' @param formulaLong A two-sided linear formula object describing both the +#' +#' @param formulaLong A two-sided linear formula object describing both the #' fixed-effects and random-effects parts of the longitudinal submodel, #' similar in vein to formula specification in the \strong{lme4} package -#' (see \code{\link[lme4]{glmer}} or the \strong{lme4} vignette for details). -#' Note however that the double bar (\code{||}) notation is not allowed +#' (see \code{\link[lme4]{glmer}} or the \strong{lme4} vignette for details). +#' Note however that the double bar (\code{||}) notation is not allowed #' when specifying the random-effects parts of the formula, and neither -#' are nested grouping factors (e.g. \code{(1 | g1/g2))} or -#' \code{(1 | g1:g2)}, where \code{g1}, \code{g2} are grouping factors. +#' are nested grouping factors (e.g. \code{(1 | g1/g2))} or +#' \code{(1 | g1:g2)}, where \code{g1}, \code{g2} are grouping factors. #' Offset terms can also be included in the model formula. -#' For a multivariate joint model (i.e. more than one longitudinal marker) +#' For a multivariate joint model (i.e. more than one longitudinal marker) #' this should be a list of such formula objects, with each element #' of the list providing the formula for one of the longitudinal submodels. #' @param dataLong A data frame containing the variables specified in #' \code{formulaLong}. If fitting a multivariate joint model, then this can -#' be either a single data frame which contains the data for all +#' be either a single data frame which contains the data for all #' longitudinal submodels, or it can be a list of data frames where each -#' element of the list provides the data for one of the longitudinal +#' element of the list provides the data for one of the longitudinal #' submodels. #' @param formulaEvent A two-sided formula object describing the event -#' submodel. The left hand side of the formula should be a \code{Surv()} +#' submodel. The left hand side of the formula should be a \code{Surv()} #' object. See \code{\link[survival]{Surv}}. #' @param dataEvent A data frame containing the variables specified in #' \code{formulaEvent}. -#' @param time_var A character string specifying the name of the variable +#' @param time_var A character string specifying the name of the variable #' in \code{dataLong} which represents time. #' @param id_var A character string specifying the name of the variable in #' \code{dataLong} which distinguishes between individuals. This can be @@ -62,458 +62,458 @@ #' to be the individual). If there is more than one grouping factor (i.e. #' clustering beyond the level of the individual) then the \code{id_var} #' argument must be specified. -#' @param family The family (and possibly also the link function) for the -#' longitudinal submodel(s). See \code{\link[lme4]{glmer}} for details. +#' @param family The family (and possibly also the link function) for the +#' longitudinal submodel(s). See \code{\link[lme4]{glmer}} for details. #' If fitting a multivariate joint model, then this can optionally be a #' list of families, in which case each element of the list specifies the #' family for one of the longitudinal submodels. #' @param assoc A character string or character vector specifying the joint #' model association structure. Possible association structures that can -#' be used include: "etavalue" (the default); "etaslope"; "etaauc"; -#' "muvalue"; "muslope"; "muauc"; "shared_b"; "shared_coef"; or "null". -#' These are described in the \strong{Details} section below. For a multivariate -#' joint model, different association structures can optionally be used for +#' be used include: "etavalue" (the default); "etaslope"; "etaauc"; +#' "muvalue"; "muslope"; "muauc"; "shared_b"; "shared_coef"; or "null". +#' These are described in the \strong{Details} section below. For a multivariate +#' joint model, different association structures can optionally be used for #' each longitudinal submodel by specifying a list of character -#' vectors, with each element of the list specifying the desired association +#' vectors, with each element of the list specifying the desired association #' structure for one of the longitudinal submodels. Specifying \code{assoc = NULL} -#' will fit a joint model with no association structure (equivalent -#' to fitting separate longitudinal and time-to-event models). It is also -#' possible to include interaction terms between the association term -#' ("etavalue", "etaslope", "muvalue", "muslope") and observed data/covariates. -#' It is also possible, when fitting a multivariate joint model, to include -#' interaction terms between the association terms ("etavalue" or "muvalue") -#' corresponding to the different longitudinal outcomes. See the +#' will fit a joint model with no association structure (equivalent +#' to fitting separate longitudinal and time-to-event models). It is also +#' possible to include interaction terms between the association term +#' ("etavalue", "etaslope", "muvalue", "muslope") and observed data/covariates. +#' It is also possible, when fitting a multivariate joint model, to include +#' interaction terms between the association terms ("etavalue" or "muvalue") +#' corresponding to the different longitudinal outcomes. See the #' \strong{Details} section as well as the \strong{Examples} below. #' @param lag_assoc A non-negative scalar specifying the time lag that should be -#' used for the association structure. That is, the hazard of the event at -#' time \emph{t} will be assumed to be associated with the value/slope/auc of +#' used for the association structure. That is, the hazard of the event at +#' time \emph{t} will be assumed to be associated with the value/slope/auc of #' the longitudinal marker at time \emph{t-u}, where \emph{u} is the time lag. #' If fitting a multivariate joint model, then a different time lag can be used #' for each longitudinal marker by providing a numeric vector of lags, otherwise -#' if a scalar is provided then the specified time lag will be used for all -#' longitudinal markers. Note however that only one time lag can be specified -#' for linking each longitudinal marker to the +#' if a scalar is provided then the specified time lag will be used for all +#' longitudinal markers. Note however that only one time lag can be specified +#' for linking each longitudinal marker to the #' event, and that that time lag will be used for all association structure -#' types (e.g. \code{"etavalue"}, \code{"etaslope"}, \code{"etaauc"}, +#' types (e.g. \code{"etavalue"}, \code{"etaslope"}, \code{"etaauc"}, #' \code{"muvalue"}, etc) that are specified for that longitudinal marker in #' the \code{assoc} argument. #' @param grp_assoc Character string specifying the method for combining information #' across lower level units clustered within an individual when forming the -#' association structure. This is only relevant when a grouping factor is -#' specified in \code{formulaLong} that corresponds to clustering within +#' association structure. This is only relevant when a grouping factor is +#' specified in \code{formulaLong} that corresponds to clustering within #' individuals. This can be specified as either \code{"sum"}, \code{mean}, #' \code{"min"} or \code{"max"}. For example, specifying \code{grp_assoc = "sum"} -#' indicates that the association structure should be based on a summation across +#' indicates that the association structure should be based on a summation across #' the lower level units clustered within an individual, or specifying -#' \code{grp_assoc = "mean"} indicates that the association structure -#' should be based on the mean (i.e. average) taken across the lower level +#' \code{grp_assoc = "mean"} indicates that the association structure +#' should be based on the mean (i.e. average) taken across the lower level #' units clustered within an individual. -#' So, for example, specifying \code{assoc = "muvalue"} -#' and \code{grp_assoc = "sum"} would mean that the log hazard at time +#' So, for example, specifying \code{assoc = "muvalue"} +#' and \code{grp_assoc = "sum"} would mean that the log hazard at time #' \emph{t} for individual \emph{i} would be linearly related to the sum of -#' the expected values at time \emph{t} for each of the lower level -#' units (which may be for example tumor lesions) clustered within that -#' individual. -#' @param scale_assoc A non-zero numeric value specifying an optional scaling -#' parameter for the association structure. This multiplicatively scales the -#' value/slope/auc of the longitudinal marker by \code{scale_assoc} within the -#' event submodel. When fitting a multivariate joint model, a scaling parameter -#' must be specified for each longitudinal submodel using a vector of numeric -#' values. Note that only one scaling parameter can be specified for each -#' longitudinal submodel, and it will be used for all association structure -#' types (e.g. \code{"etavalue"}, \code{"etaslope"}, \code{"etaauc"}, +#' the expected values at time \emph{t} for each of the lower level +#' units (which may be for example tumor lesions) clustered within that +#' individual. +#' @param scale_assoc A non-zero numeric value specifying an optional scaling +#' parameter for the association structure. This multiplicatively scales the +#' value/slope/auc of the longitudinal marker by \code{scale_assoc} within the +#' event submodel. When fitting a multivariate joint model, a scaling parameter +#' must be specified for each longitudinal submodel using a vector of numeric +#' values. Note that only one scaling parameter can be specified for each +#' longitudinal submodel, and it will be used for all association structure +#' types (e.g. \code{"etavalue"}, \code{"etaslope"}, \code{"etaauc"}, #' \code{"muvalue"}, etc) that are specified for that longitudinal marker in #' the \code{assoc} argument. #' @param basehaz A character string indicating which baseline hazard to use -#' for the event submodel. Options are a B-splines approximation estimated -#' for the log baseline hazard (\code{"bs"}, the default), a Weibull +#' for the event submodel. Options are a B-splines approximation estimated +#' for the log baseline hazard (\code{"bs"}, the default), a Weibull #' baseline hazard (\code{"weibull"}), or a piecewise -#' constant baseline hazard (\code{"piecewise"}). (Note however that there +#' constant baseline hazard (\code{"piecewise"}). (Note however that there #' is currently limited post-estimation functionality available for #' models estimated using a piecewise constant baseline hazard). #' @param basehaz_ops A named list specifying options related to the baseline #' hazard. Currently this can include: \cr #' \describe{ -#' \item{\code{df}}{A positive integer specifying the degrees of freedom +#' \item{\code{df}}{A positive integer specifying the degrees of freedom #' for the B-splines if \code{basehaz = "bs"}, or the number of -#' intervals used for the piecewise constant baseline hazard if +#' intervals used for the piecewise constant baseline hazard if #' \code{basehaz = "piecewise"}. The default is 6.} -#' \item{\code{knots}}{An optional numeric vector specifying the internal knot -#' locations for the B-splines if \code{basehaz = "bs"}, or the -#' internal cut-points for defining intervals of the piecewise constant +#' \item{\code{knots}}{An optional numeric vector specifying the internal knot +#' locations for the B-splines if \code{basehaz = "bs"}, or the +#' internal cut-points for defining intervals of the piecewise constant #' baseline hazard if \code{basehaz = "piecewise"}. Knots cannot be -#' specified if \code{df} is specified. If not specified, then the +#' specified if \code{df} is specified. If not specified, then the #' default is to use \code{df - 4} knots if \code{basehaz = "bs"}, #' or \code{df - 1} knots if \code{basehaz = "piecewise"}, which are #' placed at equally spaced percentiles of the distribution of #' observed event times.} #' } #' @param epsilon The half-width of the central difference used to numerically -#' calculate the derivate when the \code{"etaslope"} association structure -#' is used. +#' calculate the derivate when the \code{"etaslope"} association structure +#' is used. #' @param qnodes The number of nodes to use for the Gauss-Kronrod quadrature -#' that is used to evaluate the cumulative hazard in the likelihood function. +#' that is used to evaluate the cumulative hazard in the likelihood function. #' Options are 15 (the default), 11 or 7. -#' @param weights Experimental and should be used with caution. The +#' @param weights Experimental and should be used with caution. The #' user can optionally supply a 2-column data frame containing a set of #' 'prior weights' to be used in the estimation process. The data frame should -#' contain two columns: the first containing the IDs for each individual, and +#' contain two columns: the first containing the IDs for each individual, and #' the second containing the corresponding weights. The data frame should only -#' have one row for each individual; that is, weights should be constant +#' have one row for each individual; that is, weights should be constant #' within individuals. #' @param init The method for generating the initial values for the MCMC. -#' The default is \code{"prefit"}, which uses those obtained from -#' fitting separate longitudinal and time-to-event models prior to -#' fitting the joint model. The separate longitudinal model is a -#' (possibly multivariate) generalised linear mixed -#' model estimated using variational bayes. This is achieved via the +#' The default is \code{"prefit"}, which uses those obtained from +#' fitting separate longitudinal and time-to-event models prior to +#' fitting the joint model. The separate longitudinal model is a +#' (possibly multivariate) generalised linear mixed +#' model estimated using variational bayes. This is achieved via the #' \code{\link{stan_mvmer}} function with \code{algorithm = "meanfield"}. -#' The separate Cox model is estimated using \code{\link[survival]{coxph}}. +#' The separate Cox model is estimated using \code{\link[survival]{coxph}}. #' This is achieved -#' using the and time-to-event models prior +#' using the and time-to-event models prior #' to fitting the joint model. The separate models are estimated using the #' \code{\link[lme4]{glmer}} and \code{\link[survival]{coxph}} functions. -#' This should provide reasonable initial values which should aid the -#' MCMC sampler. Parameters that cannot be obtained from -#' fitting separate longitudinal and time-to-event models are initialised +#' This should provide reasonable initial values which should aid the +#' MCMC sampler. Parameters that cannot be obtained from +#' fitting separate longitudinal and time-to-event models are initialised #' using the "random" method for \code{\link[rstan]{stan}}. #' However it is recommended that any final analysis should ideally #' be performed with several MCMC chains each initiated from a different #' set of initial values; this can be obtained by setting -#' \code{init = "random"}. In addition, other possibilities for specifying -#' \code{init} are the same as those described for \code{\link[rstan]{stan}}. -#' @param priorLong,priorEvent,priorEvent_assoc The prior distributions for the +#' \code{init = "random"}. In addition, other possibilities for specifying +#' \code{init} are the same as those described for \code{\link[rstan]{stan}}. +#' @param priorLong,priorEvent,priorEvent_assoc The prior distributions for the #' regression coefficients in the longitudinal submodel(s), event submodel, -#' and the association parameter(s). Can be a call to one of the various functions -#' provided by \pkg{rstanarm} for specifying priors. The subset of these functions -#' that can be used for the prior on the coefficients can be grouped into several +#' and the association parameter(s). Can be a call to one of the various functions +#' provided by \pkg{rstanarm} for specifying priors. The subset of these functions +#' that can be used for the prior on the coefficients can be grouped into several #' "families": -#' +#' #' \tabular{ll}{ -#' \strong{Family} \tab \strong{Functions} \cr -#' \emph{Student t family} \tab \code{normal}, \code{student_t}, \code{cauchy} \cr -#' \emph{Hierarchical shrinkage family} \tab \code{hs}, \code{hs_plus} \cr +#' \strong{Family} \tab \strong{Functions} \cr +#' \emph{Student t family} \tab \code{normal}, \code{student_t}, \code{cauchy} \cr +#' \emph{Hierarchical shrinkage family} \tab \code{hs}, \code{hs_plus} \cr #' \emph{Laplace family} \tab \code{laplace}, \code{lasso} \cr #' } -#' -#' See the \link[=priors]{priors help page} for details on the families and +#' +#' See the \link[=priors]{priors help page} for details on the families and #' how to specify the arguments for all of the functions in the table above. #' To omit a prior ---i.e., to use a flat (improper) uniform prior--- #' \code{prior} can be set to \code{NULL}, although this is rarely a good #' idea. -#' +#' #' \strong{Note:} Unless \code{QR=TRUE}, if \code{prior} is from the Student t -#' family or Laplace family, and if the \code{autoscale} argument to the -#' function used to specify the prior (e.g. \code{\link{normal}}) is left at -#' its default and recommended value of \code{TRUE}, then the default or +#' family or Laplace family, and if the \code{autoscale} argument to the +#' function used to specify the prior (e.g. \code{\link{normal}}) is left at +#' its default and recommended value of \code{TRUE}, then the default or #' user-specified prior scale(s) may be adjusted internally based on the scales #' of the predictors. See the \link[=priors]{priors help page} for details on #' the rescaling and the \code{\link{prior_summary}} function for a summary of #' the priors used for a particular model. -#' @param priorLong_intercept,priorEvent_intercept The prior distributions -#' for the intercepts in the longitudinal submodel(s) and event submodel. -#' Can be a call to \code{normal}, \code{student_t} or -#' \code{cauchy}. See the \link[=priors]{priors help page} for details on +#' @param priorLong_intercept,priorEvent_intercept The prior distributions +#' for the intercepts in the longitudinal submodel(s) and event submodel. +#' Can be a call to \code{normal}, \code{student_t} or +#' \code{cauchy}. See the \link[=priors]{priors help page} for details on #' these functions. To omit a prior on the intercept ---i.e., to use a flat #' (improper) uniform prior--- \code{prior_intercept} can be set to #' \code{NULL}. -#' +#' #' \strong{Note:} The prior distribution for the intercept is set so it -#' applies to the value when all predictors are centered. Moreover, +#' applies to the value when all predictors are centered. Moreover, #' note that a prior is only placed on the intercept for the event submodel #' when a Weibull baseline hazard has been specified. For the B-splines and #' piecewise constant baseline hazards there is not intercept parameter that -#' is given a prior distribution; an intercept parameter will be shown in -#' the output for the fitted model, but this just corresponds to the +#' is given a prior distribution; an intercept parameter will be shown in +#' the output for the fitted model, but this just corresponds to the #' necessary post-estimation adjustment in the linear predictor due to the #' centering of the predictiors in the event submodel. -#' +#' #' @param priorLong_aux The prior distribution for the "auxiliary" parameters -#' in the longitudinal submodels (if applicable). -#' The "auxiliary" parameter refers to a different parameter -#' depending on the \code{family}. For Gaussian models \code{priorLong_aux} -#' controls \code{"sigma"}, the error -#' standard deviation. For negative binomial models \code{priorLong_aux} controls -#' \code{"reciprocal_dispersion"}, which is similar to the +#' in the longitudinal submodels (if applicable). +#' The "auxiliary" parameter refers to a different parameter +#' depending on the \code{family}. For Gaussian models \code{priorLong_aux} +#' controls \code{"sigma"}, the error +#' standard deviation. For negative binomial models \code{priorLong_aux} controls +#' \code{"reciprocal_dispersion"}, which is similar to the #' \code{"size"} parameter of \code{\link[stats:NegBinomial]{rnbinom}}: -#' smaller values of \code{"reciprocal_dispersion"} correspond to -#' greater dispersion. For gamma models \code{priorLong_aux} sets the prior on -#' to the \code{"shape"} parameter (see e.g., -#' \code{\link[stats:GammaDist]{rgamma}}), and for inverse-Gaussian models it is the +#' smaller values of \code{"reciprocal_dispersion"} correspond to +#' greater dispersion. For gamma models \code{priorLong_aux} sets the prior on +#' to the \code{"shape"} parameter (see e.g., +#' \code{\link[stats:GammaDist]{rgamma}}), and for inverse-Gaussian models it is the #' so-called \code{"lambda"} parameter (which is essentially the reciprocal of -#' a scale parameter). Binomial and Poisson models do not have auxiliary -#' parameters. -#' -#' \code{priorLong_aux} can be a call to \code{exponential} to -#' use an exponential distribution, or \code{normal}, \code{student_t} or -#' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy -#' prior. See \code{\link{priors}} for details on these functions. To omit a -#' prior ---i.e., to use a flat (improper) uniform prior--- set +#' a scale parameter). Binomial and Poisson models do not have auxiliary +#' parameters. +#' +#' \code{priorLong_aux} can be a call to \code{exponential} to +#' use an exponential distribution, or \code{normal}, \code{student_t} or +#' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy +#' prior. See \code{\link{priors}} for details on these functions. To omit a +#' prior ---i.e., to use a flat (improper) uniform prior--- set #' \code{priorLong_aux} to \code{NULL}. -#' +#' #' If fitting a multivariate joint model, you have the option to #' specify a list of prior distributions, however the elements of the list -#' that correspond to any longitudinal submodel which does not have an -#' auxiliary parameter will be ignored. +#' that correspond to any longitudinal submodel which does not have an +#' auxiliary parameter will be ignored. #' @param priorEvent_aux The prior distribution for the "auxiliary" parameters -#' in the event submodel. The "auxiliary" parameters refers to different +#' in the event submodel. The "auxiliary" parameters refers to different #' parameters depending on the baseline hazard. For \code{basehaz = "weibull"} -#' the auxiliary parameter is the Weibull shape parameter. For +#' the auxiliary parameter is the Weibull shape parameter. For #' \code{basehaz = "bs"} the auxiliary parameters are the coefficients for the #' B-spline approximation to the log baseline hazard. #' For \code{basehaz = "piecewise"} the auxiliary parameters are the piecewise #' estimates of the log baseline hazard. #' @param prior_covariance Cannot be \code{NULL}; see \code{\link{priors}} for #' more information about the prior distributions on covariance matrices. -#' Note however that the default prior for covariance matrices in -#' \code{stan_jm} is slightly different to that in \code{\link{stan_glmer}} +#' Note however that the default prior for covariance matrices in +#' \code{stan_jm} is slightly different to that in \code{\link{stan_glmer}} #' (the details of which are described on the \code{\link{priors}} page). -#' -#' @details The \code{stan_jm} function can be used to fit a joint model (also -#' known as a shared parameter model) for longitudinal and time-to-event data +#' +#' @details The \code{stan_jm} function can be used to fit a joint model (also +#' known as a shared parameter model) for longitudinal and time-to-event data #' under a Bayesian framework. The underlying -#' estimation is carried out using the Bayesian C++ package Stan +#' estimation is carried out using the Bayesian C++ package Stan #' (\url{https://mc-stan.org/}). \cr -#' \cr +#' \cr #' The joint model may be univariate (with only one longitudinal submodel) or -#' multivariate (with more than one longitudinal submodel). -#' For the longitudinal submodel a (possibly multivariate) generalised linear -#' mixed model is assumed with any of the \code{\link[stats]{family}} choices -#' allowed by \code{\link[lme4]{glmer}}. If a multivariate joint model is specified +#' multivariate (with more than one longitudinal submodel). +#' For the longitudinal submodel a (possibly multivariate) generalised linear +#' mixed model is assumed with any of the \code{\link[stats]{family}} choices +#' allowed by \code{\link[lme4]{glmer}}. If a multivariate joint model is specified #' (by providing a list of formulas in the \code{formulaLong} argument), then -#' the multivariate longitudinal submodel consists of a multivariate generalized +#' the multivariate longitudinal submodel consists of a multivariate generalized #' linear model (GLM) with group-specific terms that are assumed to be correlated #' across the different GLM submodels. That is, within #' a grouping factor (for example, patient ID) the group-specific terms are -#' assumed to be correlated across the different GLM submodels. It is +#' assumed to be correlated across the different GLM submodels. It is #' possible to specify a different outcome type (for example a different #' family and/or link function) for each of the GLM submodels, by providing -#' a list of \code{\link[stats]{family}} objects in the \code{family} -#' argument. Multi-level -#' clustered data are allowed, and that additional clustering can occur at a -#' level higher than the individual-level (e.g. patients clustered within +#' a list of \code{\link[stats]{family}} objects in the \code{family} +#' argument. Multi-level +#' clustered data are allowed, and that additional clustering can occur at a +#' level higher than the individual-level (e.g. patients clustered within #' clinics), or at a level lower than the individual-level (e.g. tumor lesions #' clustered within patients). If the clustering occurs at a level lower than -#' the individual, then the user needs to indicate how the lower level +#' the individual, then the user needs to indicate how the lower level #' clusters should be handled when forming the association structure between #' the longitudinal and event submodels (see the \code{grp_assoc} argument #' described above). \cr #' \cr #' For the event submodel a parametric -#' proportional hazards model is assumed. The baseline hazard can be estimated +#' proportional hazards model is assumed. The baseline hazard can be estimated #' using either a cubic B-splines approximation (\code{basehaz = "bs"}, the #' default), a Weibull distribution (\code{basehaz = "weibull"}), or a #' piecewise constant baseline hazard (\code{basehaz = "piecewise"}). -#' If the B-spline or piecewise constant baseline hazards are used, -#' then the degrees of freedom or the internal knot locations can be +#' If the B-spline or piecewise constant baseline hazards are used, +#' then the degrees of freedom or the internal knot locations can be #' (optionally) specified. If #' the degrees of freedom are specified (through the \code{df} argument) then -#' the knot locations are automatically generated based on the -#' distribution of the observed event times (not including censoring times). -#' Otherwise internal knot locations can be specified +#' the knot locations are automatically generated based on the +#' distribution of the observed event times (not including censoring times). +#' Otherwise internal knot locations can be specified #' directly through the \code{knots} argument. If neither \code{df} or #' \code{knots} is specified, then the default is to set \code{df} equal to 6. #' It is not possible to specify both \code{df} and \code{knots}. \cr #' \cr -#' Time-varying covariates are allowed in both the -#' longitudinal and event submodels. These should be specified in the data -#' in the same way as they normally would when fitting a separate -#' longitudinal model using \code{\link[lme4]{lmer}} or a separate +#' Time-varying covariates are allowed in both the +#' longitudinal and event submodels. These should be specified in the data +#' in the same way as they normally would when fitting a separate +#' longitudinal model using \code{\link[lme4]{lmer}} or a separate #' time-to-event model using \code{\link[survival]{coxph}}. These time-varying -#' covariates should be exogenous in nature, otherwise they would perhaps -#' be better specified as an additional outcome (i.e. by including them as an +#' covariates should be exogenous in nature, otherwise they would perhaps +#' be better specified as an additional outcome (i.e. by including them as an #' additional longitudinal outcome in the joint model). \cr #' \cr -#' Bayesian estimation of the joint model is performed via MCMC. The Bayesian -#' model includes independent priors on the -#' regression coefficients for both the longitudinal and event submodels, +#' Bayesian estimation of the joint model is performed via MCMC. The Bayesian +#' model includes independent priors on the +#' regression coefficients for both the longitudinal and event submodels, #' including the association parameter(s) (in much the same way as the #' regression parameters in \code{\link{stan_glm}}) and #' priors on the terms of a decomposition of the covariance matrices of the -#' group-specific parameters. +#' group-specific parameters. #' See \code{\link{priors}} for more information about the priors distributions #' that are available. \cr #' \cr -#' Gauss-Kronrod quadrature is used to numerically evaluate the integral +#' Gauss-Kronrod quadrature is used to numerically evaluate the integral #' over the cumulative hazard in the likelihood function for the event submodel. #' The accuracy of the numerical approximation can be controlled using the -#' number of quadrature nodes, specified through the \code{qnodes} -#' argument. Using a higher number of quadrature nodes will result in a more +#' number of quadrature nodes, specified through the \code{qnodes} +#' argument. Using a higher number of quadrature nodes will result in a more #' accurate approximation. -#' +#' #' \subsection{Association structures}{ -#' The association structure for the joint model can be based on any of the -#' following parameterisations: +#' The association structure for the joint model can be based on any of the +#' following parameterisations: #' \itemize{ -#' \item current value of the linear predictor in the -#' longitudinal submodel (\code{"etavalue"}) -#' \item first derivative (slope) of the linear predictor in the -#' longitudinal submodel (\code{"etaslope"}) -#' \item the area under the curve of the linear predictor in the -#' longitudinal submodel (\code{"etaauc"}) -#' \item current expected value of the longitudinal submodel +#' \item current value of the linear predictor in the +#' longitudinal submodel (\code{"etavalue"}) +#' \item first derivative (slope) of the linear predictor in the +#' longitudinal submodel (\code{"etaslope"}) +#' \item the area under the curve of the linear predictor in the +#' longitudinal submodel (\code{"etaauc"}) +#' \item current expected value of the longitudinal submodel #' (\code{"muvalue"}) -#' \item the area under the curve of the expected value from the +#' \item the area under the curve of the expected value from the #' longitudinal submodel (\code{"muauc"}) -#' \item shared individual-level random effects (\code{"shared_b"}) -#' \item shared individual-level random effects which also incorporate -#' the corresponding fixed effect as well as any corresponding +#' \item shared individual-level random effects (\code{"shared_b"}) +#' \item shared individual-level random effects which also incorporate +#' the corresponding fixed effect as well as any corresponding #' random effects for clustering levels higher than the individual) #' (\code{"shared_coef"}) #' \item interactions between association terms and observed data/covariates -#' (\code{"etavalue_data"}, \code{"etaslope_data"}, \code{"muvalue_data"}, +#' (\code{"etavalue_data"}, \code{"etaslope_data"}, \code{"muvalue_data"}, #' \code{"muslope_data"}). These are described further below. -#' \item interactions between association terms corresponding to different -#' longitudinal outcomes in a multivariate joint model +#' \item interactions between association terms corresponding to different +#' longitudinal outcomes in a multivariate joint model #' (\code{"etavalue_etavalue(#)"}, \code{"etavalue_muvalue(#)"}, #' \code{"muvalue_etavalue(#)"}, \code{"muvalue_muvalue(#)"}). These -#' are described further below. -#' \item no association structure (equivalent to fitting separate -#' longitudinal and event models) (\code{"null"} or \code{NULL}) +#' are described further below. +#' \item no association structure (equivalent to fitting separate +#' longitudinal and event models) (\code{"null"} or \code{NULL}) #' } #' More than one association structure can be specified, however, -#' not all possible combinations are allowed. -#' Note that for the lagged association structures baseline values (time = 0) -#' are used for the instances -#' where the time lag results in a time prior to baseline. When using the +#' not all possible combinations are allowed. +#' Note that for the lagged association structures baseline values (time = 0) +#' are used for the instances +#' where the time lag results in a time prior to baseline. When using the #' \code{"etaauc"} or \code{"muauc"} association structures, the area under -#' the curve is evaluated using Gauss-Kronrod quadrature with 15 quadrature -#' nodes. By default, \code{"shared_b"} and \code{"shared_coef"} contribute -#' all random effects to the association structure; however, a subset of the -#' random effects can be chosen by specifying their indices between parentheses -#' as a suffix, for example, \code{"shared_b(1)"} or \code{"shared_b(1:3)"} or +#' the curve is evaluated using Gauss-Kronrod quadrature with 15 quadrature +#' nodes. By default, \code{"shared_b"} and \code{"shared_coef"} contribute +#' all random effects to the association structure; however, a subset of the +#' random effects can be chosen by specifying their indices between parentheses +#' as a suffix, for example, \code{"shared_b(1)"} or \code{"shared_b(1:3)"} or #' \code{"shared_b(1,2,4)"}, and so on. \cr -#' \cr +#' \cr #' In addition, several association terms (\code{"etavalue"}, \code{"etaslope"}, -#' \code{"muvalue"}, \code{"muslope"}) can be interacted with observed +#' \code{"muvalue"}, \code{"muslope"}) can be interacted with observed #' data/covariates. To do this, use the association term's main handle plus a -#' suffix of \code{"_data"} then followed by the model matrix formula in -#' parentheses. For example if we had a variable in our dataset for gender -#' named \code{sex} then we might want to obtain different estimates for the -#' association between the current slope of the marker and the risk of the -#' event for each gender. To do this we would specify +#' suffix of \code{"_data"} then followed by the model matrix formula in +#' parentheses. For example if we had a variable in our dataset for gender +#' named \code{sex} then we might want to obtain different estimates for the +#' association between the current slope of the marker and the risk of the +#' event for each gender. To do this we would specify #' \code{assoc = c("etaslope", "etaslope_data(~ sex)")}. \cr #' \cr -#' It is also possible, when fitting a multivariate joint model, to include +#' It is also possible, when fitting a multivariate joint model, to include #' interaction terms between the association terms themselves (this only -#' applies for interacting \code{"etavalue"} or \code{"muvalue"}). For example, -#' if we had a joint model with two longitudinal markers, we could specify +#' applies for interacting \code{"etavalue"} or \code{"muvalue"}). For example, +#' if we had a joint model with two longitudinal markers, we could specify #' \code{assoc = list(c("etavalue", "etavalue_etavalue(2)"), "etavalue")}. #' The first element of list says we want to use the value of the linear #' predictor for the first marker, as well as it's interaction with the -#' value of the linear predictor for the second marker. The second element of -#' the list says we want to also include the expected value of the second marker -#' (i.e. as a "main effect"). Therefore, the linear predictor for the event +#' value of the linear predictor for the second marker. The second element of +#' the list says we want to also include the expected value of the second marker +#' (i.e. as a "main effect"). Therefore, the linear predictor for the event #' submodel would include the "main effects" for each marker as well as their #' interaction. \cr #' \cr #' There are additional examples in the \strong{Examples} section below. #' } -#' +#' #' @return A \link[=stanreg-objects]{stanjm} object is returned. -#' -#' @seealso \code{\link{stanreg-objects}}, \code{\link{stanmvreg-methods}}, +#' +#' @seealso \code{\link{stanreg-objects}}, \code{\link{stanmvreg-methods}}, #' \code{\link{print.stanmvreg}}, \code{\link{summary.stanmvreg}}, -#' \code{\link{posterior_traj}}, \code{\link{posterior_survfit}}, +#' \code{\link{posterior_traj}}, \code{\link{posterior_survfit}}, #' \code{\link{posterior_predict}}, \code{\link{posterior_interval}}, #' \code{\link{pp_check}}, \code{\link{ps_check}}, \code{\link{stan_mvmer}}. -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch !="i386") { #' \donttest{ -#' +#' #' ##### -#' # Univariate joint model, with association structure based on the +#' # Univariate joint model, with association structure based on the #' # current value of the linear predictor -#' f1 <- stan_jm(formulaLong = logBili ~ year + (1 | id), +#' f1 <- stan_jm(formulaLong = logBili ~ year + (1 | id), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' time_var = "year", #' # this next line is only to keep the example small in size! #' chains = 1, cores = 1, seed = 12345, iter = 1000) -#' print(f1) -#' summary(f1) -#' +#' print(f1) +#' summary(f1) +#' #' ##### -#' # Univariate joint model, with association structure based on the +#' # Univariate joint model, with association structure based on the #' # current value and slope of the linear predictor -#' f2 <- stan_jm(formulaLong = logBili ~ year + (year | id), +#' f2 <- stan_jm(formulaLong = logBili ~ year + (year | id), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' assoc = c("etavalue", "etaslope"), #' time_var = "year", #' chains = 1, cores = 1, seed = 12345, iter = 1000) -#' print(f2) -#' +#' print(f2) +#' #' ##### -#' # Univariate joint model, with association structure based on the -#' # lagged value of the linear predictor, where the lag is 2 time +#' # Univariate joint model, with association structure based on the +#' # lagged value of the linear predictor, where the lag is 2 time #' # units (i.e. 2 years in this example) -#' f3 <- stan_jm(formulaLong = logBili ~ year + (1 | id), +#' f3 <- stan_jm(formulaLong = logBili ~ year + (1 | id), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' time_var = "year", #' assoc = "etavalue", lag_assoc = 2, #' chains = 1, cores = 1, seed = 12345, iter = 1000) -#' print(f3) -#' +#' print(f3) +#' #' ##### -#' # Univariate joint model, where the association structure includes -#' # interactions with observed data. Here we specify that we want to use -#' # an association structure based on the current value of the linear -#' # predictor from the longitudinal submodel (i.e. "etavalue"), but we +#' # Univariate joint model, where the association structure includes +#' # interactions with observed data. Here we specify that we want to use +#' # an association structure based on the current value of the linear +#' # predictor from the longitudinal submodel (i.e. "etavalue"), but we #' # also want to interact this with the treatment covariate (trt) from -#' # pbcLong data frame, so that we can estimate a different association -#' # parameter (i.e. estimated effect of log serum bilirubin on the log +#' # pbcLong data frame, so that we can estimate a different association +#' # parameter (i.e. estimated effect of log serum bilirubin on the log #' # hazard of death) for each treatment group -#' f4 <- stan_jm(formulaLong = logBili ~ year + (1 | id), +#' f4 <- stan_jm(formulaLong = logBili ~ year + (1 | id), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' time_var = "year", #' assoc = c("etavalue", "etavalue_data(~ trt)"), #' chains = 1, cores = 1, seed = 12345, iter = 1000) #' print(f4) -#' +#' #' ###### -#' # Multivariate joint model, with association structure based -#' # on the current value and slope of the linear predictor in the -#' # first longitudinal submodel and the area under the marker +#' # Multivariate joint model, with association structure based +#' # on the current value and slope of the linear predictor in the +#' # first longitudinal submodel and the area under the marker #' # trajectory for the second longitudinal submodel #' mv1 <- stan_jm( #' formulaLong = list( -#' logBili ~ year + (1 | id), +#' logBili ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, -#' assoc = list(c("etavalue", "etaslope"), "etaauc"), +#' assoc = list(c("etavalue", "etaslope"), "etaauc"), #' time_var = "year", #' chains = 1, cores = 1, seed = 12345, iter = 100) #' print(mv1) -#' +#' #' ##### -#' # Multivariate joint model, where the association structure is formed by -#' # including the expected value of each longitudinal marker (logBili and -#' # albumin) in the linear predictor of the event submodel, as well as their -#' # interaction effect (i.e. the interaction between the two "etavalue" terms). -#' # Note that whether such an association structure based on a marker by -#' # marker interaction term makes sense will depend on the context of your +#' # Multivariate joint model, where the association structure is formed by +#' # including the expected value of each longitudinal marker (logBili and +#' # albumin) in the linear predictor of the event submodel, as well as their +#' # interaction effect (i.e. the interaction between the two "etavalue" terms). +#' # Note that whether such an association structure based on a marker by +#' # marker interaction term makes sense will depend on the context of your #' # application -- here we just show it for demostration purposes). #' mv2 <- stan_jm( #' formulaLong = list( -#' logBili ~ year + (1 | id), +#' logBili ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' assoc = list(c("etavalue", "etavalue_etavalue(2)"), "etavalue"), -#' time_var = "year", +#' time_var = "year", #' chains = 1, cores = 1, seed = 12345, iter = 100) -#' +#' #' ##### #' # Multivariate joint model, with one bernoulli marker and one #' # Gaussian marker. We will artificially create the bernoulli @@ -521,74 +521,120 @@ #' pbcLong$ybern <- as.integer(pbcLong$logBili >= mean(pbcLong$logBili)) #' mv3 <- stan_jm( #' formulaLong = list( -#' ybern ~ year + (1 | id), +#' ybern ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' family = list(binomial, gaussian), -#' time_var = "year", +#' time_var = "year", #' chains = 1, cores = 1, seed = 12345, iter = 1000) #' } #' } -#' -stan_jm <- function(formulaLong, dataLong, formulaEvent, dataEvent, time_var, - id_var, family = gaussian, assoc = "etavalue", - lag_assoc = 0, grp_assoc, scale_assoc = NULL, epsilon = 1E-5, - basehaz = c("bs", "weibull", "piecewise"), basehaz_ops, - qnodes = 15, init = "prefit", weights, - priorLong = normal(autoscale=TRUE), priorLong_intercept = normal(autoscale=TRUE), - priorLong_aux = cauchy(0, 5, autoscale=TRUE), priorEvent = normal(autoscale=TRUE), - priorEvent_intercept = normal(autoscale=TRUE), priorEvent_aux = cauchy(autoscale=TRUE), - priorEvent_assoc = normal(autoscale=TRUE), prior_covariance = lkj(autoscale=TRUE), - prior_PD = FALSE, algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, max_treedepth = 10L, QR = FALSE, - sparse = FALSE, ...) { - +#' +stan_jm <- function( + formulaLong, + dataLong, + formulaEvent, + dataEvent, + time_var, + id_var, + family = gaussian, + assoc = "etavalue", + lag_assoc = 0, + grp_assoc, + scale_assoc = NULL, + epsilon = 1E-5, + basehaz = c("bs", "weibull", "piecewise"), + basehaz_ops, + qnodes = 15, + init = "prefit", + weights, + priorLong = normal(autoscale = TRUE), + priorLong_intercept = normal(autoscale = TRUE), + priorLong_aux = cauchy(0, 5, autoscale = TRUE), + priorEvent = normal(autoscale = TRUE), + priorEvent_intercept = normal(autoscale = TRUE), + priorEvent_aux = cauchy(autoscale = TRUE), + priorEvent_assoc = normal(autoscale = TRUE), + prior_covariance = lkj(autoscale = TRUE), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + max_treedepth = 10L, + QR = FALSE, + sparse = FALSE, + ... +) { #----------------------------- # Pre-processing of arguments - #----------------------------- - + #----------------------------- + # Set seed if specified dots <- list(...) - if ("seed" %in% names(dots)) + if ("seed" %in% names(dots)) { set.seed(dots$seed) - + } + algorithm <- match.arg(algorithm) - basehaz <- match.arg(basehaz) - - if (missing(basehaz_ops)) basehaz_ops <- NULL - if (missing(weights)) weights <- NULL - if (missing(id_var)) id_var <- NULL - if (missing(time_var)) time_var <- NULL - if (missing(grp_assoc)) grp_assoc <- NULL + basehaz <- match.arg(basehaz) + + if (missing(basehaz_ops)) { + basehaz_ops <- NULL + } + if (missing(weights)) { + weights <- NULL + } + if (missing(id_var)) { + id_var <- NULL + } + if (missing(time_var)) { + time_var <- NULL + } + if (missing(grp_assoc)) { + grp_assoc <- NULL + } - if (!is.null(weights)) + if (!is.null(weights)) { stop("'weights' are not yet implemented.") - if (QR) + } + if (QR) { stop("'QR' decomposition is not yet implemented.") - if (sparse) + } + if (sparse) { stop("'sparse' option is not yet implemented.") - - if (is.null(time_var)) + } + + if (is.null(time_var)) { stop("'time_var' must be specified.") + } # Formula - formulaLong <- validate_arg(formulaLong, "formula"); M <- length(formulaLong) - if (M > 3L) - stop("'stan_jm' is currently limited to a maximum of 3 longitudinal outcomes.") - + formulaLong <- validate_arg(formulaLong, "formula") + M <- length(formulaLong) + if (M > 3L) { + stop( + "'stan_jm' is currently limited to a maximum of 3 longitudinal outcomes." + ) + } + # Data - dataLong <- validate_arg(dataLong, "data.frame", validate_length = M) + dataLong <- validate_arg(dataLong, "data.frame", validate_length = M) dataEvent <- as.data.frame(dataEvent) # Family ok_family_classes <- c("function", "family", "character") - ok_families <- c("binomial", "gaussian", "Gamma", - "inverse.gaussian", "poisson", "neg_binomial_2") + ok_families <- c( + "binomial", + "gaussian", + "Gamma", + "inverse.gaussian", + "poisson", + "neg_binomial_2" + ) family <- validate_arg(family, ok_family_classes, validate_length = M) family <- lapply(family, validate_famlink, ok_families) - + # Assoc ok_assoc_classes <- c("NULL", "character") assoc <- validate_arg(assoc, ok_assoc_classes, validate_length = M) @@ -597,57 +643,110 @@ stan_jm <- function(formulaLong, dataLong, formulaEvent, dataEvent, time_var, priorLong <- broadcast_prior(priorLong, M) priorLong_intercept <- broadcast_prior(priorLong_intercept, M) priorLong_aux <- broadcast_prior(priorLong_aux, M) - + #----------- # Fit model #----------- - - stanfit <- stan_jm.fit(formulaLong = formulaLong, dataLong = dataLong, - formulaEvent = formulaEvent, dataEvent = dataEvent, - time_var = time_var, id_var = id_var, family = family, - assoc = assoc, lag_assoc = lag_assoc, grp_assoc = grp_assoc, - epsilon = epsilon, basehaz = basehaz, basehaz_ops = basehaz_ops, - qnodes = qnodes, init = init, weights = weights, scale_assoc = scale_assoc, - priorLong = priorLong, - priorLong_intercept = priorLong_intercept, - priorLong_aux = priorLong_aux, - priorEvent = priorEvent, - priorEvent_intercept = priorEvent_intercept, - priorEvent_aux = priorEvent_aux, - priorEvent_assoc = priorEvent_assoc, - prior_covariance = prior_covariance, prior_PD = prior_PD, - algorithm = algorithm, adapt_delta = adapt_delta, - max_treedepth = max_treedepth, QR = QR, sparse = sparse, ...) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) + + stanfit <- stan_jm.fit( + formulaLong = formulaLong, + dataLong = dataLong, + formulaEvent = formulaEvent, + dataEvent = dataEvent, + time_var = time_var, + id_var = id_var, + family = family, + assoc = assoc, + lag_assoc = lag_assoc, + grp_assoc = grp_assoc, + epsilon = epsilon, + basehaz = basehaz, + basehaz_ops = basehaz_ops, + qnodes = qnodes, + init = init, + weights = weights, + scale_assoc = scale_assoc, + priorLong = priorLong, + priorLong_intercept = priorLong_intercept, + priorLong_aux = priorLong_aux, + priorEvent = priorEvent, + priorEvent_intercept = priorEvent_intercept, + priorEvent_aux = priorEvent_aux, + priorEvent_assoc = priorEvent_assoc, + prior_covariance = prior_covariance, + prior_PD = prior_PD, + algorithm = algorithm, + adapt_delta = adapt_delta, + max_treedepth = max_treedepth, + QR = QR, + sparse = sparse, + ... + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } y_mod <- attr(stanfit, "y_mod") e_mod <- attr(stanfit, "e_mod") a_mod <- attr(stanfit, "a_mod") - cnms <- attr(stanfit, "cnms") + cnms <- attr(stanfit, "cnms") flevels <- attr(stanfit, "flevels") assoc <- attr(stanfit, "assoc") scale_assoc <- attr(stanfit, "scale_assoc") id_var <- attr(stanfit, "id_var") - basehaz <- attr(stanfit, "basehaz") - grp_stuff <- attr(stanfit, "grp_stuff") + basehaz <- attr(stanfit, "basehaz") + grp_stuff <- attr(stanfit, "grp_stuff") prior_info <- attr(stanfit, "prior_info") - stanfit <- drop_attributes(stanfit, "y_mod", "e_mod", "a_mod", "cnms", - "flevels", "assoc", "id_var", "basehaz", - "grp_stuff", "prior_info","scale_assoc") - + stanfit <- drop_attributes( + stanfit, + "y_mod", + "e_mod", + "a_mod", + "cnms", + "flevels", + "assoc", + "id_var", + "basehaz", + "grp_stuff", + "prior_info", + "scale_assoc" + ) + terms <- c(fetch(y_mod, "terms"), list(terms(e_mod$mod))) n_yobs <- fetch_(y_mod, "x", "N") n_grps <- sapply(flevels, n_distinct) n_subjects <- e_mod$Npat - fit <- nlist(stanfit, formula = c(formulaLong, formulaEvent), family, - id_var, time_var, weights, scale_assoc, qnodes, basehaz, assoc, - M, cnms, flevels, n_grps, n_subjects, n_yobs, epsilon, - algorithm, terms, glmod = y_mod, survmod = e_mod, - assocmod = a_mod, grp_stuff, dataLong, dataEvent, - prior.info = prior_info, stan_function = "stan_jm", - call = match.call(expand.dots = TRUE)) - + fit <- nlist( + stanfit, + formula = c(formulaLong, formulaEvent), + family, + id_var, + time_var, + weights, + scale_assoc, + qnodes, + basehaz, + assoc, + M, + cnms, + flevels, + n_grps, + n_subjects, + n_yobs, + epsilon, + algorithm, + terms, + glmod = y_mod, + survmod = e_mod, + assocmod = a_mod, + grp_stuff, + dataLong, + dataEvent, + prior.info = prior_info, + stan_function = "stan_jm", + call = match.call(expand.dots = TRUE) + ) + out <- stanmvreg(fit) return(out) } - diff --git a/R/stan_lm.R b/R/stan_lm.R index 825d581d8..3490e432c 100644 --- a/R/stan_lm.R +++ b/R/stan_lm.R @@ -1,23 +1,23 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian regularized linear models via Stan -#' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' Bayesian inference for linear modeling with regularizing priors on the model #' parameters that are driven by prior beliefs about \eqn{R^2}, the proportion #' of variance in the outcome attributable to the predictors. See @@ -25,7 +25,7 @@ #' \code{\link{stan_glm}} with \code{family="gaussian"} also estimates a linear #' model with normally-distributed errors and allows for various other priors on #' the coefficients. -#' +#' #' @export #' @templateVar fun stan_lm, stan_aov #' @templateVar fitfun stan_lm.fit or stan_lm.wfit @@ -45,7 +45,7 @@ #' @template args-adapt_delta #' #' @param w Same as in \code{lm.wfit} but rarely specified. -#' @param prior Must be a call to \code{\link{R2}} with its +#' @param prior Must be a call to \code{\link{R2}} with its #' \code{location} argument specified or \code{NULL}, which would #' indicate a standard uniform prior for the \eqn{R^2}. #' @param prior_intercept Either \code{NULL} (the default) or a call to @@ -55,7 +55,7 @@ #' root of the sample size, which is legitimate because the marginal #' standard deviation of the outcome is a primitive parameter being #' estimated. -#' +#' #' \strong{Note:} If using a dense representation of the design matrix #' ---i.e., if the \code{sparse} argument is left at its default value of #' \code{FALSE}--- then the prior distribution for the intercept is set so it @@ -70,79 +70,89 @@ #' predictors (i.e., same as in \code{glm}). #' #' -#' @details The \code{stan_lm} function is similar in syntax to the +#' @details The \code{stan_lm} function is similar in syntax to the #' \code{\link[stats]{lm}} function but rather than choosing the parameters to -#' minimize the sum of squared residuals, samples from the posterior +#' minimize the sum of squared residuals, samples from the posterior #' distribution are drawn using MCMC (if \code{algorithm} is #' \code{"sampling"}). The \code{stan_lm} function has a formula-based #' interface and would usually be called by users but the \code{stan_lm.fit} #' and \code{stan_lm.wfit} functions might be called by other functions that #' parse the data themselves and are analogous to \code{lm.fit} #' and \code{lm.wfit} respectively. -#' +#' #' In addition to estimating \code{sigma} --- the standard deviation of the #' normally-distributed errors --- this model estimates a positive parameter -#' called \code{log-fit_ratio}. If it is positive, the marginal posterior +#' called \code{log-fit_ratio}. If it is positive, the marginal posterior #' variance of the outcome will exceed the sample variance of the outcome #' by a multiplicative factor equal to the square of \code{fit_ratio}. #' Conversely if \code{log-fit_ratio} is negative, then the model underfits. #' Given the regularizing nature of the priors, a slight underfit is good. -#' +#' #' Finally, the posterior predictive distribution is generated with the #' predictors fixed at their sample means. This quantity is useful for #' checking convergence because it is reasonably normally distributed #' and a function of all the parameters in the model. -#' +#' #' The \code{stan_aov} function is similar to \code{\link[stats]{aov}}, but #' does a Bayesian analysis of variance that is basically equivalent to #' \code{stan_lm} with dummy variables. \code{stan_aov} has a somewhat #' customized \code{\link{print}} method that prints an ANOVA-like table in #' addition to the output printed for \code{stan_lm} models. -#' -#' -#' @references +#' +#' +#' @references #' Lewandowski, D., Kurowicka D., and Joe, H. (2009). Generating random -#' correlation matrices based on vines and extended onion method. +#' correlation matrices based on vines and extended onion method. #' \emph{Journal of Multivariate Analysis}. \strong{100}(9), 1989--2001. -#' -#' @seealso +#' +#' @seealso #' The vignettes for \code{stan_lm} and \code{stan_aov}, which have more #' thorough descriptions and examples. #' \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' Also see \code{\link{stan_glm}}, which --- if \code{family = #' gaussian(link="identity")} --- also estimates a linear model with #' normally-distributed errors but specifies different priors. -#' -#' +#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch !="i386") { -#' (fit <- stan_lm(mpg ~ wt + qsec + am, data = mtcars, prior = R2(0.75), +#' (fit <- stan_lm(mpg ~ wt + qsec + am, data = mtcars, prior = R2(0.75), #' # the next line is only to make the example go fast enough #' chains = 1, iter = 300, seed = 12345, refresh = 0)) -#' plot(fit, "hist", pars = c("wt", "am", "qsec", "sigma"), +#' plot(fit, "hist", pars = c("wt", "am", "qsec", "sigma"), #' transformations = list(sigma = "log")) #' } -stan_lm <- function(formula, data, subset, weights, na.action, - model = TRUE, x = FALSE, y = FALSE, - singular.ok = TRUE, contrasts = NULL, offset, ..., - prior = R2(stop("'location' must be specified")), - prior_intercept = NULL, - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL) { - +stan_lm <- function( + formula, + data, + subset, + weights, + na.action, + model = TRUE, + x = FALSE, + y = FALSE, + singular.ok = TRUE, + contrasts = NULL, + offset, + ..., + prior = R2(stop("'location' must be specified")), + prior_intercept = NULL, + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL +) { algorithm <- match.arg(algorithm) validate_glm_formula(formula) data <- validate_data(data, if_missing = environment(formula)) - + call <- match.call(expand.dots = TRUE) mf <- match.call(expand.dots = FALSE) mf[[1L]] <- as.name("lm") mf$data <- data mf$x <- mf$y <- mf$singular.ok <- TRUE mf$qr <- FALSE - mf$prior <- mf$prior_intercept <- mf$prior_PD <- mf$algorithm <- + mf$prior <- mf$prior_intercept <- mf$prior_PD <- mf$algorithm <- mf$adapt_delta <- NULL mf$method <- "model.frame" modelframe <- suppressWarnings(eval(mf, parent.frame())) @@ -151,28 +161,48 @@ stan_lm <- function(formula, data, subset, weights, na.action, X <- model.matrix(mt, modelframe, contrasts) w <- as.vector(model.weights(modelframe)) offset <- as.vector(model.offset(modelframe)) - stanfit <- stan_lm.wfit(y = Y, x = X, w, offset, singular.ok = singular.ok, - prior = prior, prior_intercept = prior_intercept, - prior_PD = prior_PD, - algorithm = algorithm, adapt_delta = adapt_delta, - ...) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) - fit <- nlist(stanfit, family = gaussian(), formula, offset, weights = w, - x = X[,intersect(colnames(X), dimnames(stanfit)[[3]]), drop = FALSE], - y = Y, - data = data, - prior.info = prior, - algorithm, call, terms = mt, - model = if (model) modelframe else NULL, - na.action = attr(modelframe, "na.action"), - contrasts = attr(X, "contrasts"), - stan_function = "stan_lm") + stanfit <- stan_lm.wfit( + y = Y, + x = X, + w, + offset, + singular.ok = singular.ok, + prior = prior, + prior_intercept = prior_intercept, + prior_PD = prior_PD, + algorithm = algorithm, + adapt_delta = adapt_delta, + ... + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } + fit <- nlist( + stanfit, + family = gaussian(), + formula, + offset, + weights = w, + x = X[, intersect(colnames(X), dimnames(stanfit)[[3]]), drop = FALSE], + y = Y, + data = data, + prior.info = prior, + algorithm, + call, + terms = mt, + model = if (model) modelframe else NULL, + na.action = attr(modelframe, "na.action"), + contrasts = attr(X, "contrasts"), + stan_function = "stan_lm" + ) out <- stanreg(fit) out$xlevels <- .getXlevels(mt, modelframe) - if (!x) + if (!x) { out$x <- NULL - if (!y) + } + if (!y) { out$y <- NULL - + } + return(out) } diff --git a/R/stan_mvmer.R b/R/stan_mvmer.R index 9c3b81c31..fd9dc8b27 100644 --- a/R/stan_mvmer.R +++ b/R/stan_mvmer.R @@ -1,28 +1,28 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University # Copyright (C) 2016, 2017 Sam Brilleman -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. -#' Bayesian multivariate generalized linear models with correlated +#' Bayesian multivariate generalized linear models with correlated #' group-specific terms via Stan -#' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Bayesian inference for multivariate GLMs with group-specific coefficients +#' +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' Bayesian inference for multivariate GLMs with group-specific coefficients #' that are assumed to be correlated across the GLM submodels. -#' +#' #' @export #' @template args-dots #' @template args-prior_PD @@ -31,90 +31,90 @@ #' @template args-max_treedepth #' @template args-QR #' @template args-sparse -#' -#' @param formula A two-sided linear formula object describing both the -#' fixed-effects and random-effects parts of the longitudinal submodel +#' +#' @param formula A two-sided linear formula object describing both the +#' fixed-effects and random-effects parts of the longitudinal submodel #' similar in vein to formula specification in the \strong{lme4} package -#' (see \code{\link[lme4]{glmer}} or the \strong{lme4} vignette for details). -#' Note however that the double bar (\code{||}) notation is not allowed +#' (see \code{\link[lme4]{glmer}} or the \strong{lme4} vignette for details). +#' Note however that the double bar (\code{||}) notation is not allowed #' when specifying the random-effects parts of the formula, and neither -#' are nested grouping factors (e.g. \code{(1 | g1/g2))} or -#' \code{(1 | g1:g2)}, where \code{g1}, \code{g2} are grouping factors. -#' For a multivariate GLM this should be a list of such formula objects, -#' with each element of the list providing the formula for one of the +#' are nested grouping factors (e.g. \code{(1 | g1/g2))} or +#' \code{(1 | g1:g2)}, where \code{g1}, \code{g2} are grouping factors. +#' For a multivariate GLM this should be a list of such formula objects, +#' with each element of the list providing the formula for one of the #' GLM submodels. #' @param data A data frame containing the variables specified in #' \code{formula}. For a multivariate GLM, this can -#' be either a single data frame which contains the data for all +#' be either a single data frame which contains the data for all #' GLM submodels, or it can be a list of data frames where each #' element of the list provides the data for one of the GLM submodels. -#' @param family The family (and possibly also the link function) for the -#' GLM submodel(s). See \code{\link[lme4]{glmer}} for details. +#' @param family The family (and possibly also the link function) for the +#' GLM submodel(s). See \code{\link[lme4]{glmer}} for details. #' If fitting a multivariate GLM, then this can optionally be a #' list of families, in which case each element of the list specifies the #' family for one of the GLM submodels. In other words, a different family -#' can be specified for each GLM submodel. +#' can be specified for each GLM submodel. #' @param weights Same as in \code{\link[stats]{glm}}, -#' except that when fitting a multivariate GLM and a list of data frames -#' is provided in \code{data} then a corresponding list of weights -#' must be provided. If weights are -#' provided for one of the GLM submodels, then they must be provided for +#' except that when fitting a multivariate GLM and a list of data frames +#' is provided in \code{data} then a corresponding list of weights +#' must be provided. If weights are +#' provided for one of the GLM submodels, then they must be provided for #' all GLM submodels. #' @param prior,prior_intercept,prior_aux Same as in \code{\link{stan_glmer}} -#' except that for a multivariate GLM a list of priors can be provided for -#' any of \code{prior}, \code{prior_intercept} or \code{prior_aux} arguments. -#' That is, different priors can optionally be specified for each of the GLM -#' submodels. If a list is not provided, then the same prior distributions are +#' except that for a multivariate GLM a list of priors can be provided for +#' any of \code{prior}, \code{prior_intercept} or \code{prior_aux} arguments. +#' That is, different priors can optionally be specified for each of the GLM +#' submodels. If a list is not provided, then the same prior distributions are #' used for each GLM submodel. Note that the \code{"product_normal"} prior is #' not allowed for \code{stan_mvmer}. #' @param prior_covariance Cannot be \code{NULL}; see \code{\link{priors}} for #' more information about the prior distributions on covariance matrices. -#' Note however that the default prior for covariance matrices in -#' \code{stan_mvmer} is slightly different to that in \code{\link{stan_glmer}} +#' Note however that the default prior for covariance matrices in +#' \code{stan_mvmer} is slightly different to that in \code{\link{stan_glmer}} #' (the details of which are described on the \code{\link{priors}} page). #' @param init The method for generating initial values. See #' \code{\link[rstan]{stan}}. -#' +#' #' @details The \code{stan_mvmer} function can be used to fit a multivariate #' generalized linear model (GLM) with group-specific terms. The model consists #' of distinct GLM submodels, each which contains group-specific terms; within #' a grouping factor (for example, patient ID) the grouping-specific terms are -#' assumed to be correlated across the different GLM submodels. It is +#' assumed to be correlated across the different GLM submodels. It is #' possible to specify a different outcome type (for example a different #' family and/or link function) for each of the GLM submodels. \cr #' \cr -#' Bayesian estimation of the model is performed via MCMC, in the same way as +#' Bayesian estimation of the model is performed via MCMC, in the same way as #' for \code{\link{stan_glmer}}. Also, similar to \code{\link{stan_glmer}}, -#' an unstructured covariance matrix is used for the group-specific terms +#' an unstructured covariance matrix is used for the group-specific terms #' within a given grouping factor, with priors on the terms of a decomposition -#' of the covariance matrix.See \code{\link{priors}} for more information about -#' the priors distributions that are available for the covariance matrices, +#' of the covariance matrix.See \code{\link{priors}} for more information about +#' the priors distributions that are available for the covariance matrices, #' the regression coefficients and the intercept and auxiliary parameters. #' #' @return A \link[=stanreg-objects]{stanmvreg} object is returned. -#' +#' #' @seealso \code{\link{stan_glmer}}, \code{\link{stan_jm}}, -#' \code{\link{stanreg-objects}}, \code{\link{stanmvreg-methods}}, +#' \code{\link{stanreg-objects}}, \code{\link{stanmvreg-methods}}, #' \code{\link{print.stanmvreg}}, \code{\link{summary.stanmvreg}}, #' \code{\link{posterior_predict}}, \code{\link{posterior_interval}}. -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch !="i386") { #' \donttest{ #' ##### -#' # A multivariate GLM with two submodels. For the grouping factor 'id', the +#' # A multivariate GLM with two submodels. For the grouping factor 'id', the #' # group-specific intercept from the first submodel (logBili) is assumed to -#' # be correlated with the group-specific intercept and linear slope in the +#' # be correlated with the group-specific intercept and linear slope in the #' # second submodel (albumin) #' f1 <- stan_mvmer( #' formula = list( -#' logBili ~ year + (1 | id), +#' logBili ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), -#' data = pbcLong, +#' data = pbcLong, #' # this next line is only to keep the example small in size! #' chains = 1, cores = 1, seed = 12345, iter = 1000) -#' summary(f1) -#' +#' summary(f1) +#' #' ##### #' # A multivariate GLM with one bernoulli outcome and one #' # gaussian outcome. We will artificially create the bernoulli @@ -122,91 +122,142 @@ #' pbcLong$ybern <- as.integer(pbcLong$logBili >= mean(pbcLong$logBili)) #' f2 <- stan_mvmer( #' formula = list( -#' ybern ~ year + (1 | id), +#' ybern ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), #' data = pbcLong, #' family = list(binomial, gaussian), #' chains = 1, cores = 1, seed = 12345, iter = 1000) #' } #' } -stan_mvmer <- function(formula, data, family = gaussian, weights, - prior = normal(autoscale=TRUE), prior_intercept = normal(autoscale=TRUE), - prior_aux = cauchy(0, 5, autoscale=TRUE), - prior_covariance = lkj(autoscale=TRUE), prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, max_treedepth = 10L, - init = "random", QR = FALSE, sparse = FALSE, ...) { - +stan_mvmer <- function( + formula, + data, + family = gaussian, + weights, + prior = normal(autoscale = TRUE), + prior_intercept = normal(autoscale = TRUE), + prior_aux = cauchy(0, 5, autoscale = TRUE), + prior_covariance = lkj(autoscale = TRUE), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + max_treedepth = 10L, + init = "random", + QR = FALSE, + sparse = FALSE, + ... +) { #----------------------------- # Pre-processing of arguments - #----------------------------- - + #----------------------------- + algorithm <- match.arg(algorithm) - - if (missing(weights)) weights <- NULL - - if (!is.null(weights)) + + if (missing(weights)) { + weights <- NULL + } + + if (!is.null(weights)) { stop("'weights' are not yet implemented.") - if (QR) + } + if (QR) { stop("'QR' decomposition is not yet implemented.") - if (sparse) + } + if (sparse) { stop("'sparse' option is not yet implemented.") - + } + # Formula - formula <- validate_arg(formula, "formula"); M <- length(formula) - if (M > 3L) - stop("'stan_mvmer' is currently limited to a maximum of 3 outcomes.") - + formula <- validate_arg(formula, "formula") + M <- length(formula) + if (M > 3L) { + stop("'stan_mvmer' is currently limited to a maximum of 3 outcomes.") + } + # Data - data <- validate_arg(data, "data.frame", validate_length = M) + data <- validate_arg(data, "data.frame", validate_length = M) data <- xapply(formula, data, FUN = get_all_vars) # drop additional vars - + # Family ok_classes <- c("function", "family", "character") - ok_families <- c("binomial", "gaussian", "Gamma", - "inverse.gaussian", "poisson", "neg_binomial_2") + ok_families <- c( + "binomial", + "gaussian", + "Gamma", + "inverse.gaussian", + "poisson", + "neg_binomial_2" + ) family <- validate_arg(family, ok_classes, validate_length = M) family <- lapply(family, validate_famlink, ok_families) # Observation weights if (!is.null(weights)) { - if (!is(weights, "list")) + if (!is(weights, "list")) { weights <- rep(list(weights), M) + } weights <- lapply(weights, validate_weights) } - + # Is prior* already a list? prior <- broadcast_prior(prior, M) prior_intercept <- broadcast_prior(prior_intercept, M) prior_aux <- broadcast_prior(prior_aux, M) - + #----------- # Fit model - #----------- - - stanfit <- stan_jm.fit(formulaLong = formula, dataLong = data, family = family, - weights = weights, priorLong = prior, - priorLong_intercept = prior_intercept, priorLong_aux = prior_aux, - prior_covariance = prior_covariance, prior_PD = prior_PD, - algorithm = algorithm, adapt_delta = adapt_delta, - max_treedepth = max_treedepth, init = init, - QR = QR, sparse = sparse, ...) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) + #----------- + + stanfit <- stan_jm.fit( + formulaLong = formula, + dataLong = data, + family = family, + weights = weights, + priorLong = prior, + priorLong_intercept = prior_intercept, + priorLong_aux = prior_aux, + prior_covariance = prior_covariance, + prior_PD = prior_PD, + algorithm = algorithm, + adapt_delta = adapt_delta, + max_treedepth = max_treedepth, + init = init, + QR = QR, + sparse = sparse, + ... + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } y_mod <- attr(stanfit, "y_mod") - cnms <- attr(stanfit, "cnms") + cnms <- attr(stanfit, "cnms") flevels <- attr(stanfit, "flevels") prior_info <- attr(stanfit, "prior_info") stanfit <- drop_attributes(stanfit, "y_mod", "cnms", "flevels", "prior_info") - + terms <- fetch(y_mod, "terms") n_yobs <- fetch_(y_mod, "x", "N") n_grps <- sapply(flevels, n_distinct) - - fit <- nlist(stanfit, formula, family, weights, M, cnms, flevels, n_grps, n_yobs, - algorithm, terms, glmod = y_mod, data, prior.info = prior_info, - stan_function = "stan_mvmer", call = match.call(expand.dots = TRUE)) - + + fit <- nlist( + stanfit, + formula, + family, + weights, + M, + cnms, + flevels, + n_grps, + n_yobs, + algorithm, + terms, + glmod = y_mod, + data, + prior.info = prior_info, + stan_function = "stan_mvmer", + call = match.call(expand.dots = TRUE) + ) + out <- stanmvreg(fit) return(out) } - diff --git a/R/stan_nlmer.R b/R/stan_nlmer.R index a215551aa..44b6a4d88 100644 --- a/R/stan_nlmer.R +++ b/R/stan_nlmer.R @@ -1,24 +1,24 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2016 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian nonlinear models with group-specific terms via Stan -#' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Bayesian inference for NLMMs with group-specific coefficients that have +#' +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' Bayesian inference for NLMMs with group-specific coefficients that have #' unknown covariance matrices with flexible priors. #' #' @export @@ -35,39 +35,39 @@ #' @template args-adapt_delta #' @template args-sparse #' @template args-QR -#' +#' #' @param formula,data Same as for \code{\link[lme4]{nlmer}}. \emph{We strongly #' advise against omitting the \code{data} argument}. Unless \code{data} is #' specified (and is a data frame) many post-estimation functions (including #' \code{update}, \code{loo}, \code{kfold}) are not guaranteed to work #' properly. #' @param subset,weights,offset Same as \code{\link[stats]{glm}}. -#' @param na.action,contrasts Same as \code{\link[stats]{glm}}, but rarely +#' @param na.action,contrasts Same as \code{\link[stats]{glm}}, but rarely #' specified. #' @param prior_covariance Cannot be \code{NULL}; see \code{\link{decov}} for #' more information about the default arguments. #' -#' @details The \code{stan_nlmer} function is similar in syntax to -#' \code{\link[lme4]{nlmer}} but rather than performing (approximate) maximum +#' @details The \code{stan_nlmer} function is similar in syntax to +#' \code{\link[lme4]{nlmer}} but rather than performing (approximate) maximum #' marginal likelihood estimation, Bayesian estimation is by default performed #' via MCMC. The Bayesian model adds independent priors on the "coefficients" -#' --- which are really intercepts --- in the same way as -#' \code{\link{stan_nlmer}} and priors on the terms of a decomposition of the +#' --- which are really intercepts --- in the same way as +#' \code{\link{stan_nlmer}} and priors on the terms of a decomposition of the #' covariance matrices of the group-specific parameters. See #' \code{\link{priors}} for more information about the priors. -#' -#' The supported transformation functions are limited to the named +#' +#' The supported transformation functions are limited to the named #' "self-starting" functions in the \pkg{stats} library: #' \code{\link[stats]{SSasymp}}, \code{\link[stats]{SSasympOff}}, #' \code{\link[stats]{SSasympOrig}}, \code{\link[stats]{SSbiexp}}, #' \code{\link[stats]{SSfol}}, \code{\link[stats]{SSfpl}}, #' \code{\link[stats]{SSgompertz}}, \code{\link[stats]{SSlogis}}, #' \code{\link[stats]{SSmicmen}}, and \code{\link[stats]{SSweibull}}. -#' -#' -#' @seealso The vignette for \code{stan_glmer}, which also discusses +#' +#' +#' @seealso The vignette for \code{stan_glmer}, which also discusses #' \code{stan_nlmer} models. \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch !="i386") { #' \donttest{ @@ -75,12 +75,12 @@ #' Orange$circumference <- Orange$circumference / 100 #' Orange$age <- Orange$age / 100 #' fit <- stan_nlmer( -#' circumference ~ SSlogis(age, Asym, xmid, scal) ~ Asym|Tree, -#' data = Orange, +#' circumference ~ SSlogis(age, Asym, xmid, scal) ~ Asym|Tree, +#' data = Orange, #' # for speed only -#' chains = 1, +#' chains = 1, #' iter = 1000 -#' ) +#' ) #' print(fit) #' posterior_interval(fit) #' plot(fit, regex_pars = "b\\[") @@ -89,101 +89,130 @@ #' @importFrom lme4 nlformula #' @importFrom stats getInitial stan_nlmer <- - function(formula, - data = NULL, - subset, - weights, - na.action, - offset, - contrasts = NULL, - ..., - prior = normal(autoscale=TRUE), - prior_aux = exponential(autoscale=TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE) { - - if (!has_outcome_variable(formula[[2]])) { - stop("LHS of formula must be specified.") - } - f <- as.character(formula[-3]) - SSfunctions <- grep("^SS[[:lower:]]+", ls("package:stats"), value = TRUE) - SSfun <- sapply(SSfunctions, function(ss) - grepl(paste0(ss, "("), x = f[2], fixed = TRUE)) - if (!any(SSfun)) { - stop("'stan_nlmer' requires a named self-starting nonlinear function.") - } - SSfun <- which(SSfun) - SSfun_char <- names(SSfun) - - mc <- match.call(expand.dots = FALSE) - mc$prior <- mc$prior_aux <- mc$prior_covariance <- mc$prior_PD <- - mc$algorithm <- mc$adapt_delta <- mc$QR <- mc$sparse <- NULL - mc$start <- - unlist(getInitial( - object = as.formula(f[-1]), - data = data, - control = list(maxiter = 0, warnOnly = TRUE) - )) - - nlf <- nlformula(mc) - X <- nlf$X - y <- nlf$respMod$y - weights <- nlf$respMod$weights - offset <- nlf$respMod$offset - - nlf$reTrms$SSfun <- SSfun - nlf$reTrms$decov <- prior_covariance - - nlf_inputs <- parse_nlf_inputs(nlf$respMod) - if (SSfun_char == "SSfol") { - nlf$reTrms$Dose <- nlf$frame[[nlf_inputs[2]]] - nlf$reTrms$input <- nlf$frame[[nlf_inputs[3]]] - } else { - nlf$reTrms$input <- nlf$frame[[nlf_inputs[2]]] - } - - - algorithm <- match.arg(algorithm) - stanfit <- stan_glm.fit(x = X, y = y, family = gaussian(link = "identity"), - weights = weights, offset = offset, - prior = prior, prior_intercept = NULL, - prior_aux = prior_aux, prior_PD = prior_PD, - algorithm = algorithm, adapt_delta = adapt_delta, - group = nlf$reTrms, QR = QR, sparse = sparse, ...) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } - - if (SSfun_char == "SSfpl") { # SSfun = 6 - stanfit@sim$samples <- lapply(stanfit@sim$samples, FUN = function(x) { - x[[4L]] <- exp(x[[4L]]) - return(x) - }) - } else if (SSfun_char == "SSlogis") { # SSfun = 8 - stanfit@sim$samples <- lapply(stanfit@sim$samples, FUN = function(x) { - x[[3L]] <- exp(x[[3L]]) - return(x) + function( + formula, + data = NULL, + subset, + weights, + na.action, + offset, + contrasts = NULL, + ..., + prior = normal(autoscale = TRUE), + prior_aux = exponential(autoscale = TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE + ) { + if (!has_outcome_variable(formula[[2]])) { + stop("LHS of formula must be specified.") + } + f <- as.character(formula[-3]) + SSfunctions <- grep("^SS[[:lower:]]+", ls("package:stats"), value = TRUE) + SSfun <- sapply(SSfunctions, function(ss) { + grepl(paste0(ss, "("), x = f[2], fixed = TRUE) }) + if (!any(SSfun)) { + stop("'stan_nlmer' requires a named self-starting nonlinear function.") + } + SSfun <- which(SSfun) + SSfun_char <- names(SSfun) + + mc <- match.call(expand.dots = FALSE) + mc$prior <- mc$prior_aux <- mc$prior_covariance <- mc$prior_PD <- + mc$algorithm <- mc$adapt_delta <- mc$QR <- mc$sparse <- NULL + mc$start <- + unlist(getInitial( + object = as.formula(f[-1]), + data = data, + control = list(maxiter = 0, warnOnly = TRUE) + )) + + nlf <- nlformula(mc) + X <- nlf$X + y <- nlf$respMod$y + weights <- nlf$respMod$weights + offset <- nlf$respMod$offset + + nlf$reTrms$SSfun <- SSfun + nlf$reTrms$decov <- prior_covariance + + nlf_inputs <- parse_nlf_inputs(nlf$respMod) + if (SSfun_char == "SSfol") { + nlf$reTrms$Dose <- nlf$frame[[nlf_inputs[2]]] + nlf$reTrms$input <- nlf$frame[[nlf_inputs[3]]] + } else { + nlf$reTrms$input <- nlf$frame[[nlf_inputs[2]]] + } + + algorithm <- match.arg(algorithm) + stanfit <- stan_glm.fit( + x = X, + y = y, + family = gaussian(link = "identity"), + weights = weights, + offset = offset, + prior = prior, + prior_intercept = NULL, + prior_aux = prior_aux, + prior_PD = prior_PD, + algorithm = algorithm, + adapt_delta = adapt_delta, + group = nlf$reTrms, + QR = QR, + sparse = sparse, + ... + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } + + if (SSfun_char == "SSfpl") { + # SSfun = 6 + stanfit@sim$samples <- lapply(stanfit@sim$samples, FUN = function(x) { + x[[4L]] <- exp(x[[4L]]) + return(x) + }) + } else if (SSfun_char == "SSlogis") { + # SSfun = 8 + stanfit@sim$samples <- lapply(stanfit@sim$samples, FUN = function(x) { + x[[3L]] <- exp(x[[3L]]) + return(x) + }) + } + + Z <- pad_reTrms( + Ztlist = nlf$reTrms$Ztlist, + cnms = nlf$reTrms$cnms, + flist = nlf$reTrms$flist + )$Z + colnames(Z) <- b_names(names(stanfit), value = TRUE) + + fit <- nlist( + stanfit, + family = make_nlf_family(SSfun_char, nlf), + formula, + offset, + weights, + x = cbind(X, Z), + y = y, + data, + call = match.call(), + terms = NULL, + model = NULL, + na.action = na.omit, + contrasts, + algorithm, + glmod = nlf, + stan_function = "stan_nlmer" + ) + out <- stanreg(fit) + class(out) <- c(class(out), "nlmerMod", "lmerMod") + return(out) } - - Z <- pad_reTrms(Ztlist = nlf$reTrms$Ztlist, cnms = nlf$reTrms$cnms, - flist = nlf$reTrms$flist)$Z - colnames(Z) <- b_names(names(stanfit), value = TRUE) - - fit <- nlist(stanfit, - family = make_nlf_family(SSfun_char, nlf), - formula, offset, weights, - x = cbind(X, Z), y = y, data, call = match.call(), terms = NULL, - model = NULL, na.action = na.omit, contrasts, algorithm, - glmod = nlf, stan_function = "stan_nlmer") - out <- stanreg(fit) - class(out) <- c(class(out), "nlmerMod", "lmerMod") - return(out) -} # internal ---------------------------------------------------------------- @@ -205,8 +234,8 @@ parse_nlf_inputs <- function(respMod) { ) } -# Make family object -# +# Make family object +# # @param SSfun_char SS function name as a string # @param nlf Object returned by nlformula # @return A family object @@ -222,20 +251,27 @@ make_nlf_family <- function(SSfun_char, nlf) { end <- i * len t(eta[, start:end, drop = FALSE]) }) - if (is.null(arg2)) SSargs <- c(list(arg1), SSargs) - else SSargs <- c(list(arg1, arg2), SSargs) + if (is.null(arg2)) { + SSargs <- c(list(arg1), SSargs) + } else { + SSargs <- c(list(arg1, arg2), SSargs) + } } else { - SSargs <- as.data.frame(matrix(eta, nrow = length(arg1))) - if (is.null(arg2)) SSargs <- cbind(arg1, SSargs) - else SSargs <- cbind(arg1, arg2, SSargs) + SSargs <- as.data.frame(matrix(eta, nrow = length(arg1))) + if (is.null(arg2)) { + SSargs <- cbind(arg1, SSargs) + } else { + SSargs <- cbind(arg1, arg2, SSargs) + } } names(SSargs) <- names(formals(FUN)) - if (FUN == "SSbiexp") + if (FUN == "SSbiexp") { SSargs$A1 <- SSargs$A1 + exp(SSargs$A2) - + } + do.call(FUN, args = SSargs) } - + nlf_inputs <- parse_nlf_inputs(nlf$respMod) if (SSfun_char == "SSfol") { formals(g$linkinv)$arg1 <- nlf$frame[[nlf_inputs[2]]] @@ -243,9 +279,9 @@ make_nlf_family <- function(SSfun_char, nlf) { } else { formals(g$linkinv)$arg1 <- nlf$frame[[nlf_inputs[2]]] } - - g$linkfun <- function(mu) stop("'linkfun' should not have been called") + + g$linkfun <- function(mu) stop("'linkfun' should not have been called") g$variance <- function(mu) stop("'variance' should not have been called") - g$mu.eta <- function(mu) stop("'mu.eta' should not have been called") + g$mu.eta <- function(mu) stop("'mu.eta' should not have been called") return(g) } diff --git a/R/stan_polr.R b/R/stan_polr.R index ebfbc9b08..a870c108f 100644 --- a/R/stan_polr.R +++ b/R/stan_polr.R @@ -18,7 +18,7 @@ #' Bayesian ordinal regression models via Stan #' -#' \if{html}{\figure{stanlogo.png}{options: width="25" alt="https://mc-stan.org/about/logo/"}} +#' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' Bayesian inference for ordinal (or binary) regression models under a #' proportional odds assumption. #' @@ -56,13 +56,13 @@ #' the exponent applied to the probability of success when there are only #' two outcome categories. If \code{NULL}, which is the default, then the #' exponent is taken to be fixed at \eqn{1}. -#' @param do_residuals A logical scalar indicating whether or not to +#' @param do_residuals A logical scalar indicating whether or not to #' automatically calculate fit residuals after sampling completes. Defaults to #' \code{TRUE} if and only if \code{algorithm="sampling"}. Setting #' \code{do_residuals=FALSE} is only useful in the somewhat rare case that #' \code{stan_polr} appears to finish sampling but hangs instead of returning #' the fitted model object. -#' +#' #' @details The \code{stan_polr} function is similar in syntax to #' \code{\link[MASS]{polr}} but rather than performing maximum likelihood #' estimation of a proportional odds model, Bayesian estimation is performed @@ -128,24 +128,31 @@ #' } #' #' @importFrom utils packageVersion -stan_polr <- function(formula, data, weights, ..., subset, - na.action = getOption("na.action", "na.omit"), - contrasts = NULL, model = TRUE, - method = c("logistic", "probit", "loglog", "cloglog", - "cauchit"), - prior = R2(stop("'location' must be specified")), - prior_counts = dirichlet(1), shape = NULL, rate = NULL, - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - do_residuals = NULL) { - +stan_polr <- function( + formula, + data, + weights, + ..., + subset, + na.action = getOption("na.action", "na.omit"), + contrasts = NULL, + model = TRUE, + method = c("logistic", "probit", "loglog", "cloglog", "cauchit"), + prior = R2(stop("'location' must be specified")), + prior_counts = dirichlet(1), + shape = NULL, + rate = NULL, + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + do_residuals = NULL +) { data <- validate_data(data, if_missing = environment(formula)) is_char <- which(sapply(data, is.character)) for (j in is_char) { data[[j]] <- as.factor(data[[j]]) } - + algorithm <- match.arg(algorithm) if (is.null(do_residuals)) { do_residuals <- algorithm == "sampling" @@ -160,8 +167,8 @@ stan_polr <- function(formula, data, weights, ..., subset, m$data <- data } m$method <- m$model <- m$... <- m$prior <- m$prior_counts <- - m$prior_PD <- m$algorithm <- m$adapt_delta <- m$shape <- m$rate <- - m$do_residuals <- NULL + m$prior_PD <- m$algorithm <- m$adapt_delta <- m$shape <- m$rate <- + m$do_residuals <- NULL m[[1L]] <- quote(stats::model.frame) m$drop.unused.levels <- FALSE m <- eval.parent(m) @@ -175,21 +182,27 @@ stan_polr <- function(formula, data, weights, ..., subset, if (xint > 0L) { x <- x[, -xint, drop = FALSE] pc <- pc - 1L - } else stop("an intercept is needed and assumed") + } else { + stop("an intercept is needed and assumed") + } K <- ncol(x) wt <- model.weights(m) - if (!length(wt)) + if (!length(wt)) { wt <- rep(1, n) + } offset <- model.offset(m) - if (length(offset) <= 1L) + if (length(offset) <= 1L) { offset <- rep(0, n) + } y <- model.response(m) - if (!is.factor(y)) + if (!is.factor(y)) { stop("Response variable must be a factor.", call. = FALSE) + } lev <- levels(y) llev <- length(lev) - if (llev < 2L) + if (llev < 2L) { stop("Response variable must have 2 or more levels.", call. = FALSE) + } # y <- unclass(y) q <- llev - 1L @@ -210,28 +223,48 @@ stan_polr <- function(formula, data, weights, ..., subset, do_residuals = do_residuals, ... ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } inverse_link <- linkinv(method) - if (llev == 2L) { # actually a Bernoulli model - family <- switch(method, - logistic = binomial(link = "logit"), - loglog = binomial(loglog), - binomial(link = method)) - fit <- nlist(stanfit, family, formula, offset, weights = wt, - x = cbind("(Intercept)" = 1, x), y = as.integer(y == lev[2]), - data, call, terms = Terms, model = m, - algorithm, na.action = attr(m, "na.action"), - contrasts = attr(x, "contrasts"), - stan_function = "stan_polr") + if (llev == 2L) { + # actually a Bernoulli model + family <- switch( + method, + logistic = binomial(link = "logit"), + loglog = binomial(loglog), + binomial(link = method) + ) + fit <- nlist( + stanfit, + family, + formula, + offset, + weights = wt, + x = cbind("(Intercept)" = 1, x), + y = as.integer(y == lev[2]), + data, + call, + terms = Terms, + model = m, + algorithm, + na.action = attr(m, "na.action"), + contrasts = attr(x, "contrasts"), + stan_function = "stan_polr" + ) out <- stanreg(fit) - if (!model) + if (!model) { out$model <- NULL - if (algorithm == "sampling") + } + if (algorithm == "sampling") { check_rhats(out$stan_summary[, "Rhat"]) - - if (is.null(shape) && is.null(rate)) # not a scobit model + } + + if (is.null(shape) && is.null(rate)) { + # not a scobit model return(out) + } out$method <- method return(structure(out, class = c("stanreg", "polr"))) @@ -243,7 +276,7 @@ stan_polr <- function(formula, data, weights, ..., subset, covmat <- cov(stanmat) coefs <- apply(stanmat[, 1:K, drop = FALSE], 2L, median) ses <- apply(stanmat[, 1:K, drop = FALSE], 2L, mad) - zeta <- apply(stanmat[, (K+1):K2, drop = FALSE], 2L, median) + zeta <- apply(stanmat[, (K + 1):K2, drop = FALSE], 2L, median) eta <- linear_predictor(coefs, x, offset) mu <- inverse_link(eta) @@ -257,34 +290,54 @@ stan_polr <- function(formula, data, weights, ..., subset, names(residuals) <- rownames(x) } stan_summary <- make_stan_summary(stanfit) - if (algorithm == "sampling") + if (algorithm == "sampling") { check_rhats(stan_summary[, "Rhat"]) + } - out <- nlist(coefficients = coefs, ses, zeta, residuals, - fitted.values = mu, linear.predictors = eta, covmat, - y, x, model = if (model) m, data, - offset, weights = wt, prior.weights = wt, - family = method, method, contrasts, na.action, - call, formula, terms = Terms, - prior.info = attr(stanfit, "prior.info"), - algorithm, stan_summary, stanfit, - rstan_version = packageVersion("rstan"), - stan_function = "stan_polr") + out <- nlist( + coefficients = coefs, + ses, + zeta, + residuals, + fitted.values = mu, + linear.predictors = eta, + covmat, + y, + x, + model = if (model) m, + data, + offset, + weights = wt, + prior.weights = wt, + family = method, + method, + contrasts, + na.action, + call, + formula, + terms = Terms, + prior.info = attr(stanfit, "prior.info"), + algorithm, + stan_summary, + stanfit, + rstan_version = packageVersion("rstan"), + stan_function = "stan_polr" + ) structure(out, class = c("stanreg", "polr")) } - # internal ---------------------------------------------------------------- # CDF, inverse-CDF and PDF for Gumbel distribution -pgumbel <- function (q, loc = 0, scale = 1, lower.tail = TRUE) { - q <- (q - loc)/scale +pgumbel <- function(q, loc = 0, scale = 1, lower.tail = TRUE) { + q <- (q - loc) / scale p <- exp(-exp(-q)) - if (!lower.tail) + if (!lower.tail) { 1 - p - else + } else { p + } } qgumbel <- function(p, loc = 0, scale = 1) { loc - scale * log(-log(p)) @@ -292,12 +345,18 @@ qgumbel <- function(p, loc = 0, scale = 1) { dgumbel <- function(x, loc = 0, scale = 1, log = FALSE) { z <- (x - loc) / scale log_f <- -(z + exp(-z)) - if (!log) + if (!log) { exp(log_f) - else + } else { log_f + } } -loglog <- list(linkfun = qgumbel, linkinv = pgumbel, mu.eta = dgumbel, - valideta = function(eta) TRUE, name = "loglog") +loglog <- list( + linkfun = qgumbel, + linkinv = pgumbel, + mu.eta = dgumbel, + valideta = function(eta) TRUE, + name = "loglog" +) class(loglog) <- "link-glm" diff --git a/man/figures/logo.svg b/man/figures/logo.svg deleted file mode 100644 index b4c09fc5d..000000000 --- a/man/figures/logo.svg +++ /dev/null @@ -1,96 +0,0 @@ - - - - diff --git a/man/figures/stanlogo.png b/man/figures/stanlogo.png deleted file mode 100644 index 4a4f06aa9e11cc8772bfbc428651c85adac16f38..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 16172 zcmX9_1z1$i*CwTuPU-HJk_HK30cnu#kX&M=OMXaqEFHRllyonMbeH790@Afe3W$8y z|HrfY?8DxjJ9o}GbLPyv?;HC@TkRSCb9^*3v}do?U+JNtp+kW8d)z0$H+5O*Gz7r>V^zA7fZ`ks!y5F4-q8Uz9naPfHO zV`t;#Am9mh$~%>Lj)umB_WG5g!TbEDK8yt`Wvh9J9@Y>bjxPPqeF}c@znK@ zT!3VIqS)zd|*$kYvbgjK(HZOMMjWUyz&-u%5mZX zj!E-ajTkc#{pm{9H-^=XAvpwLNEg%LZRp($HJ8clV%r{{#$Ur{nJ>n4I1L&JWFO$dJImIV9YXm>wC`zqB1(TUxSpR+5S z%>AC1yn7+_PibLuUT}=?vfYj)3#G1)z;Fz92tnP+2WOB@GiHzeZ*SHbqFX|{yQ$Ic zkNh!Sykeddzn{L@18zVQMzKAFP9ZV1HPD0-f_YXW;-`aEpViv;;zV!jGm!=F34hj* z;5scw|6@(aUw5Z%7YGdIBcILI(#LJq$k6=0^*uxe`SO#I#}E6hPW7+}$n!Z-qf-@Y zlAlRrh-|EYPNh)@gMP~_Qx9dD=a0GTNT8b_qf=}?pYOVR@=?KPxFLJOFin=TplLzV z5h?-R8;qtDZ!y9fnv|*t4P-!qRL;0|=3OWCZQR9bR&W(RBOXOBO&+qFIpKa)cq=D^s3Y|2m z<=Iu?t5+Xb?MA;@X#Dx5x*)eFtu9p$o=UIn)R1T0r}`TI88+@)Q+?|qeIPjD@Y5d| zFdC5=#PCAbhkgG>QT2Y(Ho>an`8L_JCV}&UPxGejd(%pTKd{=0ctlnqly>;B#hMu# zKc7`w9!P6eHh`zlv0Y%-Jky?-%KuEHaDs8GA`JCBFT(A#)89Y>s2y#cLkB@;w z*Z8L7T25%QcM=IFSlt-Qf#YH)(T^sbNYwu*#LC1L2cyazU6Ez`I^l}&MrwU~+YMnA zN}Oq#yeze2n>8TV*3~p=q-f4S5EC#>y+!GpnsYcvelQesh zUS{`7{(D3(k~1dt#wZ8zms5NkfC5(8y?R*2==k!K$G*ccp{J(pjD05tj8Ih% z^0p=54l<_b9U$*9>%Eg}-_KjNJE6py)L|M4_p)A1D89k%nZlU>jEU^o^Cpx63{{P| znR|88saQ8q=-@gUDMtX#>ph9WJC#i~Jb{xzkH4DjbaJVaHCsJ-X!zH9T026Xw*km2 zZVs9U4XM&!Ge$BCe9Z;-r9+&AIdF`^1+={;C=C9%Pzu6Aa75aTuXo@%E1P(Myk}1U z(~YDhV%*rP?v11ct}Of}v_G$_9_x<9OJ}mg2X_JYzf{JOfd^sM#yAJ~GO)pwX?jLm z5L9|0uqck8+DdM{pe*hc{=d7{qYVfu-H>*so^M9|Ia~FHn;tk2o>Ri0>k6s-2HqQ$ zdARZPQ9Vv(P9Lndtk<3Jl={^X=AHx0D&Zitf#-(9wT|P$`q`>RFL^0_@z^)9n10Rw z&3PvMu2C2wuj2OU8UN^h&oX(m>=?N;H5g@Hcz8xXobg`+R|kiyJkebd+=u$RW!c4t z{T5Br)k7c$Yq49MPR#%5?CZIkv>DA!oYY#+Jif-nZ^$`BaR&pg)%W+u|0AVHDP3xI zWV*TqG?8bQ0#6-(x4dB8D1$fVoEM*UDWs?ISqv@R*Y0j=BcY%G-Vv~8>7Bd+d_y{h z+eP>+hb5k3clEjrHl2ZJ0+IcAbR6&i+fNO=VK={zgGP8s%w<8>m^3w6bJp|7_%jyLpBezuGW?+7S zeV;J`m|{7l#F$~a_UKqWjRd8z3<~#lrjypYO@KfG=+!|dzMF)3~it*_M)QF_fy`;|0Vg20=T!W|>oH(+7iCb<`p7aBlw%p4phSR1#AVn>f!EMgb@B*tFq|iTc1`RTWcX)%fY0W z!2Y2!-(|6(8pqW*^2I-57b`T~asQ;ny;gXQH?GuN{mM5+CY(QjPc512j|_9$fr!z= z8Zh)Ym2Wy@e74)f5w|Aw+0P>QXvi|oA5zJ62xU4IQIxr{ z;$16MV`vOYXpp=y@}F&j@!Aj&!gT#3#W0%Uo}7u?Jz&9w8IT|6-z&Ka`tF}7Y)HqC z#KtJrzT>>TGGFlrmN`%*_b}M1?-QQzjB>9!V1{d4Ukn1f?G8;BQ((~){#?BQa}a?P zdvs&-UXzy6VzrA$6p77tEI^*yjVgZ245BdWAsjy|_-;SI8u^E*_UuiS7Sh9n%vT<>?F^cymdA%7JRP=3(0~0@r~%A7b*hsRAYSB=5QZ(v zPe%Osl=s^9Q?Vu%{H@Na6)=QBd-7N95Lv{XI}mJ^u?n6VUXKCXH9Gf%b_vVbH!jeD zd4_^syJF>FCt+FEuY8J+m8mT~x4;S_C0WOMvqS8m=809k6d&Fjg%?~Ku@D5LkwM?7 zckP~^@8&R^?#8VHm5d2ak-O99@5~--LEdNL{Bu{~N1XL*3@ z?u5K`#3LIT?AO8kei7m^S5w1OR8zjw<8HZ@vz2|58l?0`xq69UqChFwQ1+c!Fb*(e zHA}VA_zD+dlZ+{!Tn~5S%eiMw4+zzx!Hle~%zOF-ntAPkMvNb~FUt>-gv)uxOFuAYtMoM(Jby$_!VOgf%T@;;EW@K%MxHanZtJHfIjzp5u?5{Ci+XYO|u9{xl zPue8>5Lf&7B}3hCyn>;4 z^1F`m=`0SvQvQG!u&;a$;Li<5AK3IaI59XQL6{s3o{ufObU?cmw*u)gR>&=>(J{lm zM9os-FDI!F(iJs^IWQrLG#4g))>+QTs^f3WU$Eo|f_coK4dP%=NAns|8KTQ=`F{JU zs*|S0$$#aJVgff#d<9MUut9{2l1TGAwosl2q&#m`*-dpKf-F)nj-nGMuz;ddc)9gs zuD8dO0sfrG#m{`Sr&+R7EhC5H{uF0A7LS)^Mrr&G#}yyvU9A^S1LHUG-Y`#O3Hl?gg$i}^*&%PIuL11QYW^X~Zmg6S81U(VkgqHhYWoLnHy;>i*q zOcaBa8p^vh;r*Q#!o^cN>wAwr|F#>`F?V-?b542DZ7qe((jhp)uyT>r@EA_smun@Q z-1%6b??%ghYSGrNvQ>pAWAXPgV4V%tkdT@K>F6SHllnZ2<{S6lc=LWW22gxZVDE%!)*84HKxuwqZ)j(<%o}O>6 z_Y7VZg-$^*^z*Zn+Y(oPij@75RSA751bdI#;uB2T#=Jc5bFKUPYENIb7~eFiXl-^h zN9G2XUw?0T#ovee9+`v`d)^wKucB>D(El^A5v#+P^@aywrdYFdfyxaqI(C#NpfM&R zF2o3IU@6B9jO&}hbCp2Lq>i@Hm`3|kTV8jt(*!z~yZ>*bGx3D2=bFCncOzXNzd;d` zSA(*)?j?DOemF^;#g>7YyyX^F2xm9f4THoLDMwOb>?&6rzo=#mi)uoYQ_0k0|{nlOcNjbN9%-fo@Vv8!nV~d7>L?sQp zTC~uW^g5JxI{{dwNFORk^83WisOF;J`{h(HE>DH5wz^~6xbNslE=^+c*B?AE3A#Ih zK$BD1yQH_TCL|+_+#cS^RYs-nPTze(F~Rl#J7ykMMvkLF(O+UpVpDHR=W*jbC)UoL z82u4*-^Y-I*ulT{U(?WV6~GYF_Md^XIp?q~Y~=@+!M_x*sW-1tHxvJewi2 zlNDNZ-6C8^XZ}+=elyqV)& z;g@p1j-~0Tcu=aRB(`MtQ4x*(>FM!}XiVZr!YkTxwWqWg*G#O5WyJcl70ZKsH^ zO-Fy*v2H*8R)8M((oK@0;<8{ON7;*c8U zJb0XoetL{0YnCD!@f_KnFcL}VusEzL?k+t~Qh+8*i7P$&KjE0cD>lWeaa!iythl}DkT+1U?v|a?T>=zxmNDo1hl|xMQ}8{9PWeXZ;1_bgJgnWCXy10oWCa>Kqc|sR2ba?H=4&M z9_vj{KkpbJna}^1pUDa`H`ckJx96gYI8Ji!kUoQ#eb~Ja!t2)Ksc})MZEliF*0Jlkn}q!rVx`>U{r?VshhnA$mrSg-WJjD`|HR45}3nrpXJ{_ z=imjmYx>fj4uNn>uKj3yDvo_GvovRr92?d29GL3TPio2zZGJO!Tly8_u)J|n!H>#7 zL!5knrHtokY%j^H#}h~7Z~lu4xeUJ$$Y&2yMfMngPtI-3#1Yyg5R*uyi7Uf z!X0woLae3lIt+6eW-L5C!K3GKgsL1#>18Q1M(2auW5x9Ig-`j3P!HdtKx1vtTMdIr z@l~!qk}8{w7){jNnh0 zbDqEvKLlXA(NU30jUnsBx^}D5QOT!DbxX%-KUY3BHViF{32g4f5e~8?>6fOk)@&z^ zFw4>|IdN=QQyEN6>f|(ByJFM#T>G6987Ij(nve$D#Ka$2ee?ru1xma`C0+?^P6Dlm zk`8p^Sm(2po~OI#a^Hj;U!*U9uHLJxoKscG;GNe5zLhJQ@(C@Nv1=)h3|rq#YlX9n zNHTiTU`g`eNmh#5w`Fz-n^MdIHN=rP{Q5qmjRspt|IH!G$I$#_vI)ESjik5@tCrNR z3!3sDzu;7J7upfc0=qk-IkDcovAV<7ya9F%EX-nbRki~MrBHNB~oEII}& zc*^tpb&JxX(2;{!67O%#S+TiTL&LxOVQWf>lZY!lyS0NJ^X!j@4>%VJ-Ma4Uy z>J`j5{^lJPX`^oTyll)~!Q|jz@|1?e!Gr_u zXO%Lxl!6}7-EqM4QqTwzUIIv+@; za7gC1Qbu&uH>5L!u|X*=$5yAkuS2&oqPdvbYg+~HGzOM<#bZMsr4G&-1iIgR!e+o@ zEhMx}N>)xv#0ZLa8CR6d>9}7EdPvxRea#e|fBV3m#nJRf}*6O7_S$C~4nv zMJ0gmc)L=_7EJD?MEAzDqfvkGGMAwXvGbnMW;7y-VXf)%$_tSv-uXN1?{3;Jf6?U< zzfu`8)h=RHI$CTxs+g7!v(#w5I_(6#KyFt31i@(O)W4QpS2*Hc3;8BNEe#w~P*&q@ zNwD2&7%I{AeOU4iCSO?>gCW?NGclch*}lYjN_aL`Lof7!xH@RPH)_?Mo zab`RvI)@n&(o}#s*-e4>{l(UAE_)@qC1ftFS`s0AEC5mASf=y5=03l8vT%yHw_8;D z!cXUOVP`Ys5Zd~S$KC8zfY6T-WFHVS;lL|G+`(=%yifS+UZktYjM1pQ1!?cp_1|8I zUbCN$#{F8JxyZP21-MZ&gY)~x^1hGWu|Jo%wz-15K62YMK-vjJW(H4|Ia;Sm90pF2 z4?(Vo$DozwFwg7?v3MN(YHz%EJTIxM`?e)F_9Z{f!hdPS>e^#;wUC3;hWOZD&%A>? z-o*uhgL`>XH|0uc>X)TwTBFuz3>W6tAD#ktO zM5!)!i~A)R3RSvHEIKmm1kDfCGW>{~KhLEZF--q$BvZyXF*EZj((Pv-C}w7}Eo}4Z zDe5&SzNClSmGu_hy2i!z{T7N&;97{0A+Hz+tN9peKVbQ1HZ9=eu%=@F$5)aZgcXVI z_cr?EgVA{3aLs-e$_ir7EEr{X4FP8u7I_5?%PKNyaTNz|CFDm1`f@SY_bY@H)s`jM zq)AO~+^Boj{(j-JAi1~vAj?4rrIuc88z-lh5FwYGg(T?JvwT$bplGfc9P4kX<^T9d zi7!@f7sp@uBHHd1*FIOXRDZPzEpW_IhUMT#-1zb%O`*NU`gN0V=)v$CZ}GiC_Rix+ zyXBxC>@xeLfQgfm==Hazf$IU~LM#T7v+%11)*b0^ZfY0ZLOi>|XJlXOhVZ<5aq}94 z16aK5abM0tQuKsnysIHCBjEvwrA<$S-4(}|*e(=O>y6GihOp?#U;2KWXm?Wc+j_qM z!PQS8f4|J$Wj^!m>{SkB%zVE%uP0bJ^;-!`COj%5PB+%hcWcSI3^JE!TmUXQviG7E z7Q@dWkGT%kOm~mUSBOTDf3{a8UkPP{skOwPFB$m_x(y2QHt*QsM6UvZI-BOB+EoU)y^3y=fGDtNKe10U+fuhO80B5Uw-(HxgrtaE*Jcd_Ihb+=RZr=?UJ@Ao`rNyH$XXGe*e^U9zZWd>715fM74gV@2wMQmgbf zKXC!`q$y4Ur)>6>7N-T#sQB%#2F>5^zN8n3$4NZ++HXnn75S>s$LC=N5|o%Bk~FC(Wof|oqhsU`z?@KyFvE4>1~y8W*NHxAlNC*<{DL9{Z` zAr<;e^CjJH&Ux};4`0{W5k}Bms8EA$FjTMUd#u(Nd4_K6&&VWvf#VA6gv_pkGV1qy z2_{CVj#Y_UV@WJ7d0E_VfV{SCGxzm!E9 zTlD!Tjvq2H*E8zR5s;j{`I6qkv^zeTAv@PB^NBv?x}cA4{jA>`c;-Q0?76b(tS+df z*&eA!m3rgC0K6f>(vv$vjF|h%xm+_^3dnQFMTbmMMcyQCvFO7&ymz z@By3vxL?>}B!SC5X9e5D=Y3t<2Wg&{Chw;H@T=r0SvR7{Iiz_EBn9xHq~AEQ&-94r zp7)FAO2lMP?yScVY9}fs#k<8<>ZSJX62JceAx^hYa^&8r==TnEifdLJCr})J;&kLT z9zp(|En$ge^q}B6{6>#yc=wHU<3n$DEm}n^rt4OCL1{Iit>shOmeoXlM|nZN5UVaY zt3%KLl@$B3z0awGeK9`gE9R?%adDiX!3ZEz+?$|)SZ(5zqmYi6D2XyY25a0d%ew2U z#c2uHIHXLI_WQ2%Yb~#`;6aRiy+YNnquklGbV--^2r3H>r^^9^@$W$I%j|%RJd2NF zn1+%)Ws%HAXDXckjWqnjDqQtN9T^L_+!d8HQ_dPRkN?XS5mSi10HVqf+seQ;auZ|v z)dZz=#hwgI;j@a1H(pg_&P2-=?D*;a^KV4Wk%E-c&zvTbiRR)_&k{ep| z6!Yc0QtbFrv;JTBXgfO=`pQpO-qoAnZJ=RUoJhoTQ$}?dAnCOkgrdvQ&=?B-aRIWwJ`>n{ z)FW~7hXtz%uYq|>fYTJy#0R0=&s5kHLh*a{>pA2ImdF) zcJ01vr-5z5XT4~k2D7u>Cw55GH2Fzt*|L+#zBwc0Xum~mGv|%1al_EwN%_sgL1fvu zq`~PGa+#)qL*3a=_$abJ4zA8U8da$+@Y;C8EiW=Mowz!(7EG09DEB?*JVhyo8V8hs zS*rbBO5NFqmww=f4y0OZ}U`tY0#DX!P@vNMyh?;=gLw_ zuBTHYDbc5%T+1vdm7Z;#TA>1T*w32!OhZ{{E^=*np2jO_Cy01HnnmS^Q(b&%Bnc@A z5KhQ>9%Hb=s8#ZN_0;NE*2Xa}1{&E|zK^%eJo=n!j*`vIHeX-?U zqk;9VEz*}*L1&ui`)u7#+i;yc3Ec~PAsJLG0FixM)8w;Tz>1X(X46@pPPH|+ErU!g zh)oC1pCXSN)eWbe$OA0?iqfRhGru8|cD0T1@8igxe$Lj^mSfSiuz>Xb(EY6ME^L zpiSr3%d73;N5ZdYOB6MU-)Xsrd`G3f8SX+8Fzp}n;G%BmHAHov_h@Rg+~jXsk<@4;?S*NSa@ z$SI2QO+?Ij(O6EO5Gb0gEJf--L*TGt8>j+PP6}rE(Sx36L+-M>{J$NE|aLsdi z-VBl#F2X#NfW$*P1F;J}PK)4KIJIoQzj+)+-|@IO9i(%<5yzb?O_>m|F(jVbvYi#L zaMGZw#T>ky)SV)n`WSFm>Z-^GAI^^*^ zr$6ymLD~3#OJC3F<2TH8jUSEv>Ai7(>_q@5-cl`0)oIw_By;>2q)RV7y3n}GyTz)~LovAc5#2Qnl&@XE931FG<5&3&#d3JGR5%=B$7%njawdn;Xy zG)w`QlElv1s|m8+SgA2P5Hv2rPr%V3)lL|G8s@VN6J#DIpxchwQKs~(Z{xw9w#@HX%jW&D|b2rXB zX5qHJmXlv~7}zn-4*2x6Vk1YAZ|O59reSVqn&sm`zy`V8zH~Br#46!cyK>gO!0ZhM zz0_;_1gYLsi!mPBS;KtN&(!7$Ww#m#S;fHbX6V|V?^vu$k*}UCN#$&;D~Ft??8s#& zu14U1Nk^!C)D8cQ{^~$u5>-*mLD*3sKhcce1_`-O(X5TqMvF)eNU*z337WJsyf2Xp zYLja0441H%NC6IrfepQIteq42xf1b(E%Bb;XD$3);}*~0MR&JjthUTtyKvJ00_%=c zIxw8Rqo+77N@e+(UBW?p1W!I)bdW&ru3h;k8azPxey|nAP!95PS z{EoHeCJrC?gxfrl&Apno1)|p>@tC3tRm)I(HwYtw{d2-bztxL2^5c=teB2AWJue z!}TrJmqxNN>U7O_7UN_#2Pd8-KpEp)>0Exu)22PF@-J<4FAe4OS z>2W&Jlz{)jfgdW&Q9j6yPUUCdrR@|Kv1b1M852YC`AOo5^1Du6e>4^O!mDDK4i@FO zG^k#g$dge!#f<)LCbV2+a61~U*}Jz*a-&jct6hj?{mAFL!RaasJ?c*74pn8N+&a{e z8B4}onErDZ7W2VgQ3qbDwgWHJ4U>s`R%cD6pTNz->;)zV`_i4M^ORy*K=szWwf63M zF8@%E$XCdwlqu{VN>v}s6j>zK!p$eX7bqnEZ2?f&LS~-iqE%hti=LMYjB9zeQ+#3b zL^~pR2hU8IWP^wOk_Brx+i33?hN*v!aHz;FYrnH#<;MxBP==5qr0XHa*x#9POiKg3 zWZ@H9in)~mgpw^fl?lSPP5PU;FHVrhE1X|+aw`JpB)Q|;LCBhlazF5b+NnjAquZqi z$R?ir7L~Hyruz1=Icz{~GZ+9A|LaSX<@ev;VIWC5TfDT!OA_Wl8CWYSh}5KJ5lz`@ znLQHGgnfA&5;85t`_mvHxPNu3JTd=QapofM{-qsAn@vGK^6%>BCfU@QC~^IeYL+S6 zybly{ozI=SEB^i3u7UJ-W_V_&a40)QkMTC|vnH9$lPKQv*Z=xvd0bmvybRn9#j$(x zxzYsZ>FLS4MB#_5Ck29MKLS@QhX?RH{(->Wyw{?ZT;eeXNks$k2kTuGi(#VwIBao< z`PD@lyF2BUh`(<(_n)k+r&rnHc)emAjO(_>{nOAoKo}An7!dwfD1vAvCbdTxCgB^k z6`H#N52N7^o4Q&C4$hy|5A9Q=P~WOpSuXB@JxX_zd)q@ox`kn8I+1^zaZiocWI07w z0aNEGC3|KFOF^tKYwA#A1otn%IB&MqBHy;trpu=G))dQEmY*;%qLa%V{OsD@_(Vjd z2RZU-C;GgzP&41OEQcDrTn(JI!XME&1XvfmuS9=N8A*;U-cJ1W{cat38xrDIl>M>* zCpGHb{av8lQvkh}{a|g2>27sqdW;s=s2il1%6RRhQENr@DqF+W~GLF1t|3Vd#)=~Fam*0hy>C|(`T{-PFsqe*KjgUr|z_4n^_!6Ga) zRys!rB_989+#5XJYbBP&oARX+MxWCl7UD29(bdS626emZE1vyGw1)$?1({vx@e=!M zw>?Y%U6HuH(b;LdVw-03S{_Sam{VB&5p8~qhPP?BRCt1| zJYyzUcJ=u$LphT5rdG%b6IzgHN28yAY3kMU)T<|V;)@?Nx%n<}9#d-`PJ3wvbg+nf zw{}d&sp;0LuK%An&p1^Yl6-~kZgV`QI4w5-!>SKvKrr&~tZ8z5Frq;OjPr4mcG5ro z#b?i|KBeir|7Kf`Wj+Su9M&L3H!H|T5_@R@EdQSLl6G0zh*C^Hq=%($Y*#pu8_i|9 z6RWj2@)9NJ_&|t^xN{|GHpaapv;KtQ+eLdc);WT92dwBp0C*NhJ;f8BZxm?ti|xr@ zCa*aGz1H#nv8wKV8o4InZS*K0kEP?K+OTf-+$f~&1Gd+%h);&T?g`{>WuOs-uUCKC zm1qEWqZA&*igcr@D*liTmxlvnym98WRfQwkhJaoGX~u4%xusIcYX~s619MSsTTUZ6 zz233bybHk@{qNu5qXxKHS-#FI10}QTb%|^U>CZQ3_bhdk@~!?Y%*Furbq~ zZ;)cQz?%8ix0O^h5n)p^-aciqxzP%CwMm{JqGPmE;>)b?F930)?FaBfGtkKy)&mnX zWT|F8e##wi#ppnUj|ezsJku&>5mXVgY;M4R--?@`Mh+W1x;MFFsF`0Q545xw{F% z%f8u^P9OO)B|d#uU|z^Xv?J$HyjA!FnsVd=O>4yP^^SaJIaMKV31oCQ=FSS~piV6A zIx`!pu?RZLcBZGW(*$r^CVvHh>)y%7%gOKm$Ve(>mC*MDL4zjQWZrm#)~ zR9wj;{LzD|Z+$|`oYn<~0a_!i*K7DBunFgxmZoUso2XsgZSd|yDclMb9in4;QSppW zFnOXsxtp{o(3JOwC&3yp`S$cS?X?sQ(( z*=*b{ixSHj#g>iF)vpL|U%|Dr7E#rXu056ed*=b#KMNw|o*?kP6);!c`^YYur~_HC zAoqe|ozVOV9bk@M%A2{slEH1YH}SwB{$VyQPqOVp2Z@ycqWj@DMW!t7OZF><()C7If>R z(ri5Qgo%>8Zd`M7ouh&PIj6tNa8dS6?hS1flrP)OLZg2n>90qv(%j5SG}onlb(0>jlGN_`usB|I}IRj&x_sy)ssp*bKJLe zXD<~-5BcK`YP7gt%K!Y?zb^1YLigTdnl`uqNoRy}hUP`(wa3~dCsX(8#_eG8AEJ2B zrarS=+^7JsP3_}iic!_&C#v#$*A=mcjww=dqB*jp(?g1=RL=yHGhAW0(iPO&V*7XM?lrVw2)Q>&kF z^8vk$3Aj&2@rgad-!9Nh=a_fwmWO7}3+B=b zmJJp~0kr>sacM04dGZ#yEB#^71-i!aa-B-=m!!}FB#VU#GdV&)(`$^U;Em z)sbcbw4NuPB&;#Gm`JohbT2s}`g==}+syDnq{1p=2u=jX{jMi$R~kQHHK;_r8Dk8~ zA}ggsI$H_UMCFF*W0L&gUEs!5u_u}77Vt3qM?DTRi1o!e+vj z2FI*<{wRwHPlY#L7S@CJqytA`OQsI1S+er8e#g{BX&c4TRDWEEs- zFH@jPgPySJ;qvFsw{R4Bj6V7Q;#4sFCMan}z^jO5jMN#PkyS3cH&O}E^2)9yJ9bAE z55p_rJ~Th$dr^lj-LsISLaxioB-xdjWW#UVOy#>5T^NGst=t_=^rukG)!N`f`JyZ# z7bPWMqeYop)71@w=~~+8I7d2bP_2x);!sR*%zkC*UF-=@5e|9M=%&jG#a~>onR@Ul zQ0o+Z_X%hO81v|g1&&6nKT>ZYB$jRB9D;9OdOLOhk8U%o4{$%xCO|nQY++bWoKO`V z&+TKkvR=N-&R+RmNTn-ED5)hf$5S4$fNm!9WYzL^i^-`3ZJbx0RTC?q39Tow0RI)>hZXhN6$76`+f(Km_bYhZC=w;8i*0@8TV~x4+@; z2mcr1jJ9fNbSWHzkc-JO4%s`b4A{_iK-4RJg~S%+7Jt8a2x_f(Bov1Y56}Al*VU5~ zPhTx|?s)S|5yMYIk8{`{ng$TqG}72zxAmkY#cSHEy7S)9wE?UpUAO#(&f(78AsuXB z4Ri#Un-Mr<{@s@m!U&DUiPs*0(?z4$+TUdD!0#uuL)>{+=fdlO zP_;XEWN#yQZUO{riaB>Y*y`2QYeEUlnYodK(RU$EB7^TQ>=n*ndUimcUKH0Cl?YP1BsE72%ZBdQJ5xy}u{sn}_&raaz&Aj20E8@t4G55tI(O^a~)^8AI4f2A% zKf6J&S!LdmdA|-26anoTN-Z`*uA0`5r9bL8Se>E~RLadU6V%f}6S)2JC|uk=?Svu~ zgB!u9S%6+JA>$kLA3&|okqgkBHoa=<-jG&j=8E?_mDSZ*&GlbFq5-^2+k^xD2W9L) z7{&cNKoTGV9IhO>xEpNq{_8GKqb>+4oNcbO$_q~?C(X-}`oQ73j`IhrbJ`VDvQj&Y z^W4Ss-(4HPs6jxA@zNJv=m#J~7?-p3^17vaTXaeP>CJKzNJ8NAj*G*hX>Tx~1P~5- zF@)u0QV*F@J(Zn*brPfaNKkQBFpwic!F%4U=5l)z0L{w)NmL_(N}#`-cuyUR2Z4Kz z#wyXWp-GB7AVzy}hN^D-%jec9 zD4D^G3X8bl`qV7O--LPzfS|)hxLJ)88sg%3H)#us4d7x5*aLD9N?N_X!37$cqdXSJ z+*F8jj$Qm6!eFNn9{KlcLCKy;{Y`QrqS2m2tQ-%4mJd+2g;fr*qlv_31M5&spLe#ZWxajP17@Fa9SYNrogYFrL$Ynm1|R z8wTUH>fH-R)I}2h0wg^cjRf1gCr!al0{!ss87#m&96KgMg`(Y2{%c7b_EcTYjSA#5 zHYy7oI)oAo6NUc*hW~TqxuU$4&Z=h!4mXa`X+TrPh_dwSFw+gjdRbS{?b7G7HJ+D$ zFKic3XY??0KqoXk-u8AN~KHeG-RVc}^pGigA zz%QuhH1n_?DB0v|oldloHVK(Q-%R_5nfrQ^BSX;vxeJ3`2j?o&?Q3a@N8xM=v*2>! zIsl@3V{{Jdb;o(A{~qG=Ppd^}M`*uexk0HfEfb-Ge}|V>D~xT8v!BdzxtiVR*oYF^ zod)Dy{ikU-4{96g$NpvV~1q`APpwzLQbb~kCKu^u1yhf52* z_WvaNz{$~Wb#6e4CFsRgga%D~FwH&guu5h8AX$LuL?MVt9%WXmENiQuUxjWQ zMH~hc6i1||qraH(_wJBeqL8~f8m~K!ERlk=4KMx-I-@F22F zXQKvC2*_}FT4L?;2KunNhm8&3)zZBPd|EGu>bLl_YH{=k-U&~A{4fepD15SpZGees zxZ~5K>G_+6303jD`PJsHycLO1VJhfoL1qxtwbVbik0KI|DY*bB6a8w6Tk$=<(Y-yL zT4)+8=_+%bH>QC4>fiqdK|dC_Ve_8zJT-aTmhqZ;M%_&8;6Kkm-yUw<+EruQk2l%= zxVm2We9i5C#@=FII{a5zL{@otd3Zo)Jj10%1UI}93fFZeyUYrvxRcv6a*Xbn3S(A<$7LSFduV2o-tDEB_%Nz-q zc*{|Zn2-Ym4MJx^XFC9|SSB2Ok9&kJMe}RG9Y!%N)-CI>ZNx6dO4GY=O+N-NoT@M8 z=n2gFr%1-M^-HPiI|6lY>4Ae@nO#0wqto4#T}LC~7mx>KvgSFgZpnyvtN{9b;vT%Q zKHlOmqu*p+LA3%O9lr%G8yY^lUoZX?+sSia@)&F)<|@^P(_)->E4Z>)xAYL8Sfvuc z^ysY#2n-MEyJ4QSP$ET&<{^T4?hz>_(Fn4y@s|%QXChu!kqE}#5Tcp${jRO|r86Pk z#Z;I&$B(ht)85f+KFWSNyd#fjo>-S5plXfApI6$zw)cA$CNE@;6Z)Wfo$>H2rCoV} zq@ciF^~y;~a-@a(biq;aZ&q<~@%H|bF|!KPo|UE~73 zcp&H_ssrM+5D1&UJhImJYHtGmNE{>z27WX@cgt`9yON0gB!}_{X{o~iWq>0ZX0X#( z8SZ<_jY_P5m2clMbS7X9pIZrvrMz~+b>meW#u86x*RNV4ShWe}3+ikR@A6t4T3)na zL|XR_KgNtwQk{KN<)g|r5B^y@5q4G3O>Wwr*JVbyN$FZ{k6%`&mJOc0>Q0Oc6gg24Qc!#9+)ZtNI9+B(qKhdyMbiGd9_cQoZT_||Q z^j0FTOrkz8ZC$JzT4O$s&H2k#Uf_Bxf;OP`-(k0~oBa35;@=}BRV Date: Wed, 3 Dec 2025 10:39:07 -0800 Subject: [PATCH 06/14] Fixed readme [no ci] --- man/figures/logo.svg | 1 + 1 file changed, 1 insertion(+) create mode 100644 man/figures/logo.svg diff --git a/man/figures/logo.svg b/man/figures/logo.svg new file mode 100644 index 000000000..496f04025 --- /dev/null +++ b/man/figures/logo.svg @@ -0,0 +1 @@ + \ No newline at end of file From db66df6029906b934bc5c3297e8fc0c1c3764a9f Mon Sep 17 00:00:00 2001 From: VisruthSK <67435125+VisruthSK@users.noreply.github.com> Date: Wed, 3 Dec 2025 11:29:55 -0800 Subject: [PATCH 07/14] Added dev site [ci skip] --- _pkgdown.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 877cfb7c0..21a5856d9 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -2,6 +2,9 @@ url: https://mc-stan.org/rstanarm destination: "." +development: + mode: auto + template: package: pkgdownconfig From 7f7e342334dd74b71510e8c01e7e1f516c655886 Mon Sep 17 00:00:00 2001 From: VisruthSK <67435125+VisruthSK@users.noreply.github.com> Date: Wed, 3 Dec 2025 13:35:26 -0800 Subject: [PATCH 08/14] Reverted extraneous formatting changes --- R/stan_betareg.R | 229 ++++++-------- R/stan_biglm.R | 82 ++--- R/stan_clogit.R | 158 ++++------ R/stan_gamm4.R | 584 +++++++++++++++--------------------- R/stan_glm.R | 403 ++++++++++++------------- R/stan_glmer.R | 411 ++++++++++++------------- R/stan_jm.R | 762 ++++++++++++++++++++--------------------------- R/stan_lm.R | 140 ++++----- R/stan_mvmer.R | 234 ++++++--------- R/stan_nlmer.R | 292 ++++++++---------- R/stan_polr.R | 179 ++++------- 11 files changed, 1461 insertions(+), 2013 deletions(-) diff --git a/R/stan_betareg.R b/R/stan_betareg.R index d8b907dca..b45ab1391 100644 --- a/R/stan_betareg.R +++ b/R/stan_betareg.R @@ -1,16 +1,16 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. @@ -18,14 +18,14 @@ #' Bayesian beta regression models via Stan #' #' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Beta regression modeling with optional prior distributions for the +#' Beta regression modeling with optional prior distributions for the #' coefficients, intercept, and auxiliary parameter \code{phi} (if applicable). #' #' @export #' @templateVar armRef (Ch. 3-6) #' @templateVar pkg betareg #' @templateVar pkgfun betareg -#' @templateVar sameargs model,offset,weights +#' @templateVar sameargs model,offset,weights #' @templateVar rareargs na.action #' @templateVar fun stan_betareg #' @templateVar fitfun stan_betareg.fit @@ -43,24 +43,24 @@ #' @template args-algorithm #' @template args-adapt_delta #' @template args-QR -#' -#' @param link Character specification of the link function used in the model +#' +#' @param link Character specification of the link function used in the model #' for mu (specified through \code{x}). Currently, "logit", "probit", #' "cloglog", "cauchit", "log", and "loglog" are supported. -#' @param link.phi If applicable, character specification of the link function -#' used in the model for \code{phi} (specified through \code{z}). Currently, +#' @param link.phi If applicable, character specification of the link function +#' used in the model for \code{phi} (specified through \code{z}). Currently, #' "identity", "log" (default), and "sqrt" are supported. Since the "sqrt" #' link function is known to be unstable, it is advisable to specify a #' different link function (or to model \code{phi} as a scalar parameter #' instead of via a linear predictor by excluding \code{z} from the #' \code{formula} and excluding \code{link.phi}). -#' @param prior_z Prior distribution for the coefficients in the model for +#' @param prior_z Prior distribution for the coefficients in the model for #' \code{phi} (if applicable). Same options as for \code{prior}. -#' @param prior_intercept_z Prior distribution for the intercept in the model +#' @param prior_intercept_z Prior distribution for the intercept in the model #' for \code{phi} (if applicable). Same options as for \code{prior_intercept}. -#' @param prior_phi The prior distribution for \code{phi} if it is \emph{not} -#' modeled as a function of predictors. If \code{z} variables are specified -#' then \code{prior_phi} is ignored and \code{prior_intercept_z} and +#' @param prior_phi The prior distribution for \code{phi} if it is \emph{not} +#' modeled as a function of predictors. If \code{z} variables are specified +#' then \code{prior_phi} is ignored and \code{prior_intercept_z} and #' \code{prior_z} are used to specify the priors on the intercept and #' coefficients in the model for \code{phi}. When applicable, \code{prior_phi} #' can be a call to \code{exponential} to use an exponential distribution, or @@ -68,23 +68,23 @@ #' half-t, or half-Cauchy prior. See \code{\link{priors}} for details on these #' functions. To omit a prior ---i.e., to use a flat (improper) uniform #' prior--- set \code{prior_phi} to \code{NULL}. -#' -#' @details The \code{stan_betareg} function is similar in syntax to -#' \code{\link[betareg]{betareg}} but rather than performing maximum -#' likelihood estimation, full Bayesian estimation is performed (if -#' \code{algorithm} is \code{"sampling"}) via MCMC. The Bayesian model adds +#' +#' @details The \code{stan_betareg} function is similar in syntax to +#' \code{\link[betareg]{betareg}} but rather than performing maximum +#' likelihood estimation, full Bayesian estimation is performed (if +#' \code{algorithm} is \code{"sampling"}) via MCMC. The Bayesian model adds #' priors (independent by default) on the coefficients of the beta regression #' model. The \code{stan_betareg} function calls the workhorse #' \code{stan_betareg.fit} function, but it is also possible to call the #' latter directly. -#' +#' #' @seealso The vignette for \code{stan_betareg}. #' \url{https://mc-stan.org/rstanarm/articles/} -#' -#' @references Ferrari, SLP and Cribari-Neto, F (2004). Beta regression for +#' +#' @references Ferrari, SLP and Cribari-Neto, F (2004). Beta regression for #' modeling rates and proportions. \emph{Journal of Applied Statistics}. #' 31(7), 799--815. -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' ### Simulated data @@ -96,55 +96,54 @@ #' y <- rbeta(N, mu * phi, (1 - mu) * phi) #' hist(y, col = "dark grey", border = FALSE, xlim = c(0,1)) #' fake_dat <- data.frame(y, x, z) -#' +#' #' fit <- stan_betareg( -#' y ~ x | z, data = fake_dat, -#' link = "logit", -#' link.phi = "log", +#' y ~ x | z, data = fake_dat, +#' link = "logit", +#' link.phi = "log", #' algorithm = "optimizing" # just for speed of example -#' ) +#' ) #' print(fit, digits = 2) #' } stan_betareg <- - function( - formula, - data, - subset, - na.action, - weights, - offset, - link = c("logit", "probit", "cloglog", "cauchit", "log", "loglog"), - link.phi = NULL, - model = TRUE, - y = TRUE, - x = FALSE, - ..., - prior = normal(autoscale = TRUE), - prior_intercept = normal(autoscale = TRUE), - prior_z = normal(autoscale = TRUE), - prior_intercept_z = normal(autoscale = TRUE), - prior_phi = exponential(autoscale = TRUE), - prior_PD = FALSE, - algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE - ) { + function(formula, + data, + subset, + na.action, + weights, + offset, + link = c("logit", "probit", "cloglog", "cauchit", "log", "loglog"), + link.phi = NULL, + model = TRUE, + y = TRUE, + x = FALSE, + ..., + prior = normal(autoscale=TRUE), + prior_intercept = normal(autoscale=TRUE), + prior_z = normal(autoscale=TRUE), + prior_intercept_z = normal(autoscale=TRUE), + prior_phi = exponential(autoscale=TRUE), + prior_PD = FALSE, + algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE) { + if (!requireNamespace("betareg", quietly = TRUE)) { stop("Please install the betareg package before using 'stan_betareg'.") } if (!has_outcome_variable(formula)) { stop("LHS of formula must be specified.") } - + mc <- match.call(expand.dots = FALSE) data <- validate_data(data, if_missing = environment(formula)) mc$data <- data mc$model <- mc$y <- mc$x <- TRUE - + # NULLify any Stan specific arguments in mc mc$prior <- mc$prior_intercept <- mc$prior_PD <- mc$algorithm <- mc$adapt_delta <- mc$QR <- mc$sparse <- mc$prior_dispersion <- NULL - + mc$drop.unused.levels <- TRUE mc[[1L]] <- quote(betareg::betareg) mc$control <- betareg::betareg.control(maxit = 0, fsmaxit = 0) @@ -156,91 +155,60 @@ stan_betareg <- Z <- model.matrix(br, model = "precision") weights <- validate_weights(as.vector(model.weights(mf))) offset <- validate_offset(as.vector(model.offset(mf)), y = Y) - + # check if user specified matrix for precision model - if ( - length(grep("\\|", all.names(formula))) == 0 && - is.null(link.phi) - ) { + if (length(grep("\\|", all.names(formula))) == 0 && + is.null(link.phi)) Z <- NULL - } - + algorithm <- match.arg(algorithm) link <- match.arg(link) link_phi <- match.arg(link.phi, c(NULL, "log", "identity", "sqrt")) - - stanfit <- - stan_betareg.fit( - x = X, - y = Y, - z = Z, - weights = weights, - offset = offset, - link = link, - link.phi = link.phi, - ..., - prior = prior, - prior_z = prior_z, - prior_intercept = prior_intercept, - prior_intercept_z = prior_intercept_z, - prior_phi = prior_phi, - prior_PD = prior_PD, - algorithm = algorithm, - adapt_delta = adapt_delta, - QR = QR - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } - if (is.null(link.phi) && is.null(Z)) { + + stanfit <- + stan_betareg.fit(x = X, y = Y, z = Z, + weights = weights, offset = offset, + link = link, link.phi = link.phi, + ..., + prior = prior, prior_z = prior_z, + prior_intercept = prior_intercept, + prior_intercept_z = prior_intercept_z, + prior_phi = prior_phi, prior_PD = prior_PD, + algorithm = algorithm, adapt_delta = adapt_delta, + QR = QR) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) + if (is.null(link.phi) && is.null(Z)) link_phi <- "identity" - } sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) - X <- X[, !sel, drop = FALSE] + X <- X[ , !sel, drop = FALSE] if (!is.null(Z)) { sel <- apply(Z, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) - Z <- Z[, !sel, drop = FALSE] + Z <- Z[ , !sel, drop = FALSE] } - fit <- - nlist( - stanfit, - algorithm, - data, - offset, - weights, - x = X, - y = Y, - z = Z %ORifNULL% model.matrix(y ~ 1), - family = beta_fam(link), - family_phi = beta_phi_fam(link_phi), - formula, - model = mf, - terms = mt, - call = match.call(), - na.action = attr(mf, "na.action"), - contrasts = attr(X, "contrasts"), - stan_function = "stan_betareg" - ) + fit <- + nlist(stanfit, algorithm, data, offset, weights, + x = X, y = Y, z = Z %ORifNULL% model.matrix(y ~ 1), + family = beta_fam(link), family_phi = beta_phi_fam(link_phi), + formula, model = mf, terms = mt, call = match.call(), + na.action = attr(mf, "na.action"), contrasts = attr(X, "contrasts"), + stan_function = "stan_betareg") out <- stanreg(fit) if (algorithm == "optimizing") { out$log_p <- stanfit$log_p out$log_g <- stanfit$log_g } - out$xlevels <- lapply(mf[, -1], FUN = function(x) { + out$xlevels <- lapply(mf[,-1], FUN = function(x) { xlev <- if (is.factor(x) || is.character(x)) levels(x) else NULL xlev[!vapply(xlev, is.null, NA)] }) out$levels <- br$levels - if (!x) { + if (!x) out$x <- NULL - } - if (!y) { + if (!y) out$y <- NULL - } - if (!model) { + if (!model) out$model <- NULL - } - + structure(out, class = c("stanreg", "betareg")) } @@ -251,11 +219,8 @@ beta_fam <- function(link = "logit") { if (link == "loglog") { out <- binomial("cloglog") out$linkinv <- function(eta) { - 1 - - pmax( - pmin(-expm1(-exp(eta)), 1 - .Machine$double.eps), - .Machine$double.eps - ) + 1 - pmax(pmin(-expm1(-exp(eta)), 1 - .Machine$double.eps), + .Machine$double.eps) } out$linkfun <- function(mu) log(-log(mu)) } else { @@ -263,15 +228,12 @@ beta_fam <- function(link = "logit") { } out$family <- "beta" out$variance <- function(mu, phi) mu * (1 - mu) / (phi + 1) - out$dev.resids <- function(y, mu, wt) { + out$dev.resids <- function(y, mu, wt) stop("'dev.resids' function should not be called") - } - out$aic <- function(y, n, mu, wt, dev) { + out$aic <- function(y, n, mu, wt, dev) stop("'aic' function should not have been called") - } - out$simulate <- function(object, nsim) { + out$simulate <- function(object, nsim) stop("'simulate' function should not have been called") - } return(out) } @@ -280,14 +242,11 @@ beta_phi_fam <- function(link = "log") { out <- poisson(link) out$family <- "beta_phi" out$variance <- function(mu, phi) mu * (1 - mu) / (phi + 1) - out$dev.resids <- function(y, mu, wt) { + out$dev.resids <- function(y, mu, wt) stop("'dev.resids' function should not be called") - } - out$aic <- function(y, n, mu, wt, dev) { + out$aic <- function(y, n, mu, wt, dev) stop("'aic' function should not have been called") - } - out$simulate <- function(object, nsim) { + out$simulate <- function(object, nsim) stop("'simulate' function should not have been called") - } return(out) -} +} \ No newline at end of file diff --git a/R/stan_biglm.R b/R/stan_biglm.R index 6171a9e82..b0c598675 100644 --- a/R/stan_biglm.R +++ b/R/stan_biglm.R @@ -1,31 +1,31 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian regularized linear but big models via Stan -#' +#' #' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' This is the same model as with \code{\link{stan_lm}} but it utilizes the #' output from \code{\link[biglm]{biglm}} in the \pkg{biglm} package in order to #' proceed when the data is too large to fit in memory. -#' +#' #' @export #' @param biglm The list output by \code{\link[biglm]{biglm}} in the \pkg{biglm} #' package. -#' @param xbar A numeric vector of column means in the implicit design matrix +#' @param xbar A numeric vector of column means in the implicit design matrix #' excluding the intercept for the observations included in the model. #' @param ybar A numeric scalar indicating the mean of the outcome for the #' observations included in the model. @@ -39,18 +39,18 @@ #' @template args-prior_PD #' @template args-algorithm #' @template args-adapt_delta -#' -#' @details The \code{stan_biglm} function is intended to be used in the same +#' +#' @details The \code{stan_biglm} function is intended to be used in the same #' circumstances as the \code{\link[biglm]{biglm}} function in the \pkg{biglm} -#' package but with an informative prior on the \eqn{R^2} of the regression. -#' Like \code{\link[biglm]{biglm}}, the memory required to estimate the model -#' depends largely on the number of predictors rather than the number of -#' observations. However, \code{stan_biglm} and \code{stan_biglm.fit} have -#' additional required arguments that are not necessary in +#' package but with an informative prior on the \eqn{R^2} of the regression. +#' Like \code{\link[biglm]{biglm}}, the memory required to estimate the model +#' depends largely on the number of predictors rather than the number of +#' observations. However, \code{stan_biglm} and \code{stan_biglm.fit} have +#' additional required arguments that are not necessary in #' \code{\link[biglm]{biglm}}, namely \code{xbar}, \code{ybar}, and \code{s_y}. -#' If any observations have any missing values on any of the predictors or the +#' If any observations have any missing values on any of the predictors or the #' outcome, such observations do not contribute to these statistics. -#' +#' #' @return The output of both \code{stan_biglm} and \code{stan_biglm.fit} is an #' object of \code{\link[rstan:stanfit-class]{stanfit-class}} rather than #' \code{\link{stanreg-objects}}, which is more limited and less convenient @@ -58,30 +58,19 @@ #' design matrix into memory. Without the full design matrix,some of the #' elements of a \code{\link{stanreg-objects}} object cannot be calculated, #' such as residuals. Thus, the functions in the \pkg{rstanarm} package that -#' input \code{\link{stanreg-objects}}, such as +#' input \code{\link{stanreg-objects}}, such as #' \code{\link{posterior_predict}} cannot be used. -#' -stan_biglm <- function( - biglm, - xbar, - ybar, - s_y, - ..., - prior = R2(stop("'location' must be specified")), - prior_intercept = NULL, - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL -) { +#' +stan_biglm <- function(biglm, xbar, ybar, s_y, ..., + prior = R2(stop("'location' must be specified")), + prior_intercept = NULL, prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL) { if (!requireNamespace("biglm", quietly = TRUE)) { stop("Please install the biglm package to use this function.") } - if ( - !inherits(biglm, "biglm") || - is.null(biglm$qr) || - !inherits(biglm$qr, "bigqr") || - is.null(biglm$terms) - ) { + if (!inherits(biglm, "biglm") || is.null(biglm$qr) || + !inherits(biglm$qr, "bigqr") || is.null(biglm$terms)) { stop("'biglm' must be of S3 class biglm as defined by the biglm package.") } @@ -91,26 +80,15 @@ stan_biglm <- function( R <- sqrt(biglm$qr$D) * R if (identical(attr(biglm$terms, "intercept"), 1L)) { b <- b[-1] - R <- R[-1, -1] + R <- R[-1,-1] has_intercept <- TRUE } else { has_intercept <- FALSE } - stan_biglm.fit( - b, - R, - SSR = biglm$qr$ss, - N = biglm$n, - xbar, - ybar, - s_y, - has_intercept, - ..., - prior = prior, - prior_intercept = prior_intercept, - prior_PD = prior_PD, - algorithm = match.arg(algorithm), - adapt_delta = adapt_delta - ) + stan_biglm.fit(b, R, SSR = biglm$qr$ss, N = biglm$n, xbar, ybar, s_y, + has_intercept, ..., + prior = prior, prior_intercept = prior_intercept, + prior_PD = prior_PD, algorithm = match.arg(algorithm), + adapt_delta = adapt_delta) } diff --git a/R/stan_clogit.R b/R/stan_clogit.R index 7d747d0da..5ff61a6da 100644 --- a/R/stan_clogit.R +++ b/R/stan_clogit.R @@ -1,16 +1,16 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. @@ -37,15 +37,15 @@ #' @template args-QR #' @template args-sparse #' @template args-dots -#' +#' #' @param formula,data,subset,na.action,contrasts Same as for \code{\link[lme4]{glmer}}, #' except that any global intercept included in the formula will be dropped. #' \emph{We strongly advise against omitting the \code{data} argument}. Unless #' \code{data} is specified (and is a data frame) many post-estimation #' functions (including \code{update}, \code{loo}, \code{kfold}) are not #' guaranteed to work properly. -#' @param strata A factor indicating the groups in the data where the number of -#' successes (possibly one) is fixed by the research design. It may be useful +#' @param strata A factor indicating the groups in the data where the number of +#' successes (possibly one) is fixed by the research design. It may be useful #' to use \code{\link{interaction}} or \code{\link[survival]{strata}} to #' create this factor. However, the \code{strata} argument must not rely on #' any object besides the \code{data} \code{\link{data.frame}}. @@ -53,30 +53,30 @@ #' terms are included in the \code{formula}. See \code{\link{decov}} for #' more information about the default arguments. Ignored when there are no #' group-specific terms. -#' -#' @details The \code{stan_clogit} function is mostly similar in syntax to +#' +#' @details The \code{stan_clogit} function is mostly similar in syntax to #' \code{\link[survival]{clogit}} but rather than performing maximum #' likelihood estimation of generalized linear models, full Bayesian #' estimation is performed (if \code{algorithm} is \code{"sampling"}) via #' MCMC. The Bayesian model adds priors (independent by default) on the #' coefficients of the GLM. -#' -#' The \code{data.frame} passed to the \code{data} argument must be sorted by +#' +#' The \code{data.frame} passed to the \code{data} argument must be sorted by #' the variable passed to the \code{strata} argument. -#' +#' #' The \code{formula} may have group-specific terms like in #' \code{\link{stan_glmer}} but should not allow the intercept to vary by the #' stratifying variable, since there is no information in the data with which #' to estimate such deviations in the intercept. -#' +#' #' @seealso The vignette for Bernoulli and binomial models, which has more #' details on using \code{stan_clogit}. #' \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' dat <- infert[order(infert$stratum), ] # order by strata -#' post <- stan_clogit(case ~ spontaneous + induced + (1 | education), +#' post <- stan_clogit(case ~ spontaneous + induced + (1 | education), #' strata = stratum, #' data = dat, #' subset = parity <= 2, @@ -84,38 +84,27 @@ #' chains = 2, iter = 500) # for speed only #' #' nd <- dat[dat$parity > 2, c("case", "spontaneous", "induced", "education", "stratum")] -#' # next line would fail without case and stratum variables +#' # next line would fail without case and stratum variables #' pr <- posterior_epred(post, newdata = nd) # get predicted probabilities -#' +#' #' # not a random variable b/c probabilities add to 1 within strata -#' all.equal(rep(sum(nd$case), nrow(pr)), rowSums(pr)) +#' all.equal(rep(sum(nd$case), nrow(pr)), rowSums(pr)) #' } #' @importFrom reformulas findbars -stan_clogit <- function( - formula, - data, - subset, - na.action = NULL, - contrasts = NULL, - ..., - strata, - prior = normal(autoscale = TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE -) { +stan_clogit <- function(formula, data, subset, na.action = NULL, contrasts = NULL, + ..., + strata, prior = normal(autoscale=TRUE), + prior_covariance = decov(), prior_PD = FALSE, + algorithm = c("sampling", "optimizing", + "meanfield", "fullrank"), + adapt_delta = NULL, QR = FALSE, sparse = FALSE) { + algorithm <- match.arg(algorithm) data <- validate_data(data, if_missing = environment(formula)) call <- match.call(expand.dots = TRUE) mf <- match.call(expand.dots = FALSE) - m <- match( - c("formula", "data", "subset", "na.action", "strata"), - table = names(mf), - nomatch = 0L - ) + m <- match(c("formula", "data", "subset", "na.action", "strata"), + table = names(mf), nomatch = 0L) mf <- mf[c(1L, m)] names(mf)[length(mf)] <- "weights" mf$data <- data @@ -125,9 +114,8 @@ stan_clogit <- function( } has_bars <- length(findbars(formula)) > 0 if (has_bars) { - if (is.null(prior_covariance)) { + if (is.null(prior_covariance)) stop("'prior_covariance' can't be NULL.", call. = FALSE) - } mf[[1L]] <- quote(lme4::glFormula) mf$control <- make_glmerControl() glmod <- eval(mf, parent.frame()) @@ -135,14 +123,14 @@ stan_clogit <- function( mf <- glmod$fr Y <- mf[, as.character(glmod$formula[2L])] group <- glmod$reTrms - group$strata <- glmod$strata <- as.factor(mf[, "(weights)"]) + group$strata <- glmod$strata <- as.factor(mf[,"(weights)"]) group$decov <- prior_covariance } else { validate_glm_formula(formula) mf[[1L]] <- as.name("model.frame") mf$drop.unused.levels <- TRUE mf <- eval(mf, parent.frame()) - group <- list(strata = as.factor(mf[, "(weights)"])) + group <- list(strata = as.factor(mf[,"(weights)"])) mt <- attr(mf, "terms") X <- model.matrix(mt, mf, contrasts) Y <- array1D_check(model.response(mf, type = "any")) @@ -151,7 +139,7 @@ stan_clogit <- function( if (is.factor(Y)) { Y <- fac2bin(Y) } - + ord <- order(group$strata) if (any(diff(ord) <= 0)) { stop("Data must be sorted by 'strata' (in increasing order).") @@ -160,9 +148,8 @@ stan_clogit <- function( weights <- double(0) mf <- check_constant_vars(mf) mt <- attr(mf, "terms") - if (is.empty.model(mt)) { + if (is.empty.model(mt)) stop("Predictors specified.", call. = FALSE) - } xint <- match("(Intercept)", colnames(X), nomatch = 0L) if (xint > 0L) { X <- X[, -xint, drop = FALSE] @@ -171,30 +158,16 @@ stan_clogit <- function( attr(mt, "intercept") <- 0L } f <- binomial(link = "logit") - stanfit <- stan_glm.fit( - x = X, - y = Y, - weights = weights, - offset = offset, - family = f, - prior = prior, - prior_PD = prior_PD, - algorithm = algorithm, - adapt_delta = adapt_delta, - group = group, - QR = QR, - sparse = sparse, - ... - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } + stanfit <- stan_glm.fit(x = X, y = Y, weights = weights, + offset = offset, family = f, + prior = prior, + prior_PD = prior_PD, + algorithm = algorithm, adapt_delta = adapt_delta, + group = group, QR = QR, sparse = sparse, ...) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) f$link <- "clogit" - f$linkinv <- function( - eta, - g = group$strata, - successes = aggregate(Y, by = list(g), FUN = sum)$x - ) { + f$linkinv <- function(eta, g = group$strata, + successes = aggregate(Y, by = list(g), FUN = sum)$x) { denoms <- unlist(lapply(1:length(successes), FUN = function(j) { mark <- g == levels(g)[j] log_clogit_denom(sum(mark), successes[j], eta[mark]) @@ -203,47 +176,28 @@ stan_clogit <- function( } f$linkfun <- log f$mu.eta <- function(eta) stop("'mu.eta' should not have been called") - fit <- nlist( - stanfit, - algorithm, - family = f, - formula, - data, - offset, - weights, - x = X, - y = Y, - model = mf, - terms = mt, - call, - na.action = attr(mf, "na.action"), - contrasts = contrasts, - stan_function = "stan_clogit", - glmod = if (has_bars) glmod - ) + fit <- nlist(stanfit, algorithm, family = f, formula, data, offset, weights, + x = X, y = Y, model = mf, terms = mt, call, + na.action = attr(mf, "na.action"), + contrasts = contrasts, + stan_function = "stan_clogit", + glmod = if(has_bars) glmod) out <- stanreg(fit) out$xlevels <- .getXlevels(mt, mf) - class(out) <- c(class(out), if (has_bars) "lmerMod", "clogit") + class(out) <- c(class(out), if(has_bars) "lmerMod", "clogit") return(out) } log_clogit_denom <- function(N_j, D_j, eta_j) { - if (D_j == 1 && N_j == NROW(eta_j)) { - return(log_sum_exp(eta_j)) - } - if (D_j == 0) { - return(0) - } + if (D_j == 1 && N_j == NROW(eta_j)) return(log_sum_exp(eta_j)); + if (D_j == 0) return(0) if (N_j == D_j) { - if (D_j == 1) { - return(eta_j[N_j]) - } + if (D_j == 1) return(eta_j[N_j]) return(sum(eta_j[(N_j - 1):(N_j + 1)])) - } else { + } + else { N_jm1 <- N_j - 1 - return(log_sum_exp2( - log_clogit_denom(N_jm1, D_j, eta_j), - log_clogit_denom(N_jm1, D_j - 1, eta_j) + eta_j[N_j] - )) + return( log_sum_exp2(log_clogit_denom(N_jm1, D_j, eta_j), + log_clogit_denom(N_jm1, D_j - 1, eta_j) + eta_j[N_j]) ) } -} +} \ No newline at end of file diff --git a/R/stan_gamm4.R b/R/stan_gamm4.R index 7d76c1531..abb2d38db 100644 --- a/R/stan_gamm4.R +++ b/R/stan_gamm4.R @@ -1,27 +1,27 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2016 Simon N. Wood # Copyright (C) 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian generalized linear additive models with optional group-specific #' terms via Stan -#' +#' #' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' Bayesian inference for GAMMs with flexible priors. -#' +#' #' @export #' @templateVar fun stan_gamm4 #' @templateVar pkg gamm4 @@ -37,38 +37,38 @@ #' @template args-adapt_delta #' @template args-QR #' @template args-sparse -#' -#' @param formula,random,family,data,knots,drop.unused.levels Same as for +#' +#' @param formula,random,family,data,knots,drop.unused.levels Same as for #' \code{\link[gamm4]{gamm4}}. \emph{We strongly advise against #' omitting the \code{data} argument}. Unless \code{data} is specified (and is #' a data frame) many post-estimation functions (including \code{update}, #' \code{loo}, \code{kfold}) are not guaranteed to work properly. -#' @param subset,weights,na.action Same as \code{\link[stats]{glm}}, +#' @param subset,weights,na.action Same as \code{\link[stats]{glm}}, #' but rarely specified. -#' @param ... Further arguments passed to \code{\link[rstan:stanmodel-method-sampling]{sampling}} (e.g. +#' @param ... Further arguments passed to \code{\link[rstan:stanmodel-method-sampling]{sampling}} (e.g. #' \code{iter}, \code{chains}, \code{cores}, etc.) or to #' \code{\link[rstan:stanmodel-method-vb]{vb}} (if \code{algorithm} is \code{"meanfield"} or #' \code{"fullrank"}). #' @param prior_covariance Cannot be \code{NULL}; see \code{\link{decov}} for #' more information about the default arguments. #' -#' @details The \code{stan_gamm4} function is similar in syntax to -#' \code{\link[gamm4]{gamm4}} in the \pkg{gamm4} package. But rather than performing +#' @details The \code{stan_gamm4} function is similar in syntax to +#' \code{\link[gamm4]{gamm4}} in the \pkg{gamm4} package. But rather than performing #' (restricted) maximum likelihood estimation with the \pkg{lme4} package, -#' the \code{stan_gamm4} function utilizes MCMC to perform Bayesian -#' estimation. The Bayesian model adds priors on the common regression -#' coefficients (in the same way as \code{\link{stan_glm}}), priors on the +#' the \code{stan_gamm4} function utilizes MCMC to perform Bayesian +#' estimation. The Bayesian model adds priors on the common regression +#' coefficients (in the same way as \code{\link{stan_glm}}), priors on the #' standard deviations of the smooth terms, and a prior on the decomposition -#' of the covariance matrices of any group-specific parameters (as in +#' of the covariance matrices of any group-specific parameters (as in #' \code{\link{stan_glmer}}). Estimating these models via MCMC avoids #' the optimization issues that often crop up with GAMMs and provides better -#' estimates for the uncertainty in the parameter estimates. -#' +#' estimates for the uncertainty in the parameter estimates. +#' #' See \code{\link[gamm4]{gamm4}} for more information about the model #' specicification and \code{\link{priors}} for more information about the #' priors on the main coefficients. The \code{formula} should include at least #' one smooth term, which can be specified in any way that is supported by the -#' \code{\link[mgcv]{jagam}} function in the \pkg{mgcv} package. The +#' \code{\link[mgcv]{jagam}} function in the \pkg{mgcv} package. The #' \code{prior_smooth} argument should be used to specify a prior on the unknown #' standard deviations that govern how smooth the smooth function is. The #' \code{prior_covariance} argument can be used to specify the prior on the @@ -77,30 +77,30 @@ #' group-specific terms to implement the departure from linearity in the smooth #' terms, but that is not the case for \code{stan_gamm4} where the group-specific #' terms are exactly the same as in \code{\link{stan_glmer}}. -#' +#' #' The \code{plot_nonlinear} function creates a ggplot object with one facet for #' each smooth function specified in the call to \code{stan_gamm4} in the case -#' where all smooths are univariate. A subset of the smooth functions can be +#' where all smooths are univariate. A subset of the smooth functions can be #' specified using the \code{smooths} argument, which is necessary to plot a #' bivariate smooth or to exclude the bivariate smooth and plot the univariate -#' ones. In the bivariate case, a plot is produced using +#' ones. In the bivariate case, a plot is produced using #' \code{\link[ggplot2]{geom_contour}}. In the univariate case, the resulting -#' plot is conceptually similar to \code{\link[mgcv]{plot.gam}} except the -#' outer lines here demark the edges of posterior uncertainty intervals +#' plot is conceptually similar to \code{\link[mgcv]{plot.gam}} except the +#' outer lines here demark the edges of posterior uncertainty intervals #' (credible intervals) rather than confidence intervals and the inner line #' is the posterior median of the function rather than the function implied -#' by a point estimate. To change the colors used in the plot see +#' by a point estimate. To change the colors used in the plot see #' \code{\link[bayesplot:bayesplot-colors]{color_scheme_set}}. -#' -#' @references -#' Crainiceanu, C., Ruppert D., and Wand, M. (2005). Bayesian analysis for +#' +#' @references +#' Crainiceanu, C., Ruppert D., and Wand, M. (2005). Bayesian analysis for #' penalized spline regression using WinBUGS. \emph{Journal of Statistical -#' Software}. \strong{14}(14), 1--22. +#' Software}. \strong{14}(14), 1--22. #' \url{https://www.jstatsoft.org/article/view/v014i14} -#' +#' #' @seealso The vignette for \code{stan_glmer}, which also discusses #' \code{stan_gamm4}. \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' # from example(gamm4, package = "gamm4"), prefixing gamm4() call with stan_ @@ -110,7 +110,7 @@ #' dat$fac <- fac <- as.factor(sample(1:20, 400, replace = TRUE)) #' dat$y <- dat$y + model.matrix(~ fac - 1) %*% rnorm(20) * .5 #' -#' br <- stan_gamm4(y ~ s(x0) + x1 + s(x2), data = dat, random = ~ (1 | fac), +#' br <- stan_gamm4(y ~ s(x0) + x1 + s(x2), data = dat, random = ~ (1 | fac), #' chains = 1, iter = 500) # for example speed #' print(br) #' plot_nonlinear(br) @@ -118,235 +118,162 @@ #' } #' } stan_gamm4 <- - function( - formula, - random = NULL, - family = gaussian(), - data, - weights = NULL, - subset = NULL, - na.action, - knots = NULL, - drop.unused.levels = TRUE, - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_smooth = exponential(autoscale = FALSE), - prior_aux = exponential(autoscale = TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE - ) { - data <- validate_data(data, if_missing = list()) - family <- validate_family(family) - - if (length(mgcv::interpret.gam(formula)$smooth.spec) == 0) { - stop( - "Formula must have at least one smooth term to use stan_gamm4.", - call. = FALSE - ) - } - + function(formula, + random = NULL, + family = gaussian(), + data, + weights = NULL, + subset = NULL, + na.action, + knots = NULL, + drop.unused.levels = TRUE, + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_smooth = exponential(autoscale = FALSE), + prior_aux = exponential(autoscale=TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE) { + + data <- validate_data(data, if_missing = list()) + family <- validate_family(family) + + if (length(mgcv::interpret.gam(formula)$smooth.spec) == 0) { + stop("Formula must have at least one smooth term to use stan_gamm4.", call. = FALSE) + } + + if (!is.null(random)) { + fake.formula <- as.character(mgcv::interpret.gam(formula)$fake.formula) + form <- paste(fake.formula[2], fake.formula[1], fake.formula[3], + "+", random[2], collapse = " ") + glmod <- lme4::glFormula(as.formula(form), data, family = gaussian, + subset, weights, na.action, + control = make_glmerControl( + ignore_x_scale = prior$autoscale %ORifNULL% FALSE + ) + ) + data <- glmod$fr + weights <- validate_weights(glmod$fr$weights) + } + else { + weights <- validate_weights(weights) + glmod <- NULL + } + + if (family$family == "binomial") { + data$temp_y <- rep(1, NROW(data)) # work around jagam bug + temp_formula <- update(formula, temp_y ~ .) + jd <- mgcv::jagam(formula = temp_formula, family = gaussian(), data = data, + file = tempfile(fileext = ".jags"), weights = NULL, + na.action = na.action, offset = NULL, knots = knots, + drop.unused.levels = drop.unused.levels, diagonalize = TRUE) + if (!is.null(random)) { - fake.formula <- as.character(mgcv::interpret.gam(formula)$fake.formula) - form <- paste( - fake.formula[2], - fake.formula[1], - fake.formula[3], - "+", - random[2], - collapse = " " - ) - glmod <- lme4::glFormula( - as.formula(form), - data, - family = gaussian, - subset, - weights, - na.action, - control = make_glmerControl( - ignore_x_scale = prior$autoscale %ORifNULL% FALSE - ) - ) - data <- glmod$fr - weights <- validate_weights(glmod$fr$weights) - } else { - weights <- validate_weights(weights) - glmod <- NULL - } - - if (family$family == "binomial") { - data$temp_y <- rep(1, NROW(data)) # work around jagam bug - temp_formula <- update(formula, temp_y ~ .) - jd <- mgcv::jagam( - formula = temp_formula, - family = gaussian(), - data = data, - file = tempfile(fileext = ".jags"), - weights = NULL, - na.action = na.action, - offset = NULL, - knots = knots, - drop.unused.levels = drop.unused.levels, - diagonalize = TRUE - ) - - if (!is.null(random)) { - y <- data[, as.character(formula[2L])] - } else { - y <- eval(formula[[2L]], data) - } - - if (binom_y_prop(y, family, weights)) { - y1 <- as.integer(as.vector(y) * weights) - y <- cbind(y1, y0 = weights - y1) - weights <- double(0) - } - } else { - jd <- mgcv::jagam( - formula = formula, - family = gaussian(), - data = data, - file = tempfile(fileext = ".jags"), - weights = NULL, - na.action = na.action, - offset = NULL, - knots = knots, - drop.unused.levels = drop.unused.levels, - diagonalize = TRUE - ) - y <- jd$jags.data$y - } - # there is no offset allowed by gamm4::gamm4 - offset <- validate_offset(as.vector(model.offset(jd$pregam$model)), y = y) - X <- jd$jags.data$X - mark <- which(colnames(X) != "") - colnames(X) <- colnames(jd$pregam$X) <- jd$pregam$term.names - S <- lapply(jd$pregam$smooth, FUN = function(s) { - ranks <- s$rank - start <- s$first.para - out <- list() - for (r in seq_along(ranks)) { - end <- start + ranks[r] - 1L - out[[r]] <- X[, start:end, drop = FALSE] - start <- end + 1L - } - return(out) - }) - if (any(sapply(S, length) > 1)) { - S <- unlist(S, recursive = FALSE) - } - names(S) <- names(jd$pregam$sp) - X <- X[, mark, drop = FALSE] - - for (s in seq_along(S)) { - # sometimes elements of S are lists themselves that need to be unpacked - # before passing to stan_glm.fit (https://github.com/stan-dev/rstanarm/issues/362) - if (is.list(S[[s]])) { - S[[s]] <- do.call(cbind, S[[s]]) - } - } - X <- c(list(X), S) - - if (is.null(prior)) { - prior <- list() - } - if (is.null(prior_intercept)) { - prior_intercept <- list() - } - if (is.null(prior_aux)) { - prior_aux <- list() - } - if (is.null(prior_smooth)) { - prior_smooth <- list() - } - - if (is.null(random)) { - group <- list() - prior_covariance <- list() + y <- data[, as.character(formula[2L])] } else { - group <- glmod$reTrms - group$decov <- prior_covariance - } - algorithm <- match.arg(algorithm) - - stanfit <- stan_glm.fit( - x = X, - y = y, - weights = weights, - offset = offset, - family = family, - prior = prior, - prior_intercept = prior_intercept, - prior_aux = prior_aux, - prior_smooth = prior_smooth, - prior_PD = prior_PD, - algorithm = algorithm, - adapt_delta = adapt_delta, - group = group, - QR = QR, - ... - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } - if (family$family == "Beta regression") { - family$family <- "beta" + y <- eval(formula[[2L]], data) } - X <- do.call(cbind, args = X) - if (is.null(random)) { - Z <- Matrix::Matrix(nrow = NROW(y), ncol = 0, sparse = TRUE) - } else { - Z <- pad_reTrms( - Ztlist = group$Ztlist, - cnms = group$cnms, - flist = group$flist - )$Z - colnames(Z) <- b_names(names(stanfit), value = TRUE) + + if (binom_y_prop(y, family, weights)) { + y1 <- as.integer(as.vector(y) * weights) + y <- cbind(y1, y0 = weights - y1) + weights <- double(0) } - XZ <- cbind(X, Z) - - # make jam object with point estimates, see ?mgcv::sim2jam - mat <- as.matrix(stanfit) - mark <- 1:ncol(X) - jd$pregam$Vp <- cov(mat[, mark, drop = FALSE]) - jd$pregam$coefficients <- colMeans(mat[, mark, drop = FALSE]) - jd$pregam$sig2 <- if ("sigma" %in% colnames(mat)) { - mean(mat[, "sigma"]) - } else { - 1 + } else { + jd <- mgcv::jagam(formula = formula, family = gaussian(), data = data, + file = tempfile(fileext = ".jags"), weights = NULL, + na.action = na.action, offset = NULL, knots = knots, + drop.unused.levels = drop.unused.levels, diagonalize = TRUE) + y <- jd$jags.data$y + } + # there is no offset allowed by gamm4::gamm4 + offset <- validate_offset(as.vector(model.offset(jd$pregam$model)), y = y) + X <- jd$jags.data$X + mark <- which(colnames(X) != "") + colnames(X) <- colnames(jd$pregam$X) <- jd$pregam$term.names + S <- lapply(jd$pregam$smooth, FUN = function(s) { + ranks <- s$rank + start <- s$first.para + out <- list() + for (r in seq_along(ranks)) { + end <- start + ranks[r] - 1L + out[[r]] <- X[,start:end, drop = FALSE] + start <- end + 1L } - eta <- X %*% t(mat[, mark, drop = FALSE]) - mu <- rowMeans(family$linkinv(eta)) - eta <- rowMeans(eta) - w <- as.numeric(jd$pregam$w * family$mu.eta(eta)^2 / family$variance(mu)) - XWX <- t(X) %*% (w * X) - jd$pregam$edf <- rowSums(jd$pregam$Vp * t(XWX)) / jd$pregam$sig2 - class(jd$pregam) <- c("jam", "gam") - fit <- nlist( - stanfit, - family, - formula, - offset, - weights, - x = XZ, - y = y, - data, - terms = jd$pregam$terms, - model = if (is.null(random)) jd$pregam$model else glmod$fr, - call = match.call(expand.dots = TRUE), - algorithm, - glmod = glmod, - stan_function = "stan_gamm4" - ) - out <- stanreg(fit) - out$jam <- jd$pregam - class(out) <- c(class(out), "gamm4", if (!is.null(glmod)) "lmerMod") return(out) + }) + if (any(sapply(S, length) > 1)) S <- unlist(S, recursive = FALSE) + names(S) <- names(jd$pregam$sp) + X <- X[,mark, drop = FALSE] + + for (s in seq_along(S)) { + # sometimes elements of S are lists themselves that need to be unpacked + # before passing to stan_glm.fit (https://github.com/stan-dev/rstanarm/issues/362) + if (is.list(S[[s]])) + S[[s]] <- do.call(cbind, S[[s]]) + } + X <- c(list(X), S) + + if (is.null(prior)) prior <- list() + if (is.null(prior_intercept)) prior_intercept <- list() + if (is.null(prior_aux)) prior_aux <- list() + if (is.null(prior_smooth)) prior_smooth <- list() + + if (is.null(random)) { + group <- list() + prior_covariance <- list() + } + else { + group <- glmod$reTrms + group$decov <- prior_covariance + } + algorithm <- match.arg(algorithm) + + stanfit <- stan_glm.fit(x = X, y = y, weights = weights, + offset = offset, family = family, + prior = prior, prior_intercept = prior_intercept, + prior_aux = prior_aux, prior_smooth = prior_smooth, + prior_PD = prior_PD, algorithm = algorithm, + adapt_delta = adapt_delta, group = group, QR = QR, ...) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) + if (family$family == "Beta regression") family$family <- "beta" + X <- do.call(cbind, args = X) + if (is.null(random)) Z <- Matrix::Matrix(nrow = NROW(y), ncol = 0, sparse = TRUE) + else { + Z <- pad_reTrms(Ztlist = group$Ztlist, cnms = group$cnms, + flist = group$flist)$Z + colnames(Z) <- b_names(names(stanfit), value = TRUE) } + XZ <- cbind(X, Z) + + # make jam object with point estimates, see ?mgcv::sim2jam + mat <- as.matrix(stanfit) + mark <- 1:ncol(X) + jd$pregam$Vp <- cov(mat[,mark, drop = FALSE]) + jd$pregam$coefficients <- colMeans(mat[,mark, drop = FALSE]) + jd$pregam$sig2 <- if ("sigma" %in% colnames(mat)) mean(mat[,"sigma"]) else 1 + eta <- X %*% t(mat[,mark,drop = FALSE]) + mu <- rowMeans(family$linkinv(eta)) + eta <- rowMeans(eta) + w <- as.numeric(jd$pregam$w * family$mu.eta(eta) ^ 2 / family$variance(mu)) + XWX <- t(X) %*% (w * X) + jd$pregam$edf <- rowSums(jd$pregam$Vp * t(XWX)) / jd$pregam$sig2 + class(jd$pregam) <- c("jam", "gam") + fit <- nlist(stanfit, family, formula, offset, weights, + x = XZ, y = y, data, terms = jd$pregam$terms, + model = if (is.null(random)) jd$pregam$model else glmod$fr, + call = match.call(expand.dots = TRUE), + algorithm, glmod = glmod, + stan_function = "stan_gamm4") + out <- stanreg(fit) + out$jam <- jd$pregam + class(out) <- c(class(out), "gamm4", if (!is.null(glmod)) "lmerMod") + return(out) +} #' @rdname stan_gamm4 #' @export @@ -356,83 +283,64 @@ stan_gamm4 <- #' include all smooth terms. #' @param prob For univarite smooths, a scalar between 0 and 1 governing the #' width of the uncertainty interval. -#' @param facet_args An optional named list of arguments passed to +#' @param facet_args An optional named list of arguments passed to #' \code{\link[ggplot2]{facet_wrap}} (other than the \code{facets} argument). -#' @param alpha,size For univariate smooths, passed to +#' @param alpha,size For univariate smooths, passed to #' \code{\link[ggplot2]{geom_ribbon}}. For bivariate smooths, \code{size/2} is #' passed to \code{\link[ggplot2]{geom_contour}}. -#' +#' #' @return \code{plot_nonlinear} returns a ggplot object. -#' +#' #' @importFrom ggplot2 aes_ aes_string facet_wrap ggplot geom_contour geom_line geom_ribbon labs scale_color_gradient2 -#' -plot_nonlinear <- function( - x, - smooths, - ..., - prob = 0.9, - facet_args = list(), - alpha = 1, - size = 0.75 -) { +#' +plot_nonlinear <- function(x, smooths, ..., + prob = 0.9, facet_args = list(), + alpha = 1, size = 0.75) { validate_stanreg_object(x) - if (!is(x, "gamm4")) { + if (!is(x, "gamm4")) stop("Plot only available for models fit using the stan_gamm4 function.") - } on.exit(message("try plot(x$jam) instead")) scheme <- bayesplot::color_scheme_get() - + XZ <- x$x - XZ <- XZ[, !grepl("_NEW_", colnames(XZ), fixed = TRUE)] + XZ <- XZ[,!grepl("_NEW_", colnames(XZ), fixed = TRUE)] labels <- sapply(x$jam$smooth, "[[", "label") xnames <- sapply(x$jam$smooth, "[[", "vn") names(x$jam$smooth) <- labels names(xnames) <- labels fs <- sapply(x$jam$smooth, FUN = "inherits", what = "fs.interaction") - + if (!missing(smooths)) { found <- smooths %in% labels if (all(!found)) { - stop( - "All specified terms are invalid. Valid terms are: ", - paste( - grep(",", labels, fixed = TRUE, value = TRUE, invert = TRUE), - collapse = ", " - ) - ) + stop("All specified terms are invalid. Valid terms are: ", + paste(grep(",", labels, fixed = TRUE, value = TRUE, invert = TRUE), + collapse = ", ")) } else if (any(!found)) { - warning( - "The following specified terms were not found and ignored: ", - paste(smooths[!found], collapse = ", ") - ) + warning("The following specified terms were not found and ignored: ", + paste(smooths[!found], collapse = ", ")) } labels <- smooths[found] fs <- fs[found] if (!is.matrix(xnames)) xnames <- xnames[found] - } else { - smooths <- 1:length(labels) } - + else smooths <- 1:length(labels) + B <- as.matrix(x)[, colnames(XZ), drop = FALSE] original <- x$jam$model - + bivariate <- any(grepl(",", labels, fixed = TRUE)) if (bivariate && !any(fs)) { if (length(labels) > 1) { on.exit(NULL) - stop( - "Multivariate functions can only be plotted one at a time; specify 'smooths'." - ) + stop("Multivariate functions can only be plotted one at a time; specify 'smooths'.") } - if (length(xnames) > 2) { + if (length(xnames) > 2) stop("Only univariate and bivariate functions can be plotted currently.") - } xrange <- range(original[, xnames[1]]) yrange <- range(original[, xnames[2]]) - xz <- expand.grid( - seq(from = xrange[1], to = xrange[2], length.out = 100), - seq(from = yrange[1], to = yrange[2], length.out = 100) - ) + xz <- expand.grid(seq(from = xrange[1], to = xrange[2], length.out = 100), + seq(from = yrange[1], to = yrange[2], length.out = 100)) colnames(xz) <- xnames[1:2] plot_data <- data.frame(x = xz[, 1], y = xz[, 2]) nd <- original @@ -446,47 +354,45 @@ plot_nonlinear <- function( xz <- XZ[, grepl(labels, colnames(XZ), fixed = TRUE), drop = FALSE] plot_data$z <- apply(linear_predictor.matrix(b, xz), 2, FUN = median) return( - ggplot(plot_data, aes_(x = ~x, y = ~y, z = ~z)) + - geom_contour(aes_string(color = "..level.."), size = size / 2) + - labs(x = xnames[1], y = xnames[2]) + - scale_color_gradient2( - low = scheme[[1]], - mid = scheme[[3]], - high = scheme[[6]] - ) + - bayesplot::theme_default() + ggplot(plot_data, aes_(x = ~x, y = ~y, z = ~z)) + + geom_contour(aes_string(color = "..level.."), size = size/2) + + labs(x = xnames[1], y = xnames[2]) + + scale_color_gradient2(low = scheme[[1]], + mid = scheme[[3]], + high = scheme[[6]]) + + bayesplot::theme_default() ) } - + df_list <- lapply(x$jam$smooth[smooths], FUN = function(s) { incl <- s$first.para:s$last.para b <- B[, incl, drop = FALSE] - if (inherits(s, "fs.interaction")) { - # see mgcv:::plot.fs.interaction - xx <- original[, s$base$term] - fac <- original[, s$fterm] + if (inherits(s, "fs.interaction")) { # see mgcv:::plot.fs.interaction + xx <- original[,s$base$term] + fac <- original[,s$fterm] out <- by(data.frame(fac, xx), list(fac), FUN = function(df) { - df <- df[order(df[, 2]), ] + df <- df[order(df[,2]),] names(df) <- c(s$fterm, s$base$term) xz <- mgcv::PredictMat(s, df) f <- linear_predictor.matrix(b, xz) data.frame( - predictor = df[, 2], - lower = apply(f, 2, quantile, probs = (1 - prob) / 2), - upper = apply(f, 2, quantile, probs = prob + (1 - prob) / 2), + predictor = df[,2], + lower = apply(f, 2, quantile, probs = (1 - prob) / 2), + upper = apply(f, 2, quantile, probs = prob + (1 - prob) / 2), middle = apply(f, 2, median), - term = paste(s$label, df[, 1], sep = ".") + term = paste(s$label, df[,1], sep = ".") ) }) do.call(rbind, args = out) - } else { + } + else { xz <- XZ[, incl, drop = FALSE] x <- original[, s$term] ord <- order(x) x <- x[ord] - xz <- xz[ord, , drop = FALSE] + xz <- xz[ord, , drop=FALSE] if (!is.null(s$by.level)) { - fac <- original[, s$by][ord] + fac <- original[,s$by][ord] mark <- fac == s$by.level x <- x[mark] xz <- xz[mark, , drop = FALSE] @@ -494,39 +400,29 @@ plot_nonlinear <- function( f <- linear_predictor.matrix(b, xz) data.frame( predictor = x, - lower = apply(f, 2, quantile, probs = (1 - prob) / 2), - upper = apply(f, 2, quantile, probs = prob + (1 - prob) / 2), + lower = apply(f, 2, quantile, probs = (1 - prob) / 2), + upper = apply(f, 2, quantile, probs = prob + (1 - prob) / 2), middle = apply(f, 2, median), term = s$label ) } }) plot_data <- do.call(rbind, df_list) - - facet_args[["facets"]] <- ~term - if (is.null(facet_args[["scales"]])) { + + facet_args[["facets"]] <- ~ term + if (is.null(facet_args[["scales"]])) facet_args[["scales"]] <- "free" - } - if (is.null(facet_args[["strip.position"]])) { + if (is.null(facet_args[["strip.position"]])) facet_args[["strip.position"]] <- "left" - } - on.exit(NULL) - ggplot(plot_data, aes_(x = ~predictor)) + - geom_ribbon( - aes_(ymin = ~lower, ymax = ~upper), - fill = scheme[[1]], - color = scheme[[2]], - alpha = alpha, - size = size - ) + - geom_line( - aes_(y = ~middle), - color = scheme[[5]], - size = 0.75 * size, - lineend = "round" - ) + - labs(y = NULL) + - do.call(facet_wrap, facet_args) + + on.exit(NULL) + ggplot(plot_data, aes_(x = ~ predictor)) + + geom_ribbon(aes_(ymin = ~ lower, ymax = ~ upper), + fill = scheme[[1]], color = scheme[[2]], + alpha = alpha, size = size) + + geom_line(aes_(y = ~ middle), color = scheme[[5]], + size = 0.75 * size, lineend = "round") + + labs(y = NULL) + + do.call(facet_wrap, facet_args) + bayesplot::theme_default() -} +} \ No newline at end of file diff --git a/R/stan_glm.R b/R/stan_glm.R index 3292a6c0c..143899a8b 100644 --- a/R/stan_glm.R +++ b/R/stan_glm.R @@ -1,16 +1,16 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. @@ -25,7 +25,7 @@ #' @templateVar armRef (Ch. 3-6) #' @templateVar pkg stats #' @templateVar pkgfun glm -#' @templateVar sameargs model,offset,weights +#' @templateVar sameargs model,offset,weights #' @templateVar rareargs na.action,contrasts #' @templateVar fun stan_glm, stan_glm.nb #' @templateVar fitfun stan_glm.fit @@ -46,7 +46,7 @@ #' @template args-sparse #' @template reference-gelman-hill #' @template reference-muth -#' +#' #' @param family Same as \code{\link[stats]{glm}}, except negative binomial GLMs #' are also possible using the \code{\link{neg_binomial_2}} family object. #' @param y In \code{stan_glm}, logical scalar indicating whether to @@ -70,35 +70,35 @@ #' implausible then there may be something wrong, e.g., severe model #' misspecification, problems with the data and/or priors, computational #' issues, etc. -#' -#' @details The \code{stan_glm} function is similar in syntax to -#' \code{\link[stats]{glm}} but rather than performing maximum likelihood -#' estimation of generalized linear models, full Bayesian estimation is +#' +#' @details The \code{stan_glm} function is similar in syntax to +#' \code{\link[stats]{glm}} but rather than performing maximum likelihood +#' estimation of generalized linear models, full Bayesian estimation is #' performed (if \code{algorithm} is \code{"sampling"}) via MCMC. The Bayesian #' model adds priors (independent by default) on the coefficients of the GLM. #' The \code{stan_glm} function calls the workhorse \code{stan_glm.fit} #' function, but it is also possible to call the latter directly. -#' -#' The \code{stan_glm.nb} function, which takes the extra argument -#' \code{link}, is a wrapper for \code{stan_glm} with \code{family = +#' +#' The \code{stan_glm.nb} function, which takes the extra argument +#' \code{link}, is a wrapper for \code{stan_glm} with \code{family = #' \link{neg_binomial_2}(link)}. -#' +#' #' @seealso The various vignettes for \code{stan_glm} at #' \url{https://mc-stan.org/rstanarm/articles/}. -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' ### Linear regression #' mtcars$mpg10 <- mtcars$mpg / 10 #' fit <- stan_glm( -#' mpg10 ~ wt + cyl + am, -#' data = mtcars, +#' mpg10 ~ wt + cyl + am, +#' data = mtcars, #' QR = TRUE, #' # for speed of example only (default is "sampling") #' algorithm = "fullrank", -#' refresh = 0 -#' ) -#' +#' refresh = 0 +#' ) +#' #' plot(fit, prob = 0.5) #' plot(fit, prob = 0.5, pars = "beta") #' plot(fit, "hist", pars = "sigma") @@ -107,262 +107,237 @@ #' head(wells) #' wells$dist100 <- wells$dist / 100 #' fit2 <- stan_glm( -#' switch ~ dist100 + arsenic, -#' data = wells, -#' family = binomial(link = "logit"), +#' switch ~ dist100 + arsenic, +#' data = wells, +#' family = binomial(link = "logit"), #' prior_intercept = normal(0, 10), #' QR = TRUE, #' refresh = 0, #' # for speed of example only -#' chains = 2, iter = 200 +#' chains = 2, iter = 200 #' ) #' print(fit2) #' prior_summary(fit2) -#' +#' #' # ?bayesplot::mcmc_areas #' plot(fit2, plotfun = "areas", prob = 0.9, #' pars = c("(Intercept)", "arsenic")) -#' +#' #' # ?bayesplot::ppc_error_binned -#' pp_check(fit2, plotfun = "error_binned") -#' -#' -#' ### Poisson regression (example from help("glm")) +#' pp_check(fit2, plotfun = "error_binned") +#' +#' +#' ### Poisson regression (example from help("glm")) #' count_data <- data.frame( #' counts = c(18,17,15,20,10,20,25,13,12), #' outcome = gl(3,1,9), #' treatment = gl(3,3) #' ) #' fit3 <- stan_glm( -#' counts ~ outcome + treatment, -#' data = count_data, +#' counts ~ outcome + treatment, +#' data = count_data, #' family = poisson(link="log"), #' prior = normal(0, 2), #' refresh = 0, #' # for speed of example only -#' chains = 2, iter = 250 -#' ) +#' chains = 2, iter = 250 +#' ) #' print(fit3) -#' +#' #' bayesplot::color_scheme_set("viridis") #' plot(fit3) #' plot(fit3, regex_pars = c("outcome", "treatment")) #' plot(fit3, plotfun = "combo", regex_pars = "treatment") # ?bayesplot::mcmc_combo #' posterior_vs_prior(fit3, regex_pars = c("outcome", "treatment")) -#' +#' #' ### Gamma regression (example from help("glm")) #' clotting <- data.frame(log_u = log(c(5,10,15,20,30,40,60,80,100)), #' lot1 = c(118,58,42,35,27,25,21,19,18), #' lot2 = c(69,35,26,21,18,16,13,12,12)) #' fit4 <- stan_glm( -#' lot1 ~ log_u, -#' data = clotting, +#' lot1 ~ log_u, +#' data = clotting, #' family = Gamma(link="log"), #' iter = 500, # for speed of example only #' refresh = 0 -#' ) +#' ) #' print(fit4, digits = 2) -#' +#' #' fit5 <- update(fit4, formula = lot2 ~ log_u) -#' +#' #' # ?bayesplot::ppc_dens_overlay #' bayesplot::bayesplot_grid( -#' pp_check(fit4, seed = 123), +#' pp_check(fit4, seed = 123), #' pp_check(fit5, seed = 123), #' titles = c("lot1", "lot2") -#' ) -#' -#' +#' ) +#' +#' #' ### Negative binomial regression #' fit6 <- stan_glm.nb( -#' Days ~ Sex/(Age + Eth*Lrn), -#' data = MASS::quine, -#' link = "log", +#' Days ~ Sex/(Age + Eth*Lrn), +#' data = MASS::quine, +#' link = "log", #' prior_aux = exponential(1.5, autoscale=TRUE), #' chains = 2, iter = 200, # for speed of example only #' refresh = 0 -#' ) -#' +#' ) +#' #' prior_summary(fit6) #' bayesplot::color_scheme_set("brightblue") #' plot(fit6) #' pp_check(fit6, plotfun = "hist", nreps = 5) # ?bayesplot::ppc_hist -#' +#' #' # 80% interval of estimated reciprocal_dispersion parameter #' posterior_interval(fit6, pars = "reciprocal_dispersion", prob = 0.8) #' plot(fit6, "areas", pars = "reciprocal_dispersion", prob = 0.8) #' } #' } stan_glm <- - function( - formula, - family = gaussian(), - data, - weights, - subset, - na.action = NULL, - offset = NULL, - model = TRUE, - x = FALSE, - y = TRUE, - contrasts = NULL, - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale = TRUE), - prior_PD = FALSE, - algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), - mean_PPD = algorithm != "optimizing" && !prior_PD, - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE - ) { - algorithm <- match.arg(algorithm) - family <- validate_family(family) - validate_glm_formula(formula) - data <- validate_data(data, if_missing = environment(formula)) - - call <- match.call(expand.dots = TRUE) - mf <- match.call(expand.dots = FALSE) - m <- match( - c("formula", "subset", "weights", "na.action", "offset"), - table = names(mf), - nomatch = 0L - ) - mf <- mf[c(1L, m)] - mf$data <- data - mf$drop.unused.levels <- TRUE - mf[[1L]] <- as.name("model.frame") - mf <- eval(mf, parent.frame()) - mf <- check_constant_vars(mf) - mt <- attr(mf, "terms") - Y <- array1D_check(model.response(mf, type = "any")) - if (is.empty.model(mt)) { - stop("No intercept or predictors specified.", call. = FALSE) - } - X <- model.matrix(mt, mf, contrasts) - contrasts <- attr(X, "contrasts") - weights <- validate_weights(as.vector(model.weights(mf))) - offset <- validate_offset(as.vector(model.offset(mf)), y = Y) - if (binom_y_prop(Y, family, weights)) { - y1 <- as.integer(as.vector(Y) * weights) - Y <- cbind(y1, y0 = weights - y1) - weights <- double(0) - } - - if (prior_PD) { - # can result in errors (e.g. from poisson) if draws from prior are weird - mean_PPD <- FALSE - } - - stanfit <- stan_glm.fit( - x = X, - y = Y, - weights = weights, - offset = offset, - family = family, - prior = prior, - prior_intercept = prior_intercept, - prior_aux = prior_aux, - prior_PD = prior_PD, - algorithm = algorithm, - mean_PPD = mean_PPD, - adapt_delta = adapt_delta, - QR = QR, - sparse = sparse, - ... - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } - if (family$family == "Beta regression") { - family$family <- "beta" - } - - sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) - X <- X[, !sel, drop = FALSE] + function(formula, + family = gaussian(), + data, + weights, + subset, + na.action = NULL, + offset = NULL, + model = TRUE, + x = FALSE, + y = TRUE, + contrasts = NULL, + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale=TRUE), + prior_PD = FALSE, + algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), + mean_PPD = algorithm != "optimizing" && !prior_PD, + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE) { + + algorithm <- match.arg(algorithm) + family <- validate_family(family) + validate_glm_formula(formula) + data <- validate_data(data, if_missing = environment(formula)) + + call <- match.call(expand.dots = TRUE) + mf <- match.call(expand.dots = FALSE) + m <- match(c("formula", "subset", "weights", "na.action", "offset"), + table = names(mf), nomatch = 0L) + mf <- mf[c(1L, m)] + mf$data <- data + mf$drop.unused.levels <- TRUE + mf[[1L]] <- as.name("model.frame") + mf <- eval(mf, parent.frame()) + mf <- check_constant_vars(mf) + mt <- attr(mf, "terms") + Y <- array1D_check(model.response(mf, type = "any")) + if (is.empty.model(mt)) + stop("No intercept or predictors specified.", call. = FALSE) + X <- model.matrix(mt, mf, contrasts) + contrasts <- attr(X, "contrasts") + weights <- validate_weights(as.vector(model.weights(mf))) + offset <- validate_offset(as.vector(model.offset(mf)), y = Y) + if (binom_y_prop(Y, family, weights)) { + y1 <- as.integer(as.vector(Y) * weights) + Y <- cbind(y1, y0 = weights - y1) + weights <- double(0) + } + + if (prior_PD) { + # can result in errors (e.g. from poisson) if draws from prior are weird + mean_PPD <- FALSE + } - fit <- nlist( - stanfit, - algorithm, - family, - formula, - data, - offset, - weights, - x = X, - y = Y, - model = mf, - terms = mt, - call, - na.action = attr(mf, "na.action"), - contrasts = contrasts, - stan_function = "stan_glm" - ) + stanfit <- stan_glm.fit( + x = X, + y = Y, + weights = weights, + offset = offset, + family = family, + prior = prior, + prior_intercept = prior_intercept, + prior_aux = prior_aux, + prior_PD = prior_PD, + algorithm = algorithm, + mean_PPD = mean_PPD, + adapt_delta = adapt_delta, + QR = QR, + sparse = sparse, + ... + ) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) + if (family$family == "Beta regression") { + family$family <- "beta" + } - out <- stanreg(fit) - if (algorithm == "optimizing") { - out$log_p <- stanfit$log_p - out$log_g <- stanfit$log_g - out$psis <- stanfit$psis - out$ir_idx <- stanfit$ir_idx - out$diagnostics <- stanfit$diagnostics - } - out$compute_mean_PPD <- mean_PPD - out$xlevels <- .getXlevels(mt, mf) - if (!x) { - out$x <- NULL - } - if (!y) { - out$y <- NULL - } - if (!model) { - out$model <- NULL - } + sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) + X <- X[ , !sel, drop = FALSE] - return(out) + fit <- nlist(stanfit, algorithm, family, formula, data, offset, weights, + x = X, y = Y, model = mf, terms = mt, call, + na.action = attr(mf, "na.action"), + contrasts = contrasts, + stan_function = "stan_glm") + + out <- stanreg(fit) + if (algorithm == "optimizing") { + out$log_p <- stanfit$log_p + out$log_g <- stanfit$log_g + out$psis <- stanfit$psis + out$ir_idx <- stanfit$ir_idx + out$diagnostics <- stanfit$diagnostics } + out$compute_mean_PPD <- mean_PPD + out$xlevels <- .getXlevels(mt, mf) + if (!x) + out$x <- NULL + if (!y) + out$y <- NULL + if (!model) + out$model <- NULL + + return(out) +} #' @rdname stan_glm #' @export -#' @param link For \code{stan_glm.nb} only, the link function to use. See +#' @param link For \code{stan_glm.nb} only, the link function to use. See #' \code{\link{neg_binomial_2}}. -#' -stan_glm.nb <- - function( - formula, - data, - weights, - subset, - na.action = NULL, - offset = NULL, - model = TRUE, - x = FALSE, - y = TRUE, - contrasts = NULL, - link = "log", - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale = TRUE), - prior_PD = FALSE, - algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), - mean_PPD = algorithm != "optimizing", - adapt_delta = NULL, - QR = FALSE - ) { - if ("family" %in% names(list(...))) { - stop("'family' should not be specified.") - } - mc <- call <- match.call() - if (!"formula" %in% names(call)) { - names(call)[2L] <- "formula" - } - mc[[1L]] <- quote(stan_glm) - mc$link <- NULL - mc$family <- neg_binomial_2(link = link) - out <- eval(mc, parent.frame()) - out$call <- call - out$stan_function <- "stan_glm.nb" - return(out) - } +#' +stan_glm.nb <- + function(formula, + data, + weights, + subset, + na.action = NULL, + offset = NULL, + model = TRUE, + x = FALSE, + y = TRUE, + contrasts = NULL, + link = "log", + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale=TRUE), + prior_PD = FALSE, + algorithm = c("sampling", "optimizing", "meanfield", "fullrank"), + mean_PPD = algorithm != "optimizing", + adapt_delta = NULL, + QR = FALSE) { + + if ("family" %in% names(list(...))) + stop("'family' should not be specified.") + mc <- call <- match.call() + if (!"formula" %in% names(call)) + names(call)[2L] <- "formula" + mc[[1L]] <- quote(stan_glm) + mc$link <- NULL + mc$family <- neg_binomial_2(link = link) + out <- eval(mc, parent.frame()) + out$call <- call + out$stan_function <- "stan_glm.nb" + return(out) +} \ No newline at end of file diff --git a/R/stan_glmer.R b/R/stan_glmer.R index e82211944..945ec6797 100644 --- a/R/stan_glmer.R +++ b/R/stan_glmer.R @@ -1,26 +1,26 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian generalized linear models with group-specific terms via Stan -#' +#' #' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Bayesian inference for GLMs with group-specific coefficients that have +#' Bayesian inference for GLMs with group-specific coefficients that have #' unknown covariance matrices with flexible priors. -#' +#' #' @export #' @templateVar armRef (Ch. 11-15) #' @templateVar fun stan_glmer, stan_lmer, stan_glmer.nb @@ -39,263 +39,226 @@ #' @template args-sparse #' @template reference-gelman-hill #' @template reference-muth -#' +#' #' @param formula,data Same as for \code{\link[lme4]{glmer}}. \emph{We -#' strongly advise against omitting the \code{data} argument}. Unless -#' \code{data} is specified (and is a data frame) many post-estimation -#' functions (including \code{update}, \code{loo}, \code{kfold}) are not +#' strongly advise against omitting the \code{data} argument}. Unless +#' \code{data} is specified (and is a data frame) many post-estimation +#' functions (including \code{update}, \code{loo}, \code{kfold}) are not #' guaranteed to work properly. #' @param family Same as for \code{\link[lme4]{glmer}} except it is also #' possible to use \code{family=mgcv::betar} to estimate a Beta regression #' with \code{stan_glmer}. #' @param subset,weights,offset Same as \code{\link[stats]{glm}}. -#' @param na.action,contrasts Same as \code{\link[stats]{glm}}, but rarely +#' @param na.action,contrasts Same as \code{\link[stats]{glm}}, but rarely #' specified. -#' @param ... For \code{stan_glmer}, further arguments passed to -#' \code{\link[rstan:stanmodel-method-sampling]{sampling}} (e.g. \code{iter}, \code{chains}, -#' \code{cores}, etc.) or to \code{\link[rstan:stanmodel-method-vb]{vb}} (if \code{algorithm} is -#' \code{"meanfield"} or \code{"fullrank"}). For \code{stan_lmer} and +#' @param ... For \code{stan_glmer}, further arguments passed to +#' \code{\link[rstan:stanmodel-method-sampling]{sampling}} (e.g. \code{iter}, \code{chains}, +#' \code{cores}, etc.) or to \code{\link[rstan:stanmodel-method-vb]{vb}} (if \code{algorithm} is +#' \code{"meanfield"} or \code{"fullrank"}). For \code{stan_lmer} and #' \code{stan_glmer.nb}, \code{...} should also contain all relevant arguments #' to pass to \code{stan_glmer} (except \code{family}). #' -#' @details The \code{stan_glmer} function is similar in syntax to -#' \code{\link[lme4]{glmer}} but rather than performing (restricted) maximum -#' likelihood estimation of generalized linear models, Bayesian estimation is -#' performed via MCMC. The Bayesian model adds priors on the +#' @details The \code{stan_glmer} function is similar in syntax to +#' \code{\link[lme4]{glmer}} but rather than performing (restricted) maximum +#' likelihood estimation of generalized linear models, Bayesian estimation is +#' performed via MCMC. The Bayesian model adds priors on the #' regression coefficients (in the same way as \code{\link{stan_glm}}) and #' priors on the terms of a decomposition of the covariance matrices of the #' group-specific parameters. See \code{\link{priors}} for more information #' about the priors. -#' -#' The \code{stan_lmer} function is equivalent to \code{stan_glmer} with -#' \code{family = gaussian(link = "identity")}. -#' -#' The \code{stan_glmer.nb} function, which takes the extra argument -#' \code{link}, is a wrapper for \code{stan_glmer} with \code{family = +#' +#' The \code{stan_lmer} function is equivalent to \code{stan_glmer} with +#' \code{family = gaussian(link = "identity")}. +#' +#' The \code{stan_glmer.nb} function, which takes the extra argument +#' \code{link}, is a wrapper for \code{stan_glmer} with \code{family = #' \link{neg_binomial_2}(link)}. -#' -#' @return A list with classes \code{stanreg}, \code{glm}, \code{lm}, +#' +#' @return A list with classes \code{stanreg}, \code{glm}, \code{lm}, #' and \code{lmerMod}. The conventions for the parameter names are the #' same as in the lme4 package with the addition that the standard #' deviation of the errors is called \code{sigma} and the variance-covariance #' matrix of the group-specific deviations from the common parameters is #' called \code{Sigma}, even if this variance-covariance matrix only has #' one row and one column (in which case it is just the group-level variance). -#' -#' -#' @seealso The vignette for \code{stan_glmer} and the \emph{Hierarchical +#' +#' +#' @seealso The vignette for \code{stan_glmer} and the \emph{Hierarchical #' Partial Pooling} vignette. \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch != "i386") { #' # see help(example_model) for details on the model below -#' if (!exists("example_model")) example(example_model) +#' if (!exists("example_model")) example(example_model) #' print(example_model, digits = 1) #' } #' @importFrom lme4 glFormula #' @importFrom Matrix Matrix t -stan_glmer <- - function( - formula, - data = NULL, - family = gaussian, - subset, - weights, - na.action = getOption("na.action", "na.omit"), - offset, - contrasts = NULL, - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale = TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE - ) { - call <- match.call(expand.dots = TRUE) - mc <- match.call(expand.dots = FALSE) - data <- validate_data(data) #, if_missing = environment(formula)) - family <- validate_family(family) - mc[[1]] <- quote(lme4::glFormula) - mc$control <- make_glmerControl( - ignore_lhs = prior_PD, - ignore_x_scale = prior$autoscale %ORifNULL% FALSE - ) - mc$data <- data - mc$prior <- mc$prior_intercept <- mc$prior_covariance <- mc$prior_aux <- - mc$prior_PD <- mc$algorithm <- mc$scale <- mc$concentration <- mc$shape <- - mc$adapt_delta <- mc$... <- mc$QR <- mc$sparse <- NULL - glmod <- eval(mc, parent.frame()) - X <- glmod$X - if ("b" %in% colnames(X)) { - stop( - "stan_glmer does not allow the name 'b' for predictor variables.", - call. = FALSE - ) - } - - if (prior_PD && !has_outcome_variable(formula)) { - y <- NULL - } else { - y <- glmod$fr[, as.character(glmod$formula[2L])] - if (is.matrix(y) && ncol(y) == 1L) { - y <- as.vector(y) - } - } - - offset <- model.offset(glmod$fr) %ORifNULL% double(0) - weights <- validate_weights(as.vector(model.weights(glmod$fr))) - if (binom_y_prop(y, family, weights)) { - y1 <- as.integer(as.vector(y) * weights) - y <- cbind(y1, y0 = weights - y1) - weights <- double(0) - } - - if (is.null(prior_covariance)) { - stop("'prior_covariance' can't be NULL.", call. = FALSE) - } - group <- glmod$reTrms - group$decov <- prior_covariance - algorithm <- match.arg(algorithm) - stanfit <- stan_glm.fit( - x = X, - y = y, - weights = weights, - offset = offset, - family = family, - prior = prior, - prior_intercept = prior_intercept, - prior_aux = prior_aux, - prior_PD = prior_PD, - algorithm = algorithm, - adapt_delta = adapt_delta, - group = group, - QR = QR, - sparse = sparse, - mean_PPD = !prior_PD, - ... - ) - - add_classes <- "lmerMod" # additional classes to eventually add to stanreg object - if (family$family == "Beta regression") { - add_classes <- c(add_classes, "betareg") - family$family <- "beta" +stan_glmer <- + function(formula, + data = NULL, + family = gaussian, + subset, + weights, + na.action = getOption("na.action", "na.omit"), + offset, + contrasts = NULL, + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale=TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE) { + + call <- match.call(expand.dots = TRUE) + mc <- match.call(expand.dots = FALSE) + data <- validate_data(data) #, if_missing = environment(formula)) + family <- validate_family(family) + mc[[1]] <- quote(lme4::glFormula) + mc$control <- make_glmerControl( + ignore_lhs = prior_PD, + ignore_x_scale = prior$autoscale %ORifNULL% FALSE + ) + mc$data <- data + mc$prior <- mc$prior_intercept <- mc$prior_covariance <- mc$prior_aux <- + mc$prior_PD <- mc$algorithm <- mc$scale <- mc$concentration <- mc$shape <- + mc$adapt_delta <- mc$... <- mc$QR <- mc$sparse <- NULL + glmod <- eval(mc, parent.frame()) + X <- glmod$X + if ("b" %in% colnames(X)) { + stop("stan_glmer does not allow the name 'b' for predictor variables.", + call. = FALSE) + } + + if (prior_PD && !has_outcome_variable(formula)) { + y <- NULL + } else { + y <- glmod$fr[, as.character(glmod$formula[2L])] + if (is.matrix(y) && ncol(y) == 1L) { + y <- as.vector(y) } - sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) - X <- X[, !sel, drop = FALSE] - Z <- pad_reTrms( - Ztlist = group$Ztlist, - cnms = group$cnms, - flist = group$flist - )$Z - colnames(Z) <- b_names(names(stanfit), value = TRUE) - - fit <- nlist( - stanfit, - family, - formula, - offset, - weights, - x = cbind(X, Z), - y = y, - data, - call, - terms = NULL, - model = NULL, - na.action = attr(glmod$fr, "na.action"), - contrasts, - algorithm, - glmod, - stan_function = "stan_glmer" - ) - out <- stanreg(fit) - class(out) <- c(class(out), add_classes) + } - return(out) + offset <- model.offset(glmod$fr) %ORifNULL% double(0) + weights <- validate_weights(as.vector(model.weights(glmod$fr))) + if (binom_y_prop(y, family, weights)) { + y1 <- as.integer(as.vector(y) * weights) + y <- cbind(y1, y0 = weights - y1) + weights <- double(0) + } + + if (is.null(prior_covariance)) + stop("'prior_covariance' can't be NULL.", call. = FALSE) + group <- glmod$reTrms + group$decov <- prior_covariance + algorithm <- match.arg(algorithm) + stanfit <- stan_glm.fit(x = X, y = y, weights = weights, + offset = offset, family = family, + prior = prior, prior_intercept = prior_intercept, + prior_aux = prior_aux, prior_PD = prior_PD, + algorithm = algorithm, adapt_delta = adapt_delta, + group = group, QR = QR, sparse = sparse, + mean_PPD = !prior_PD, + ...) + + add_classes <- "lmerMod" # additional classes to eventually add to stanreg object + if (family$family == "Beta regression") { + add_classes <- c(add_classes, "betareg") + family$family <- "beta" } + sel <- apply(X, 2L, function(x) !all(x == 1) && length(unique(x)) < 2) + X <- X[ , !sel, drop = FALSE] + Z <- pad_reTrms(Ztlist = group$Ztlist, cnms = group$cnms, + flist = group$flist)$Z + colnames(Z) <- b_names(names(stanfit), value = TRUE) + + fit <- nlist(stanfit, family, formula, offset, weights, + x = cbind(X, Z), y = y, data, call, terms = NULL, model = NULL, + na.action = attr(glmod$fr, "na.action"), contrasts, algorithm, glmod, + stan_function = "stan_glmer") + out <- stanreg(fit) + class(out) <- c(class(out), add_classes) + + return(out) +} #' @rdname stan_glmer #' @export -stan_lmer <- - function( - formula, - data = NULL, - subset, - weights, - na.action = getOption("na.action", "na.omit"), - offset, - contrasts = NULL, - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale = TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE - ) { - if ("family" %in% names(list(...))) { - stop( - "'family' should not be specified. ", - "To specify a family use stan_glmer instead of stan_lmer." - ) - } - mc <- call <- match.call(expand.dots = TRUE) - if (!"formula" %in% names(call)) { - names(call)[2L] <- "formula" - } - mc[[1L]] <- quote(stan_glmer) - mc$REML <- NULL - mc$family <- "gaussian" - out <- eval(mc, parent.frame()) - out$call <- call - out$stan_function <- "stan_lmer" - return(out) +stan_lmer <- + function(formula, + data = NULL, + subset, + weights, + na.action = getOption("na.action", "na.omit"), + offset, + contrasts = NULL, + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale=TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE) { + if ("family" %in% names(list(...))) { + stop( + "'family' should not be specified. ", + "To specify a family use stan_glmer instead of stan_lmer." + ) } + mc <- call <- match.call(expand.dots = TRUE) + if (!"formula" %in% names(call)) + names(call)[2L] <- "formula" + mc[[1L]] <- quote(stan_glmer) + mc$REML <- NULL + mc$family <- "gaussian" + out <- eval(mc, parent.frame()) + out$call <- call + out$stan_function <- "stan_lmer" + return(out) +} #' @rdname stan_glmer #' @export -#' @param link For \code{stan_glmer.nb} only, the link function to use. See +#' @param link For \code{stan_glmer.nb} only, the link function to use. See #' \code{\link{neg_binomial_2}}. -#' -stan_glmer.nb <- - function( - formula, - data = NULL, - subset, - weights, - na.action = getOption("na.action", "na.omit"), - offset, - contrasts = NULL, - link = "log", - ..., - prior = default_prior_coef(family), - prior_intercept = default_prior_intercept(family), - prior_aux = exponential(autoscale = TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE - ) { - if ("family" %in% names(list(...))) { - stop("'family' should not be specified.") - } - mc <- call <- match.call(expand.dots = TRUE) - if (!"formula" %in% names(call)) { - names(call)[2L] <- "formula" - } - mc[[1]] <- quote(stan_glmer) - mc$REML <- mc$link <- NULL - mc$family <- neg_binomial_2(link = link) - out <- eval(mc, parent.frame()) - out$call <- call - out$stan_function <- "stan_glmer.nb" - return(out) - } +#' +stan_glmer.nb <- + function(formula, + data = NULL, + subset, + weights, + na.action = getOption("na.action", "na.omit"), + offset, + contrasts = NULL, + link = "log", + ..., + prior = default_prior_coef(family), + prior_intercept = default_prior_intercept(family), + prior_aux = exponential(autoscale=TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE) { + + if ("family" %in% names(list(...))) + stop("'family' should not be specified.") + mc <- call <- match.call(expand.dots = TRUE) + if (!"formula" %in% names(call)) + names(call)[2L] <- "formula" + mc[[1]] <- quote(stan_glmer) + mc$REML <- mc$link <- NULL + mc$family <- neg_binomial_2(link = link) + out <- eval(mc, parent.frame()) + out$call <- call + out$stan_function <- "stan_glmer.nb" + return(out) +} \ No newline at end of file diff --git a/R/stan_jm.R b/R/stan_jm.R index b8aac1a54..2e3998fb4 100644 --- a/R/stan_jm.R +++ b/R/stan_jm.R @@ -1,27 +1,27 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University # Copyright (C) 2016, 2017 Sam Brilleman -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian joint longitudinal and time-to-event models via Stan -#' +#' #' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Fits a shared parameter joint model for longitudinal and time-to-event +#' Fits a shared parameter joint model for longitudinal and time-to-event #' (e.g. survival) data under a Bayesian framework using Stan. -#' +#' #' @export #' @template args-dots #' @template args-prior_PD @@ -30,31 +30,31 @@ #' @template args-max_treedepth #' @template args-QR #' @template args-sparse -#' -#' @param formulaLong A two-sided linear formula object describing both the +#' +#' @param formulaLong A two-sided linear formula object describing both the #' fixed-effects and random-effects parts of the longitudinal submodel, #' similar in vein to formula specification in the \strong{lme4} package -#' (see \code{\link[lme4]{glmer}} or the \strong{lme4} vignette for details). -#' Note however that the double bar (\code{||}) notation is not allowed +#' (see \code{\link[lme4]{glmer}} or the \strong{lme4} vignette for details). +#' Note however that the double bar (\code{||}) notation is not allowed #' when specifying the random-effects parts of the formula, and neither -#' are nested grouping factors (e.g. \code{(1 | g1/g2))} or -#' \code{(1 | g1:g2)}, where \code{g1}, \code{g2} are grouping factors. +#' are nested grouping factors (e.g. \code{(1 | g1/g2))} or +#' \code{(1 | g1:g2)}, where \code{g1}, \code{g2} are grouping factors. #' Offset terms can also be included in the model formula. -#' For a multivariate joint model (i.e. more than one longitudinal marker) +#' For a multivariate joint model (i.e. more than one longitudinal marker) #' this should be a list of such formula objects, with each element #' of the list providing the formula for one of the longitudinal submodels. #' @param dataLong A data frame containing the variables specified in #' \code{formulaLong}. If fitting a multivariate joint model, then this can -#' be either a single data frame which contains the data for all +#' be either a single data frame which contains the data for all #' longitudinal submodels, or it can be a list of data frames where each -#' element of the list provides the data for one of the longitudinal +#' element of the list provides the data for one of the longitudinal #' submodels. #' @param formulaEvent A two-sided formula object describing the event -#' submodel. The left hand side of the formula should be a \code{Surv()} +#' submodel. The left hand side of the formula should be a \code{Surv()} #' object. See \code{\link[survival]{Surv}}. #' @param dataEvent A data frame containing the variables specified in #' \code{formulaEvent}. -#' @param time_var A character string specifying the name of the variable +#' @param time_var A character string specifying the name of the variable #' in \code{dataLong} which represents time. #' @param id_var A character string specifying the name of the variable in #' \code{dataLong} which distinguishes between individuals. This can be @@ -62,458 +62,458 @@ #' to be the individual). If there is more than one grouping factor (i.e. #' clustering beyond the level of the individual) then the \code{id_var} #' argument must be specified. -#' @param family The family (and possibly also the link function) for the -#' longitudinal submodel(s). See \code{\link[lme4]{glmer}} for details. +#' @param family The family (and possibly also the link function) for the +#' longitudinal submodel(s). See \code{\link[lme4]{glmer}} for details. #' If fitting a multivariate joint model, then this can optionally be a #' list of families, in which case each element of the list specifies the #' family for one of the longitudinal submodels. #' @param assoc A character string or character vector specifying the joint #' model association structure. Possible association structures that can -#' be used include: "etavalue" (the default); "etaslope"; "etaauc"; -#' "muvalue"; "muslope"; "muauc"; "shared_b"; "shared_coef"; or "null". -#' These are described in the \strong{Details} section below. For a multivariate -#' joint model, different association structures can optionally be used for +#' be used include: "etavalue" (the default); "etaslope"; "etaauc"; +#' "muvalue"; "muslope"; "muauc"; "shared_b"; "shared_coef"; or "null". +#' These are described in the \strong{Details} section below. For a multivariate +#' joint model, different association structures can optionally be used for #' each longitudinal submodel by specifying a list of character -#' vectors, with each element of the list specifying the desired association +#' vectors, with each element of the list specifying the desired association #' structure for one of the longitudinal submodels. Specifying \code{assoc = NULL} -#' will fit a joint model with no association structure (equivalent -#' to fitting separate longitudinal and time-to-event models). It is also -#' possible to include interaction terms between the association term -#' ("etavalue", "etaslope", "muvalue", "muslope") and observed data/covariates. -#' It is also possible, when fitting a multivariate joint model, to include -#' interaction terms between the association terms ("etavalue" or "muvalue") -#' corresponding to the different longitudinal outcomes. See the +#' will fit a joint model with no association structure (equivalent +#' to fitting separate longitudinal and time-to-event models). It is also +#' possible to include interaction terms between the association term +#' ("etavalue", "etaslope", "muvalue", "muslope") and observed data/covariates. +#' It is also possible, when fitting a multivariate joint model, to include +#' interaction terms between the association terms ("etavalue" or "muvalue") +#' corresponding to the different longitudinal outcomes. See the #' \strong{Details} section as well as the \strong{Examples} below. #' @param lag_assoc A non-negative scalar specifying the time lag that should be -#' used for the association structure. That is, the hazard of the event at -#' time \emph{t} will be assumed to be associated with the value/slope/auc of +#' used for the association structure. That is, the hazard of the event at +#' time \emph{t} will be assumed to be associated with the value/slope/auc of #' the longitudinal marker at time \emph{t-u}, where \emph{u} is the time lag. #' If fitting a multivariate joint model, then a different time lag can be used #' for each longitudinal marker by providing a numeric vector of lags, otherwise -#' if a scalar is provided then the specified time lag will be used for all -#' longitudinal markers. Note however that only one time lag can be specified -#' for linking each longitudinal marker to the +#' if a scalar is provided then the specified time lag will be used for all +#' longitudinal markers. Note however that only one time lag can be specified +#' for linking each longitudinal marker to the #' event, and that that time lag will be used for all association structure -#' types (e.g. \code{"etavalue"}, \code{"etaslope"}, \code{"etaauc"}, +#' types (e.g. \code{"etavalue"}, \code{"etaslope"}, \code{"etaauc"}, #' \code{"muvalue"}, etc) that are specified for that longitudinal marker in #' the \code{assoc} argument. #' @param grp_assoc Character string specifying the method for combining information #' across lower level units clustered within an individual when forming the -#' association structure. This is only relevant when a grouping factor is -#' specified in \code{formulaLong} that corresponds to clustering within +#' association structure. This is only relevant when a grouping factor is +#' specified in \code{formulaLong} that corresponds to clustering within #' individuals. This can be specified as either \code{"sum"}, \code{mean}, #' \code{"min"} or \code{"max"}. For example, specifying \code{grp_assoc = "sum"} -#' indicates that the association structure should be based on a summation across +#' indicates that the association structure should be based on a summation across #' the lower level units clustered within an individual, or specifying -#' \code{grp_assoc = "mean"} indicates that the association structure -#' should be based on the mean (i.e. average) taken across the lower level +#' \code{grp_assoc = "mean"} indicates that the association structure +#' should be based on the mean (i.e. average) taken across the lower level #' units clustered within an individual. -#' So, for example, specifying \code{assoc = "muvalue"} -#' and \code{grp_assoc = "sum"} would mean that the log hazard at time +#' So, for example, specifying \code{assoc = "muvalue"} +#' and \code{grp_assoc = "sum"} would mean that the log hazard at time #' \emph{t} for individual \emph{i} would be linearly related to the sum of -#' the expected values at time \emph{t} for each of the lower level -#' units (which may be for example tumor lesions) clustered within that -#' individual. -#' @param scale_assoc A non-zero numeric value specifying an optional scaling -#' parameter for the association structure. This multiplicatively scales the -#' value/slope/auc of the longitudinal marker by \code{scale_assoc} within the -#' event submodel. When fitting a multivariate joint model, a scaling parameter -#' must be specified for each longitudinal submodel using a vector of numeric -#' values. Note that only one scaling parameter can be specified for each -#' longitudinal submodel, and it will be used for all association structure -#' types (e.g. \code{"etavalue"}, \code{"etaslope"}, \code{"etaauc"}, +#' the expected values at time \emph{t} for each of the lower level +#' units (which may be for example tumor lesions) clustered within that +#' individual. +#' @param scale_assoc A non-zero numeric value specifying an optional scaling +#' parameter for the association structure. This multiplicatively scales the +#' value/slope/auc of the longitudinal marker by \code{scale_assoc} within the +#' event submodel. When fitting a multivariate joint model, a scaling parameter +#' must be specified for each longitudinal submodel using a vector of numeric +#' values. Note that only one scaling parameter can be specified for each +#' longitudinal submodel, and it will be used for all association structure +#' types (e.g. \code{"etavalue"}, \code{"etaslope"}, \code{"etaauc"}, #' \code{"muvalue"}, etc) that are specified for that longitudinal marker in #' the \code{assoc} argument. #' @param basehaz A character string indicating which baseline hazard to use -#' for the event submodel. Options are a B-splines approximation estimated -#' for the log baseline hazard (\code{"bs"}, the default), a Weibull +#' for the event submodel. Options are a B-splines approximation estimated +#' for the log baseline hazard (\code{"bs"}, the default), a Weibull #' baseline hazard (\code{"weibull"}), or a piecewise -#' constant baseline hazard (\code{"piecewise"}). (Note however that there +#' constant baseline hazard (\code{"piecewise"}). (Note however that there #' is currently limited post-estimation functionality available for #' models estimated using a piecewise constant baseline hazard). #' @param basehaz_ops A named list specifying options related to the baseline #' hazard. Currently this can include: \cr #' \describe{ -#' \item{\code{df}}{A positive integer specifying the degrees of freedom +#' \item{\code{df}}{A positive integer specifying the degrees of freedom #' for the B-splines if \code{basehaz = "bs"}, or the number of -#' intervals used for the piecewise constant baseline hazard if +#' intervals used for the piecewise constant baseline hazard if #' \code{basehaz = "piecewise"}. The default is 6.} -#' \item{\code{knots}}{An optional numeric vector specifying the internal knot -#' locations for the B-splines if \code{basehaz = "bs"}, or the -#' internal cut-points for defining intervals of the piecewise constant +#' \item{\code{knots}}{An optional numeric vector specifying the internal knot +#' locations for the B-splines if \code{basehaz = "bs"}, or the +#' internal cut-points for defining intervals of the piecewise constant #' baseline hazard if \code{basehaz = "piecewise"}. Knots cannot be -#' specified if \code{df} is specified. If not specified, then the +#' specified if \code{df} is specified. If not specified, then the #' default is to use \code{df - 4} knots if \code{basehaz = "bs"}, #' or \code{df - 1} knots if \code{basehaz = "piecewise"}, which are #' placed at equally spaced percentiles of the distribution of #' observed event times.} #' } #' @param epsilon The half-width of the central difference used to numerically -#' calculate the derivate when the \code{"etaslope"} association structure -#' is used. +#' calculate the derivate when the \code{"etaslope"} association structure +#' is used. #' @param qnodes The number of nodes to use for the Gauss-Kronrod quadrature -#' that is used to evaluate the cumulative hazard in the likelihood function. +#' that is used to evaluate the cumulative hazard in the likelihood function. #' Options are 15 (the default), 11 or 7. -#' @param weights Experimental and should be used with caution. The +#' @param weights Experimental and should be used with caution. The #' user can optionally supply a 2-column data frame containing a set of #' 'prior weights' to be used in the estimation process. The data frame should -#' contain two columns: the first containing the IDs for each individual, and +#' contain two columns: the first containing the IDs for each individual, and #' the second containing the corresponding weights. The data frame should only -#' have one row for each individual; that is, weights should be constant +#' have one row for each individual; that is, weights should be constant #' within individuals. #' @param init The method for generating the initial values for the MCMC. -#' The default is \code{"prefit"}, which uses those obtained from -#' fitting separate longitudinal and time-to-event models prior to -#' fitting the joint model. The separate longitudinal model is a -#' (possibly multivariate) generalised linear mixed -#' model estimated using variational bayes. This is achieved via the +#' The default is \code{"prefit"}, which uses those obtained from +#' fitting separate longitudinal and time-to-event models prior to +#' fitting the joint model. The separate longitudinal model is a +#' (possibly multivariate) generalised linear mixed +#' model estimated using variational bayes. This is achieved via the #' \code{\link{stan_mvmer}} function with \code{algorithm = "meanfield"}. -#' The separate Cox model is estimated using \code{\link[survival]{coxph}}. +#' The separate Cox model is estimated using \code{\link[survival]{coxph}}. #' This is achieved -#' using the and time-to-event models prior +#' using the and time-to-event models prior #' to fitting the joint model. The separate models are estimated using the #' \code{\link[lme4]{glmer}} and \code{\link[survival]{coxph}} functions. -#' This should provide reasonable initial values which should aid the -#' MCMC sampler. Parameters that cannot be obtained from -#' fitting separate longitudinal and time-to-event models are initialised +#' This should provide reasonable initial values which should aid the +#' MCMC sampler. Parameters that cannot be obtained from +#' fitting separate longitudinal and time-to-event models are initialised #' using the "random" method for \code{\link[rstan]{stan}}. #' However it is recommended that any final analysis should ideally #' be performed with several MCMC chains each initiated from a different #' set of initial values; this can be obtained by setting -#' \code{init = "random"}. In addition, other possibilities for specifying -#' \code{init} are the same as those described for \code{\link[rstan]{stan}}. -#' @param priorLong,priorEvent,priorEvent_assoc The prior distributions for the +#' \code{init = "random"}. In addition, other possibilities for specifying +#' \code{init} are the same as those described for \code{\link[rstan]{stan}}. +#' @param priorLong,priorEvent,priorEvent_assoc The prior distributions for the #' regression coefficients in the longitudinal submodel(s), event submodel, -#' and the association parameter(s). Can be a call to one of the various functions -#' provided by \pkg{rstanarm} for specifying priors. The subset of these functions -#' that can be used for the prior on the coefficients can be grouped into several +#' and the association parameter(s). Can be a call to one of the various functions +#' provided by \pkg{rstanarm} for specifying priors. The subset of these functions +#' that can be used for the prior on the coefficients can be grouped into several #' "families": -#' +#' #' \tabular{ll}{ -#' \strong{Family} \tab \strong{Functions} \cr -#' \emph{Student t family} \tab \code{normal}, \code{student_t}, \code{cauchy} \cr -#' \emph{Hierarchical shrinkage family} \tab \code{hs}, \code{hs_plus} \cr +#' \strong{Family} \tab \strong{Functions} \cr +#' \emph{Student t family} \tab \code{normal}, \code{student_t}, \code{cauchy} \cr +#' \emph{Hierarchical shrinkage family} \tab \code{hs}, \code{hs_plus} \cr #' \emph{Laplace family} \tab \code{laplace}, \code{lasso} \cr #' } -#' -#' See the \link[=priors]{priors help page} for details on the families and +#' +#' See the \link[=priors]{priors help page} for details on the families and #' how to specify the arguments for all of the functions in the table above. #' To omit a prior ---i.e., to use a flat (improper) uniform prior--- #' \code{prior} can be set to \code{NULL}, although this is rarely a good #' idea. -#' +#' #' \strong{Note:} Unless \code{QR=TRUE}, if \code{prior} is from the Student t -#' family or Laplace family, and if the \code{autoscale} argument to the -#' function used to specify the prior (e.g. \code{\link{normal}}) is left at -#' its default and recommended value of \code{TRUE}, then the default or +#' family or Laplace family, and if the \code{autoscale} argument to the +#' function used to specify the prior (e.g. \code{\link{normal}}) is left at +#' its default and recommended value of \code{TRUE}, then the default or #' user-specified prior scale(s) may be adjusted internally based on the scales #' of the predictors. See the \link[=priors]{priors help page} for details on #' the rescaling and the \code{\link{prior_summary}} function for a summary of #' the priors used for a particular model. -#' @param priorLong_intercept,priorEvent_intercept The prior distributions -#' for the intercepts in the longitudinal submodel(s) and event submodel. -#' Can be a call to \code{normal}, \code{student_t} or -#' \code{cauchy}. See the \link[=priors]{priors help page} for details on +#' @param priorLong_intercept,priorEvent_intercept The prior distributions +#' for the intercepts in the longitudinal submodel(s) and event submodel. +#' Can be a call to \code{normal}, \code{student_t} or +#' \code{cauchy}. See the \link[=priors]{priors help page} for details on #' these functions. To omit a prior on the intercept ---i.e., to use a flat #' (improper) uniform prior--- \code{prior_intercept} can be set to #' \code{NULL}. -#' +#' #' \strong{Note:} The prior distribution for the intercept is set so it -#' applies to the value when all predictors are centered. Moreover, +#' applies to the value when all predictors are centered. Moreover, #' note that a prior is only placed on the intercept for the event submodel #' when a Weibull baseline hazard has been specified. For the B-splines and #' piecewise constant baseline hazards there is not intercept parameter that -#' is given a prior distribution; an intercept parameter will be shown in -#' the output for the fitted model, but this just corresponds to the +#' is given a prior distribution; an intercept parameter will be shown in +#' the output for the fitted model, but this just corresponds to the #' necessary post-estimation adjustment in the linear predictor due to the #' centering of the predictiors in the event submodel. -#' +#' #' @param priorLong_aux The prior distribution for the "auxiliary" parameters -#' in the longitudinal submodels (if applicable). -#' The "auxiliary" parameter refers to a different parameter -#' depending on the \code{family}. For Gaussian models \code{priorLong_aux} -#' controls \code{"sigma"}, the error -#' standard deviation. For negative binomial models \code{priorLong_aux} controls -#' \code{"reciprocal_dispersion"}, which is similar to the +#' in the longitudinal submodels (if applicable). +#' The "auxiliary" parameter refers to a different parameter +#' depending on the \code{family}. For Gaussian models \code{priorLong_aux} +#' controls \code{"sigma"}, the error +#' standard deviation. For negative binomial models \code{priorLong_aux} controls +#' \code{"reciprocal_dispersion"}, which is similar to the #' \code{"size"} parameter of \code{\link[stats:NegBinomial]{rnbinom}}: -#' smaller values of \code{"reciprocal_dispersion"} correspond to -#' greater dispersion. For gamma models \code{priorLong_aux} sets the prior on -#' to the \code{"shape"} parameter (see e.g., -#' \code{\link[stats:GammaDist]{rgamma}}), and for inverse-Gaussian models it is the +#' smaller values of \code{"reciprocal_dispersion"} correspond to +#' greater dispersion. For gamma models \code{priorLong_aux} sets the prior on +#' to the \code{"shape"} parameter (see e.g., +#' \code{\link[stats:GammaDist]{rgamma}}), and for inverse-Gaussian models it is the #' so-called \code{"lambda"} parameter (which is essentially the reciprocal of -#' a scale parameter). Binomial and Poisson models do not have auxiliary -#' parameters. -#' -#' \code{priorLong_aux} can be a call to \code{exponential} to -#' use an exponential distribution, or \code{normal}, \code{student_t} or -#' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy -#' prior. See \code{\link{priors}} for details on these functions. To omit a -#' prior ---i.e., to use a flat (improper) uniform prior--- set +#' a scale parameter). Binomial and Poisson models do not have auxiliary +#' parameters. +#' +#' \code{priorLong_aux} can be a call to \code{exponential} to +#' use an exponential distribution, or \code{normal}, \code{student_t} or +#' \code{cauchy}, which results in a half-normal, half-t, or half-Cauchy +#' prior. See \code{\link{priors}} for details on these functions. To omit a +#' prior ---i.e., to use a flat (improper) uniform prior--- set #' \code{priorLong_aux} to \code{NULL}. -#' +#' #' If fitting a multivariate joint model, you have the option to #' specify a list of prior distributions, however the elements of the list -#' that correspond to any longitudinal submodel which does not have an -#' auxiliary parameter will be ignored. +#' that correspond to any longitudinal submodel which does not have an +#' auxiliary parameter will be ignored. #' @param priorEvent_aux The prior distribution for the "auxiliary" parameters -#' in the event submodel. The "auxiliary" parameters refers to different +#' in the event submodel. The "auxiliary" parameters refers to different #' parameters depending on the baseline hazard. For \code{basehaz = "weibull"} -#' the auxiliary parameter is the Weibull shape parameter. For +#' the auxiliary parameter is the Weibull shape parameter. For #' \code{basehaz = "bs"} the auxiliary parameters are the coefficients for the #' B-spline approximation to the log baseline hazard. #' For \code{basehaz = "piecewise"} the auxiliary parameters are the piecewise #' estimates of the log baseline hazard. #' @param prior_covariance Cannot be \code{NULL}; see \code{\link{priors}} for #' more information about the prior distributions on covariance matrices. -#' Note however that the default prior for covariance matrices in -#' \code{stan_jm} is slightly different to that in \code{\link{stan_glmer}} +#' Note however that the default prior for covariance matrices in +#' \code{stan_jm} is slightly different to that in \code{\link{stan_glmer}} #' (the details of which are described on the \code{\link{priors}} page). -#' -#' @details The \code{stan_jm} function can be used to fit a joint model (also -#' known as a shared parameter model) for longitudinal and time-to-event data +#' +#' @details The \code{stan_jm} function can be used to fit a joint model (also +#' known as a shared parameter model) for longitudinal and time-to-event data #' under a Bayesian framework. The underlying -#' estimation is carried out using the Bayesian C++ package Stan +#' estimation is carried out using the Bayesian C++ package Stan #' (\url{https://mc-stan.org/}). \cr -#' \cr +#' \cr #' The joint model may be univariate (with only one longitudinal submodel) or -#' multivariate (with more than one longitudinal submodel). -#' For the longitudinal submodel a (possibly multivariate) generalised linear -#' mixed model is assumed with any of the \code{\link[stats]{family}} choices -#' allowed by \code{\link[lme4]{glmer}}. If a multivariate joint model is specified +#' multivariate (with more than one longitudinal submodel). +#' For the longitudinal submodel a (possibly multivariate) generalised linear +#' mixed model is assumed with any of the \code{\link[stats]{family}} choices +#' allowed by \code{\link[lme4]{glmer}}. If a multivariate joint model is specified #' (by providing a list of formulas in the \code{formulaLong} argument), then -#' the multivariate longitudinal submodel consists of a multivariate generalized +#' the multivariate longitudinal submodel consists of a multivariate generalized #' linear model (GLM) with group-specific terms that are assumed to be correlated #' across the different GLM submodels. That is, within #' a grouping factor (for example, patient ID) the group-specific terms are -#' assumed to be correlated across the different GLM submodels. It is +#' assumed to be correlated across the different GLM submodels. It is #' possible to specify a different outcome type (for example a different #' family and/or link function) for each of the GLM submodels, by providing -#' a list of \code{\link[stats]{family}} objects in the \code{family} -#' argument. Multi-level -#' clustered data are allowed, and that additional clustering can occur at a -#' level higher than the individual-level (e.g. patients clustered within +#' a list of \code{\link[stats]{family}} objects in the \code{family} +#' argument. Multi-level +#' clustered data are allowed, and that additional clustering can occur at a +#' level higher than the individual-level (e.g. patients clustered within #' clinics), or at a level lower than the individual-level (e.g. tumor lesions #' clustered within patients). If the clustering occurs at a level lower than -#' the individual, then the user needs to indicate how the lower level +#' the individual, then the user needs to indicate how the lower level #' clusters should be handled when forming the association structure between #' the longitudinal and event submodels (see the \code{grp_assoc} argument #' described above). \cr #' \cr #' For the event submodel a parametric -#' proportional hazards model is assumed. The baseline hazard can be estimated +#' proportional hazards model is assumed. The baseline hazard can be estimated #' using either a cubic B-splines approximation (\code{basehaz = "bs"}, the #' default), a Weibull distribution (\code{basehaz = "weibull"}), or a #' piecewise constant baseline hazard (\code{basehaz = "piecewise"}). -#' If the B-spline or piecewise constant baseline hazards are used, -#' then the degrees of freedom or the internal knot locations can be +#' If the B-spline or piecewise constant baseline hazards are used, +#' then the degrees of freedom or the internal knot locations can be #' (optionally) specified. If #' the degrees of freedom are specified (through the \code{df} argument) then -#' the knot locations are automatically generated based on the -#' distribution of the observed event times (not including censoring times). -#' Otherwise internal knot locations can be specified +#' the knot locations are automatically generated based on the +#' distribution of the observed event times (not including censoring times). +#' Otherwise internal knot locations can be specified #' directly through the \code{knots} argument. If neither \code{df} or #' \code{knots} is specified, then the default is to set \code{df} equal to 6. #' It is not possible to specify both \code{df} and \code{knots}. \cr #' \cr -#' Time-varying covariates are allowed in both the -#' longitudinal and event submodels. These should be specified in the data -#' in the same way as they normally would when fitting a separate -#' longitudinal model using \code{\link[lme4]{lmer}} or a separate +#' Time-varying covariates are allowed in both the +#' longitudinal and event submodels. These should be specified in the data +#' in the same way as they normally would when fitting a separate +#' longitudinal model using \code{\link[lme4]{lmer}} or a separate #' time-to-event model using \code{\link[survival]{coxph}}. These time-varying -#' covariates should be exogenous in nature, otherwise they would perhaps -#' be better specified as an additional outcome (i.e. by including them as an +#' covariates should be exogenous in nature, otherwise they would perhaps +#' be better specified as an additional outcome (i.e. by including them as an #' additional longitudinal outcome in the joint model). \cr #' \cr -#' Bayesian estimation of the joint model is performed via MCMC. The Bayesian -#' model includes independent priors on the -#' regression coefficients for both the longitudinal and event submodels, +#' Bayesian estimation of the joint model is performed via MCMC. The Bayesian +#' model includes independent priors on the +#' regression coefficients for both the longitudinal and event submodels, #' including the association parameter(s) (in much the same way as the #' regression parameters in \code{\link{stan_glm}}) and #' priors on the terms of a decomposition of the covariance matrices of the -#' group-specific parameters. +#' group-specific parameters. #' See \code{\link{priors}} for more information about the priors distributions #' that are available. \cr #' \cr -#' Gauss-Kronrod quadrature is used to numerically evaluate the integral +#' Gauss-Kronrod quadrature is used to numerically evaluate the integral #' over the cumulative hazard in the likelihood function for the event submodel. #' The accuracy of the numerical approximation can be controlled using the -#' number of quadrature nodes, specified through the \code{qnodes} -#' argument. Using a higher number of quadrature nodes will result in a more +#' number of quadrature nodes, specified through the \code{qnodes} +#' argument. Using a higher number of quadrature nodes will result in a more #' accurate approximation. -#' +#' #' \subsection{Association structures}{ -#' The association structure for the joint model can be based on any of the -#' following parameterisations: +#' The association structure for the joint model can be based on any of the +#' following parameterisations: #' \itemize{ -#' \item current value of the linear predictor in the -#' longitudinal submodel (\code{"etavalue"}) -#' \item first derivative (slope) of the linear predictor in the -#' longitudinal submodel (\code{"etaslope"}) -#' \item the area under the curve of the linear predictor in the -#' longitudinal submodel (\code{"etaauc"}) -#' \item current expected value of the longitudinal submodel +#' \item current value of the linear predictor in the +#' longitudinal submodel (\code{"etavalue"}) +#' \item first derivative (slope) of the linear predictor in the +#' longitudinal submodel (\code{"etaslope"}) +#' \item the area under the curve of the linear predictor in the +#' longitudinal submodel (\code{"etaauc"}) +#' \item current expected value of the longitudinal submodel #' (\code{"muvalue"}) -#' \item the area under the curve of the expected value from the +#' \item the area under the curve of the expected value from the #' longitudinal submodel (\code{"muauc"}) -#' \item shared individual-level random effects (\code{"shared_b"}) -#' \item shared individual-level random effects which also incorporate -#' the corresponding fixed effect as well as any corresponding +#' \item shared individual-level random effects (\code{"shared_b"}) +#' \item shared individual-level random effects which also incorporate +#' the corresponding fixed effect as well as any corresponding #' random effects for clustering levels higher than the individual) #' (\code{"shared_coef"}) #' \item interactions between association terms and observed data/covariates -#' (\code{"etavalue_data"}, \code{"etaslope_data"}, \code{"muvalue_data"}, +#' (\code{"etavalue_data"}, \code{"etaslope_data"}, \code{"muvalue_data"}, #' \code{"muslope_data"}). These are described further below. -#' \item interactions between association terms corresponding to different -#' longitudinal outcomes in a multivariate joint model +#' \item interactions between association terms corresponding to different +#' longitudinal outcomes in a multivariate joint model #' (\code{"etavalue_etavalue(#)"}, \code{"etavalue_muvalue(#)"}, #' \code{"muvalue_etavalue(#)"}, \code{"muvalue_muvalue(#)"}). These -#' are described further below. -#' \item no association structure (equivalent to fitting separate -#' longitudinal and event models) (\code{"null"} or \code{NULL}) +#' are described further below. +#' \item no association structure (equivalent to fitting separate +#' longitudinal and event models) (\code{"null"} or \code{NULL}) #' } #' More than one association structure can be specified, however, -#' not all possible combinations are allowed. -#' Note that for the lagged association structures baseline values (time = 0) -#' are used for the instances -#' where the time lag results in a time prior to baseline. When using the +#' not all possible combinations are allowed. +#' Note that for the lagged association structures baseline values (time = 0) +#' are used for the instances +#' where the time lag results in a time prior to baseline. When using the #' \code{"etaauc"} or \code{"muauc"} association structures, the area under -#' the curve is evaluated using Gauss-Kronrod quadrature with 15 quadrature -#' nodes. By default, \code{"shared_b"} and \code{"shared_coef"} contribute -#' all random effects to the association structure; however, a subset of the -#' random effects can be chosen by specifying their indices between parentheses -#' as a suffix, for example, \code{"shared_b(1)"} or \code{"shared_b(1:3)"} or +#' the curve is evaluated using Gauss-Kronrod quadrature with 15 quadrature +#' nodes. By default, \code{"shared_b"} and \code{"shared_coef"} contribute +#' all random effects to the association structure; however, a subset of the +#' random effects can be chosen by specifying their indices between parentheses +#' as a suffix, for example, \code{"shared_b(1)"} or \code{"shared_b(1:3)"} or #' \code{"shared_b(1,2,4)"}, and so on. \cr -#' \cr +#' \cr #' In addition, several association terms (\code{"etavalue"}, \code{"etaslope"}, -#' \code{"muvalue"}, \code{"muslope"}) can be interacted with observed +#' \code{"muvalue"}, \code{"muslope"}) can be interacted with observed #' data/covariates. To do this, use the association term's main handle plus a -#' suffix of \code{"_data"} then followed by the model matrix formula in -#' parentheses. For example if we had a variable in our dataset for gender -#' named \code{sex} then we might want to obtain different estimates for the -#' association between the current slope of the marker and the risk of the -#' event for each gender. To do this we would specify +#' suffix of \code{"_data"} then followed by the model matrix formula in +#' parentheses. For example if we had a variable in our dataset for gender +#' named \code{sex} then we might want to obtain different estimates for the +#' association between the current slope of the marker and the risk of the +#' event for each gender. To do this we would specify #' \code{assoc = c("etaslope", "etaslope_data(~ sex)")}. \cr #' \cr -#' It is also possible, when fitting a multivariate joint model, to include +#' It is also possible, when fitting a multivariate joint model, to include #' interaction terms between the association terms themselves (this only -#' applies for interacting \code{"etavalue"} or \code{"muvalue"}). For example, -#' if we had a joint model with two longitudinal markers, we could specify +#' applies for interacting \code{"etavalue"} or \code{"muvalue"}). For example, +#' if we had a joint model with two longitudinal markers, we could specify #' \code{assoc = list(c("etavalue", "etavalue_etavalue(2)"), "etavalue")}. #' The first element of list says we want to use the value of the linear #' predictor for the first marker, as well as it's interaction with the -#' value of the linear predictor for the second marker. The second element of -#' the list says we want to also include the expected value of the second marker -#' (i.e. as a "main effect"). Therefore, the linear predictor for the event +#' value of the linear predictor for the second marker. The second element of +#' the list says we want to also include the expected value of the second marker +#' (i.e. as a "main effect"). Therefore, the linear predictor for the event #' submodel would include the "main effects" for each marker as well as their #' interaction. \cr #' \cr #' There are additional examples in the \strong{Examples} section below. #' } -#' +#' #' @return A \link[=stanreg-objects]{stanjm} object is returned. -#' -#' @seealso \code{\link{stanreg-objects}}, \code{\link{stanmvreg-methods}}, +#' +#' @seealso \code{\link{stanreg-objects}}, \code{\link{stanmvreg-methods}}, #' \code{\link{print.stanmvreg}}, \code{\link{summary.stanmvreg}}, -#' \code{\link{posterior_traj}}, \code{\link{posterior_survfit}}, +#' \code{\link{posterior_traj}}, \code{\link{posterior_survfit}}, #' \code{\link{posterior_predict}}, \code{\link{posterior_interval}}, #' \code{\link{pp_check}}, \code{\link{ps_check}}, \code{\link{stan_mvmer}}. -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch !="i386") { #' \donttest{ -#' +#' #' ##### -#' # Univariate joint model, with association structure based on the +#' # Univariate joint model, with association structure based on the #' # current value of the linear predictor -#' f1 <- stan_jm(formulaLong = logBili ~ year + (1 | id), +#' f1 <- stan_jm(formulaLong = logBili ~ year + (1 | id), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' time_var = "year", #' # this next line is only to keep the example small in size! #' chains = 1, cores = 1, seed = 12345, iter = 1000) -#' print(f1) -#' summary(f1) -#' +#' print(f1) +#' summary(f1) +#' #' ##### -#' # Univariate joint model, with association structure based on the +#' # Univariate joint model, with association structure based on the #' # current value and slope of the linear predictor -#' f2 <- stan_jm(formulaLong = logBili ~ year + (year | id), +#' f2 <- stan_jm(formulaLong = logBili ~ year + (year | id), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' assoc = c("etavalue", "etaslope"), #' time_var = "year", #' chains = 1, cores = 1, seed = 12345, iter = 1000) -#' print(f2) -#' +#' print(f2) +#' #' ##### -#' # Univariate joint model, with association structure based on the -#' # lagged value of the linear predictor, where the lag is 2 time +#' # Univariate joint model, with association structure based on the +#' # lagged value of the linear predictor, where the lag is 2 time #' # units (i.e. 2 years in this example) -#' f3 <- stan_jm(formulaLong = logBili ~ year + (1 | id), +#' f3 <- stan_jm(formulaLong = logBili ~ year + (1 | id), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' time_var = "year", #' assoc = "etavalue", lag_assoc = 2, #' chains = 1, cores = 1, seed = 12345, iter = 1000) -#' print(f3) -#' +#' print(f3) +#' #' ##### -#' # Univariate joint model, where the association structure includes -#' # interactions with observed data. Here we specify that we want to use -#' # an association structure based on the current value of the linear -#' # predictor from the longitudinal submodel (i.e. "etavalue"), but we +#' # Univariate joint model, where the association structure includes +#' # interactions with observed data. Here we specify that we want to use +#' # an association structure based on the current value of the linear +#' # predictor from the longitudinal submodel (i.e. "etavalue"), but we #' # also want to interact this with the treatment covariate (trt) from -#' # pbcLong data frame, so that we can estimate a different association -#' # parameter (i.e. estimated effect of log serum bilirubin on the log +#' # pbcLong data frame, so that we can estimate a different association +#' # parameter (i.e. estimated effect of log serum bilirubin on the log #' # hazard of death) for each treatment group -#' f4 <- stan_jm(formulaLong = logBili ~ year + (1 | id), +#' f4 <- stan_jm(formulaLong = logBili ~ year + (1 | id), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' time_var = "year", #' assoc = c("etavalue", "etavalue_data(~ trt)"), #' chains = 1, cores = 1, seed = 12345, iter = 1000) #' print(f4) -#' +#' #' ###### -#' # Multivariate joint model, with association structure based -#' # on the current value and slope of the linear predictor in the -#' # first longitudinal submodel and the area under the marker +#' # Multivariate joint model, with association structure based +#' # on the current value and slope of the linear predictor in the +#' # first longitudinal submodel and the area under the marker #' # trajectory for the second longitudinal submodel #' mv1 <- stan_jm( #' formulaLong = list( -#' logBili ~ year + (1 | id), +#' logBili ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, -#' assoc = list(c("etavalue", "etaslope"), "etaauc"), +#' assoc = list(c("etavalue", "etaslope"), "etaauc"), #' time_var = "year", #' chains = 1, cores = 1, seed = 12345, iter = 100) #' print(mv1) -#' +#' #' ##### -#' # Multivariate joint model, where the association structure is formed by -#' # including the expected value of each longitudinal marker (logBili and -#' # albumin) in the linear predictor of the event submodel, as well as their -#' # interaction effect (i.e. the interaction between the two "etavalue" terms). -#' # Note that whether such an association structure based on a marker by -#' # marker interaction term makes sense will depend on the context of your +#' # Multivariate joint model, where the association structure is formed by +#' # including the expected value of each longitudinal marker (logBili and +#' # albumin) in the linear predictor of the event submodel, as well as their +#' # interaction effect (i.e. the interaction between the two "etavalue" terms). +#' # Note that whether such an association structure based on a marker by +#' # marker interaction term makes sense will depend on the context of your #' # application -- here we just show it for demostration purposes). #' mv2 <- stan_jm( #' formulaLong = list( -#' logBili ~ year + (1 | id), +#' logBili ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' assoc = list(c("etavalue", "etavalue_etavalue(2)"), "etavalue"), -#' time_var = "year", +#' time_var = "year", #' chains = 1, cores = 1, seed = 12345, iter = 100) -#' +#' #' ##### #' # Multivariate joint model, with one bernoulli marker and one #' # Gaussian marker. We will artificially create the bernoulli @@ -521,120 +521,74 @@ #' pbcLong$ybern <- as.integer(pbcLong$logBili >= mean(pbcLong$logBili)) #' mv3 <- stan_jm( #' formulaLong = list( -#' ybern ~ year + (1 | id), +#' ybern ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), #' dataLong = pbcLong, -#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, +#' formulaEvent = Surv(futimeYears, death) ~ sex + trt, #' dataEvent = pbcSurv, #' family = list(binomial, gaussian), -#' time_var = "year", +#' time_var = "year", #' chains = 1, cores = 1, seed = 12345, iter = 1000) #' } #' } -#' -stan_jm <- function( - formulaLong, - dataLong, - formulaEvent, - dataEvent, - time_var, - id_var, - family = gaussian, - assoc = "etavalue", - lag_assoc = 0, - grp_assoc, - scale_assoc = NULL, - epsilon = 1E-5, - basehaz = c("bs", "weibull", "piecewise"), - basehaz_ops, - qnodes = 15, - init = "prefit", - weights, - priorLong = normal(autoscale = TRUE), - priorLong_intercept = normal(autoscale = TRUE), - priorLong_aux = cauchy(0, 5, autoscale = TRUE), - priorEvent = normal(autoscale = TRUE), - priorEvent_intercept = normal(autoscale = TRUE), - priorEvent_aux = cauchy(autoscale = TRUE), - priorEvent_assoc = normal(autoscale = TRUE), - prior_covariance = lkj(autoscale = TRUE), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - max_treedepth = 10L, - QR = FALSE, - sparse = FALSE, - ... -) { +#' +stan_jm <- function(formulaLong, dataLong, formulaEvent, dataEvent, time_var, + id_var, family = gaussian, assoc = "etavalue", + lag_assoc = 0, grp_assoc, scale_assoc = NULL, epsilon = 1E-5, + basehaz = c("bs", "weibull", "piecewise"), basehaz_ops, + qnodes = 15, init = "prefit", weights, + priorLong = normal(autoscale=TRUE), priorLong_intercept = normal(autoscale=TRUE), + priorLong_aux = cauchy(0, 5, autoscale=TRUE), priorEvent = normal(autoscale=TRUE), + priorEvent_intercept = normal(autoscale=TRUE), priorEvent_aux = cauchy(autoscale=TRUE), + priorEvent_assoc = normal(autoscale=TRUE), prior_covariance = lkj(autoscale=TRUE), + prior_PD = FALSE, algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, max_treedepth = 10L, QR = FALSE, + sparse = FALSE, ...) { + #----------------------------- # Pre-processing of arguments - #----------------------------- - + #----------------------------- + # Set seed if specified dots <- list(...) - if ("seed" %in% names(dots)) { + if ("seed" %in% names(dots)) set.seed(dots$seed) - } - + algorithm <- match.arg(algorithm) - basehaz <- match.arg(basehaz) - - if (missing(basehaz_ops)) { - basehaz_ops <- NULL - } - if (missing(weights)) { - weights <- NULL - } - if (missing(id_var)) { - id_var <- NULL - } - if (missing(time_var)) { - time_var <- NULL - } - if (missing(grp_assoc)) { - grp_assoc <- NULL - } + basehaz <- match.arg(basehaz) + + if (missing(basehaz_ops)) basehaz_ops <- NULL + if (missing(weights)) weights <- NULL + if (missing(id_var)) id_var <- NULL + if (missing(time_var)) time_var <- NULL + if (missing(grp_assoc)) grp_assoc <- NULL - if (!is.null(weights)) { + if (!is.null(weights)) stop("'weights' are not yet implemented.") - } - if (QR) { + if (QR) stop("'QR' decomposition is not yet implemented.") - } - if (sparse) { + if (sparse) stop("'sparse' option is not yet implemented.") - } - - if (is.null(time_var)) { + + if (is.null(time_var)) stop("'time_var' must be specified.") - } # Formula - formulaLong <- validate_arg(formulaLong, "formula") - M <- length(formulaLong) - if (M > 3L) { - stop( - "'stan_jm' is currently limited to a maximum of 3 longitudinal outcomes." - ) - } - + formulaLong <- validate_arg(formulaLong, "formula"); M <- length(formulaLong) + if (M > 3L) + stop("'stan_jm' is currently limited to a maximum of 3 longitudinal outcomes.") + # Data - dataLong <- validate_arg(dataLong, "data.frame", validate_length = M) + dataLong <- validate_arg(dataLong, "data.frame", validate_length = M) dataEvent <- as.data.frame(dataEvent) # Family ok_family_classes <- c("function", "family", "character") - ok_families <- c( - "binomial", - "gaussian", - "Gamma", - "inverse.gaussian", - "poisson", - "neg_binomial_2" - ) + ok_families <- c("binomial", "gaussian", "Gamma", + "inverse.gaussian", "poisson", "neg_binomial_2") family <- validate_arg(family, ok_family_classes, validate_length = M) family <- lapply(family, validate_famlink, ok_families) - + # Assoc ok_assoc_classes <- c("NULL", "character") assoc <- validate_arg(assoc, ok_assoc_classes, validate_length = M) @@ -643,110 +597,56 @@ stan_jm <- function( priorLong <- broadcast_prior(priorLong, M) priorLong_intercept <- broadcast_prior(priorLong_intercept, M) priorLong_aux <- broadcast_prior(priorLong_aux, M) - + #----------- # Fit model #----------- - - stanfit <- stan_jm.fit( - formulaLong = formulaLong, - dataLong = dataLong, - formulaEvent = formulaEvent, - dataEvent = dataEvent, - time_var = time_var, - id_var = id_var, - family = family, - assoc = assoc, - lag_assoc = lag_assoc, - grp_assoc = grp_assoc, - epsilon = epsilon, - basehaz = basehaz, - basehaz_ops = basehaz_ops, - qnodes = qnodes, - init = init, - weights = weights, - scale_assoc = scale_assoc, - priorLong = priorLong, - priorLong_intercept = priorLong_intercept, - priorLong_aux = priorLong_aux, - priorEvent = priorEvent, - priorEvent_intercept = priorEvent_intercept, - priorEvent_aux = priorEvent_aux, - priorEvent_assoc = priorEvent_assoc, - prior_covariance = prior_covariance, - prior_PD = prior_PD, - algorithm = algorithm, - adapt_delta = adapt_delta, - max_treedepth = max_treedepth, - QR = QR, - sparse = sparse, - ... - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } + + stanfit <- stan_jm.fit(formulaLong = formulaLong, dataLong = dataLong, + formulaEvent = formulaEvent, dataEvent = dataEvent, + time_var = time_var, id_var = id_var, family = family, + assoc = assoc, lag_assoc = lag_assoc, grp_assoc = grp_assoc, + epsilon = epsilon, basehaz = basehaz, basehaz_ops = basehaz_ops, + qnodes = qnodes, init = init, weights = weights, scale_assoc = scale_assoc, + priorLong = priorLong, + priorLong_intercept = priorLong_intercept, + priorLong_aux = priorLong_aux, + priorEvent = priorEvent, + priorEvent_intercept = priorEvent_intercept, + priorEvent_aux = priorEvent_aux, + priorEvent_assoc = priorEvent_assoc, + prior_covariance = prior_covariance, prior_PD = prior_PD, + algorithm = algorithm, adapt_delta = adapt_delta, + max_treedepth = max_treedepth, QR = QR, sparse = sparse, ...) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) y_mod <- attr(stanfit, "y_mod") e_mod <- attr(stanfit, "e_mod") a_mod <- attr(stanfit, "a_mod") - cnms <- attr(stanfit, "cnms") + cnms <- attr(stanfit, "cnms") flevels <- attr(stanfit, "flevels") assoc <- attr(stanfit, "assoc") scale_assoc <- attr(stanfit, "scale_assoc") id_var <- attr(stanfit, "id_var") - basehaz <- attr(stanfit, "basehaz") - grp_stuff <- attr(stanfit, "grp_stuff") + basehaz <- attr(stanfit, "basehaz") + grp_stuff <- attr(stanfit, "grp_stuff") prior_info <- attr(stanfit, "prior_info") - stanfit <- drop_attributes( - stanfit, - "y_mod", - "e_mod", - "a_mod", - "cnms", - "flevels", - "assoc", - "id_var", - "basehaz", - "grp_stuff", - "prior_info", - "scale_assoc" - ) - + stanfit <- drop_attributes(stanfit, "y_mod", "e_mod", "a_mod", "cnms", + "flevels", "assoc", "id_var", "basehaz", + "grp_stuff", "prior_info","scale_assoc") + terms <- c(fetch(y_mod, "terms"), list(terms(e_mod$mod))) n_yobs <- fetch_(y_mod, "x", "N") n_grps <- sapply(flevels, n_distinct) n_subjects <- e_mod$Npat - fit <- nlist( - stanfit, - formula = c(formulaLong, formulaEvent), - family, - id_var, - time_var, - weights, - scale_assoc, - qnodes, - basehaz, - assoc, - M, - cnms, - flevels, - n_grps, - n_subjects, - n_yobs, - epsilon, - algorithm, - terms, - glmod = y_mod, - survmod = e_mod, - assocmod = a_mod, - grp_stuff, - dataLong, - dataEvent, - prior.info = prior_info, - stan_function = "stan_jm", - call = match.call(expand.dots = TRUE) - ) - + fit <- nlist(stanfit, formula = c(formulaLong, formulaEvent), family, + id_var, time_var, weights, scale_assoc, qnodes, basehaz, assoc, + M, cnms, flevels, n_grps, n_subjects, n_yobs, epsilon, + algorithm, terms, glmod = y_mod, survmod = e_mod, + assocmod = a_mod, grp_stuff, dataLong, dataEvent, + prior.info = prior_info, stan_function = "stan_jm", + call = match.call(expand.dots = TRUE)) + out <- stanmvreg(fit) return(out) } diff --git a/R/stan_lm.R b/R/stan_lm.R index 3490e432c..3f6db17da 100644 --- a/R/stan_lm.R +++ b/R/stan_lm.R @@ -1,22 +1,22 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian regularized linear models via Stan -#' +#' #' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} #' Bayesian inference for linear modeling with regularizing priors on the model #' parameters that are driven by prior beliefs about \eqn{R^2}, the proportion @@ -25,7 +25,7 @@ #' \code{\link{stan_glm}} with \code{family="gaussian"} also estimates a linear #' model with normally-distributed errors and allows for various other priors on #' the coefficients. -#' +#' #' @export #' @templateVar fun stan_lm, stan_aov #' @templateVar fitfun stan_lm.fit or stan_lm.wfit @@ -45,7 +45,7 @@ #' @template args-adapt_delta #' #' @param w Same as in \code{lm.wfit} but rarely specified. -#' @param prior Must be a call to \code{\link{R2}} with its +#' @param prior Must be a call to \code{\link{R2}} with its #' \code{location} argument specified or \code{NULL}, which would #' indicate a standard uniform prior for the \eqn{R^2}. #' @param prior_intercept Either \code{NULL} (the default) or a call to @@ -55,7 +55,7 @@ #' root of the sample size, which is legitimate because the marginal #' standard deviation of the outcome is a primitive parameter being #' estimated. -#' +#' #' \strong{Note:} If using a dense representation of the design matrix #' ---i.e., if the \code{sparse} argument is left at its default value of #' \code{FALSE}--- then the prior distribution for the intercept is set so it @@ -70,89 +70,79 @@ #' predictors (i.e., same as in \code{glm}). #' #' -#' @details The \code{stan_lm} function is similar in syntax to the +#' @details The \code{stan_lm} function is similar in syntax to the #' \code{\link[stats]{lm}} function but rather than choosing the parameters to -#' minimize the sum of squared residuals, samples from the posterior +#' minimize the sum of squared residuals, samples from the posterior #' distribution are drawn using MCMC (if \code{algorithm} is #' \code{"sampling"}). The \code{stan_lm} function has a formula-based #' interface and would usually be called by users but the \code{stan_lm.fit} #' and \code{stan_lm.wfit} functions might be called by other functions that #' parse the data themselves and are analogous to \code{lm.fit} #' and \code{lm.wfit} respectively. -#' +#' #' In addition to estimating \code{sigma} --- the standard deviation of the #' normally-distributed errors --- this model estimates a positive parameter -#' called \code{log-fit_ratio}. If it is positive, the marginal posterior +#' called \code{log-fit_ratio}. If it is positive, the marginal posterior #' variance of the outcome will exceed the sample variance of the outcome #' by a multiplicative factor equal to the square of \code{fit_ratio}. #' Conversely if \code{log-fit_ratio} is negative, then the model underfits. #' Given the regularizing nature of the priors, a slight underfit is good. -#' +#' #' Finally, the posterior predictive distribution is generated with the #' predictors fixed at their sample means. This quantity is useful for #' checking convergence because it is reasonably normally distributed #' and a function of all the parameters in the model. -#' +#' #' The \code{stan_aov} function is similar to \code{\link[stats]{aov}}, but #' does a Bayesian analysis of variance that is basically equivalent to #' \code{stan_lm} with dummy variables. \code{stan_aov} has a somewhat #' customized \code{\link{print}} method that prints an ANOVA-like table in #' addition to the output printed for \code{stan_lm} models. -#' -#' -#' @references +#' +#' +#' @references #' Lewandowski, D., Kurowicka D., and Joe, H. (2009). Generating random -#' correlation matrices based on vines and extended onion method. +#' correlation matrices based on vines and extended onion method. #' \emph{Journal of Multivariate Analysis}. \strong{100}(9), 1989--2001. -#' -#' @seealso +#' +#' @seealso #' The vignettes for \code{stan_lm} and \code{stan_aov}, which have more #' thorough descriptions and examples. #' \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' Also see \code{\link{stan_glm}}, which --- if \code{family = #' gaussian(link="identity")} --- also estimates a linear model with #' normally-distributed errors but specifies different priors. -#' -#' +#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch !="i386") { -#' (fit <- stan_lm(mpg ~ wt + qsec + am, data = mtcars, prior = R2(0.75), +#' (fit <- stan_lm(mpg ~ wt + qsec + am, data = mtcars, prior = R2(0.75), #' # the next line is only to make the example go fast enough #' chains = 1, iter = 300, seed = 12345, refresh = 0)) -#' plot(fit, "hist", pars = c("wt", "am", "qsec", "sigma"), +#' plot(fit, "hist", pars = c("wt", "am", "qsec", "sigma"), #' transformations = list(sigma = "log")) #' } -stan_lm <- function( - formula, - data, - subset, - weights, - na.action, - model = TRUE, - x = FALSE, - y = FALSE, - singular.ok = TRUE, - contrasts = NULL, - offset, - ..., - prior = R2(stop("'location' must be specified")), - prior_intercept = NULL, - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL -) { +stan_lm <- function(formula, data, subset, weights, na.action, + model = TRUE, x = FALSE, y = FALSE, + singular.ok = TRUE, contrasts = NULL, offset, ..., + prior = R2(stop("'location' must be specified")), + prior_intercept = NULL, + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL) { + algorithm <- match.arg(algorithm) validate_glm_formula(formula) data <- validate_data(data, if_missing = environment(formula)) - + call <- match.call(expand.dots = TRUE) mf <- match.call(expand.dots = FALSE) mf[[1L]] <- as.name("lm") mf$data <- data mf$x <- mf$y <- mf$singular.ok <- TRUE mf$qr <- FALSE - mf$prior <- mf$prior_intercept <- mf$prior_PD <- mf$algorithm <- + mf$prior <- mf$prior_intercept <- mf$prior_PD <- mf$algorithm <- mf$adapt_delta <- NULL mf$method <- "model.frame" modelframe <- suppressWarnings(eval(mf, parent.frame())) @@ -161,48 +151,28 @@ stan_lm <- function( X <- model.matrix(mt, modelframe, contrasts) w <- as.vector(model.weights(modelframe)) offset <- as.vector(model.offset(modelframe)) - stanfit <- stan_lm.wfit( - y = Y, - x = X, - w, - offset, - singular.ok = singular.ok, - prior = prior, - prior_intercept = prior_intercept, - prior_PD = prior_PD, - algorithm = algorithm, - adapt_delta = adapt_delta, - ... - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } - fit <- nlist( - stanfit, - family = gaussian(), - formula, - offset, - weights = w, - x = X[, intersect(colnames(X), dimnames(stanfit)[[3]]), drop = FALSE], - y = Y, - data = data, - prior.info = prior, - algorithm, - call, - terms = mt, - model = if (model) modelframe else NULL, - na.action = attr(modelframe, "na.action"), - contrasts = attr(X, "contrasts"), - stan_function = "stan_lm" - ) + stanfit <- stan_lm.wfit(y = Y, x = X, w, offset, singular.ok = singular.ok, + prior = prior, prior_intercept = prior_intercept, + prior_PD = prior_PD, + algorithm = algorithm, adapt_delta = adapt_delta, + ...) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) + fit <- nlist(stanfit, family = gaussian(), formula, offset, weights = w, + x = X[,intersect(colnames(X), dimnames(stanfit)[[3]]), drop = FALSE], + y = Y, + data = data, + prior.info = prior, + algorithm, call, terms = mt, + model = if (model) modelframe else NULL, + na.action = attr(modelframe, "na.action"), + contrasts = attr(X, "contrasts"), + stan_function = "stan_lm") out <- stanreg(fit) out$xlevels <- .getXlevels(mt, modelframe) - if (!x) { + if (!x) out$x <- NULL - } - if (!y) { + if (!y) out$y <- NULL - } - + return(out) -} +} \ No newline at end of file diff --git a/R/stan_mvmer.R b/R/stan_mvmer.R index fd9dc8b27..e9a58bab9 100644 --- a/R/stan_mvmer.R +++ b/R/stan_mvmer.R @@ -1,28 +1,28 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2013, 2014, 2015, 2016, 2017 Trustees of Columbia University # Copyright (C) 2016, 2017 Sam Brilleman -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. -#' Bayesian multivariate generalized linear models with correlated +#' Bayesian multivariate generalized linear models with correlated #' group-specific terms via Stan -#' +#' #' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Bayesian inference for multivariate GLMs with group-specific coefficients +#' Bayesian inference for multivariate GLMs with group-specific coefficients #' that are assumed to be correlated across the GLM submodels. -#' +#' #' @export #' @template args-dots #' @template args-prior_PD @@ -31,90 +31,90 @@ #' @template args-max_treedepth #' @template args-QR #' @template args-sparse -#' -#' @param formula A two-sided linear formula object describing both the -#' fixed-effects and random-effects parts of the longitudinal submodel +#' +#' @param formula A two-sided linear formula object describing both the +#' fixed-effects and random-effects parts of the longitudinal submodel #' similar in vein to formula specification in the \strong{lme4} package -#' (see \code{\link[lme4]{glmer}} or the \strong{lme4} vignette for details). -#' Note however that the double bar (\code{||}) notation is not allowed +#' (see \code{\link[lme4]{glmer}} or the \strong{lme4} vignette for details). +#' Note however that the double bar (\code{||}) notation is not allowed #' when specifying the random-effects parts of the formula, and neither -#' are nested grouping factors (e.g. \code{(1 | g1/g2))} or -#' \code{(1 | g1:g2)}, where \code{g1}, \code{g2} are grouping factors. -#' For a multivariate GLM this should be a list of such formula objects, -#' with each element of the list providing the formula for one of the +#' are nested grouping factors (e.g. \code{(1 | g1/g2))} or +#' \code{(1 | g1:g2)}, where \code{g1}, \code{g2} are grouping factors. +#' For a multivariate GLM this should be a list of such formula objects, +#' with each element of the list providing the formula for one of the #' GLM submodels. #' @param data A data frame containing the variables specified in #' \code{formula}. For a multivariate GLM, this can -#' be either a single data frame which contains the data for all +#' be either a single data frame which contains the data for all #' GLM submodels, or it can be a list of data frames where each #' element of the list provides the data for one of the GLM submodels. -#' @param family The family (and possibly also the link function) for the -#' GLM submodel(s). See \code{\link[lme4]{glmer}} for details. +#' @param family The family (and possibly also the link function) for the +#' GLM submodel(s). See \code{\link[lme4]{glmer}} for details. #' If fitting a multivariate GLM, then this can optionally be a #' list of families, in which case each element of the list specifies the #' family for one of the GLM submodels. In other words, a different family -#' can be specified for each GLM submodel. +#' can be specified for each GLM submodel. #' @param weights Same as in \code{\link[stats]{glm}}, -#' except that when fitting a multivariate GLM and a list of data frames -#' is provided in \code{data} then a corresponding list of weights -#' must be provided. If weights are -#' provided for one of the GLM submodels, then they must be provided for +#' except that when fitting a multivariate GLM and a list of data frames +#' is provided in \code{data} then a corresponding list of weights +#' must be provided. If weights are +#' provided for one of the GLM submodels, then they must be provided for #' all GLM submodels. #' @param prior,prior_intercept,prior_aux Same as in \code{\link{stan_glmer}} -#' except that for a multivariate GLM a list of priors can be provided for -#' any of \code{prior}, \code{prior_intercept} or \code{prior_aux} arguments. -#' That is, different priors can optionally be specified for each of the GLM -#' submodels. If a list is not provided, then the same prior distributions are +#' except that for a multivariate GLM a list of priors can be provided for +#' any of \code{prior}, \code{prior_intercept} or \code{prior_aux} arguments. +#' That is, different priors can optionally be specified for each of the GLM +#' submodels. If a list is not provided, then the same prior distributions are #' used for each GLM submodel. Note that the \code{"product_normal"} prior is #' not allowed for \code{stan_mvmer}. #' @param prior_covariance Cannot be \code{NULL}; see \code{\link{priors}} for #' more information about the prior distributions on covariance matrices. -#' Note however that the default prior for covariance matrices in -#' \code{stan_mvmer} is slightly different to that in \code{\link{stan_glmer}} +#' Note however that the default prior for covariance matrices in +#' \code{stan_mvmer} is slightly different to that in \code{\link{stan_glmer}} #' (the details of which are described on the \code{\link{priors}} page). #' @param init The method for generating initial values. See #' \code{\link[rstan]{stan}}. -#' +#' #' @details The \code{stan_mvmer} function can be used to fit a multivariate #' generalized linear model (GLM) with group-specific terms. The model consists #' of distinct GLM submodels, each which contains group-specific terms; within #' a grouping factor (for example, patient ID) the grouping-specific terms are -#' assumed to be correlated across the different GLM submodels. It is +#' assumed to be correlated across the different GLM submodels. It is #' possible to specify a different outcome type (for example a different #' family and/or link function) for each of the GLM submodels. \cr #' \cr -#' Bayesian estimation of the model is performed via MCMC, in the same way as +#' Bayesian estimation of the model is performed via MCMC, in the same way as #' for \code{\link{stan_glmer}}. Also, similar to \code{\link{stan_glmer}}, -#' an unstructured covariance matrix is used for the group-specific terms +#' an unstructured covariance matrix is used for the group-specific terms #' within a given grouping factor, with priors on the terms of a decomposition -#' of the covariance matrix.See \code{\link{priors}} for more information about -#' the priors distributions that are available for the covariance matrices, +#' of the covariance matrix.See \code{\link{priors}} for more information about +#' the priors distributions that are available for the covariance matrices, #' the regression coefficients and the intercept and auxiliary parameters. #' #' @return A \link[=stanreg-objects]{stanmvreg} object is returned. -#' +#' #' @seealso \code{\link{stan_glmer}}, \code{\link{stan_jm}}, -#' \code{\link{stanreg-objects}}, \code{\link{stanmvreg-methods}}, +#' \code{\link{stanreg-objects}}, \code{\link{stanmvreg-methods}}, #' \code{\link{print.stanmvreg}}, \code{\link{summary.stanmvreg}}, #' \code{\link{posterior_predict}}, \code{\link{posterior_interval}}. -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch !="i386") { #' \donttest{ #' ##### -#' # A multivariate GLM with two submodels. For the grouping factor 'id', the +#' # A multivariate GLM with two submodels. For the grouping factor 'id', the #' # group-specific intercept from the first submodel (logBili) is assumed to -#' # be correlated with the group-specific intercept and linear slope in the +#' # be correlated with the group-specific intercept and linear slope in the #' # second submodel (albumin) #' f1 <- stan_mvmer( #' formula = list( -#' logBili ~ year + (1 | id), +#' logBili ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), -#' data = pbcLong, +#' data = pbcLong, #' # this next line is only to keep the example small in size! #' chains = 1, cores = 1, seed = 12345, iter = 1000) -#' summary(f1) -#' +#' summary(f1) +#' #' ##### #' # A multivariate GLM with one bernoulli outcome and one #' # gaussian outcome. We will artificially create the bernoulli @@ -122,142 +122,90 @@ #' pbcLong$ybern <- as.integer(pbcLong$logBili >= mean(pbcLong$logBili)) #' f2 <- stan_mvmer( #' formula = list( -#' ybern ~ year + (1 | id), +#' ybern ~ year + (1 | id), #' albumin ~ sex + year + (year | id)), #' data = pbcLong, #' family = list(binomial, gaussian), #' chains = 1, cores = 1, seed = 12345, iter = 1000) #' } #' } -stan_mvmer <- function( - formula, - data, - family = gaussian, - weights, - prior = normal(autoscale = TRUE), - prior_intercept = normal(autoscale = TRUE), - prior_aux = cauchy(0, 5, autoscale = TRUE), - prior_covariance = lkj(autoscale = TRUE), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - max_treedepth = 10L, - init = "random", - QR = FALSE, - sparse = FALSE, - ... -) { +stan_mvmer <- function(formula, data, family = gaussian, weights, + prior = normal(autoscale=TRUE), prior_intercept = normal(autoscale=TRUE), + prior_aux = cauchy(0, 5, autoscale=TRUE), + prior_covariance = lkj(autoscale=TRUE), prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, max_treedepth = 10L, + init = "random", QR = FALSE, sparse = FALSE, ...) { + #----------------------------- # Pre-processing of arguments - #----------------------------- - + #----------------------------- + algorithm <- match.arg(algorithm) - - if (missing(weights)) { - weights <- NULL - } - - if (!is.null(weights)) { + + if (missing(weights)) weights <- NULL + + if (!is.null(weights)) stop("'weights' are not yet implemented.") - } - if (QR) { + if (QR) stop("'QR' decomposition is not yet implemented.") - } - if (sparse) { + if (sparse) stop("'sparse' option is not yet implemented.") - } - + # Formula - formula <- validate_arg(formula, "formula") - M <- length(formula) - if (M > 3L) { - stop("'stan_mvmer' is currently limited to a maximum of 3 outcomes.") - } - + formula <- validate_arg(formula, "formula"); M <- length(formula) + if (M > 3L) + stop("'stan_mvmer' is currently limited to a maximum of 3 outcomes.") + # Data - data <- validate_arg(data, "data.frame", validate_length = M) + data <- validate_arg(data, "data.frame", validate_length = M) data <- xapply(formula, data, FUN = get_all_vars) # drop additional vars - + # Family ok_classes <- c("function", "family", "character") - ok_families <- c( - "binomial", - "gaussian", - "Gamma", - "inverse.gaussian", - "poisson", - "neg_binomial_2" - ) + ok_families <- c("binomial", "gaussian", "Gamma", + "inverse.gaussian", "poisson", "neg_binomial_2") family <- validate_arg(family, ok_classes, validate_length = M) family <- lapply(family, validate_famlink, ok_families) # Observation weights if (!is.null(weights)) { - if (!is(weights, "list")) { + if (!is(weights, "list")) weights <- rep(list(weights), M) - } weights <- lapply(weights, validate_weights) } - + # Is prior* already a list? prior <- broadcast_prior(prior, M) prior_intercept <- broadcast_prior(prior_intercept, M) prior_aux <- broadcast_prior(prior_aux, M) - + #----------- # Fit model - #----------- - - stanfit <- stan_jm.fit( - formulaLong = formula, - dataLong = data, - family = family, - weights = weights, - priorLong = prior, - priorLong_intercept = prior_intercept, - priorLong_aux = prior_aux, - prior_covariance = prior_covariance, - prior_PD = prior_PD, - algorithm = algorithm, - adapt_delta = adapt_delta, - max_treedepth = max_treedepth, - init = init, - QR = QR, - sparse = sparse, - ... - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } + #----------- + + stanfit <- stan_jm.fit(formulaLong = formula, dataLong = data, family = family, + weights = weights, priorLong = prior, + priorLong_intercept = prior_intercept, priorLong_aux = prior_aux, + prior_covariance = prior_covariance, prior_PD = prior_PD, + algorithm = algorithm, adapt_delta = adapt_delta, + max_treedepth = max_treedepth, init = init, + QR = QR, sparse = sparse, ...) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) y_mod <- attr(stanfit, "y_mod") - cnms <- attr(stanfit, "cnms") + cnms <- attr(stanfit, "cnms") flevels <- attr(stanfit, "flevels") prior_info <- attr(stanfit, "prior_info") stanfit <- drop_attributes(stanfit, "y_mod", "cnms", "flevels", "prior_info") - + terms <- fetch(y_mod, "terms") n_yobs <- fetch_(y_mod, "x", "N") n_grps <- sapply(flevels, n_distinct) - - fit <- nlist( - stanfit, - formula, - family, - weights, - M, - cnms, - flevels, - n_grps, - n_yobs, - algorithm, - terms, - glmod = y_mod, - data, - prior.info = prior_info, - stan_function = "stan_mvmer", - call = match.call(expand.dots = TRUE) - ) - + + fit <- nlist(stanfit, formula, family, weights, M, cnms, flevels, n_grps, n_yobs, + algorithm, terms, glmod = y_mod, data, prior.info = prior_info, + stan_function = "stan_mvmer", call = match.call(expand.dots = TRUE)) + out <- stanmvreg(fit) return(out) } diff --git a/R/stan_nlmer.R b/R/stan_nlmer.R index 44b6a4d88..d3bf377a3 100644 --- a/R/stan_nlmer.R +++ b/R/stan_nlmer.R @@ -1,24 +1,24 @@ # Part of the rstanarm package for estimating model parameters # Copyright (C) 2016 Trustees of Columbia University -# +# # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. -# +# # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. -# +# # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. #' Bayesian nonlinear models with group-specific terms via Stan -#' +#' #' \if{html}{\figure{logo.svg}{options: width="25" alt="https://mc-stan.org/about/logo/"}} -#' Bayesian inference for NLMMs with group-specific coefficients that have +#' Bayesian inference for NLMMs with group-specific coefficients that have #' unknown covariance matrices with flexible priors. #' #' @export @@ -35,39 +35,39 @@ #' @template args-adapt_delta #' @template args-sparse #' @template args-QR -#' +#' #' @param formula,data Same as for \code{\link[lme4]{nlmer}}. \emph{We strongly #' advise against omitting the \code{data} argument}. Unless \code{data} is #' specified (and is a data frame) many post-estimation functions (including #' \code{update}, \code{loo}, \code{kfold}) are not guaranteed to work #' properly. #' @param subset,weights,offset Same as \code{\link[stats]{glm}}. -#' @param na.action,contrasts Same as \code{\link[stats]{glm}}, but rarely +#' @param na.action,contrasts Same as \code{\link[stats]{glm}}, but rarely #' specified. #' @param prior_covariance Cannot be \code{NULL}; see \code{\link{decov}} for #' more information about the default arguments. #' -#' @details The \code{stan_nlmer} function is similar in syntax to -#' \code{\link[lme4]{nlmer}} but rather than performing (approximate) maximum +#' @details The \code{stan_nlmer} function is similar in syntax to +#' \code{\link[lme4]{nlmer}} but rather than performing (approximate) maximum #' marginal likelihood estimation, Bayesian estimation is by default performed #' via MCMC. The Bayesian model adds independent priors on the "coefficients" -#' --- which are really intercepts --- in the same way as -#' \code{\link{stan_nlmer}} and priors on the terms of a decomposition of the +#' --- which are really intercepts --- in the same way as +#' \code{\link{stan_nlmer}} and priors on the terms of a decomposition of the #' covariance matrices of the group-specific parameters. See #' \code{\link{priors}} for more information about the priors. -#' -#' The supported transformation functions are limited to the named +#' +#' The supported transformation functions are limited to the named #' "self-starting" functions in the \pkg{stats} library: #' \code{\link[stats]{SSasymp}}, \code{\link[stats]{SSasympOff}}, #' \code{\link[stats]{SSasympOrig}}, \code{\link[stats]{SSbiexp}}, #' \code{\link[stats]{SSfol}}, \code{\link[stats]{SSfpl}}, #' \code{\link[stats]{SSgompertz}}, \code{\link[stats]{SSlogis}}, #' \code{\link[stats]{SSmicmen}}, and \code{\link[stats]{SSweibull}}. -#' -#' -#' @seealso The vignette for \code{stan_glmer}, which also discusses +#' +#' +#' @seealso The vignette for \code{stan_glmer}, which also discusses #' \code{stan_nlmer} models. \url{https://mc-stan.org/rstanarm/articles/} -#' +#' #' @examples #' if (.Platform$OS.type != "windows" || .Platform$r_arch !="i386") { #' \donttest{ @@ -75,12 +75,12 @@ #' Orange$circumference <- Orange$circumference / 100 #' Orange$age <- Orange$age / 100 #' fit <- stan_nlmer( -#' circumference ~ SSlogis(age, Asym, xmid, scal) ~ Asym|Tree, -#' data = Orange, +#' circumference ~ SSlogis(age, Asym, xmid, scal) ~ Asym|Tree, +#' data = Orange, #' # for speed only -#' chains = 1, +#' chains = 1, #' iter = 1000 -#' ) +#' ) #' print(fit) #' posterior_interval(fit) #' plot(fit, regex_pars = "b\\[") @@ -89,130 +89,101 @@ #' @importFrom lme4 nlformula #' @importFrom stats getInitial stan_nlmer <- - function( - formula, - data = NULL, - subset, - weights, - na.action, - offset, - contrasts = NULL, - ..., - prior = normal(autoscale = TRUE), - prior_aux = exponential(autoscale = TRUE), - prior_covariance = decov(), - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - QR = FALSE, - sparse = FALSE - ) { - if (!has_outcome_variable(formula[[2]])) { - stop("LHS of formula must be specified.") - } - f <- as.character(formula[-3]) - SSfunctions <- grep("^SS[[:lower:]]+", ls("package:stats"), value = TRUE) - SSfun <- sapply(SSfunctions, function(ss) { - grepl(paste0(ss, "("), x = f[2], fixed = TRUE) + function(formula, + data = NULL, + subset, + weights, + na.action, + offset, + contrasts = NULL, + ..., + prior = normal(autoscale=TRUE), + prior_aux = exponential(autoscale=TRUE), + prior_covariance = decov(), + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + QR = FALSE, + sparse = FALSE) { + + if (!has_outcome_variable(formula[[2]])) { + stop("LHS of formula must be specified.") + } + f <- as.character(formula[-3]) + SSfunctions <- grep("^SS[[:lower:]]+", ls("package:stats"), value = TRUE) + SSfun <- sapply(SSfunctions, function(ss) + grepl(paste0(ss, "("), x = f[2], fixed = TRUE)) + if (!any(SSfun)) { + stop("'stan_nlmer' requires a named self-starting nonlinear function.") + } + SSfun <- which(SSfun) + SSfun_char <- names(SSfun) + + mc <- match.call(expand.dots = FALSE) + mc$prior <- mc$prior_aux <- mc$prior_covariance <- mc$prior_PD <- + mc$algorithm <- mc$adapt_delta <- mc$QR <- mc$sparse <- NULL + mc$start <- + unlist(getInitial( + object = as.formula(f[-1]), + data = data, + control = list(maxiter = 0, warnOnly = TRUE) + )) + + nlf <- nlformula(mc) + X <- nlf$X + y <- nlf$respMod$y + weights <- nlf$respMod$weights + offset <- nlf$respMod$offset + + nlf$reTrms$SSfun <- SSfun + nlf$reTrms$decov <- prior_covariance + + nlf_inputs <- parse_nlf_inputs(nlf$respMod) + if (SSfun_char == "SSfol") { + nlf$reTrms$Dose <- nlf$frame[[nlf_inputs[2]]] + nlf$reTrms$input <- nlf$frame[[nlf_inputs[3]]] + } else { + nlf$reTrms$input <- nlf$frame[[nlf_inputs[2]]] + } + + + algorithm <- match.arg(algorithm) + stanfit <- stan_glm.fit(x = X, y = y, family = gaussian(link = "identity"), + weights = weights, offset = offset, + prior = prior, prior_intercept = NULL, + prior_aux = prior_aux, prior_PD = prior_PD, + algorithm = algorithm, adapt_delta = adapt_delta, + group = nlf$reTrms, QR = QR, sparse = sparse, ...) + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { + return(stanfit) + } + + if (SSfun_char == "SSfpl") { # SSfun = 6 + stanfit@sim$samples <- lapply(stanfit@sim$samples, FUN = function(x) { + x[[4L]] <- exp(x[[4L]]) + return(x) + }) + } else if (SSfun_char == "SSlogis") { # SSfun = 8 + stanfit@sim$samples <- lapply(stanfit@sim$samples, FUN = function(x) { + x[[3L]] <- exp(x[[3L]]) + return(x) }) - if (!any(SSfun)) { - stop("'stan_nlmer' requires a named self-starting nonlinear function.") - } - SSfun <- which(SSfun) - SSfun_char <- names(SSfun) - - mc <- match.call(expand.dots = FALSE) - mc$prior <- mc$prior_aux <- mc$prior_covariance <- mc$prior_PD <- - mc$algorithm <- mc$adapt_delta <- mc$QR <- mc$sparse <- NULL - mc$start <- - unlist(getInitial( - object = as.formula(f[-1]), - data = data, - control = list(maxiter = 0, warnOnly = TRUE) - )) - - nlf <- nlformula(mc) - X <- nlf$X - y <- nlf$respMod$y - weights <- nlf$respMod$weights - offset <- nlf$respMod$offset - - nlf$reTrms$SSfun <- SSfun - nlf$reTrms$decov <- prior_covariance - - nlf_inputs <- parse_nlf_inputs(nlf$respMod) - if (SSfun_char == "SSfol") { - nlf$reTrms$Dose <- nlf$frame[[nlf_inputs[2]]] - nlf$reTrms$input <- nlf$frame[[nlf_inputs[3]]] - } else { - nlf$reTrms$input <- nlf$frame[[nlf_inputs[2]]] - } - - algorithm <- match.arg(algorithm) - stanfit <- stan_glm.fit( - x = X, - y = y, - family = gaussian(link = "identity"), - weights = weights, - offset = offset, - prior = prior, - prior_intercept = NULL, - prior_aux = prior_aux, - prior_PD = prior_PD, - algorithm = algorithm, - adapt_delta = adapt_delta, - group = nlf$reTrms, - QR = QR, - sparse = sparse, - ... - ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } - - if (SSfun_char == "SSfpl") { - # SSfun = 6 - stanfit@sim$samples <- lapply(stanfit@sim$samples, FUN = function(x) { - x[[4L]] <- exp(x[[4L]]) - return(x) - }) - } else if (SSfun_char == "SSlogis") { - # SSfun = 8 - stanfit@sim$samples <- lapply(stanfit@sim$samples, FUN = function(x) { - x[[3L]] <- exp(x[[3L]]) - return(x) - }) - } - - Z <- pad_reTrms( - Ztlist = nlf$reTrms$Ztlist, - cnms = nlf$reTrms$cnms, - flist = nlf$reTrms$flist - )$Z - colnames(Z) <- b_names(names(stanfit), value = TRUE) - - fit <- nlist( - stanfit, - family = make_nlf_family(SSfun_char, nlf), - formula, - offset, - weights, - x = cbind(X, Z), - y = y, - data, - call = match.call(), - terms = NULL, - model = NULL, - na.action = na.omit, - contrasts, - algorithm, - glmod = nlf, - stan_function = "stan_nlmer" - ) - out <- stanreg(fit) - class(out) <- c(class(out), "nlmerMod", "lmerMod") - return(out) } + + Z <- pad_reTrms(Ztlist = nlf$reTrms$Ztlist, cnms = nlf$reTrms$cnms, + flist = nlf$reTrms$flist)$Z + colnames(Z) <- b_names(names(stanfit), value = TRUE) + + fit <- nlist(stanfit, + family = make_nlf_family(SSfun_char, nlf), + formula, offset, weights, + x = cbind(X, Z), y = y, data, call = match.call(), terms = NULL, + model = NULL, na.action = na.omit, contrasts, algorithm, + glmod = nlf, stan_function = "stan_nlmer") + out <- stanreg(fit) + class(out) <- c(class(out), "nlmerMod", "lmerMod") + return(out) +} # internal ---------------------------------------------------------------- @@ -234,8 +205,8 @@ parse_nlf_inputs <- function(respMod) { ) } -# Make family object -# +# Make family object +# # @param SSfun_char SS function name as a string # @param nlf Object returned by nlformula # @return A family object @@ -251,27 +222,20 @@ make_nlf_family <- function(SSfun_char, nlf) { end <- i * len t(eta[, start:end, drop = FALSE]) }) - if (is.null(arg2)) { - SSargs <- c(list(arg1), SSargs) - } else { - SSargs <- c(list(arg1, arg2), SSargs) - } + if (is.null(arg2)) SSargs <- c(list(arg1), SSargs) + else SSargs <- c(list(arg1, arg2), SSargs) } else { - SSargs <- as.data.frame(matrix(eta, nrow = length(arg1))) - if (is.null(arg2)) { - SSargs <- cbind(arg1, SSargs) - } else { - SSargs <- cbind(arg1, arg2, SSargs) - } + SSargs <- as.data.frame(matrix(eta, nrow = length(arg1))) + if (is.null(arg2)) SSargs <- cbind(arg1, SSargs) + else SSargs <- cbind(arg1, arg2, SSargs) } names(SSargs) <- names(formals(FUN)) - if (FUN == "SSbiexp") { + if (FUN == "SSbiexp") SSargs$A1 <- SSargs$A1 + exp(SSargs$A2) - } - + do.call(FUN, args = SSargs) } - + nlf_inputs <- parse_nlf_inputs(nlf$respMod) if (SSfun_char == "SSfol") { formals(g$linkinv)$arg1 <- nlf$frame[[nlf_inputs[2]]] @@ -279,9 +243,9 @@ make_nlf_family <- function(SSfun_char, nlf) { } else { formals(g$linkinv)$arg1 <- nlf$frame[[nlf_inputs[2]]] } - - g$linkfun <- function(mu) stop("'linkfun' should not have been called") + + g$linkfun <- function(mu) stop("'linkfun' should not have been called") g$variance <- function(mu) stop("'variance' should not have been called") - g$mu.eta <- function(mu) stop("'mu.eta' should not have been called") + g$mu.eta <- function(mu) stop("'mu.eta' should not have been called") return(g) -} +} \ No newline at end of file diff --git a/R/stan_polr.R b/R/stan_polr.R index a870c108f..d3aa10b19 100644 --- a/R/stan_polr.R +++ b/R/stan_polr.R @@ -56,13 +56,13 @@ #' the exponent applied to the probability of success when there are only #' two outcome categories. If \code{NULL}, which is the default, then the #' exponent is taken to be fixed at \eqn{1}. -#' @param do_residuals A logical scalar indicating whether or not to +#' @param do_residuals A logical scalar indicating whether or not to #' automatically calculate fit residuals after sampling completes. Defaults to #' \code{TRUE} if and only if \code{algorithm="sampling"}. Setting #' \code{do_residuals=FALSE} is only useful in the somewhat rare case that #' \code{stan_polr} appears to finish sampling but hangs instead of returning #' the fitted model object. -#' +#' #' @details The \code{stan_polr} function is similar in syntax to #' \code{\link[MASS]{polr}} but rather than performing maximum likelihood #' estimation of a proportional odds model, Bayesian estimation is performed @@ -128,31 +128,24 @@ #' } #' #' @importFrom utils packageVersion -stan_polr <- function( - formula, - data, - weights, - ..., - subset, - na.action = getOption("na.action", "na.omit"), - contrasts = NULL, - model = TRUE, - method = c("logistic", "probit", "loglog", "cloglog", "cauchit"), - prior = R2(stop("'location' must be specified")), - prior_counts = dirichlet(1), - shape = NULL, - rate = NULL, - prior_PD = FALSE, - algorithm = c("sampling", "meanfield", "fullrank"), - adapt_delta = NULL, - do_residuals = NULL -) { +stan_polr <- function(formula, data, weights, ..., subset, + na.action = getOption("na.action", "na.omit"), + contrasts = NULL, model = TRUE, + method = c("logistic", "probit", "loglog", "cloglog", + "cauchit"), + prior = R2(stop("'location' must be specified")), + prior_counts = dirichlet(1), shape = NULL, rate = NULL, + prior_PD = FALSE, + algorithm = c("sampling", "meanfield", "fullrank"), + adapt_delta = NULL, + do_residuals = NULL) { + data <- validate_data(data, if_missing = environment(formula)) is_char <- which(sapply(data, is.character)) for (j in is_char) { data[[j]] <- as.factor(data[[j]]) } - + algorithm <- match.arg(algorithm) if (is.null(do_residuals)) { do_residuals <- algorithm == "sampling" @@ -167,8 +160,8 @@ stan_polr <- function( m$data <- data } m$method <- m$model <- m$... <- m$prior <- m$prior_counts <- - m$prior_PD <- m$algorithm <- m$adapt_delta <- m$shape <- m$rate <- - m$do_residuals <- NULL + m$prior_PD <- m$algorithm <- m$adapt_delta <- m$shape <- m$rate <- + m$do_residuals <- NULL m[[1L]] <- quote(stats::model.frame) m$drop.unused.levels <- FALSE m <- eval.parent(m) @@ -182,27 +175,21 @@ stan_polr <- function( if (xint > 0L) { x <- x[, -xint, drop = FALSE] pc <- pc - 1L - } else { - stop("an intercept is needed and assumed") - } + } else stop("an intercept is needed and assumed") K <- ncol(x) wt <- model.weights(m) - if (!length(wt)) { + if (!length(wt)) wt <- rep(1, n) - } offset <- model.offset(m) - if (length(offset) <= 1L) { + if (length(offset) <= 1L) offset <- rep(0, n) - } y <- model.response(m) - if (!is.factor(y)) { + if (!is.factor(y)) stop("Response variable must be a factor.", call. = FALSE) - } lev <- levels(y) llev <- length(lev) - if (llev < 2L) { + if (llev < 2L) stop("Response variable must have 2 or more levels.", call. = FALSE) - } # y <- unclass(y) q <- llev - 1L @@ -223,48 +210,28 @@ stan_polr <- function( do_residuals = do_residuals, ... ) - if (algorithm != "optimizing" && !is(stanfit, "stanfit")) { - return(stanfit) - } + if (algorithm != "optimizing" && !is(stanfit, "stanfit")) return(stanfit) inverse_link <- linkinv(method) - if (llev == 2L) { - # actually a Bernoulli model - family <- switch( - method, - logistic = binomial(link = "logit"), - loglog = binomial(loglog), - binomial(link = method) - ) - fit <- nlist( - stanfit, - family, - formula, - offset, - weights = wt, - x = cbind("(Intercept)" = 1, x), - y = as.integer(y == lev[2]), - data, - call, - terms = Terms, - model = m, - algorithm, - na.action = attr(m, "na.action"), - contrasts = attr(x, "contrasts"), - stan_function = "stan_polr" - ) + if (llev == 2L) { # actually a Bernoulli model + family <- switch(method, + logistic = binomial(link = "logit"), + loglog = binomial(loglog), + binomial(link = method)) + fit <- nlist(stanfit, family, formula, offset, weights = wt, + x = cbind("(Intercept)" = 1, x), y = as.integer(y == lev[2]), + data, call, terms = Terms, model = m, + algorithm, na.action = attr(m, "na.action"), + contrasts = attr(x, "contrasts"), + stan_function = "stan_polr") out <- stanreg(fit) - if (!model) { + if (!model) out$model <- NULL - } - if (algorithm == "sampling") { + if (algorithm == "sampling") check_rhats(out$stan_summary[, "Rhat"]) - } - - if (is.null(shape) && is.null(rate)) { - # not a scobit model + + if (is.null(shape) && is.null(rate)) # not a scobit model return(out) - } out$method <- method return(structure(out, class = c("stanreg", "polr"))) @@ -276,7 +243,7 @@ stan_polr <- function( covmat <- cov(stanmat) coefs <- apply(stanmat[, 1:K, drop = FALSE], 2L, median) ses <- apply(stanmat[, 1:K, drop = FALSE], 2L, mad) - zeta <- apply(stanmat[, (K + 1):K2, drop = FALSE], 2L, median) + zeta <- apply(stanmat[, (K+1):K2, drop = FALSE], 2L, median) eta <- linear_predictor(coefs, x, offset) mu <- inverse_link(eta) @@ -290,54 +257,34 @@ stan_polr <- function( names(residuals) <- rownames(x) } stan_summary <- make_stan_summary(stanfit) - if (algorithm == "sampling") { + if (algorithm == "sampling") check_rhats(stan_summary[, "Rhat"]) - } - out <- nlist( - coefficients = coefs, - ses, - zeta, - residuals, - fitted.values = mu, - linear.predictors = eta, - covmat, - y, - x, - model = if (model) m, - data, - offset, - weights = wt, - prior.weights = wt, - family = method, - method, - contrasts, - na.action, - call, - formula, - terms = Terms, - prior.info = attr(stanfit, "prior.info"), - algorithm, - stan_summary, - stanfit, - rstan_version = packageVersion("rstan"), - stan_function = "stan_polr" - ) + out <- nlist(coefficients = coefs, ses, zeta, residuals, + fitted.values = mu, linear.predictors = eta, covmat, + y, x, model = if (model) m, data, + offset, weights = wt, prior.weights = wt, + family = method, method, contrasts, na.action, + call, formula, terms = Terms, + prior.info = attr(stanfit, "prior.info"), + algorithm, stan_summary, stanfit, + rstan_version = packageVersion("rstan"), + stan_function = "stan_polr") structure(out, class = c("stanreg", "polr")) } + # internal ---------------------------------------------------------------- # CDF, inverse-CDF and PDF for Gumbel distribution -pgumbel <- function(q, loc = 0, scale = 1, lower.tail = TRUE) { - q <- (q - loc) / scale +pgumbel <- function (q, loc = 0, scale = 1, lower.tail = TRUE) { + q <- (q - loc)/scale p <- exp(-exp(-q)) - if (!lower.tail) { + if (!lower.tail) 1 - p - } else { + else p - } } qgumbel <- function(p, loc = 0, scale = 1) { loc - scale * log(-log(p)) @@ -345,18 +292,12 @@ qgumbel <- function(p, loc = 0, scale = 1) { dgumbel <- function(x, loc = 0, scale = 1, log = FALSE) { z <- (x - loc) / scale log_f <- -(z + exp(-z)) - if (!log) { + if (!log) exp(log_f) - } else { + else log_f - } } -loglog <- list( - linkfun = qgumbel, - linkinv = pgumbel, - mu.eta = dgumbel, - valideta = function(eta) TRUE, - name = "loglog" -) -class(loglog) <- "link-glm" +loglog <- list(linkfun = qgumbel, linkinv = pgumbel, mu.eta = dgumbel, + valideta = function(eta) TRUE, name = "loglog") +class(loglog) <- "link-glm" \ No newline at end of file From 6f6f38a61ddcff532f2a3161b41f940c5bba4486 Mon Sep 17 00:00:00 2001 From: Visruth <67435125+VisruthSK@users.noreply.github.com> Date: Thu, 4 Dec 2025 17:35:37 -0800 Subject: [PATCH 09/14] Clean gh-pages branch on builds --- .github/workflows/pkgdown.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 877722477..89bb3e542 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -47,6 +47,6 @@ jobs: - name: Deploy to GitHub pages 🚀 uses: JamesIves/github-pages-deploy-action@v4 with: - clean: false + clean: true branch: gh-pages folder: docs \ No newline at end of file From d9bc6b871141f20af4ed0fc4d4bc93edf778e415 Mon Sep 17 00:00:00 2001 From: VisruthSK <67435125+VisruthSK@users.noreply.github.com> Date: Fri, 5 Dec 2025 15:53:36 -0800 Subject: [PATCH 10/14] Revert "Clean gh-pages branch on builds" This reverts commit 6f6f38a61ddcff532f2a3161b41f940c5bba4486. --- .github/workflows/pkgdown.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 89bb3e542..877722477 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -47,6 +47,6 @@ jobs: - name: Deploy to GitHub pages 🚀 uses: JamesIves/github-pages-deploy-action@v4 with: - clean: true + clean: false branch: gh-pages folder: docs \ No newline at end of file From 62df739237076cb27fa6c90eb3c43da4f2d2a78c Mon Sep 17 00:00:00 2001 From: jgabry Date: Tue, 9 Dec 2025 14:12:26 -0700 Subject: [PATCH 11/14] Update lm.Rmd --- vignettes/lm.Rmd | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/vignettes/lm.Rmd b/vignettes/lm.Rmd index 497195b57..c704908d0 100644 --- a/vignettes/lm.Rmd +++ b/vignettes/lm.Rmd @@ -250,7 +250,9 @@ clouds_cf$seeding[] <- "yes" y1_rep <- posterior_predict(post, newdata = clouds_cf) clouds_cf$seeding[] <- "no" y0_rep <- posterior_predict(post, newdata = clouds_cf) -qplot(x = c(y1_rep - y0_rep), geom = "histogram", xlab = "Estimated ATE") +ggplot(data.frame(x = c(y1_rep - y0_rep))) + + geom_histogram(aes(x)) + + labs(x = "Estimated ATE", y = NULL) ``` As can be seen, the treatment effect is not estimated precisely and is as @@ -283,17 +285,18 @@ __loo__ package. ```{r lm-clouds-loo, warning=TRUE} (loo_post <- loo(post)) -loo_compare(loo_post, loo(simple)) +(loo_simple <- loo(simple)) +loo_compare(loo_post, loo_simple) ``` The results indicate that the first approach is expected to produce better out-of-sample predictions but the Warning messages are at least as important. -Many of the estimated shape parameters for the Generalized Pareto distribution -are above $0.5$ in the model with Cauchy priors, which indicates that these +Some of the estimated shape parameters for the Generalized Pareto distribution +are above $0.7$ in the model with Cauchy priors, which indicates that these estimates are only going to converge slowly to the true out-of-sample deviance measures. Thus, with only $24$ observations, they should not be considered reliable. The more complicated prior derived above is stronger --- as -evidenced by the fact that the effective number of parameters is about half +evidenced by the fact that the effective number of parameters `p_loo` is about half of that in the simpler approach and $12$ for the maximum likelihood estimator --- and only has a few of the $24$ Pareto shape estimates in the "danger zone". We might want to reexamine these observations From 10e791f0fdd0ff7ada8da0c00dc05c1ba173cc97 Mon Sep 17 00:00:00 2001 From: jgabry Date: Tue, 9 Dec 2025 15:57:53 -0700 Subject: [PATCH 12/14] fix line endings --- R/stan_betareg.R | 2 +- R/stan_clogit.R | 2 +- R/stan_gamm4.R | 2 +- R/stan_glm.R | 2 +- R/stan_glmer.R | 2 +- R/stan_lm.R | 2 +- R/stan_nlmer.R | 2 +- R/stan_polr.R | 2 +- R/stan_polr.fit.R | 1 - 9 files changed, 8 insertions(+), 9 deletions(-) diff --git a/R/stan_betareg.R b/R/stan_betareg.R index b45ab1391..9284848f6 100644 --- a/R/stan_betareg.R +++ b/R/stan_betareg.R @@ -249,4 +249,4 @@ beta_phi_fam <- function(link = "log") { out$simulate <- function(object, nsim) stop("'simulate' function should not have been called") return(out) -} \ No newline at end of file +} diff --git a/R/stan_clogit.R b/R/stan_clogit.R index 5ff61a6da..ac2dec7b4 100644 --- a/R/stan_clogit.R +++ b/R/stan_clogit.R @@ -200,4 +200,4 @@ log_clogit_denom <- function(N_j, D_j, eta_j) { return( log_sum_exp2(log_clogit_denom(N_jm1, D_j, eta_j), log_clogit_denom(N_jm1, D_j - 1, eta_j) + eta_j[N_j]) ) } -} \ No newline at end of file +} diff --git a/R/stan_gamm4.R b/R/stan_gamm4.R index abb2d38db..a6380c845 100644 --- a/R/stan_gamm4.R +++ b/R/stan_gamm4.R @@ -425,4 +425,4 @@ plot_nonlinear <- function(x, smooths, ..., labs(y = NULL) + do.call(facet_wrap, facet_args) + bayesplot::theme_default() -} \ No newline at end of file +} diff --git a/R/stan_glm.R b/R/stan_glm.R index 143899a8b..3b9d92b31 100644 --- a/R/stan_glm.R +++ b/R/stan_glm.R @@ -340,4 +340,4 @@ stan_glm.nb <- out$call <- call out$stan_function <- "stan_glm.nb" return(out) -} \ No newline at end of file +} diff --git a/R/stan_glmer.R b/R/stan_glmer.R index 945ec6797..b4a238153 100644 --- a/R/stan_glmer.R +++ b/R/stan_glmer.R @@ -261,4 +261,4 @@ stan_glmer.nb <- out$call <- call out$stan_function <- "stan_glmer.nb" return(out) -} \ No newline at end of file +} diff --git a/R/stan_lm.R b/R/stan_lm.R index 3f6db17da..576066f0c 100644 --- a/R/stan_lm.R +++ b/R/stan_lm.R @@ -175,4 +175,4 @@ stan_lm <- function(formula, data, subset, weights, na.action, out$y <- NULL return(out) -} \ No newline at end of file +} diff --git a/R/stan_nlmer.R b/R/stan_nlmer.R index d3bf377a3..bbde44d52 100644 --- a/R/stan_nlmer.R +++ b/R/stan_nlmer.R @@ -248,4 +248,4 @@ make_nlf_family <- function(SSfun_char, nlf) { g$variance <- function(mu) stop("'variance' should not have been called") g$mu.eta <- function(mu) stop("'mu.eta' should not have been called") return(g) -} \ No newline at end of file +} diff --git a/R/stan_polr.R b/R/stan_polr.R index d3aa10b19..96439f6f9 100644 --- a/R/stan_polr.R +++ b/R/stan_polr.R @@ -300,4 +300,4 @@ dgumbel <- function(x, loc = 0, scale = 1, log = FALSE) { loglog <- list(linkfun = qgumbel, linkinv = pgumbel, mu.eta = dgumbel, valideta = function(eta) TRUE, name = "loglog") -class(loglog) <- "link-glm" \ No newline at end of file +class(loglog) <- "link-glm" diff --git a/R/stan_polr.fit.R b/R/stan_polr.fit.R index a26a4bb20..736fe5cb8 100644 --- a/R/stan_polr.fit.R +++ b/R/stan_polr.fit.R @@ -191,4 +191,3 @@ summarize_polr_prior <- function(prior, prior_counts, shape=NULL, rate=NULL) { return(prior_list) } - From 869af42c13a7577d3c07681947fa5d09f6618dac Mon Sep 17 00:00:00 2001 From: jgabry Date: Wed, 10 Dec 2025 14:50:20 -0700 Subject: [PATCH 13/14] Update NEWS.md --- NEWS.md | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/NEWS.md b/NEWS.md index 22c38c418..4fd1eefc3 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,32 @@ +# rstanarm v2.32.2 + +* Update recommendations for responding to convergence warnings by @jgabry in https://github.com/stan-dev/rstanarm/pull/617 +* Replace Stan R Packages repo with R-Universe by @andrjohns in https://github.com/stan-dev/rstanarm/pull/624 +* Fix mistaken ')' alignment in output test by @MichaelChirico in https://github.com/stan-dev/rstanarm/pull/636 +* Default to not computing r_eff for loo by @jgabry in https://github.com/stan-dev/rstanarm/pull/638 +* migrate formula machinery from lme4 to reformulas by @bbolker in https://github.com/stan-dev/rstanarm/pull/639 +* Fix documentations to address CRAN NOTEs by @yoshidk6 in https://github.com/stan-dev/rstanarm/pull/641 +* Use vectorized abs() by @HPCurtis in https://github.com/stan-dev/rstanarm/pull/632 +* Use rstantools - Fix Build/Export Errors by @andrjohns in https://github.com/stan-dev/rstanarm/pull/625 + +# rstanarm v2.32.1 + +* Avoid error for 1-D unit_vector by @jgabry in https://github.com/stan-dev/rstanarm/pull/606 +* Update .set_nreps by @avehtari in https://github.com/stan-dev/rstanarm/pull/612 +* Use LTO during compilation + + +# rstanarm 2.26.1 + +This release updates rstanarm to use the latest syntax supported by rstan. + +* wells dataset wrong variable name by @storopoli in https://github.com/stan-dev/rstanarm/pull/552 +* add logo to be displayed in r-universe by @avehtari in https://github.com/stan-dev/rstanarm/pull/569 +* Fix CRAN NOTEs and failures by @andrjohns in https://github.com/stan-dev/rstanarm/pull/587 +* Implement posterior::as_draws() for rstanarm objects by @jgabry in https://github.com/stan-dev/rstanarm/pull/596 +* Array syntax by @bgoodri in https://github.com/stan-dev/rstanarm/pull/597 + + # rstanarm 2.21.3 ### Bug fixes From ef0757dd99125af2f2cd349030a535e2e7b25bb1 Mon Sep 17 00:00:00 2001 From: jgabry Date: Wed, 10 Dec 2025 14:56:08 -0700 Subject: [PATCH 14/14] Update .Rbuildignore --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index ecdbd1ed8..13b7ffafc 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -22,3 +22,4 @@ dev-notes/* revdep/* ^\.github$ +^_pkgdown\.yml$