Binary files /tmp/tmpt0wkwjq4/DNen8CCOKk/r-cran-brms-2.16.3/build/vignette.rds and /tmp/tmpt0wkwjq4/VQL6MIL24y/r-cran-brms-2.17.0/build/vignette.rds differ diff -Nru r-cran-brms-2.16.3/debian/changelog r-cran-brms-2.17.0/debian/changelog --- r-cran-brms-2.16.3/debian/changelog 2021-11-24 17:47:18.000000000 +0000 +++ r-cran-brms-2.17.0/debian/changelog 2022-04-27 11:56:31.000000000 +0000 @@ -1,3 +1,10 @@ +r-cran-brms (2.17.0-1) unstable; urgency=medium + + * New upstream version + * Test-Depends as in DESCRIPTION as far as available + + -- Andreas Tille Wed, 27 Apr 2022 13:56:31 +0200 + r-cran-brms (2.16.3-1) unstable; urgency=medium * Team upload. diff -Nru r-cran-brms-2.16.3/debian/tests/control r-cran-brms-2.17.0/debian/tests/control --- r-cran-brms-2.16.3/debian/tests/control 2021-11-24 17:41:23.000000000 +0000 +++ r-cran-brms-2.17.0/debian/tests/control 2022-04-27 11:56:31.000000000 +0000 @@ -1,5 +1,30 @@ Tests: run-unit-test -Depends: @, r-cran-testthat, r-cran-emmeans, r-cran-mnormt, r-cran-spdep, r-cran-rwiener, r-cran-splines2, r-cran-rtdists +Depends: @, + r-cran-testthat, + r-cran-emmeans, +# r-cran-cmdstanr, + r-cran-projpred, + r-cran-mnormt, r-cran-splines2, + r-cran-rwiener, + r-cran-rtdists, + r-cran-extradistr, + r-cran-processx, + r-cran-mice, + r-cran-spdep, + r-cran-mnormt, + r-cran-lme4, +# r-cran-mcmcglmm + r-cran-splines2, + r-cran-ape, + r-cran-arm, + r-cran-statmod, + r-cran-digest, + r-cran-diffobj, + r-cran-r.rsp, + r-cran-gtable, + r-cran-shiny, + r-cran-knitr, + r-cran-rmarkdown Restrictions: allow-stderr diff -Nru r-cran-brms-2.16.3/DESCRIPTION r-cran-brms-2.17.0/DESCRIPTION --- r-cran-brms-2.16.3/DESCRIPTION 2021-11-22 19:50:03.000000000 +0000 +++ r-cran-brms-2.17.0/DESCRIPTION 2022-04-13 14:22:29.000000000 +0000 @@ -2,8 +2,8 @@ Encoding: UTF-8 Type: Package Title: Bayesian Regression Models using 'Stan' -Version: 2.16.3 -Date: 2021-11-22 +Version: 2.17.0 +Date: 2022-04-08 Authors@R: c(person("Paul-Christian", "Bürkner", email = "paul.buerkner@gmail.com", role = c("aut", "cre")), @@ -13,7 +13,8 @@ person("Martin", "Modrak", role = c("ctb")), person("Hamada S.", "Badr", role = c("ctb")), person("Frank", "Weber", role = c("ctb")), - person("Mattan S.", "Ben-Shachar", role = c("ctb"))) + person("Mattan S.", "Ben-Shachar", role = c("ctb")), + person("Hayden", "Rabel", role = c("ctb"))) Depends: R (>= 3.5.0), Rcpp (>= 0.12.0), methods Imports: rstan (>= 2.19.2), ggplot2 (>= 2.0.0), loo (>= 2.3.1), posterior (>= 1.0.0), Matrix (>= 1.1.1), mgcv (>= 1.8-13), @@ -22,24 +23,25 @@ 1.19.0), matrixStats, nleqslv, nlme, coda, abind, stats, utils, parallel, grDevices, backports Suggests: testthat (>= 0.9.1), emmeans (>= 1.4.2), cmdstanr (>= 0.4.0), - projpred (>= 2.0.0), RWiener, rtdists, mice, spdep, mnormt, - lme4, MCMCglmm, splines2, ape, arm, statmod, digest, diffobj, - R.rsp, gtable, shiny, knitr, rmarkdown + projpred (>= 2.0.0), RWiener, rtdists, extraDistr, processx, + mice, spdep, mnormt, lme4, MCMCglmm, splines2, ape, arm, + statmod, digest, diffobj, R.rsp, gtable, shiny, knitr, + rmarkdown Description: Fit Bayesian generalized (non-)linear multivariate multilevel models - using 'Stan' for full Bayesian inference. A wide range of distributions - and link functions are supported, allowing users to fit -- among others -- - linear, robust linear, count data, survival, response times, ordinal, - zero-inflated, hurdle, and even self-defined mixture models all in a - multilevel context. Further modeling options include non-linear and - smooth terms, auto-correlation structures, censored data, meta-analytic - standard errors, and quite a few more. In addition, all parameters of the - response distribution can be predicted in order to perform distributional - regression. Prior specifications are flexible and explicitly encourage + using 'Stan' for full Bayesian inference. A wide range of distributions + and link functions are supported, allowing users to fit -- among others -- + linear, robust linear, count data, survival, response times, ordinal, + zero-inflated, hurdle, and even self-defined mixture models all in a + multilevel context. Further modeling options include non-linear and + smooth terms, auto-correlation structures, censored data, meta-analytic + standard errors, and quite a few more. In addition, all parameters of the + response distribution can be predicted in order to perform distributional + regression. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. - Model fit can easily be assessed and compared with posterior predictive + Model fit can easily be assessed and compared with posterior predictive checks and leave-one-out cross-validation. References: Bürkner (2017) ; Bürkner (2018) ; - Bürkner (2021) ; Carpenter et al. (2017) + Bürkner (2021) ; Carpenter et al. (2017) . LazyData: true NeedsCompilation: no @@ -50,7 +52,7 @@ Additional_repositories: https://mc-stan.org/r-packages/ VignetteBuilder: knitr, R.rsp RoxygenNote: 7.1.2 -Packaged: 2021-11-22 17:06:55 UTC; paulb +Packaged: 2022-04-11 08:20:38 UTC; paul.buerkner Author: Paul-Christian Bürkner [aut, cre], Jonah Gabry [ctb], Sebastian Weber [ctb], @@ -58,7 +60,8 @@ Martin Modrak [ctb], Hamada S. Badr [ctb], Frank Weber [ctb], - Mattan S. Ben-Shachar [ctb] + Mattan S. Ben-Shachar [ctb], + Hayden Rabel [ctb] Maintainer: Paul-Christian Bürkner Repository: CRAN -Date/Publication: 2021-11-22 19:50:02 UTC +Date/Publication: 2022-04-13 14:22:29 UTC diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_asym_laplace.stan r-cran-brms-2.17.0/inst/chunks/fun_asym_laplace.stan --- r-cran-brms-2.16.3/inst/chunks/fun_asym_laplace.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_asym_laplace.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,58 +1,58 @@ - /* helper function for asym_laplace_lpdf - * Args: - * y: the response value - * quantile: quantile parameter in (0, 1) - */ - real rho_quantile(real y, real quantile) { - if (y < 0) { - return y * (quantile - 1); - } else { - return y * quantile; - } - } - /* asymmetric laplace log-PDF for a single response - * Args: - * y: the response value - * mu: location parameter - * sigma: positive scale parameter - * quantile: quantile parameter in (0, 1) - * Returns: - * a scalar to be added to the log posterior - */ - real asym_laplace_lpdf(real y, real mu, real sigma, real quantile) { - return log(quantile * (1 - quantile)) - - log(sigma) - - rho_quantile((y - mu) / sigma, quantile); - } - /* asymmetric laplace log-CDF for a single quantile - * Args: - * y: a quantile - * mu: location parameter - * sigma: positive scale parameter - * quantile: quantile parameter in (0, 1) - * Returns: - * a scalar to be added to the log posterior - */ - real asym_laplace_lcdf(real y, real mu, real sigma, real quantile) { - if (y < mu) { - return log(quantile) + (1 - quantile) * (y - mu) / sigma; - } else { - return log1m((1 - quantile) * exp(-quantile * (y - mu) / sigma)); - } - } - /* asymmetric laplace log-CCDF for a single quantile - * Args: - * y: a quantile - * mu: location parameter - * sigma: positive scale parameter - * quantile: quantile parameter in (0, 1) - * Returns: - * a scalar to be added to the log posterior - */ - real asym_laplace_lccdf(real y, real mu, real sigma, real quantile) { - if (y < mu) { - return log1m(quantile * exp((1 - quantile) * (y - mu) / sigma)); - } else { - return log1m(quantile) - quantile * (y - mu) / sigma; - } - } + /* helper function for asym_laplace_lpdf + * Args: + * y: the response value + * quantile: quantile parameter in (0, 1) + */ + real rho_quantile(real y, real quantile) { + if (y < 0) { + return y * (quantile - 1); + } else { + return y * quantile; + } + } + /* asymmetric laplace log-PDF for a single response + * Args: + * y: the response value + * mu: location parameter + * sigma: positive scale parameter + * quantile: quantile parameter in (0, 1) + * Returns: + * a scalar to be added to the log posterior + */ + real asym_laplace_lpdf(real y, real mu, real sigma, real quantile) { + return log(quantile * (1 - quantile)) - + log(sigma) - + rho_quantile((y - mu) / sigma, quantile); + } + /* asymmetric laplace log-CDF for a single quantile + * Args: + * y: a quantile + * mu: location parameter + * sigma: positive scale parameter + * quantile: quantile parameter in (0, 1) + * Returns: + * a scalar to be added to the log posterior + */ + real asym_laplace_lcdf(real y, real mu, real sigma, real quantile) { + if (y < mu) { + return log(quantile) + (1 - quantile) * (y - mu) / sigma; + } else { + return log1m((1 - quantile) * exp(-quantile * (y - mu) / sigma)); + } + } + /* asymmetric laplace log-CCDF for a single quantile + * Args: + * y: a quantile + * mu: location parameter + * sigma: positive scale parameter + * quantile: quantile parameter in (0, 1) + * Returns: + * a scalar to be added to the log posterior + */ + real asym_laplace_lccdf(real y, real mu, real sigma, real quantile) { + if (y < mu) { + return log1m(quantile * exp((1 - quantile) * (y - mu) / sigma)); + } else { + return log1m(quantile) - quantile * (y - mu) / sigma; + } + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_cauchit.stan r-cran-brms-2.17.0/inst/chunks/fun_cauchit.stan --- r-cran-brms-2.16.3/inst/chunks/fun_cauchit.stan 2017-11-13 08:30:32.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_cauchit.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,18 +1,18 @@ - /* compute the cauchit link - * Args: - * p: a scalar in (0, 1) - * Returns: - * a scalar in (-Inf, Inf) - */ - real cauchit(real p) { - return tan(pi() * (p - 0.5)); - } - /* compute the inverse of the cauchit link - * Args: - * y: a scalar in (-Inf, Inf) - * Returns: - * a scalar in (0, 1) - */ - real inv_cauchit(real y) { - return cauchy_cdf(y, 0, 1); - } + /* compute the cauchit link + * Args: + * p: a scalar in (0, 1) + * Returns: + * a scalar in (-Inf, Inf) + */ + real cauchit(real p) { + return tan(pi() * (p - 0.5)); + } + /* compute the inverse of the cauchit link + * Args: + * y: a scalar in (-Inf, Inf) + * Returns: + * a scalar in (0, 1) + */ + real inv_cauchit(real y) { + return cauchy_cdf(y, 0, 1); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_cholesky_cor_ar1.stan r-cran-brms-2.17.0/inst/chunks/fun_cholesky_cor_ar1.stan --- r-cran-brms-2.16.3/inst/chunks/fun_cholesky_cor_ar1.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_cholesky_cor_ar1.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,20 +1,20 @@ - /* compute the cholesky factor of an AR1 correlation matrix - * Args: - * ar: AR1 autocorrelation - * nrows: number of rows of the covariance matrix - * Returns: - * A nrows x nrows matrix - */ - matrix cholesky_cor_ar1(real ar, int nrows) { - matrix[nrows, nrows] mat; - vector[nrows - 1] gamma; - mat = diag_matrix(rep_vector(1, nrows)); - for (i in 2:nrows) { - gamma[i - 1] = pow(ar, i - 1); - for (j in 1:(i - 1)) { - mat[i, j] = gamma[i - j]; - mat[j, i] = gamma[i - j]; - } - } - return cholesky_decompose(mat ./ (1 - ar^2)); - } + /* compute the cholesky factor of an AR1 correlation matrix + * Args: + * ar: AR1 autocorrelation + * nrows: number of rows of the covariance matrix + * Returns: + * A nrows x nrows matrix + */ + matrix cholesky_cor_ar1(real ar, int nrows) { + matrix[nrows, nrows] mat; + vector[nrows - 1] gamma; + mat = diag_matrix(rep_vector(1, nrows)); + for (i in 2:nrows) { + gamma[i - 1] = pow(ar, i - 1); + for (j in 1:(i - 1)) { + mat[i, j] = gamma[i - j]; + mat[j, i] = gamma[i - j]; + } + } + return cholesky_decompose(mat ./ (1 - ar^2)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_cholesky_cor_arma1.stan r-cran-brms-2.17.0/inst/chunks/fun_cholesky_cor_arma1.stan --- r-cran-brms-2.16.3/inst/chunks/fun_cholesky_cor_arma1.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_cholesky_cor_arma1.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,22 +1,22 @@ - /* compute the cholesky factor of an ARMA1 correlation matrix - * Args: - * ar: AR1 autocorrelation - * ma: MA1 autocorrelation - * nrows: number of rows of the covariance matrix - * Returns: - * A nrows x nrows matrix - */ - matrix cholesky_cor_arma1(real ar, real ma, int nrows) { - matrix[nrows, nrows] mat; - vector[nrows] gamma; - mat = diag_matrix(rep_vector(1 + ma^2 + 2 * ar * ma, nrows)); - gamma[1] = (1 + ar * ma) * (ar + ma); - for (i in 2:nrows) { - gamma[i] = gamma[1] * pow(ar, i - 1); - for (j in 1:(i - 1)) { - mat[i, j] = gamma[i - j]; - mat[j, i] = gamma[i - j]; - } - } - return cholesky_decompose(mat ./ (1 - ar^2)); - } + /* compute the cholesky factor of an ARMA1 correlation matrix + * Args: + * ar: AR1 autocorrelation + * ma: MA1 autocorrelation + * nrows: number of rows of the covariance matrix + * Returns: + * A nrows x nrows matrix + */ + matrix cholesky_cor_arma1(real ar, real ma, int nrows) { + matrix[nrows, nrows] mat; + vector[nrows] gamma; + mat = diag_matrix(rep_vector(1 + ma^2 + 2 * ar * ma, nrows)); + gamma[1] = (1 + ar * ma) * (ar + ma); + for (i in 2:nrows) { + gamma[i] = gamma[1] * pow(ar, i - 1); + for (j in 1:(i - 1)) { + mat[i, j] = gamma[i - j]; + mat[j, i] = gamma[i - j]; + } + } + return cholesky_decompose(mat ./ (1 - ar^2)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_cholesky_cor_cosy.stan r-cran-brms-2.17.0/inst/chunks/fun_cholesky_cor_cosy.stan --- r-cran-brms-2.16.3/inst/chunks/fun_cholesky_cor_cosy.stan 2020-02-27 16:10:02.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_cholesky_cor_cosy.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,18 +1,18 @@ - /* compute the cholesky factor of a compound symmetry correlation matrix - * Args: - * cosy: compound symmetry correlation - * nrows: number of rows of the covariance matrix - * Returns: - * A nrows x nrows covariance matrix - */ - matrix cholesky_cor_cosy(real cosy, int nrows) { - matrix[nrows, nrows] mat; - mat = diag_matrix(rep_vector(1, nrows)); - for (i in 2:nrows) { - for (j in 1:(i - 1)) { - mat[i, j] = cosy; - mat[j, i] = mat[i, j]; - } - } - return cholesky_decompose(mat); - } + /* compute the cholesky factor of a compound symmetry correlation matrix + * Args: + * cosy: compound symmetry correlation + * nrows: number of rows of the covariance matrix + * Returns: + * A nrows x nrows covariance matrix + */ + matrix cholesky_cor_cosy(real cosy, int nrows) { + matrix[nrows, nrows] mat; + mat = diag_matrix(rep_vector(1, nrows)); + for (i in 2:nrows) { + for (j in 1:(i - 1)) { + mat[i, j] = cosy; + mat[j, i] = mat[i, j]; + } + } + return cholesky_decompose(mat); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_cholesky_cor_ma1.stan r-cran-brms-2.17.0/inst/chunks/fun_cholesky_cor_ma1.stan --- r-cran-brms-2.16.3/inst/chunks/fun_cholesky_cor_ma1.stan 2020-02-27 16:10:02.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_cholesky_cor_ma1.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,20 +1,20 @@ - /* compute the cholesky factor of a MA1 correlation matrix - * Args: - * ma: MA1 autocorrelation - * nrows: number of rows of the covariance matrix - * Returns: - * A nrows x nrows MA1 covariance matrix - */ - matrix cholesky_cor_ma1(real ma, int nrows) { - matrix[nrows, nrows] mat; - mat = diag_matrix(rep_vector(1 + ma^2, nrows)); - if (nrows > 1) { - mat[1, 2] = ma; - for (i in 2:(nrows - 1)) { - mat[i, i - 1] = ma; - mat[i, i + 1] = ma; - } - mat[nrows, nrows - 1] = ma; - } - return cholesky_decompose(mat); - } + /* compute the cholesky factor of a MA1 correlation matrix + * Args: + * ma: MA1 autocorrelation + * nrows: number of rows of the covariance matrix + * Returns: + * A nrows x nrows MA1 covariance matrix + */ + matrix cholesky_cor_ma1(real ma, int nrows) { + matrix[nrows, nrows] mat; + mat = diag_matrix(rep_vector(1 + ma^2, nrows)); + if (nrows > 1) { + mat[1, 2] = ma; + for (i in 2:(nrows - 1)) { + mat[i, i - 1] = ma; + mat[i, i + 1] = ma; + } + mat[nrows, nrows - 1] = ma; + } + return cholesky_decompose(mat); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_cloglog.stan r-cran-brms-2.17.0/inst/chunks/fun_cloglog.stan --- r-cran-brms-2.16.3/inst/chunks/fun_cloglog.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_cloglog.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,9 +1,9 @@ - /* compute the cloglog link - * Args: - * p: a scalar in (0, 1) - * Returns: - * a scalar in (-Inf, Inf) - */ - real cloglog(real p) { - return log(-log1m(p)); - } + /* compute the cloglog link + * Args: + * p: a scalar in (0, 1) + * Returns: + * a scalar in (-Inf, Inf) + */ + real cloglog(real p) { + return log(-log1m(p)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_com_poisson.stan r-cran-brms-2.17.0/inst/chunks/fun_com_poisson.stan --- r-cran-brms-2.16.3/inst/chunks/fun_com_poisson.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_com_poisson.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,118 +1,118 @@ - // log approximate normalizing constant of the COM poisson distribuion - // approximation based on doi:10.1007/s10463-017-0629-6 - // Args: see log_Z_com_poisson() - real log_Z_com_poisson_approx(real log_mu, real nu) { - real nu_mu = nu * exp(log_mu); - real nu2 = nu^2; - // first 4 terms of the residual series - real log_sum_resid = log1p( - nu_mu^(-1) * (nu2 - 1) / 24 + - nu_mu^(-2) * (nu2 - 1) / 1152 * (nu2 + 23) + - nu_mu^(-3) * (nu2 - 1) / 414720 * (5 * nu2^2 - 298 * nu2 + 11237) - ); - return nu_mu + log_sum_resid - - ((log(2 * pi()) + log_mu) * (nu - 1) / 2 + log(nu) / 2); - } - // log normalizing constant of the COM Poisson distribution - // implementation inspired by code of Ben Goodrich - // improved following suggestions of Sebastian Weber (#892) - // Args: - // log_mu: log location parameter - // shape: positive shape parameter - real log_Z_com_poisson(real log_mu, real nu) { - real log_Z; - int k = 2; - int M = 10000; - int converged = 0; - int num_terms = 50; - if (nu == 1) { - return exp(log_mu); - } - // nu == 0 or Inf will fail in this parameterization - if (nu <= 0) { - reject("nu must be positive"); - } - if (nu == positive_infinity()) { - reject("nu must be finite"); - } - if (log_mu * nu >= log(1.5) && log_mu >= log(1.5)) { - return log_Z_com_poisson_approx(log_mu, nu); - } - // direct computation of the truncated series - // check if the Mth term of the series is small enough - if (nu * (M * log_mu - lgamma(M + 1)) > -36.0) { - reject("nu is too close to zero."); - } - // first 2 terms of the series - log_Z = log1p_exp(nu * log_mu); - while (converged == 0) { - // adding terms in batches simplifies the AD tape - vector[num_terms + 1] log_Z_terms; - int i = 1; - log_Z_terms[1] = log_Z; - while (i <= num_terms) { - log_Z_terms[i + 1] = nu * (k * log_mu - lgamma(k + 1)); - k += 1; - if (log_Z_terms[i + 1] <= -36.0) { - converged = 1; - break; - } - i += 1; - } - log_Z = log_sum_exp(log_Z_terms[1:(i + 1)]); - } - return log_Z; - } - // COM Poisson log-PMF for a single response (log parameterization) - // Args: - // y: the response value - // log_mu: log location parameter - // shape: positive shape parameter - real com_poisson_log_lpmf(int y, real log_mu, real nu) { - if (nu == 1) return poisson_log_lpmf(y | log_mu); - return nu * (y * log_mu - lgamma(y + 1)) - log_Z_com_poisson(log_mu, nu); - } - // COM Poisson log-PMF for a single response - real com_poisson_lpmf(int y, real mu, real nu) { - if (nu == 1) return poisson_lpmf(y | mu); - return com_poisson_log_lpmf(y | log(mu), nu); - } - // COM Poisson log-CDF for a single response - real com_poisson_lcdf(int y, real mu, real nu) { - real log_mu; - real log_Z; // log denominator - vector[y] log_num_terms; // terms of the log numerator - if (nu == 1) { - return poisson_lcdf(y | mu); - } - // nu == 0 or Inf will fail in this parameterization - if (nu <= 0) { - reject("nu must be positive"); - } - if (nu == positive_infinity()) { - reject("nu must be finite"); - } - if (y > 10000) { - reject("cannot handle y > 10000"); - } - log_mu = log(mu); - if (nu * (y * log_mu - lgamma(y + 1)) <= -36.0) { - // y is large enough for the CDF to be very close to 1; - return 0; - } - log_Z = log_Z_com_poisson(log_mu, nu); - if (y == 0) { - return -log_Z; - } - // first 2 terms of the series - log_num_terms[1] = log1p_exp(nu * log_mu); - // remaining terms of the series until y - for (k in 2:y) { - log_num_terms[k] = nu * (k * log_mu - lgamma(k + 1)); - } - return log_sum_exp(log_num_terms) - log_Z; - } - // COM Poisson log-CCDF for a single response - real com_poisson_lccdf(int y, real mu, real nu) { - return log1m_exp(com_poisson_lcdf(y | mu, nu)); - } + // log approximate normalizing constant of the COM poisson distribuion + // approximation based on doi:10.1007/s10463-017-0629-6 + // Args: see log_Z_com_poisson() + real log_Z_com_poisson_approx(real log_mu, real nu) { + real nu_mu = nu * exp(log_mu); + real nu2 = nu^2; + // first 4 terms of the residual series + real log_sum_resid = log1p( + nu_mu^(-1) * (nu2 - 1) / 24 + + nu_mu^(-2) * (nu2 - 1) / 1152 * (nu2 + 23) + + nu_mu^(-3) * (nu2 - 1) / 414720 * (5 * nu2^2 - 298 * nu2 + 11237) + ); + return nu_mu + log_sum_resid - + ((log(2 * pi()) + log_mu) * (nu - 1) / 2 + log(nu) / 2); + } + // log normalizing constant of the COM Poisson distribution + // implementation inspired by code of Ben Goodrich + // improved following suggestions of Sebastian Weber (#892) + // Args: + // log_mu: log location parameter + // shape: positive shape parameter + real log_Z_com_poisson(real log_mu, real nu) { + real log_Z; + int k = 2; + int M = 10000; + int converged = 0; + int num_terms = 50; + if (nu == 1) { + return exp(log_mu); + } + // nu == 0 or Inf will fail in this parameterization + if (nu <= 0) { + reject("nu must be positive"); + } + if (nu == positive_infinity()) { + reject("nu must be finite"); + } + if (log_mu * nu >= log(1.5) && log_mu >= log(1.5)) { + return log_Z_com_poisson_approx(log_mu, nu); + } + // direct computation of the truncated series + // check if the Mth term of the series is small enough + if (nu * (M * log_mu - lgamma(M + 1)) > -36.0) { + reject("nu is too close to zero."); + } + // first 2 terms of the series + log_Z = log1p_exp(nu * log_mu); + while (converged == 0) { + // adding terms in batches simplifies the AD tape + vector[num_terms + 1] log_Z_terms; + int i = 1; + log_Z_terms[1] = log_Z; + while (i <= num_terms) { + log_Z_terms[i + 1] = nu * (k * log_mu - lgamma(k + 1)); + k += 1; + if (log_Z_terms[i + 1] <= -36.0) { + converged = 1; + break; + } + i += 1; + } + log_Z = log_sum_exp(log_Z_terms[1:(i + 1)]); + } + return log_Z; + } + // COM Poisson log-PMF for a single response (log parameterization) + // Args: + // y: the response value + // log_mu: log location parameter + // shape: positive shape parameter + real com_poisson_log_lpmf(int y, real log_mu, real nu) { + if (nu == 1) return poisson_log_lpmf(y | log_mu); + return nu * (y * log_mu - lgamma(y + 1)) - log_Z_com_poisson(log_mu, nu); + } + // COM Poisson log-PMF for a single response + real com_poisson_lpmf(int y, real mu, real nu) { + if (nu == 1) return poisson_lpmf(y | mu); + return com_poisson_log_lpmf(y | log(mu), nu); + } + // COM Poisson log-CDF for a single response + real com_poisson_lcdf(int y, real mu, real nu) { + real log_mu; + real log_Z; // log denominator + vector[y] log_num_terms; // terms of the log numerator + if (nu == 1) { + return poisson_lcdf(y | mu); + } + // nu == 0 or Inf will fail in this parameterization + if (nu <= 0) { + reject("nu must be positive"); + } + if (nu == positive_infinity()) { + reject("nu must be finite"); + } + if (y > 10000) { + reject("cannot handle y > 10000"); + } + log_mu = log(mu); + if (nu * (y * log_mu - lgamma(y + 1)) <= -36.0) { + // y is large enough for the CDF to be very close to 1; + return 0; + } + log_Z = log_Z_com_poisson(log_mu, nu); + if (y == 0) { + return -log_Z; + } + // first 2 terms of the series + log_num_terms[1] = log1p_exp(nu * log_mu); + // remaining terms of the series until y + for (k in 2:y) { + log_num_terms[k] = nu * (k * log_mu - lgamma(k + 1)); + } + return log_sum_exp(log_num_terms) - log_Z; + } + // COM Poisson log-CCDF for a single response + real com_poisson_lccdf(int y, real mu, real nu) { + return log1m_exp(com_poisson_lcdf(y | mu, nu)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_cox.stan r-cran-brms-2.17.0/inst/chunks/fun_cox.stan --- r-cran-brms-2.16.3/inst/chunks/fun_cox.stan 2021-02-10 15:31:40.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_cox.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,37 +1,37 @@ - /* distribution functions of the Cox proportional hazards model - * parameterize hazard(t) = baseline(t) * mu - * so that higher values of 'mu' imply lower survival times - * Args: - * y: the response value; currently ignored as the relevant - * information is passed via 'bhaz' and 'cbhaz' - * mu: positive location parameter - * bhaz: baseline hazard - * cbhaz: cumulative baseline hazard - */ - real cox_lhaz(real y, real mu, real bhaz, real cbhaz) { - return log(bhaz) + log(mu); - } - real cox_lccdf(real y, real mu, real bhaz, real cbhaz) { - // equivalent to the log survival function - return - cbhaz * mu; - } - real cox_lcdf(real y, real mu, real bhaz, real cbhaz) { - return log1m_exp(cox_lccdf(y | mu, bhaz, cbhaz)); - } - real cox_lpdf(real y, real mu, real bhaz, real cbhaz) { - return cox_lhaz(y, mu, bhaz, cbhaz) + cox_lccdf(y | mu, bhaz, cbhaz); - } - // Distribution functions of the Cox model in log parameterization - real cox_log_lhaz(real y, real log_mu, real bhaz, real cbhaz) { - return log(bhaz) + log_mu; - } - real cox_log_lccdf(real y, real log_mu, real bhaz, real cbhaz) { - return - cbhaz * exp(log_mu); - } - real cox_log_lcdf(real y, real log_mu, real bhaz, real cbhaz) { - return log1m_exp(cox_log_lccdf(y | log_mu, bhaz, cbhaz)); - } - real cox_log_lpdf(real y, real log_mu, real bhaz, real cbhaz) { - return cox_log_lhaz(y, log_mu, bhaz, cbhaz) + - cox_log_lccdf(y | log_mu, bhaz, cbhaz); - } + /* distribution functions of the Cox proportional hazards model + * parameterize hazard(t) = baseline(t) * mu + * so that higher values of 'mu' imply lower survival times + * Args: + * y: the response value; currently ignored as the relevant + * information is passed via 'bhaz' and 'cbhaz' + * mu: positive location parameter + * bhaz: baseline hazard + * cbhaz: cumulative baseline hazard + */ + real cox_lhaz(real y, real mu, real bhaz, real cbhaz) { + return log(bhaz) + log(mu); + } + real cox_lccdf(real y, real mu, real bhaz, real cbhaz) { + // equivalent to the log survival function + return - cbhaz * mu; + } + real cox_lcdf(real y, real mu, real bhaz, real cbhaz) { + return log1m_exp(cox_lccdf(y | mu, bhaz, cbhaz)); + } + real cox_lpdf(real y, real mu, real bhaz, real cbhaz) { + return cox_lhaz(y, mu, bhaz, cbhaz) + cox_lccdf(y | mu, bhaz, cbhaz); + } + // Distribution functions of the Cox model in log parameterization + real cox_log_lhaz(real y, real log_mu, real bhaz, real cbhaz) { + return log(bhaz) + log_mu; + } + real cox_log_lccdf(real y, real log_mu, real bhaz, real cbhaz) { + return - cbhaz * exp(log_mu); + } + real cox_log_lcdf(real y, real log_mu, real bhaz, real cbhaz) { + return log1m_exp(cox_log_lccdf(y | log_mu, bhaz, cbhaz)); + } + real cox_log_lpdf(real y, real log_mu, real bhaz, real cbhaz) { + return cox_log_lhaz(y, log_mu, bhaz, cbhaz) + + cox_log_lccdf(y | log_mu, bhaz, cbhaz); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_dirichlet_logit.stan r-cran-brms-2.17.0/inst/chunks/fun_dirichlet_logit.stan --- r-cran-brms-2.16.3/inst/chunks/fun_dirichlet_logit.stan 2020-02-27 16:10:02.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_dirichlet_logit.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,11 +1,11 @@ - /* dirichlet-logit log-PDF - * Args: - * y: vector of real response values - * mu: vector of category logit probabilities - * phi: precision parameter - * Returns: - * a scalar to be added to the log posterior - */ - real dirichlet_logit_lpdf(vector y, vector mu, real phi) { - return dirichlet_lpdf(y | softmax(mu) * phi); - } + /* dirichlet-logit log-PDF + * Args: + * y: vector of real response values + * mu: vector of category logit probabilities + * phi: precision parameter + * Returns: + * a scalar to be added to the log posterior + */ + real dirichlet_logit_lpdf(vector y, vector mu, real phi) { + return dirichlet_lpdf(y | softmax(mu) * phi); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_discrete_weibull.stan r-cran-brms-2.17.0/inst/chunks/fun_discrete_weibull.stan --- r-cran-brms-2.16.3/inst/chunks/fun_discrete_weibull.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_discrete_weibull.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,19 +1,19 @@ - /* discrete Weibull log-PMF for a single response - * Args: - * y: the response value - * mu: location parameter on the unit interval - * shape: positive shape parameter - * Returns: - * a scalar to be added to the log posterior - */ - real discrete_weibull_lpmf(int y, real mu, real shape) { - return log(mu^y^shape - mu^(y+1)^shape); - } - // discrete Weibull log-CDF for a single response - real discrete_weibull_lcdf(int y, real mu, real shape) { - return log1m(mu^(y + 1)^shape); - } - // discrete Weibull log-CCDF for a single response - real discrete_weibull_lccdf(int y, real mu, real shape) { - return lmultiply((y + 1)^shape, mu); - } + /* discrete Weibull log-PMF for a single response + * Args: + * y: the response value + * mu: location parameter on the unit interval + * shape: positive shape parameter + * Returns: + * a scalar to be added to the log posterior + */ + real discrete_weibull_lpmf(int y, real mu, real shape) { + return log(mu^y^shape - mu^(y+1)^shape); + } + // discrete Weibull log-CDF for a single response + real discrete_weibull_lcdf(int y, real mu, real shape) { + return log1m(mu^(y + 1)^shape); + } + // discrete Weibull log-CCDF for a single response + real discrete_weibull_lccdf(int y, real mu, real shape) { + return lmultiply((y + 1)^shape, mu); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_gaussian_process_approx.stan r-cran-brms-2.17.0/inst/chunks/fun_gaussian_process_approx.stan --- r-cran-brms-2.16.3/inst/chunks/fun_gaussian_process_approx.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_gaussian_process_approx.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,31 +1,31 @@ - /* Spectral density function of a Gaussian process - * with squared exponential covariance kernel - * Args: - * x: array of numeric values of dimension NB x D - * sdgp: marginal SD parameter - * lscale: vector of length-scale parameters - * Returns: - * numeric values of the function evaluated at 'x' - */ - vector spd_cov_exp_quad(data vector[] x, real sdgp, vector lscale) { - int NB = dims(x)[1]; - int D = dims(x)[2]; - int Dls = rows(lscale); - vector[NB] out; - if (Dls == 1) { - // one dimensional or isotropic GP - real constant = square(sdgp) * (sqrt(2 * pi()) * lscale[1])^D; - real neg_half_lscale2 = -0.5 * square(lscale[1]); - for (m in 1:NB) { - out[m] = constant * exp(neg_half_lscale2 * dot_self(x[m])); - } - } else { - // multi-dimensional non-isotropic GP - real constant = square(sdgp) * sqrt(2 * pi())^D * prod(lscale); - vector[Dls] neg_half_lscale2 = -0.5 * square(lscale); - for (m in 1:NB) { - out[m] = constant * exp(dot_product(neg_half_lscale2, square(x[m]))); - } - } - return out; - } + /* Spectral density function of a Gaussian process + * with squared exponential covariance kernel + * Args: + * x: array of numeric values of dimension NB x D + * sdgp: marginal SD parameter + * lscale: vector of length-scale parameters + * Returns: + * numeric values of the function evaluated at 'x' + */ + vector spd_cov_exp_quad(data vector[] x, real sdgp, vector lscale) { + int NB = dims(x)[1]; + int D = dims(x)[2]; + int Dls = rows(lscale); + vector[NB] out; + if (Dls == 1) { + // one dimensional or isotropic GP + real constant = square(sdgp) * (sqrt(2 * pi()) * lscale[1])^D; + real neg_half_lscale2 = -0.5 * square(lscale[1]); + for (m in 1:NB) { + out[m] = constant * exp(neg_half_lscale2 * dot_self(x[m])); + } + } else { + // multi-dimensional non-isotropic GP + real constant = square(sdgp) * sqrt(2 * pi())^D * prod(lscale); + vector[Dls] neg_half_lscale2 = -0.5 * square(lscale); + for (m in 1:NB) { + out[m] = constant * exp(dot_product(neg_half_lscale2, square(x[m]))); + } + } + return out; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_gaussian_process.stan r-cran-brms-2.17.0/inst/chunks/fun_gaussian_process.stan --- r-cran-brms-2.16.3/inst/chunks/fun_gaussian_process.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_gaussian_process.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,29 +1,29 @@ - /* compute a latent Gaussian process - * Args: - * x: array of continuous predictor values - * sdgp: marginal SD parameter - * lscale: length-scale parameter - * zgp: vector of independent standard normal variables - * Returns: - * a vector to be added to the linear predictor - */ - vector gp(data vector[] x, real sdgp, vector lscale, vector zgp) { - int Dls = rows(lscale); - int N = size(x); - matrix[N, N] cov; - if (Dls == 1) { - // one dimensional or isotropic GP - cov = gp_exp_quad_cov(x, sdgp, lscale[1]); - } else { - // multi-dimensional non-isotropic GP - cov = gp_exp_quad_cov(x[, 1], sdgp, lscale[1]); - for (d in 2:Dls) { - cov = cov .* gp_exp_quad_cov(x[, d], 1, lscale[d]); - } - } - for (n in 1:N) { - // deal with numerical non-positive-definiteness - cov[n, n] += 1e-12; - } - return cholesky_decompose(cov) * zgp; - } + /* compute a latent Gaussian process + * Args: + * x: array of continuous predictor values + * sdgp: marginal SD parameter + * lscale: length-scale parameter + * zgp: vector of independent standard normal variables + * Returns: + * a vector to be added to the linear predictor + */ + vector gp(data vector[] x, real sdgp, vector lscale, vector zgp) { + int Dls = rows(lscale); + int N = size(x); + matrix[N, N] cov; + if (Dls == 1) { + // one dimensional or isotropic GP + cov = gp_exp_quad_cov(x, sdgp, lscale[1]); + } else { + // multi-dimensional non-isotropic GP + cov = gp_exp_quad_cov(x[, 1], sdgp, lscale[1]); + for (d in 2:Dls) { + cov = cov .* gp_exp_quad_cov(x[, d], 1, lscale[d]); + } + } + for (n in 1:N) { + // deal with numerical non-positive-definiteness + cov[n, n] += 1e-12; + } + return cholesky_decompose(cov) * zgp; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_gen_extreme_value.stan r-cran-brms-2.17.0/inst/chunks/fun_gen_extreme_value.stan --- r-cran-brms-2.16.3/inst/chunks/fun_gen_extreme_value.stan 2018-03-22 07:52:16.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_gen_extreme_value.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,48 +1,48 @@ - /* generalized extreme value log-PDF for a single response - * Args: - * y: the response value - * mu: location parameter - * sigma: scale parameter - * xi: shape parameter - * Returns: - * a scalar to be added to the log posterior - */ - real gen_extreme_value_lpdf(real y, real mu, real sigma, real xi) { - real x = (y - mu) / sigma; - if (xi == 0) { - return - log(sigma) - x - exp(-x); - } else { - real t = 1 + xi * x; - real inv_xi = 1 / xi; - return - log(sigma) - (1 + inv_xi) * log(t) - pow(t, -inv_xi); - } - } - /* generalized extreme value log-CDF for a single response - * Args: - * y: a quantile - * mu: location parameter - * sigma: scale parameter - * xi: shape parameter - * Returns: - * log(P(Y <= y)) - */ - real gen_extreme_value_lcdf(real y, real mu, real sigma, real xi) { - real x = (y - mu) / sigma; - if (xi == 0) { - return - exp(-x); - } else { - return - pow(1 + xi * x, - 1 / xi); - } - } - /* generalized extreme value log-CCDF for a single response - * Args: - * y: a quantile - * mu: location parameter - * sigma: scale parameter - * xi: shape parameter - * Returns: - * log(P(Y > y)) - */ - real gen_extreme_value_lccdf(real y, real mu, real sigma, real xi) { - return log1m_exp(gen_extreme_value_lcdf(y | mu, sigma, xi)); - } + /* generalized extreme value log-PDF for a single response + * Args: + * y: the response value + * mu: location parameter + * sigma: scale parameter + * xi: shape parameter + * Returns: + * a scalar to be added to the log posterior + */ + real gen_extreme_value_lpdf(real y, real mu, real sigma, real xi) { + real x = (y - mu) / sigma; + if (xi == 0) { + return - log(sigma) - x - exp(-x); + } else { + real t = 1 + xi * x; + real inv_xi = 1 / xi; + return - log(sigma) - (1 + inv_xi) * log(t) - pow(t, -inv_xi); + } + } + /* generalized extreme value log-CDF for a single response + * Args: + * y: a quantile + * mu: location parameter + * sigma: scale parameter + * xi: shape parameter + * Returns: + * log(P(Y <= y)) + */ + real gen_extreme_value_lcdf(real y, real mu, real sigma, real xi) { + real x = (y - mu) / sigma; + if (xi == 0) { + return - exp(-x); + } else { + return - pow(1 + xi * x, - 1 / xi); + } + } + /* generalized extreme value log-CCDF for a single response + * Args: + * y: a quantile + * mu: location parameter + * sigma: scale parameter + * xi: shape parameter + * Returns: + * log(P(Y > y)) + */ + real gen_extreme_value_lccdf(real y, real mu, real sigma, real xi) { + return log1m_exp(gen_extreme_value_lcdf(y | mu, sigma, xi)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_horseshoe.stan r-cran-brms-2.17.0/inst/chunks/fun_horseshoe.stan --- r-cran-brms-2.16.3/inst/chunks/fun_horseshoe.stan 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_horseshoe.stan 2021-12-20 13:50:54.000000000 +0000 @@ -1,16 +1,16 @@ - /* Efficient computation of the horseshoe prior - * see Appendix C.1 in https://projecteuclid.org/euclid.ejs/1513306866 - * Args: - * z: standardized population-level coefficients - * lambda: local shrinkage parameters - * tau: global shrinkage parameter - * c2: slap regularization parameter - * Returns: - * population-level coefficients following the horseshoe prior - */ - vector horseshoe(vector z, vector lambda, real tau, real c2) { - int K = rows(z); - vector[K] lambda2 = square(lambda); - vector[K] lambda_tilde = sqrt(c2 * lambda2 ./ (c2 + tau^2 * lambda2)); - return z .* lambda_tilde * tau; - } + /* Efficient computation of the horseshoe prior + * see Appendix C.1 in https://projecteuclid.org/euclid.ejs/1513306866 + * Args: + * z: standardized population-level coefficients + * lambda: local shrinkage parameters + * tau: global shrinkage parameter + * c2: slap regularization parameter + * Returns: + * population-level coefficients following the horseshoe prior + */ + vector horseshoe(vector z, vector lambda, real tau, real c2) { + int K = rows(z); + vector[K] lambda2 = square(lambda); + vector[K] lambda_tilde = sqrt(c2 * lambda2 ./ (c2 + tau^2 * lambda2)); + return z .* lambda_tilde * tau; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_hurdle_gamma.stan r-cran-brms-2.17.0/inst/chunks/fun_hurdle_gamma.stan --- r-cran-brms-2.16.3/inst/chunks/fun_hurdle_gamma.stan 2018-05-17 23:12:30.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_hurdle_gamma.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,43 +1,43 @@ - /* hurdle gamma log-PDF of a single response - * Args: - * y: the response value - * alpha: shape parameter of the gamma distribution - * beta: rate parameter of the gamma distribution - * hu: hurdle probability - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_gamma_lpdf(real y, real alpha, real beta, real hu) { - if (y == 0) { - return bernoulli_lpmf(1 | hu); - } else { - return bernoulli_lpmf(0 | hu) + - gamma_lpdf(y | alpha, beta); - } - } - /* hurdle gamma log-PDF of a single response - * logit parameterization of the hurdle part - * Args: - * y: the response value - * alpha: shape parameter of the gamma distribution - * beta: rate parameter of the gamma distribution - * hu: linear predictor for the hurdle part - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_gamma_logit_lpdf(real y, real alpha, real beta, real hu) { - if (y == 0) { - return bernoulli_logit_lpmf(1 | hu); - } else { - return bernoulli_logit_lpmf(0 | hu) + - gamma_lpdf(y | alpha, beta); - } - } - // hurdle gamma log-CCDF and log-CDF functions - real hurdle_gamma_lccdf(real y, real alpha, real beta, real hu) { - return bernoulli_lpmf(0 | hu) + gamma_lccdf(y | alpha, beta); - } - real hurdle_gamma_lcdf(real y, real alpha, real beta, real hu) { - return log1m_exp(hurdle_gamma_lccdf(y | alpha, beta, hu)); - } - + /* hurdle gamma log-PDF of a single response + * Args: + * y: the response value + * alpha: shape parameter of the gamma distribution + * beta: rate parameter of the gamma distribution + * hu: hurdle probability + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_gamma_lpdf(real y, real alpha, real beta, real hu) { + if (y == 0) { + return bernoulli_lpmf(1 | hu); + } else { + return bernoulli_lpmf(0 | hu) + + gamma_lpdf(y | alpha, beta); + } + } + /* hurdle gamma log-PDF of a single response + * logit parameterization of the hurdle part + * Args: + * y: the response value + * alpha: shape parameter of the gamma distribution + * beta: rate parameter of the gamma distribution + * hu: linear predictor for the hurdle part + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_gamma_logit_lpdf(real y, real alpha, real beta, real hu) { + if (y == 0) { + return bernoulli_logit_lpmf(1 | hu); + } else { + return bernoulli_logit_lpmf(0 | hu) + + gamma_lpdf(y | alpha, beta); + } + } + // hurdle gamma log-CCDF and log-CDF functions + real hurdle_gamma_lccdf(real y, real alpha, real beta, real hu) { + return bernoulli_lpmf(0 | hu) + gamma_lccdf(y | alpha, beta); + } + real hurdle_gamma_lcdf(real y, real alpha, real beta, real hu) { + return log1m_exp(hurdle_gamma_lccdf(y | alpha, beta, hu)); + } + diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_hurdle_lognormal.stan r-cran-brms-2.17.0/inst/chunks/fun_hurdle_lognormal.stan --- r-cran-brms-2.16.3/inst/chunks/fun_hurdle_lognormal.stan 2018-05-17 23:12:40.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_hurdle_lognormal.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,42 +1,42 @@ - /* hurdle lognormal log-PDF of a single response - * Args: - * y: the response value - * mu: mean parameter of the lognormal distribution - * sigma: sd parameter of the lognormal distribution - * hu: hurdle probability - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_lognormal_lpdf(real y, real mu, real sigma, real hu) { - if (y == 0) { - return bernoulli_lpmf(1 | hu); - } else { - return bernoulli_lpmf(0 | hu) + - lognormal_lpdf(y | mu, sigma); - } - } - /* hurdle lognormal log-PDF of a single response - * logit parameterization of the hurdle part - * Args: - * y: the response value - * mu: mean parameter of the lognormal distribution - * sigma: sd parameter of the lognormal distribution - * hu: linear predictor for the hurdle part - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_lognormal_logit_lpdf(real y, real mu, real sigma, real hu) { - if (y == 0) { - return bernoulli_logit_lpmf(1 | hu); - } else { - return bernoulli_logit_lpmf(0 | hu) + - lognormal_lpdf(y | mu, sigma); - } - } - // hurdle lognormal log-CCDF and log-CDF functions - real hurdle_lognormal_lccdf(real y, real mu, real sigma, real hu) { - return bernoulli_lpmf(0 | hu) + lognormal_lccdf(y | mu, sigma); - } - real hurdle_lognormal_lcdf(real y, real mu, real sigma, real hu) { - return log1m_exp(hurdle_lognormal_lccdf(y | mu, sigma, hu)); - } + /* hurdle lognormal log-PDF of a single response + * Args: + * y: the response value + * mu: mean parameter of the lognormal distribution + * sigma: sd parameter of the lognormal distribution + * hu: hurdle probability + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_lognormal_lpdf(real y, real mu, real sigma, real hu) { + if (y == 0) { + return bernoulli_lpmf(1 | hu); + } else { + return bernoulli_lpmf(0 | hu) + + lognormal_lpdf(y | mu, sigma); + } + } + /* hurdle lognormal log-PDF of a single response + * logit parameterization of the hurdle part + * Args: + * y: the response value + * mu: mean parameter of the lognormal distribution + * sigma: sd parameter of the lognormal distribution + * hu: linear predictor for the hurdle part + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_lognormal_logit_lpdf(real y, real mu, real sigma, real hu) { + if (y == 0) { + return bernoulli_logit_lpmf(1 | hu); + } else { + return bernoulli_logit_lpmf(0 | hu) + + lognormal_lpdf(y | mu, sigma); + } + } + // hurdle lognormal log-CCDF and log-CDF functions + real hurdle_lognormal_lccdf(real y, real mu, real sigma, real hu) { + return bernoulli_lpmf(0 | hu) + lognormal_lccdf(y | mu, sigma); + } + real hurdle_lognormal_lcdf(real y, real mu, real sigma, real hu) { + return log1m_exp(hurdle_lognormal_lccdf(y | mu, sigma, hu)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_hurdle_negbinomial.stan r-cran-brms-2.17.0/inst/chunks/fun_hurdle_negbinomial.stan --- r-cran-brms-2.16.3/inst/chunks/fun_hurdle_negbinomial.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_hurdle_negbinomial.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,84 +1,84 @@ - /* hurdle negative binomial log-PDF of a single response - * Args: - * y: the response value - * mu: mean parameter of negative binomial distribution - * phi: shape parameter of negative binomial distribution - * hu: hurdle probability - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_neg_binomial_lpmf(int y, real mu, real phi, real hu) { - if (y == 0) { - return bernoulli_lpmf(1 | hu); - } else { - return bernoulli_lpmf(0 | hu) + - neg_binomial_2_lpmf(y | mu, phi) - - log1m((phi / (mu + phi))^phi); - } - } - /* hurdle negative binomial log-PDF of a single response - * logit parameterization for the hurdle part - * Args: - * y: the response value - * mu: mean parameter of negative binomial distribution - * phi: phi parameter of negative binomial distribution - * hu: linear predictor of hurdle part - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_neg_binomial_logit_lpmf(int y, real mu, real phi, real hu) { - if (y == 0) { - return bernoulli_logit_lpmf(1 | hu); - } else { - return bernoulli_logit_lpmf(0 | hu) + - neg_binomial_2_lpmf(y | mu, phi) - - log1m((phi / (mu + phi))^phi); - } - } - /* hurdle negative binomial log-PDF of a single response - * log parameterization for the negative binomial part - * Args: - * y: the response value - * eta: linear predictor for negative binomial distribution - * phi phi parameter of negative binomial distribution - * hu: hurdle probability - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_neg_binomial_log_lpmf(int y, real eta, real phi, real hu) { - if (y == 0) { - return bernoulli_lpmf(1 | hu); - } else { - return bernoulli_lpmf(0 | hu) + - neg_binomial_2_log_lpmf(y | eta, phi) - - log1m((phi / (exp(eta) + phi))^phi); - } - } - /* hurdle negative binomial log-PDF of a single response - * log parameterization for the negative binomial part - * logit parameterization for the hurdle part - * Args: - * y: the response value - * eta: linear predictor for negative binomial distribution - * phi: phi parameter of negative binomial distribution - * hu: linear predictor of hurdle part - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_neg_binomial_log_logit_lpmf(int y, real eta, real phi, real hu) { - if (y == 0) { - return bernoulli_logit_lpmf(1 | hu); - } else { - return bernoulli_logit_lpmf(0 | hu) + - neg_binomial_2_log_lpmf(y | eta, phi) - - log1m((phi / (exp(eta) + phi))^phi); - } - } - // hurdle negative binomial log-CCDF and log-CDF functions - real hurdle_neg_binomial_lccdf(int y, real mu, real phi, real hu) { - return bernoulli_lpmf(0 | hu) + neg_binomial_2_lccdf(y | mu, phi) - - log1m((phi / (mu + phi))^phi); - } - real hurdle_neg_binomial_lcdf(int y, real mu, real phi, real hu) { - return log1m_exp(hurdle_neg_binomial_lccdf(y | mu, phi, hu)); - } + /* hurdle negative binomial log-PDF of a single response + * Args: + * y: the response value + * mu: mean parameter of negative binomial distribution + * phi: shape parameter of negative binomial distribution + * hu: hurdle probability + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_neg_binomial_lpmf(int y, real mu, real phi, real hu) { + if (y == 0) { + return bernoulli_lpmf(1 | hu); + } else { + return bernoulli_lpmf(0 | hu) + + neg_binomial_2_lpmf(y | mu, phi) - + log1m((phi / (mu + phi))^phi); + } + } + /* hurdle negative binomial log-PDF of a single response + * logit parameterization for the hurdle part + * Args: + * y: the response value + * mu: mean parameter of negative binomial distribution + * phi: phi parameter of negative binomial distribution + * hu: linear predictor of hurdle part + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_neg_binomial_logit_lpmf(int y, real mu, real phi, real hu) { + if (y == 0) { + return bernoulli_logit_lpmf(1 | hu); + } else { + return bernoulli_logit_lpmf(0 | hu) + + neg_binomial_2_lpmf(y | mu, phi) - + log1m((phi / (mu + phi))^phi); + } + } + /* hurdle negative binomial log-PDF of a single response + * log parameterization for the negative binomial part + * Args: + * y: the response value + * eta: linear predictor for negative binomial distribution + * phi phi parameter of negative binomial distribution + * hu: hurdle probability + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_neg_binomial_log_lpmf(int y, real eta, real phi, real hu) { + if (y == 0) { + return bernoulli_lpmf(1 | hu); + } else { + return bernoulli_lpmf(0 | hu) + + neg_binomial_2_log_lpmf(y | eta, phi) - + log1m((phi / (exp(eta) + phi))^phi); + } + } + /* hurdle negative binomial log-PDF of a single response + * log parameterization for the negative binomial part + * logit parameterization for the hurdle part + * Args: + * y: the response value + * eta: linear predictor for negative binomial distribution + * phi: phi parameter of negative binomial distribution + * hu: linear predictor of hurdle part + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_neg_binomial_log_logit_lpmf(int y, real eta, real phi, real hu) { + if (y == 0) { + return bernoulli_logit_lpmf(1 | hu); + } else { + return bernoulli_logit_lpmf(0 | hu) + + neg_binomial_2_log_lpmf(y | eta, phi) - + log1m((phi / (exp(eta) + phi))^phi); + } + } + // hurdle negative binomial log-CCDF and log-CDF functions + real hurdle_neg_binomial_lccdf(int y, real mu, real phi, real hu) { + return bernoulli_lpmf(0 | hu) + neg_binomial_2_lccdf(y | mu, phi) - + log1m((phi / (mu + phi))^phi); + } + real hurdle_neg_binomial_lcdf(int y, real mu, real phi, real hu) { + return log1m_exp(hurdle_neg_binomial_lccdf(y | mu, phi, hu)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_hurdle_poisson.stan r-cran-brms-2.17.0/inst/chunks/fun_hurdle_poisson.stan --- r-cran-brms-2.16.3/inst/chunks/fun_hurdle_poisson.stan 2018-05-17 23:02:34.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_hurdle_poisson.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,80 +1,80 @@ - /* hurdle poisson log-PDF of a single response - * Args: - * y: the response value - * lambda: mean parameter of the poisson distribution - * hu: hurdle probability - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_poisson_lpmf(int y, real lambda, real hu) { - if (y == 0) { - return bernoulli_lpmf(1 | hu); - } else { - return bernoulli_lpmf(0 | hu) + - poisson_lpmf(y | lambda) - - log1m_exp(-lambda); - } - } - /* hurdle poisson log-PDF of a single response - * logit parameterization of the hurdle part - * Args: - * y: the response value - * lambda: mean parameter of the poisson distribution - * hu: linear predictor for hurdle part - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_poisson_logit_lpmf(int y, real lambda, real hu) { - if (y == 0) { - return bernoulli_logit_lpmf(1 | hu); - } else { - return bernoulli_logit_lpmf(0 | hu) + - poisson_lpmf(y | lambda) - - log1m_exp(-lambda); - } - } - /* hurdle poisson log-PDF of a single response - * log parameterization for the poisson part - * Args: - * y: the response value - * eta: linear predictor for poisson part - * hu: hurdle probability - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_poisson_log_lpmf(int y, real eta, real hu) { - if (y == 0) { - return bernoulli_lpmf(1 | hu); - } else { - return bernoulli_lpmf(0 | hu) + - poisson_log_lpmf(y | eta) - - log1m_exp(-exp(eta)); - } - } - /* hurdle poisson log-PDF of a single response - * log parameterization for the poisson part - * logit parameterization of the hurdle part - * Args: - * y: the response value - * eta: linear predictor for poisson part - * hu: linear predictor for hurdle part - * Returns: - * a scalar to be added to the log posterior - */ - real hurdle_poisson_log_logit_lpmf(int y, real eta, real hu) { - if (y == 0) { - return bernoulli_logit_lpmf(1 | hu); - } else { - return bernoulli_logit_lpmf(0 | hu) + - poisson_log_lpmf(y | eta) - - log1m_exp(-exp(eta)); - } - } - // hurdle poisson log-CCDF and log-CDF functions - real hurdle_poisson_lccdf(int y, real lambda, real hu) { - return bernoulli_lpmf(0 | hu) + poisson_lccdf(y | lambda) - - log1m_exp(-lambda); - } - real hurdle_poisson_lcdf(int y, real lambda, real hu) { - return log1m_exp(hurdle_poisson_lccdf(y | lambda, hu)); - } + /* hurdle poisson log-PDF of a single response + * Args: + * y: the response value + * lambda: mean parameter of the poisson distribution + * hu: hurdle probability + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_poisson_lpmf(int y, real lambda, real hu) { + if (y == 0) { + return bernoulli_lpmf(1 | hu); + } else { + return bernoulli_lpmf(0 | hu) + + poisson_lpmf(y | lambda) - + log1m_exp(-lambda); + } + } + /* hurdle poisson log-PDF of a single response + * logit parameterization of the hurdle part + * Args: + * y: the response value + * lambda: mean parameter of the poisson distribution + * hu: linear predictor for hurdle part + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_poisson_logit_lpmf(int y, real lambda, real hu) { + if (y == 0) { + return bernoulli_logit_lpmf(1 | hu); + } else { + return bernoulli_logit_lpmf(0 | hu) + + poisson_lpmf(y | lambda) - + log1m_exp(-lambda); + } + } + /* hurdle poisson log-PDF of a single response + * log parameterization for the poisson part + * Args: + * y: the response value + * eta: linear predictor for poisson part + * hu: hurdle probability + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_poisson_log_lpmf(int y, real eta, real hu) { + if (y == 0) { + return bernoulli_lpmf(1 | hu); + } else { + return bernoulli_lpmf(0 | hu) + + poisson_log_lpmf(y | eta) - + log1m_exp(-exp(eta)); + } + } + /* hurdle poisson log-PDF of a single response + * log parameterization for the poisson part + * logit parameterization of the hurdle part + * Args: + * y: the response value + * eta: linear predictor for poisson part + * hu: linear predictor for hurdle part + * Returns: + * a scalar to be added to the log posterior + */ + real hurdle_poisson_log_logit_lpmf(int y, real eta, real hu) { + if (y == 0) { + return bernoulli_logit_lpmf(1 | hu); + } else { + return bernoulli_logit_lpmf(0 | hu) + + poisson_log_lpmf(y | eta) - + log1m_exp(-exp(eta)); + } + } + // hurdle poisson log-CCDF and log-CDF functions + real hurdle_poisson_lccdf(int y, real lambda, real hu) { + return bernoulli_lpmf(0 | hu) + poisson_lccdf(y | lambda) - + log1m_exp(-lambda); + } + real hurdle_poisson_lcdf(int y, real lambda, real hu) { + return log1m_exp(hurdle_poisson_lccdf(y | lambda, hu)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_inv_gaussian.stan r-cran-brms-2.17.0/inst/chunks/fun_inv_gaussian.stan --- r-cran-brms-2.16.3/inst/chunks/fun_inv_gaussian.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_inv_gaussian.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,50 +1,50 @@ - /* inverse Gaussian log-PDF for a single response - * Args: - * y: the response value - * mu: positive mean parameter - * shape: positive shape parameter - * Returns: - * a scalar to be added to the log posterior - */ - real inv_gaussian_lpdf(real y, real mu, real shape) { - return 0.5 * log(shape / (2 * pi())) - - 1.5 * log(y) - - 0.5 * shape * square((y - mu) / (mu * sqrt(y))); - } - /* vectorized inverse Gaussian log-PDF - * Args: - * y: response vector - * mu: positive mean parameter vector - * shape: positive shape parameter - * Returns: - * a scalar to be added to the log posterior - */ - real inv_gaussian_vector_lpdf(vector y, vector mu, real shape) { - return 0.5 * rows(y) * log(shape / (2 * pi())) - - 1.5 * sum(log(y)) - - 0.5 * shape * dot_self((y - mu) ./ (mu .* sqrt(y))); - } - /* inverse Gaussian log-CDF for a single quantile - * Args: - * y: a quantile - * mu: positive mean parameter - * shape: positive shape parameter - * Returns: - * log(P(Y <= y)) - */ - real inv_gaussian_lcdf(real y, real mu, real shape) { - return log(Phi(sqrt(shape) / sqrt(y) * (y / mu - 1)) + - exp(2 * shape / mu) * Phi(-sqrt(shape) / sqrt(y) * (y / mu + 1))); - } - /* inverse Gaussian log-CCDF for a single quantile - * Args: - * y: a quantile - * mu: positive mean parameter - * shape: positive shape parameter - * Returns: - * log(P(Y > y)) - */ - real inv_gaussian_lccdf(real y, real mu, real shape) { - return log1m(Phi(sqrt(shape) / sqrt(y) * (y / mu - 1)) - - exp(2 * shape / mu) * Phi(-sqrt(shape) / sqrt(y) * (y / mu + 1))); - } + /* inverse Gaussian log-PDF for a single response + * Args: + * y: the response value + * mu: positive mean parameter + * shape: positive shape parameter + * Returns: + * a scalar to be added to the log posterior + */ + real inv_gaussian_lpdf(real y, real mu, real shape) { + return 0.5 * log(shape / (2 * pi())) - + 1.5 * log(y) - + 0.5 * shape * square((y - mu) / (mu * sqrt(y))); + } + /* vectorized inverse Gaussian log-PDF + * Args: + * y: response vector + * mu: positive mean parameter vector + * shape: positive shape parameter + * Returns: + * a scalar to be added to the log posterior + */ + real inv_gaussian_vector_lpdf(vector y, vector mu, real shape) { + return 0.5 * rows(y) * log(shape / (2 * pi())) - + 1.5 * sum(log(y)) - + 0.5 * shape * dot_self((y - mu) ./ (mu .* sqrt(y))); + } + /* inverse Gaussian log-CDF for a single quantile + * Args: + * y: a quantile + * mu: positive mean parameter + * shape: positive shape parameter + * Returns: + * log(P(Y <= y)) + */ + real inv_gaussian_lcdf(real y, real mu, real shape) { + return log(Phi(sqrt(shape) / sqrt(y) * (y / mu - 1)) + + exp(2 * shape / mu) * Phi(-sqrt(shape) / sqrt(y) * (y / mu + 1))); + } + /* inverse Gaussian log-CCDF for a single quantile + * Args: + * y: a quantile + * mu: positive mean parameter + * shape: positive shape parameter + * Returns: + * log(P(Y > y)) + */ + real inv_gaussian_lccdf(real y, real mu, real shape) { + return log1m(Phi(sqrt(shape) / sqrt(y) * (y / mu - 1)) - + exp(2 * shape / mu) * Phi(-sqrt(shape) / sqrt(y) * (y / mu + 1))); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_logistic_normal.stan r-cran-brms-2.17.0/inst/chunks/fun_logistic_normal.stan --- r-cran-brms-2.16.3/inst/chunks/fun_logistic_normal.stan 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_logistic_normal.stan 2022-03-13 16:10:29.000000000 +0000 @@ -0,0 +1,35 @@ + /* multi-logit transform + * Args: + * y: simplex vector of length D + * ref: a single integer in 1:D indicating the reference category + * Returns: + * an unbounded real vector of length D - 1 + */ + vector multi_logit(vector y, int ref) { + vector[rows(y) - 1] x; + for (i in 1:(ref - 1)) { + x[i] = log(y[i]) - log(y[ref]); + } + for (i in (ref+1):rows(y)) { + x[i - 1] = log(y[i]) - log(y[ref]); + } + return(x); + } + /* logistic-normal log-PDF + * Args: + * y: simplex vector of response values (length D) + * mu: vector of means on the logit scale (length D-1) + * sigma: vector for standard deviations on the logit scale (length D-1) + * Lcor: Cholesky correlation matrix on the logit scale (dim D-1) + * ref: a single integer in 1:D indicating the reference category + * Returns: + * a scalar to be added to the log posterior + */ + real logistic_normal_cholesky_cor_lpdf(vector y, vector mu, vector sigma, + matrix Lcor, int ref) { + int D = rows(y); + vector[D - 1] x = multi_logit(y, ref); + matrix[D - 1, D - 1] Lcov = diag_pre_multiply(sigma, Lcor); + // multi-normal plus Jacobian adjustment of multivariate logit transform + return multi_normal_cholesky_lpdf(x | mu, Lcov) - sum(log(y)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_logm1.stan r-cran-brms-2.17.0/inst/chunks/fun_logm1.stan --- r-cran-brms-2.16.3/inst/chunks/fun_logm1.stan 2017-11-13 08:30:32.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_logm1.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,18 +1,18 @@ - /* compute the logm1 link - * Args: - * p: a positive scalar - * Returns: - * a scalar in (-Inf, Inf) - */ - real logm1(real y) { - return log(y - 1); - } - /* compute the inverse of the logm1 link - * Args: - * y: a scalar in (-Inf, Inf) - * Returns: - * a positive scalar - */ - real expp1(real y) { - return exp(y) + 1; - } + /* compute the logm1 link + * Args: + * p: a positive scalar + * Returns: + * a scalar in (-Inf, Inf) + */ + real logm1(real y) { + return log(y - 1); + } + /* compute the inverse of the logm1 link + * Args: + * y: a scalar in (-Inf, Inf) + * Returns: + * a positive scalar + */ + real expp1(real y) { + return exp(y) + 1; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_monotonic.stan r-cran-brms-2.17.0/inst/chunks/fun_monotonic.stan --- r-cran-brms-2.16.3/inst/chunks/fun_monotonic.stan 2020-02-27 16:10:02.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_monotonic.stan 2021-12-20 13:50:54.000000000 +0000 @@ -1,14 +1,14 @@ - /* compute monotonic effects - * Args: - * scale: a simplex parameter - * i: index to sum over the simplex - * Returns: - * a scalar between 0 and 1 - */ - real mo(vector scale, int i) { - if (i == 0) { - return 0; - } else { - return rows(scale) * sum(scale[1:i]); - } - } + /* compute monotonic effects + * Args: + * scale: a simplex parameter + * i: index to sum over the simplex + * Returns: + * a scalar between 0 and 1 + */ + real mo(vector scale, int i) { + if (i == 0) { + return 0; + } else { + return rows(scale) * sum(scale[1:i]); + } + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_multinomial_logit.stan r-cran-brms-2.17.0/inst/chunks/fun_multinomial_logit.stan --- r-cran-brms-2.16.3/inst/chunks/fun_multinomial_logit.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_multinomial_logit.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,10 +1,10 @@ - /* multinomial-logit log-PMF - * Args: - * y: array of integer response values - * mu: vector of category logit probabilities - * Returns: - * a scalar to be added to the log posterior - */ - real multinomial_logit2_lpmf(int[] y, vector mu) { - return multinomial_lpmf(y | softmax(mu)); - } + /* multinomial-logit log-PMF + * Args: + * y: array of integer response values + * mu: vector of category logit probabilities + * Returns: + * a scalar to be added to the log posterior + */ + real multinomial_logit2_lpmf(int[] y, vector mu) { + return multinomial_lpmf(y | softmax(mu)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_normal_errorsar.stan r-cran-brms-2.17.0/inst/chunks/fun_normal_errorsar.stan --- r-cran-brms-2.16.3/inst/chunks/fun_normal_errorsar.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_normal_errorsar.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,23 +1,23 @@ - /* normal log-pdf for spatially lagged residuals - * Args: - * y: the response vector - * mu: mean parameter vector - * sigma: residual standard deviation - * rho: positive autoregressive parameter - * W: spatial weight matrix - * eigenW: precomputed eigenvalues of W - * Returns: - * a scalar to be added to the log posterior - */ - real normal_errorsar_lpdf(vector y, vector mu, real sigma, - real rho, data matrix W, data vector eigenW) { - int N = rows(y); - real inv_sigma2 = inv_square(sigma); - matrix[N, N] W_tilde = add_diag(-rho * W, 1); - vector[N] half_pred; - real log_det; - half_pred = W_tilde * (y - mu); - log_det = sum(log1m(rho * eigenW)); - return 0.5 * N * log(inv_sigma2) + log_det - - 0.5 * dot_self(half_pred) * inv_sigma2; - } + /* normal log-pdf for spatially lagged residuals + * Args: + * y: the response vector + * mu: mean parameter vector + * sigma: residual standard deviation + * rho: positive autoregressive parameter + * W: spatial weight matrix + * eigenW: precomputed eigenvalues of W + * Returns: + * a scalar to be added to the log posterior + */ + real normal_errorsar_lpdf(vector y, vector mu, real sigma, + real rho, data matrix W, data vector eigenW) { + int N = rows(y); + real inv_sigma2 = inv_square(sigma); + matrix[N, N] W_tilde = add_diag(-rho * W, 1); + vector[N] half_pred; + real log_det; + half_pred = W_tilde * (y - mu); + log_det = sum(log1m(rho * eigenW)); + return 0.5 * N * log(inv_sigma2) + log_det - + 0.5 * dot_self(half_pred) * inv_sigma2; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_normal_fcor.stan r-cran-brms-2.17.0/inst/chunks/fun_normal_fcor.stan --- r-cran-brms-2.16.3/inst/chunks/fun_normal_fcor.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_normal_fcor.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,26 +1,26 @@ - /* multi-normal log-PDF for fixed correlation matrices - * assuming homogoneous variances - * Args: - * y: response vector - * mu: mean parameter vector - * sigma: residual standard deviation - * chol_cor: cholesky factor of the correlation matrix - * Returns: - * sum of the log-PDF values of all observations - */ - real normal_fcor_hom_lpdf(vector y, vector mu, real sigma, data matrix chol_cor) { - return multi_normal_cholesky_lpdf(y | mu, sigma * chol_cor); - } - /* multi-normal log-PDF for fixed correlation matrices - * assuming heterogenous variances - * Args: - * y: response vector - * mu: mean parameter vector - * sigma: residual standard deviation vector - * chol_cor: cholesky factor of the correlation matrix - * Returns: - * sum of the log-PDF values of all observations - */ - real normal_fcor_het_lpdf(vector y, vector mu, vector sigma, data matrix chol_cor) { - return multi_normal_cholesky_lpdf(y | mu, diag_pre_multiply(sigma, chol_cor)); - } + /* multi-normal log-PDF for fixed correlation matrices + * assuming homogoneous variances + * Args: + * y: response vector + * mu: mean parameter vector + * sigma: residual standard deviation + * chol_cor: cholesky factor of the correlation matrix + * Returns: + * sum of the log-PDF values of all observations + */ + real normal_fcor_hom_lpdf(vector y, vector mu, real sigma, data matrix chol_cor) { + return multi_normal_cholesky_lpdf(y | mu, sigma * chol_cor); + } + /* multi-normal log-PDF for fixed correlation matrices + * assuming heterogenous variances + * Args: + * y: response vector + * mu: mean parameter vector + * sigma: residual standard deviation vector + * chol_cor: cholesky factor of the correlation matrix + * Returns: + * sum of the log-PDF values of all observations + */ + real normal_fcor_het_lpdf(vector y, vector mu, vector sigma, data matrix chol_cor) { + return multi_normal_cholesky_lpdf(y | mu, diag_pre_multiply(sigma, chol_cor)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_normal_lagsar.stan r-cran-brms-2.17.0/inst/chunks/fun_normal_lagsar.stan --- r-cran-brms-2.16.3/inst/chunks/fun_normal_lagsar.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_normal_lagsar.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,23 +1,23 @@ - /* normal log-pdf for spatially lagged responses - * Args: - * y: the response vector - * mu: mean parameter vector - * sigma: residual standard deviation - * rho: positive autoregressive parameter - * W: spatial weight matrix - * eigenW: precomputed eigenvalues of W - * Returns: - * a scalar to be added to the log posterior - */ - real normal_lagsar_lpdf(vector y, vector mu, real sigma, - real rho, data matrix W, data vector eigenW) { - int N = rows(y); - real inv_sigma2 = inv_square(sigma); - matrix[N, N] W_tilde = add_diag(-rho * W, 1); - vector[N] half_pred; - real log_det; - half_pred = W_tilde * y - mu; - log_det = sum(log1m(rho * eigenW)); - return 0.5 * N * log(inv_sigma2) + log_det - - 0.5 * dot_self(half_pred) * inv_sigma2; - } + /* normal log-pdf for spatially lagged responses + * Args: + * y: the response vector + * mu: mean parameter vector + * sigma: residual standard deviation + * rho: positive autoregressive parameter + * W: spatial weight matrix + * eigenW: precomputed eigenvalues of W + * Returns: + * a scalar to be added to the log posterior + */ + real normal_lagsar_lpdf(vector y, vector mu, real sigma, + real rho, data matrix W, data vector eigenW) { + int N = rows(y); + real inv_sigma2 = inv_square(sigma); + matrix[N, N] W_tilde = add_diag(-rho * W, 1); + vector[N] half_pred; + real log_det; + half_pred = W_tilde * y - mu; + log_det = sum(log1m(rho * eigenW)); + return 0.5 * N * log(inv_sigma2) + log_det - + 0.5 * dot_self(half_pred) * inv_sigma2; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_normal_time.stan r-cran-brms-2.17.0/inst/chunks/fun_normal_time.stan --- r-cran-brms-2.16.3/inst/chunks/fun_normal_time.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_normal_time.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,71 +1,71 @@ - /* multi-normal log-PDF for time-series covariance structures - * assuming homogoneous variances - * Args: - * y: response vector - * mu: mean parameter vector - * sigma: residual standard deviation - * chol_cor: cholesky factor of the correlation matrix - * se2: square of user defined standard errors - * should be set to zero if none are defined - * nobs: number of observations in each group - * begin: the first observation in each group - * end: the last observation in each group - * Returns: - * sum of the log-PDF values of all observations - */ - real normal_time_hom_lpdf(vector y, vector mu, real sigma, matrix chol_cor, - data vector se2, int[] nobs, int[] begin, int[] end) { - int I = size(nobs); - int has_se = max(se2) > 0; - vector[I] lp; - for (i in 1:I) { - matrix[nobs[i], nobs[i]] L; - L = sigma * chol_cor[1:nobs[i], 1:nobs[i]]; - if (has_se) { - // need to add 'se' to the correlation matrix itself - L = multiply_lower_tri_self_transpose(L); - L += diag_matrix(se2[begin[i]:end[i]]); - L = cholesky_decompose(L); - } - lp[i] = multi_normal_cholesky_lpdf( - y[begin[i]:end[i]] | mu[begin[i]:end[i]], L - ); - } - return sum(lp); - } - /* multi-normal log-PDF for time-series covariance structures - * assuming heterogenous variances - * Args: - * y: response vector - * mu: mean parameter vector - * sigma: residual standard deviation vector - * chol_cor: cholesky factor of the correlation matrix - * se2: square of user defined standard errors - * should be set to zero if none are defined - * nobs: number of observations in each group - * begin: the first observation in each group - * end: the last observation in each group - * Returns: - * sum of the log-PDF values of all observations - */ - real normal_time_het_lpdf(vector y, vector mu, vector sigma, matrix chol_cor, - data vector se2, int[] nobs, int[] begin, int[] end) { - int I = size(nobs); - int has_se = max(se2) > 0; - vector[I] lp; - for (i in 1:I) { - matrix[nobs[i], nobs[i]] L; - L = diag_pre_multiply(sigma[begin[i]:end[i]], - chol_cor[1:nobs[i], 1:nobs[i]]); - if (has_se) { - // need to add 'se' to the correlation matrix itself - L = multiply_lower_tri_self_transpose(L); - L += diag_matrix(se2[begin[i]:end[i]]); - L = cholesky_decompose(L); - } - lp[i] = multi_normal_cholesky_lpdf( - y[begin[i]:end[i]] | mu[begin[i]:end[i]], L - ); - } - return sum(lp); - } + /* multi-normal log-PDF for time-series covariance structures + * assuming homogoneous variances + * Args: + * y: response vector + * mu: mean parameter vector + * sigma: residual standard deviation + * chol_cor: cholesky factor of the correlation matrix + * se2: square of user defined standard errors + * should be set to zero if none are defined + * nobs: number of observations in each group + * begin: the first observation in each group + * end: the last observation in each group + * Returns: + * sum of the log-PDF values of all observations + */ + real normal_time_hom_lpdf(vector y, vector mu, real sigma, matrix chol_cor, + data vector se2, int[] nobs, int[] begin, int[] end) { + int I = size(nobs); + int has_se = max(se2) > 0; + vector[I] lp; + for (i in 1:I) { + matrix[nobs[i], nobs[i]] L; + L = sigma * chol_cor[1:nobs[i], 1:nobs[i]]; + if (has_se) { + // need to add 'se' to the correlation matrix itself + L = multiply_lower_tri_self_transpose(L); + L += diag_matrix(se2[begin[i]:end[i]]); + L = cholesky_decompose(L); + } + lp[i] = multi_normal_cholesky_lpdf( + y[begin[i]:end[i]] | mu[begin[i]:end[i]], L + ); + } + return sum(lp); + } + /* multi-normal log-PDF for time-series covariance structures + * assuming heterogenous variances + * Args: + * y: response vector + * mu: mean parameter vector + * sigma: residual standard deviation vector + * chol_cor: cholesky factor of the correlation matrix + * se2: square of user defined standard errors + * should be set to zero if none are defined + * nobs: number of observations in each group + * begin: the first observation in each group + * end: the last observation in each group + * Returns: + * sum of the log-PDF values of all observations + */ + real normal_time_het_lpdf(vector y, vector mu, vector sigma, matrix chol_cor, + data vector se2, int[] nobs, int[] begin, int[] end) { + int I = size(nobs); + int has_se = max(se2) > 0; + vector[I] lp; + for (i in 1:I) { + matrix[nobs[i], nobs[i]] L; + L = diag_pre_multiply(sigma[begin[i]:end[i]], + chol_cor[1:nobs[i], 1:nobs[i]]); + if (has_se) { + // need to add 'se' to the correlation matrix itself + L = multiply_lower_tri_self_transpose(L); + L += diag_matrix(se2[begin[i]:end[i]]); + L = cholesky_decompose(L); + } + lp[i] = multi_normal_cholesky_lpdf( + y[begin[i]:end[i]] | mu[begin[i]:end[i]], L + ); + } + return sum(lp); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_r2d2.stan r-cran-brms-2.17.0/inst/chunks/fun_r2d2.stan --- r-cran-brms-2.16.3/inst/chunks/fun_r2d2.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_r2d2.stan 2021-12-20 13:50:54.000000000 +0000 @@ -1,11 +1,11 @@ - /* Efficient computation of the R2D2 prior - * Args: - * z: standardized population-level coefficients - * phi: local weight parameters - * tau2: global scale parameter - * Returns: - * population-level coefficients following the R2D2 prior - */ - vector R2D2(vector z, vector phi, real tau2) { - return z .* sqrt(phi * tau2); - } + /* Efficient computation of the R2D2 prior + * Args: + * z: standardized population-level coefficients + * phi: local weight parameters + * tau2: global scale parameter + * Returns: + * population-level coefficients following the R2D2 prior + */ + vector R2D2(vector z, vector phi, real tau2) { + return z .* sqrt(phi * tau2); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_scale_r_cor_by_cov.stan r-cran-brms-2.17.0/inst/chunks/fun_scale_r_cor_by_cov.stan --- r-cran-brms-2.16.3/inst/chunks/fun_scale_r_cor_by_cov.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_scale_r_cor_by_cov.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,43 +1,43 @@ - /* compute correlated group-level effects with 'by' variables - * in the presence of a within-group covariance matrix - * Args: - * z: matrix of unscaled group-level effects - * SD: matrix of standard deviation parameters - * L: an array of cholesky factor correlation matrices - * Jby: index which grouping level belongs to which by level - * Lcov: cholesky factor of within-group correlation matrix - * Returns: - * matrix of scaled group-level effects - */ - matrix scale_r_cor_by_cov(matrix z, matrix SD, matrix[] L, - int[] Jby, matrix Lcov) { - vector[num_elements(z)] z_flat = to_vector(z); - vector[num_elements(z)] r = rep_vector(0, num_elements(z)); - matrix[rows(L[1]), cols(L[1])] LC[size(L)]; - int rows_z = rows(z); - int rows_L = rows(L[1]); - for (i in 1:size(LC)) { - LC[i] = diag_pre_multiply(SD[, i], L[i]); - } - // kronecker product of cholesky factors times a vector - for (icov in 1:rows(Lcov)) { - for (jcov in 1:icov) { - if (Lcov[icov, jcov] > 1e-10) { - // avoid calculating products between unrelated individuals - for (i in 1:rows_L) { - for (j in 1:i) { - // incremented element of the output vector - int k = (rows_L * (icov - 1)) + i; - // applied element of the input vector - int l = (rows_L * (jcov - 1)) + j; - // column number of z to which z_flat[l] belongs - int m = (l - 1) / rows_z + 1; - r[k] = r[k] + Lcov[icov, jcov] * LC[Jby[m]][i, j] * z_flat[l]; - } - } - } - } - } - // r is returned in another dimension order than z - return to_matrix(r, cols(z), rows(z), 0); - } + /* compute correlated group-level effects with 'by' variables + * in the presence of a within-group covariance matrix + * Args: + * z: matrix of unscaled group-level effects + * SD: matrix of standard deviation parameters + * L: an array of cholesky factor correlation matrices + * Jby: index which grouping level belongs to which by level + * Lcov: cholesky factor of within-group correlation matrix + * Returns: + * matrix of scaled group-level effects + */ + matrix scale_r_cor_by_cov(matrix z, matrix SD, matrix[] L, + int[] Jby, matrix Lcov) { + vector[num_elements(z)] z_flat = to_vector(z); + vector[num_elements(z)] r = rep_vector(0, num_elements(z)); + matrix[rows(L[1]), cols(L[1])] LC[size(L)]; + int rows_z = rows(z); + int rows_L = rows(L[1]); + for (i in 1:size(LC)) { + LC[i] = diag_pre_multiply(SD[, i], L[i]); + } + // kronecker product of cholesky factors times a vector + for (icov in 1:rows(Lcov)) { + for (jcov in 1:icov) { + if (Lcov[icov, jcov] > 1e-10) { + // avoid calculating products between unrelated individuals + for (i in 1:rows_L) { + for (j in 1:i) { + // incremented element of the output vector + int k = (rows_L * (icov - 1)) + i; + // applied element of the input vector + int l = (rows_L * (jcov - 1)) + j; + // column number of z to which z_flat[l] belongs + int m = (l - 1) / rows_z + 1; + r[k] = r[k] + Lcov[icov, jcov] * LC[Jby[m]][i, j] * z_flat[l]; + } + } + } + } + } + // r is returned in another dimension order than z + return to_matrix(r, cols(z), rows(z), 0); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_scale_r_cor_by.stan r-cran-brms-2.17.0/inst/chunks/fun_scale_r_cor_by.stan --- r-cran-brms-2.16.3/inst/chunks/fun_scale_r_cor_by.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_scale_r_cor_by.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,21 +1,21 @@ - /* compute correlated group-level effects with 'by' variables - * Args: - * z: matrix of unscaled group-level effects - * SD: matrix of standard deviation parameters - * L: an array of cholesky factor correlation matrices - * Jby: index which grouping level belongs to which by level - * Returns: - * matrix of scaled group-level effects - */ - matrix scale_r_cor_by(matrix z, matrix SD, matrix[] L, int[] Jby) { - // r is stored in another dimension order than z - matrix[cols(z), rows(z)] r; - matrix[rows(L[1]), cols(L[1])] LC[size(L)]; - for (i in 1:size(LC)) { - LC[i] = diag_pre_multiply(SD[, i], L[i]); - } - for (j in 1:rows(r)) { - r[j] = transpose(LC[Jby[j]] * z[, j]); - } - return r; - } + /* compute correlated group-level effects with 'by' variables + * Args: + * z: matrix of unscaled group-level effects + * SD: matrix of standard deviation parameters + * L: an array of cholesky factor correlation matrices + * Jby: index which grouping level belongs to which by level + * Returns: + * matrix of scaled group-level effects + */ + matrix scale_r_cor_by(matrix z, matrix SD, matrix[] L, int[] Jby) { + // r is stored in another dimension order than z + matrix[cols(z), rows(z)] r; + matrix[rows(L[1]), cols(L[1])] LC[size(L)]; + for (i in 1:size(LC)) { + LC[i] = diag_pre_multiply(SD[, i], L[i]); + } + for (j in 1:rows(r)) { + r[j] = transpose(LC[Jby[j]] * z[, j]); + } + return r; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_scale_r_cor_cov.stan r-cran-brms-2.17.0/inst/chunks/fun_scale_r_cor_cov.stan --- r-cran-brms-2.16.3/inst/chunks/fun_scale_r_cor_cov.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_scale_r_cor_cov.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,36 +1,36 @@ - /* compute correlated group-level effects - * in the presence of a within-group covariance matrix - * Args: - * z: matrix of unscaled group-level effects - * SD: vector of standard deviation parameters - * L: cholesky factor correlation matrix - * Lcov: cholesky factor of within-group correlation matrix - * Returns: - * matrix of scaled group-level effects - */ - matrix scale_r_cor_cov(matrix z, vector SD, matrix L, matrix Lcov) { - vector[num_elements(z)] z_flat = to_vector(z); - vector[num_elements(z)] r = rep_vector(0, num_elements(z)); - matrix[rows(L), cols(L)] LC = diag_pre_multiply(SD, L); - int rows_z = rows(z); - int rows_L = rows(L); - // kronecker product of cholesky factors times a vector - for (icov in 1:rows(Lcov)) { - for (jcov in 1:icov) { - if (Lcov[icov, jcov] > 1e-10) { - // avoid calculating products between unrelated individuals - for (i in 1:rows_L) { - for (j in 1:i) { - // incremented element of the output vector - int k = (rows_L * (icov - 1)) + i; - // applied element of the input vector - int l = (rows_L * (jcov - 1)) + j; - r[k] = r[k] + Lcov[icov, jcov] * LC[i, j] * z_flat[l]; - } - } - } - } - } - // r is returned in another dimension order than z - return to_matrix(r, cols(z), rows(z), 0); - } + /* compute correlated group-level effects + * in the presence of a within-group covariance matrix + * Args: + * z: matrix of unscaled group-level effects + * SD: vector of standard deviation parameters + * L: cholesky factor correlation matrix + * Lcov: cholesky factor of within-group correlation matrix + * Returns: + * matrix of scaled group-level effects + */ + matrix scale_r_cor_cov(matrix z, vector SD, matrix L, matrix Lcov) { + vector[num_elements(z)] z_flat = to_vector(z); + vector[num_elements(z)] r = rep_vector(0, num_elements(z)); + matrix[rows(L), cols(L)] LC = diag_pre_multiply(SD, L); + int rows_z = rows(z); + int rows_L = rows(L); + // kronecker product of cholesky factors times a vector + for (icov in 1:rows(Lcov)) { + for (jcov in 1:icov) { + if (Lcov[icov, jcov] > 1e-10) { + // avoid calculating products between unrelated individuals + for (i in 1:rows_L) { + for (j in 1:i) { + // incremented element of the output vector + int k = (rows_L * (icov - 1)) + i; + // applied element of the input vector + int l = (rows_L * (jcov - 1)) + j; + r[k] = r[k] + Lcov[icov, jcov] * LC[i, j] * z_flat[l]; + } + } + } + } + } + // r is returned in another dimension order than z + return to_matrix(r, cols(z), rows(z), 0); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_scale_r_cor.stan r-cran-brms-2.17.0/inst/chunks/fun_scale_r_cor.stan --- r-cran-brms-2.16.3/inst/chunks/fun_scale_r_cor.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_scale_r_cor.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,12 +1,12 @@ - /* compute correlated group-level effects - * Args: - * z: matrix of unscaled group-level effects - * SD: vector of standard deviation parameters - * L: cholesky factor correlation matrix - * Returns: - * matrix of scaled group-level effects - */ - matrix scale_r_cor(matrix z, vector SD, matrix L) { - // r is stored in another dimension order than z - return transpose(diag_pre_multiply(SD, L) * z); - } + /* compute correlated group-level effects + * Args: + * z: matrix of unscaled group-level effects + * SD: vector of standard deviation parameters + * L: cholesky factor correlation matrix + * Returns: + * matrix of scaled group-level effects + */ + matrix scale_r_cor(matrix z, vector SD, matrix L) { + // r is stored in another dimension order than z + return transpose(diag_pre_multiply(SD, L) * z); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_scale_time_err.stan r-cran-brms-2.17.0/inst/chunks/fun_scale_time_err.stan --- r-cran-brms-2.16.3/inst/chunks/fun_scale_time_err.stan 2021-06-11 18:45:59.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_scale_time_err.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,20 +1,20 @@ - /* scale and correlate time-series residuals - * Args: - * zerr: standardized and independent residuals - * sderr: standard deviation of the residuals - * chol_cor: cholesky factor of the correlation matrix - * nobs: number of observations in each group - * begin: the first observation in each group - * end: the last observation in each group - * Returns: - * vector of scaled and correlated residuals - */ - vector scale_time_err(vector zerr, real sderr, matrix chol_cor, - int[] nobs, int[] begin, int[] end) { - vector[rows(zerr)] err; - for (i in 1:size(nobs)) { - err[begin[i]:end[i]] = - sderr * chol_cor[1:nobs[i], 1:nobs[i]] * zerr[begin[i]:end[i]]; - } - return err; - } + /* scale and correlate time-series residuals + * Args: + * zerr: standardized and independent residuals + * sderr: standard deviation of the residuals + * chol_cor: cholesky factor of the correlation matrix + * nobs: number of observations in each group + * begin: the first observation in each group + * end: the last observation in each group + * Returns: + * vector of scaled and correlated residuals + */ + vector scale_time_err(vector zerr, real sderr, matrix chol_cor, + int[] nobs, int[] begin, int[] end) { + vector[rows(zerr)] err; + for (i in 1:size(nobs)) { + err[begin[i]:end[i]] = + sderr * chol_cor[1:nobs[i], 1:nobs[i]] * zerr[begin[i]:end[i]]; + } + return err; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_scale_xi.stan r-cran-brms-2.17.0/inst/chunks/fun_scale_xi.stan --- r-cran-brms-2.16.3/inst/chunks/fun_scale_xi.stan 2018-03-22 07:52:16.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_scale_xi.stan 2021-12-20 13:50:54.000000000 +0000 @@ -1,34 +1,34 @@ - /* scale auxiliary parameter xi to a suitable region - * expecting sigma to be a scalar - * Args: - * xi: unscaled shape parameter - * y: response values - * mu: location parameter - * sigma: scale parameter - * Returns: - * scaled shape parameter xi - */ - real scale_xi(real xi, vector y, vector mu, real sigma) { - vector[rows(y)] x = (y - mu) / sigma; - vector[2] bounds = [-inv(min(x)), -inv(max(x))]'; - real lb = min(bounds); - real ub = max(bounds); - return inv_logit(xi) * (ub - lb) + lb; - } - /* scale auxiliary parameter xi to a suitable region - * expecting sigma to be a vector - * Args: - * xi: unscaled shape parameter - * y: response values - * mu: location parameter - * sigma: scale parameter - * Returns: - * scaled shape parameter xi - */ - real scale_xi_vector(real xi, vector y, vector mu, vector sigma) { - vector[rows(y)] x = (y - mu) ./ sigma; - vector[2] bounds = [-inv(min(x)), -inv(max(x))]'; - real lb = min(bounds); - real ub = max(bounds); - return inv_logit(xi) * (ub - lb) + lb; - } + /* scale auxiliary parameter xi to a suitable region + * expecting sigma to be a scalar + * Args: + * xi: unscaled shape parameter + * y: response values + * mu: location parameter + * sigma: scale parameter + * Returns: + * scaled shape parameter xi + */ + real scale_xi(real xi, vector y, vector mu, real sigma) { + vector[rows(y)] x = (y - mu) / sigma; + vector[2] bounds = [-inv(min(x)), -inv(max(x))]'; + real lb = min(bounds); + real ub = max(bounds); + return inv_logit(xi) * (ub - lb) + lb; + } + /* scale auxiliary parameter xi to a suitable region + * expecting sigma to be a vector + * Args: + * xi: unscaled shape parameter + * y: response values + * mu: location parameter + * sigma: scale parameter + * Returns: + * scaled shape parameter xi + */ + real scale_xi_vector(real xi, vector y, vector mu, vector sigma) { + vector[rows(y)] x = (y - mu) ./ sigma; + vector[2] bounds = [-inv(min(x)), -inv(max(x))]'; + real lb = min(bounds); + real ub = max(bounds); + return inv_logit(xi) * (ub - lb) + lb; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_sequence.stan r-cran-brms-2.17.0/inst/chunks/fun_sequence.stan --- r-cran-brms-2.16.3/inst/chunks/fun_sequence.stan 2021-06-11 18:40:42.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_sequence.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,14 +1,14 @@ /* integer sequence of values - * Args: + * Args: * start: starting integer * end: ending integer - * Returns: + * Returns: * an integer sequence from start to end - */ - int[] sequence(int start, int end) { + */ + int[] sequence(int start, int end) { int seq[end - start + 1]; for (n in 1:num_elements(seq)) { seq[n] = n + start - 1; } - return seq; - } + return seq; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_softit.stan r-cran-brms-2.17.0/inst/chunks/fun_softit.stan --- r-cran-brms-2.16.3/inst/chunks/fun_softit.stan 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_softit.stan 2022-03-13 16:10:29.000000000 +0000 @@ -0,0 +1,18 @@ + /* compute the softit link + * Args: + * p: a scalar in (0, 1) + * Returns: + * a scalar in (-Inf, Inf) + */ + real softit(real p) { + return log(expm1(-p / (p - 1))); + } + /* compute the inverse of the sofit link + * Args: + * y: a scalar in (-Inf, Inf) + * Returns: + * a scalar in (0, 1) + */ + real inv_softit(real y) { + return log1p_exp(y) / (1 + log1p_exp(y)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_softplus.stan r-cran-brms-2.17.0/inst/chunks/fun_softplus.stan --- r-cran-brms-2.16.3/inst/chunks/fun_softplus.stan 2020-02-27 16:10:02.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_softplus.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,9 +1,9 @@ - /* softplus link function inverse to 'log1p_exp' - * Args: - * x: a positive scalar - * Returns: - * a scalar in (-Inf, Inf) - */ - real log_expm1(real x) { - return log(expm1(x)); - } + /* softplus link function inverse to 'log1p_exp' + * Args: + * x: a positive scalar + * Returns: + * a scalar in (-Inf, Inf) + */ + real log_expm1(real x) { + return log(expm1(x)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_sparse_car_lpdf.stan r-cran-brms-2.17.0/inst/chunks/fun_sparse_car_lpdf.stan --- r-cran-brms-2.16.3/inst/chunks/fun_sparse_car_lpdf.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_sparse_car_lpdf.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,37 +1,37 @@ - /* Return the log probability of a proper conditional autoregressive (CAR) - * prior with a sparse representation for the adjacency matrix - * Full credit to Max Joseph (https://github.com/mbjoseph/CARstan) - * Args: - * phi: Vector containing the CAR parameters for each location - * car: Dependence (usually spatial) parameter for the CAR prior - * sdcar: Standard deviation parameter for the CAR prior - * Nloc: Number of locations - * Nedges: Number of edges (adjacency pairs) - * Nneigh: Number of neighbors for each location - * eigenW: Eigenvalues of D^(-1/2) * W * D^(-1/2) - * edges1, edges2: Sparse representation of adjacency matrix - * Details: - * D = Diag(Nneigh) - * Returns: - * Log probability density of CAR prior up to additive constant - */ - real sparse_car_lpdf(vector phi, real car, real sdcar, int Nloc, - int Nedges, data vector Nneigh, data vector eigenW, - int[] edges1, int[] edges2) { - real tau; // precision parameter - row_vector[Nloc] phit_D; // phi' * D - row_vector[Nloc] phit_W; // phi' * W - vector[Nloc] ldet; - tau = inv_square(sdcar); - phit_D = (phi .* Nneigh)'; - phit_W = rep_row_vector(0, Nloc); - for (i in 1:Nedges) { - phit_W[edges1[i]] = phit_W[edges1[i]] + phi[edges2[i]]; - phit_W[edges2[i]] = phit_W[edges2[i]] + phi[edges1[i]]; - } - for (i in 1:Nloc) { - ldet[i] = log1m(car * eigenW[i]); - } - return 0.5 * (Nloc * log(tau) + sum(ldet) - - tau * (phit_D * phi - car * (phit_W * phi))); - } + /* Return the log probability of a proper conditional autoregressive (CAR) + * prior with a sparse representation for the adjacency matrix + * Full credit to Max Joseph (https://github.com/mbjoseph/CARstan) + * Args: + * phi: Vector containing the CAR parameters for each location + * car: Dependence (usually spatial) parameter for the CAR prior + * sdcar: Standard deviation parameter for the CAR prior + * Nloc: Number of locations + * Nedges: Number of edges (adjacency pairs) + * Nneigh: Number of neighbors for each location + * eigenW: Eigenvalues of D^(-1/2) * W * D^(-1/2) + * edges1, edges2: Sparse representation of adjacency matrix + * Details: + * D = Diag(Nneigh) + * Returns: + * Log probability density of CAR prior up to additive constant + */ + real sparse_car_lpdf(vector phi, real car, real sdcar, int Nloc, + int Nedges, data vector Nneigh, data vector eigenW, + int[] edges1, int[] edges2) { + real tau; // precision parameter + row_vector[Nloc] phit_D; // phi' * D + row_vector[Nloc] phit_W; // phi' * W + vector[Nloc] ldet; + tau = inv_square(sdcar); + phit_D = (phi .* Nneigh)'; + phit_W = rep_row_vector(0, Nloc); + for (i in 1:Nedges) { + phit_W[edges1[i]] = phit_W[edges1[i]] + phi[edges2[i]]; + phit_W[edges2[i]] = phit_W[edges2[i]] + phi[edges1[i]]; + } + for (i in 1:Nloc) { + ldet[i] = log1m(car * eigenW[i]); + } + return 0.5 * (Nloc * log(tau) + sum(ldet) - + tau * (phit_D * phi - car * (phit_W * phi))); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_sparse_icar_lpdf.stan r-cran-brms-2.17.0/inst/chunks/fun_sparse_icar_lpdf.stan --- r-cran-brms-2.16.3/inst/chunks/fun_sparse_icar_lpdf.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_sparse_icar_lpdf.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,32 +1,32 @@ - /* Return the log probability of an intrinsic conditional autoregressive - * (ICAR) prior with a sparse representation for the adjacency matrix - * Full credit to Max Joseph (https://github.com/mbjoseph/CARstan) - * Args: - * phi: Vector containing the CAR parameters for each location - * sdcar: Standard deviation parameter for the CAR prior - * Nloc: Number of locations - * Nedges: Number of edges (adjacency pairs) - * Nneigh: Number of neighbors for each location - * eigenW: Eigenvalues of D^(-1/2) * W * D^(-1/2) - * edges1, edges2: Sparse representation of adjacency matrix - * Details: - * D = Diag(Nneigh) - * Returns: - * Log probability density of CAR prior up to additive constant - */ - real sparse_icar_lpdf(vector phi, real sdcar, int Nloc, - int Nedges, data vector Nneigh, data vector eigenW, - int[] edges1, int[] edges2) { - real tau; // precision parameter - row_vector[Nloc] phit_D; // phi' * D - row_vector[Nloc] phit_W; // phi' * W - tau = inv_square(sdcar); - phit_D = (phi .* Nneigh)'; - phit_W = rep_row_vector(0, Nloc); - for (i in 1:Nedges) { - phit_W[edges1[i]] = phit_W[edges1[i]] + phi[edges2[i]]; - phit_W[edges2[i]] = phit_W[edges2[i]] + phi[edges1[i]]; - } - return 0.5 * ((Nloc - 1) * log(tau) - - tau * (phit_D * phi - (phit_W * phi))); - } + /* Return the log probability of an intrinsic conditional autoregressive + * (ICAR) prior with a sparse representation for the adjacency matrix + * Full credit to Max Joseph (https://github.com/mbjoseph/CARstan) + * Args: + * phi: Vector containing the CAR parameters for each location + * sdcar: Standard deviation parameter for the CAR prior + * Nloc: Number of locations + * Nedges: Number of edges (adjacency pairs) + * Nneigh: Number of neighbors for each location + * eigenW: Eigenvalues of D^(-1/2) * W * D^(-1/2) + * edges1, edges2: Sparse representation of adjacency matrix + * Details: + * D = Diag(Nneigh) + * Returns: + * Log probability density of CAR prior up to additive constant + */ + real sparse_icar_lpdf(vector phi, real sdcar, int Nloc, + int Nedges, data vector Nneigh, data vector eigenW, + int[] edges1, int[] edges2) { + real tau; // precision parameter + row_vector[Nloc] phit_D; // phi' * D + row_vector[Nloc] phit_W; // phi' * W + tau = inv_square(sdcar); + phit_D = (phi .* Nneigh)'; + phit_W = rep_row_vector(0, Nloc); + for (i in 1:Nedges) { + phit_W[edges1[i]] = phit_W[edges1[i]] + phi[edges2[i]]; + phit_W[edges2[i]] = phit_W[edges2[i]] + phi[edges1[i]]; + } + return 0.5 * ((Nloc - 1) * log(tau) - + tau * (phit_D * phi - (phit_W * phi))); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_squareplus.stan r-cran-brms-2.17.0/inst/chunks/fun_squareplus.stan --- r-cran-brms-2.16.3/inst/chunks/fun_squareplus.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_squareplus.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,18 +1,18 @@ - /* squareplus inverse link function (squareplus itself) - * Args: - * x: a scalar in (-Inf, Inf) - * Returns: - * a positive scalar - */ - real squareplus(real x) { - return (x + sqrt(x^2 + 4)) / 2; - } - /* squareplus link function (inverse squareplus) - * Args: - * x: a positive scalar - * Returns: - * a scalar in (-Inf, Inf) - */ - real inv_squareplus(real x) { - return (x^2 - 1) / x; - } + /* squareplus inverse link function (squareplus itself) + * Args: + * x: a scalar in (-Inf, Inf) + * Returns: + * a positive scalar + */ + real squareplus(real x) { + return (x + sqrt(x^2 + 4)) / 2; + } + /* squareplus link function (inverse squareplus) + * Args: + * x: a positive scalar + * Returns: + * a scalar in (-Inf, Inf) + */ + real inv_squareplus(real x) { + return (x^2 - 1) / x; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_student_t_errorsar.stan r-cran-brms-2.17.0/inst/chunks/fun_student_t_errorsar.stan --- r-cran-brms-2.16.3/inst/chunks/fun_student_t_errorsar.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_student_t_errorsar.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,26 +1,26 @@ - /* student-t log-pdf for spatially lagged residuals - * Args: - * y: the response vector - * nu: degrees of freedom parameter - * mu: mean parameter vector - * sigma: residual scale parameter - * rho: positive autoregressive parameter - * W: spatial weight matrix - * eigenW: precomputed eigenvalues of W - * Returns: - * a scalar to be added to the log posterior - */ - real student_t_errorsar_lpdf(vector y, real nu, vector mu, real sigma, - real rho, data matrix W, data vector eigenW) { - int N = rows(y); - real K = rows(y); // avoid integer division warning - real inv_sigma2 = inv_square(sigma); - matrix[N, N] W_tilde = add_diag(-rho * W, 1); - vector[N] half_pred; - real log_det; - half_pred = W_tilde * (y - mu); - log_det = sum(log1m(rho * eigenW)); - return - K / 2 * log(nu) + lgamma((nu + K) / 2) - lgamma(nu / 2) + - 0.5 * K * log(inv_sigma2) + log_det - - (nu + K) / 2 * log1p(dot_self(half_pred) * inv_sigma2 / nu); - } + /* student-t log-pdf for spatially lagged residuals + * Args: + * y: the response vector + * nu: degrees of freedom parameter + * mu: mean parameter vector + * sigma: residual scale parameter + * rho: positive autoregressive parameter + * W: spatial weight matrix + * eigenW: precomputed eigenvalues of W + * Returns: + * a scalar to be added to the log posterior + */ + real student_t_errorsar_lpdf(vector y, real nu, vector mu, real sigma, + real rho, data matrix W, data vector eigenW) { + int N = rows(y); + real K = rows(y); // avoid integer division warning + real inv_sigma2 = inv_square(sigma); + matrix[N, N] W_tilde = add_diag(-rho * W, 1); + vector[N] half_pred; + real log_det; + half_pred = W_tilde * (y - mu); + log_det = sum(log1m(rho * eigenW)); + return - K / 2 * log(nu) + lgamma((nu + K) / 2) - lgamma(nu / 2) + + 0.5 * K * log(inv_sigma2) + log_det - + (nu + K) / 2 * log1p(dot_self(half_pred) * inv_sigma2 / nu); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_student_t_fcor.stan r-cran-brms-2.17.0/inst/chunks/fun_student_t_fcor.stan --- r-cran-brms-2.16.3/inst/chunks/fun_student_t_fcor.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_student_t_fcor.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,35 +1,35 @@ - /* multi-student-t log-PDF for fixed correlation matrices - * assuming homogoneous variances - * Args: - * y: response vector - * nu: degrees of freedom parameter - * mu: mean parameter vector - * sigma: scale parameter - * chol_cor: cholesky factor of the correlation matrix - * Returns: - * sum of the log-PDF values of all observations - */ - real student_t_fcor_hom_lpdf(vector y, real nu, vector mu, real sigma, - data matrix chol_cor) { - int N = rows(chol_cor); - matrix[N, N] Cov = multiply_lower_tri_self_transpose(sigma * chol_cor); - return multi_student_t_lpdf(y | nu, mu, Cov); - } - /* multi-student-t log-PDF for fixed correlation matrices - * assuming heterogenous variances - * Args: - * y: response vector - * nu: degrees of freedom parameter - * mu: mean parameter vector - * sigma: scale parameter vector - * chol_cor: cholesky factor of the correlation matrix - * Returns: - * sum of the log-PDF values of all observations - */ - real student_t_fcor_het_lpdf(vector y, real nu, vector mu, vector sigma, - data matrix chol_cor) { - int N = rows(chol_cor); - matrix[N, N] Cov = diag_pre_multiply(sigma, chol_cor); - Cov = multiply_lower_tri_self_transpose(Cov); - return multi_student_t_lpdf(y | nu, mu, Cov); - } + /* multi-student-t log-PDF for fixed correlation matrices + * assuming homogoneous variances + * Args: + * y: response vector + * nu: degrees of freedom parameter + * mu: mean parameter vector + * sigma: scale parameter + * chol_cor: cholesky factor of the correlation matrix + * Returns: + * sum of the log-PDF values of all observations + */ + real student_t_fcor_hom_lpdf(vector y, real nu, vector mu, real sigma, + data matrix chol_cor) { + int N = rows(chol_cor); + matrix[N, N] Cov = multiply_lower_tri_self_transpose(sigma * chol_cor); + return multi_student_t_lpdf(y | nu, mu, Cov); + } + /* multi-student-t log-PDF for fixed correlation matrices + * assuming heterogenous variances + * Args: + * y: response vector + * nu: degrees of freedom parameter + * mu: mean parameter vector + * sigma: scale parameter vector + * chol_cor: cholesky factor of the correlation matrix + * Returns: + * sum of the log-PDF values of all observations + */ + real student_t_fcor_het_lpdf(vector y, real nu, vector mu, vector sigma, + data matrix chol_cor) { + int N = rows(chol_cor); + matrix[N, N] Cov = diag_pre_multiply(sigma, chol_cor); + Cov = multiply_lower_tri_self_transpose(Cov); + return multi_student_t_lpdf(y | nu, mu, Cov); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_student_t_lagsar.stan r-cran-brms-2.17.0/inst/chunks/fun_student_t_lagsar.stan --- r-cran-brms-2.16.3/inst/chunks/fun_student_t_lagsar.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_student_t_lagsar.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,26 +1,26 @@ - /* student-t log-pdf for spatially lagged responses - * Args: - * y: the response vector - * nu: degrees of freedom parameter - * mu: mean parameter vector - * sigma: residual scale parameter - * rho: positive autoregressive parameter - * W: spatial weight matrix - * eigenW: precomputed eigenvalues of W - * Returns: - * a scalar to be added to the log posterior - */ - real student_t_lagsar_lpdf(vector y, real nu, vector mu, real sigma, - real rho, data matrix W, data vector eigenW) { - int N = rows(y); - real K = rows(y); // avoid integer division warning - real inv_sigma2 = inv_square(sigma); - matrix[N, N] W_tilde = add_diag(-rho * W, 1); - vector[N] half_pred; - real log_det; - half_pred = W_tilde * y - mu; - log_det = sum(log1m(rho * eigenW)); - return - K / 2 * log(nu) + lgamma((nu + K) / 2) - lgamma(nu / 2) + - 0.5 * K * log(inv_sigma2) + log_det - - (nu + K) / 2 * log1p(dot_self(half_pred) * inv_sigma2 / nu); - } + /* student-t log-pdf for spatially lagged responses + * Args: + * y: the response vector + * nu: degrees of freedom parameter + * mu: mean parameter vector + * sigma: residual scale parameter + * rho: positive autoregressive parameter + * W: spatial weight matrix + * eigenW: precomputed eigenvalues of W + * Returns: + * a scalar to be added to the log posterior + */ + real student_t_lagsar_lpdf(vector y, real nu, vector mu, real sigma, + real rho, data matrix W, data vector eigenW) { + int N = rows(y); + real K = rows(y); // avoid integer division warning + real inv_sigma2 = inv_square(sigma); + matrix[N, N] W_tilde = add_diag(-rho * W, 1); + vector[N] half_pred; + real log_det; + half_pred = W_tilde * y - mu; + log_det = sum(log1m(rho * eigenW)); + return - K / 2 * log(nu) + lgamma((nu + K) / 2) - lgamma(nu / 2) + + 0.5 * K * log(inv_sigma2) + log_det - + (nu + K) / 2 * log1p(dot_self(half_pred) * inv_sigma2 / nu); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_student_t_time.stan r-cran-brms-2.17.0/inst/chunks/fun_student_t_time.stan --- r-cran-brms-2.16.3/inst/chunks/fun_student_t_time.stan 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_student_t_time.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,71 +1,71 @@ - /* multi-student-t log-PDF for time-series covariance structures - * assuming homogoneous variances - * Args: - * y: response vector - * nu: degrees of freedom parameter - * mu: mean parameter vector - * sigma: scale parameter - * chol_cor: cholesky factor of the correlation matrix - * se2: square of user defined standard errors - * should be set to zero if none are defined - * nobs: number of observations in each group - * begin: the first observation in each group - * end: the last observation in each group - * Returns: - * sum of the log-PDF values of all observations - */ - real student_t_time_hom_lpdf(vector y, real nu, vector mu, real sigma, - matrix chol_cor, data vector se2, int[] nobs, - int[] begin, int[] end) { - int I = size(nobs); - int has_se = max(se2) > 0; - vector[I] lp; - for (i in 1:I) { - matrix[nobs[i], nobs[i]] Cov; - Cov = sigma * chol_cor[1:nobs[i], 1:nobs[i]]; - Cov = multiply_lower_tri_self_transpose(Cov); - if (has_se) { - Cov += diag_matrix(se2[begin[i]:end[i]]); - } - lp[i] = multi_student_t_lpdf( - y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov - ); - } - return sum(lp); - } - /* multi-student-t log-PDF for time-series covariance structures - * assuming heterogenous variances - * Args: - * y: response vector - * nu: degrees of freedom parameter - * mu: mean parameter vector - * sigma: scale parameter vector - * chol_cor: cholesky factor of the correlation matrix - * se2: square of user defined standard errors - * should be set to zero if none are defined - * nobs: number of observations in each group - * begin: the first observation in each group - * end: the last observation in each group - * Returns: - * sum of the log-PDF values of all observations - */ - real student_t_time_het_lpdf(vector y, real nu, vector mu, vector sigma, - matrix chol_cor, data vector se2, int[] nobs, - int[] begin, int[] end) { - int I = size(nobs); - int has_se = max(se2) > 0; - vector[I] lp; - for (i in 1:I) { - matrix[nobs[i], nobs[i]] Cov; - Cov = diag_pre_multiply(sigma[begin[i]:end[i]], - chol_cor[1:nobs[i], 1:nobs[i]]); - Cov = multiply_lower_tri_self_transpose(Cov); - if (has_se) { - Cov += diag_matrix(se2[begin[i]:end[i]]); - } - lp[i] = multi_student_t_lpdf( - y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov - ); - } - return sum(lp); - } + /* multi-student-t log-PDF for time-series covariance structures + * assuming homogoneous variances + * Args: + * y: response vector + * nu: degrees of freedom parameter + * mu: mean parameter vector + * sigma: scale parameter + * chol_cor: cholesky factor of the correlation matrix + * se2: square of user defined standard errors + * should be set to zero if none are defined + * nobs: number of observations in each group + * begin: the first observation in each group + * end: the last observation in each group + * Returns: + * sum of the log-PDF values of all observations + */ + real student_t_time_hom_lpdf(vector y, real nu, vector mu, real sigma, + matrix chol_cor, data vector se2, int[] nobs, + int[] begin, int[] end) { + int I = size(nobs); + int has_se = max(se2) > 0; + vector[I] lp; + for (i in 1:I) { + matrix[nobs[i], nobs[i]] Cov; + Cov = sigma * chol_cor[1:nobs[i], 1:nobs[i]]; + Cov = multiply_lower_tri_self_transpose(Cov); + if (has_se) { + Cov += diag_matrix(se2[begin[i]:end[i]]); + } + lp[i] = multi_student_t_lpdf( + y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov + ); + } + return sum(lp); + } + /* multi-student-t log-PDF for time-series covariance structures + * assuming heterogenous variances + * Args: + * y: response vector + * nu: degrees of freedom parameter + * mu: mean parameter vector + * sigma: scale parameter vector + * chol_cor: cholesky factor of the correlation matrix + * se2: square of user defined standard errors + * should be set to zero if none are defined + * nobs: number of observations in each group + * begin: the first observation in each group + * end: the last observation in each group + * Returns: + * sum of the log-PDF values of all observations + */ + real student_t_time_het_lpdf(vector y, real nu, vector mu, vector sigma, + matrix chol_cor, data vector se2, int[] nobs, + int[] begin, int[] end) { + int I = size(nobs); + int has_se = max(se2) > 0; + vector[I] lp; + for (i in 1:I) { + matrix[nobs[i], nobs[i]] Cov; + Cov = diag_pre_multiply(sigma[begin[i]:end[i]], + chol_cor[1:nobs[i], 1:nobs[i]]); + Cov = multiply_lower_tri_self_transpose(Cov); + if (has_se) { + Cov += diag_matrix(se2[begin[i]:end[i]]); + } + lp[i] = multi_student_t_lpdf( + y[begin[i]:end[i]] | nu, mu[begin[i]:end[i]], Cov + ); + } + return sum(lp); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_tan_half.stan r-cran-brms-2.17.0/inst/chunks/fun_tan_half.stan --- r-cran-brms-2.16.3/inst/chunks/fun_tan_half.stan 2017-11-13 08:30:32.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_tan_half.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,18 +1,18 @@ - /* compute the tan_half link - * Args: - * x: a scalar in (-pi, pi) - * Returns: - * a scalar in (-Inf, Inf) - */ - real tan_half(real x) { - return tan(x / 2); - } - /* compute the inverse of the tan_half link - * Args: - * y: a scalar in (-Inf, Inf) - * Returns: - * a scalar in (-pi, pi) - */ - real inv_tan_half(real y) { - return 2 * atan(y); - } + /* compute the tan_half link + * Args: + * x: a scalar in (-pi, pi) + * Returns: + * a scalar in (-Inf, Inf) + */ + real tan_half(real x) { + return tan(x / 2); + } + /* compute the inverse of the tan_half link + * Args: + * y: a scalar in (-Inf, Inf) + * Returns: + * a scalar in (-pi, pi) + */ + real inv_tan_half(real y) { + return 2 * atan(y); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_von_mises.stan r-cran-brms-2.17.0/inst/chunks/fun_von_mises.stan --- r-cran-brms-2.16.3/inst/chunks/fun_von_mises.stan 2020-08-15 06:55:36.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_von_mises.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,34 +1,34 @@ - /* von Mises log-PDF of a single response - * for kappa > 100 the normal approximation is used - * for reasons of numerial stability - * Args: - * y: the response vector between -pi and pi - * mu: location parameter vector - * kappa: precision parameter - * Returns: - * a scalar to be added to the log posterior - */ - real von_mises_real_lpdf(real y, real mu, real kappa) { - if (kappa < 100) { - return von_mises_lpdf(y | mu, kappa); - } else { - return normal_lpdf(y | mu, sqrt(1 / kappa)); - } - } - /* von Mises log-PDF of a response vector - * for kappa > 100 the normal approximation is used - * for reasons of numerial stability - * Args: - * y: the response vector between -pi and pi - * mu: location parameter vector - * kappa: precision parameter - * Returns: - * a scalar to be added to the log posterior - */ - real von_mises_vector_lpdf(vector y, vector mu, real kappa) { - if (kappa < 100) { - return von_mises_lpdf(y | mu, kappa); - } else { - return normal_lpdf(y | mu, sqrt(1 / kappa)); - } - } + /* von Mises log-PDF of a single response + * for kappa > 100 the normal approximation is used + * for reasons of numerial stability + * Args: + * y: the response vector between -pi and pi + * mu: location parameter vector + * kappa: precision parameter + * Returns: + * a scalar to be added to the log posterior + */ + real von_mises_real_lpdf(real y, real mu, real kappa) { + if (kappa < 100) { + return von_mises_lpdf(y | mu, kappa); + } else { + return normal_lpdf(y | mu, sqrt(1 / kappa)); + } + } + /* von Mises log-PDF of a response vector + * for kappa > 100 the normal approximation is used + * for reasons of numerial stability + * Args: + * y: the response vector between -pi and pi + * mu: location parameter vector + * kappa: precision parameter + * Returns: + * a scalar to be added to the log posterior + */ + real von_mises_vector_lpdf(vector y, vector mu, real kappa) { + if (kappa < 100) { + return von_mises_lpdf(y | mu, kappa); + } else { + return normal_lpdf(y | mu, sqrt(1 / kappa)); + } + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_which_range.stan r-cran-brms-2.17.0/inst/chunks/fun_which_range.stan --- r-cran-brms-2.16.3/inst/chunks/fun_which_range.stan 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_which_range.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,48 +1,48 @@ - /* how many elements are in a range of integers? - * Args: - * x: an integer array - * start: start of the range (inclusive) - * end: end of the range (inclusive) - * Returns: - * a scalar integer - */ - int size_range(int[] x, int start, int end) { - int out = 0; - for (i in 1:size(x)) { - out += (x[i] >= start && x[i] <= end); - } - return out; - } - /* which elements are in a range of integers? - * Args: - * x: an integer array - * start: start of the range (inclusive) - * end: end of the range (inclusive) - * Returns: - * an integer array - */ - int[] which_range(int[] x, int start, int end) { - int out[size_range(x, start, end)]; - int j = 1; - for (i in 1:size(x)) { - if (x[i] >= start && x[i] <= end) { - out[j] = i; - j += 1; - } - } - return out; - } - /* adjust array values to x - start + 1 - * Args: - * x: an integer array - * start: start of the range of values in x (inclusive) - * Returns: - * an integer array - */ - int[] start_at_one(int[] x, int start) { - int out[size(x)]; - for (i in 1:size(x)) { - out[i] = x[i] - start + 1; - } - return out; - } + /* how many elements are in a range of integers? + * Args: + * x: an integer array + * start: start of the range (inclusive) + * end: end of the range (inclusive) + * Returns: + * a scalar integer + */ + int size_range(int[] x, int start, int end) { + int out = 0; + for (i in 1:size(x)) { + out += (x[i] >= start && x[i] <= end); + } + return out; + } + /* which elements are in a range of integers? + * Args: + * x: an integer array + * start: start of the range (inclusive) + * end: end of the range (inclusive) + * Returns: + * an integer array + */ + int[] which_range(int[] x, int start, int end) { + int out[size_range(x, start, end)]; + int j = 1; + for (i in 1:size(x)) { + if (x[i] >= start && x[i] <= end) { + out[j] = i; + j += 1; + } + } + return out; + } + /* adjust array values to x - start + 1 + * Args: + * x: an integer array + * start: start of the range of values in x (inclusive) + * Returns: + * an integer array + */ + int[] start_at_one(int[] x, int start) { + int out[size(x)]; + for (i in 1:size(x)) { + out[i] = x[i] - start + 1; + } + return out; + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_wiener_diffusion.stan r-cran-brms-2.17.0/inst/chunks/fun_wiener_diffusion.stan --- r-cran-brms-2.16.3/inst/chunks/fun_wiener_diffusion.stan 2017-11-13 08:30:32.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_wiener_diffusion.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,19 +1,19 @@ - /* Wiener diffusion log-PDF for a single response - * Args: - * y: reaction time data - * dec: decision data (0 or 1) - * alpha: boundary separation parameter > 0 - * tau: non-decision time parameter > 0 - * beta: initial bias parameter in [0, 1] - * delta: drift rate parameter - * Returns: - * a scalar to be added to the log posterior - */ - real wiener_diffusion_lpdf(real y, int dec, real alpha, - real tau, real beta, real delta) { - if (dec == 1) { - return wiener_lpdf(y | alpha, tau, beta, delta); - } else { - return wiener_lpdf(y | alpha, tau, 1 - beta, - delta); - } - } + /* Wiener diffusion log-PDF for a single response + * Args: + * y: reaction time data + * dec: decision data (0 or 1) + * alpha: boundary separation parameter > 0 + * tau: non-decision time parameter > 0 + * beta: initial bias parameter in [0, 1] + * delta: drift rate parameter + * Returns: + * a scalar to be added to the log posterior + */ + real wiener_diffusion_lpdf(real y, int dec, real alpha, + real tau, real beta, real delta) { + if (dec == 1) { + return wiener_lpdf(y | alpha, tau, beta, delta); + } else { + return wiener_lpdf(y | alpha, tau, 1 - beta, - delta); + } + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_asym_laplace.stan r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_asym_laplace.stan --- r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_asym_laplace.stan 2020-02-27 16:10:02.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_asym_laplace.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,62 +1,62 @@ - /* zero-inflated asymmetric laplace log-PDF for a single response - * Args: - * y: the response value - * mu: location parameter - * sigma: positive scale parameter - * quantile: quantile parameter in (0, 1) - * zi: zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_asym_laplace_lpdf(real y, real mu, real sigma, - real quantile, real zi) { - if (y == 0) { - return bernoulli_lpmf(1 | zi); - } else { - return bernoulli_lpmf(0 | zi) + - asym_laplace_lpdf(y | mu, sigma, quantile); - } - } - /* zero-inflated asymmetric laplace log-PDF for a single response - * Args: - * y: the response value - * mu: location parameter - * sigma: positive scale parameter - * quantile: quantile parameter in (0, 1) - * zi: linear predictor of the zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_asym_laplace_logit_lpdf(real y, real mu, real sigma, - real quantile, real zi) { - if (y == 0) { - return bernoulli_logit_lpmf(1 | zi); - } else { - return bernoulli_logit_lpmf(0 | zi) + - asym_laplace_lpdf(y | mu, sigma, quantile); - } - } - // zero-inflated asymmetric laplace log-CDF function - real zero_inflated_asym_laplace_lcdf(real y, real mu, real sigma, - real quantile, real zi) { - if (y < 0) { - return bernoulli_lpmf(0 | zi) + - asym_laplace_lcdf(y | mu, sigma, quantile); - } else { - return log_sum_exp(bernoulli_lpmf(1 | zi), - bernoulli_lpmf(0 | zi) + - asym_laplace_lcdf(y | mu, sigma, quantile)); - } - } - // zero-inflated asymmetric laplace log-CCDF function - real zero_inflated_asym_laplace_lccdf(real y, real mu, real sigma, - real quantile, real zi) { - if (y > 0) { - return bernoulli_lpmf(0 | zi) + - asym_laplace_lccdf(y | mu, sigma, quantile); - } else { - return log_sum_exp(bernoulli_lpmf(1 | zi), - bernoulli_lpmf(0 | zi) + - asym_laplace_lccdf(y | mu, sigma, quantile)); - } - } + /* zero-inflated asymmetric laplace log-PDF for a single response + * Args: + * y: the response value + * mu: location parameter + * sigma: positive scale parameter + * quantile: quantile parameter in (0, 1) + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_asym_laplace_lpdf(real y, real mu, real sigma, + real quantile, real zi) { + if (y == 0) { + return bernoulli_lpmf(1 | zi); + } else { + return bernoulli_lpmf(0 | zi) + + asym_laplace_lpdf(y | mu, sigma, quantile); + } + } + /* zero-inflated asymmetric laplace log-PDF for a single response + * Args: + * y: the response value + * mu: location parameter + * sigma: positive scale parameter + * quantile: quantile parameter in (0, 1) + * zi: linear predictor of the zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_asym_laplace_logit_lpdf(real y, real mu, real sigma, + real quantile, real zi) { + if (y == 0) { + return bernoulli_logit_lpmf(1 | zi); + } else { + return bernoulli_logit_lpmf(0 | zi) + + asym_laplace_lpdf(y | mu, sigma, quantile); + } + } + // zero-inflated asymmetric laplace log-CDF function + real zero_inflated_asym_laplace_lcdf(real y, real mu, real sigma, + real quantile, real zi) { + if (y < 0) { + return bernoulli_lpmf(0 | zi) + + asym_laplace_lcdf(y | mu, sigma, quantile); + } else { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + asym_laplace_lcdf(y | mu, sigma, quantile)); + } + } + // zero-inflated asymmetric laplace log-CCDF function + real zero_inflated_asym_laplace_lccdf(real y, real mu, real sigma, + real quantile, real zi) { + if (y > 0) { + return bernoulli_lpmf(0 | zi) + + asym_laplace_lccdf(y | mu, sigma, quantile); + } else { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + asym_laplace_lccdf(y | mu, sigma, quantile)); + } + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_beta_binomial.stan r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_beta_binomial.stan --- r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_beta_binomial.stan 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_beta_binomial.stan 2022-04-08 12:23:23.000000000 +0000 @@ -0,0 +1,58 @@ + /* zero-inflated beta-binomial log-PDF of a single response + * Args: + * y: the response value + * trials: number of trials of the binomial part + * mu: mean parameter of the beta distribution + * phi: precision parameter of the beta distribution + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_beta_binomial_lpmf(int y, int trials, + real mu, real phi, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + beta_binomial_lpmf(0 | trials, + mu * phi, + (1 - mu) * phi)); + } else { + return bernoulli_lpmf(0 | zi) + + beta_binomial_lpmf(y | trials, mu * phi, (1 - mu) * phi); + } + } + /* zero-inflated beta-binomial log-PDF of a single response + * logit parameterization of the zero-inflation part + * Args: + * y: the response value + * trials: number of trials of the binomial part + * mu: mean parameter of the beta distribution + * phi: precision parameter of the beta distribution + * zi: linear predictor for zero-inflation part + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_beta_binomial_logit_lpmf(int y, int trials, + real mu, real phi, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_logit_lpmf(1 | zi), + bernoulli_logit_lpmf(0 | zi) + + beta_binomial_lpmf(0 | trials, + mu * phi, + (1 - mu) * phi)); + } else { + return bernoulli_logit_lpmf(0 | zi) + + beta_binomial_lpmf(y | trials, mu * phi, (1 - mu) * phi); + } + } + // zero-inflated beta-binomial log-CCDF and log-CDF functions + real zero_inflated_beta_binomial_lccdf(int y, int trials, real mu, real phi, + real zi) { + return bernoulli_lpmf(0 | zi) + beta_binomial_lccdf(y | trials, + mu * phi, + (1 - mu) * phi); + } + real zero_inflated_beta_binomial_lcdf(int y, int trials, real mu, real phi, + real zi) { + return log1m_exp(zero_inflated_beta_binomial_lccdf(y | trials, mu, phi, zi)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_beta.stan r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_beta.stan --- r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_beta.stan 2018-05-17 23:17:59.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_beta.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,45 +1,45 @@ - /* zero-inflated beta log-PDF of a single response - * Args: - * y: the response value - * mu: mean parameter of the beta distribution - * phi: precision parameter of the beta distribution - * zi: zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_beta_lpdf(real y, real mu, real phi, real zi) { - row_vector[2] shape = [mu * phi, (1 - mu) * phi]; - if (y == 0) { - return bernoulli_lpmf(1 | zi); - } else { - return bernoulli_lpmf(0 | zi) + - beta_lpdf(y | shape[1], shape[2]); - } - } - /* zero-inflated beta log-PDF of a single response - * logit parameterization of the zero-inflation part - * Args: - * y: the response value - * mu: mean parameter of the beta distribution - * phi: precision parameter of the beta distribution - * zi: linear predictor for zero-inflation part - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_beta_logit_lpdf(real y, real mu, real phi, real zi) { - row_vector[2] shape = [mu * phi, (1 - mu) * phi]; - if (y == 0) { - return bernoulli_logit_lpmf(1 | zi); - } else { - return bernoulli_logit_lpmf(0 | zi) + - beta_lpdf(y | shape[1], shape[2]); - } - } - // zero-inflated beta log-CCDF and log-CDF functions - real zero_inflated_beta_lccdf(real y, real mu, real phi, real zi) { - row_vector[2] shape = [mu * phi, (1 - mu) * phi]; - return bernoulli_lpmf(0 | zi) + beta_lccdf(y | shape[1], shape[2]); - } - real zero_inflated_beta_lcdf(real y, real mu, real phi, real zi) { - return log1m_exp(zero_inflated_beta_lccdf(y | mu, phi, zi)); - } + /* zero-inflated beta log-PDF of a single response + * Args: + * y: the response value + * mu: mean parameter of the beta distribution + * phi: precision parameter of the beta distribution + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_beta_lpdf(real y, real mu, real phi, real zi) { + row_vector[2] shape = [mu * phi, (1 - mu) * phi]; + if (y == 0) { + return bernoulli_lpmf(1 | zi); + } else { + return bernoulli_lpmf(0 | zi) + + beta_lpdf(y | shape[1], shape[2]); + } + } + /* zero-inflated beta log-PDF of a single response + * logit parameterization of the zero-inflation part + * Args: + * y: the response value + * mu: mean parameter of the beta distribution + * phi: precision parameter of the beta distribution + * zi: linear predictor for zero-inflation part + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_beta_logit_lpdf(real y, real mu, real phi, real zi) { + row_vector[2] shape = [mu * phi, (1 - mu) * phi]; + if (y == 0) { + return bernoulli_logit_lpmf(1 | zi); + } else { + return bernoulli_logit_lpmf(0 | zi) + + beta_lpdf(y | shape[1], shape[2]); + } + } + // zero-inflated beta log-CCDF and log-CDF functions + real zero_inflated_beta_lccdf(real y, real mu, real phi, real zi) { + row_vector[2] shape = [mu * phi, (1 - mu) * phi]; + return bernoulli_lpmf(0 | zi) + beta_lccdf(y | shape[1], shape[2]); + } + real zero_inflated_beta_lcdf(real y, real mu, real phi, real zi) { + return log1m_exp(zero_inflated_beta_lccdf(y | mu, phi, zi)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_binomial.stan r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_binomial.stan --- r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_binomial.stan 2018-05-17 23:05:06.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_binomial.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,91 +1,91 @@ - /* zero-inflated binomial log-PDF of a single response - * Args: - * y: the response value - * trials: number of trials of the binomial part - * theta: probability parameter of the binomial part - * zi: zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_binomial_lpmf(int y, int trials, - real theta, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_lpmf(1 | zi), - bernoulli_lpmf(0 | zi) + - binomial_lpmf(0 | trials, theta)); - } else { - return bernoulli_lpmf(0 | zi) + - binomial_lpmf(y | trials, theta); - } - } - /* zero-inflated binomial log-PDF of a single response - * logit parameterization of the zero-inflation part - * Args: - * y: the response value - * trials: number of trials of the binomial part - * theta: probability parameter of the binomial part - * zi: linear predictor for zero-inflation part - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_binomial_logit_lpmf(int y, int trials, - real theta, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_logit_lpmf(1 | zi), - bernoulli_logit_lpmf(0 | zi) + - binomial_lpmf(0 | trials, theta)); - } else { - return bernoulli_logit_lpmf(0 | zi) + - binomial_lpmf(y | trials, theta); - } - } - /* zero-inflated binomial log-PDF of a single response - * logit parameterization of the binomial part - * Args: - * y: the response value - * trials: number of trials of the binomial part - * eta: linear predictor for binomial part - * zi: zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_binomial_blogit_lpmf(int y, int trials, - real eta, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_lpmf(1 | zi), - bernoulli_lpmf(0 | zi) + - binomial_logit_lpmf(0 | trials, eta)); - } else { - return bernoulli_lpmf(0 | zi) + - binomial_logit_lpmf(y | trials, eta); - } - } - /* zero-inflated binomial log-PDF of a single response - * logit parameterization of the binomial part - * logit parameterization of the zero-inflation part - * Args: - * y: the response value - * trials: number of trials of the binomial part - * eta: linear predictor for binomial part - * zi: linear predictor for zero-inflation part - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_binomial_blogit_logit_lpmf(int y, int trials, - real eta, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_logit_lpmf(1 | zi), - bernoulli_logit_lpmf(0 | zi) + - binomial_logit_lpmf(0 | trials, eta)); - } else { - return bernoulli_logit_lpmf(0 | zi) + - binomial_logit_lpmf(y | trials, eta); - } - } - // zero-inflated binomial log-CCDF and log-CDF functions - real zero_inflated_binomial_lccdf(int y, int trials, real theta, real zi) { - return bernoulli_lpmf(0 | zi) + binomial_lccdf(y | trials, theta); - } - real zero_inflated_binomial_lcdf(int y, int trials, real theta, real zi) { - return log1m_exp(zero_inflated_binomial_lccdf(y | trials, theta, zi)); - } + /* zero-inflated binomial log-PDF of a single response + * Args: + * y: the response value + * trials: number of trials of the binomial part + * theta: probability parameter of the binomial part + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_binomial_lpmf(int y, int trials, + real theta, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + binomial_lpmf(0 | trials, theta)); + } else { + return bernoulli_lpmf(0 | zi) + + binomial_lpmf(y | trials, theta); + } + } + /* zero-inflated binomial log-PDF of a single response + * logit parameterization of the zero-inflation part + * Args: + * y: the response value + * trials: number of trials of the binomial part + * theta: probability parameter of the binomial part + * zi: linear predictor for zero-inflation part + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_binomial_logit_lpmf(int y, int trials, + real theta, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_logit_lpmf(1 | zi), + bernoulli_logit_lpmf(0 | zi) + + binomial_lpmf(0 | trials, theta)); + } else { + return bernoulli_logit_lpmf(0 | zi) + + binomial_lpmf(y | trials, theta); + } + } + /* zero-inflated binomial log-PDF of a single response + * logit parameterization of the binomial part + * Args: + * y: the response value + * trials: number of trials of the binomial part + * eta: linear predictor for binomial part + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_binomial_blogit_lpmf(int y, int trials, + real eta, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + binomial_logit_lpmf(0 | trials, eta)); + } else { + return bernoulli_lpmf(0 | zi) + + binomial_logit_lpmf(y | trials, eta); + } + } + /* zero-inflated binomial log-PDF of a single response + * logit parameterization of the binomial part + * logit parameterization of the zero-inflation part + * Args: + * y: the response value + * trials: number of trials of the binomial part + * eta: linear predictor for binomial part + * zi: linear predictor for zero-inflation part + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_binomial_blogit_logit_lpmf(int y, int trials, + real eta, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_logit_lpmf(1 | zi), + bernoulli_logit_lpmf(0 | zi) + + binomial_logit_lpmf(0 | trials, eta)); + } else { + return bernoulli_logit_lpmf(0 | zi) + + binomial_logit_lpmf(y | trials, eta); + } + } + // zero-inflated binomial log-CCDF and log-CDF functions + real zero_inflated_binomial_lccdf(int y, int trials, real theta, real zi) { + return bernoulli_lpmf(0 | zi) + binomial_lccdf(y | trials, theta); + } + real zero_inflated_binomial_lcdf(int y, int trials, real theta, real zi) { + return log1m_exp(zero_inflated_binomial_lccdf(y | trials, theta, zi)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_negbinomial.stan r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_negbinomial.stan --- r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_negbinomial.stan 2018-05-17 23:02:54.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_negbinomial.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,91 +1,91 @@ - /* zero-inflated negative binomial log-PDF of a single response - * Args: - * y: the response value - * mu: mean parameter of negative binomial distribution - * phi: shape parameter of negative binomial distribution - * zi: zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_neg_binomial_lpmf(int y, real mu, real phi, - real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_lpmf(1 | zi), - bernoulli_lpmf(0 | zi) + - neg_binomial_2_lpmf(0 | mu, phi)); - } else { - return bernoulli_lpmf(0 | zi) + - neg_binomial_2_lpmf(y | mu, phi); - } - } - /* zero-inflated negative binomial log-PDF of a single response - * logit parameterization of the zero-inflation part - * Args: - * y: the response value - * mu: mean parameter of negative binomial distribution - * phi: shape parameter of negative binomial distribution - * zi: linear predictor for zero-inflation part - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_neg_binomial_logit_lpmf(int y, real mu, - real phi, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_logit_lpmf(1 | zi), - bernoulli_logit_lpmf(0 | zi) + - neg_binomial_2_lpmf(0 | mu, phi)); - } else { - return bernoulli_logit_lpmf(0 | zi) + - neg_binomial_2_lpmf(y | mu, phi); - } - } - /* zero-inflated negative binomial log-PDF of a single response - * log parameterization for the negative binomial part - * Args: - * y: the response value - * eta: linear predictor for negative binomial distribution - * phi: shape parameter of negative binomial distribution - * zi: zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_neg_binomial_log_lpmf(int y, real eta, - real phi, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_lpmf(1 | zi), - bernoulli_lpmf(0 | zi) + - neg_binomial_2_log_lpmf(0 | eta, phi)); - } else { - return bernoulli_lpmf(0 | zi) + - neg_binomial_2_log_lpmf(y | eta, phi); - } - } - /* zero-inflated negative binomial log-PDF of a single response - * log parameterization for the negative binomial part - * logit parameterization of the zero-inflation part - * Args: - * y: the response value - * eta: linear predictor for negative binomial distribution - * phi: shape parameter of negative binomial distribution - * zi: linear predictor for zero-inflation part - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_neg_binomial_log_logit_lpmf(int y, real eta, - real phi, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_logit_lpmf(1 | zi), - bernoulli_logit_lpmf(0 | zi) + - neg_binomial_2_log_lpmf(0 | eta, phi)); - } else { - return bernoulli_logit_lpmf(0 | zi) + - neg_binomial_2_log_lpmf(y | eta, phi); - } - } - // zero_inflated negative binomial log-CCDF and log-CDF functions - real zero_inflated_neg_binomial_lccdf(int y, real mu, real phi, real hu) { - return bernoulli_lpmf(0 | hu) + neg_binomial_2_lccdf(y | mu, phi); - } - real zero_inflated_neg_binomial_lcdf(int y, real mu, real phi, real hu) { - return log1m_exp(zero_inflated_neg_binomial_lccdf(y | mu, phi, hu)); - } + /* zero-inflated negative binomial log-PDF of a single response + * Args: + * y: the response value + * mu: mean parameter of negative binomial distribution + * phi: shape parameter of negative binomial distribution + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_neg_binomial_lpmf(int y, real mu, real phi, + real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + neg_binomial_2_lpmf(0 | mu, phi)); + } else { + return bernoulli_lpmf(0 | zi) + + neg_binomial_2_lpmf(y | mu, phi); + } + } + /* zero-inflated negative binomial log-PDF of a single response + * logit parameterization of the zero-inflation part + * Args: + * y: the response value + * mu: mean parameter of negative binomial distribution + * phi: shape parameter of negative binomial distribution + * zi: linear predictor for zero-inflation part + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_neg_binomial_logit_lpmf(int y, real mu, + real phi, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_logit_lpmf(1 | zi), + bernoulli_logit_lpmf(0 | zi) + + neg_binomial_2_lpmf(0 | mu, phi)); + } else { + return bernoulli_logit_lpmf(0 | zi) + + neg_binomial_2_lpmf(y | mu, phi); + } + } + /* zero-inflated negative binomial log-PDF of a single response + * log parameterization for the negative binomial part + * Args: + * y: the response value + * eta: linear predictor for negative binomial distribution + * phi: shape parameter of negative binomial distribution + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_neg_binomial_log_lpmf(int y, real eta, + real phi, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + neg_binomial_2_log_lpmf(0 | eta, phi)); + } else { + return bernoulli_lpmf(0 | zi) + + neg_binomial_2_log_lpmf(y | eta, phi); + } + } + /* zero-inflated negative binomial log-PDF of a single response + * log parameterization for the negative binomial part + * logit parameterization of the zero-inflation part + * Args: + * y: the response value + * eta: linear predictor for negative binomial distribution + * phi: shape parameter of negative binomial distribution + * zi: linear predictor for zero-inflation part + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_neg_binomial_log_logit_lpmf(int y, real eta, + real phi, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_logit_lpmf(1 | zi), + bernoulli_logit_lpmf(0 | zi) + + neg_binomial_2_log_lpmf(0 | eta, phi)); + } else { + return bernoulli_logit_lpmf(0 | zi) + + neg_binomial_2_log_lpmf(y | eta, phi); + } + } + // zero_inflated negative binomial log-CCDF and log-CDF functions + real zero_inflated_neg_binomial_lccdf(int y, real mu, real phi, real hu) { + return bernoulli_lpmf(0 | hu) + neg_binomial_2_lccdf(y | mu, phi); + } + real zero_inflated_neg_binomial_lcdf(int y, real mu, real phi, real hu) { + return log1m_exp(zero_inflated_neg_binomial_lccdf(y | mu, phi, hu)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_poisson.stan r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_poisson.stan --- r-cran-brms-2.16.3/inst/chunks/fun_zero_inflated_poisson.stan 2018-05-17 23:01:52.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_zero_inflated_poisson.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,83 +1,83 @@ - /* zero-inflated poisson log-PDF of a single response - * Args: - * y: the response value - * lambda: mean parameter of the poisson distribution - * zi: zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_poisson_lpmf(int y, real lambda, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_lpmf(1 | zi), - bernoulli_lpmf(0 | zi) + - poisson_lpmf(0 | lambda)); - } else { - return bernoulli_lpmf(0 | zi) + - poisson_lpmf(y | lambda); - } - } - /* zero-inflated poisson log-PDF of a single response - * logit parameterization of the zero-inflation part - * Args: - * y: the response value - * lambda: mean parameter of the poisson distribution - * zi: linear predictor for zero-inflation part - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_poisson_logit_lpmf(int y, real lambda, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_logit_lpmf(1 | zi), - bernoulli_logit_lpmf(0 | zi) + - poisson_lpmf(0 | lambda)); - } else { - return bernoulli_logit_lpmf(0 | zi) + - poisson_lpmf(y | lambda); - } - } - /* zero-inflated poisson log-PDF of a single response - * log parameterization for the poisson part - * Args: - * y: the response value - * eta: linear predictor for poisson distribution - * zi: zero-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_poisson_log_lpmf(int y, real eta, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_lpmf(1 | zi), - bernoulli_lpmf(0 | zi) + - poisson_log_lpmf(0 | eta)); - } else { - return bernoulli_lpmf(0 | zi) + - poisson_log_lpmf(y | eta); - } - } - /* zero-inflated poisson log-PDF of a single response - * log parameterization for the poisson part - * logit parameterization of the zero-inflation part - * Args: - * y: the response value - * eta: linear predictor for poisson distribution - * zi: linear predictor for zero-inflation part - * Returns: - * a scalar to be added to the log posterior - */ - real zero_inflated_poisson_log_logit_lpmf(int y, real eta, real zi) { - if (y == 0) { - return log_sum_exp(bernoulli_logit_lpmf(1 | zi), - bernoulli_logit_lpmf(0 | zi) + - poisson_log_lpmf(0 | eta)); - } else { - return bernoulli_logit_lpmf(0 | zi) + - poisson_log_lpmf(y | eta); - } - } - // zero-inflated poisson log-CCDF and log-CDF functions - real zero_inflated_poisson_lccdf(int y, real lambda, real zi) { - return bernoulli_lpmf(0 | zi) + poisson_lccdf(y | lambda); - } - real zero_inflated_poisson_lcdf(int y, real lambda, real zi) { - return log1m_exp(zero_inflated_poisson_lccdf(y | lambda, zi)); - } + /* zero-inflated poisson log-PDF of a single response + * Args: + * y: the response value + * lambda: mean parameter of the poisson distribution + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_poisson_lpmf(int y, real lambda, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + poisson_lpmf(0 | lambda)); + } else { + return bernoulli_lpmf(0 | zi) + + poisson_lpmf(y | lambda); + } + } + /* zero-inflated poisson log-PDF of a single response + * logit parameterization of the zero-inflation part + * Args: + * y: the response value + * lambda: mean parameter of the poisson distribution + * zi: linear predictor for zero-inflation part + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_poisson_logit_lpmf(int y, real lambda, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_logit_lpmf(1 | zi), + bernoulli_logit_lpmf(0 | zi) + + poisson_lpmf(0 | lambda)); + } else { + return bernoulli_logit_lpmf(0 | zi) + + poisson_lpmf(y | lambda); + } + } + /* zero-inflated poisson log-PDF of a single response + * log parameterization for the poisson part + * Args: + * y: the response value + * eta: linear predictor for poisson distribution + * zi: zero-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_poisson_log_lpmf(int y, real eta, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_lpmf(1 | zi), + bernoulli_lpmf(0 | zi) + + poisson_log_lpmf(0 | eta)); + } else { + return bernoulli_lpmf(0 | zi) + + poisson_log_lpmf(y | eta); + } + } + /* zero-inflated poisson log-PDF of a single response + * log parameterization for the poisson part + * logit parameterization of the zero-inflation part + * Args: + * y: the response value + * eta: linear predictor for poisson distribution + * zi: linear predictor for zero-inflation part + * Returns: + * a scalar to be added to the log posterior + */ + real zero_inflated_poisson_log_logit_lpmf(int y, real eta, real zi) { + if (y == 0) { + return log_sum_exp(bernoulli_logit_lpmf(1 | zi), + bernoulli_logit_lpmf(0 | zi) + + poisson_log_lpmf(0 | eta)); + } else { + return bernoulli_logit_lpmf(0 | zi) + + poisson_log_lpmf(y | eta); + } + } + // zero-inflated poisson log-CCDF and log-CDF functions + real zero_inflated_poisson_lccdf(int y, real lambda, real zi) { + return bernoulli_lpmf(0 | zi) + poisson_lccdf(y | lambda); + } + real zero_inflated_poisson_lcdf(int y, real lambda, real zi) { + return log1m_exp(zero_inflated_poisson_lccdf(y | lambda, zi)); + } diff -Nru r-cran-brms-2.16.3/inst/chunks/fun_zero_one_inflated_beta.stan r-cran-brms-2.17.0/inst/chunks/fun_zero_one_inflated_beta.stan --- r-cran-brms-2.16.3/inst/chunks/fun_zero_one_inflated_beta.stan 2018-05-17 23:17:36.000000000 +0000 +++ r-cran-brms-2.17.0/inst/chunks/fun_zero_one_inflated_beta.stan 2022-03-13 16:10:29.000000000 +0000 @@ -1,21 +1,21 @@ - /* zero-one-inflated beta log-PDF of a single response - * Args: - * y: response value - * mu: mean parameter of the beta part - * phi: precision parameter of the beta part - * zoi: zero-one-inflation probability - * coi: conditional one-inflation probability - * Returns: - * a scalar to be added to the log posterior - */ - real zero_one_inflated_beta_lpdf(real y, real mu, real phi, - real zoi, real coi) { - row_vector[2] shape = [mu * phi, (1 - mu) * phi]; - if (y == 0) { - return bernoulli_lpmf(1 | zoi) + bernoulli_lpmf(0 | coi); - } else if (y == 1) { - return bernoulli_lpmf(1 | zoi) + bernoulli_lpmf(1 | coi); - } else { - return bernoulli_lpmf(0 | zoi) + beta_lpdf(y | shape[1], shape[2]); - } - } + /* zero-one-inflated beta log-PDF of a single response + * Args: + * y: response value + * mu: mean parameter of the beta part + * phi: precision parameter of the beta part + * zoi: zero-one-inflation probability + * coi: conditional one-inflation probability + * Returns: + * a scalar to be added to the log posterior + */ + real zero_one_inflated_beta_lpdf(real y, real mu, real phi, + real zoi, real coi) { + row_vector[2] shape = [mu * phi, (1 - mu) * phi]; + if (y == 0) { + return bernoulli_lpmf(1 | zoi) + bernoulli_lpmf(0 | coi); + } else if (y == 1) { + return bernoulli_lpmf(1 | zoi) + bernoulli_lpmf(1 | coi); + } else { + return bernoulli_lpmf(0 | zoi) + beta_lpdf(y | shape[1], shape[2]); + } + } diff -Nru r-cran-brms-2.16.3/inst/CITATION r-cran-brms-2.17.0/inst/CITATION --- r-cran-brms-2.16.3/inst/CITATION 2021-11-22 15:31:05.000000000 +0000 +++ r-cran-brms-2.17.0/inst/CITATION 2022-03-13 16:10:29.000000000 +0000 @@ -26,7 +26,7 @@ year = "2018", volume = "10", number = "1", - pages = "395--411", + pages = "395--411", doi = "10.32614/RJ-2018-017", textVersion = paste( "Paul-Christian Bürkner (2018).", diff -Nru r-cran-brms-2.16.3/inst/doc/brms_customfamilies.html r-cran-brms-2.17.0/inst/doc/brms_customfamilies.html --- r-cran-brms-2.16.3/inst/doc/brms_customfamilies.html 2021-11-22 15:44:23.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_customfamilies.html 2022-04-11 07:55:14.000000000 +0000 @@ -1,392 +1,393 @@ - - - - - - - - - - - - - - - - -Define Custom Response Distributions with brms - - - - - - - - - - - - - - - - - - - - - - - - - -

Define Custom Response Distributions with brms

-

Paul Bürkner

-

2021-11-22

- - - - -
-

Introduction

-

The brms package comes with a lot of built-in response distributions – usually called families in R – to specify among others linear, count data, survival, response times, or ordinal models (see help(brmsfamily) for an overview). Despite supporting over two dozen families, there is still a long list of distributions, which are not natively supported. The present vignette will explain how to specify such custom families in brms. By doing that, users can benefit from the modeling flexibility and post-processing options of brms even when using self-defined response distributions. If you have built a custom family that you want to make available to other users, you can submit a pull request to this GitHub repository.

-
-
-

A Case Study

-

As a case study, we will use the cbpp data of the lme4 package, which describes the development of the CBPP disease of cattle in Africa. The data set contains four variables: period (the time period), herd (a factor identifying the cattle herd), incidence (number of new disease cases for a given herd and time period), as well as size (the herd size at the beginning of a given time period).

-
data("cbpp", package = "lme4")
-head(cbpp)
-
  herd incidence size period
-1    1         2   14      1
-2    1         3   12      2
-3    1         4    9      3
-4    1         0    5      4
-5    2         3   22      1
-6    2         1   18      2
-

In a first step, we will be predicting incidence using a simple binomial model, which will serve as our baseline model. For observed number of events \(y\) (incidence in our case) and total number of trials \(T\) (size), the probability mass function of the binomial distribution is defined as

-

\[ -P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} -\]

-

where \(p\) is the event probability. In the classical binomial model, we will directly predict \(p\) on the logit-scale, which means that for each observation \(i\) we compute the success probability \(p_i\) as

-

\[ -p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} -\]

-

where \(\eta_i\) is the linear predictor term of observation \(i\) (see vignette("brms_overview") for more details on linear predictors in brms). Predicting incidence by period and a varying intercept of herd is straight forward in brms:

-
fit1 <- brm(incidence | trials(size) ~ period + (1|herd), 
-            data = cbpp, family = binomial())
-

In the summary output, we see that the incidence probability varies substantially over herds, but reduces over the course of the time as indicated by the negative coefficients of period.

-
summary(fit1)
-
 Family: binomial 
-  Links: mu = logit 
-Formula: incidence | trials(size) ~ period + (1 | herd) 
-   Data: cbpp (Number of observations: 56) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Group-Level Effects: 
-~herd (Number of levels: 15) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     0.76      0.23     0.39     1.31 1.00     1445     2015
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    -1.41      0.26    -1.96    -0.91 1.00     2105     2262
-period2      -1.00      0.31    -1.62    -0.40 1.00     4299     3017
-period3      -1.15      0.34    -1.84    -0.49 1.00     4247     3127
-period4      -1.62      0.42    -2.48    -0.85 1.00     4449     2833
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

A drawback of the binomial model is that – after taking into account the linear predictor – its variance is fixed to \(\text{Var}(y_i) = T_i p_i (1 - p_i)\). All variance exceeding this value cannot be not taken into account by the model. There are multiple ways of dealing with this so called overdispersion and the solution described below will serve as an illustrative example of how to define custom families in brms.

-
-
-

The Beta-Binomial Distribution

-

The beta-binomial model is a generalization of the binomial model with an additional parameter to account for overdispersion. In the beta-binomial model, we do not predict the binomial probability \(p_i\) directly, but assume it to be beta distributed with hyperparameters \(\alpha > 0\) and \(\beta > 0\):

-

\[ -p_i \sim \text{Beta}(\alpha_i, \beta_i) -\]

-

The \(\alpha\) and \(\beta\) parameters are both hard to interpret and generally not recommended for use in regression models. Thus, we will apply a different parameterization with parameters \(\mu \in [0, 1]\) and \(\phi > 0\), which we will call \(\text{Beta2}\):

-

\[ -\text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) -\]

-

The parameters \(\mu\) and \(\phi\) specify the mean and precision parameter, respectively. By defining

-

\[ -\mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} -\]

-

we still predict the expected probability by means of our transformed linear predictor (as in the original binomial model), but account for potential overdispersion via the parameter \(\phi\).

-
-
-

Fitting Custom Family Models

-

The beta-binomial distribution is not natively supported in brms and so we will have to define it ourselves using the custom_family function. This function requires the family’s name, the names of its parameters (mu and phi in our case), corresponding link functions (only applied if parameters are predicted), their theoretical lower and upper bounds (only applied if parameters are not predicted), information on whether the distribution is discrete or continuous, and finally, whether additional non-parameter variables need to be passed to the distribution. For our beta-binomial example, this results in the following custom family:

-
beta_binomial2 <- custom_family(
-  "beta_binomial2", dpars = c("mu", "phi"),
-  links = c("logit", "log"), lb = c(NA, 0),
-  type = "int", vars = "vint1[n]"
-)
-

The name vint1 for the variable containing the number of trials is not chosen arbitrarily as we will see below. Next, we have to provide the relevant Stan functions if the distribution is not defined in Stan itself. For the beta_binomial2 distribution, this is straight forward since the ordinal beta_binomial distribution is already implemented.

-
stan_funs <- "
-  real beta_binomial2_lpmf(int y, real mu, real phi, int T) {
-    return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi);
-  }
-  int beta_binomial2_rng(real mu, real phi, int T) {
-    return beta_binomial_rng(T, mu * phi, (1 - mu) * phi);
-  }
-"
-

For the model fitting, we will only need beta_binomial2_lpmf, but beta_binomial2_rng will come in handy when it comes to post-processing. We define:

-
stanvars <- stanvar(scode = stan_funs, block = "functions")
-

To provide information about the number of trials (an integer variable), we are going to use the addition argument vint(), which can only be used in custom families. Similarly, if we needed to include additional vectors of real data, we would use vreal(). Actually, for this particular example, we could more elegantly apply the addition argument trials() instead of vint()as in the basic binomial model. However, since the present vignette is meant to give a general overview of the topic, we will go with the more general method.

-

We now have all components together to fit our custom beta-binomial model:

-
fit2 <- brm(
-  incidence | vint(size) ~ period + (1|herd), data = cbpp, 
-  family = beta_binomial2, stanvars = stanvars
-)
-

The summary output reveals that the uncertainty in the coefficients of period is somewhat larger than in the basic binomial model, which is the result of including the overdispersion parameter phi in the model. Apart from that, the results looks pretty similar.

-
summary(fit2)
-
 Family: beta_binomial2 
-  Links: mu = logit; phi = identity 
-Formula: incidence | vint(size) ~ period + (1 | herd) 
-   Data: cbpp (Number of observations: 56) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Group-Level Effects: 
-~herd (Number of levels: 15) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     0.38      0.26     0.02     0.95 1.00     1217     1803
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    -1.33      0.25    -1.85    -0.87 1.00     4229     2921
-period2      -1.02      0.41    -1.84    -0.24 1.00     4213     2908
-period3      -1.27      0.45    -2.21    -0.41 1.00     4187     2754
-period4      -1.55      0.53    -2.67    -0.60 1.00     4286     2988
-
-Family Specific Parameters: 
-    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-phi    17.58     20.67     5.50    58.12 1.00     1750     1189
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
-
-

Post-Processing Custom Family Models

-

Some post-processing methods such as summary or plot work out of the box for custom family models. However, there are three particularly important methods, which require additional input by the user. These are posterior_epred, posterior_predict and log_lik computing predicted mean values, predicted response values, and log-likelihood values, respectively. They are not only relevant for their own sake, but also provide the basis of many other post-processing methods. For instance, we may be interested in comparing the fit of the binomial model with that of the beta-binomial model by means of approximate leave-one-out cross-validation implemented in method loo, which in turn requires log_lik to be working.

-

The log_lik function of a family should be named log_lik_<family-name> and have the two arguments i (indicating observations) and prep. You don’t have to worry too much about how prep is created (if you are interested, check out the prepare_predictions function). Instead, all you need to know is that parameters are stored in slot dpars and data are stored in slot data. Generally, parameters take on the form of a \(S \times N\) matrix (with \(S =\) number of posterior draws and \(N =\) number of observations) if they are predicted (as is mu in our example) and a vector of size \(N\) if the are not predicted (as is phi).

-

We could define the complete log-likelihood function in R directly, or we can expose the self-defined Stan functions and apply them. The latter approach is usually more convenient, but the former is more stable and the only option when implementing custom families in other R packages building upon brms. For the purpose of the present vignette, we will go with the latter approach.

-
expose_functions(fit2, vectorize = TRUE)
-

and define the required log_lik functions with a few lines of code.

-
log_lik_beta_binomial2 <- function(i, prep) {
-  mu <- brms::get_dpar(prep, "mu", i = i)
-  phi <- brms::get_dpar(prep, "phi", i = i)
-  trials <- prep$data$vint1[i]
-  y <- prep$data$Y[i]
-  beta_binomial2_lpmf(y, mu, phi, trials)
-}
-

The get_dpar function will do the necessary transformations to handle both the case when the distributional parameters are predicted separately for each row and when they are the same for the whole fit.

-

With that being done, all of the post-processing methods requiring log_lik will work as well. For instance, model comparison can simply be performed via

-
loo(fit1, fit2)
-
Output of model 'fit1':
-
-Computed from 4000 by 56 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -100.1 10.2
-p_loo        22.4  4.3
-looic       200.3 20.4
-------
-Monte Carlo SE of elpd_loo is NA.
-
-Pareto k diagnostic values:
-                         Count Pct.    Min. n_eff
-(-Inf, 0.5]   (good)     40    71.4%   915       
- (0.5, 0.7]   (ok)       11    19.6%   197       
-   (0.7, 1]   (bad)       5     8.9%   62        
-   (1, Inf)   (very bad)  0     0.0%   <NA>      
-See help('pareto-k-diagnostic') for details.
-
-Output of model 'fit2':
-
-Computed from 4000 by 56 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo    -95.1  8.3
-p_loo        10.8  2.1
-looic       190.1 16.7
-------
-Monte Carlo SE of elpd_loo is NA.
-
-Pareto k diagnostic values:
-                         Count Pct.    Min. n_eff
-(-Inf, 0.5]   (good)     46    82.1%   1119      
- (0.5, 0.7]   (ok)        7    12.5%   785       
-   (0.7, 1]   (bad)       3     5.4%   54        
-   (1, Inf)   (very bad)  0     0.0%   <NA>      
-See help('pareto-k-diagnostic') for details.
-
-Model comparisons:
-     elpd_diff se_diff
-fit2  0.0       0.0   
-fit1 -5.1       4.3
-

Since larger ELPD values indicate better fit, we see that the beta-binomial model fits somewhat better, although the corresponding standard error reveals that the difference is not that substantial.

-

Next, we will define the function necessary for the posterior_predict method:

-
posterior_predict_beta_binomial2 <- function(i, prep, ...) {
-  mu <- brms::get_dpar(prep, "mu", i = i)
-  phi <- brms::get_dpar(prep, "phi", i = i)
-  trials <- prep$data$vint1[i]
-  beta_binomial2_rng(mu, phi, trials)
-}
-

The posterior_predict function looks pretty similar to the corresponding log_lik function, except that we are now creating random draws of the response instead of log-likelihood values. Again, we are using an exposed Stan function for convenience. Make sure to add a ... argument to your posterior_predict function even if you are not using it, since some families require additional arguments. With posterior_predict to be working, we can engage for instance in posterior-predictive checking:

-
pp_check(fit2)
-

-

When defining the posterior_epred function, you have to keep in mind that it has only a prep argument and should compute the mean response values for all observations at once. Since the mean of the beta-binomial distribution is \(\text{E}(y) = \mu T\) definition of the corresponding posterior_epred function is not too complicated, but we need to get the dimension of parameters and data in line.

-
posterior_epred_beta_binomial2 <- function(prep) {
-  mu <- brms::get_dpar(prep, "mu")
-  trials <- prep$data$vint1
-  trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE)
-  mu * trials
-}
-

A post-processing method relying directly on posterior_epred is conditional_effects, which allows to visualize effects of predictors.

-
conditional_effects(fit2, conditions = data.frame(size = 1))
-

-

For ease of interpretation we have set size to 1 so that the y-axis of the above plot indicates probabilities.

-
-
-

Turning a Custom Family into a Native Family

-

Family functions built natively into brms are safer to use and more convenient, as they require much less user input. If you think that your custom family is general enough to be useful to other users, please feel free to open an issue on GitHub so that we can discuss all the details. Provided that we agree it makes sense to implement your family natively in brms, the following steps are required (foo is a placeholder for the family name):

-
    -
  • In family-lists.R, add function .family_foo which should contain basic information about your family (you will find lots of examples for other families there).
    • -
  • In families.R, add family function foo which should be a simple wrapper around .brmsfamily.
    • -
  • In stan-likelihood.R, add function stan_log_lik_foo which provides the likelihood of the family in Stan language.
    • -
  • If necessary, add self-defined Stan functions in separate files under inst/chunks.
    • -
  • Add functions posterior_predict_foo, posterior_epred_foo and log_lik_foo to posterior_predict.R, posterior_epred.R and log_lik.R, respectively.
    • -
  • If necessary, add distribution functions to distributions.R.
    • -
-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Define Custom Response Distributions with brms + + + + + + + + + + + + + + + + + + + + + + + + + +

Define Custom Response Distributions with brms

+

Paul Bürkner

+

2022-04-11

+ + + + +
+

Introduction

+

The brms package comes with a lot of built-in response distributions – usually called families in R – to specify among others linear, count data, survival, response times, or ordinal models (see help(brmsfamily) for an overview). Despite supporting over two dozen families, there is still a long list of distributions, which are not natively supported. The present vignette will explain how to specify such custom families in brms. By doing that, users can benefit from the modeling flexibility and post-processing options of brms even when using self-defined response distributions. If you have built a custom family that you want to make available to other users, you can submit a pull request to this GitHub repository.

+
+
+

A Case Study

+

As a case study, we will use the cbpp data of the lme4 package, which describes the development of the CBPP disease of cattle in Africa. The data set contains four variables: period (the time period), herd (a factor identifying the cattle herd), incidence (number of new disease cases for a given herd and time period), as well as size (the herd size at the beginning of a given time period).

+
data("cbpp", package = "lme4")
+head(cbpp)
+
  herd incidence size period
+1    1         2   14      1
+2    1         3   12      2
+3    1         4    9      3
+4    1         0    5      4
+5    2         3   22      1
+6    2         1   18      2
+

In a first step, we will be predicting incidence using a simple binomial model, which will serve as our baseline model. For observed number of events \(y\) (incidence in our case) and total number of trials \(T\) (size), the probability mass function of the binomial distribution is defined as

+

\[ +P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} +\]

+

where \(p\) is the event probability. In the classical binomial model, we will directly predict \(p\) on the logit-scale, which means that for each observation \(i\) we compute the success probability \(p_i\) as

+

\[ +p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} +\]

+

where \(\eta_i\) is the linear predictor term of observation \(i\) (see vignette("brms_overview") for more details on linear predictors in brms). Predicting incidence by period and a varying intercept of herd is straight forward in brms:

+
fit1 <- brm(incidence | trials(size) ~ period + (1|herd),
+            data = cbpp, family = binomial())
+

In the summary output, we see that the incidence probability varies substantially over herds, but reduces over the course of the time as indicated by the negative coefficients of period.

+
summary(fit1)
+
 Family: binomial 
+  Links: mu = logit 
+Formula: incidence | trials(size) ~ period + (1 | herd) 
+   Data: cbpp (Number of observations: 56) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Group-Level Effects: 
+~herd (Number of levels: 15) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     0.75      0.22     0.40     1.26 1.00     1385     2147
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    -1.41      0.26    -1.95    -0.92 1.00     2022     1969
+period2      -1.00      0.31    -1.63    -0.41 1.00     4988     2916
+period3      -1.14      0.32    -1.80    -0.52 1.00     4683     2938
+period4      -1.62      0.44    -2.58    -0.83 1.00     5154     2885
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

A drawback of the binomial model is that – after taking into account the linear predictor – its variance is fixed to \(\text{Var}(y_i) = T_i p_i (1 - p_i)\). All variance exceeding this value cannot be not taken into account by the model. There are multiple ways of dealing with this so called overdispersion and the solution described below will serve as an illustrative example of how to define custom families in brms.

+
+
+

The Beta-Binomial Distribution

+

The beta-binomial model is a generalization of the binomial model with an additional parameter to account for overdispersion. In the beta-binomial model, we do not predict the binomial probability \(p_i\) directly, but assume it to be beta distributed with hyperparameters \(\alpha > 0\) and \(\beta > 0\):

+

\[ +p_i \sim \text{Beta}(\alpha_i, \beta_i) +\]

+

The \(\alpha\) and \(\beta\) parameters are both hard to interpret and generally not recommended for use in regression models. Thus, we will apply a different parameterization with parameters \(\mu \in [0, 1]\) and \(\phi > 0\), which we will call \(\text{Beta2}\):

+

\[ +\text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) +\]

+

The parameters \(\mu\) and \(\phi\) specify the mean and precision parameter, respectively. By defining

+

\[ +\mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} +\]

+

we still predict the expected probability by means of our transformed linear predictor (as in the original binomial model), but account for potential overdispersion via the parameter \(\phi\).

+
+
+

Fitting Custom Family Models

+

The beta-binomial distribution is natively supported in brms nowadays, but we will still use it as an example to define it ourselves via the custom_family function. This function requires the family’s name, the names of its parameters (mu and phi in our case), corresponding link functions (only applied if parameters are predicted), their theoretical lower and upper bounds (only applied if parameters are not predicted), information on whether the distribution is discrete or continuous, and finally, whether additional non-parameter variables need to be passed to the distribution. For our beta-binomial example, this results in the following custom family:

+
beta_binomial2 <- custom_family(
+  "beta_binomial2", dpars = c("mu", "phi"),
+  links = c("logit", "log"),
+  lb = c(0, 0), ub = c(1, NA),
+  type = "int", vars = "vint1[n]"
+)
+

The name vint1 for the variable containing the number of trials is not chosen arbitrarily as we will see below. Next, we have to provide the relevant Stan functions if the distribution is not defined in Stan itself. For the beta_binomial2 distribution, this is straight forward since the ordinal beta_binomial distribution is already implemented.

+
stan_funs <- "
+  real beta_binomial2_lpmf(int y, real mu, real phi, int T) {
+    return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi);
+  }
+  int beta_binomial2_rng(real mu, real phi, int T) {
+    return beta_binomial_rng(T, mu * phi, (1 - mu) * phi);
+  }
+"
+

For the model fitting, we will only need beta_binomial2_lpmf, but beta_binomial2_rng will come in handy when it comes to post-processing. We define:

+
stanvars <- stanvar(scode = stan_funs, block = "functions")
+

To provide information about the number of trials (an integer variable), we are going to use the addition argument vint(), which can only be used in custom families. Similarly, if we needed to include additional vectors of real data, we would use vreal(). Actually, for this particular example, we could more elegantly apply the addition argument trials() instead of vint()as in the basic binomial model. However, since the present vignette is meant to give a general overview of the topic, we will go with the more general method.

+

We now have all components together to fit our custom beta-binomial model:

+
fit2 <- brm(
+  incidence | vint(size) ~ period + (1|herd), data = cbpp,
+  family = beta_binomial2, stanvars = stanvars
+)
+

The summary output reveals that the uncertainty in the coefficients of period is somewhat larger than in the basic binomial model, which is the result of including the overdispersion parameter phi in the model. Apart from that, the results looks pretty similar.

+
summary(fit2)
+
 Family: beta_binomial2 
+  Links: mu = logit; phi = identity 
+Formula: incidence | vint(size) ~ period + (1 | herd) 
+   Data: cbpp (Number of observations: 56) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Group-Level Effects: 
+~herd (Number of levels: 15) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     0.39      0.27     0.02     1.00 1.00      976     1394
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    -1.34      0.26    -1.88    -0.84 1.00     2715     1400
+period2      -1.01      0.41    -1.84    -0.22 1.00     4116     2970
+period3      -1.26      0.46    -2.24    -0.43 1.00     3842     3053
+period4      -1.54      0.52    -2.63    -0.60 1.00     3688     2141
+
+Family Specific Parameters: 
+    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+phi    17.50     15.15     5.45    58.17 1.01     1414      847
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
+
+

Post-Processing Custom Family Models

+

Some post-processing methods such as summary or plot work out of the box for custom family models. However, there are three particularly important methods, which require additional input by the user. These are posterior_epred, posterior_predict and log_lik computing predicted mean values, predicted response values, and log-likelihood values, respectively. They are not only relevant for their own sake, but also provide the basis of many other post-processing methods. For instance, we may be interested in comparing the fit of the binomial model with that of the beta-binomial model by means of approximate leave-one-out cross-validation implemented in method loo, which in turn requires log_lik to be working.

+

The log_lik function of a family should be named log_lik_<family-name> and have the two arguments i (indicating observations) and prep. You don’t have to worry too much about how prep is created (if you are interested, check out the prepare_predictions function). Instead, all you need to know is that parameters are stored in slot dpars and data are stored in slot data. Generally, parameters take on the form of a \(S \times N\) matrix (with \(S =\) number of posterior draws and \(N =\) number of observations) if they are predicted (as is mu in our example) and a vector of size \(N\) if the are not predicted (as is phi).

+

We could define the complete log-likelihood function in R directly, or we can expose the self-defined Stan functions and apply them. The latter approach is usually more convenient, but the former is more stable and the only option when implementing custom families in other R packages building upon brms. For the purpose of the present vignette, we will go with the latter approach.

+
expose_functions(fit2, vectorize = TRUE)
+

and define the required log_lik functions with a few lines of code.

+
log_lik_beta_binomial2 <- function(i, prep) {
+  mu <- brms::get_dpar(prep, "mu", i = i)
+  phi <- brms::get_dpar(prep, "phi", i = i)
+  trials <- prep$data$vint1[i]
+  y <- prep$data$Y[i]
+  beta_binomial2_lpmf(y, mu, phi, trials)
+}
+

The get_dpar function will do the necessary transformations to handle both the case when the distributional parameters are predicted separately for each row and when they are the same for the whole fit.

+

With that being done, all of the post-processing methods requiring log_lik will work as well. For instance, model comparison can simply be performed via

+
loo(fit1, fit2)
+
Output of model 'fit1':
+
+Computed from 4000 by 56 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -100.4 10.3
+p_loo        22.6  4.4
+looic       200.9 20.6
+------
+Monte Carlo SE of elpd_loo is NA.
+
+Pareto k diagnostic values:
+                         Count Pct.    Min. n_eff
+(-Inf, 0.5]   (good)     40    71.4%   1338      
+ (0.5, 0.7]   (ok)       11    19.6%   188       
+   (0.7, 1]   (bad)       3     5.4%   25        
+   (1, Inf)   (very bad)  2     3.6%   21        
+See help('pareto-k-diagnostic') for details.
+
+Output of model 'fit2':
+
+Computed from 4000 by 56 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo    -95.1  8.3
+p_loo        10.9  2.1
+looic       190.1 16.7
+------
+Monte Carlo SE of elpd_loo is NA.
+
+Pareto k diagnostic values:
+                         Count Pct.    Min. n_eff
+(-Inf, 0.5]   (good)     47    83.9%   1004      
+ (0.5, 0.7]   (ok)        7    12.5%   264       
+   (0.7, 1]   (bad)       1     1.8%   1153      
+   (1, Inf)   (very bad)  1     1.8%   23        
+See help('pareto-k-diagnostic') for details.
+
+Model comparisons:
+     elpd_diff se_diff
+fit2  0.0       0.0   
+fit1 -5.4       4.2
+

Since larger ELPD values indicate better fit, we see that the beta-binomial model fits somewhat better, although the corresponding standard error reveals that the difference is not that substantial.

+

Next, we will define the function necessary for the posterior_predict method:

+
posterior_predict_beta_binomial2 <- function(i, prep, ...) {
+  mu <- brms::get_dpar(prep, "mu", i = i)
+  phi <- brms::get_dpar(prep, "phi", i = i)
+  trials <- prep$data$vint1[i]
+  beta_binomial2_rng(mu, phi, trials)
+}
+

The posterior_predict function looks pretty similar to the corresponding log_lik function, except that we are now creating random draws of the response instead of log-likelihood values. Again, we are using an exposed Stan function for convenience. Make sure to add a ... argument to your posterior_predict function even if you are not using it, since some families require additional arguments. With posterior_predict to be working, we can engage for instance in posterior-predictive checking:

+
pp_check(fit2)
+

+

When defining the posterior_epred function, you have to keep in mind that it has only a prep argument and should compute the mean response values for all observations at once. Since the mean of the beta-binomial distribution is \(\text{E}(y) = \mu T\) definition of the corresponding posterior_epred function is not too complicated, but we need to get the dimension of parameters and data in line.

+
posterior_epred_beta_binomial2 <- function(prep) {
+  mu <- brms::get_dpar(prep, "mu")
+  trials <- prep$data$vint1
+  trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE)
+  mu * trials
+}
+

A post-processing method relying directly on posterior_epred is conditional_effects, which allows to visualize effects of predictors.

+
conditional_effects(fit2, conditions = data.frame(size = 1))
+

+

For ease of interpretation we have set size to 1 so that the y-axis of the above plot indicates probabilities.

+
+
+

Turning a Custom Family into a Native Family

+

Family functions built natively into brms are safer to use and more convenient, as they require much less user input. If you think that your custom family is general enough to be useful to other users, please feel free to open an issue on GitHub so that we can discuss all the details. Provided that we agree it makes sense to implement your family natively in brms, the following steps are required (foo is a placeholder for the family name):

+
    +
  • In family-lists.R, add function .family_foo which should contain basic information about your family (you will find lots of examples for other families there).
    • +
  • In families.R, add family function foo which should be a simple wrapper around .brmsfamily.
    • +
  • In stan-likelihood.R, add function stan_log_lik_foo which provides the likelihood of the family in Stan language.
    • +
  • If necessary, add self-defined Stan functions in separate files under inst/chunks.
    • +
  • Add functions posterior_predict_foo, posterior_epred_foo and log_lik_foo to posterior_predict.R, posterior_epred.R and log_lik.R, respectively.
    • +
  • If necessary, add distribution functions to distributions.R.
    • +
+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_customfamilies.R r-cran-brms-2.17.0/inst/doc/brms_customfamilies.R --- r-cran-brms-2.16.3/inst/doc/brms_customfamilies.R 2021-11-22 15:44:21.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_customfamilies.R 2022-04-11 07:55:14.000000000 +0000 @@ -1,98 +1,99 @@ -params <- -list(EVAL = TRUE) - -## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) - -## ----cbpp------------------------------------------------------------------------------- -data("cbpp", package = "lme4") -head(cbpp) - -## ----fit1, results='hide'--------------------------------------------------------------- -fit1 <- brm(incidence | trials(size) ~ period + (1|herd), - data = cbpp, family = binomial()) - -## ----fit1_summary----------------------------------------------------------------------- -summary(fit1) - -## ----beta_binomial2--------------------------------------------------------------------- -beta_binomial2 <- custom_family( - "beta_binomial2", dpars = c("mu", "phi"), - links = c("logit", "log"), lb = c(NA, 0), - type = "int", vars = "vint1[n]" -) - -## ----stan_funs-------------------------------------------------------------------------- -stan_funs <- " - real beta_binomial2_lpmf(int y, real mu, real phi, int T) { - return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); - } - int beta_binomial2_rng(real mu, real phi, int T) { - return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); - } -" - -## ----stanvars--------------------------------------------------------------------------- -stanvars <- stanvar(scode = stan_funs, block = "functions") - -## ----fit2, results='hide'--------------------------------------------------------------- -fit2 <- brm( - incidence | vint(size) ~ period + (1|herd), data = cbpp, - family = beta_binomial2, stanvars = stanvars -) - -## ----summary_fit2----------------------------------------------------------------------- -summary(fit2) - -## --------------------------------------------------------------------------------------- -expose_functions(fit2, vectorize = TRUE) - -## ----log_lik---------------------------------------------------------------------------- -log_lik_beta_binomial2 <- function(i, prep) { - mu <- brms::get_dpar(prep, "mu", i = i) - phi <- brms::get_dpar(prep, "phi", i = i) - trials <- prep$data$vint1[i] - y <- prep$data$Y[i] - beta_binomial2_lpmf(y, mu, phi, trials) -} - -## ----loo-------------------------------------------------------------------------------- -loo(fit1, fit2) - -## ----posterior_predict------------------------------------------------------------------ -posterior_predict_beta_binomial2 <- function(i, prep, ...) { - mu <- brms::get_dpar(prep, "mu", i = i) - phi <- brms::get_dpar(prep, "phi", i = i) - trials <- prep$data$vint1[i] - beta_binomial2_rng(mu, phi, trials) -} - -## ----pp_check--------------------------------------------------------------------------- -pp_check(fit2) - -## ----posterior_epred-------------------------------------------------------------------- -posterior_epred_beta_binomial2 <- function(prep) { - mu <- brms::get_dpar(prep, "mu") - trials <- prep$data$vint1 - trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) - mu * trials -} - -## ----conditional_effects---------------------------------------------------------------- -conditional_effects(fit2, conditions = data.frame(size = 1)) - +params <- +list(EVAL = TRUE) + +## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) + +## ----cbpp------------------------------------------------------------------------------- +data("cbpp", package = "lme4") +head(cbpp) + +## ----fit1, results='hide'--------------------------------------------------------------- +fit1 <- brm(incidence | trials(size) ~ period + (1|herd), + data = cbpp, family = binomial()) + +## ----fit1_summary----------------------------------------------------------------------- +summary(fit1) + +## ----beta_binomial2--------------------------------------------------------------------- +beta_binomial2 <- custom_family( + "beta_binomial2", dpars = c("mu", "phi"), + links = c("logit", "log"), + lb = c(0, 0), ub = c(1, NA), + type = "int", vars = "vint1[n]" +) + +## ----stan_funs-------------------------------------------------------------------------- +stan_funs <- " + real beta_binomial2_lpmf(int y, real mu, real phi, int T) { + return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); + } + int beta_binomial2_rng(real mu, real phi, int T) { + return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); + } +" + +## ----stanvars--------------------------------------------------------------------------- +stanvars <- stanvar(scode = stan_funs, block = "functions") + +## ----fit2, results='hide'--------------------------------------------------------------- +fit2 <- brm( + incidence | vint(size) ~ period + (1|herd), data = cbpp, + family = beta_binomial2, stanvars = stanvars +) + +## ----summary_fit2----------------------------------------------------------------------- +summary(fit2) + +## --------------------------------------------------------------------------------------- +expose_functions(fit2, vectorize = TRUE) + +## ----log_lik---------------------------------------------------------------------------- +log_lik_beta_binomial2 <- function(i, prep) { + mu <- brms::get_dpar(prep, "mu", i = i) + phi <- brms::get_dpar(prep, "phi", i = i) + trials <- prep$data$vint1[i] + y <- prep$data$Y[i] + beta_binomial2_lpmf(y, mu, phi, trials) +} + +## ----loo-------------------------------------------------------------------------------- +loo(fit1, fit2) + +## ----posterior_predict------------------------------------------------------------------ +posterior_predict_beta_binomial2 <- function(i, prep, ...) { + mu <- brms::get_dpar(prep, "mu", i = i) + phi <- brms::get_dpar(prep, "phi", i = i) + trials <- prep$data$vint1[i] + beta_binomial2_rng(mu, phi, trials) +} + +## ----pp_check--------------------------------------------------------------------------- +pp_check(fit2) + +## ----posterior_epred-------------------------------------------------------------------- +posterior_epred_beta_binomial2 <- function(prep) { + mu <- brms::get_dpar(prep, "mu") + trials <- prep$data$vint1 + trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) + mu * trials +} + +## ----conditional_effects---------------------------------------------------------------- +conditional_effects(fit2, conditions = data.frame(size = 1)) + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_customfamilies.Rmd r-cran-brms-2.17.0/inst/doc/brms_customfamilies.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_customfamilies.Rmd 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_customfamilies.Rmd 2022-04-11 07:20:51.000000000 +0000 @@ -1,341 +1,342 @@ ---- -title: "Define Custom Response Distributions with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Define Custom Response Distributions with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -The **brms** package comes with a lot of built-in response distributions -- -usually called *families* in R -- to specify among others linear, count data, -survival, response times, or ordinal models (see `help(brmsfamily)` for an -overview). Despite supporting over two dozen families, there is still a long -list of distributions, which are not natively supported. The present vignette -will explain how to specify such *custom families* in **brms**. By doing that, -users can benefit from the modeling flexibility and post-processing options of -**brms** even when using self-defined response distributions. -If you have built a custom family that you want to make available to other -users, you can submit a pull request to this -[GitHub repository](https://github.com/paul-buerkner/custom-brms-families). - -## A Case Study - -As a case study, we will use the `cbpp` data of the **lme4** package, which -describes the development of the CBPP disease of cattle in Africa. The data set -contains four variables: `period` (the time period), `herd` (a factor -identifying the cattle herd), `incidence` (number of new disease cases for a -given herd and time period), as well as `size` (the herd size at the beginning -of a given time period). - -```{r cbpp} -data("cbpp", package = "lme4") -head(cbpp) -``` - -In a first step, we will be predicting `incidence` using a simple binomial -model, which will serve as our baseline model. For observed number of events $y$ -(`incidence` in our case) and total number of trials $T$ (`size`), the -probability mass function of the binomial distribution is defined as - -$$ -P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} -$$ - -where $p$ is the event probability. In the classical binomial model, we will -directly predict $p$ on the logit-scale, which means that for each observation -$i$ we compute the success probability $p_i$ as - -$$ -p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} -$$ - -where $\eta_i$ is the linear predictor term of observation $i$ (see -`vignette("brms_overview")` for more details on linear predictors in **brms**). -Predicting `incidence` by `period` and a varying intercept of `herd` is straight -forward in **brms**: - -```{r fit1, results='hide'} -fit1 <- brm(incidence | trials(size) ~ period + (1|herd), - data = cbpp, family = binomial()) -``` - -In the summary output, we see that the incidence probability varies -substantially over herds, but reduces over the course of the time as indicated -by the negative coefficients of `period`. - -```{r fit1_summary} -summary(fit1) -``` - -A drawback of the binomial model is that -- after taking into account the linear -predictor -- its variance is fixed to $\text{Var}(y_i) = T_i p_i (1 - p_i)$. All -variance exceeding this value cannot be not taken into account by the model. -There are multiple ways of dealing with this so called *overdispersion* and the -solution described below will serve as an illustrative example of how to define -custom families in **brms**. - - -## The Beta-Binomial Distribution - -The *beta-binomial* model is a generalization of the *binomial* model -with an additional parameter to account for overdispersion. In the beta-binomial -model, we do not predict the binomial probability $p_i$ directly, but assume it -to be beta distributed with hyperparameters $\alpha > 0$ and $\beta > 0$: - -$$ -p_i \sim \text{Beta}(\alpha_i, \beta_i) -$$ - -The $\alpha$ and $\beta$ parameters are both hard to interpret and generally -not recommended for use in regression models. Thus, we will apply a different -parameterization with parameters $\mu \in [0, 1]$ and $\phi > 0$, which we will -call $\text{Beta2}$: - -$$ -\text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) -$$ - -The parameters $\mu$ and $\phi$ specify the mean and precision parameter, -respectively. By defining - -$$ -\mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} -$$ - -we still predict the expected probability by means of our transformed linear -predictor (as in the original binomial model), but account for potential -overdispersion via the parameter $\phi$. - - -## Fitting Custom Family Models - -The beta-binomial distribution is not natively supported in **brms** and so we -will have to define it ourselves using the `custom_family` function. This -function requires the family's name, the names of its parameters (`mu` and `phi` -in our case), corresponding link functions (only applied if parameters are -predicted), their theoretical lower and upper bounds (only applied if parameters -are not predicted), information on whether the distribution is discrete or -continuous, and finally, whether additional non-parameter variables need to be -passed to the distribution. For our beta-binomial example, this results in the -following custom family: - -```{r beta_binomial2} -beta_binomial2 <- custom_family( - "beta_binomial2", dpars = c("mu", "phi"), - links = c("logit", "log"), lb = c(NA, 0), - type = "int", vars = "vint1[n]" -) -``` - -The name `vint1` for the variable containing the number of trials is not chosen -arbitrarily as we will see below. Next, we have to provide the relevant **Stan** -functions if the distribution is not defined in **Stan** itself. For the -`beta_binomial2` distribution, this is straight forward since the ordinal -`beta_binomial` distribution is already implemented. - -```{r stan_funs} -stan_funs <- " - real beta_binomial2_lpmf(int y, real mu, real phi, int T) { - return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); - } - int beta_binomial2_rng(real mu, real phi, int T) { - return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); - } -" -``` - -For the model fitting, we will only need `beta_binomial2_lpmf`, but -`beta_binomial2_rng` will come in handy when it comes to post-processing. -We define: - -```{r stanvars} -stanvars <- stanvar(scode = stan_funs, block = "functions") -``` - -To provide information about the number of trials (an integer variable), we are -going to use the addition argument `vint()`, which can only be used in custom -families. Similarly, if we needed to include additional vectors of real data, we -would use `vreal()`. Actually, for this particular example, we could more -elegantly apply the addition argument `trials()` instead of `vint()`as in the -basic binomial model. However, since the present vignette is meant to give a -general overview of the topic, we will go with the more general method. - -We now have all components together to fit our custom beta-binomial model: - -```{r fit2, results='hide'} -fit2 <- brm( - incidence | vint(size) ~ period + (1|herd), data = cbpp, - family = beta_binomial2, stanvars = stanvars -) -``` - -The summary output reveals that the uncertainty in the coefficients of `period` -is somewhat larger than in the basic binomial model, which is the result of -including the overdispersion parameter `phi` in the model. Apart from that, the -results looks pretty similar. - -```{r summary_fit2} -summary(fit2) -``` - - -## Post-Processing Custom Family Models - -Some post-processing methods such as `summary` or `plot` work out of the box for -custom family models. However, there are three particularly important methods, -which require additional input by the user. These are `posterior_epred`, -`posterior_predict` and `log_lik` computing predicted mean values, predicted -response values, and log-likelihood values, respectively. They are not only -relevant for their own sake, but also provide the basis of many other -post-processing methods. For instance, we may be interested in comparing the fit -of the binomial model with that of the beta-binomial model by means of -approximate leave-one-out cross-validation implemented in method `loo`, which in -turn requires `log_lik` to be working. - -The `log_lik` function of a family should be named `log_lik_` and -have the two arguments `i` (indicating observations) and `prep`. You don't have -to worry too much about how `prep` is created (if you are interested, check -out the `prepare_predictions` function). Instead, all you need to know is -that parameters are stored in slot `dpars` and data are stored in slot `data`. -Generally, parameters take on the form of a $S \times N$ matrix (with $S =$ -number of posterior draws and $N =$ number of observations) if they are -predicted (as is `mu` in our example) and a vector of size $N$ if the are not -predicted (as is `phi`). - -We could define the complete log-likelihood function in R directly, or we can -expose the self-defined **Stan** functions and apply them. The latter approach -is usually more convenient, but the former is more stable and the only option -when implementing custom families in other R packages building upon **brms**. -For the purpose of the present vignette, we will go with the latter approach. - -```{r} -expose_functions(fit2, vectorize = TRUE) -``` - -and define the required `log_lik` functions with a few lines of code. - -```{r log_lik} -log_lik_beta_binomial2 <- function(i, prep) { - mu <- brms::get_dpar(prep, "mu", i = i) - phi <- brms::get_dpar(prep, "phi", i = i) - trials <- prep$data$vint1[i] - y <- prep$data$Y[i] - beta_binomial2_lpmf(y, mu, phi, trials) -} -``` - -The `get_dpar` function will do the necessary transformations to handle both -the case when the distributional parameters are predicted separately for each -row and when they are the same for the whole fit. - -With that being done, all of the post-processing methods requiring `log_lik` -will work as well. For instance, model comparison can simply be performed via - -```{r loo} -loo(fit1, fit2) -``` - -Since larger `ELPD` values indicate better fit, we see that the beta-binomial -model fits somewhat better, although the corresponding standard error reveals -that the difference is not that substantial. - -Next, we will define the function necessary for the `posterior_predict` method: - -```{r posterior_predict} -posterior_predict_beta_binomial2 <- function(i, prep, ...) { - mu <- brms::get_dpar(prep, "mu", i = i) - phi <- brms::get_dpar(prep, "phi", i = i) - trials <- prep$data$vint1[i] - beta_binomial2_rng(mu, phi, trials) -} -``` - -The `posterior_predict` function looks pretty similar to the corresponding -`log_lik` function, except that we are now creating random draws of the -response instead of log-likelihood values. Again, we are using an exposed -**Stan** function for convenience. Make sure to add a `...` argument to your -`posterior_predict` function even if you are not using it, since some families -require additional arguments. With `posterior_predict` to be working, we can -engage for instance in posterior-predictive checking: - -```{r pp_check} -pp_check(fit2) -``` - -When defining the `posterior_epred` function, you have to keep in mind that it -has only a `prep` argument and should compute the mean response values for all -observations at once. Since the mean of the beta-binomial distribution is -$\text{E}(y) = \mu T$ definition of the corresponding `posterior_epred` function -is not too complicated, but we need to get the dimension of parameters and data -in line. - -```{r posterior_epred} -posterior_epred_beta_binomial2 <- function(prep) { - mu <- brms::get_dpar(prep, "mu") - trials <- prep$data$vint1 - trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) - mu * trials -} -``` - -A post-processing method relying directly on `posterior_epred` is -`conditional_effects`, which allows to visualize effects of predictors. - -```{r conditional_effects} -conditional_effects(fit2, conditions = data.frame(size = 1)) -``` - -For ease of interpretation we have set `size` to 1 so that the y-axis of the -above plot indicates probabilities. - - -## Turning a Custom Family into a Native Family - -Family functions built natively into **brms** are safer to use and more -convenient, as they require much less user input. If you think that your custom -family is general enough to be useful to other users, please feel free to open -an issue on [GitHub](https://github.com/paul-buerkner/brms/issues) so that we -can discuss all the details. Provided that we agree it makes sense to implement -your family natively in brms, the following steps are required (`foo` is a -placeholder for the family name): - -* In `family-lists.R`, add function `.family_foo` which should contain basic -information about your family (you will find lots of examples for other families -there). -* In `families.R`, add family function `foo` which should be a simple wrapper -around `.brmsfamily`. -* In `stan-likelihood.R`, add function `stan_log_lik_foo` which provides the -likelihood of the family in Stan language. -* If necessary, add self-defined Stan functions in separate files under -`inst/chunks`. -* Add functions `posterior_predict_foo`, `posterior_epred_foo` and `log_lik_foo` -to `posterior_predict.R`, `posterior_epred.R` and `log_lik.R`, respectively. -* If necessary, add distribution functions to `distributions.R`. +--- +title: "Define Custom Response Distributions with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Define Custom Response Distributions with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +The **brms** package comes with a lot of built-in response distributions -- +usually called *families* in R -- to specify among others linear, count data, +survival, response times, or ordinal models (see `help(brmsfamily)` for an +overview). Despite supporting over two dozen families, there is still a long +list of distributions, which are not natively supported. The present vignette +will explain how to specify such *custom families* in **brms**. By doing that, +users can benefit from the modeling flexibility and post-processing options of +**brms** even when using self-defined response distributions. +If you have built a custom family that you want to make available to other +users, you can submit a pull request to this +[GitHub repository](https://github.com/paul-buerkner/custom-brms-families). + +## A Case Study + +As a case study, we will use the `cbpp` data of the **lme4** package, which +describes the development of the CBPP disease of cattle in Africa. The data set +contains four variables: `period` (the time period), `herd` (a factor +identifying the cattle herd), `incidence` (number of new disease cases for a +given herd and time period), as well as `size` (the herd size at the beginning +of a given time period). + +```{r cbpp} +data("cbpp", package = "lme4") +head(cbpp) +``` + +In a first step, we will be predicting `incidence` using a simple binomial +model, which will serve as our baseline model. For observed number of events $y$ +(`incidence` in our case) and total number of trials $T$ (`size`), the +probability mass function of the binomial distribution is defined as + +$$ +P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} +$$ + +where $p$ is the event probability. In the classical binomial model, we will +directly predict $p$ on the logit-scale, which means that for each observation +$i$ we compute the success probability $p_i$ as + +$$ +p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} +$$ + +where $\eta_i$ is the linear predictor term of observation $i$ (see +`vignette("brms_overview")` for more details on linear predictors in **brms**). +Predicting `incidence` by `period` and a varying intercept of `herd` is straight +forward in **brms**: + +```{r fit1, results='hide'} +fit1 <- brm(incidence | trials(size) ~ period + (1|herd), + data = cbpp, family = binomial()) +``` + +In the summary output, we see that the incidence probability varies +substantially over herds, but reduces over the course of the time as indicated +by the negative coefficients of `period`. + +```{r fit1_summary} +summary(fit1) +``` + +A drawback of the binomial model is that -- after taking into account the linear +predictor -- its variance is fixed to $\text{Var}(y_i) = T_i p_i (1 - p_i)$. All +variance exceeding this value cannot be not taken into account by the model. +There are multiple ways of dealing with this so called *overdispersion* and the +solution described below will serve as an illustrative example of how to define +custom families in **brms**. + + +## The Beta-Binomial Distribution + +The *beta-binomial* model is a generalization of the *binomial* model +with an additional parameter to account for overdispersion. In the beta-binomial +model, we do not predict the binomial probability $p_i$ directly, but assume it +to be beta distributed with hyperparameters $\alpha > 0$ and $\beta > 0$: + +$$ +p_i \sim \text{Beta}(\alpha_i, \beta_i) +$$ + +The $\alpha$ and $\beta$ parameters are both hard to interpret and generally +not recommended for use in regression models. Thus, we will apply a different +parameterization with parameters $\mu \in [0, 1]$ and $\phi > 0$, which we will +call $\text{Beta2}$: + +$$ +\text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) +$$ + +The parameters $\mu$ and $\phi$ specify the mean and precision parameter, +respectively. By defining + +$$ +\mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} +$$ + +we still predict the expected probability by means of our transformed linear +predictor (as in the original binomial model), but account for potential +overdispersion via the parameter $\phi$. + + +## Fitting Custom Family Models + +The beta-binomial distribution is natively supported in **brms** nowadays, but +we will still use it as an example to define it ourselves via the +`custom_family` function. This function requires the family's name, the names of +its parameters (`mu` and `phi` in our case), corresponding link functions (only +applied if parameters are predicted), their theoretical lower and upper bounds +(only applied if parameters are not predicted), information on whether the +distribution is discrete or continuous, and finally, whether additional +non-parameter variables need to be passed to the distribution. For our +beta-binomial example, this results in the following custom family: + +```{r beta_binomial2} +beta_binomial2 <- custom_family( + "beta_binomial2", dpars = c("mu", "phi"), + links = c("logit", "log"), + lb = c(0, 0), ub = c(1, NA), + type = "int", vars = "vint1[n]" +) +``` + +The name `vint1` for the variable containing the number of trials is not chosen +arbitrarily as we will see below. Next, we have to provide the relevant **Stan** +functions if the distribution is not defined in **Stan** itself. For the +`beta_binomial2` distribution, this is straight forward since the ordinal +`beta_binomial` distribution is already implemented. + +```{r stan_funs} +stan_funs <- " + real beta_binomial2_lpmf(int y, real mu, real phi, int T) { + return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); + } + int beta_binomial2_rng(real mu, real phi, int T) { + return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); + } +" +``` + +For the model fitting, we will only need `beta_binomial2_lpmf`, but +`beta_binomial2_rng` will come in handy when it comes to post-processing. +We define: + +```{r stanvars} +stanvars <- stanvar(scode = stan_funs, block = "functions") +``` + +To provide information about the number of trials (an integer variable), we are +going to use the addition argument `vint()`, which can only be used in custom +families. Similarly, if we needed to include additional vectors of real data, we +would use `vreal()`. Actually, for this particular example, we could more +elegantly apply the addition argument `trials()` instead of `vint()`as in the +basic binomial model. However, since the present vignette is meant to give a +general overview of the topic, we will go with the more general method. + +We now have all components together to fit our custom beta-binomial model: + +```{r fit2, results='hide'} +fit2 <- brm( + incidence | vint(size) ~ period + (1|herd), data = cbpp, + family = beta_binomial2, stanvars = stanvars +) +``` + +The summary output reveals that the uncertainty in the coefficients of `period` +is somewhat larger than in the basic binomial model, which is the result of +including the overdispersion parameter `phi` in the model. Apart from that, the +results looks pretty similar. + +```{r summary_fit2} +summary(fit2) +``` + + +## Post-Processing Custom Family Models + +Some post-processing methods such as `summary` or `plot` work out of the box for +custom family models. However, there are three particularly important methods, +which require additional input by the user. These are `posterior_epred`, +`posterior_predict` and `log_lik` computing predicted mean values, predicted +response values, and log-likelihood values, respectively. They are not only +relevant for their own sake, but also provide the basis of many other +post-processing methods. For instance, we may be interested in comparing the fit +of the binomial model with that of the beta-binomial model by means of +approximate leave-one-out cross-validation implemented in method `loo`, which in +turn requires `log_lik` to be working. + +The `log_lik` function of a family should be named `log_lik_` and +have the two arguments `i` (indicating observations) and `prep`. You don't have +to worry too much about how `prep` is created (if you are interested, check +out the `prepare_predictions` function). Instead, all you need to know is +that parameters are stored in slot `dpars` and data are stored in slot `data`. +Generally, parameters take on the form of a $S \times N$ matrix (with $S =$ +number of posterior draws and $N =$ number of observations) if they are +predicted (as is `mu` in our example) and a vector of size $N$ if the are not +predicted (as is `phi`). + +We could define the complete log-likelihood function in R directly, or we can +expose the self-defined **Stan** functions and apply them. The latter approach +is usually more convenient, but the former is more stable and the only option +when implementing custom families in other R packages building upon **brms**. +For the purpose of the present vignette, we will go with the latter approach. + +```{r} +expose_functions(fit2, vectorize = TRUE) +``` + +and define the required `log_lik` functions with a few lines of code. + +```{r log_lik} +log_lik_beta_binomial2 <- function(i, prep) { + mu <- brms::get_dpar(prep, "mu", i = i) + phi <- brms::get_dpar(prep, "phi", i = i) + trials <- prep$data$vint1[i] + y <- prep$data$Y[i] + beta_binomial2_lpmf(y, mu, phi, trials) +} +``` + +The `get_dpar` function will do the necessary transformations to handle both +the case when the distributional parameters are predicted separately for each +row and when they are the same for the whole fit. + +With that being done, all of the post-processing methods requiring `log_lik` +will work as well. For instance, model comparison can simply be performed via + +```{r loo} +loo(fit1, fit2) +``` + +Since larger `ELPD` values indicate better fit, we see that the beta-binomial +model fits somewhat better, although the corresponding standard error reveals +that the difference is not that substantial. + +Next, we will define the function necessary for the `posterior_predict` method: + +```{r posterior_predict} +posterior_predict_beta_binomial2 <- function(i, prep, ...) { + mu <- brms::get_dpar(prep, "mu", i = i) + phi <- brms::get_dpar(prep, "phi", i = i) + trials <- prep$data$vint1[i] + beta_binomial2_rng(mu, phi, trials) +} +``` + +The `posterior_predict` function looks pretty similar to the corresponding +`log_lik` function, except that we are now creating random draws of the +response instead of log-likelihood values. Again, we are using an exposed +**Stan** function for convenience. Make sure to add a `...` argument to your +`posterior_predict` function even if you are not using it, since some families +require additional arguments. With `posterior_predict` to be working, we can +engage for instance in posterior-predictive checking: + +```{r pp_check} +pp_check(fit2) +``` + +When defining the `posterior_epred` function, you have to keep in mind that it +has only a `prep` argument and should compute the mean response values for all +observations at once. Since the mean of the beta-binomial distribution is +$\text{E}(y) = \mu T$ definition of the corresponding `posterior_epred` function +is not too complicated, but we need to get the dimension of parameters and data +in line. + +```{r posterior_epred} +posterior_epred_beta_binomial2 <- function(prep) { + mu <- brms::get_dpar(prep, "mu") + trials <- prep$data$vint1 + trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) + mu * trials +} +``` + +A post-processing method relying directly on `posterior_epred` is +`conditional_effects`, which allows to visualize effects of predictors. + +```{r conditional_effects} +conditional_effects(fit2, conditions = data.frame(size = 1)) +``` + +For ease of interpretation we have set `size` to 1 so that the y-axis of the +above plot indicates probabilities. + + +## Turning a Custom Family into a Native Family + +Family functions built natively into **brms** are safer to use and more +convenient, as they require much less user input. If you think that your custom +family is general enough to be useful to other users, please feel free to open +an issue on [GitHub](https://github.com/paul-buerkner/brms/issues) so that we +can discuss all the details. Provided that we agree it makes sense to implement +your family natively in brms, the following steps are required (`foo` is a +placeholder for the family name): + +* In `family-lists.R`, add function `.family_foo` which should contain basic +information about your family (you will find lots of examples for other families +there). +* In `families.R`, add family function `foo` which should be a simple wrapper +around `.brmsfamily`. +* In `stan-likelihood.R`, add function `stan_log_lik_foo` which provides the +likelihood of the family in Stan language. +* If necessary, add self-defined Stan functions in separate files under +`inst/chunks`. +* Add functions `posterior_predict_foo`, `posterior_epred_foo` and `log_lik_foo` +to `posterior_predict.R`, `posterior_epred.R` and `log_lik.R`, respectively. +* If necessary, add distribution functions to `distributions.R`. diff -Nru r-cran-brms-2.16.3/inst/doc/brms_distreg.html r-cran-brms-2.17.0/inst/doc/brms_distreg.html --- r-cran-brms-2.16.3/inst/doc/brms_distreg.html 2021-11-22 15:49:50.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_distreg.html 2022-04-11 07:57:13.000000000 +0000 @@ -1,358 +1,358 @@ - - - - - - - - - - - - - - - - -Estimating Distributional Models with brms - - - - - - - - - - - - - - - - - - - - - - - - - -

Estimating Distributional Models with brms

-

Paul Bürkner

-

2021-11-22

- - - - -
-

Introduction

-

This vignette provides an introduction on how to fit distributional regression models with brms. We use the term distributional model to refer to a model, in which we can specify predictor terms for all parameters of the assumed response distribution. In the vast majority of regression model implementations, only the location parameter (usually the mean) of the response distribution depends on the predictors and corresponding regression parameters. Other parameters (e.g., scale or shape parameters) are estimated as auxiliary parameters assuming them to be constant across observations. This assumption is so common that most researchers applying regression models are often (in my experience) not aware of the possibility of relaxing it. This is understandable insofar as relaxing this assumption drastically increase model complexity and thus makes models hard to fit. Fortunately, brms uses Stan on the backend, which is an incredibly flexible and powerful tool for estimating Bayesian models so that model complexity is much less of an issue.

-

Suppose we have a normally distributed response variable. Then, in basic linear regression, we specify a predictor term \(\eta_{\mu}\) for the mean parameter \(\mu\) of the normal distribution. The second parameter of the normal distribution – the residual standard deviation \(\sigma\) – is assumed to be constant across observations. We estimate \(\sigma\) but do not try to predict it. In a distributional model, however, we do exactly this by specifying a predictor term \(\eta_{\sigma}\) for \(\sigma\) in addition to the predictor term \(\eta_{\mu}\). Ignoring group-level effects for the moment, the linear predictor of a parameter \(\theta\) for observation \(n\) has the form

-

\[\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}\] where \(x_{\theta i n}\) denotes the value of the \(i\)th predictor of parameter \(\theta\) for observation \(n\) and \(b_{\theta i}\) is the \(i\)th regression coefficient of parameter \(\theta\). A distributional normal model with response variable \(y\) can then be written as

-

\[y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)\] We used the exponential function around \(\eta_{\sigma}\) to reflect that \(\sigma\) constitutes a standard deviation and thus only takes on positive values, while a linear predictor can be any real number.

-
-
-

A simple distributional model

-

Unequal variance models are possibly the most simple, but nevertheless very important application of distributional models. Suppose we have two groups of patients: One group receives a treatment (e.g., an antidepressive drug) and another group receives placebo. Since the treatment may not work equally well for all patients, the symptom variance of the treatment group may be larger than the symptom variance of the placebo group after some weeks of treatment. For simplicity, assume that we only investigate the post-treatment values.

-
group <- rep(c("treat", "placebo"), each = 30)
-symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1))
-dat1 <- data.frame(group, symptom_post)
-head(dat1)
-
  group symptom_post
-1 treat    0.7494321
-2 treat    4.6104747
-3 treat    0.2906019
-4 treat   -0.4612407
-5 treat    0.6131628
-6 treat    0.4834311
-

The following model estimates the effect of group on both the mean and the residual standard deviation of the normal response distribution.

-
fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), 
-            data = dat1, family = gaussian())
-

Useful summary statistics and plots can be obtained via

-
summary(fit1)
-plot(fit1, N = 2, ask = FALSE)
-

-
plot(conditional_effects(fit1), points = TRUE)
-

-

The population-level effect sigma_grouptreat, which is the contrast of the two residual standard deviations on the log-scale, reveals that the variances of both groups are indeed different. This impression is confirmed when looking at the conditional_effects of group. Going one step further, we can compute the residual standard deviations on the original scale using the hypothesis method.

-
hyp <- c("exp(sigma_Intercept) = 0",
-         "exp(sigma_Intercept + sigma_grouptreat) = 0")
-hypothesis(fit1, hyp)
-
Hypothesis Tests for class b:
-                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
-1 (exp(sigma_Interc... = 0     1.12      0.16     0.87     1.47         NA        NA    *
-2 (exp(sigma_Interc... = 0     1.93      0.26     1.51     2.52         NA        NA    *
----
-'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
-'*': For one-sided hypotheses, the posterior probability exceeds 95%;
-for two-sided hypotheses, the value tested against lies outside the 95%-CI.
-Posterior probabilities of point hypotheses assume equal prior probabilities.
-

We may also directly compare them and plot the posterior distribution of their difference.

-
hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)"
-(hyp <- hypothesis(fit1, hyp))
-
Hypothesis Tests for class b:
-                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
-1 (exp(sigma_Interc... > 0     0.81       0.3     0.34     1.34     665.67         1    *
----
-'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
-'*': For one-sided hypotheses, the posterior probability exceeds 95%;
-for two-sided hypotheses, the value tested against lies outside the 95%-CI.
-Posterior probabilities of point hypotheses assume equal prior probabilities.
-
plot(hyp, chars = NULL)
-

-

Indeed, the residual standard deviation of the treatment group seems to larger than that of the placebo group. Moreover the magnitude of this difference is pretty similar to what we expected due to the values we put into the data simulations.

-
-
-

Zero-Inflated Models

-

Another important application of the distributional regression framework are so called zero-inflated models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. For example, if one seeks to predict the number of cigarettes people smoke per day and also includes non-smokers, there will be a huge amount of zeros which, when not modeled appropriately, can seriously distort parameter estimates. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (), the data are described as follows: “The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.”

-
zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv")
-head(zinb)
-
  nofish livebait camper persons child         xb         zg count
-1      1        0      0       1     0 -0.8963146  3.0504048     0
-2      0        1      1       1     0 -0.5583450  1.7461489     0
-3      0        1      0       1     0 -0.4017310  0.2799389     0
-4      0        1      1       2     1 -0.9562981 -0.6015257     0
-5      0        1      0       1     0  0.4368910  0.5277091     1
-6      0        1      1       4     2  1.3944855 -0.7075348     0
-

As predictors we choose the number of people per group, the number of children, as well as whether the group consists of campers. Many groups may not even try catching any fish at all (thus leading to many zero responses) and so we fit a zero-inflated Poisson model to the data. For now, we assume a constant zero-inflation probability across observations.

-
fit_zinb1 <- brm(count ~ persons + child + camper, 
-                 data = zinb, family = zero_inflated_poisson())
-

Again, we summarize the results using the usual methods.

-
summary(fit_zinb1)
-
 Family: zero_inflated_poisson 
-  Links: mu = log; zi = identity 
-Formula: count ~ persons + child + camper 
-   Data: zinb (Number of observations: 250) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    -1.01      0.18    -1.37    -0.68 1.00     2796     2890
-persons       0.87      0.05     0.79     0.97 1.00     2866     2708
-child        -1.37      0.09    -1.55    -1.19 1.00     2679     2717
-camper        0.80      0.09     0.62     0.99 1.00     3175     2259
-
-Family Specific Parameters: 
-   Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-zi     0.41      0.04     0.32     0.49 1.00     3031     2507
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(conditional_effects(fit_zinb1), ask = FALSE)
-

-

According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability zi is pretty large with a mean of 41%. Please note that the probability of catching no fish is actually higher than 41%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-inflation). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here).

-

Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish. Most children are just terribly bad at waiting for hours until something happens. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data.

-
fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), 
-                 data = zinb, family = zero_inflated_poisson())
-
summary(fit_zinb2)
-
 Family: zero_inflated_poisson 
-  Links: mu = log; zi = logit 
-Formula: count ~ persons + child + camper 
-         zi ~ child
-   Data: zinb (Number of observations: 250) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept       -1.08      0.18    -1.44    -0.74 1.00     2863     3006
-zi_Intercept    -0.96      0.26    -1.48    -0.48 1.00     3613     2910
-persons          0.89      0.05     0.80     0.98 1.00     2688     2945
-child           -1.18      0.09    -1.37    -0.99 1.00     2568     2241
-camper           0.78      0.10     0.60     0.97 1.00     3735     2754
-zi_child         1.22      0.28     0.69     1.77 1.00     3457     2755
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(conditional_effects(fit_zinb2), ask = FALSE)
-

-

To transform the linear predictor of zi into a probability, brms applies the logit-link:

-

\[logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}\]

-

The logit-link takes values within \([0, 1]\) and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors.

-

According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your change of catching no fish at all (as implied by the zero-inflation part) most likely because groups with more children are not even trying.

-
-
-

Additive Distributional Models

-

In the examples so far, we did not have multilevel data and thus did not fully use the capabilities of the distributional regression framework of brms. In the example presented below, we will not only show how to deal with multilevel data in distributional models, but also how to incorporate smooth terms (i.e., splines) into the model. In many applications, we have no or only a very vague idea how the relationship between a predictor and the response looks like. A very flexible approach to tackle this problems is to use splines and let them figure out the form of the relationship. For illustration purposes, we simulate some data with the mgcv package, which is also used in brms to prepare smooth terms.

-
dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE)
-
Gu & Wahba 4 term additive model
-
head(dat_smooth[, 1:6])
-
         y         x0        x1        x2         x3        f
-1 14.49903 0.90367316 0.5599891 0.2892207 0.25739676 14.65363
-2 15.62866 0.05106966 0.3067924 0.2004563 0.46890431 16.76730
-3 18.96673 0.41930344 0.8640141 0.5152081 0.49768229 19.30891
-4 18.00491 0.88620754 0.1923437 0.6606654 0.01195286 17.42330
-5 11.57063 0.47699339 0.2445614 0.3427586 0.77137988 12.80572
-6 14.70050 0.24687260 0.7712136 0.7318031 0.96783381 14.48305
-

The data contains the predictors x0 to x3 as well as the grouping factor fac indicating the nested structure of the data. We predict the response variable y using smooth terms of x1 and x2 and a varying intercept of fac. In addition, we assume the residual standard deviation sigma to vary by a smoothing term of x0 and a varying intercept of fac.

-
fit_smooth1 <- brm(
-  bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)),
-  data = dat_smooth, family = gaussian(),
-  chains = 2, control = list(adapt_delta = 0.95)
-)
-
summary(fit_smooth1)
-
 Family: gaussian 
-  Links: mu = identity; sigma = log 
-Formula: y ~ s(x1) + s(x2) + (1 | fac) 
-         sigma ~ s(x0) + (1 | fac)
-   Data: dat_smooth (Number of observations: 200) 
-  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 2000
-
-Smooth Terms: 
-                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sds(sx1_1)           2.81      2.10     0.31     8.22 1.00      808      902
-sds(sx2_1)          19.35      4.78    12.06    30.65 1.00      911     1431
-sds(sigma_sx0_1)     1.09      0.95     0.05     3.58 1.00      641      780
-
-Group-Level Effects: 
-~fac (Number of levels: 4) 
-                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)           5.09      2.36     2.36    11.25 1.00     1006     1100
-sd(sigma_Intercept)     0.12      0.19     0.00     0.54 1.01      555      732
-
-Population-Level Effects: 
-                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept          15.32      2.33    10.69    20.26 1.00      746      905
-sigma_Intercept     0.78      0.10     0.59     0.98 1.01     1027      717
-sx1_1              10.25      6.01    -3.87    21.54 1.00     1095      951
-sx2_1              63.62     15.84    32.24    94.36 1.01     1262      856
-sigma_sx0_1         1.70      2.17    -2.41     6.82 1.00     1063     1180
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE)
-

-

This model is likely an overkill for the data at hand, but nicely demonstrates the ease with which one can specify complex models with brms and to fit them using Stan on the backend.

-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Estimating Distributional Models with brms + + + + + + + + + + + + + + + + + + + + + + + + + +

Estimating Distributional Models with brms

+

Paul Bürkner

+

2022-04-11

+ + + + +
+

Introduction

+

This vignette provides an introduction on how to fit distributional regression models with brms. We use the term distributional model to refer to a model, in which we can specify predictor terms for all parameters of the assumed response distribution. In the vast majority of regression model implementations, only the location parameter (usually the mean) of the response distribution depends on the predictors and corresponding regression parameters. Other parameters (e.g., scale or shape parameters) are estimated as auxiliary parameters assuming them to be constant across observations. This assumption is so common that most researchers applying regression models are often (in my experience) not aware of the possibility of relaxing it. This is understandable insofar as relaxing this assumption drastically increase model complexity and thus makes models hard to fit. Fortunately, brms uses Stan on the backend, which is an incredibly flexible and powerful tool for estimating Bayesian models so that model complexity is much less of an issue.

+

Suppose we have a normally distributed response variable. Then, in basic linear regression, we specify a predictor term \(\eta_{\mu}\) for the mean parameter \(\mu\) of the normal distribution. The second parameter of the normal distribution – the residual standard deviation \(\sigma\) – is assumed to be constant across observations. We estimate \(\sigma\) but do not try to predict it. In a distributional model, however, we do exactly this by specifying a predictor term \(\eta_{\sigma}\) for \(\sigma\) in addition to the predictor term \(\eta_{\mu}\). Ignoring group-level effects for the moment, the linear predictor of a parameter \(\theta\) for observation \(n\) has the form

+

\[\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}\] where \(x_{\theta i n}\) denotes the value of the \(i\)th predictor of parameter \(\theta\) for observation \(n\) and \(b_{\theta i}\) is the \(i\)th regression coefficient of parameter \(\theta\). A distributional normal model with response variable \(y\) can then be written as

+

\[y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)\] We used the exponential function around \(\eta_{\sigma}\) to reflect that \(\sigma\) constitutes a standard deviation and thus only takes on positive values, while a linear predictor can be any real number.

+
+
+

A simple distributional model

+

Unequal variance models are possibly the most simple, but nevertheless very important application of distributional models. Suppose we have two groups of patients: One group receives a treatment (e.g., an antidepressive drug) and another group receives placebo. Since the treatment may not work equally well for all patients, the symptom variance of the treatment group may be larger than the symptom variance of the placebo group after some weeks of treatment. For simplicity, assume that we only investigate the post-treatment values.

+
group <- rep(c("treat", "placebo"), each = 30)
+symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1))
+dat1 <- data.frame(group, symptom_post)
+head(dat1)
+
  group symptom_post
+1 treat  -1.87801043
+2 treat  -0.01566953
+3 treat   2.92786188
+4 treat  -0.59624582
+5 treat   1.31352509
+6 treat   0.44636464
+

The following model estimates the effect of group on both the mean and the residual standard deviation of the normal response distribution.

+
fit1 <- brm(bf(symptom_post ~ group, sigma ~ group),
+            data = dat1, family = gaussian())
+

Useful summary statistics and plots can be obtained via

+
summary(fit1)
+plot(fit1, N = 2, ask = FALSE)
+

+
plot(conditional_effects(fit1), points = TRUE)
+

+

The population-level effect sigma_grouptreat, which is the contrast of the two residual standard deviations on the log-scale, reveals that the variances of both groups are indeed different. This impression is confirmed when looking at the conditional_effects of group. Going one step further, we can compute the residual standard deviations on the original scale using the hypothesis method.

+
hyp <- c("exp(sigma_Intercept) = 0",
+         "exp(sigma_Intercept + sigma_grouptreat) = 0")
+hypothesis(fit1, hyp)
+
Hypothesis Tests for class b:
+                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
+1 (exp(sigma_Interc... = 0     1.23      0.17     0.94     1.62         NA        NA    *
+2 (exp(sigma_Interc... = 0     1.82      0.24     1.42     2.36         NA        NA    *
+---
+'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
+'*': For one-sided hypotheses, the posterior probability exceeds 95%;
+for two-sided hypotheses, the value tested against lies outside the 95%-CI.
+Posterior probabilities of point hypotheses assume equal prior probabilities.
+

We may also directly compare them and plot the posterior distribution of their difference.

+
hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)"
+(hyp <- hypothesis(fit1, hyp))
+
Hypothesis Tests for class b:
+                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
+1 (exp(sigma_Interc... > 0     0.59       0.3     0.12     1.09      46.62      0.98    *
+---
+'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
+'*': For one-sided hypotheses, the posterior probability exceeds 95%;
+for two-sided hypotheses, the value tested against lies outside the 95%-CI.
+Posterior probabilities of point hypotheses assume equal prior probabilities.
+
plot(hyp, chars = NULL)
+

+

Indeed, the residual standard deviation of the treatment group seems to larger than that of the placebo group. Moreover the magnitude of this difference is pretty similar to what we expected due to the values we put into the data simulations.

+
+
+

Zero-Inflated Models

+

Another important application of the distributional regression framework are so called zero-inflated models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. For example, if one seeks to predict the number of cigarettes people smoke per day and also includes non-smokers, there will be a huge amount of zeros which, when not modeled appropriately, can seriously distort parameter estimates. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (), the data are described as follows: “The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.”

+
zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv")
+head(zinb)
+
  nofish livebait camper persons child         xb         zg count
+1      1        0      0       1     0 -0.8963146  3.0504048     0
+2      0        1      1       1     0 -0.5583450  1.7461489     0
+3      0        1      0       1     0 -0.4017310  0.2799389     0
+4      0        1      1       2     1 -0.9562981 -0.6015257     0
+5      0        1      0       1     0  0.4368910  0.5277091     1
+6      0        1      1       4     2  1.3944855 -0.7075348     0
+

As predictors we choose the number of people per group, the number of children, as well as whether the group consists of campers. Many groups may not even try catching any fish at all (thus leading to many zero responses) and so we fit a zero-inflated Poisson model to the data. For now, we assume a constant zero-inflation probability across observations.

+
fit_zinb1 <- brm(count ~ persons + child + camper,
+                 data = zinb, family = zero_inflated_poisson())
+

Again, we summarize the results using the usual methods.

+
summary(fit_zinb1)
+
 Family: zero_inflated_poisson 
+  Links: mu = log; zi = identity 
+Formula: count ~ persons + child + camper 
+   Data: zinb (Number of observations: 250) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    -1.01      0.17    -1.35    -0.69 1.00     2727     2896
+persons       0.87      0.04     0.79     0.96 1.00     2435     2644
+child        -1.37      0.09    -1.55    -1.19 1.00     3005     3156
+camper        0.80      0.09     0.62     0.99 1.00     3320     2666
+
+Family Specific Parameters: 
+   Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+zi     0.41      0.04     0.32     0.50 1.00     2935     2544
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(conditional_effects(fit_zinb1), ask = FALSE)
+

+

According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability zi is pretty large with a mean of 41%. Please note that the probability of catching no fish is actually higher than 41%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-inflation). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here).

+

Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish. Most children are just terribly bad at waiting for hours until something happens. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data.

+
fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child),
+                 data = zinb, family = zero_inflated_poisson())
+
summary(fit_zinb2)
+
 Family: zero_inflated_poisson 
+  Links: mu = log; zi = logit 
+Formula: count ~ persons + child + camper 
+         zi ~ child
+   Data: zinb (Number of observations: 250) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept       -1.08      0.18    -1.44    -0.74 1.00     2925     2991
+zi_Intercept    -0.96      0.25    -1.50    -0.49 1.00     3824     3028
+persons          0.89      0.05     0.81     0.98 1.00     2931     2432
+child           -1.18      0.09    -1.36    -1.00 1.00     3113     2838
+camper           0.78      0.09     0.59     0.96 1.00     3654     2868
+zi_child         1.22      0.27     0.71     1.77 1.00     3696     3032
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(conditional_effects(fit_zinb2), ask = FALSE)
+

+

To transform the linear predictor of zi into a probability, brms applies the logit-link:

+

\[logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}\]

+

The logit-link takes values within \([0, 1]\) and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors.

+

According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your change of catching no fish at all (as implied by the zero-inflation part) most likely because groups with more children are not even trying.

+
+
+

Additive Distributional Models

+

In the examples so far, we did not have multilevel data and thus did not fully use the capabilities of the distributional regression framework of brms. In the example presented below, we will not only show how to deal with multilevel data in distributional models, but also how to incorporate smooth terms (i.e., splines) into the model. In many applications, we have no or only a very vague idea how the relationship between a predictor and the response looks like. A very flexible approach to tackle this problems is to use splines and let them figure out the form of the relationship. For illustration purposes, we simulate some data with the mgcv package, which is also used in brms to prepare smooth terms.

+
dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE)
+
Gu & Wahba 4 term additive model
+
head(dat_smooth[, 1:6])
+
          y        x0        x1         x2        x3         f
+1  9.936558 0.1973287 0.7004375 0.40864152 0.9353307 12.243452
+2 15.371527 0.4643275 0.1872081 0.42545194 0.7630161 13.055025
+3 17.064734 0.4213382 0.9984329 0.01129940 0.9500368 18.318051
+4 18.142893 0.2651790 0.9341625 0.82298324 0.1433123 20.679426
+5 10.781404 0.3738912 0.6881174 0.01021943 0.7583943  8.814676
+6 17.458429 0.9558911 0.1973761 0.29053608 0.4920378 15.715280
+

The data contains the predictors x0 to x3 as well as the grouping factor fac indicating the nested structure of the data. We predict the response variable y using smooth terms of x1 and x2 and a varying intercept of fac. In addition, we assume the residual standard deviation sigma to vary by a smoothing term of x0 and a varying intercept of fac.

+
fit_smooth1 <- brm(
+  bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)),
+  data = dat_smooth, family = gaussian(),
+  chains = 2, control = list(adapt_delta = 0.95)
+)
+
summary(fit_smooth1)
+
 Family: gaussian 
+  Links: mu = identity; sigma = log 
+Formula: y ~ s(x1) + s(x2) + (1 | fac) 
+         sigma ~ s(x0) + (1 | fac)
+   Data: dat_smooth (Number of observations: 200) 
+  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 2000
+
+Smooth Terms: 
+                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sds(sx1_1)           2.26      1.52     0.32     6.22 1.00      910      849
+sds(sx2_1)          19.44      5.56    11.51    33.54 1.00      617      891
+sds(sigma_sx0_1)     0.62      0.70     0.02     2.63 1.00      621      822
+
+Group-Level Effects: 
+~fac (Number of levels: 4) 
+                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)           4.84      2.17     2.26    10.58 1.00     1128     1320
+sd(sigma_Intercept)     0.18      0.23     0.01     0.71 1.00      648      793
+
+Population-Level Effects: 
+                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept          15.09      2.14    10.67    19.60 1.00      801      943
+sigma_Intercept     0.76      0.13     0.49     1.02 1.00      997      966
+sx1_1               7.96      4.64    -2.30    17.03 1.00     1454     1159
+sx2_1              40.11     13.23    14.40    66.66 1.00     1246     1133
+sigma_sx0_1        -0.61      1.72    -5.65     1.78 1.00      744      594
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE)
+

+

This model is likely an overkill for the data at hand, but nicely demonstrates the ease with which one can specify complex models with brms and to fit them using Stan on the backend.

+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_distreg.R r-cran-brms-2.17.0/inst/doc/brms_distreg.R --- r-cran-brms-2.16.3/inst/doc/brms_distreg.R 2021-11-22 15:49:50.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_distreg.R 2022-04-11 07:57:12.000000000 +0000 @@ -1,81 +1,81 @@ -params <- -list(EVAL = TRUE) - -## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) - -## --------------------------------------------------------------------------------------- -group <- rep(c("treat", "placebo"), each = 30) -symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) -dat1 <- data.frame(group, symptom_post) -head(dat1) - -## ---- results='hide'-------------------------------------------------------------------- -fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), - data = dat1, family = gaussian()) - -## ---- results='hide'-------------------------------------------------------------------- -summary(fit1) -plot(fit1, N = 2, ask = FALSE) -plot(conditional_effects(fit1), points = TRUE) - -## --------------------------------------------------------------------------------------- -hyp <- c("exp(sigma_Intercept) = 0", - "exp(sigma_Intercept + sigma_grouptreat) = 0") -hypothesis(fit1, hyp) - -## --------------------------------------------------------------------------------------- -hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" -(hyp <- hypothesis(fit1, hyp)) -plot(hyp, chars = NULL) - -## --------------------------------------------------------------------------------------- -zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") -head(zinb) - -## ---- results='hide'-------------------------------------------------------------------- -fit_zinb1 <- brm(count ~ persons + child + camper, - data = zinb, family = zero_inflated_poisson()) - -## --------------------------------------------------------------------------------------- -summary(fit_zinb1) -plot(conditional_effects(fit_zinb1), ask = FALSE) - -## ---- results='hide'-------------------------------------------------------------------- -fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), - data = zinb, family = zero_inflated_poisson()) - -## --------------------------------------------------------------------------------------- -summary(fit_zinb2) -plot(conditional_effects(fit_zinb2), ask = FALSE) - -## --------------------------------------------------------------------------------------- -dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) -head(dat_smooth[, 1:6]) - -## ---- results='hide'-------------------------------------------------------------------- -fit_smooth1 <- brm( - bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), - data = dat_smooth, family = gaussian(), - chains = 2, control = list(adapt_delta = 0.95) -) - -## --------------------------------------------------------------------------------------- -summary(fit_smooth1) -plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) - +params <- +list(EVAL = TRUE) + +## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) + +## --------------------------------------------------------------------------------------- +group <- rep(c("treat", "placebo"), each = 30) +symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) +dat1 <- data.frame(group, symptom_post) +head(dat1) + +## ---- results='hide'-------------------------------------------------------------------- +fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), + data = dat1, family = gaussian()) + +## ---- results='hide'-------------------------------------------------------------------- +summary(fit1) +plot(fit1, N = 2, ask = FALSE) +plot(conditional_effects(fit1), points = TRUE) + +## --------------------------------------------------------------------------------------- +hyp <- c("exp(sigma_Intercept) = 0", + "exp(sigma_Intercept + sigma_grouptreat) = 0") +hypothesis(fit1, hyp) + +## --------------------------------------------------------------------------------------- +hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" +(hyp <- hypothesis(fit1, hyp)) +plot(hyp, chars = NULL) + +## --------------------------------------------------------------------------------------- +zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") +head(zinb) + +## ---- results='hide'-------------------------------------------------------------------- +fit_zinb1 <- brm(count ~ persons + child + camper, + data = zinb, family = zero_inflated_poisson()) + +## --------------------------------------------------------------------------------------- +summary(fit_zinb1) +plot(conditional_effects(fit_zinb1), ask = FALSE) + +## ---- results='hide'-------------------------------------------------------------------- +fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), + data = zinb, family = zero_inflated_poisson()) + +## --------------------------------------------------------------------------------------- +summary(fit_zinb2) +plot(conditional_effects(fit_zinb2), ask = FALSE) + +## --------------------------------------------------------------------------------------- +dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) +head(dat_smooth[, 1:6]) + +## ---- results='hide'-------------------------------------------------------------------- +fit_smooth1 <- brm( + bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), + data = dat_smooth, family = gaussian(), + chains = 2, control = list(adapt_delta = 0.95) +) + +## --------------------------------------------------------------------------------------- +summary(fit_smooth1) +plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_distreg.Rmd r-cran-brms-2.17.0/inst/doc/brms_distreg.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_distreg.Rmd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_distreg.Rmd 2022-04-11 07:20:41.000000000 +0000 @@ -1,254 +1,254 @@ ---- -title: "Estimating Distributional Models with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Distributional Models with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -This vignette provides an introduction on how to fit distributional regression -models with **brms**. We use the term *distributional model* to refer to a -model, in which we can specify predictor terms for all parameters of the assumed -response distribution. In the vast majority of regression model implementations, -only the location parameter (usually the mean) of the response distribution -depends on the predictors and corresponding regression parameters. Other -parameters (e.g., scale or shape parameters) are estimated as auxiliary -parameters assuming them to be constant across observations. This assumption is -so common that most researchers applying regression models are often (in my -experience) not aware of the possibility of relaxing it. This is understandable -insofar as relaxing this assumption drastically increase model complexity and -thus makes models hard to fit. Fortunately, **brms** uses **Stan** on the -backend, which is an incredibly flexible and powerful tool for estimating -Bayesian models so that model complexity is much less of an issue. - -Suppose we have a normally distributed response variable. Then, in basic linear -regression, we specify a predictor term $\eta_{\mu}$ for the mean parameter -$\mu$ of the normal distribution. The second parameter of the normal -distribution -- the residual standard deviation $\sigma$ -- is assumed to be -constant across observations. We estimate $\sigma$ but do not try to *predict* -it. In a distributional model, however, we do exactly this by specifying a -predictor term $\eta_{\sigma}$ for $\sigma$ in addition to the predictor term -$\eta_{\mu}$. Ignoring group-level effects for the moment, the linear predictor -of a parameter $\theta$ for observation $n$ has the form - -$$\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}$$ -where $x_{\theta i n}$ denotes the value of the $i$th predictor of parameter -$\theta$ for observation $n$ and $b_{\theta i}$ is the $i$th regression -coefficient of parameter $\theta$. A distributional normal model with response -variable $y$ can then be written as - -$$y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)$$ -We used the exponential function around $\eta_{\sigma}$ to reflect that $\sigma$ -constitutes a standard deviation and thus only takes on positive values, while a -linear predictor can be any real number. - -## A simple distributional model - -Unequal variance models are possibly the most simple, but nevertheless very -important application of distributional models. Suppose we have two groups of -patients: One group receives a treatment (e.g., an antidepressive drug) and -another group receives placebo. Since the treatment may not work equally well -for all patients, the symptom variance of the treatment group may be larger than -the symptom variance of the placebo group after some weeks of treatment. For -simplicity, assume that we only investigate the post-treatment values. - -```{r} -group <- rep(c("treat", "placebo"), each = 30) -symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) -dat1 <- data.frame(group, symptom_post) -head(dat1) -``` - -The following model estimates the effect of `group` on both the mean and the -residual standard deviation of the normal response distribution. - -```{r, results='hide'} -fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), - data = dat1, family = gaussian()) -``` - -Useful summary statistics and plots can be obtained via - -```{r, results='hide'} -summary(fit1) -plot(fit1, N = 2, ask = FALSE) -plot(conditional_effects(fit1), points = TRUE) -``` - -The population-level effect `sigma_grouptreat`, which is the contrast of the two -residual standard deviations on the log-scale, reveals that the variances of -both groups are indeed different. This impression is confirmed when looking at -the `conditional_effects` of `group`. Going one step further, we can compute the -residual standard deviations on the original scale using the `hypothesis` -method. - -```{r} -hyp <- c("exp(sigma_Intercept) = 0", - "exp(sigma_Intercept + sigma_grouptreat) = 0") -hypothesis(fit1, hyp) -``` - -We may also directly compare them and plot the posterior distribution of their -difference. - -```{r} -hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" -(hyp <- hypothesis(fit1, hyp)) -plot(hyp, chars = NULL) -``` - -Indeed, the residual standard deviation of the treatment group seems to larger -than that of the placebo group. Moreover the magnitude of this difference is -pretty similar to what we expected due to the values we put into the data -simulations. - -## Zero-Inflated Models - -Another important application of the distributional regression framework are so -called zero-inflated models. These models are helpful whenever there are more -zeros in the response variable than one would naturally expect. For example, if -one seeks to predict the number of cigarettes people smoke per day and also -includes non-smokers, there will be a huge amount of zeros which, when not -modeled appropriately, can seriously distort parameter estimates. Here, we -consider an example dealing with the number of fish caught by various groups of -people. On the UCLA website -(\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), -the data are described as follows: "The state wildlife biologists want to model -how many fish are being caught by fishermen at a state park. Visitors are asked -how long they stayed, how many people were in the group, were there children in -the group and how many fish were caught. Some visitors do not fish, but there is -no data on whether a person fished or not. Some visitors who did fish did not -catch any fish so there are excess zeros in the data because of the people that -did not fish." - -```{r} -zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") -head(zinb) -``` - -As predictors we choose the number of people per group, the number of children, -as well as whether the group consists of campers. Many groups may not even try -catching any fish at all (thus leading to many zero responses) and so we fit a -zero-inflated Poisson model to the data. For now, we assume a constant -zero-inflation probability across observations. - -```{r, results='hide'} -fit_zinb1 <- brm(count ~ persons + child + camper, - data = zinb, family = zero_inflated_poisson()) -``` - -Again, we summarize the results using the usual methods. - -```{r} -summary(fit_zinb1) -plot(conditional_effects(fit_zinb1), ask = FALSE) -``` - -According to the parameter estimates, larger groups catch more fish, campers -catch more fish than non-campers, and groups with more children catch less fish. -The zero-inflation probability `zi` is pretty large with a mean of 41%. Please -note that the probability of catching no fish is actually higher than 41%, but -parts of this probability are already modeled by the Poisson distribution itself -(hence the name zero-*inflation*). If you want to treat all zeros as originating -from a separate process, you can use hurdle models instead (not shown here). - -Now, we try to additionally predict the zero-inflation probability by the number -of children. The underlying reasoning is that we expect groups with more -children to not even try catching fish. Most children are just terribly bad at -waiting for hours until something happens. From a purely statistical -perspective, zero-inflated (and hurdle) distributions are a mixture of two -processes and predicting both parts of the model is natural and often very -reasonable to make full use of the data. - -```{r, results='hide'} -fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), - data = zinb, family = zero_inflated_poisson()) -``` - -```{r} -summary(fit_zinb2) -plot(conditional_effects(fit_zinb2), ask = FALSE) -``` - -To transform the linear predictor of `zi` into a probability, **brms** applies -the logit-link: - -$$logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}$$ - -The logit-link takes values within $[0, 1]$ and returns values on the real line. -Thus, it allows the transition between probabilities and linear predictors. - -According to the model, trying to fish with children not only decreases the -overall number fish caught (as implied by the Poisson part of the model) but -also drastically increases your change of catching no fish at all (as implied by -the zero-inflation part) most likely because groups with more children are not -even trying. - -## Additive Distributional Models - -In the examples so far, we did not have multilevel data and thus did not fully -use the capabilities of the distributional regression framework of **brms**. In -the example presented below, we will not only show how to deal with multilevel -data in distributional models, but also how to incorporate smooth terms (i.e., -splines) into the model. In many applications, we have no or only a very vague -idea how the relationship between a predictor and the response looks like. A -very flexible approach to tackle this problems is to use splines and let them -figure out the form of the relationship. For illustration purposes, we simulate -some data with the **mgcv** package, which is also used in **brms** to prepare -smooth terms. - -```{r} -dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) -head(dat_smooth[, 1:6]) -``` - -The data contains the predictors `x0` to `x3` as well as the grouping factor -`fac` indicating the nested structure of the data. We predict the response -variable `y` using smooth terms of `x1` and `x2` and a varying intercept of -`fac`. In addition, we assume the residual standard deviation `sigma` to vary by -a smoothing term of `x0` and a varying intercept of `fac`. - -```{r, results='hide'} -fit_smooth1 <- brm( - bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), - data = dat_smooth, family = gaussian(), - chains = 2, control = list(adapt_delta = 0.95) -) -``` - -```{r} -summary(fit_smooth1) -plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) -``` - -This model is likely an overkill for the data at hand, but nicely demonstrates -the ease with which one can specify complex models with **brms** and to fit them -using **Stan** on the backend. +--- +title: "Estimating Distributional Models with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Distributional Models with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +This vignette provides an introduction on how to fit distributional regression +models with **brms**. We use the term *distributional model* to refer to a +model, in which we can specify predictor terms for all parameters of the assumed +response distribution. In the vast majority of regression model implementations, +only the location parameter (usually the mean) of the response distribution +depends on the predictors and corresponding regression parameters. Other +parameters (e.g., scale or shape parameters) are estimated as auxiliary +parameters assuming them to be constant across observations. This assumption is +so common that most researchers applying regression models are often (in my +experience) not aware of the possibility of relaxing it. This is understandable +insofar as relaxing this assumption drastically increase model complexity and +thus makes models hard to fit. Fortunately, **brms** uses **Stan** on the +backend, which is an incredibly flexible and powerful tool for estimating +Bayesian models so that model complexity is much less of an issue. + +Suppose we have a normally distributed response variable. Then, in basic linear +regression, we specify a predictor term $\eta_{\mu}$ for the mean parameter +$\mu$ of the normal distribution. The second parameter of the normal +distribution -- the residual standard deviation $\sigma$ -- is assumed to be +constant across observations. We estimate $\sigma$ but do not try to *predict* +it. In a distributional model, however, we do exactly this by specifying a +predictor term $\eta_{\sigma}$ for $\sigma$ in addition to the predictor term +$\eta_{\mu}$. Ignoring group-level effects for the moment, the linear predictor +of a parameter $\theta$ for observation $n$ has the form + +$$\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}$$ +where $x_{\theta i n}$ denotes the value of the $i$th predictor of parameter +$\theta$ for observation $n$ and $b_{\theta i}$ is the $i$th regression +coefficient of parameter $\theta$. A distributional normal model with response +variable $y$ can then be written as + +$$y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)$$ +We used the exponential function around $\eta_{\sigma}$ to reflect that $\sigma$ +constitutes a standard deviation and thus only takes on positive values, while a +linear predictor can be any real number. + +## A simple distributional model + +Unequal variance models are possibly the most simple, but nevertheless very +important application of distributional models. Suppose we have two groups of +patients: One group receives a treatment (e.g., an antidepressive drug) and +another group receives placebo. Since the treatment may not work equally well +for all patients, the symptom variance of the treatment group may be larger than +the symptom variance of the placebo group after some weeks of treatment. For +simplicity, assume that we only investigate the post-treatment values. + +```{r} +group <- rep(c("treat", "placebo"), each = 30) +symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) +dat1 <- data.frame(group, symptom_post) +head(dat1) +``` + +The following model estimates the effect of `group` on both the mean and the +residual standard deviation of the normal response distribution. + +```{r, results='hide'} +fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), + data = dat1, family = gaussian()) +``` + +Useful summary statistics and plots can be obtained via + +```{r, results='hide'} +summary(fit1) +plot(fit1, N = 2, ask = FALSE) +plot(conditional_effects(fit1), points = TRUE) +``` + +The population-level effect `sigma_grouptreat`, which is the contrast of the two +residual standard deviations on the log-scale, reveals that the variances of +both groups are indeed different. This impression is confirmed when looking at +the `conditional_effects` of `group`. Going one step further, we can compute the +residual standard deviations on the original scale using the `hypothesis` +method. + +```{r} +hyp <- c("exp(sigma_Intercept) = 0", + "exp(sigma_Intercept + sigma_grouptreat) = 0") +hypothesis(fit1, hyp) +``` + +We may also directly compare them and plot the posterior distribution of their +difference. + +```{r} +hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" +(hyp <- hypothesis(fit1, hyp)) +plot(hyp, chars = NULL) +``` + +Indeed, the residual standard deviation of the treatment group seems to larger +than that of the placebo group. Moreover the magnitude of this difference is +pretty similar to what we expected due to the values we put into the data +simulations. + +## Zero-Inflated Models + +Another important application of the distributional regression framework are so +called zero-inflated models. These models are helpful whenever there are more +zeros in the response variable than one would naturally expect. For example, if +one seeks to predict the number of cigarettes people smoke per day and also +includes non-smokers, there will be a huge amount of zeros which, when not +modeled appropriately, can seriously distort parameter estimates. Here, we +consider an example dealing with the number of fish caught by various groups of +people. On the UCLA website +(\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), +the data are described as follows: "The state wildlife biologists want to model +how many fish are being caught by fishermen at a state park. Visitors are asked +how long they stayed, how many people were in the group, were there children in +the group and how many fish were caught. Some visitors do not fish, but there is +no data on whether a person fished or not. Some visitors who did fish did not +catch any fish so there are excess zeros in the data because of the people that +did not fish." + +```{r} +zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") +head(zinb) +``` + +As predictors we choose the number of people per group, the number of children, +as well as whether the group consists of campers. Many groups may not even try +catching any fish at all (thus leading to many zero responses) and so we fit a +zero-inflated Poisson model to the data. For now, we assume a constant +zero-inflation probability across observations. + +```{r, results='hide'} +fit_zinb1 <- brm(count ~ persons + child + camper, + data = zinb, family = zero_inflated_poisson()) +``` + +Again, we summarize the results using the usual methods. + +```{r} +summary(fit_zinb1) +plot(conditional_effects(fit_zinb1), ask = FALSE) +``` + +According to the parameter estimates, larger groups catch more fish, campers +catch more fish than non-campers, and groups with more children catch less fish. +The zero-inflation probability `zi` is pretty large with a mean of 41%. Please +note that the probability of catching no fish is actually higher than 41%, but +parts of this probability are already modeled by the Poisson distribution itself +(hence the name zero-*inflation*). If you want to treat all zeros as originating +from a separate process, you can use hurdle models instead (not shown here). + +Now, we try to additionally predict the zero-inflation probability by the number +of children. The underlying reasoning is that we expect groups with more +children to not even try catching fish. Most children are just terribly bad at +waiting for hours until something happens. From a purely statistical +perspective, zero-inflated (and hurdle) distributions are a mixture of two +processes and predicting both parts of the model is natural and often very +reasonable to make full use of the data. + +```{r, results='hide'} +fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), + data = zinb, family = zero_inflated_poisson()) +``` + +```{r} +summary(fit_zinb2) +plot(conditional_effects(fit_zinb2), ask = FALSE) +``` + +To transform the linear predictor of `zi` into a probability, **brms** applies +the logit-link: + +$$logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}$$ + +The logit-link takes values within $[0, 1]$ and returns values on the real line. +Thus, it allows the transition between probabilities and linear predictors. + +According to the model, trying to fish with children not only decreases the +overall number fish caught (as implied by the Poisson part of the model) but +also drastically increases your change of catching no fish at all (as implied by +the zero-inflation part) most likely because groups with more children are not +even trying. + +## Additive Distributional Models + +In the examples so far, we did not have multilevel data and thus did not fully +use the capabilities of the distributional regression framework of **brms**. In +the example presented below, we will not only show how to deal with multilevel +data in distributional models, but also how to incorporate smooth terms (i.e., +splines) into the model. In many applications, we have no or only a very vague +idea how the relationship between a predictor and the response looks like. A +very flexible approach to tackle this problems is to use splines and let them +figure out the form of the relationship. For illustration purposes, we simulate +some data with the **mgcv** package, which is also used in **brms** to prepare +smooth terms. + +```{r} +dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) +head(dat_smooth[, 1:6]) +``` + +The data contains the predictors `x0` to `x3` as well as the grouping factor +`fac` indicating the nested structure of the data. We predict the response +variable `y` using smooth terms of `x1` and `x2` and a varying intercept of +`fac`. In addition, we assume the residual standard deviation `sigma` to vary by +a smoothing term of `x0` and a varying intercept of `fac`. + +```{r, results='hide'} +fit_smooth1 <- brm( + bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), + data = dat_smooth, family = gaussian(), + chains = 2, control = list(adapt_delta = 0.95) +) +``` + +```{r} +summary(fit_smooth1) +plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) +``` + +This model is likely an overkill for the data at hand, but nicely demonstrates +the ease with which one can specify complex models with **brms** and to fit them +using **Stan** on the backend. diff -Nru r-cran-brms-2.16.3/inst/doc/brms_families.html r-cran-brms-2.17.0/inst/doc/brms_families.html --- r-cran-brms-2.16.3/inst/doc/brms_families.html 2021-11-22 15:49:51.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_families.html 2022-04-11 07:57:13.000000000 +0000 @@ -1,237 +1,244 @@ - - - - - - - - - - - - - - - - -Parameterization of Response Distributions in brms - - - - - - - - - - - - - - - - - - - - - - -

Parameterization of Response Distributions in brms

-

Paul Bürkner

-

2021-11-22

- - - - -

The purpose of this vignette is to discuss the parameterizations of the families (i.e., response distributions) used in brms. For a more general overview of the package see vignette("brms_overview").

-
-

Notation

-

Throughout this vignette, we denote values of the response variable as \(y\), a density function as \(f\), and use \(\mu\) to refer to the main model parameter, which is usually the mean of the response distribution or some closely related quantity. In a regression framework, \(\mu\) is not estimated directly but computed as \(\mu = g(\eta)\), where \(\eta\) is a predictor term (see help(brmsformula) for details) and \(g\) is the response function (i.e., inverse of the link function).

-
-
-

Location shift models

-

The density of the gaussian family is given by \[ -f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) -\]

-

where \(\sigma\) is the residual standard deviation. The density of the student family is given by \[ -f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} -\]

-

\(\Gamma\) denotes the gamma function and \(\nu > 1\) are the degrees of freedom. As \(\nu \rightarrow \infty\), the student distribution becomes the gaussian distribution. The density of the skew_normal family is given by \[ -f(y) = \frac{1}{\sqrt{2\pi}\sigma} - \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) -\left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) -\]

-

where \(\xi\) is the location parameter, \(\omega\) is the positive scale parameter, \(\alpha\) the skewness parameter, and \(\text{erf}\) denotes the error function of the gaussian distribution. To parameterize the skew-normal distribution in terms of the mean \(\mu\) and standard deviation \(\sigma\), \(\omega\) and \(\xi\) are computed as \[ -\omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} -\]

-

\[ -\xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} -\]

-

If \(\alpha = 0\), the skew-normal distribution becomes the gaussian distribution. For location shift models, \(y\) can be any real value.

-
-
-

Binary and count data models

-

The density of the binomial family is given by \[ -f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} -\] where \(N\) is the number of trials and \(y \in \{0, ... , N\}\). When all \(N\) are \(1\) (i.e., \(y \in \{0,1\}\)), the bernoulli distribution for binary data arises.

-

For \(y \in \mathbb{N}_0\), the density of the poisson family is given by \[ -f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) -\] The density of the negbinomial (negative binomial) family is \[ -f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} -\left(\frac{\phi}{\mu + \phi}\right)^\phi -\] where \(\phi\) is a positive precision parameter. For \(\phi \rightarrow \infty\), the negative binomial distribution becomes the poisson distribution. The density of the geometric family arises if \(\phi\) is set to \(1\).

- -
-
-

Time-to-event models

-

With time-to-event models we mean all models that are defined on the positive reals only, that is \(y \in \mathbb{R}^+\). The density of the lognormal family is given by \[ -f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) -\] where \(\sigma\) is the residual standard deviation on the log-scale. The density of the Gamma family is given by \[ -f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} -\exp\left(-\frac{\alpha y}{\mu}\right) -\] where \(\alpha\) is a positive shape parameter. The density of the weibull family is given by \[ -f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} -\exp\left(-\left(\frac{y}{s}\right)^\alpha\right) -\] where \(\alpha\) is again a positive shape parameter and \(s = \mu / \Gamma(1 + 1 / \alpha)\) is the scale parameter to that \(\mu\) is the mean of the distribution. The exponential family arises if \(\alpha\) is set to \(1\) for either the gamma or Weibull distribution. The density of the inverse.gaussian family is given by \[ -f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) -\] where \(\alpha\) is a positive shape parameter. The cox family implements Cox proportional hazards model which assumes a hazard function of the form \(h(y) = h_0(y) \mu\) with baseline hazard \(h_0(y)\) expressed via M-splines (which integrate to I-splines) in order to ensure monotonicity. The density of the cox model is then given by \[ -f(y) = h(y) S(y) -\] where \(S(y)\) is the survival function implied by \(h(y)\).

-
-
-

Extreme value models

-

Modeling extremes requires special distributions. One may use the weibull distribution (see above) or the frechet distribution with density \[ -f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) -\] where \(s = \mu / \Gamma(1 - 1 / \nu)\) is a positive scale parameter and \(\nu > 1\) is a shape parameter so that \(\mu\) predicts the mean of the Frechet distribution. A generalization of both distributions is the generalized extreme value distribution (family gen_extreme_value) with density \[ -f(y) = \frac{1}{\sigma} t(y)^{-1 - 1 / \xi} \exp(-t(y)) -\] where \[ -t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} -\] with positive scale parameter \(\sigma\) and shape parameter \(\xi\).

-
-
-

Response time models

-

One family that is especially suited to model reaction times is the exgaussian (‘exponentially modified Gaussian’) family. Its density is given by

-

\[ -f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) -\] where \(\beta\) is the scale (inverse rate) of the exponential component, \(\xi\) is the mean of the Gaussian component, \(\sigma\) is the standard deviation of the Gaussian component, and \(\text{erfc}\) is the complementary error function. We parameterize \(\mu = \xi + \beta\) so that the main predictor term equals the mean of the distribution.

-

Another family well suited for modeling response times is the shifted_lognormal distribution. It’s density equals that of the lognormal distribution except that the whole distribution is shifted to the right by a positive parameter called ndt (for consistency with the wiener diffusion model explained below).

-

A family concerned with the combined modeling of reaction times and corresponding binary responses is the wiener diffusion model. It has four model parameters each with a natural interpretation. The parameter \(\alpha > 0\) describes the separation between two boundaries of the diffusion process, \(\tau > 0\) describes the non-decision time (e.g., due to image or motor processing), \(\beta \in [0, 1]\) describes the initial bias in favor of the upper alternative, and \(\delta \in \mathbb{R}\) describes the drift rate to the boundaries (a positive value indicates a drift towards to upper boundary). The density for the reaction time at the upper boundary is given by

-

\[ -f(y) = \frac{\alpha}{(y-\tau)^3/2} -\exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) -\sum_{k = - \infty}^{\infty} (2k + \beta) -\phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) -\]

-

where \(\phi(x)\) denotes the standard normal density function. The density at the lower boundary can be obtained by substituting \(1 - \beta\) for \(\beta\) and \(-\delta\) for \(\delta\) in the above equation. In brms the parameters \(\alpha\), \(\tau\), and \(\beta\) are modeled as auxiliary parameters named bs (‘boundary separation’), ndt (‘non-decision time’), and bias respectively, whereas the drift rate \(\delta\) is modeled via the ordinary model formula that is as \(\delta = \mu\).

-
-
-

Quantile regression

-

Quantile regression is implemented via family asym_laplace (asymmetric Laplace distribution) with density

-

\[ -f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) -\] where \(\rho_p\) is given by \(\rho_p(x) = x (p - I_{x < 0})\) and \(I_A\) is the indicator function of set \(A\). The parameter \(\sigma\) is a positive scale parameter and \(p\) is the quantile parameter taking on values in \((0, 1)\). For this distribution, we have \(P(Y < g(\eta)) = p\). Thus, quantile regression can be performed by fixing \(p\) to the quantile to interest.

-
-
-

Probability models

-

The density of the Beta family for \(y \in (0,1)\) is given by \[ -f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} -\] where \(B\) is the beta function and \(\phi\) is a positive precision parameter. A multivariate generalization of the Beta family is the dirichlet family with density \[ -f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} - \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. -\] The dirichlet distribution is only implemented with the multivariate logit link function so that \[ -\mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} -\] For reasons of identifiability, \(\eta_{1}\) is set to \(0\).

-
-
-

Circular models

-

The density of the von_mises family for \(y \in (-\pi,\pi)\) is given by \[ -f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} -\] where \(I_0\) is the modified Bessel function of order 0 and \(\kappa\) is a positive precision parameter.

-
-
-

Ordinal and categorical models

-

For ordinal and categorical models, \(y\) is one of the categories \(1, ..., K\). The intercepts of ordinal models are called thresholds and are denoted as \(\tau_k\), with \(k \in \{1, ..., K-1\}\), whereas \(\eta\) does not contain a fixed effects intercept. Note that the applied link functions \(h\) are technically distribution functions \(\mathbb{R} \rightarrow [0,1]\). The density of the cumulative family (implementing the most basic ordinal model) is given by \[ -f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) -\]

-

The densities of the sratio (stopping ratio) and cratio (continuation ratio) families are given by \[ -f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) -\] and \[ -f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) -\]

-

respectively. Note that both families are equivalent for symmetric link functions such as logit or probit. The density of the acat (adjacent category) family is given by \[ -f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) - \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) - \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} -\] For the logit link, this can be simplified to \[ -f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} - {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} -\] The linear predictor \(\eta\) can be generalized to also depend on the category \(k\) for a subset of predictors. This leads to category specific effects (for details on how to specify them see help(brm)). Note that cumulative and sratio models use \(\tau - \eta\), whereas cratio and acat use \(\eta - \tau\). This is done to ensure that larger values of \(\eta\) increase the probability of higher response categories.

-

The categorical family is currently only implemented with the multivariate logit link function and has density \[ -f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} -\] Note that \(\eta\) does also depend on the category \(k\). For reasons of identifiability, \(\eta_{1}\) is set to \(0\). A generalization of the categorical family to more than one trial is the multinomial family with density \[ -f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} - \prod_{k=1}^K \mu_{k}^{y_{k}} -\] where, for each category, \(\mu_{k}\) is estimated via the multivariate logit link function shown above.

-
-
-

Zero-inflated and hurdle models

-

Zero-inflated and hurdle families extend existing families by adding special processes for responses that are zero. The density of a zero-inflated family is given by \[ -f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ -f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 -\] where \(z\) denotes the zero-inflation probability. Currently implemented families are zero_inflated_poisson, zero_inflated_binomial, zero_inflated_negbinomial, and zero_inflated_beta.

-

The density of a hurdle family is given by \[ -f_z(y) = z \quad \text{if } y = 0 \\ -f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 -\] Currently implemented families are hurdle_poisson, hurdle_negbinomial, hurdle_gamma, and hurdle_lognormal.

-

The density of a zero-one-inflated family is given by \[ -f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ -f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ -f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} -\] where \(\alpha\) is the zero-one-inflation probability (i.e. the probability that zero or one occurs) and \(\gamma\) is the conditional one-inflation probability (i.e. the probability that one occurs rather than zero). Currently implemented families are zero_one_inflated_beta.

-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Parameterization of Response Distributions in brms + + + + + + + + + + + + + + + + + + + + + + +

Parameterization of Response Distributions in brms

+

Paul Bürkner

+

2022-04-11

+ + + + +

The purpose of this vignette is to discuss the parameterizations of the families (i.e., response distributions) used in brms. For a more general overview of the package see vignette("brms_overview").

+
+

Notation

+

Throughout this vignette, we denote values of the response variable as \(y\), a density function as \(f\), and use \(\mu\) to refer to the main model parameter, which is usually the mean of the response distribution or some closely related quantity. In a regression framework, \(\mu\) is not estimated directly but computed as \(\mu = g(\eta)\), where \(\eta\) is a predictor term (see help(brmsformula) for details) and \(g\) is the response function (i.e., inverse of the link function).

+
+
+

Location shift models

+

The density of the gaussian family is given by \[ +f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) +\]

+

where \(\sigma\) is the residual standard deviation. The density of the student family is given by \[ +f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} +\]

+

\(\Gamma\) denotes the gamma function and \(\nu > 1\) are the degrees of freedom. As \(\nu \rightarrow \infty\), the student distribution becomes the gaussian distribution. The density of the skew_normal family is given by \[ +f(y) = \frac{1}{\sqrt{2\pi}\omega} + \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) +\left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) +\]

+

where \(\xi\) is the location parameter, \(\omega\) is the positive scale parameter, \(\alpha\) the skewness parameter, and \(\text{erf}\) denotes the error function of the gaussian distribution. To parameterize the skew-normal distribution in terms of the mean \(\mu\) and standard deviation \(\sigma\), \(\omega\) and \(\xi\) are computed as \[ +\omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} +\]

+

\[ +\xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} +\]

+

If \(\alpha = 0\), the skew-normal distribution becomes the gaussian distribution. For location shift models, \(y\) can be any real value.

+
+
+

Binary and count data models

+

The density of the binomial family is given by \[ +f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} +\] where \(N\) is the number of trials and \(y \in \{0, ... , N\}\). When all \(N\) are \(1\) (i.e., \(y \in \{0,1\}\)), the bernoulli distribution for binary data arises.

+

For \(y \in \mathbb{N}_0\), the density of the poisson family is given by \[ +f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) +\] The density of the negbinomial (negative binomial) family is \[ +f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} +\left(\frac{\phi}{\mu + \phi}\right)^\phi +\] where \(\phi\) is a positive precision parameter. For \(\phi \rightarrow \infty\), the negative binomial distribution becomes the poisson distribution. The density of the geometric family arises if \(\phi\) is set to \(1\).

+ +
+
+

Time-to-event models

+

With time-to-event models we mean all models that are defined on the positive reals only, that is \(y \in \mathbb{R}^+\). The density of the lognormal family is given by \[ +f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) +\] where \(\sigma\) is the residual standard deviation on the log-scale. The density of the Gamma family is given by \[ +f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} +\exp\left(-\frac{\alpha y}{\mu}\right) +\] where \(\alpha\) is a positive shape parameter. The density of the weibull family is given by \[ +f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} +\exp\left(-\left(\frac{y}{s}\right)^\alpha\right) +\] where \(\alpha\) is again a positive shape parameter and \(s = \mu / \Gamma(1 + 1 / \alpha)\) is the scale parameter to that \(\mu\) is the mean of the distribution. The exponential family arises if \(\alpha\) is set to \(1\) for either the gamma or Weibull distribution. The density of the inverse.gaussian family is given by \[ +f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) +\] where \(\alpha\) is a positive shape parameter. The cox family implements Cox proportional hazards model which assumes a hazard function of the form \(h(y) = h_0(y) \mu\) with baseline hazard \(h_0(y)\) expressed via M-splines (which integrate to I-splines) in order to ensure monotonicity. The density of the cox model is then given by \[ +f(y) = h(y) S(y) +\] where \(S(y)\) is the survival function implied by \(h(y)\).

+
+
+

Extreme value models

+

Modeling extremes requires special distributions. One may use the weibull distribution (see above) or the frechet distribution with density \[ +f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) +\] where \(s = \mu / \Gamma(1 - 1 / \nu)\) is a positive scale parameter and \(\nu > 1\) is a shape parameter so that \(\mu\) predicts the mean of the Frechet distribution. A generalization of both distributions is the generalized extreme value distribution (family gen_extreme_value) with density \[ +f(y) = \frac{1}{\sigma} t(y)^{-1 - 1 / \xi} \exp(-t(y)) +\] where \[ +t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} +\] with positive scale parameter \(\sigma\) and shape parameter \(\xi\).

+
+
+

Response time models

+

One family that is especially suited to model reaction times is the exgaussian (‘exponentially modified Gaussian’) family. Its density is given by

+

\[ +f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) +\] where \(\beta\) is the scale (inverse rate) of the exponential component, \(\xi\) is the mean of the Gaussian component, \(\sigma\) is the standard deviation of the Gaussian component, and \(\text{erfc}\) is the complementary error function. We parameterize \(\mu = \xi + \beta\) so that the main predictor term equals the mean of the distribution.

+

Another family well suited for modeling response times is the shifted_lognormal distribution. It’s density equals that of the lognormal distribution except that the whole distribution is shifted to the right by a positive parameter called ndt (for consistency with the wiener diffusion model explained below).

+

A family concerned with the combined modeling of reaction times and corresponding binary responses is the wiener diffusion model. It has four model parameters each with a natural interpretation. The parameter \(\alpha > 0\) describes the separation between two boundaries of the diffusion process, \(\tau > 0\) describes the non-decision time (e.g., due to image or motor processing), \(\beta \in [0, 1]\) describes the initial bias in favor of the upper alternative, and \(\delta \in \mathbb{R}\) describes the drift rate to the boundaries (a positive value indicates a drift towards to upper boundary). The density for the reaction time at the upper boundary is given by

+

\[ +f(y) = \frac{\alpha}{(y-\tau)^3/2} +\exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) +\sum_{k = - \infty}^{\infty} (2k + \beta) +\phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) +\]

+

where \(\phi(x)\) denotes the standard normal density function. The density at the lower boundary can be obtained by substituting \(1 - \beta\) for \(\beta\) and \(-\delta\) for \(\delta\) in the above equation. In brms the parameters \(\alpha\), \(\tau\), and \(\beta\) are modeled as auxiliary parameters named bs (‘boundary separation’), ndt (‘non-decision time’), and bias respectively, whereas the drift rate \(\delta\) is modeled via the ordinary model formula that is as \(\delta = \mu\).

+
+
+

Quantile regression

+

Quantile regression is implemented via family asym_laplace (asymmetric Laplace distribution) with density

+

\[ +f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) +\] where \(\rho_p\) is given by \(\rho_p(x) = x (p - I_{x < 0})\) and \(I_A\) is the indicator function of set \(A\). The parameter \(\sigma\) is a positive scale parameter and \(p\) is the quantile parameter taking on values in \((0, 1)\). For this distribution, we have \(P(Y < g(\eta)) = p\). Thus, quantile regression can be performed by fixing \(p\) to the quantile to interest.

+
+
+

Probability models

+

The density of the Beta family for \(y \in (0,1)\) is given by \[ +f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} +\] where \(B\) is the beta function and \(\phi\) is a positive precision parameter. A multivariate generalization of the Beta family is the dirichlet family with density \[ +f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} + \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. +\] The dirichlet family is implemented with the multivariate logit link function so that \[ +\mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} +\] For reasons of identifiability, \(\eta_{\rm ref}\) is set to \(0\), where \({\rm ref}\) is one of the response categories chosen as reference.

+

An alternative to the dirichlet family is the logistic_normal family with density \[ +f(y) = \frac{1}{\prod_{k=1}^K y_k} \times + \text{multivariate_normal}(\tilde{y} \, | \, \mu, \sigma, \Omega) +\] where \(\tilde{y}\) is the multivariate logit transformed response \[ +\tilde{y} = (\log(y_1 / y_{\rm ref}), \ldots, \log(y_{\rm ref-1} / y_{\rm ref}), + \log(y_{\rm ref+1} / y_{\rm ref}), \ldots, \log(y_K / y_{\rm ref})) +\] of dimension \(K-1\) (excluding the reference category), which is modeled as multivariate normally distributed with latent mean and standard deviation vectors \(\mu\) and \(\sigma\), as well as correlation matrix \(\Omega\).

+
+
+

Circular models

+

The density of the von_mises family for \(y \in (-\pi,\pi)\) is given by \[ +f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} +\] where \(I_0\) is the modified Bessel function of order 0 and \(\kappa\) is a positive precision parameter.

+
+
+

Ordinal and categorical models

+

For ordinal and categorical models, \(y\) is one of the categories \(1, ..., K\). The intercepts of ordinal models are called thresholds and are denoted as \(\tau_k\), with \(k \in \{1, ..., K-1\}\), whereas \(\eta\) does not contain a fixed effects intercept. Note that the applied link functions \(h\) are technically distribution functions \(\mathbb{R} \rightarrow [0,1]\). The density of the cumulative family (implementing the most basic ordinal model) is given by \[ +f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) +\]

+

The densities of the sratio (stopping ratio) and cratio (continuation ratio) families are given by \[ +f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) +\] and \[ +f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) +\]

+

respectively. Note that both families are equivalent for symmetric link functions such as logit or probit. The density of the acat (adjacent category) family is given by \[ +f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) + \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) + \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} +\] For the logit link, this can be simplified to \[ +f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} + {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} +\] The linear predictor \(\eta\) can be generalized to also depend on the category \(k\) for a subset of predictors. This leads to category specific effects (for details on how to specify them see help(brm)). Note that cumulative and sratio models use \(\tau - \eta\), whereas cratio and acat use \(\eta - \tau\). This is done to ensure that larger values of \(\eta\) increase the probability of higher response categories.

+

The categorical family is currently only implemented with the multivariate logit link function and has density \[ +f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} +\] Note that \(\eta\) does also depend on the category \(k\). For reasons of identifiability, \(\eta_{1}\) is set to \(0\). A generalization of the categorical family to more than one trial is the multinomial family with density \[ +f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} + \prod_{k=1}^K \mu_{k}^{y_{k}} +\] where, for each category, \(\mu_{k}\) is estimated via the multivariate logit link function shown above.

+
+
+

Zero-inflated and hurdle models

+

Zero-inflated and hurdle families extend existing families by adding special processes for responses that are zero. The density of a zero-inflated family is given by \[ +f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ +f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 +\] where \(z\) denotes the zero-inflation probability. Currently implemented families are zero_inflated_poisson, zero_inflated_binomial, zero_inflated_negbinomial, and zero_inflated_beta.

+

The density of a hurdle family is given by \[ +f_z(y) = z \quad \text{if } y = 0 \\ +f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 +\] Currently implemented families are hurdle_poisson, hurdle_negbinomial, hurdle_gamma, and hurdle_lognormal.

+

The density of a zero-one-inflated family is given by \[ +f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ +f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ +f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} +\] where \(\alpha\) is the zero-one-inflation probability (i.e. the probability that zero or one occurs) and \(\gamma\) is the conditional one-inflation probability (i.e. the probability that one occurs rather than zero). Currently implemented families are zero_one_inflated_beta.

+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_families.Rmd r-cran-brms-2.17.0/inst/doc/brms_families.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_families.Rmd 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_families.Rmd 2022-04-08 11:57:41.000000000 +0000 @@ -1,332 +1,349 @@ ---- -title: "Parameterization of Response Distributions in brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Parameterization of Response Distributions in brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} ---- - -The purpose of this vignette is to discuss the parameterizations of the families -(i.e., response distributions) used in brms. For a more general overview of -the package see `vignette("brms_overview")`. - -## Notation - -Throughout this vignette, we denote values of the response variable as $y$, a -density function as $f$, and use $\mu$ to refer to the main model parameter, -which is usually the mean of the response distribution or some closely related -quantity. In a regression framework, $\mu$ is not estimated directly but -computed as $\mu = g(\eta)$, where $\eta$ is a predictor term (see -`help(brmsformula)` for details) and $g$ is the response function (i.e., -inverse of the link function). - -## Location shift models - -The density of the **gaussian** family is given by -$$ -f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) -$$ - -where $\sigma$ is the residual standard deviation. The density of the -**student** family is given by -$$ -f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} -$$ - -$\Gamma$ denotes the gamma function and $\nu > 1$ are the degrees of freedom. As -$\nu \rightarrow \infty$, the student distribution becomes the gaussian -distribution. The density of the **skew_normal** family is given by -$$ -f(y) = \frac{1}{\sqrt{2\pi}\sigma} - \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) -\left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) -$$ - -where $\xi$ is the location parameter, $\omega$ is the positive scale parameter, -$\alpha$ the skewness parameter, and $\text{erf}$ denotes the error function of -the gaussian distribution. To parameterize the skew-normal distribution in terms -of the mean $\mu$ and standard deviation $\sigma$, $\omega$ and $\xi$ are -computed as -$$ -\omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} -$$ - -$$ -\xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} -$$ - -If $\alpha = 0$, the skew-normal distribution becomes the gaussian distribution. -For location shift models, $y$ can be any real value. - -## Binary and count data models - -The density of the **binomial** family is given by -$$ -f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} -$$ -where $N$ is the number of trials and $y \in \{0, ... , N\}$. When all -$N$ are $1$ (i.e., $y \in \{0,1\}$), the **bernoulli** distribution for binary -data arises. - -For $y \in \mathbb{N}_0$, the density of the **poisson** family is given by -$$ -f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) -$$ -The density of the **negbinomial** (negative binomial) family is -$$ -f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} -\left(\frac{\phi}{\mu + \phi}\right)^\phi -$$ -where $\phi$ is a positive precision parameter. For $\phi \rightarrow \infty$, -the negative binomial distribution becomes the poisson distribution. The density -of the **geometric** family arises if $\phi$ is set to $1$. - - - -## Time-to-event models - -With time-to-event models we mean all models that are defined on the positive -reals only, that is $y \in \mathbb{R}^+$. The density of the **lognormal** -family is given by -$$ -f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) -$$ -where $\sigma$ is the residual standard deviation on the log-scale. -The density of the **Gamma** family is given by -$$ -f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} -\exp\left(-\frac{\alpha y}{\mu}\right) -$$ -where $\alpha$ is a positive shape parameter. The density of the **weibull** -family is given by -$$ -f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} -\exp\left(-\left(\frac{y}{s}\right)^\alpha\right) -$$ -where $\alpha$ is again a positive shape parameter and -$s = \mu / \Gamma(1 + 1 / \alpha)$ is the scale parameter to that $\mu$ -is the mean of the distribution. The **exponential** family arises if $\alpha$ -is set to $1$ for either the gamma or Weibull distribution. The density of the -**inverse.gaussian** family is given by -$$ -f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) -$$ -where $\alpha$ is a positive shape parameter. The **cox** family implements Cox -proportional hazards model which assumes a hazard function of the form $h(y) = -h_0(y) \mu$ with baseline hazard $h_0(y)$ expressed via M-splines (which -integrate to I-splines) in order to ensure monotonicity. The density of the cox -model is then given by -$$ -f(y) = h(y) S(y) -$$ -where $S(y)$ is the survival function implied by $h(y)$. - -## Extreme value models - -Modeling extremes requires special distributions. One may use the **weibull** -distribution (see above) or the **frechet** distribution with density -$$ -f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) -$$ -where $s = \mu / \Gamma(1 - 1 / \nu)$ is a positive scale parameter and -$\nu > 1$ is a shape parameter so that $\mu$ predicts the mean of the Frechet -distribution. A generalization of both distributions is the generalized extreme -value distribution (family **gen_extreme_value**) with density -$$ -f(y) = \frac{1}{\sigma} t(y)^{-1 - 1 / \xi} \exp(-t(y)) -$$ -where -$$ -t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} -$$ -with positive scale parameter $\sigma$ and shape parameter $\xi$. - -## Response time models - -One family that is especially suited to model reaction times is the -**exgaussian** ('exponentially modified Gaussian') family. Its density is given -by - -$$ -f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) -$$ -where $\beta$ is the scale (inverse rate) of the exponential component, $\xi$ is -the mean of the Gaussian component, $\sigma$ is the standard deviation of the -Gaussian component, and $\text{erfc}$ is the complementary error function. We -parameterize $\mu = \xi + \beta$ so that the main predictor term equals the -mean of the distribution. - -Another family well suited for modeling response times is the -**shifted_lognormal** distribution. It's density equals that of the -**lognormal** distribution except that the whole distribution is shifted to the -right by a positive parameter called *ndt* (for consistency with the **wiener** -diffusion model explained below). - -A family concerned with the combined modeling of reaction times and -corresponding binary responses is the **wiener** diffusion model. It has four -model parameters each with a natural interpretation. The parameter $\alpha > 0$ -describes the separation between two boundaries of the diffusion process, -$\tau > 0$ describes the non-decision time (e.g., due to image or motor processing), -$\beta \in [0, 1]$ describes the initial bias in favor of the upper alternative, -and $\delta \in \mathbb{R}$ describes the drift rate to the boundaries (a -positive value indicates a drift towards to upper boundary). The density for the -reaction time at the upper boundary is given by - -$$ -f(y) = \frac{\alpha}{(y-\tau)^3/2} -\exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) -\sum_{k = - \infty}^{\infty} (2k + \beta) -\phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) -$$ - -where $\phi(x)$ denotes the standard normal density function. The density at the -lower boundary can be obtained by substituting $1 - \beta$ for $\beta$ and -$-\delta$ for $\delta$ in the above equation. In brms the parameters -$\alpha$, $\tau$, and $\beta$ are modeled as auxiliary parameters named *bs* -('boundary separation'), *ndt* ('non-decision time'), and *bias* respectively, -whereas the drift rate $\delta$ is modeled via the ordinary model formula that -is as $\delta = \mu$. - -## Quantile regression - -Quantile regression is implemented via family **asym_laplace** (asymmetric -Laplace distribution) with density - -$$ -f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) -$$ -where $\rho_p$ is given by $\rho_p(x) = x (p - I_{x < 0})$ and $I_A$ is the -indicator function of set $A$. The parameter $\sigma$ is a positive scale -parameter and $p$ is the *quantile* parameter taking on values in $(0, 1)$. For -this distribution, we have $P(Y < g(\eta)) = p$. Thus, quantile regression can -be performed by fixing $p$ to the quantile to interest. - -## Probability models - -The density of the **Beta** family for $y \in (0,1)$ is given by -$$ -f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} -$$ -where $B$ is the beta function and $\phi$ is a positive precision parameter. -A multivariate generalization of the **Beta** family is the **dirichlet** family -with density -$$ -f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} - \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. -$$ -The **dirichlet** distribution is only implemented with the multivariate logit -link function so that -$$ -\mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} -$$ -For reasons of identifiability, $\eta_{1}$ is set to $0$. - -## Circular models - -The density of the **von_mises** family for $y \in (-\pi,\pi)$ is given by -$$ -f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} -$$ -where $I_0$ is the modified Bessel function of order 0 and $\kappa$ is -a positive precision parameter. - -## Ordinal and categorical models - -For ordinal and categorical models, $y$ is one of the categories $1, ..., K$. -The intercepts of ordinal models are called thresholds and are denoted as -$\tau_k$, with $k \in \{1, ..., K-1\}$, whereas $\eta$ does not contain a fixed -effects intercept. Note that the applied link functions $h$ are technically -distribution functions $\mathbb{R} \rightarrow [0,1]$. The density of the -**cumulative** family (implementing the most basic ordinal model) is given by -$$ -f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) -$$ - -The densities of the **sratio** (stopping ratio) and **cratio** (continuation -ratio) families are given by -$$ -f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) -$$ -and -$$ -f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) -$$ - -respectively. Note that both families are equivalent for symmetric link -functions such as logit or probit. The density of the **acat** (adjacent -category) family is given by -$$ -f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) - \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) - \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} -$$ -For the logit link, this can be simplified to -$$ -f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} - {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} -$$ -The linear predictor $\eta$ can be generalized to also depend on the category -$k$ for a subset of predictors. This leads to category specific -effects (for details on how to specify them see `help(brm)`). Note that -**cumulative** and **sratio** models use $\tau - \eta$, whereas **cratio** and -**acat** use $\eta - \tau$. This is done to ensure that larger values of $\eta$ -increase the probability of *higher* response categories. - -The **categorical** family is currently only implemented with the multivariate -logit link function and has density -$$ -f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} -$$ -Note that $\eta$ does also depend on the category $k$. For reasons of -identifiability, $\eta_{1}$ is set to $0$. A generalization of the -**categorical** family to more than one trial is the **multinomial** family with -density -$$ -f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} - \prod_{k=1}^K \mu_{k}^{y_{k}} -$$ -where, for each category, $\mu_{k}$ is estimated via the multivariate logit link -function shown above. - -## Zero-inflated and hurdle models - -**Zero-inflated** and **hurdle** families extend existing families by adding -special processes for responses that are zero. The density of a -**zero-inflated** family is given by -$$ -f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ -f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 -$$ -where $z$ denotes the zero-inflation probability. Currently implemented families -are **zero_inflated_poisson**, **zero_inflated_binomial**, -**zero_inflated_negbinomial**, and **zero_inflated_beta**. - -The density of a **hurdle** family is given by -$$ -f_z(y) = z \quad \text{if } y = 0 \\ -f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 -$$ -Currently implemented families are **hurdle_poisson**, **hurdle_negbinomial**, -**hurdle_gamma**, and **hurdle_lognormal**. - -The density of a **zero-one-inflated** family is given by -$$ -f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ -f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ -f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} -$$ -where $\alpha$ is the zero-one-inflation probability (i.e. the probability that -zero or one occurs) and $\gamma$ is the conditional one-inflation probability -(i.e. the probability that one occurs rather than zero). Currently implemented -families are **zero_one_inflated_beta**. +--- +title: "Parameterization of Response Distributions in brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Parameterization of Response Distributions in brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +--- + +The purpose of this vignette is to discuss the parameterizations of the families +(i.e., response distributions) used in brms. For a more general overview of +the package see `vignette("brms_overview")`. + +## Notation + +Throughout this vignette, we denote values of the response variable as $y$, a +density function as $f$, and use $\mu$ to refer to the main model parameter, +which is usually the mean of the response distribution or some closely related +quantity. In a regression framework, $\mu$ is not estimated directly but +computed as $\mu = g(\eta)$, where $\eta$ is a predictor term (see +`help(brmsformula)` for details) and $g$ is the response function (i.e., +inverse of the link function). + +## Location shift models + +The density of the **gaussian** family is given by +$$ +f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) +$$ + +where $\sigma$ is the residual standard deviation. The density of the +**student** family is given by +$$ +f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} +$$ + +$\Gamma$ denotes the gamma function and $\nu > 1$ are the degrees of freedom. As +$\nu \rightarrow \infty$, the student distribution becomes the gaussian +distribution. The density of the **skew_normal** family is given by +$$ +f(y) = \frac{1}{\sqrt{2\pi}\omega} + \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) +\left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) +$$ + +where $\xi$ is the location parameter, $\omega$ is the positive scale parameter, +$\alpha$ the skewness parameter, and $\text{erf}$ denotes the error function of +the gaussian distribution. To parameterize the skew-normal distribution in terms +of the mean $\mu$ and standard deviation $\sigma$, $\omega$ and $\xi$ are +computed as +$$ +\omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} +$$ + +$$ +\xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} +$$ + +If $\alpha = 0$, the skew-normal distribution becomes the gaussian distribution. +For location shift models, $y$ can be any real value. + +## Binary and count data models + +The density of the **binomial** family is given by +$$ +f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} +$$ +where $N$ is the number of trials and $y \in \{0, ... , N\}$. When all +$N$ are $1$ (i.e., $y \in \{0,1\}$), the **bernoulli** distribution for binary +data arises. + +For $y \in \mathbb{N}_0$, the density of the **poisson** family is given by +$$ +f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) +$$ +The density of the **negbinomial** (negative binomial) family is +$$ +f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} +\left(\frac{\phi}{\mu + \phi}\right)^\phi +$$ +where $\phi$ is a positive precision parameter. For $\phi \rightarrow \infty$, +the negative binomial distribution becomes the poisson distribution. The density +of the **geometric** family arises if $\phi$ is set to $1$. + + + +## Time-to-event models + +With time-to-event models we mean all models that are defined on the positive +reals only, that is $y \in \mathbb{R}^+$. The density of the **lognormal** +family is given by +$$ +f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) +$$ +where $\sigma$ is the residual standard deviation on the log-scale. +The density of the **Gamma** family is given by +$$ +f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} +\exp\left(-\frac{\alpha y}{\mu}\right) +$$ +where $\alpha$ is a positive shape parameter. The density of the **weibull** +family is given by +$$ +f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} +\exp\left(-\left(\frac{y}{s}\right)^\alpha\right) +$$ +where $\alpha$ is again a positive shape parameter and +$s = \mu / \Gamma(1 + 1 / \alpha)$ is the scale parameter to that $\mu$ +is the mean of the distribution. The **exponential** family arises if $\alpha$ +is set to $1$ for either the gamma or Weibull distribution. The density of the +**inverse.gaussian** family is given by +$$ +f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) +$$ +where $\alpha$ is a positive shape parameter. The **cox** family implements Cox +proportional hazards model which assumes a hazard function of the form $h(y) = +h_0(y) \mu$ with baseline hazard $h_0(y)$ expressed via M-splines (which +integrate to I-splines) in order to ensure monotonicity. The density of the cox +model is then given by +$$ +f(y) = h(y) S(y) +$$ +where $S(y)$ is the survival function implied by $h(y)$. + +## Extreme value models + +Modeling extremes requires special distributions. One may use the **weibull** +distribution (see above) or the **frechet** distribution with density +$$ +f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) +$$ +where $s = \mu / \Gamma(1 - 1 / \nu)$ is a positive scale parameter and +$\nu > 1$ is a shape parameter so that $\mu$ predicts the mean of the Frechet +distribution. A generalization of both distributions is the generalized extreme +value distribution (family **gen_extreme_value**) with density +$$ +f(y) = \frac{1}{\sigma} t(y)^{-1 - 1 / \xi} \exp(-t(y)) +$$ +where +$$ +t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} +$$ +with positive scale parameter $\sigma$ and shape parameter $\xi$. + +## Response time models + +One family that is especially suited to model reaction times is the +**exgaussian** ('exponentially modified Gaussian') family. Its density is given +by + +$$ +f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) +$$ +where $\beta$ is the scale (inverse rate) of the exponential component, $\xi$ is +the mean of the Gaussian component, $\sigma$ is the standard deviation of the +Gaussian component, and $\text{erfc}$ is the complementary error function. We +parameterize $\mu = \xi + \beta$ so that the main predictor term equals the +mean of the distribution. + +Another family well suited for modeling response times is the +**shifted_lognormal** distribution. It's density equals that of the +**lognormal** distribution except that the whole distribution is shifted to the +right by a positive parameter called *ndt* (for consistency with the **wiener** +diffusion model explained below). + +A family concerned with the combined modeling of reaction times and +corresponding binary responses is the **wiener** diffusion model. It has four +model parameters each with a natural interpretation. The parameter $\alpha > 0$ +describes the separation between two boundaries of the diffusion process, +$\tau > 0$ describes the non-decision time (e.g., due to image or motor processing), +$\beta \in [0, 1]$ describes the initial bias in favor of the upper alternative, +and $\delta \in \mathbb{R}$ describes the drift rate to the boundaries (a +positive value indicates a drift towards to upper boundary). The density for the +reaction time at the upper boundary is given by + +$$ +f(y) = \frac{\alpha}{(y-\tau)^3/2} +\exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) +\sum_{k = - \infty}^{\infty} (2k + \beta) +\phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) +$$ + +where $\phi(x)$ denotes the standard normal density function. The density at the +lower boundary can be obtained by substituting $1 - \beta$ for $\beta$ and +$-\delta$ for $\delta$ in the above equation. In brms the parameters +$\alpha$, $\tau$, and $\beta$ are modeled as auxiliary parameters named *bs* +('boundary separation'), *ndt* ('non-decision time'), and *bias* respectively, +whereas the drift rate $\delta$ is modeled via the ordinary model formula that +is as $\delta = \mu$. + +## Quantile regression + +Quantile regression is implemented via family **asym_laplace** (asymmetric +Laplace distribution) with density + +$$ +f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) +$$ +where $\rho_p$ is given by $\rho_p(x) = x (p - I_{x < 0})$ and $I_A$ is the +indicator function of set $A$. The parameter $\sigma$ is a positive scale +parameter and $p$ is the *quantile* parameter taking on values in $(0, 1)$. For +this distribution, we have $P(Y < g(\eta)) = p$. Thus, quantile regression can +be performed by fixing $p$ to the quantile to interest. + +## Probability models + +The density of the **Beta** family for $y \in (0,1)$ is given by +$$ +f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} +$$ +where $B$ is the beta function and $\phi$ is a positive precision parameter. +A multivariate generalization of the **Beta** family is the **dirichlet** family +with density +$$ +f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} + \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. +$$ +The **dirichlet** family is implemented with the multivariate logit +link function so that +$$ +\mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} +$$ +For reasons of identifiability, $\eta_{\rm ref}$ is set to $0$, where ${\rm ref}$ +is one of the response categories chosen as reference. + +An alternative to the **dirichlet** family is the **logistic_normal** family +with density +$$ +f(y) = \frac{1}{\prod_{k=1}^K y_k} \times + \text{multivariate_normal}(\tilde{y} \, | \, \mu, \sigma, \Omega) +$$ +where $\tilde{y}$ is the multivariate logit transformed response +$$ +\tilde{y} = (\log(y_1 / y_{\rm ref}), \ldots, \log(y_{\rm ref-1} / y_{\rm ref}), + \log(y_{\rm ref+1} / y_{\rm ref}), \ldots, \log(y_K / y_{\rm ref})) +$$ +of dimension $K-1$ (excluding the reference category), which is modeled as +multivariate normally distributed with latent mean and standard deviation +vectors $\mu$ and $\sigma$, as well as correlation matrix $\Omega$. + + +## Circular models + +The density of the **von_mises** family for $y \in (-\pi,\pi)$ is given by +$$ +f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} +$$ +where $I_0$ is the modified Bessel function of order 0 and $\kappa$ is +a positive precision parameter. + +## Ordinal and categorical models + +For ordinal and categorical models, $y$ is one of the categories $1, ..., K$. +The intercepts of ordinal models are called thresholds and are denoted as +$\tau_k$, with $k \in \{1, ..., K-1\}$, whereas $\eta$ does not contain a fixed +effects intercept. Note that the applied link functions $h$ are technically +distribution functions $\mathbb{R} \rightarrow [0,1]$. The density of the +**cumulative** family (implementing the most basic ordinal model) is given by +$$ +f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) +$$ + +The densities of the **sratio** (stopping ratio) and **cratio** (continuation +ratio) families are given by +$$ +f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) +$$ +and +$$ +f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) +$$ + +respectively. Note that both families are equivalent for symmetric link +functions such as logit or probit. The density of the **acat** (adjacent +category) family is given by +$$ +f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) + \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) + \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} +$$ +For the logit link, this can be simplified to +$$ +f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} + {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} +$$ +The linear predictor $\eta$ can be generalized to also depend on the category +$k$ for a subset of predictors. This leads to category specific +effects (for details on how to specify them see `help(brm)`). Note that +**cumulative** and **sratio** models use $\tau - \eta$, whereas **cratio** and +**acat** use $\eta - \tau$. This is done to ensure that larger values of $\eta$ +increase the probability of *higher* response categories. + +The **categorical** family is currently only implemented with the multivariate +logit link function and has density +$$ +f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} +$$ +Note that $\eta$ does also depend on the category $k$. For reasons of +identifiability, $\eta_{1}$ is set to $0$. A generalization of the +**categorical** family to more than one trial is the **multinomial** family with +density +$$ +f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} + \prod_{k=1}^K \mu_{k}^{y_{k}} +$$ +where, for each category, $\mu_{k}$ is estimated via the multivariate logit link +function shown above. + +## Zero-inflated and hurdle models + +**Zero-inflated** and **hurdle** families extend existing families by adding +special processes for responses that are zero. The density of a +**zero-inflated** family is given by +$$ +f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ +f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 +$$ +where $z$ denotes the zero-inflation probability. Currently implemented families +are **zero_inflated_poisson**, **zero_inflated_binomial**, +**zero_inflated_negbinomial**, and **zero_inflated_beta**. + +The density of a **hurdle** family is given by +$$ +f_z(y) = z \quad \text{if } y = 0 \\ +f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 +$$ +Currently implemented families are **hurdle_poisson**, **hurdle_negbinomial**, +**hurdle_gamma**, and **hurdle_lognormal**. + +The density of a **zero-one-inflated** family is given by +$$ +f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ +f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ +f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} +$$ +where $\alpha$ is the zero-one-inflation probability (i.e. the probability that +zero or one occurs) and $\gamma$ is the conditional one-inflation probability +(i.e. the probability that one occurs rather than zero). Currently implemented +families are **zero_one_inflated_beta**. diff -Nru r-cran-brms-2.16.3/inst/doc/brms_missings.html r-cran-brms-2.17.0/inst/doc/brms_missings.html --- r-cran-brms-2.16.3/inst/doc/brms_missings.html 2021-11-22 15:52:27.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_missings.html 2022-04-11 07:58:05.000000000 +0000 @@ -1,302 +1,302 @@ - - - - - - - - - - - - - - - - -Handle Missing Values with brms - - - - - - - - - - - - - - - - - - - - - - - - - -

Handle Missing Values with brms

-

Paul Bürkner

-

2021-11-22

- - - - -
-

Introduction

-

Many real world data sets contain missing values for various reasons. Generally, we have quite a few options to handle those missing values. The easiest solution is to remove all rows from the data set, where one or more variables are missing. However, if values are not missing completely at random, this will likely lead to bias in our analysis. Accordingly, we usually want to impute missing values in one way or the other. Here, we will consider two very general approaches using brms: (1) Impute missing values before the model fitting with multiple imputation, and (2) impute missing values on the fly during model fitting1. As a simple example, we will use the nhanes data set, which contains information on participants’ age, bmi (body mass index), hyp (hypertensive), and chl (total serum cholesterol). For the purpose of the present vignette, we are primarily interested in predicting bmi by age and chl.

-
data("nhanes", package = "mice")
-head(nhanes)
-
  age  bmi hyp chl
-1   1   NA  NA  NA
-2   2 22.7   1 187
-3   1   NA   1 187
-4   3   NA  NA  NA
-5   1 20.4   1 113
-6   3   NA  NA 184
-
-
-

Imputation before model fitting

-

There are many approaches allowing us to impute missing data before the actual model fitting takes place. From a statistical perspective, multiple imputation is one of the best solutions. Each missing value is not imputed once but m times leading to a total of m fully imputed data sets. The model can then be fitted to each of those data sets separately and results are pooled across models, afterwards. One widely applied package for multiple imputation is mice (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the following in combination with brms. Here, we apply the default settings of mice, which means that all variables will be used to impute missing values in all other variables and imputation functions automatically chosen based on the variables’ characteristics.

-
library(mice)
-imp <- mice(nhanes, m = 5, print = FALSE)
-

Now, we have m = 5 imputed data sets stored within the imp object. In practice, we will likely need more than 5 of those to accurately account for the uncertainty induced by the missingness, perhaps even in the area of 100 imputed data sets (Zhou & Reiter, 2010). Of course, this increases the computational burden by a lot and so we stick to m = 5 for the purpose of this vignette. Regardless of the value of m, we can either extract those data sets and then pass them to the actual model fitting function as a list of data frames, or pass imp directly. The latter works because brms offers special support for data imputed by mice. We will go with the latter approach, since it is less typing. Fitting our model of interest with brms to the multiple imputed data sets is straightforward.

-
fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2)
-

The returned fitted model is an ordinary brmsfit object containing the posterior draws of all m submodels. While pooling across models is not necessarily straightforward in classical statistics, it is trivial in a Bayesian framework. Here, pooling results of multiple imputed data sets is simply achieved by combining the posterior draws of the submodels. Accordingly, all post-processing methods can be used out of the box without having to worry about pooling at all.

-
summary(fit_imp1)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: bmi ~ age * chl 
-   Data: imp (Number of observations: 25) 
-  Draws: 10 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 10000
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    15.80      7.81    -0.17    31.02 1.12       56      237
-age           0.80      5.06    -8.58    11.46 1.16       42      254
-chl           0.08      0.04     0.00     0.16 1.11       58      187
-age:chl      -0.02      0.02    -0.07     0.03 1.13       50      356
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     3.24      0.62     2.27     4.65 1.17       39      279
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

In the summary output, we notice that some Rhat values are higher than \(1.1\) indicating possible convergence problems. For models based on multiple imputed data sets, this is often a false positive: Chains of different submodels may not overlay each other exactly, since there were fitted to different data. We can see the chains on the right-hand side of

-
plot(fit_imp1, variable = "^b", regex = TRUE)
-

-

Such non-overlaying chains imply high Rhat values without there actually being any convergence issue. Accordingly, we have to investigate the convergence of the submodels separately, which we can do by looking at

-
round(fit_imp1$rhats, 2)
-
  b_Intercept b_age b_chl b_age.chl sigma lp__
-1           1     1     1         1     1    1
-2           1     1     1         1     1    1
-3           1     1     1         1     1    1
-4           1     1     1         1     1    1
-5           1     1     1         1     1    1
-

The convergence of each of the submodels looks good. Accordingly, we can proceed with further post-processing and interpretation of the results. For instance, we could investigate the combined effect of age and chl.

-
conditional_effects(fit_imp1, "age:chl")
-

-

To summarize, the advantages of multiple imputation are obvious: One can apply it to all kinds of models, since model fitting functions do not need to know that the data sets were imputed, beforehand. Also, we do not need to worry about pooling across submodels when using fully Bayesian methods. The only drawback is the amount of time required for model fitting. Estimating Bayesian models is already quite slow with just a single data set and it only gets worse when working with multiple imputation.

-
-

Compatibility with other multiple imputation packages

-

brms offers built-in support for mice mainly because I use the latter in some of my own research projects. Nevertheless, brm_multiple supports all kinds of multiple imputation packages as it also accepts a list of data frames as input for its data argument. Thus, you just need to extract the imputed data frames in the form of a list, which can then be passed to brm_multiple. Most multiple imputation packages have some built-in functionality for this task. When using the mi package, for instance, you simply need to call the mi::complete function to get the desired output.

-
-
-
-

Imputation during model fitting

-

Imputation during model fitting is generally thought to be more complex than imputation before model fitting, because one has to take care of everything within one step. This remains true when imputing missing values with brms, but possibly to a somewhat smaller degree. Consider again the nhanes data with the goal to predict bmi by age, and chl. Since age contains no missing values, we only have to take special care of bmi and chl. We need to tell the model two things. (1) Which variables contain missing values and how they should be predicted, as well as (2) which of these imputed variables should be used as predictors. In brms we can do this as follows:

-
bform <- bf(bmi | mi() ~ age * mi(chl)) +
-  bf(chl | mi() ~ age) + set_rescor(FALSE)
-fit_imp2 <- brm(bform, data = nhanes)
-

The model has become multivariate, as we no longer only predict bmi but also chl (see vignette("brms_multivariate") for details about the multivariate syntax of brms). We ensure that missings in both variables will be modeled rather than excluded by adding | mi() on the left-hand side of the formulas2. We write mi(chl) on the right-hand side of the formula for bmi to ensure that the estimated missing values of chl will be used in the prediction of bmi. The summary is a bit more cluttered as we get coefficients for both response variables, but apart from that we can interpret coefficients in the usual way.

-
summary(fit_imp2)
-
 Family: MV(gaussian, gaussian) 
-  Links: mu = identity; sigma = identity
-         mu = identity; sigma = identity 
-Formula: bmi | mi() ~ age * mi(chl) 
-         chl | mi() ~ age 
-   Data: nhanes (Number of observations: 25) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-bmi_Intercept    13.85      9.00    -4.14    31.86 1.00     1722     2201
-chl_Intercept   142.27     24.27    94.38   192.26 1.00     2761     2961
-bmi_age           2.68      5.59    -8.33    14.00 1.00     1481     1843
-chl_age          28.31     12.95     2.71    54.59 1.00     2713     3062
-bmi_michl         0.10      0.05     0.00     0.19 1.00     1823     2154
-bmi_michl:age    -0.03      0.03    -0.08     0.02 1.00     1521     1933
-
-Family Specific Parameters: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma_bmi     3.39      0.78     2.20     5.28 1.00     1533     1970
-sigma_chl    39.87      7.34    28.46    56.71 1.00     2051     2525
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
conditional_effects(fit_imp2, "age:chl", resp = "bmi")
-

-

The results look pretty similar to those obtained from multiple imputation, but be aware that this may not be generally the case. In multiple imputation, the default is to impute all variables based on all other variables, while in the ‘one-step’ approach, we have to explicitly specify the variables used in the imputation. Thus, arguably, multiple imputation is easier to apply. An obvious advantage of the ‘one-step’ approach is that the model needs to be fitted only once instead of m times. Also, within the brms framework, we can use multilevel structure and complex non-linear relationships for the imputation of missing values, which is not achieved as easily in standard multiple imputation software. On the downside, it is currently not possible to impute discrete variables, because Stan (the engine behind brms) does not allow estimating discrete parameters.

-
-

Combining measurement error and missing values

-

Missing value terms in brms cannot only handle missing values but also measurement error, or arbitrary combinations of the two. In fact, we can think of a missing value as a value with infinite measurement error. Thus, mi terms are a natural (and somewhat more verbose) generalization of the now soft deprecated me terms. Suppose we had measured the variable chl with some known error:

-
nhanes$se <- rexp(nrow(nhanes), 2)
-

Then we can go ahead an include this information into the model as follows:

-
bform <- bf(bmi | mi() ~ age * mi(chl)) +
-  bf(chl | mi(se) ~ age) + set_rescor(FALSE)
-fit_imp3 <- brm(bform, data = nhanes)
-

Summarizing and post-processing the model continues to work as usual.

-
-
-
-

References

-

Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by chained equations in R. Journal of Statistical Software, 1-68. doi.org/10.18637/jss.v045.i03

-

Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple Imputation. The American Statistician, 64(2), 159-163. doi.org/10.1198/tast.2010.09109

-
-
-
-
    -

  1. Actually, there is a third approach that only applies to missings in response variables. If we want to impute missing responses, we just fit the model using the observed responses and than impute the missings after fitting the model by means of posterior prediction. That is, we supply the predictor values corresponding to missing responses to the predict method.↩︎

    2. -

  2. We don’t really need this for bmi, since bmi is not used as a predictor for another variable. Accordingly, we could also – and equivalently – impute missing values of bmi after model fitting by means of posterior prediction.↩︎

    3. -
-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Handle Missing Values with brms + + + + + + + + + + + + + + + + + + + + + + + + + +

Handle Missing Values with brms

+

Paul Bürkner

+

2022-04-11

+ + + + +
+

Introduction

+

Many real world data sets contain missing values for various reasons. Generally, we have quite a few options to handle those missing values. The easiest solution is to remove all rows from the data set, where one or more variables are missing. However, if values are not missing completely at random, this will likely lead to bias in our analysis. Accordingly, we usually want to impute missing values in one way or the other. Here, we will consider two very general approaches using brms: (1) Impute missing values before the model fitting with multiple imputation, and (2) impute missing values on the fly during model fitting1. As a simple example, we will use the nhanes data set, which contains information on participants’ age, bmi (body mass index), hyp (hypertensive), and chl (total serum cholesterol). For the purpose of the present vignette, we are primarily interested in predicting bmi by age and chl.

+
data("nhanes", package = "mice")
+head(nhanes)
+
  age  bmi hyp chl
+1   1   NA  NA  NA
+2   2 22.7   1 187
+3   1   NA   1 187
+4   3   NA  NA  NA
+5   1 20.4   1 113
+6   3   NA  NA 184
+
+
+

Imputation before model fitting

+

There are many approaches allowing us to impute missing data before the actual model fitting takes place. From a statistical perspective, multiple imputation is one of the best solutions. Each missing value is not imputed once but m times leading to a total of m fully imputed data sets. The model can then be fitted to each of those data sets separately and results are pooled across models, afterwards. One widely applied package for multiple imputation is mice (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the following in combination with brms. Here, we apply the default settings of mice, which means that all variables will be used to impute missing values in all other variables and imputation functions automatically chosen based on the variables’ characteristics.

+
library(mice)
+imp <- mice(nhanes, m = 5, print = FALSE)
+

Now, we have m = 5 imputed data sets stored within the imp object. In practice, we will likely need more than 5 of those to accurately account for the uncertainty induced by the missingness, perhaps even in the area of 100 imputed data sets (Zhou & Reiter, 2010). Of course, this increases the computational burden by a lot and so we stick to m = 5 for the purpose of this vignette. Regardless of the value of m, we can either extract those data sets and then pass them to the actual model fitting function as a list of data frames, or pass imp directly. The latter works because brms offers special support for data imputed by mice. We will go with the latter approach, since it is less typing. Fitting our model of interest with brms to the multiple imputed data sets is straightforward.

+
fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2)
+

The returned fitted model is an ordinary brmsfit object containing the posterior draws of all m submodels. While pooling across models is not necessarily straightforward in classical statistics, it is trivial in a Bayesian framework. Here, pooling results of multiple imputed data sets is simply achieved by combining the posterior draws of the submodels. Accordingly, all post-processing methods can be used out of the box without having to worry about pooling at all.

+
summary(fit_imp1)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: bmi ~ age * chl 
+   Data: imp (Number of observations: 25) 
+  Draws: 10 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 10000
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    14.57      7.68    -0.70    29.92 1.06      111     2951
+age           1.78      4.89    -8.07    11.24 1.11       63      598
+chl           0.09      0.04     0.01     0.17 1.06      116      807
+age:chl      -0.02      0.02    -0.07     0.02 1.07       98      764
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     3.31      0.85     2.07     5.21 1.59       17      101
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

In the summary output, we notice that some Rhat values are higher than \(1.1\) indicating possible convergence problems. For models based on multiple imputed data sets, this is often a false positive: Chains of different submodels may not overlay each other exactly, since there were fitted to different data. We can see the chains on the right-hand side of

+
plot(fit_imp1, variable = "^b", regex = TRUE)
+

+

Such non-overlaying chains imply high Rhat values without there actually being any convergence issue. Accordingly, we have to investigate the convergence of the submodels separately, which we can do by looking at

+
round(fit_imp1$rhats, 2)
+
  b_Intercept b_age b_chl b_age.chl sigma lprior lp__
+1        1.00  1.00  1.00      1.00     1   1.01 1.01
+2        1.00  1.00  1.00      1.00     1   1.00 1.00
+3        1.01  1.01  1.01      1.01     1   1.00 1.00
+4        1.00  1.00  1.00      1.00     1   1.00 1.00
+5        1.00  1.00  1.00      1.00     1   1.00 1.00
+

The convergence of each of the submodels looks good. Accordingly, we can proceed with further post-processing and interpretation of the results. For instance, we could investigate the combined effect of age and chl.

+
conditional_effects(fit_imp1, "age:chl")
+

+

To summarize, the advantages of multiple imputation are obvious: One can apply it to all kinds of models, since model fitting functions do not need to know that the data sets were imputed, beforehand. Also, we do not need to worry about pooling across submodels when using fully Bayesian methods. The only drawback is the amount of time required for model fitting. Estimating Bayesian models is already quite slow with just a single data set and it only gets worse when working with multiple imputation.

+
+

Compatibility with other multiple imputation packages

+

brms offers built-in support for mice mainly because I use the latter in some of my own research projects. Nevertheless, brm_multiple supports all kinds of multiple imputation packages as it also accepts a list of data frames as input for its data argument. Thus, you just need to extract the imputed data frames in the form of a list, which can then be passed to brm_multiple. Most multiple imputation packages have some built-in functionality for this task. When using the mi package, for instance, you simply need to call the mi::complete function to get the desired output.

+
+
+
+

Imputation during model fitting

+

Imputation during model fitting is generally thought to be more complex than imputation before model fitting, because one has to take care of everything within one step. This remains true when imputing missing values with brms, but possibly to a somewhat smaller degree. Consider again the nhanes data with the goal to predict bmi by age, and chl. Since age contains no missing values, we only have to take special care of bmi and chl. We need to tell the model two things. (1) Which variables contain missing values and how they should be predicted, as well as (2) which of these imputed variables should be used as predictors. In brms we can do this as follows:

+
bform <- bf(bmi | mi() ~ age * mi(chl)) +
+  bf(chl | mi() ~ age) + set_rescor(FALSE)
+fit_imp2 <- brm(bform, data = nhanes)
+

The model has become multivariate, as we no longer only predict bmi but also chl (see vignette("brms_multivariate") for details about the multivariate syntax of brms). We ensure that missings in both variables will be modeled rather than excluded by adding | mi() on the left-hand side of the formulas2. We write mi(chl) on the right-hand side of the formula for bmi to ensure that the estimated missing values of chl will be used in the prediction of bmi. The summary is a bit more cluttered as we get coefficients for both response variables, but apart from that we can interpret coefficients in the usual way.

+
summary(fit_imp2)
+
 Family: MV(gaussian, gaussian) 
+  Links: mu = identity; sigma = identity
+         mu = identity; sigma = identity 
+Formula: bmi | mi() ~ age * mi(chl) 
+         chl | mi() ~ age 
+   Data: nhanes (Number of observations: 25) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+bmi_Intercept    14.12      9.03    -3.28    32.88 1.00     1521     1634
+chl_Intercept   142.04     25.67    93.41   193.22 1.00     2325     2362
+bmi_age           2.52      5.59    -8.84    13.67 1.00     1257     1713
+chl_age          28.52     13.53     1.56    54.85 1.00     2084     2112
+bmi_michl         0.10      0.05     0.00     0.19 1.00     1645     1742
+bmi_michl:age    -0.03      0.03    -0.08     0.02 1.00     1309     1753
+
+Family Specific Parameters: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma_bmi     3.38      0.79     2.21     5.23 1.00     1413     2292
+sigma_chl    40.84      8.16    28.47    60.70 1.00     1958     2154
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
conditional_effects(fit_imp2, "age:chl", resp = "bmi")
+

+

The results look pretty similar to those obtained from multiple imputation, but be aware that this may not be generally the case. In multiple imputation, the default is to impute all variables based on all other variables, while in the ‘one-step’ approach, we have to explicitly specify the variables used in the imputation. Thus, arguably, multiple imputation is easier to apply. An obvious advantage of the ‘one-step’ approach is that the model needs to be fitted only once instead of m times. Also, within the brms framework, we can use multilevel structure and complex non-linear relationships for the imputation of missing values, which is not achieved as easily in standard multiple imputation software. On the downside, it is currently not possible to impute discrete variables, because Stan (the engine behind brms) does not allow estimating discrete parameters.

+
+

Combining measurement error and missing values

+

Missing value terms in brms cannot only handle missing values but also measurement error, or arbitrary combinations of the two. In fact, we can think of a missing value as a value with infinite measurement error. Thus, mi terms are a natural (and somewhat more verbose) generalization of the now soft deprecated me terms. Suppose we had measured the variable chl with some known error:

+
nhanes$se <- rexp(nrow(nhanes), 2)
+

Then we can go ahead an include this information into the model as follows:

+
bform <- bf(bmi | mi() ~ age * mi(chl)) +
+  bf(chl | mi(se) ~ age) + set_rescor(FALSE)
+fit_imp3 <- brm(bform, data = nhanes)
+

Summarizing and post-processing the model continues to work as usual.

+
+
+
+

References

+

Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by chained equations in R. Journal of Statistical Software, 1-68. doi.org/10.18637/jss.v045.i03

+

Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple Imputation. The American Statistician, 64(2), 159-163. doi.org/10.1198/tast.2010.09109

+
+
+
+
    +

  1. Actually, there is a third approach that only applies to missings in response variables. If we want to impute missing responses, we just fit the model using the observed responses and than impute the missings after fitting the model by means of posterior prediction. That is, we supply the predictor values corresponding to missing responses to the predict method.↩︎

    2. +

  2. We don’t really need this for bmi, since bmi is not used as a predictor for another variable. Accordingly, we could also – and equivalently – impute missing values of bmi after model fitting by means of posterior prediction.↩︎

    3. +
+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_missings.R r-cran-brms-2.17.0/inst/doc/brms_missings.R --- r-cran-brms-2.16.3/inst/doc/brms_missings.R 2021-11-22 15:52:26.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_missings.R 2022-04-11 07:58:04.000000000 +0000 @@ -1,61 +1,61 @@ -params <- -list(EVAL = TRUE) - -## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) - -## --------------------------------------------------------------------------------------- -data("nhanes", package = "mice") -head(nhanes) - -## --------------------------------------------------------------------------------------- -library(mice) -imp <- mice(nhanes, m = 5, print = FALSE) - -## ---- results = 'hide', message = FALSE------------------------------------------------- -fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) - -## --------------------------------------------------------------------------------------- -summary(fit_imp1) - -## --------------------------------------------------------------------------------------- -plot(fit_imp1, variable = "^b", regex = TRUE) - -## --------------------------------------------------------------------------------------- -round(fit_imp1$rhats, 2) - -## --------------------------------------------------------------------------------------- -conditional_effects(fit_imp1, "age:chl") - -## ---- results = 'hide', message = FALSE------------------------------------------------- -bform <- bf(bmi | mi() ~ age * mi(chl)) + - bf(chl | mi() ~ age) + set_rescor(FALSE) -fit_imp2 <- brm(bform, data = nhanes) - -## --------------------------------------------------------------------------------------- -summary(fit_imp2) -conditional_effects(fit_imp2, "age:chl", resp = "bmi") - -## --------------------------------------------------------------------------------------- -nhanes$se <- rexp(nrow(nhanes), 2) - -## ---- results = 'hide', message = FALSE, eval = FALSE----------------------------------- -# bform <- bf(bmi | mi() ~ age * mi(chl)) + -# bf(chl | mi(se) ~ age) + set_rescor(FALSE) -# fit_imp3 <- brm(bform, data = nhanes) - +params <- +list(EVAL = TRUE) + +## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) + +## --------------------------------------------------------------------------------------- +data("nhanes", package = "mice") +head(nhanes) + +## --------------------------------------------------------------------------------------- +library(mice) +imp <- mice(nhanes, m = 5, print = FALSE) + +## ---- results = 'hide', message = FALSE------------------------------------------------- +fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) + +## --------------------------------------------------------------------------------------- +summary(fit_imp1) + +## --------------------------------------------------------------------------------------- +plot(fit_imp1, variable = "^b", regex = TRUE) + +## --------------------------------------------------------------------------------------- +round(fit_imp1$rhats, 2) + +## --------------------------------------------------------------------------------------- +conditional_effects(fit_imp1, "age:chl") + +## ---- results = 'hide', message = FALSE------------------------------------------------- +bform <- bf(bmi | mi() ~ age * mi(chl)) + + bf(chl | mi() ~ age) + set_rescor(FALSE) +fit_imp2 <- brm(bform, data = nhanes) + +## --------------------------------------------------------------------------------------- +summary(fit_imp2) +conditional_effects(fit_imp2, "age:chl", resp = "bmi") + +## --------------------------------------------------------------------------------------- +nhanes$se <- rexp(nrow(nhanes), 2) + +## ---- results = 'hide', message = FALSE, eval = FALSE----------------------------------- +# bform <- bf(bmi | mi() ~ age * mi(chl)) + +# bf(chl | mi(se) ~ age) + set_rescor(FALSE) +# fit_imp3 <- brm(bform, data = nhanes) + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_missings.Rmd r-cran-brms-2.17.0/inst/doc/brms_missings.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_missings.Rmd 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_missings.Rmd 2022-04-11 07:21:07.000000000 +0000 @@ -1,237 +1,237 @@ ---- -title: "Handle Missing Values with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Handle Missing Values with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -Many real world data sets contain missing values for various reasons. Generally, -we have quite a few options to handle those missing values. The easiest solution -is to remove all rows from the data set, where one or more variables are -missing. However, if values are not missing completely at random, this will -likely lead to bias in our analysis. Accordingly, we usually want to impute -missing values in one way or the other. Here, we will consider two very general -approaches using **brms**: (1) Impute missing values *before* the model fitting -with multiple imputation, and (2) impute missing values on the fly *during* -model fitting[^1]. As a simple example, we will use the `nhanes` data set, which -contains information on participants' `age`, `bmi` (body mass index), `hyp` -(hypertensive), and `chl` (total serum cholesterol). For the purpose of the -present vignette, we are primarily interested in predicting `bmi` by `age` and -`chl`. - -```{r} -data("nhanes", package = "mice") -head(nhanes) -``` - -## Imputation before model fitting - -There are many approaches allowing us to impute missing data before the actual -model fitting takes place. From a statistical perspective, multiple imputation -is one of the best solutions. Each missing value is not imputed once but -`m` times leading to a total of `m` fully imputed data sets. The model -can then be fitted to each of those data sets separately and results are pooled -across models, afterwards. One widely applied package for multiple imputation is -**mice** (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the -following in combination with **brms**. Here, we apply the default settings of -**mice**, which means that all variables will be used to impute missing values -in all other variables and imputation functions automatically chosen based on -the variables' characteristics. - -```{r} -library(mice) -imp <- mice(nhanes, m = 5, print = FALSE) -``` - -Now, we have `m = 5` imputed data sets stored within the `imp` object. In -practice, we will likely need more than `5` of those to accurately account for -the uncertainty induced by the missingness, perhaps even in the area of `100` -imputed data sets (Zhou & Reiter, 2010). Of course, this increases the -computational burden by a lot and so we stick to `m = 5` for the purpose of this -vignette. Regardless of the value of `m`, we can either extract those data sets -and then pass them to the actual model fitting function as a list of data -frames, or pass `imp` directly. The latter works because **brms** offers special -support for data imputed by **mice**. We will go with the latter approach, since -it is less typing. Fitting our model of interest with **brms** to the multiple -imputed data sets is straightforward. - -```{r, results = 'hide', message = FALSE} -fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) -``` - -The returned fitted model is an ordinary `brmsfit` object containing the -posterior draws of all `m` submodels. While pooling across models is not -necessarily straightforward in classical statistics, it is trivial in a Bayesian -framework. Here, pooling results of multiple imputed data sets is simply -achieved by combining the posterior draws of the submodels. Accordingly, all -post-processing methods can be used out of the box without having to worry about -pooling at all. - -```{r} -summary(fit_imp1) -``` - -In the summary output, we notice that some `Rhat` values are higher than $1.1$ -indicating possible convergence problems. For models based on multiple imputed -data sets, this is often a **false positive**: Chains of different submodels may -not overlay each other exactly, since there were fitted to different data. We -can see the chains on the right-hand side of - -```{r} -plot(fit_imp1, variable = "^b", regex = TRUE) -``` - -Such non-overlaying chains imply high `Rhat` values without there actually being -any convergence issue. Accordingly, we have to investigate the convergence of -the submodels separately, which we can do by looking at - -```{r} -round(fit_imp1$rhats, 2) -``` - -The convergence of each of the submodels looks good. Accordingly, we can proceed -with further post-processing and interpretation of the results. For instance, we -could investigate the combined effect of `age` and `chl`. - -```{r} -conditional_effects(fit_imp1, "age:chl") -``` - -To summarize, the advantages of multiple imputation are obvious: One can apply -it to all kinds of models, since model fitting functions do not need to know -that the data sets were imputed, beforehand. Also, we do not need to worry about -pooling across submodels when using fully Bayesian methods. The only drawback is -the amount of time required for model fitting. Estimating Bayesian models is -already quite slow with just a single data set and it only gets worse when -working with multiple imputation. - -### Compatibility with other multiple imputation packages - -**brms** offers built-in support for **mice** mainly because I use the latter in -some of my own research projects. Nevertheless, `brm_multiple` supports all -kinds of multiple imputation packages as it also accepts a *list* of data frames -as input for its `data` argument. Thus, you just need to extract the imputed -data frames in the form of a list, which can then be passed to `brm_multiple`. -Most multiple imputation packages have some built-in functionality for this -task. When using the **mi** package, for instance, you simply need to call the -`mi::complete` function to get the desired output. - -## Imputation during model fitting - -Imputation during model fitting is generally thought to be more complex than -imputation before model fitting, because one has to take care of everything -within one step. This remains true when imputing missing values with **brms**, -but possibly to a somewhat smaller degree. Consider again the `nhanes` data with -the goal to predict `bmi` by `age`, and `chl`. Since `age` contains no missing -values, we only have to take special care of `bmi` and `chl`. We need to tell -the model two things. (1) Which variables contain missing values and how they -should be predicted, as well as (2) which of these imputed variables should be -used as predictors. In **brms** we can do this as follows: - -```{r, results = 'hide', message = FALSE} -bform <- bf(bmi | mi() ~ age * mi(chl)) + - bf(chl | mi() ~ age) + set_rescor(FALSE) -fit_imp2 <- brm(bform, data = nhanes) -``` - -The model has become multivariate, as we no longer only predict `bmi` but also -`chl` (see `vignette("brms_multivariate")` for details about the multivariate -syntax of **brms**). We ensure that missings in both variables will be modeled -rather than excluded by adding `| mi()` on the left-hand side of the -formulas[^2]. We write `mi(chl)` on the right-hand side of the formula for `bmi` -to ensure that the estimated missing values of `chl` will be used in the -prediction of `bmi`. The summary is a bit more cluttered as we get coefficients -for both response variables, but apart from that we can interpret coefficients -in the usual way. - -```{r} -summary(fit_imp2) -conditional_effects(fit_imp2, "age:chl", resp = "bmi") -``` - -The results look pretty similar to those obtained from multiple imputation, but -be aware that this may not be generally the case. In multiple imputation, the -default is to impute all variables based on all other variables, while in the -'one-step' approach, we have to explicitly specify the variables used in the -imputation. Thus, arguably, multiple imputation is easier to apply. An obvious -advantage of the 'one-step' approach is that the model needs to be fitted only -once instead of `m` times. Also, within the **brms** framework, we can use -multilevel structure and complex non-linear relationships for the imputation of -missing values, which is not achieved as easily in standard multiple imputation -software. On the downside, it is currently not possible to impute discrete -variables, because **Stan** (the engine behind **brms**) does not allow -estimating discrete parameters. - -### Combining measurement error and missing values - -Missing value terms in **brms** cannot only handle missing values but also -measurement error, or arbitrary combinations of the two. In fact, we can think -of a missing value as a value with infinite measurement error. Thus, `mi` terms -are a natural (and somewhat more verbose) generalization of the now soft deprecated -`me` terms. Suppose we had measured the variable `chl` with some known error: - -```{r} -nhanes$se <- rexp(nrow(nhanes), 2) -``` - -Then we can go ahead an include this information into the model as follows: - -```{r, results = 'hide', message = FALSE, eval = FALSE} -bform <- bf(bmi | mi() ~ age * mi(chl)) + - bf(chl | mi(se) ~ age) + set_rescor(FALSE) -fit_imp3 <- brm(bform, data = nhanes) -``` - -Summarizing and post-processing the model continues to work as usual. - - -[^1]: Actually, there is a third approach that only applies to missings in -response variables. If we want to impute missing responses, we just fit the -model using the observed responses and than impute the missings *after* fitting -the model by means of posterior prediction. That is, we supply the predictor -values corresponding to missing responses to the `predict` method. - -[^2]: We don't really need this for `bmi`, since `bmi` is not used as a -predictor for another variable. Accordingly, we could also -- and equivalently --- impute missing values of `bmi` *after* model fitting by means of posterior -prediction. - -## References - -Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by -chained equations in R. *Journal of Statistical Software*, 1-68. -doi.org/10.18637/jss.v045.i03 - -Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple -Imputation. *The American Statistician*, 64(2), 159-163. -doi.org/10.1198/tast.2010.09109 +--- +title: "Handle Missing Values with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Handle Missing Values with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +Many real world data sets contain missing values for various reasons. Generally, +we have quite a few options to handle those missing values. The easiest solution +is to remove all rows from the data set, where one or more variables are +missing. However, if values are not missing completely at random, this will +likely lead to bias in our analysis. Accordingly, we usually want to impute +missing values in one way or the other. Here, we will consider two very general +approaches using **brms**: (1) Impute missing values *before* the model fitting +with multiple imputation, and (2) impute missing values on the fly *during* +model fitting[^1]. As a simple example, we will use the `nhanes` data set, which +contains information on participants' `age`, `bmi` (body mass index), `hyp` +(hypertensive), and `chl` (total serum cholesterol). For the purpose of the +present vignette, we are primarily interested in predicting `bmi` by `age` and +`chl`. + +```{r} +data("nhanes", package = "mice") +head(nhanes) +``` + +## Imputation before model fitting + +There are many approaches allowing us to impute missing data before the actual +model fitting takes place. From a statistical perspective, multiple imputation +is one of the best solutions. Each missing value is not imputed once but +`m` times leading to a total of `m` fully imputed data sets. The model +can then be fitted to each of those data sets separately and results are pooled +across models, afterwards. One widely applied package for multiple imputation is +**mice** (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the +following in combination with **brms**. Here, we apply the default settings of +**mice**, which means that all variables will be used to impute missing values +in all other variables and imputation functions automatically chosen based on +the variables' characteristics. + +```{r} +library(mice) +imp <- mice(nhanes, m = 5, print = FALSE) +``` + +Now, we have `m = 5` imputed data sets stored within the `imp` object. In +practice, we will likely need more than `5` of those to accurately account for +the uncertainty induced by the missingness, perhaps even in the area of `100` +imputed data sets (Zhou & Reiter, 2010). Of course, this increases the +computational burden by a lot and so we stick to `m = 5` for the purpose of this +vignette. Regardless of the value of `m`, we can either extract those data sets +and then pass them to the actual model fitting function as a list of data +frames, or pass `imp` directly. The latter works because **brms** offers special +support for data imputed by **mice**. We will go with the latter approach, since +it is less typing. Fitting our model of interest with **brms** to the multiple +imputed data sets is straightforward. + +```{r, results = 'hide', message = FALSE} +fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) +``` + +The returned fitted model is an ordinary `brmsfit` object containing the +posterior draws of all `m` submodels. While pooling across models is not +necessarily straightforward in classical statistics, it is trivial in a Bayesian +framework. Here, pooling results of multiple imputed data sets is simply +achieved by combining the posterior draws of the submodels. Accordingly, all +post-processing methods can be used out of the box without having to worry about +pooling at all. + +```{r} +summary(fit_imp1) +``` + +In the summary output, we notice that some `Rhat` values are higher than $1.1$ +indicating possible convergence problems. For models based on multiple imputed +data sets, this is often a **false positive**: Chains of different submodels may +not overlay each other exactly, since there were fitted to different data. We +can see the chains on the right-hand side of + +```{r} +plot(fit_imp1, variable = "^b", regex = TRUE) +``` + +Such non-overlaying chains imply high `Rhat` values without there actually being +any convergence issue. Accordingly, we have to investigate the convergence of +the submodels separately, which we can do by looking at + +```{r} +round(fit_imp1$rhats, 2) +``` + +The convergence of each of the submodels looks good. Accordingly, we can proceed +with further post-processing and interpretation of the results. For instance, we +could investigate the combined effect of `age` and `chl`. + +```{r} +conditional_effects(fit_imp1, "age:chl") +``` + +To summarize, the advantages of multiple imputation are obvious: One can apply +it to all kinds of models, since model fitting functions do not need to know +that the data sets were imputed, beforehand. Also, we do not need to worry about +pooling across submodels when using fully Bayesian methods. The only drawback is +the amount of time required for model fitting. Estimating Bayesian models is +already quite slow with just a single data set and it only gets worse when +working with multiple imputation. + +### Compatibility with other multiple imputation packages + +**brms** offers built-in support for **mice** mainly because I use the latter in +some of my own research projects. Nevertheless, `brm_multiple` supports all +kinds of multiple imputation packages as it also accepts a *list* of data frames +as input for its `data` argument. Thus, you just need to extract the imputed +data frames in the form of a list, which can then be passed to `brm_multiple`. +Most multiple imputation packages have some built-in functionality for this +task. When using the **mi** package, for instance, you simply need to call the +`mi::complete` function to get the desired output. + +## Imputation during model fitting + +Imputation during model fitting is generally thought to be more complex than +imputation before model fitting, because one has to take care of everything +within one step. This remains true when imputing missing values with **brms**, +but possibly to a somewhat smaller degree. Consider again the `nhanes` data with +the goal to predict `bmi` by `age`, and `chl`. Since `age` contains no missing +values, we only have to take special care of `bmi` and `chl`. We need to tell +the model two things. (1) Which variables contain missing values and how they +should be predicted, as well as (2) which of these imputed variables should be +used as predictors. In **brms** we can do this as follows: + +```{r, results = 'hide', message = FALSE} +bform <- bf(bmi | mi() ~ age * mi(chl)) + + bf(chl | mi() ~ age) + set_rescor(FALSE) +fit_imp2 <- brm(bform, data = nhanes) +``` + +The model has become multivariate, as we no longer only predict `bmi` but also +`chl` (see `vignette("brms_multivariate")` for details about the multivariate +syntax of **brms**). We ensure that missings in both variables will be modeled +rather than excluded by adding `| mi()` on the left-hand side of the +formulas[^2]. We write `mi(chl)` on the right-hand side of the formula for `bmi` +to ensure that the estimated missing values of `chl` will be used in the +prediction of `bmi`. The summary is a bit more cluttered as we get coefficients +for both response variables, but apart from that we can interpret coefficients +in the usual way. + +```{r} +summary(fit_imp2) +conditional_effects(fit_imp2, "age:chl", resp = "bmi") +``` + +The results look pretty similar to those obtained from multiple imputation, but +be aware that this may not be generally the case. In multiple imputation, the +default is to impute all variables based on all other variables, while in the +'one-step' approach, we have to explicitly specify the variables used in the +imputation. Thus, arguably, multiple imputation is easier to apply. An obvious +advantage of the 'one-step' approach is that the model needs to be fitted only +once instead of `m` times. Also, within the **brms** framework, we can use +multilevel structure and complex non-linear relationships for the imputation of +missing values, which is not achieved as easily in standard multiple imputation +software. On the downside, it is currently not possible to impute discrete +variables, because **Stan** (the engine behind **brms**) does not allow +estimating discrete parameters. + +### Combining measurement error and missing values + +Missing value terms in **brms** cannot only handle missing values but also +measurement error, or arbitrary combinations of the two. In fact, we can think +of a missing value as a value with infinite measurement error. Thus, `mi` terms +are a natural (and somewhat more verbose) generalization of the now soft deprecated +`me` terms. Suppose we had measured the variable `chl` with some known error: + +```{r} +nhanes$se <- rexp(nrow(nhanes), 2) +``` + +Then we can go ahead an include this information into the model as follows: + +```{r, results = 'hide', message = FALSE, eval = FALSE} +bform <- bf(bmi | mi() ~ age * mi(chl)) + + bf(chl | mi(se) ~ age) + set_rescor(FALSE) +fit_imp3 <- brm(bform, data = nhanes) +``` + +Summarizing and post-processing the model continues to work as usual. + + +[^1]: Actually, there is a third approach that only applies to missings in +response variables. If we want to impute missing responses, we just fit the +model using the observed responses and than impute the missings *after* fitting +the model by means of posterior prediction. That is, we supply the predictor +values corresponding to missing responses to the `predict` method. + +[^2]: We don't really need this for `bmi`, since `bmi` is not used as a +predictor for another variable. Accordingly, we could also -- and equivalently +-- impute missing values of `bmi` *after* model fitting by means of posterior +prediction. + +## References + +Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by +chained equations in R. *Journal of Statistical Software*, 1-68. +doi.org/10.18637/jss.v045.i03 + +Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple +Imputation. *The American Statistician*, 64(2), 159-163. +doi.org/10.1198/tast.2010.09109 diff -Nru r-cran-brms-2.16.3/inst/doc/brms_monotonic.html r-cran-brms-2.17.0/inst/doc/brms_monotonic.html --- r-cran-brms-2.16.3/inst/doc/brms_monotonic.html 2021-11-22 16:00:34.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_monotonic.html 2022-04-11 08:00:29.000000000 +0000 @@ -1,453 +1,460 @@ - - - - - - - - - - - - - - - - -Estimating Monotonic Effects with brms - - - - - - - - - - - - - - - - - - - - - - - - - -

Estimating Monotonic Effects with brms

-

Paul Bürkner

-

2021-11-22

- - - - -
-

Introduction

-

This vignette is about monotonic effects, a special way of handling discrete predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in review). A predictor, which we want to model as monotonic (i.e., having a monotonically increasing or decreasing relationship with the response), must either be integer valued or an ordered factor. As opposed to a continuous predictor, predictor categories (or integers) are not assumed to be equidistant with respect to their effect on the response variable. Instead, the distance between adjacent predictor categories (or integers) is estimated from the data and may vary across categories. This is realized by parameterizing as follows: One parameter, \(b\), takes care of the direction and size of the effect similar to an ordinary regression parameter. If the monotonic effect is used in a linear model, \(b\) can be interpreted as the expected average difference between two adjacent categories of the ordinal predictor. An additional parameter vector, \(\zeta\), estimates the normalized distances between consecutive predictor categories which thus defines the shape of the monotonic effect. For a single monotonic predictor, \(x\), the linear predictor term of observation \(n\) looks as follows:

-

\[\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i\]

-

The parameter \(b\) can take on any real value, while \(\zeta\) is a simplex, which means that it satisfies \(\zeta_i \in [0,1]\) and \(\sum_{i = 1}^D \zeta_i = 1\) with \(D\) being the number of elements of \(\zeta\). Equivalently, \(D\) is the number of categories (or highest integer in the data) minus 1, since we start counting categories from zero to simplify the notation.

-
-
-

A Simple Monotonic Model

-

A main application of monotonic effects are ordinal predictors that can be modeled this way without falsely treating them either as continuous or as unordered categorical predictors. In Psychology, for instance, this kind of data is omnipresent in the form of Likert scale items, which are often treated as being continuous for convenience without ever testing this assumption. As an example, suppose we are interested in the relationship of yearly income (in $) and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, people are not asked for the exact income. Instead, they are asked to rank themselves in one of certain classes, say: ‘below 20k’, ‘between 20k and 40k’, ‘between 40k and 100k’ and ‘above 100k’. We use some simulated data for illustration purposes.

-
income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100")
-income <- factor(sample(income_options, 100, TRUE), 
-                 levels = income_options, ordered = TRUE)
-mean_ls <- c(30, 60, 70, 75)
-ls <- mean_ls[income] + rnorm(100, sd = 7)
-dat <- data.frame(income, ls)
-

We now proceed with analyzing the data modeling income as a monotonic effect.

-
fit1 <- brm(ls ~ mo(income), data = dat)
-

The summary methods yield

-
summary(fit1)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: ls ~ mo(income) 
-   Data: dat (Number of observations: 100) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    30.96      1.23    28.56    33.30 1.00     2820     2627
-moincome     14.88      0.63    13.68    16.11 1.00     2492     2350
-
-Simplex Parameters: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-moincome1[1]     0.64      0.04     0.57     0.72 1.00     2984     2440
-moincome1[2]     0.26      0.04     0.18     0.35 1.00     4214     2857
-moincome1[3]     0.10      0.04     0.02     0.18 1.00     2933     2006
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     6.64      0.48     5.78     7.65 1.00     3299     2468
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(fit1, variable = "simo", regex = TRUE)
-

-
plot(conditional_effects(fit1))
-

-

The distributions of the simplex parameter of income, as shown in the plot method, demonstrate that the largest difference (about 70% of the difference between minimum and maximum category) is between the first two categories.

-

Now, let’s compare of monotonic model with two common alternative models. (a) Assume income to be continuous:

-
dat$income_num <- as.numeric(dat$income)
-fit2 <- brm(ls ~ income_num, data = dat)
-
summary(fit2)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: ls ~ income_num 
-   Data: dat (Number of observations: 100) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-           Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept     21.36      2.14    16.98    25.43 1.00     3668     3139
-income_num    15.34      0.83    13.73    17.05 1.00     3805     3037
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     9.17      0.67     7.95    10.60 1.00     3658     2650
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

or (b) Assume income to be an unordered factor:

-
contrasts(dat$income) <- contr.treatment(4)
-fit3 <- brm(ls ~ income, data = dat)
-
summary(fit3)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: ls ~ income 
-   Data: dat (Number of observations: 100) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    30.84      1.25    28.32    33.21 1.00     3332     2959
-income2      28.78      1.80    25.34    32.28 1.00     3866     3507
-income3      40.53      1.84    36.96    44.04 1.00     3747     2992
-income4      44.74      1.97    40.86    48.61 1.00     3670     2932
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     6.65      0.50     5.78     7.71 1.00     4168     2893
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

We can easily compare the fit of the three models using leave-one-out cross-validation.

-
loo(fit1, fit2, fit3)
-
Output of model 'fit1':
-
-Computed from 4000 by 100 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -332.9  6.6
-p_loo         4.7  0.7
-looic       665.7 13.2
-------
-Monte Carlo SE of elpd_loo is 0.0.
-
-All Pareto k estimates are good (k < 0.5).
-See help('pareto-k-diagnostic') for details.
-
-Output of model 'fit2':
-
-Computed from 4000 by 100 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -364.3  6.1
-p_loo         2.7  0.4
-looic       728.5 12.2
-------
-Monte Carlo SE of elpd_loo is 0.0.
-
-All Pareto k estimates are good (k < 0.5).
-See help('pareto-k-diagnostic') for details.
-
-Output of model 'fit3':
-
-Computed from 4000 by 100 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -333.0  6.6
-p_loo         4.8  0.7
-looic       666.0 13.2
-------
-Monte Carlo SE of elpd_loo is 0.0.
-
-All Pareto k estimates are good (k < 0.5).
-See help('pareto-k-diagnostic') for details.
-
-Model comparisons:
-     elpd_diff se_diff
-fit1   0.0       0.0  
-fit3  -0.1       0.1  
-fit2 -31.4       5.9
-

The monotonic model fits better than the continuous model, which is not surprising given that the relationship between income and ls is non-linear. The monotonic and the unordered factor model have almost identical fit in this example, but this may not be the case for other data sets.

-
-
-

Setting Prior Distributions

-

In the previous monotonic model, we have implicitly assumed that all differences between adjacent categories were a-priori the same, or formulated correctly, had the same prior distribution. In the following, we want to show how to change this assumption. The canonical prior distribution of a simplex parameter is the Dirichlet distribution, a multivariate generalization of the beta distribution. It is non-zero for all valid simplexes (i.e., \(\zeta_i \in [0,1]\) and \(\sum_{i = 1}^D \zeta_i = 1\)) and zero otherwise. The Dirichlet prior has a single parameter \(\alpha\) of the same length as \(\zeta\). The higher \(\alpha_i\) the higher the a-priori probability of higher values of \(\zeta_i\). Suppose that, before looking at the data, we expected that the same amount of additional money matters more for people who generally have less money. This translates into a higher a-priori values of \(\zeta_1\) (difference between ‘below_20’ and ‘20_to_40’) and hence into higher values of \(\alpha_1\). We choose \(\alpha_1 = 2\) and \(\alpha_2 = \alpha_3 = 1\), the latter being the default value of \(\alpha\). To fit the model we write:

-
prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1")
-fit4 <- brm(ls ~ mo(income), data = dat,
-            prior = prior4, sample_prior = TRUE)
-

The 1 at the end of "moincome1" may appear strange when first working with monotonic effects. However, it is necessary as one monotonic term may be associated with multiple simplex parameters, if interactions of multiple monotonic variables are included in the model.

-
summary(fit4)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: ls ~ mo(income) 
-   Data: dat (Number of observations: 100) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    30.92      1.27    28.40    33.47 1.00     2586     2174
-moincome     14.86      0.65    13.63    16.15 1.00     2287     2161
-
-Simplex Parameters: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-moincome1[1]     0.65      0.04     0.57     0.72 1.00     3057     2558
-moincome1[2]     0.26      0.04     0.18     0.35 1.00     3869     2718
-moincome1[3]     0.09      0.04     0.02     0.17 1.00     2553     1739
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     6.65      0.49     5.77     7.67 1.00     3445     2818
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

We have used sample_prior = TRUE to also obtain draws from the prior distribution of simo_moincome1 so that we can visualized it.

-
plot(fit4, variable = "prior_simo", regex = TRUE, N = 3)
-

-

As is visible in the plots, simo_moincome1[1] was a-priori on average twice as high as simo_moincome1[2] and simo_moincome1[3] as a result of setting \(\alpha_1\) to 2.

-
-
-

Modeling interactions of monotonic variables

-

Suppose, we have additionally asked participants for their age.

-
dat$age <- rnorm(100, mean = 40, sd = 10)
-

We are not only interested in the main effect of age but also in the interaction of income and age. Interactions with monotonic variables can be specified in the usual way using the * operator:

-
fit5 <- brm(ls ~ mo(income)*age, data = dat)
-
summary(fit5)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: ls ~ mo(income) * age 
-   Data: dat (Number of observations: 100) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept       35.27      5.35    22.95    44.47 1.00      930     1368
-age             -0.11      0.13    -0.34     0.19 1.00      949     1292
-moincome        15.61      2.72    10.88    21.39 1.00      713     1459
-moincome:age    -0.02      0.07    -0.17     0.10 1.00      710     1414
-
-Simplex Parameters: 
-                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-moincome1[1]         0.65      0.06     0.54     0.81 1.00     1646     1065
-moincome1[2]         0.26      0.06     0.13     0.37 1.00     2202     1090
-moincome1[3]         0.09      0.05     0.01     0.18 1.00     1604     1292
-moincome:age1[1]     0.40      0.27     0.02     0.90 1.00     1282     2237
-moincome:age1[2]     0.32      0.23     0.02     0.82 1.00     1907     2383
-moincome:age1[3]     0.28      0.22     0.01     0.78 1.00     1615     1865
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     6.50      0.47     5.67     7.47 1.00     2664     2826
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
conditional_effects(fit5, "income:age")
-

-
-
-

Modelling Monotonic Group-Level Effects

-

Suppose that the 100 people in our sample data were drawn from 10 different cities; 10 people per city. Thus, we add an identifier for city to the data and add some city-related variation to ls.

-
dat$city <- rep(1:10, each = 10)
-var_city <- rnorm(10, sd = 10)
-dat$ls <- dat$ls + var_city[dat$city]
-

With the following code, we fit a multilevel model assuming the intercept and the effect of income to vary by city:

-
fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat)
-
summary(fit6)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: ls ~ mo(income) * age + (mo(income) | city) 
-   Data: dat (Number of observations: 100) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Group-Level Effects: 
-~city (Number of levels: 10) 
-                        Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)               6.65      2.31     3.16    12.22 1.00     1544     2157
-sd(moincome)                0.75      0.62     0.03     2.31 1.00     1781     1820
-cor(Intercept,moincome)     0.12      0.55    -0.89     0.96 1.00     4133     2584
-
-Population-Level Effects: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept       37.84      6.12    24.85    48.35 1.00     1375     1954
-age             -0.08      0.14    -0.33     0.24 1.00     1287     2246
-moincome        16.38      2.99    11.08    22.51 1.00     1090     1066
-moincome:age    -0.04      0.08    -0.20     0.10 1.00     1076     1085
-
-Simplex Parameters: 
-                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-moincome1[1]         0.64      0.06     0.53     0.77 1.00     1742      971
-moincome1[2]         0.27      0.06     0.16     0.38 1.00     2359     1127
-moincome1[3]         0.09      0.05     0.01     0.19 1.00     2424     1679
-moincome:age1[1]     0.44      0.27     0.02     0.91 1.00     1543     2292
-moincome:age1[2]     0.30      0.22     0.01     0.80 1.00     2620     2964
-moincome:age1[3]     0.27      0.21     0.01     0.78 1.00     2874     2761
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     6.59      0.51     5.65     7.72 1.00     4172     2565
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

reveals that the effect of income varies only little across cities. For the present data, this is not overly surprising given that, in the data simulations, we assumed income to have the same effect across cities.

-
-
-

References

-

Bürkner P. C. & Charpentier, E. (in review). Monotonic Effects: A Principled Approach for Including Ordinal Predictors in Regression Models. PsyArXiv preprint.

-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Estimating Monotonic Effects with brms + + + + + + + + + + + + + + + + + + + + + + + + + +

Estimating Monotonic Effects with brms

+

Paul Bürkner

+

2022-04-11

+ + + + +
+

Introduction

+

This vignette is about monotonic effects, a special way of handling discrete predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in review). A predictor, which we want to model as monotonic (i.e., having a monotonically increasing or decreasing relationship with the response), must either be integer valued or an ordered factor. As opposed to a continuous predictor, predictor categories (or integers) are not assumed to be equidistant with respect to their effect on the response variable. Instead, the distance between adjacent predictor categories (or integers) is estimated from the data and may vary across categories. This is realized by parameterizing as follows: One parameter, \(b\), takes care of the direction and size of the effect similar to an ordinary regression parameter. If the monotonic effect is used in a linear model, \(b\) can be interpreted as the expected average difference between two adjacent categories of the ordinal predictor. An additional parameter vector, \(\zeta\), estimates the normalized distances between consecutive predictor categories which thus defines the shape of the monotonic effect. For a single monotonic predictor, \(x\), the linear predictor term of observation \(n\) looks as follows:

+

\[\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i\]

+

The parameter \(b\) can take on any real value, while \(\zeta\) is a simplex, which means that it satisfies \(\zeta_i \in [0,1]\) and \(\sum_{i = 1}^D \zeta_i = 1\) with \(D\) being the number of elements of \(\zeta\). Equivalently, \(D\) is the number of categories (or highest integer in the data) minus 1, since we start counting categories from zero to simplify the notation.

+
+
+

A Simple Monotonic Model

+

A main application of monotonic effects are ordinal predictors that can be modeled this way without falsely treating them either as continuous or as unordered categorical predictors. In Psychology, for instance, this kind of data is omnipresent in the form of Likert scale items, which are often treated as being continuous for convenience without ever testing this assumption. As an example, suppose we are interested in the relationship of yearly income (in $) and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, people are not asked for the exact income. Instead, they are asked to rank themselves in one of certain classes, say: ‘below 20k’, ‘between 20k and 40k’, ‘between 40k and 100k’ and ‘above 100k’. We use some simulated data for illustration purposes.

+
income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100")
+income <- factor(sample(income_options, 100, TRUE),
+                 levels = income_options, ordered = TRUE)
+mean_ls <- c(30, 60, 70, 75)
+ls <- mean_ls[income] + rnorm(100, sd = 7)
+dat <- data.frame(income, ls)
+

We now proceed with analyzing the data modeling income as a monotonic effect.

+
fit1 <- brm(ls ~ mo(income), data = dat)
+

The summary methods yield

+
summary(fit1)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: ls ~ mo(income) 
+   Data: dat (Number of observations: 100) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    29.73      1.26    27.19    32.22 1.00     2538     2427
+moincome     15.43      0.59    14.24    16.56 1.00     2565     2549
+
+Simplex Parameters: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+moincome1[1]     0.68      0.04     0.60     0.75 1.00     3088     2027
+moincome1[2]     0.20      0.04     0.11     0.28 1.00     3081     2534
+moincome1[3]     0.13      0.04     0.05     0.20 1.00     2570     1426
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     6.56      0.48     5.68     7.59 1.00     2954     2416
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(fit1, variable = "simo", regex = TRUE)
+

+
plot(conditional_effects(fit1))
+

+

The distributions of the simplex parameter of income, as shown in the plot method, demonstrate that the largest difference (about 70% of the difference between minimum and maximum category) is between the first two categories.

+

Now, let’s compare of monotonic model with two common alternative models. (a) Assume income to be continuous:

+
dat$income_num <- as.numeric(dat$income)
+fit2 <- brm(ls ~ income_num, data = dat)
+
summary(fit2)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: ls ~ income_num 
+   Data: dat (Number of observations: 100) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+           Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept     20.88      2.19    16.62    25.05 1.00     4244     3009
+income_num    15.01      0.78    13.45    16.54 1.00     4285     3163
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     9.36      0.70     8.14    10.86 1.00     4237     2892
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

or (b) Assume income to be an unordered factor:

+
contrasts(dat$income) <- contr.treatment(4)
+fit3 <- brm(ls ~ income, data = dat)
+
summary(fit3)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: ls ~ income 
+   Data: dat (Number of observations: 100) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    29.52      1.24    27.07    31.89 1.00     2856     2489
+income2      31.37      1.89    27.60    35.12 1.00     3396     3123
+income3      40.64      1.90    36.95    44.35 1.00     3371     2846
+income4      46.57      1.76    43.15    50.05 1.00     2982     2677
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     6.57      0.49     5.70     7.61 1.00     3467     2871
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

We can easily compare the fit of the three models using leave-one-out cross-validation.

+
loo(fit1, fit2, fit3)
+
Output of model 'fit1':
+
+Computed from 4000 by 100 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -332.1  7.3
+p_loo         5.0  0.9
+looic       664.2 14.7
+------
+Monte Carlo SE of elpd_loo is 0.0.
+
+All Pareto k estimates are good (k < 0.5).
+See help('pareto-k-diagnostic') for details.
+
+Output of model 'fit2':
+
+Computed from 4000 by 100 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -366.2  5.2
+p_loo         2.3  0.3
+looic       732.4 10.5
+------
+Monte Carlo SE of elpd_loo is 0.0.
+
+All Pareto k estimates are good (k < 0.5).
+See help('pareto-k-diagnostic') for details.
+
+Output of model 'fit3':
+
+Computed from 4000 by 100 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -332.2  7.3
+p_loo         5.1  0.9
+looic       664.3 14.5
+------
+Monte Carlo SE of elpd_loo is 0.0.
+
+Pareto k diagnostic values:
+                         Count Pct.    Min. n_eff
+(-Inf, 0.5]   (good)     99    99.0%   1623      
+ (0.5, 0.7]   (ok)        1     1.0%   1422      
+   (0.7, 1]   (bad)       0     0.0%   <NA>      
+   (1, Inf)   (very bad)  0     0.0%   <NA>      
+
+All Pareto k estimates are ok (k < 0.7).
+See help('pareto-k-diagnostic') for details.
+
+Model comparisons:
+     elpd_diff se_diff
+fit1   0.0       0.0  
+fit3  -0.1       0.2  
+fit2 -34.1       7.5
+

The monotonic model fits better than the continuous model, which is not surprising given that the relationship between income and ls is non-linear. The monotonic and the unordered factor model have almost identical fit in this example, but this may not be the case for other data sets.

+
+
+

Setting Prior Distributions

+

In the previous monotonic model, we have implicitly assumed that all differences between adjacent categories were a-priori the same, or formulated correctly, had the same prior distribution. In the following, we want to show how to change this assumption. The canonical prior distribution of a simplex parameter is the Dirichlet distribution, a multivariate generalization of the beta distribution. It is non-zero for all valid simplexes (i.e., \(\zeta_i \in [0,1]\) and \(\sum_{i = 1}^D \zeta_i = 1\)) and zero otherwise. The Dirichlet prior has a single parameter \(\alpha\) of the same length as \(\zeta\). The higher \(\alpha_i\) the higher the a-priori probability of higher values of \(\zeta_i\). Suppose that, before looking at the data, we expected that the same amount of additional money matters more for people who generally have less money. This translates into a higher a-priori values of \(\zeta_1\) (difference between ‘below_20’ and ‘20_to_40’) and hence into higher values of \(\alpha_1\). We choose \(\alpha_1 = 2\) and \(\alpha_2 = \alpha_3 = 1\), the latter being the default value of \(\alpha\). To fit the model we write:

+
prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1")
+fit4 <- brm(ls ~ mo(income), data = dat,
+            prior = prior4, sample_prior = TRUE)
+

The 1 at the end of "moincome1" may appear strange when first working with monotonic effects. However, it is necessary as one monotonic term may be associated with multiple simplex parameters, if interactions of multiple monotonic variables are included in the model.

+
summary(fit4)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: ls ~ mo(income) 
+   Data: dat (Number of observations: 100) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    29.67      1.23    27.30    32.09 1.00     2965     2392
+moincome     15.45      0.60    14.27    16.61 1.00     2375     2024
+
+Simplex Parameters: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+moincome1[1]     0.68      0.04     0.61     0.75 1.00     3448     2413
+moincome1[2]     0.20      0.04     0.11     0.29 1.00     3512     2605
+moincome1[3]     0.13      0.04     0.05     0.20 1.00     3094     1672
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     6.57      0.47     5.70     7.58 1.00     3393     2506
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

We have used sample_prior = TRUE to also obtain draws from the prior distribution of simo_moincome1 so that we can visualized it.

+
plot(fit4, variable = "prior_simo", regex = TRUE, N = 3)
+

+

As is visible in the plots, simo_moincome1[1] was a-priori on average twice as high as simo_moincome1[2] and simo_moincome1[3] as a result of setting \(\alpha_1\) to 2.

+
+
+

Modeling interactions of monotonic variables

+

Suppose, we have additionally asked participants for their age.

+
dat$age <- rnorm(100, mean = 40, sd = 10)
+

We are not only interested in the main effect of age but also in the interaction of income and age. Interactions with monotonic variables can be specified in the usual way using the * operator:

+
fit5 <- brm(ls ~ mo(income)*age, data = dat)
+
summary(fit5)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: ls ~ mo(income) * age 
+   Data: dat (Number of observations: 100) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept       36.76      3.69    29.48    44.09 1.00     1698     2191
+age             -0.17      0.08    -0.34    -0.00 1.00     1686     2115
+moincome        13.97      1.95    10.41    18.00 1.00     1160     1878
+moincome:age     0.04      0.04    -0.05     0.12 1.00     1108     1537
+
+Simplex Parameters: 
+                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+moincome1[1]         0.71      0.07     0.59     0.87 1.00     1456     1834
+moincome1[2]         0.17      0.06     0.03     0.29 1.00     1749     1422
+moincome1[3]         0.11      0.05     0.01     0.21 1.00     2040     1650
+moincome:age1[1]     0.32      0.23     0.01     0.82 1.00     2829     2435
+moincome:age1[2]     0.36      0.23     0.01     0.84 1.00     2741     2773
+moincome:age1[3]     0.32      0.22     0.02     0.80 1.00     2786     2436
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     6.46      0.48     5.63     7.48 1.00     3462     2946
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
conditional_effects(fit5, "income:age")
+

+
+
+

Modelling Monotonic Group-Level Effects

+

Suppose that the 100 people in our sample data were drawn from 10 different cities; 10 people per city. Thus, we add an identifier for city to the data and add some city-related variation to ls.

+
dat$city <- rep(1:10, each = 10)
+var_city <- rnorm(10, sd = 10)
+dat$ls <- dat$ls + var_city[dat$city]
+

With the following code, we fit a multilevel model assuming the intercept and the effect of income to vary by city:

+
fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat)
+
summary(fit6)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: ls ~ mo(income) * age + (mo(income) | city) 
+   Data: dat (Number of observations: 100) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Group-Level Effects: 
+~city (Number of levels: 10) 
+                        Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)               8.91      2.83     4.81    16.07 1.00     1615     1607
+sd(moincome)                0.68      0.58     0.02     2.11 1.00     2232     2169
+cor(Intercept,moincome)     0.09      0.56    -0.91     0.96 1.00     4506     2773
+
+Population-Level Effects: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept       39.89      4.94    30.14    49.72 1.00     1611     2578
+age             -0.24      0.09    -0.42    -0.06 1.00     2291     2302
+moincome        13.47      1.97     9.70    17.62 1.00     1803     2127
+moincome:age     0.06      0.05    -0.03     0.15 1.00     1723     1993
+
+Simplex Parameters: 
+                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+moincome1[1]         0.73      0.08     0.60     0.90 1.00     1962     1807
+moincome1[2]         0.15      0.07     0.02     0.28 1.00     2221     1668
+moincome1[3]         0.11      0.06     0.01     0.22 1.00     2881     1809
+moincome:age1[1]     0.33      0.22     0.02     0.79 1.00     3314     1908
+moincome:age1[2]     0.35      0.22     0.02     0.82 1.00     3455     3059
+moincome:age1[3]     0.32      0.21     0.02     0.79 1.00     4406     3095
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     6.35      0.50     5.48     7.42 1.00     3743     2902
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

reveals that the effect of income varies only little across cities. For the present data, this is not overly surprising given that, in the data simulations, we assumed income to have the same effect across cities.

+
+
+

References

+

Bürkner P. C. & Charpentier, E. (in review). Monotonic Effects: A Principled Approach for Including Ordinal Predictors in Regression Models. PsyArXiv preprint.

+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_monotonic.R r-cran-brms-2.17.0/inst/doc/brms_monotonic.R --- r-cran-brms-2.16.3/inst/doc/brms_monotonic.R 2021-11-22 16:00:33.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_monotonic.R 2022-04-11 08:00:28.000000000 +0000 @@ -1,86 +1,86 @@ -params <- -list(EVAL = TRUE) - -## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) - -## --------------------------------------------------------------------------------------- -income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") -income <- factor(sample(income_options, 100, TRUE), - levels = income_options, ordered = TRUE) -mean_ls <- c(30, 60, 70, 75) -ls <- mean_ls[income] + rnorm(100, sd = 7) -dat <- data.frame(income, ls) - -## ---- results='hide'-------------------------------------------------------------------- -fit1 <- brm(ls ~ mo(income), data = dat) - -## --------------------------------------------------------------------------------------- -summary(fit1) -plot(fit1, variable = "simo", regex = TRUE) -plot(conditional_effects(fit1)) - -## ---- results='hide'-------------------------------------------------------------------- -dat$income_num <- as.numeric(dat$income) -fit2 <- brm(ls ~ income_num, data = dat) - -## --------------------------------------------------------------------------------------- -summary(fit2) - -## ---- results='hide'-------------------------------------------------------------------- -contrasts(dat$income) <- contr.treatment(4) -fit3 <- brm(ls ~ income, data = dat) - -## --------------------------------------------------------------------------------------- -summary(fit3) - -## --------------------------------------------------------------------------------------- -loo(fit1, fit2, fit3) - -## ---- results='hide'-------------------------------------------------------------------- -prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") -fit4 <- brm(ls ~ mo(income), data = dat, - prior = prior4, sample_prior = TRUE) - -## --------------------------------------------------------------------------------------- -summary(fit4) - -## --------------------------------------------------------------------------------------- -plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) - -## --------------------------------------------------------------------------------------- -dat$age <- rnorm(100, mean = 40, sd = 10) - -## ---- results='hide'-------------------------------------------------------------------- -fit5 <- brm(ls ~ mo(income)*age, data = dat) - -## --------------------------------------------------------------------------------------- -summary(fit5) -conditional_effects(fit5, "income:age") - -## --------------------------------------------------------------------------------------- -dat$city <- rep(1:10, each = 10) -var_city <- rnorm(10, sd = 10) -dat$ls <- dat$ls + var_city[dat$city] - -## ---- results='hide'-------------------------------------------------------------------- -fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) - -## --------------------------------------------------------------------------------------- -summary(fit6) - +params <- +list(EVAL = TRUE) + +## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) + +## --------------------------------------------------------------------------------------- +income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") +income <- factor(sample(income_options, 100, TRUE), + levels = income_options, ordered = TRUE) +mean_ls <- c(30, 60, 70, 75) +ls <- mean_ls[income] + rnorm(100, sd = 7) +dat <- data.frame(income, ls) + +## ---- results='hide'-------------------------------------------------------------------- +fit1 <- brm(ls ~ mo(income), data = dat) + +## --------------------------------------------------------------------------------------- +summary(fit1) +plot(fit1, variable = "simo", regex = TRUE) +plot(conditional_effects(fit1)) + +## ---- results='hide'-------------------------------------------------------------------- +dat$income_num <- as.numeric(dat$income) +fit2 <- brm(ls ~ income_num, data = dat) + +## --------------------------------------------------------------------------------------- +summary(fit2) + +## ---- results='hide'-------------------------------------------------------------------- +contrasts(dat$income) <- contr.treatment(4) +fit3 <- brm(ls ~ income, data = dat) + +## --------------------------------------------------------------------------------------- +summary(fit3) + +## --------------------------------------------------------------------------------------- +loo(fit1, fit2, fit3) + +## ---- results='hide'-------------------------------------------------------------------- +prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") +fit4 <- brm(ls ~ mo(income), data = dat, + prior = prior4, sample_prior = TRUE) + +## --------------------------------------------------------------------------------------- +summary(fit4) + +## --------------------------------------------------------------------------------------- +plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) + +## --------------------------------------------------------------------------------------- +dat$age <- rnorm(100, mean = 40, sd = 10) + +## ---- results='hide'-------------------------------------------------------------------- +fit5 <- brm(ls ~ mo(income)*age, data = dat) + +## --------------------------------------------------------------------------------------- +summary(fit5) +conditional_effects(fit5, "income:age") + +## --------------------------------------------------------------------------------------- +dat$city <- rep(1:10, each = 10) +var_city <- rnorm(10, sd = 10) +dat$ls <- dat$ls + var_city[dat$city] + +## ---- results='hide'-------------------------------------------------------------------- +fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) + +## --------------------------------------------------------------------------------------- +summary(fit6) + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_monotonic.Rmd r-cran-brms-2.17.0/inst/doc/brms_monotonic.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_monotonic.Rmd 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_monotonic.Rmd 2022-04-11 07:21:15.000000000 +0000 @@ -1,234 +1,234 @@ ---- -title: "Estimating Monotonic Effects with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Monotonic Effects with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -This vignette is about monotonic effects, a special way of handling discrete -predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in -review). A predictor, which we want to model as monotonic (i.e., having a -monotonically increasing or decreasing relationship with the response), must -either be integer valued or an ordered factor. As opposed to a continuous -predictor, predictor categories (or integers) are not assumed to be equidistant -with respect to their effect on the response variable. Instead, the distance -between adjacent predictor categories (or integers) is estimated from the data -and may vary across categories. This is realized by parameterizing as follows: -One parameter, $b$, takes care of the direction and size of the effect similar -to an ordinary regression parameter. If the monotonic effect is used in a linear -model, $b$ can be interpreted as the expected average difference between two -adjacent categories of the ordinal predictor. An additional parameter vector, -$\zeta$, estimates the normalized distances between consecutive predictor -categories which thus defines the shape of the monotonic effect. For a single -monotonic predictor, $x$, the linear predictor term of observation $n$ looks as -follows: - -$$\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i$$ - -The parameter $b$ can take on any real value, while $\zeta$ is a simplex, which -means that it satisfies $\zeta_i \in [0,1]$ and $\sum_{i = 1}^D \zeta_i = 1$ -with $D$ being the number of elements of $\zeta$. Equivalently, $D$ is the -number of categories (or highest integer in the data) minus 1, since we start -counting categories from zero to simplify the notation. - -## A Simple Monotonic Model - -A main application of monotonic effects are ordinal predictors that can be -modeled this way without falsely treating them either as continuous or as -unordered categorical predictors. In Psychology, for instance, this kind of data -is omnipresent in the form of Likert scale items, which are often treated as -being continuous for convenience without ever testing this assumption. As an -example, suppose we are interested in the relationship of yearly income (in $) -and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, -people are not asked for the exact income. Instead, they are asked to rank -themselves in one of certain classes, say: 'below 20k', 'between 20k and 40k', -'between 40k and 100k' and 'above 100k'. We use some simulated data for -illustration purposes. - -```{r} -income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") -income <- factor(sample(income_options, 100, TRUE), - levels = income_options, ordered = TRUE) -mean_ls <- c(30, 60, 70, 75) -ls <- mean_ls[income] + rnorm(100, sd = 7) -dat <- data.frame(income, ls) -``` - -We now proceed with analyzing the data modeling `income` as a monotonic effect. - -```{r, results='hide'} -fit1 <- brm(ls ~ mo(income), data = dat) -``` - -The summary methods yield - -```{r} -summary(fit1) -plot(fit1, variable = "simo", regex = TRUE) -plot(conditional_effects(fit1)) -``` - -The distributions of the simplex parameter of `income`, as shown in the `plot` -method, demonstrate that the largest difference (about 70% of the difference -between minimum and maximum category) is between the first two categories. - -Now, let's compare of monotonic model with two common alternative models. (a) -Assume `income` to be continuous: - -```{r, results='hide'} -dat$income_num <- as.numeric(dat$income) -fit2 <- brm(ls ~ income_num, data = dat) -``` - -```{r} -summary(fit2) -``` - -or (b) Assume `income` to be an unordered factor: - -```{r, results='hide'} -contrasts(dat$income) <- contr.treatment(4) -fit3 <- brm(ls ~ income, data = dat) -``` - -```{r} -summary(fit3) -``` - -We can easily compare the fit of the three models using leave-one-out -cross-validation. - -```{r} -loo(fit1, fit2, fit3) -``` - -The monotonic model fits better than the continuous model, which is not -surprising given that the relationship between `income` and `ls` is non-linear. -The monotonic and the unordered factor model have almost identical fit in this -example, but this may not be the case for other data sets. - -## Setting Prior Distributions - -In the previous monotonic model, we have implicitly assumed that all differences -between adjacent categories were a-priori the same, or formulated correctly, had -the same prior distribution. In the following, we want to show how to change -this assumption. The canonical prior distribution of a simplex parameter is the -Dirichlet distribution, a multivariate generalization of the beta distribution. -It is non-zero for all valid simplexes (i.e., $\zeta_i \in [0,1]$ and $\sum_{i = -1}^D \zeta_i = 1$) and zero otherwise. The Dirichlet prior has a single -parameter $\alpha$ of the same length as $\zeta$. The higher $\alpha_i$ the -higher the a-priori probability of higher values of $\zeta_i$. Suppose that, -before looking at the data, we expected that the same amount of additional money -matters more for people who generally have less money. This translates into a -higher a-priori values of $\zeta_1$ (difference between 'below_20' and -'20_to_40') and hence into higher values of $\alpha_1$. We choose $\alpha_1 = 2$ -and $\alpha_2 = \alpha_3 = 1$, the latter being the default value of $\alpha$. -To fit the model we write: - -```{r, results='hide'} -prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") -fit4 <- brm(ls ~ mo(income), data = dat, - prior = prior4, sample_prior = TRUE) -``` - -The `1` at the end of `"moincome1"` may appear strange when first working with -monotonic effects. However, it is necessary as one monotonic term may be -associated with multiple simplex parameters, if interactions of multiple -monotonic variables are included in the model. - -```{r} -summary(fit4) -``` - -We have used `sample_prior = TRUE` to also obtain draws from the prior -distribution of `simo_moincome1` so that we can visualized it. - -```{r} -plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) -``` - -As is visible in the plots, `simo_moincome1[1]` was a-priori on average twice as -high as `simo_moincome1[2]` and `simo_moincome1[3]` as a result of setting -$\alpha_1$ to 2. - -## Modeling interactions of monotonic variables - -Suppose, we have additionally asked participants for their age. - -```{r} -dat$age <- rnorm(100, mean = 40, sd = 10) -``` - -We are not only interested in the main effect of age but also in the interaction -of income and age. Interactions with monotonic variables can be specified in the -usual way using the `*` operator: - -```{r, results='hide'} -fit5 <- brm(ls ~ mo(income)*age, data = dat) -``` - -```{r} -summary(fit5) -conditional_effects(fit5, "income:age") -``` - -## Modelling Monotonic Group-Level Effects - -Suppose that the 100 people in our sample data were drawn from 10 different -cities; 10 people per city. Thus, we add an identifier for `city` to the data -and add some city-related variation to `ls`. - -```{r} -dat$city <- rep(1:10, each = 10) -var_city <- rnorm(10, sd = 10) -dat$ls <- dat$ls + var_city[dat$city] -``` - -With the following code, we fit a multilevel model assuming the intercept and -the effect of `income` to vary by city: - -```{r, results='hide'} -fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) -``` - -```{r} -summary(fit6) -``` - -reveals that the effect of `income` varies only little across cities. For the -present data, this is not overly surprising given that, in the data simulations, -we assumed `income` to have the same effect across cities. - -## References - -Bürkner P. C. & Charpentier, E. (in review). [Monotonic Effects: A Principled -Approach for Including Ordinal Predictors in Regression Models](https://psyarxiv.com/9qkhj/). *PsyArXiv preprint*. +--- +title: "Estimating Monotonic Effects with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Monotonic Effects with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +This vignette is about monotonic effects, a special way of handling discrete +predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in +review). A predictor, which we want to model as monotonic (i.e., having a +monotonically increasing or decreasing relationship with the response), must +either be integer valued or an ordered factor. As opposed to a continuous +predictor, predictor categories (or integers) are not assumed to be equidistant +with respect to their effect on the response variable. Instead, the distance +between adjacent predictor categories (or integers) is estimated from the data +and may vary across categories. This is realized by parameterizing as follows: +One parameter, $b$, takes care of the direction and size of the effect similar +to an ordinary regression parameter. If the monotonic effect is used in a linear +model, $b$ can be interpreted as the expected average difference between two +adjacent categories of the ordinal predictor. An additional parameter vector, +$\zeta$, estimates the normalized distances between consecutive predictor +categories which thus defines the shape of the monotonic effect. For a single +monotonic predictor, $x$, the linear predictor term of observation $n$ looks as +follows: + +$$\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i$$ + +The parameter $b$ can take on any real value, while $\zeta$ is a simplex, which +means that it satisfies $\zeta_i \in [0,1]$ and $\sum_{i = 1}^D \zeta_i = 1$ +with $D$ being the number of elements of $\zeta$. Equivalently, $D$ is the +number of categories (or highest integer in the data) minus 1, since we start +counting categories from zero to simplify the notation. + +## A Simple Monotonic Model + +A main application of monotonic effects are ordinal predictors that can be +modeled this way without falsely treating them either as continuous or as +unordered categorical predictors. In Psychology, for instance, this kind of data +is omnipresent in the form of Likert scale items, which are often treated as +being continuous for convenience without ever testing this assumption. As an +example, suppose we are interested in the relationship of yearly income (in $) +and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, +people are not asked for the exact income. Instead, they are asked to rank +themselves in one of certain classes, say: 'below 20k', 'between 20k and 40k', +'between 40k and 100k' and 'above 100k'. We use some simulated data for +illustration purposes. + +```{r} +income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") +income <- factor(sample(income_options, 100, TRUE), + levels = income_options, ordered = TRUE) +mean_ls <- c(30, 60, 70, 75) +ls <- mean_ls[income] + rnorm(100, sd = 7) +dat <- data.frame(income, ls) +``` + +We now proceed with analyzing the data modeling `income` as a monotonic effect. + +```{r, results='hide'} +fit1 <- brm(ls ~ mo(income), data = dat) +``` + +The summary methods yield + +```{r} +summary(fit1) +plot(fit1, variable = "simo", regex = TRUE) +plot(conditional_effects(fit1)) +``` + +The distributions of the simplex parameter of `income`, as shown in the `plot` +method, demonstrate that the largest difference (about 70% of the difference +between minimum and maximum category) is between the first two categories. + +Now, let's compare of monotonic model with two common alternative models. (a) +Assume `income` to be continuous: + +```{r, results='hide'} +dat$income_num <- as.numeric(dat$income) +fit2 <- brm(ls ~ income_num, data = dat) +``` + +```{r} +summary(fit2) +``` + +or (b) Assume `income` to be an unordered factor: + +```{r, results='hide'} +contrasts(dat$income) <- contr.treatment(4) +fit3 <- brm(ls ~ income, data = dat) +``` + +```{r} +summary(fit3) +``` + +We can easily compare the fit of the three models using leave-one-out +cross-validation. + +```{r} +loo(fit1, fit2, fit3) +``` + +The monotonic model fits better than the continuous model, which is not +surprising given that the relationship between `income` and `ls` is non-linear. +The monotonic and the unordered factor model have almost identical fit in this +example, but this may not be the case for other data sets. + +## Setting Prior Distributions + +In the previous monotonic model, we have implicitly assumed that all differences +between adjacent categories were a-priori the same, or formulated correctly, had +the same prior distribution. In the following, we want to show how to change +this assumption. The canonical prior distribution of a simplex parameter is the +Dirichlet distribution, a multivariate generalization of the beta distribution. +It is non-zero for all valid simplexes (i.e., $\zeta_i \in [0,1]$ and $\sum_{i = +1}^D \zeta_i = 1$) and zero otherwise. The Dirichlet prior has a single +parameter $\alpha$ of the same length as $\zeta$. The higher $\alpha_i$ the +higher the a-priori probability of higher values of $\zeta_i$. Suppose that, +before looking at the data, we expected that the same amount of additional money +matters more for people who generally have less money. This translates into a +higher a-priori values of $\zeta_1$ (difference between 'below_20' and +'20_to_40') and hence into higher values of $\alpha_1$. We choose $\alpha_1 = 2$ +and $\alpha_2 = \alpha_3 = 1$, the latter being the default value of $\alpha$. +To fit the model we write: + +```{r, results='hide'} +prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") +fit4 <- brm(ls ~ mo(income), data = dat, + prior = prior4, sample_prior = TRUE) +``` + +The `1` at the end of `"moincome1"` may appear strange when first working with +monotonic effects. However, it is necessary as one monotonic term may be +associated with multiple simplex parameters, if interactions of multiple +monotonic variables are included in the model. + +```{r} +summary(fit4) +``` + +We have used `sample_prior = TRUE` to also obtain draws from the prior +distribution of `simo_moincome1` so that we can visualized it. + +```{r} +plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) +``` + +As is visible in the plots, `simo_moincome1[1]` was a-priori on average twice as +high as `simo_moincome1[2]` and `simo_moincome1[3]` as a result of setting +$\alpha_1$ to 2. + +## Modeling interactions of monotonic variables + +Suppose, we have additionally asked participants for their age. + +```{r} +dat$age <- rnorm(100, mean = 40, sd = 10) +``` + +We are not only interested in the main effect of age but also in the interaction +of income and age. Interactions with monotonic variables can be specified in the +usual way using the `*` operator: + +```{r, results='hide'} +fit5 <- brm(ls ~ mo(income)*age, data = dat) +``` + +```{r} +summary(fit5) +conditional_effects(fit5, "income:age") +``` + +## Modelling Monotonic Group-Level Effects + +Suppose that the 100 people in our sample data were drawn from 10 different +cities; 10 people per city. Thus, we add an identifier for `city` to the data +and add some city-related variation to `ls`. + +```{r} +dat$city <- rep(1:10, each = 10) +var_city <- rnorm(10, sd = 10) +dat$ls <- dat$ls + var_city[dat$city] +``` + +With the following code, we fit a multilevel model assuming the intercept and +the effect of `income` to vary by city: + +```{r, results='hide'} +fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) +``` + +```{r} +summary(fit6) +``` + +reveals that the effect of `income` varies only little across cities. For the +present data, this is not overly surprising given that, in the data simulations, +we assumed `income` to have the same effect across cities. + +## References + +Bürkner P. C. & Charpentier, E. (in review). [Monotonic Effects: A Principled +Approach for Including Ordinal Predictors in Regression Models](https://psyarxiv.com/9qkhj/). *PsyArXiv preprint*. diff -Nru r-cran-brms-2.16.3/inst/doc/brms_multilevel.ltx r-cran-brms-2.17.0/inst/doc/brms_multilevel.ltx --- r-cran-brms-2.16.3/inst/doc/brms_multilevel.ltx 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_multilevel.ltx 2022-03-13 16:10:29.000000000 +0000 @@ -1,679 +1,679 @@ -\documentclass[article, nojss]{jss} - -%\VignetteIndexEntry{Multilevel Models with brms} -%\VignetteEngine{R.rsp::tex} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% almost as usual -\author{Paul-Christian B\"urkner} -\title{Advanced Bayesian Multilevel Modeling with the \proglang{R} Package \pkg{brms}} - -%% for pretty printing and a nice hypersummary also set: -\Plainauthor{Paul-Christian B\"urkner} %% comma-separated -\Plaintitle{Advanced Bayesian Multilevel Modeling with the R Package brms} %% without formatting -\Shorttitle{Advanced Bayesian Multilevel Modeling with \pkg{brms}} %% a short title (if necessary) - -%% an abstract and keywords -\Abstract{ - The \pkg{brms} package allows R users to easily specify a wide range of Bayesian single-level and multilevel models, which are fitted with the probabilistic programming language \proglang{Stan} behind the scenes. Several response distributions are supported, of which all parameters (e.g., location, scale, and shape) can be predicted at the same time thus allowing for distributional regression. Non-linear relationships may be specified using non-linear predictor terms or semi-parametric approaches such as splines or Gaussian processes. Multivariate models, in which each response variable can be predicted using the above mentioned options, can be fitted as well. To make all of these modeling options possible in a multilevel framework, \pkg{brms} provides an intuitive and powerful formula syntax, which extends the well known formula syntax of \pkg{lme4}. The purpose of the present paper is to introduce this syntax in detail and to demonstrate its usefulness with four examples, each showing other relevant aspects of the syntax. If you use \pkg{brms}, please cite this article as published in the R Journal \citep{brms2}. -} -\Keywords{Bayesian inference, multilevel models, distributional regression, MCMC, \proglang{Stan}, \proglang{R}} -\Plainkeywords{Bayesian inference, multilevel models, distributional regression, MCMC, Stan, R} %% without formatting -%% at least one keyword must be supplied - -%% publication information -%% NOTE: Typically, this can be left commented and will be filled out by the technical editor -%% \Volume{50} -%% \Issue{9} -%% \Month{June} -%% \Year{2012} -%% \Submitdate{2012-06-04} -%% \Acceptdate{2012-06-04} - -%% The address of (at least) one author should be given -%% in the following format: -\Address{ - Paul-Christian B\"urkner\\ - E-mail: \email{paul.buerkner@gmail.com}\\ - URL: \url{https://paul-buerkner.github.io} -} -%% It is also possible to add a telephone and fax number -%% before the e-mail in the following format: -%% Telephone: +43/512/507-7103 -%% Fax: +43/512/507-2851 - - -%% for those who use Sweave please include the following line (with % symbols): -%% need no \usepackage{Sweave.sty} - -%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\begin{document} - -%% include your article here, just as usual -%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. - -\section{Introduction} - -Multilevel models (MLMs) offer great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for R have been developed to fit MLMs. Usually, however, the functionality of these implementations is limited insofar as it is only possible to predict the mean of the response distribution. Other parameters of the response distribution, such as the residual standard deviation in linear models, are assumed constant across observations, which may be violated in many applications. Accordingly, it is desirable to allow for prediction of \emph{all} response parameters at the same time. Models doing exactly that are often referred to as \emph{distributional models} or more verbosely \emph{models for location, scale and shape} \citep{rigby2005}. Another limitation of basic MLMs is that they only allow for linear predictor terms. While linear predictor terms already offer good flexibility, they are of limited use when relationships are inherently non-linear. Such non-linearity can be handled in at least two ways: (1) by fully specifying a non-linear predictor term with corresponding parameters each of which can be predicted using MLMs \citep{lindstrom1990}, or (2) estimating the form of the non-linear relationship on the fly using splines \citep{wood2004} or Gaussian processes \citep{rasmussen2006}. The former are often simply called \emph{non-linear models}, while models applying splines are referred to as \emph{generalized additive models} (GAMs; \citeauthor{hastie1990}, \citeyear{hastie1990}). - -Combining all of these modeling options into one framework is a complex task, both conceptually and with regard to model fitting. Maximum likelihood methods, which are typically applied in classical 'frequentist' statistics, can reach their limits at some point and fully Bayesian methods become the go-to solutions to fit such complex models \citep{gelman2014}. In addition to being more flexible, the Bayesian framework comes with other advantages, for instance, the ability to derive probability statements for every quantity of interest or explicitly incorporating prior knowledge about parameters into the model. The former is particularly relevant in non-linear models, for which classical approaches struggle more often than not in propagating all the uncertainty in the parameter estimates to non-linear functions such as out-of-sample predictions. - -Possibly the most powerful program for performing full Bayesian inference available to date is Stan \citep{stanM2017, carpenter2017}. It implements Hamiltonian Monte Carlo \citep{duane1987, neal2011, betancourt2014} and its extension, the No-U-Turn (NUTS) Sampler \citep{hoffman2014}. These algorithms converge much more quickly than other Markov-Chain Monte-Carlo (MCMC) algorithms especially for high-dimensional models \citep{hoffman2014, betancourt2014, betancourt2017}. An excellent non-mathematical introduction to Hamiltonian Monte Carlo can be found in \citet{betancourt2017}. - -Stan comes with its own programming language, allowing for great modeling flexibility \cite{stanM2017, carpenter2017}). Many researchers may still be hesitent to use Stan directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error-prone process even for researchers familiar with Bayesian inference. The \pkg{brms} package \citep{brms1}, presented in this paper, aims to remove these hurdles for a wide range of regression models by allowing the user to benefit from the merits of Stan by using extended \pkg{lme4}-like \citep{bates2015} formula syntax, with which many R users are familiar with. It offers much more than writing efficient and human-readable Stan code: \pkg{brms} comes with many post-processing and visualization functions, for instance to perform posterior predictive checks, leave-one-out cross-validation, visualization of estimated effects, and prediction of new data. The overarching aim is to have one general framework for regression modeling, which offers everything required to successfully apply regression models to complex data. To date, it already replaces and extends the functionality of dozens of other R packages, each of which is restricted to specific regression models\footnote{Unfortunately, due to the implementation via Stan, it is not easily possible for users to define their own response distributions and run them via \pkg{brms}. If you feel that a response distribution is missing in \pkg{brms}, please open an issue on GitHub (\url{https://github.com/paul-buerkner/brms}).}. - -The purpose of the present article is to provide an introduction of the advanced multilevel formula syntax implemented in \pkg{brms}, which allows to fit a wide and growing range of non-linear distributional multilevel models. A general overview of the package is already given in \citet{brms1}. Accordingly, the present article focuses on more recent developments. We begin by explaining the underlying structure of distributional models. Next, the formula syntax of \pkg{lme4} and its extensions implemented in \pkg{brms} are explained. Four examples that demonstrate the use of the new syntax are discussed in detail. Afterwards, the functionality of \pkg{brms} is compared with that of \pkg{rstanarm} \citep{rstanarm2017} and \pkg{MCMCglmm} \citep{hadfield2010}. We end by describing future plans for extending the package. - -\section{Model description} -\label{model} - -The core of models implemented in \pkg{brms} is the prediction of the response $y$ through predicting all parameters $\theta_p$ of the response distribution $D$, which is also called the model \code{family} in many R packages. We write -$$y_i \sim D(\theta_{1i}, \theta_{2i}, ...)$$ -to stress the dependency on the $i\textsuperscript{th}$ observation. Every parameter $\theta_p$ may be regressed on its own predictor term $\eta_p$ transformed by the inverse link function $f_p$ that is $\theta_{pi} = f_p(\eta_{pi})$\footnote{A parameter can also be assumed constant across observations so that a linear predictor is not required.}. Such models are typically refered to as \emph{distributional models}\footnote{The models described in \citet{brms1} are a sub-class of the here described models.}. Details about the parameterization of each \code{family} are given in \code{vignette("brms\_families")}. - -Suppressing the index $p$ for simplicity, a predictor term $\eta$ can generally be written as -$$ -\eta = \mathbf{X} \beta + \mathbf{Z} u + \sum_{k = 1}^K s_k(x_k) -$$ -In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The terms $s_k(x_k)$ symbolize optional smooth functions of unspecified form based on covariates $x_k$ fitted via splines (see \citet{wood2011} for the underlying implementation in the \pkg{mgcv} package) or Gaussian processes \citep{williams1996}. The response $y$ as well as $\mathbf{X}$, $\mathbf{Z}$, and $x_k$ make up the data, whereas $\beta$, $u$, and the smooth functions $s_k$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects, but I avoid theses terms following the recommendations of \citet{gelmanMLM2006}. Details about prior distributions of $\beta$ and $u$ can be found in \citet{brms1} and under \code{help("set\_prior")}. - -As an alternative to the strictly additive formulation described above, predictor terms may also have any form specifiable in Stan. We call it a \emph{non-linear} predictor and write -$$\eta = f(c_1, c_2, ..., \phi_1, \phi_2, ...)$$ -The structure of the function $f$ is given by the user, $c_r$ are known or observed covariates, and $\phi_s$ are non-linear parameters each having its own linear predictor term $\eta_{\phi_s}$ of the form specified above. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves. A frequentist implementation of such models, which inspired the non-linear syntax in \pkg{brms}, can be found in the \pkg{nlme} package \citep{nlme2016}. - -\section{Extended multilevel formula syntax} -\label{formula_syntax} - -The formula syntax applied in \pkg{brms} builds upon the syntax of the R package \pkg{lme4} \citep{bates2015}. First, we will briefly explain the \pkg{lme4} syntax used to specify multilevel models and then introduce certain extensions that allow to specify much more complicated models in \pkg{brms}. An \pkg{lme4} formula has the general form - -\begin{Sinput} -response ~ pterms + (gterms | group) -\end{Sinput} -The \code{pterms} part contains the population-level effects that are assumed to be the same across obervations. The \code{gterms} part contains so called group-level effects that are assumed to vary accross grouping variables specified in \code{group}. Multiple grouping factors each with multiple group-level effects are possible. Usually, \code{group} contains only a single variable name pointing to a factor, but you may also use \code{g1:g2} or \code{g1/g2}, if both \code{g1} and \code{g2} are suitable grouping factors. The \code{:} operator creates a new grouping factor that consists of the combined levels of \code{g1} and \code{g2} (you could think of this as pasting the levels of both factors together). The \code{/} operator indicates nested grouping structures and expands one grouping factor into two or more when using multiple \code{/} within one term. If, for instance, you write \code{(1 | g1/g2)}, it will be expanded to \code{(1 | g1) + (1 | g1:g2)}. Instead of \code{|} you may use \code{||} in grouping terms to prevent group-level correlations from being modeled. This may be useful in particular when modeling so many group-level effects that convergence of the fitting algorithms becomes an issue due to model complexity. One limitation of the \code{||} operator in \pkg{lme4} is that it only splits up terms so that columns of the design matrix originating from the same term are still modeled as correlated (e.g., when coding a categorical predictor; see the \code{mixed} function of the \pkg{afex} package by \citet{afex2015} for a way to avoid this behavior). - -While intuitive and visually appealing, the classic \pkg{lme4} syntax is not flexible enough to allow for specifying the more complex models supported by \pkg{brms}. In non-linear or distributional models, for instance, multiple parameters are predicted, each having their own population and group-level effects. Hence, multiple formulas are necessary to specify such models\footnote{Actually, it is possible to specify multiple model parts within one formula using interactions terms for instance as implemented in \pkg{MCMCglmm} \citep{hadfield2010}. However, this syntax is limited in flexibility and requires a rather deep understanding of the way R parses formulas, thus often being confusing to users.}. Then, however, specifying group-level effects of the same grouping factor to be correlated \emph{across} formulas becomes complicated. The solution implemented in \pkg{brms} (and currently unique to it) is to expand the \code{|} operator into \code{||}, where \code{} can be any value. Group-level terms with the same \code{ID} will then be modeled as correlated if they share same grouping factor(s)\footnote{It might even be further extended to \code{|fun()|}, where \code{fun} defines the type of correlation structure, defaulting to unstructured that is estimating the full correlation matrix. The \code{fun} argument is not yet supported by \pkg{brms} but could be supported in the future if other correlation structures, such as compound symmetry or Toeplitz, turn out to have reasonable practical applications and effective implementations in Stan.}. For instance, if the terms \code{(x1|ID|g1)} and \code{(x2|ID|g1)} appear somewhere in the same or different formulas passed to \pkg{brms}, they will be modeled as correlated. - -Further extensions of the classical \pkg{lme4} syntax refer to the \code{group} part. It is rather limited in its flexibility since only variable names combined by \code{:} or \code{/} are supported. We propose two extensions of this syntax: Firstly, \code{group} can generally be split up in its terms so that, say, \code{(1 | g1 + g2)} is expanded to \code{(1 | g1) + (1 | g2)}. This is fully consistent with the way \code{/} is handled so it provides a natural generalization to the existing syntax. Secondly, there are some special grouping structures that cannot be expressed by simply combining grouping variables. For instance, multi-membership models cannot be expressed this way. To overcome this limitation, we propose wrapping terms in \code{group} within special functions that allow specifying alternative grouping structures: \code{(gterms | fun(group))}. In \pkg{brms}, there are currently two such functions implemented, namely \code{gr} for the default behavior and \code{mm} for multi-membership terms. To be compatible with the original syntax and to keep formulas short, \code{gr} is automatically added internally if none of these functions is specified. - -While some non-linear relationships, such as quadratic relationships, can be expressed within the basic R formula syntax, other more complicated ones cannot. For this reason, it is possible in \pkg{brms} to fully specify non-linear predictor terms similar to how it is done in \pkg{nlme}, but fully compatible with the extended multilevel syntax described above. Suppose, for instance, we want to model the non-linear growth curve -$$ -y = b_1 (1 - \exp(-(x / b_2)^{b_3}) -$$ -between $y$ and $x$ with parameters $b_1$, $b_2$, and $b_3$ (see Example 3 in this paper for an implementation of this model with real data). Furthermore, we want all three parameters to vary by a grouping variable $g$ and model those group-level effects as correlated. Additionally $b_1$ should be predicted by a covariate $z$. We can express this in \pkg{brms} using multiple formulas, one for the non-linear model itself and one per non-linear parameter: -\begin{Sinput} -y ~ b1 * (1 - exp(-(x / b2) ^ b3) -b1 ~ z + (1|ID|g) -b2 ~ (1|ID|g) -b3 ~ (1|ID|g) -\end{Sinput} -The first formula will not be evaluated using standard R formula parsing, but instead taken literally. In contrast, the formulas for the non-linear parameters will be evaluated in the usual way and are compatible with all terms supported by \pkg{brms}. Note that we have used the above described ID-syntax to model group-level effects as correlated across formulas. - -There are other syntax extensions implemented in \pkg{brms} that do not directly target grouping terms. Firstly, there are terms formally included in the \code{pterms} part that are handled separately. The most prominent examples are smooth terms specified through the \code{s} and \code{t2} functions of the \pkg{mgcv} package \citep{wood2011}. Other examples are category specific effects \code{cs}, monotonic effects \code{mo}, noise-free effects \code{me}, or Gaussian process terms \code{gp}. The former is explained in \citet{brms1}, while the latter three are documented in \code{help(brmsformula)}. Internally, these terms are extracted from \code{pterms} and not included in the construction of the population-level design matrix. Secondly, making use of the fact that \code{|} is unused on the left-hand side of $\sim$ in formula, additional information on the response variable may be specified via -\begin{Sinput} -response | aterms ~ -\end{Sinput} -The \code{aterms} part may contain multiple terms of the form \code{fun()} separated by \code{+} each providing special information on the response variable. This allows among others to weight observations, provide known standard errors for meta-analysis, or model censored or truncated data. -As it is not the main topic of the present paper, we refer to \code{help("brmsformula")} and \code{help("addition-terms")} for more details. - -To set up the model formulas and combine them into one object, \pkg{brms} defines the \code{brmsformula} (or short \code{bf}) function. Its output can then be passed to the \code{parse\_bf} function, which splits up the formulas in separate parts and prepares them for the generation of design matrices and related data. Other packages may re-use these functions in their own routines making it easier to offer support for the above described multilevel syntax. - -\section{Examples} - -The idea of \pkg{brms} is to provide one unified framework for multilevel regression models in R. As such, the above described formula syntax in all of its variations can be applied in combination with all response distributions supported by \pkg{brms} (currently about 35 response distributions are supported; see \code{help("brmsfamily")} and \code{vignette("brms\_families")} for an overview). - -In this section, we will discuss four examples in detail, each focusing on certain aspects of the syntax. They are chosen to provide a broad overview of the modeling options. The first is about the number of fish caught be different groups of people. It does not actually contain any multilevel structure, but helps in understanding how to set up formulas for different model parts. The second example is about housing rents in Munich. We model the data using splines and a distributional regression approach. The third example is about cumulative insurance loss payments across several years, which is fitted using a rather complex non-linear multilevel model. Finally, the fourth example is about the performance of school children, who change school during the year, thus requiring a multi-membership model. - -Despite not being covered in the four examples, there are a few more modeling options that we want to briefly describe. First, \pkg{brms} allows fitting so called phylogenetic models. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. Species are not independent as they come from the same phylogenetic tree, implying that different levels of the same grouping-factor (i.e., species) are likely correlated. There is a whole vignette dedicated to this topic, which can be found via \code{vignette("brms\_phylogenetics")}. Second, there is a canonical way to handle ordinal predictors, without falsely assuming they are either categorical or continuous. We call them monotonic effects and discuss them in \code{vignette("brms\_monotonic")}. Last but not least, it is possible to account for measurement error in both response and predictor variables. This is often ignored in applied regression modeling \citep{westfall2016}, although measurement error is very common in all scientific fields making use of observational data. There is no vignette yet covering this topic, but one will be added in the future. In the meantime, \code{help("brmsformula")} is the best place to start learning about such models as well as about other details of the \pkg{brms} formula syntax. - -\subsection{Example 1: Catching fish} - -An important application of the distributional regression framework of \pkg{brms} are so called zero-inflated and hurdle models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), the data are described as follows: ``The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.'' - -\begin{Sinput} -zinb <- read.csv("http://stats.idre.ucla.edu/stat/data/fish.csv") -zinb$camper <- factor(zinb$camper, labels = c("no", "yes")) -head(zinb) -\end{Sinput} - -\begin{Sinput} - nofish livebait camper persons child xb zg count -1 1 0 no 1 0 -0.8963146 3.0504048 0 -2 0 1 yes 1 0 -0.5583450 1.7461489 0 -3 0 1 no 1 0 -0.4017310 0.2799389 0 -4 0 1 yes 2 1 -0.9562981 -0.6015257 0 -5 0 1 no 1 0 0.4368910 0.5277091 1 -6 0 1 yes 4 2 1.3944855 -0.7075348 0 -\end{Sinput} -As predictors we choose the number of people per group, the number of children, as well as whether or not the group consists of campers. Many groups may not catch any fish just because they do not try and so we fit a zero-inflated Poisson model. For now, we assume a constant zero-inflation probability across observations. - -\begin{Sinput} -fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, - family = zero_inflated_poisson("log")) -\end{Sinput} -The model is readily summarized via - -\begin{Sinput} -summary(fit_zinb1) -\end{Sinput} - -\begin{Sinput} - Family: zero_inflated_poisson (log) -Formula: count ~ persons + child + camper - Data: zinb (Number of observations: 250) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: Not computed - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept -1.01 0.17 -1.34 -0.67 2171 1 -persons 0.87 0.04 0.79 0.96 2188 1 -child -1.36 0.09 -1.55 -1.18 1790 1 -camper 0.80 0.09 0.62 0.98 2950 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -zi 0.41 0.04 0.32 0.49 2409 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} -A graphical summary is available through - -\begin{Sinput} -conditional_effects(fit_zinb1) -\end{Sinput} -\begin{figure}[ht] - \centering - \includegraphics[width=0.99\textwidth,keepaspectratio]{me_zinb1.pdf} - \caption{Conditional effects plots of the \code{fit\_zinb1} model.} - \label{me_zinb1} -\end{figure} -(see Figure \ref{me_zinb1}). In fact, the \code{conditional\_effects} method turned out to be so powerful in visualizing effects of predictors that I am using it almost as frequently as \code{summary}. According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability \code{zi} is pretty large with a mean of 41\%. Please note that the probability of catching no fish is actually higher than 41\%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-\emph{inflation}). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here). - -Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish, since children often lack the patience required for fishing. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data. - -\begin{Sinput} -fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), - data = zinb, family = zero_inflated_poisson()) -\end{Sinput} -To transform the linear predictor of \code{zi} into a probability, \pkg{brms} applies the logit-link, which takes values within $[0, 1]$ and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors. - -\begin{Sinput} -summary(fit_zinb2) -\end{Sinput} - -\begin{Sinput} - Family: zero_inflated_poisson (log) -Formula: count ~ persons + child + camper - zi ~ child - Data: zinb (Number of observations: 250) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: Not computed - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept -1.07 0.18 -1.43 -0.73 2322 1 -persons 0.89 0.05 0.80 0.98 2481 1 -child -1.17 0.10 -1.37 -1.00 2615 1 -camper 0.78 0.10 0.60 0.96 3270 1 -zi_Intercept -0.95 0.27 -1.52 -0.48 2341 1 -zi_child 1.21 0.28 0.69 1.79 2492 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} - -According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your chance of catching no fish at all (as implied by the zero-inflation part), possibly because groups with more children spend less time or no time at all fishing. Comparing model fit via leave-one-out cross validation as implemented in the \pkg{loo} package \citep{loo2016, vehtari2016}. - -\begin{Sinput} -LOO(fit_zinb1, fit_zinb2) -\end{Sinput} - -\begin{Sinput} - LOOIC SE -fit_zinb1 1639.52 363.30 -fit_zinb2 1621.35 362.39 -fit_zinb1 - fit_zinb2 18.16 15.71 -\end{Sinput} -reveals that the second model using the number of children to predict both model parts has better fit. However, when considering the standard error of the \code{LOOIC} difference, improvement in model fit is apparently modest and not substantial. More examples of distributional model can be found in \code{vignette("brms\_distreg")}. - -\subsection{Example 2: Housing rents} - -In their book about regression modeling, \citet{fahrmeir2013} use an example about the housing rents in Munich from 1999. The data contains information about roughly 3000 apartments including among others the absolute rent (\code{rent}), rent per square meter (\code{rentsqm}), size of the apartment (\code{area}), construction year (\code{yearc}), and the district in Munich (\code{district}), where the apartment is located. The data can be found in the \pkg{gamlss.data} package \citep{gamlss.data}: - -\begin{Sinput} -data("rent99", package = "gamlss.data") -head(rent99) -\end{Sinput} - -\begin{Sinput} - rent rentsqm area yearc location bath kitchen cheating district -1 109.9487 4.228797 26 1918 2 0 0 0 916 -2 243.2820 8.688646 28 1918 2 0 0 1 813 -3 261.6410 8.721369 30 1918 1 0 0 1 611 -4 106.4103 3.547009 30 1918 2 0 0 0 2025 -5 133.3846 4.446154 30 1918 2 0 0 1 561 -6 339.0256 11.300851 30 1918 2 0 0 1 541 -\end{Sinput} -Here, we aim at predicting the rent per square meter with the size of the apartment as well as the construction year, while taking the district of Munich into account. As the effect of both predictors on the rent is of unknown non-linear form, we model these variables using a bivariate tensor spline \citep{wood2013}. The district is accounted for via a varying intercept. - -\begin{Sinput} -fit_rent1 <- brm(rentsqm ~ t2(area, yearc) + (1|district), data = rent99, - chains = 2, cores = 2) -\end{Sinput} -We fit the model using just two chains (instead of the default of four chains) on two processor cores to reduce the model fitting time for the purpose of the present paper. In general, using the default option of four chains (or more) is recommended. - -\begin{Sinput} -summary(fit_rent1) -\end{Sinput} - -\begin{Sinput} - Family: gaussian(identity) -Formula: rentsqm ~ t2(area, yearc) + (1 | district) - Data: rent99 (Number of observations: 3082) -Samples: 2 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 2000 - ICs: LOO = NA; WAIC = NA; R2 = NA - -Smooth Terms: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sds(t2areayearc_1) 4.93 2.32 1.61 10.77 1546 1.00 -sds(t2areayearc_2) 5.78 2.87 1.58 13.15 1175 1.00 -sds(t2areayearc_3) 8.09 3.19 3.66 16.22 1418 1.00 - -Group-Level Effects: -~district (Number of levels: 336) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 0.60 0.06 0.48 0.73 494 1.01 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept 7.80 0.11 7.59 8.02 2000 1.00 -t2areayearc_1 -1.00 0.09 -1.15 -0.83 2000 1.00 -t2areayearc_2 0.75 0.17 0.43 1.09 2000 1.00 -t2areayearc_3 -0.07 0.16 -0.40 0.24 1579 1.00 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sigma 1.95 0.03 1.90 2.01 2000 1.00 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} -For models including splines, the output of \code{summary} is not tremendously helpful, but we get at least some information. Firstly, the credible intervals of the standard deviations of the coefficients forming the splines (under \code{'Smooth Terms'}) are sufficiently far away from zero to indicate non-linearity in the (combined) effect of \code{area} and \code{yearc}. Secondly, even after controlling for these predictors, districts still vary with respect to rent per square meter by a sizable amount as visible under \code{'Group-Level Effects'} in the output. To further understand the effect of the predictor, we apply graphical methods: - -\begin{Sinput} -conditional_effects(fit_rent1, surface = TRUE) -\end{Sinput} -In Figure \ref{me_rent1}, the conditional effects of both predictors are displayed, while the respective other predictor is fixed at its mean. In Figure \ref{me_rent2}, the combined effect is shown, clearly demonstrating an interaction between the variables. In particular, housing rents appear to be highest for small and relatively new apartments. - -\begin{figure}[ht] - \centering - \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent1.pdf} - \caption{Conditional effects plots of the \code{fit\_rent1} model for single predictors.} - \label{me_rent1} -\end{figure} - -\begin{figure}[ht] - \centering - \includegraphics[width=0.7\textwidth,keepaspectratio]{me_rent2.pdf} - \caption{Surface plot of the \code{fit\_rent1} model for the combined effect of \code{area} and \code{yearc}.} - \label{me_rent2} -\end{figure} - -In the above example, we only considered the mean of the response distribution to vary by \code{area} and \code{yearc}, but this my not necessarily reasonable assumption, as the variation of the response might vary with these variables as well. Accordingly, we fit splines and effects of district for both the location and the scale parameter, which is called \code{sigma} in Gaussian models. - -\begin{Sinput} -bform <- bf(rentsqm ~ t2(area, yearc) + (1|ID1|district), - sigma ~ t2(area, yearc) + (1|ID1|district)) -fit_rent2 <- brm(bform, data = rent99, chains = 2, cores = 2) -\end{Sinput} -If not otherwise specified, \code{sigma} is predicted on the log-scale to ensure it is positive no matter how the predictor term looks like. Instead of \code{(1|district)} as in the previous model, we now use \code{(1|ID1|district)} in both formulas. This results in modeling the varying intercepts of both model parts as correlated (see the description of the ID-syntax above). The group-level part of the \code{summary} output looks as follows: - -\begin{Sinput} -Group-Level Effects: -~district (Number of levels: 336) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 0.60 0.06 0.49 0.73 744 1.00 -sd(sigma_Intercept) 0.11 0.02 0.06 0.15 751 1.00 -cor(Intercept,sigma_Intercept) 0.72 0.17 0.35 0.98 648 1.00 -\end{Sinput} -As visible from the positive correlation of the intercepts, districts with overall higher rent per square meter have higher variation at the same time. Lastly, we want to turn our attention to the splines. While \code{conditional\_effects} is used to visualize effects of predictors on the expected response, \code{conditional\_smooths} is used to show just the spline parts of the model: - -\begin{Sinput} -conditional_smooths(fit_rent2) -\end{Sinput} -The plot on the left-hand side of Figure \ref{me_rent3} resembles the one in Figure \ref{me_rent2}, but the scale is different since only the spline is plotted. The right-hand side of \ref{me_rent3} shows the spline for \code{sigma}. Since we apply the log-link on \code{sigma} by default the spline is on the log-scale as well. As visible in the plot, the variation in the rent per square meter is highest for relatively small and old apartments, while the variation is smallest for medium to large apartments build around the 1960s. - -\begin{figure}[ht] - \centering - \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent3.pdf} - \caption{Plots showing the smooth terms of the \code{fit\_rent2} model.} - \label{me_rent3} -\end{figure} - - -\subsection{Example 3: Insurance loss payments} - -On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see \url{http://www.magesblog.com/2015/11/loss-developments-via-growth-curves-and.html}). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows: - -$$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ -$$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ - -The cumulative insurance payments $cum$ will grow over time, and we model this dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters $\theta$ and $\omega$, which are responsible for the growth of the cumulative loss and are for now assumed to be the same across years. We load the data - -\begin{Sinput} -url <- paste0("https://raw.githubusercontent.com/mages/", - "diesunddas/master/Data/ClarkTriangle.csv") -loss <- read.csv(url) -head(loss) -\end{Sinput} - -\begin{Sinput} - AY dev cum -1 1991 6 357.848 -2 1991 18 1124.788 -3 1991 30 1735.330 -4 1991 42 2182.708 -5 1991 54 2745.596 -6 1991 66 3319.994 -\end{Sinput} -and translate the proposed model into a non-linear \pkg{brms} model. - -\begin{Sinput} -nlform <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), - ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE) - -nlprior <- c(prior(normal(5000, 1000), nlpar = "ult"), - prior(normal(1, 2), nlpar = "omega"), - prior(normal(45, 10), nlpar = "theta")) - -fit_loss1 <- brm(formula = nlform, data = loss, family = gaussian(), - prior = nlprior, control = list(adapt_delta = 0.9)) -\end{Sinput} - -In the above functions calls, quite a few things are going on. The formulas are wrapped in \code{bf} to combine them into one object. The first formula specifies the non-linear model. We set argument \code{nl = TRUE} so that \pkg{brms} takes this formula literally and instead of using standard R formula parsing. We specify one additional formula per non-linear parameter (a) to clarify what variables are covariates and what are parameters and (b) to specify the predictor term for the parameters. We estimate a group-level effect of accident year (variable \code{AY}) for the ultimate loss \code{ult}. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in the case of \code{ult}, contains only a varying intercept for year. Both \code{omega} and \code{theta} are assumed to be constant across observations so we just fit a population-level intercept. - -Priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. Otherwise, we may observe that different Markov chains converge to different parameter regions as multiple posterior distribution are equally plausible. Setting prior distributions is a difficult task especially in non-linear models. It requires some experience and knowledge both about the model that is being fitted and about the data at hand. Additionally, there is more to keep in mind to optimize the sampler's performance: Firstly, using non- or weakly informative priors in non-linear models often leads to problems even if the model is generally identified. For instance, if a zero-centered and reasonably wide prior such as \code{normal(0, 10000)} it set on \code{ult}, there is little information about \code{theta} and \code{omega} for samples of \code{ult} being close to zero, which may lead to convergence problems. Secondly, Stan works best when parameters are roughly on the same order of magnitude \citep{stan2017}. In the present example, \code{ult} is of three orders larger than \code{omega}. Still, the sampler seems to work quite well, but this may not be true for other models. One solution is to rescale parameters before model fitting. For instance, for the present example, one could have downscaled \code{ult} by replacing it with \code{ult * 1000} and correspondingly the \code{normal(5000, 1000)} prior with \code{normal(5, 1)}. - -In the \code{control} argument we increase \code{adapt\_delta} to get rid of a few divergent transitions (cf. \citeauthor{stan2017}, \citeyear{stan2017}; \citeauthor{brms1}, \citeyear{brms1}). Again the model is summarized via - -\begin{Sinput} -summary(fit_loss1) -\end{Sinput} - -\begin{Sinput} - Family: gaussian (identity) -Formula: cum ~ ult * (1 - exp(-(dev / theta)^omega)) - ult ~ 1 + (1 | AY) - omega ~ 1 - theta ~ 1 - Data: loss (Number of observations: 55) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: Not computed - -Group-Level Effects: -~AY (Number of levels: 10) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(ult_Intercept) 745.74 231.31 421.05 1306.04 916 1 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -ult_Intercept 5273.70 292.34 4707.11 5852.28 798 1 -omega_Intercept 1.34 0.05 1.24 1.43 2167 1 -theta_Intercept 46.07 2.09 42.38 50.57 1896 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sigma 139.93 15.52 113.6 175.33 2358 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} -as well as - -\begin{Sinput} -conditional_effects(fit_loss1) -\end{Sinput} -\begin{figure}[ht] - \centering - \includegraphics[width=0.7\textwidth,keepaspectratio]{me_loss1.pdf} - \caption{Conditional effects plots of the \code{fit\_loss1} model.} - \label{me_loss1} -\end{figure} -(see Figure \ref{me_loss1}). We can also visualize the cumulative insurance loss over time separately for each year. - -\begin{Sinput} -conditions <- data.frame(AY = unique(loss$AY)) -rownames(conditions) <- unique(loss$AY) -me_year <- conditional_effects(fit_loss1, conditions = conditions, - re_formula = NULL, method = "predict") -plot(me_year, ncol = 5, points = TRUE) -\end{Sinput} -\begin{figure}[ht] - \centering - \includegraphics[width=0.99\textwidth,keepaspectratio]{me_loss1_year.pdf} - \caption{Conditional effects plots of the \code{fit\_loss1} model separately for each accident year.} - \label{me_loss1_year} -\end{figure} -(see Figure \ref{me_loss1_year}). It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. - -In the above model, we considered \code{omega} and \code{delta} to be constant across years, which may not necessarily be true. We can easily investigate this by fitting varying intercepts for all three non-linear parameters also estimating group-level correlation using the above introduced \code{ID} syntax. - -\begin{Sinput} -nlform2 <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), - ult ~ 1 + (1|ID1|AY), omega ~ 1 + (1|ID1|AY), - theta ~ 1 + (1|ID1|AY), nl = TRUE) - -fit_loss2 <- update(fit_loss1, formula = nlform2, - control = list(adapt_delta = 0.90)) -\end{Sinput} -We could have also specified all predictor terms more conveniently within one formula as -\begin{Sinput} -ult + omega + theta ~ 1 + (1|ID1|AY) -\end{Sinput} -because the structure of the predictor terms is identical. To compare model fit, we perform leave-one-out cross-validation. - -\begin{Sinput} -LOO(fit_loss1, fit_loss2) -\end{Sinput} - -\begin{Sinput} - LOOIC SE -fit_loss1 715.44 19.24 -fit_loss2 720.60 19.85 -fit_loss1 - fit_loss2 -5.15 5.34 -\end{Sinput} - -Since smaller values indicate better expected out-of-sample predictions and thus better model fit, the simpler model that only has a varying intercept over parameter \code{ult} is preferred. This may not be overly surprising, given that three varying intercepts as well as three group-level correlations are probably overkill for data containing only 55 observations. Nevertheless, it nicely demonstrates how to apply the \code{ID} syntax in practice. More examples of non-linear models can be found in \code{vignette("brms\_nonlinear")}. - -\subsection{Example 4: Performance of school children} - -Suppose that we want to predict the performance of students in the final exams at the end of the year. There are many variables to consider, but one important factor will clearly be school membership. Schools might differ in the ratio of teachers and students, the general quality of teaching, in the cognitive ability of the students they draw, or other factors we are not aware of that induce dependency among students of the same school. Thus, it is advised to apply a multilevel modeling techniques including school membership as a group-level term. Of course, we should account for class membership and other levels of the educational hierarchy as well, but for the purpose of the present example, we will focus on schools only. Usually, accounting for school membership is pretty-straight forward by simply adding a varying intercept to the formula: \code{(1 | school)}. However, a non-negligible number of students might change schools during the year. This would result in a situation where one student is a member of multiple schools and so we need a multi-membership model. Setting up such a model not only requires information on the different schools students attend during the year, but also the amount of time spend at each school. The latter can be used to weight the influence each school has on its students, since more time attending a school will likely result in greater influence. For now, let us assume that students change schools maximally once a year and spend equal time at each school. We will later see how to relax these assumptions. - -Real educational data are usually relatively large and complex so that we simulate our own data for the purpose of this tutorial paper. We simulate 10 schools and 1000 students, with each school having the same expected number of 100 students. We model 10\% of students as changing schools. - -\begin{Sinput} -data_mm <- sim_multi_mem(nschools = 10, nstudents = 1000, change = 0.1) -head(data_mm) -\end{Sinput} - -\begin{Sinput} - s1 s2 w1 w2 y -1 8 9 0.5 0.5 16.27422 -2 10 9 0.5 0.5 18.71387 -3 5 3 0.5 0.5 23.65319 -4 3 5 0.5 0.5 22.35204 -5 5 3 0.5 0.5 16.38019 -6 10 6 0.5 0.5 17.63494 -\end{Sinput} -The code of function \code{sim\_multi\_mem} can be found in the online supplement of the present paper. For reasons of better illustration, students changing schools appear in the first rows of the data. Data of students being only at a single school looks as follows: - -\begin{Sinput} -data_mm[101:106, ] -\end{Sinput} - -\begin{Sinput} - s1 s2 w1 w2 y -101 2 2 0.5 0.5 27.247851 -102 9 9 0.5 0.5 24.041427 -103 4 4 0.5 0.5 12.575001 -104 2 2 0.5 0.5 21.203644 -105 4 4 0.5 0.5 12.856166 -106 4 4 0.5 0.5 9.740174 -\end{Sinput} -Thus, school variables are identical, but we still have to specify both in order to pass the data appropriately. Incorporating no other predictors into the model for simplicity, a multi-membership model is specified as - -\begin{Sinput} -fit_mm <- brm(y ~ 1 + (1 | mm(s1, s2)), data = data_mm) -\end{Sinput} -The only new syntax element is that multiple grouping factors (\code{s1} and \code{s2}) are wrapped in \code{mm}. Everything else remains exactly the same. Note that we did not specify the relative weights of schools for each student and thus, by default, equal weights are assumed. - -\begin{Sinput} -summary(fit_mm) -\end{Sinput} - -\begin{Sinput} - Family: gaussian (identity) -Formula: y ~ 1 + (1 | mm(s1, s2)) - Data: data_mm (Number of observations: 1000) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: Not computed - -Group-Level Effects: -~mms1s2 (Number of levels: 10) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 2.76 0.82 1.69 4.74 682 1.01 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept 19 0.93 17.06 20.8 610 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sigma 3.58 0.08 3.43 3.75 2117 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} - -With regard to the assumptions made in the above example, it is unlikely that all children who change schools stay in both schools equally long. To relax this assumption, we have to specify weights. First, we amend the simulated data to contain non-equal weights for students changing schools. For all other students, weighting does of course not matter as they stay in the same school anyway. - -\begin{Sinput} -data_mm[1:100, "w1"] <- runif(100, 0, 1) -data_mm[1:100, "w2"] <- 1 - data_mm[1:100, "w1"] -head(data_mm) -\end{Sinput} - -\begin{Sinput} - s1 s2 w1 w2 y -1 8 9 0.3403258 0.65967423 16.27422 -2 10 9 0.1771435 0.82285652 18.71387 -3 5 3 0.9059811 0.09401892 23.65319 -4 3 5 0.4432007 0.55679930 22.35204 -5 5 3 0.8052026 0.19479738 16.38019 -6 10 6 0.5610243 0.43897567 17.63494 -\end{Sinput} -Incorporating these weights into the model is straight forward. - -\begin{Sinput} -fit_mm2 <- brm(y ~ 1 + (1 | mm(s1, s2, weights = cbind(w1, w2))), - data = data_mm) -\end{Sinput} -The summary output is similar to the previous, so we do not show it here. The second assumption that students change schools only once a year, may also easily be relaxed by providing more than two grouping factors, say, \code{mm(s1, s2, s3)}. - -\section{Comparison between packages} - -Over the years, many R packages have been developed that implement MLMs, each being more or less general in their supported models. In \cite{brms1}, I compared \pkg{brms} with \pkg{lme4} \citep{bates2015}, \pkg{MCMCglmm} \citep{hadfield2010}, \pkg{rstanarm} \citep{rstanarm2017}, and \pkg{rethinking} \citep{mcelreath2017}. Since then, quite a few new features have been added in particular to \pkg{brms} and \pkg{rstanarm}. Accordingly, in the present paper, I will update these comparisons, but focus on \pkg{brms}, \pkg{rstanarm}, and \pkg{MCMCglmm} as the possibly most important R packages implementing Bayesian MLMs. While \pkg{brms} and \pkg{rstanarm} are both based on the probabilistic programming language \pkg{Stan}, \pkg{MCMCglmm} implements its own custom MCMC algorithm. Modeling options and other important information of these packages are summarized in Table~\ref{comparison} and will be discussed in detail below. - -Regarding general model classes, all three packages support the most common types such as linear, count data and certain survival models. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. Additionally, they offer support for zero-inflated and hurdle models to account for access zeros in the data (see Example 1 above). For survival / time-to-event models, \pkg{rstanarm} offers great flexibility via the \code{stan\_jm} function, which allows for complex association structures between time-to-event data and one or more models of longitudinal covariates (for details see \url{https://cran.r-project.org/web/packages/rstanarm/vignettes/jm.html}). Model classes currently specific to \pkg{brms} are robust linear models using Student's t-distribution (family \code{student}) as well as response times models via the exponentially modified Gaussian (family \code{exgaussian}) distribution or the Wiener diffusion model (family \code{wiener}). The latter allows to simultaneously model dichotomous decisions and their corresponding response times (for a detailed example see \url{http://singmann.org/wiener-model-analysis-with-brms-part-i/}). - -All three packages offer many additional modeling options, with \pkg{brms} currently having the greatest flexibility (see Table~\ref{comparison} for a summary). Moreover, the packages differ in the general framework, in which they are implemented: \pkg{brms} and \pkg{MCMCglmm} each come with a single model fitting function (\code{brm} and \code{MCMCglmm} respectively), through which all of their models can be specified. Further, their framework allows to seamlessly combine most modeling options with each other in the same model. In contrast, the approach of \pkg{rstanarm} is to emulate existing functions of other packages. This has the advantage of an easier transition between classical and Bayesian models, since the syntax used to specify models stays the same. However, it comes with the main disadvantage that many modeling options cannot be used in combination within the same model. - -Information criteria are available in all three packages. The advantages of WAIC and LOO implemented in \pkg{brms} and \pkg{rstanarm}, are their less restrictive assumptions and that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the packages, \pkg{brms} offers a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, I believe that the way priors are specified in \pkg{brms} is more intuitive as it is directly evident what prior is actually applied. In \pkg{brms}, Bayes factors are available both via Savage-Dickey ratios \citep{wagenmakers2010} and bridge-sampling \citep{bridgesampling2017}, while \pkg{rstanarm} allows for the latter option. For a detailed comparison with respect to sampling efficiency, see \cite{brms1}. - - -\begin{table}[hbtp] -\centering -\begin{tabular}{llll} - & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline -\\ [-1.5ex] -\parbox{6cm}{\textbf{Model classes}} & & & \\ [1ex] -Linear models & yes & yes & yes \\ -Robust linear models & yes & no & no \\ -Count data models & yes & yes & yes \\ -Survival models & yes & yes$^1$ & yes \\ -Response times models & yes & no & no \\ -Beta models & yes & yes & no \\ -Categorical models & yes & yes$^2$ & yes \\ -Multinomial models & no & no & yes \\ -Ordinal models & various & cumulative$^2$ & cumulative \\ -Zero-inflated and hurdle models & yes & no & yes \\ \hline -\\ [-1.5ex] -\parbox{5cm}{\textbf{Modeling options}} & & & \\ [1ex] -Variable link functions & various & various & no \\ -Multilevel structures & yes & yes & yes \\ -Multi-membership & yes & no & yes \\ -Multivariate responses & yes & yes$^3$ & yes \\ -Non-linear predictors & yes & limited$^4$ & no \\ -Distributional regression & yes & no & no \\ -Finite mixtures & yes & no & no \\ -Splines (additive models) & yes & yes & yes \\ -Gaussian Processes & yes & no & no \\ -Temporal autocorrelation & yes & yes$^{2, 5}$ & no \\ -Spatial autocorrelation & yes & yes$^{2, 5}$ & no \\ -Monotonic effects & yes & no & no \\ -Category specific effects & yes & no & no \\ -Measurement error & yes & no & no \\ -Weights & yes & yes & no \\ -Offset & yes & yes & using priors \\ -Censored data & yes & yes$^1$ & yes \\ -Truncated data & yes & no & no \\ -Customized covariances & yes & no & yes \\ -Missing value imputation & no & no & no \\ \hline -\\ [-1.5ex] -\textbf{Bayesian specifics} & & & \\ [1ex] -Population-level priors & flexible & flexible & normal \\ -Group-level priors & normal & normal & normal \\ -Covariance priors & flexible & restricted$^6$ & restricted$^7$ \\ -Bayes factors & yes & yes$^8$ & no \\ -Parallelization & yes & yes & no \\ \hline -\\ [-1.5ex] -\textbf{Other} & & & \\ [1ex] -Estimator & HMC, NUTS & HMC, NUTS & MH, Gibbs$^9$ \\ -Information criterion & WAIC, LOO & WAIC, LOO & DIC \\ -C++ compiler required & yes & no & no \\ \hline -\end{tabular} -\caption{ -Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{MCMCglmm} packages. Notes: (1) Advanced functionality available via \code{stan\_jm}. (2) No group-level terms and related functionality allowed. (3) Cannot be combined with other modeling options such as splines. (4) Functionality limited to linear Gaussian models and certein pre-specified non-linear functions. (5) Functionality available only on GitHub branches (\url{https://github.com/stan-dev/rstanarm}). (6) For details see \cite{hadfield2010}. (7) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}. (8) Available via the \pkg{bridgesampling} package \citep{bridgesampling2017}. (9) Estimator consists of a combination of both algorithms. -} -\label{comparison} -\end{table} - -\section{Conclusion} - -The present paper is meant to introduce R users and developers to the extended \pkg{lme4} formula syntax applied in \pkg{brms}. Only a subset of modeling options were discussed in detail, which ensured the paper was not too broad. For some of the more basic models that \pkg{brms} can fit, see \citet{brms1}. Many more examples can be found in the growing number of vignettes accompanying the package (see \code{vignette(package = "brms")} for an overview). - -To date, \pkg{brms} is already one of the most flexible R packages when it comes to regression modeling. However, for the future, there are quite a few more features that I am planning to implement (see \url{https://github.com/paul-buerkner/brms/issues} for the current list of issues). In addition to smaller, incremental updates, I have two specific features in mind: (1) latent variables estimated via confirmatory factor analysis and (2) missing value imputation. I receive ideas and suggestions from users almost every day -- for which I am always grateful -- and so the list of features that will be implemented in the proceeding versions of \pkg{brms} will continue to grow. - -\section*{Acknowledgments} - -First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language Stan, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Furthermore, I want to thank Heinz Holling, Donald Williams and Ruben Arslan for valuable comments on earlier versions of the paper. I also would like to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. - -\bibliography{citations_multilevel} - -\end{document} +\documentclass[article, nojss]{jss} + +%\VignetteIndexEntry{Multilevel Models with brms} +%\VignetteEngine{R.rsp::tex} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% almost as usual +\author{Paul-Christian B\"urkner} +\title{Advanced Bayesian Multilevel Modeling with the \proglang{R} Package \pkg{brms}} + +%% for pretty printing and a nice hypersummary also set: +\Plainauthor{Paul-Christian B\"urkner} %% comma-separated +\Plaintitle{Advanced Bayesian Multilevel Modeling with the R Package brms} %% without formatting +\Shorttitle{Advanced Bayesian Multilevel Modeling with \pkg{brms}} %% a short title (if necessary) + +%% an abstract and keywords +\Abstract{ + The \pkg{brms} package allows R users to easily specify a wide range of Bayesian single-level and multilevel models, which are fitted with the probabilistic programming language \proglang{Stan} behind the scenes. Several response distributions are supported, of which all parameters (e.g., location, scale, and shape) can be predicted at the same time thus allowing for distributional regression. Non-linear relationships may be specified using non-linear predictor terms or semi-parametric approaches such as splines or Gaussian processes. Multivariate models, in which each response variable can be predicted using the above mentioned options, can be fitted as well. To make all of these modeling options possible in a multilevel framework, \pkg{brms} provides an intuitive and powerful formula syntax, which extends the well known formula syntax of \pkg{lme4}. The purpose of the present paper is to introduce this syntax in detail and to demonstrate its usefulness with four examples, each showing other relevant aspects of the syntax. If you use \pkg{brms}, please cite this article as published in the R Journal \citep{brms2}. +} +\Keywords{Bayesian inference, multilevel models, distributional regression, MCMC, \proglang{Stan}, \proglang{R}} +\Plainkeywords{Bayesian inference, multilevel models, distributional regression, MCMC, Stan, R} %% without formatting +%% at least one keyword must be supplied + +%% publication information +%% NOTE: Typically, this can be left commented and will be filled out by the technical editor +%% \Volume{50} +%% \Issue{9} +%% \Month{June} +%% \Year{2012} +%% \Submitdate{2012-06-04} +%% \Acceptdate{2012-06-04} + +%% The address of (at least) one author should be given +%% in the following format: +\Address{ + Paul-Christian B\"urkner\\ + E-mail: \email{paul.buerkner@gmail.com}\\ + URL: \url{https://paul-buerkner.github.io} +} +%% It is also possible to add a telephone and fax number +%% before the e-mail in the following format: +%% Telephone: +43/512/507-7103 +%% Fax: +43/512/507-2851 + + +%% for those who use Sweave please include the following line (with % symbols): +%% need no \usepackage{Sweave.sty} + +%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{document} + +%% include your article here, just as usual +%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. + +\section{Introduction} + +Multilevel models (MLMs) offer great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for R have been developed to fit MLMs. Usually, however, the functionality of these implementations is limited insofar as it is only possible to predict the mean of the response distribution. Other parameters of the response distribution, such as the residual standard deviation in linear models, are assumed constant across observations, which may be violated in many applications. Accordingly, it is desirable to allow for prediction of \emph{all} response parameters at the same time. Models doing exactly that are often referred to as \emph{distributional models} or more verbosely \emph{models for location, scale and shape} \citep{rigby2005}. Another limitation of basic MLMs is that they only allow for linear predictor terms. While linear predictor terms already offer good flexibility, they are of limited use when relationships are inherently non-linear. Such non-linearity can be handled in at least two ways: (1) by fully specifying a non-linear predictor term with corresponding parameters each of which can be predicted using MLMs \citep{lindstrom1990}, or (2) estimating the form of the non-linear relationship on the fly using splines \citep{wood2004} or Gaussian processes \citep{rasmussen2006}. The former are often simply called \emph{non-linear models}, while models applying splines are referred to as \emph{generalized additive models} (GAMs; \citeauthor{hastie1990}, \citeyear{hastie1990}). + +Combining all of these modeling options into one framework is a complex task, both conceptually and with regard to model fitting. Maximum likelihood methods, which are typically applied in classical 'frequentist' statistics, can reach their limits at some point and fully Bayesian methods become the go-to solutions to fit such complex models \citep{gelman2014}. In addition to being more flexible, the Bayesian framework comes with other advantages, for instance, the ability to derive probability statements for every quantity of interest or explicitly incorporating prior knowledge about parameters into the model. The former is particularly relevant in non-linear models, for which classical approaches struggle more often than not in propagating all the uncertainty in the parameter estimates to non-linear functions such as out-of-sample predictions. + +Possibly the most powerful program for performing full Bayesian inference available to date is Stan \citep{stanM2017, carpenter2017}. It implements Hamiltonian Monte Carlo \citep{duane1987, neal2011, betancourt2014} and its extension, the No-U-Turn (NUTS) Sampler \citep{hoffman2014}. These algorithms converge much more quickly than other Markov-Chain Monte-Carlo (MCMC) algorithms especially for high-dimensional models \citep{hoffman2014, betancourt2014, betancourt2017}. An excellent non-mathematical introduction to Hamiltonian Monte Carlo can be found in \citet{betancourt2017}. + +Stan comes with its own programming language, allowing for great modeling flexibility \cite{stanM2017, carpenter2017}). Many researchers may still be hesitent to use Stan directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error-prone process even for researchers familiar with Bayesian inference. The \pkg{brms} package \citep{brms1}, presented in this paper, aims to remove these hurdles for a wide range of regression models by allowing the user to benefit from the merits of Stan by using extended \pkg{lme4}-like \citep{bates2015} formula syntax, with which many R users are familiar with. It offers much more than writing efficient and human-readable Stan code: \pkg{brms} comes with many post-processing and visualization functions, for instance to perform posterior predictive checks, leave-one-out cross-validation, visualization of estimated effects, and prediction of new data. The overarching aim is to have one general framework for regression modeling, which offers everything required to successfully apply regression models to complex data. To date, it already replaces and extends the functionality of dozens of other R packages, each of which is restricted to specific regression models\footnote{Unfortunately, due to the implementation via Stan, it is not easily possible for users to define their own response distributions and run them via \pkg{brms}. If you feel that a response distribution is missing in \pkg{brms}, please open an issue on GitHub (\url{https://github.com/paul-buerkner/brms}).}. + +The purpose of the present article is to provide an introduction of the advanced multilevel formula syntax implemented in \pkg{brms}, which allows to fit a wide and growing range of non-linear distributional multilevel models. A general overview of the package is already given in \citet{brms1}. Accordingly, the present article focuses on more recent developments. We begin by explaining the underlying structure of distributional models. Next, the formula syntax of \pkg{lme4} and its extensions implemented in \pkg{brms} are explained. Four examples that demonstrate the use of the new syntax are discussed in detail. Afterwards, the functionality of \pkg{brms} is compared with that of \pkg{rstanarm} \citep{rstanarm2017} and \pkg{MCMCglmm} \citep{hadfield2010}. We end by describing future plans for extending the package. + +\section{Model description} +\label{model} + +The core of models implemented in \pkg{brms} is the prediction of the response $y$ through predicting all parameters $\theta_p$ of the response distribution $D$, which is also called the model \code{family} in many R packages. We write +$$y_i \sim D(\theta_{1i}, \theta_{2i}, ...)$$ +to stress the dependency on the $i\textsuperscript{th}$ observation. Every parameter $\theta_p$ may be regressed on its own predictor term $\eta_p$ transformed by the inverse link function $f_p$ that is $\theta_{pi} = f_p(\eta_{pi})$\footnote{A parameter can also be assumed constant across observations so that a linear predictor is not required.}. Such models are typically refered to as \emph{distributional models}\footnote{The models described in \citet{brms1} are a sub-class of the here described models.}. Details about the parameterization of each \code{family} are given in \code{vignette("brms\_families")}. + +Suppressing the index $p$ for simplicity, a predictor term $\eta$ can generally be written as +$$ +\eta = \mathbf{X} \beta + \mathbf{Z} u + \sum_{k = 1}^K s_k(x_k) +$$ +In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The terms $s_k(x_k)$ symbolize optional smooth functions of unspecified form based on covariates $x_k$ fitted via splines (see \citet{wood2011} for the underlying implementation in the \pkg{mgcv} package) or Gaussian processes \citep{williams1996}. The response $y$ as well as $\mathbf{X}$, $\mathbf{Z}$, and $x_k$ make up the data, whereas $\beta$, $u$, and the smooth functions $s_k$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects, but I avoid theses terms following the recommendations of \citet{gelmanMLM2006}. Details about prior distributions of $\beta$ and $u$ can be found in \citet{brms1} and under \code{help("set\_prior")}. + +As an alternative to the strictly additive formulation described above, predictor terms may also have any form specifiable in Stan. We call it a \emph{non-linear} predictor and write +$$\eta = f(c_1, c_2, ..., \phi_1, \phi_2, ...)$$ +The structure of the function $f$ is given by the user, $c_r$ are known or observed covariates, and $\phi_s$ are non-linear parameters each having its own linear predictor term $\eta_{\phi_s}$ of the form specified above. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves. A frequentist implementation of such models, which inspired the non-linear syntax in \pkg{brms}, can be found in the \pkg{nlme} package \citep{nlme2016}. + +\section{Extended multilevel formula syntax} +\label{formula_syntax} + +The formula syntax applied in \pkg{brms} builds upon the syntax of the R package \pkg{lme4} \citep{bates2015}. First, we will briefly explain the \pkg{lme4} syntax used to specify multilevel models and then introduce certain extensions that allow to specify much more complicated models in \pkg{brms}. An \pkg{lme4} formula has the general form + +\begin{Sinput} +response ~ pterms + (gterms | group) +\end{Sinput} +The \code{pterms} part contains the population-level effects that are assumed to be the same across obervations. The \code{gterms} part contains so called group-level effects that are assumed to vary accross grouping variables specified in \code{group}. Multiple grouping factors each with multiple group-level effects are possible. Usually, \code{group} contains only a single variable name pointing to a factor, but you may also use \code{g1:g2} or \code{g1/g2}, if both \code{g1} and \code{g2} are suitable grouping factors. The \code{:} operator creates a new grouping factor that consists of the combined levels of \code{g1} and \code{g2} (you could think of this as pasting the levels of both factors together). The \code{/} operator indicates nested grouping structures and expands one grouping factor into two or more when using multiple \code{/} within one term. If, for instance, you write \code{(1 | g1/g2)}, it will be expanded to \code{(1 | g1) + (1 | g1:g2)}. Instead of \code{|} you may use \code{||} in grouping terms to prevent group-level correlations from being modeled. This may be useful in particular when modeling so many group-level effects that convergence of the fitting algorithms becomes an issue due to model complexity. One limitation of the \code{||} operator in \pkg{lme4} is that it only splits up terms so that columns of the design matrix originating from the same term are still modeled as correlated (e.g., when coding a categorical predictor; see the \code{mixed} function of the \pkg{afex} package by \citet{afex2015} for a way to avoid this behavior). + +While intuitive and visually appealing, the classic \pkg{lme4} syntax is not flexible enough to allow for specifying the more complex models supported by \pkg{brms}. In non-linear or distributional models, for instance, multiple parameters are predicted, each having their own population and group-level effects. Hence, multiple formulas are necessary to specify such models\footnote{Actually, it is possible to specify multiple model parts within one formula using interactions terms for instance as implemented in \pkg{MCMCglmm} \citep{hadfield2010}. However, this syntax is limited in flexibility and requires a rather deep understanding of the way R parses formulas, thus often being confusing to users.}. Then, however, specifying group-level effects of the same grouping factor to be correlated \emph{across} formulas becomes complicated. The solution implemented in \pkg{brms} (and currently unique to it) is to expand the \code{|} operator into \code{||}, where \code{} can be any value. Group-level terms with the same \code{ID} will then be modeled as correlated if they share same grouping factor(s)\footnote{It might even be further extended to \code{|fun()|}, where \code{fun} defines the type of correlation structure, defaulting to unstructured that is estimating the full correlation matrix. The \code{fun} argument is not yet supported by \pkg{brms} but could be supported in the future if other correlation structures, such as compound symmetry or Toeplitz, turn out to have reasonable practical applications and effective implementations in Stan.}. For instance, if the terms \code{(x1|ID|g1)} and \code{(x2|ID|g1)} appear somewhere in the same or different formulas passed to \pkg{brms}, they will be modeled as correlated. + +Further extensions of the classical \pkg{lme4} syntax refer to the \code{group} part. It is rather limited in its flexibility since only variable names combined by \code{:} or \code{/} are supported. We propose two extensions of this syntax: Firstly, \code{group} can generally be split up in its terms so that, say, \code{(1 | g1 + g2)} is expanded to \code{(1 | g1) + (1 | g2)}. This is fully consistent with the way \code{/} is handled so it provides a natural generalization to the existing syntax. Secondly, there are some special grouping structures that cannot be expressed by simply combining grouping variables. For instance, multi-membership models cannot be expressed this way. To overcome this limitation, we propose wrapping terms in \code{group} within special functions that allow specifying alternative grouping structures: \code{(gterms | fun(group))}. In \pkg{brms}, there are currently two such functions implemented, namely \code{gr} for the default behavior and \code{mm} for multi-membership terms. To be compatible with the original syntax and to keep formulas short, \code{gr} is automatically added internally if none of these functions is specified. + +While some non-linear relationships, such as quadratic relationships, can be expressed within the basic R formula syntax, other more complicated ones cannot. For this reason, it is possible in \pkg{brms} to fully specify non-linear predictor terms similar to how it is done in \pkg{nlme}, but fully compatible with the extended multilevel syntax described above. Suppose, for instance, we want to model the non-linear growth curve +$$ +y = b_1 (1 - \exp(-(x / b_2)^{b_3}) +$$ +between $y$ and $x$ with parameters $b_1$, $b_2$, and $b_3$ (see Example 3 in this paper for an implementation of this model with real data). Furthermore, we want all three parameters to vary by a grouping variable $g$ and model those group-level effects as correlated. Additionally $b_1$ should be predicted by a covariate $z$. We can express this in \pkg{brms} using multiple formulas, one for the non-linear model itself and one per non-linear parameter: +\begin{Sinput} +y ~ b1 * (1 - exp(-(x / b2) ^ b3) +b1 ~ z + (1|ID|g) +b2 ~ (1|ID|g) +b3 ~ (1|ID|g) +\end{Sinput} +The first formula will not be evaluated using standard R formula parsing, but instead taken literally. In contrast, the formulas for the non-linear parameters will be evaluated in the usual way and are compatible with all terms supported by \pkg{brms}. Note that we have used the above described ID-syntax to model group-level effects as correlated across formulas. + +There are other syntax extensions implemented in \pkg{brms} that do not directly target grouping terms. Firstly, there are terms formally included in the \code{pterms} part that are handled separately. The most prominent examples are smooth terms specified through the \code{s} and \code{t2} functions of the \pkg{mgcv} package \citep{wood2011}. Other examples are category specific effects \code{cs}, monotonic effects \code{mo}, noise-free effects \code{me}, or Gaussian process terms \code{gp}. The former is explained in \citet{brms1}, while the latter three are documented in \code{help(brmsformula)}. Internally, these terms are extracted from \code{pterms} and not included in the construction of the population-level design matrix. Secondly, making use of the fact that \code{|} is unused on the left-hand side of $\sim$ in formula, additional information on the response variable may be specified via +\begin{Sinput} +response | aterms ~ +\end{Sinput} +The \code{aterms} part may contain multiple terms of the form \code{fun()} separated by \code{+} each providing special information on the response variable. This allows among others to weight observations, provide known standard errors for meta-analysis, or model censored or truncated data. +As it is not the main topic of the present paper, we refer to \code{help("brmsformula")} and \code{help("addition-terms")} for more details. + +To set up the model formulas and combine them into one object, \pkg{brms} defines the \code{brmsformula} (or short \code{bf}) function. Its output can then be passed to the \code{parse\_bf} function, which splits up the formulas in separate parts and prepares them for the generation of design matrices and related data. Other packages may re-use these functions in their own routines making it easier to offer support for the above described multilevel syntax. + +\section{Examples} + +The idea of \pkg{brms} is to provide one unified framework for multilevel regression models in R. As such, the above described formula syntax in all of its variations can be applied in combination with all response distributions supported by \pkg{brms} (currently about 35 response distributions are supported; see \code{help("brmsfamily")} and \code{vignette("brms\_families")} for an overview). + +In this section, we will discuss four examples in detail, each focusing on certain aspects of the syntax. They are chosen to provide a broad overview of the modeling options. The first is about the number of fish caught be different groups of people. It does not actually contain any multilevel structure, but helps in understanding how to set up formulas for different model parts. The second example is about housing rents in Munich. We model the data using splines and a distributional regression approach. The third example is about cumulative insurance loss payments across several years, which is fitted using a rather complex non-linear multilevel model. Finally, the fourth example is about the performance of school children, who change school during the year, thus requiring a multi-membership model. + +Despite not being covered in the four examples, there are a few more modeling options that we want to briefly describe. First, \pkg{brms} allows fitting so called phylogenetic models. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. Species are not independent as they come from the same phylogenetic tree, implying that different levels of the same grouping-factor (i.e., species) are likely correlated. There is a whole vignette dedicated to this topic, which can be found via \code{vignette("brms\_phylogenetics")}. Second, there is a canonical way to handle ordinal predictors, without falsely assuming they are either categorical or continuous. We call them monotonic effects and discuss them in \code{vignette("brms\_monotonic")}. Last but not least, it is possible to account for measurement error in both response and predictor variables. This is often ignored in applied regression modeling \citep{westfall2016}, although measurement error is very common in all scientific fields making use of observational data. There is no vignette yet covering this topic, but one will be added in the future. In the meantime, \code{help("brmsformula")} is the best place to start learning about such models as well as about other details of the \pkg{brms} formula syntax. + +\subsection{Example 1: Catching fish} + +An important application of the distributional regression framework of \pkg{brms} are so called zero-inflated and hurdle models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), the data are described as follows: ``The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.'' + +\begin{Sinput} +zinb <- read.csv("http://stats.idre.ucla.edu/stat/data/fish.csv") +zinb$camper <- factor(zinb$camper, labels = c("no", "yes")) +head(zinb) +\end{Sinput} + +\begin{Sinput} + nofish livebait camper persons child xb zg count +1 1 0 no 1 0 -0.8963146 3.0504048 0 +2 0 1 yes 1 0 -0.5583450 1.7461489 0 +3 0 1 no 1 0 -0.4017310 0.2799389 0 +4 0 1 yes 2 1 -0.9562981 -0.6015257 0 +5 0 1 no 1 0 0.4368910 0.5277091 1 +6 0 1 yes 4 2 1.3944855 -0.7075348 0 +\end{Sinput} +As predictors we choose the number of people per group, the number of children, as well as whether or not the group consists of campers. Many groups may not catch any fish just because they do not try and so we fit a zero-inflated Poisson model. For now, we assume a constant zero-inflation probability across observations. + +\begin{Sinput} +fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, + family = zero_inflated_poisson("log")) +\end{Sinput} +The model is readily summarized via + +\begin{Sinput} +summary(fit_zinb1) +\end{Sinput} + +\begin{Sinput} + Family: zero_inflated_poisson (log) +Formula: count ~ persons + child + camper + Data: zinb (Number of observations: 250) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: Not computed + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept -1.01 0.17 -1.34 -0.67 2171 1 +persons 0.87 0.04 0.79 0.96 2188 1 +child -1.36 0.09 -1.55 -1.18 1790 1 +camper 0.80 0.09 0.62 0.98 2950 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +zi 0.41 0.04 0.32 0.49 2409 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} +A graphical summary is available through + +\begin{Sinput} +conditional_effects(fit_zinb1) +\end{Sinput} +\begin{figure}[ht] + \centering + \includegraphics[width=0.99\textwidth,keepaspectratio]{me_zinb1.pdf} + \caption{Conditional effects plots of the \code{fit\_zinb1} model.} + \label{me_zinb1} +\end{figure} +(see Figure \ref{me_zinb1}). In fact, the \code{conditional\_effects} method turned out to be so powerful in visualizing effects of predictors that I am using it almost as frequently as \code{summary}. According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability \code{zi} is pretty large with a mean of 41\%. Please note that the probability of catching no fish is actually higher than 41\%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-\emph{inflation}). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here). + +Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish, since children often lack the patience required for fishing. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data. + +\begin{Sinput} +fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), + data = zinb, family = zero_inflated_poisson()) +\end{Sinput} +To transform the linear predictor of \code{zi} into a probability, \pkg{brms} applies the logit-link, which takes values within $[0, 1]$ and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors. + +\begin{Sinput} +summary(fit_zinb2) +\end{Sinput} + +\begin{Sinput} + Family: zero_inflated_poisson (log) +Formula: count ~ persons + child + camper + zi ~ child + Data: zinb (Number of observations: 250) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: Not computed + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept -1.07 0.18 -1.43 -0.73 2322 1 +persons 0.89 0.05 0.80 0.98 2481 1 +child -1.17 0.10 -1.37 -1.00 2615 1 +camper 0.78 0.10 0.60 0.96 3270 1 +zi_Intercept -0.95 0.27 -1.52 -0.48 2341 1 +zi_child 1.21 0.28 0.69 1.79 2492 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} + +According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your chance of catching no fish at all (as implied by the zero-inflation part), possibly because groups with more children spend less time or no time at all fishing. Comparing model fit via leave-one-out cross validation as implemented in the \pkg{loo} package \citep{loo2016, vehtari2016}. + +\begin{Sinput} +LOO(fit_zinb1, fit_zinb2) +\end{Sinput} + +\begin{Sinput} + LOOIC SE +fit_zinb1 1639.52 363.30 +fit_zinb2 1621.35 362.39 +fit_zinb1 - fit_zinb2 18.16 15.71 +\end{Sinput} +reveals that the second model using the number of children to predict both model parts has better fit. However, when considering the standard error of the \code{LOOIC} difference, improvement in model fit is apparently modest and not substantial. More examples of distributional model can be found in \code{vignette("brms\_distreg")}. + +\subsection{Example 2: Housing rents} + +In their book about regression modeling, \citet{fahrmeir2013} use an example about the housing rents in Munich from 1999. The data contains information about roughly 3000 apartments including among others the absolute rent (\code{rent}), rent per square meter (\code{rentsqm}), size of the apartment (\code{area}), construction year (\code{yearc}), and the district in Munich (\code{district}), where the apartment is located. The data can be found in the \pkg{gamlss.data} package \citep{gamlss.data}: + +\begin{Sinput} +data("rent99", package = "gamlss.data") +head(rent99) +\end{Sinput} + +\begin{Sinput} + rent rentsqm area yearc location bath kitchen cheating district +1 109.9487 4.228797 26 1918 2 0 0 0 916 +2 243.2820 8.688646 28 1918 2 0 0 1 813 +3 261.6410 8.721369 30 1918 1 0 0 1 611 +4 106.4103 3.547009 30 1918 2 0 0 0 2025 +5 133.3846 4.446154 30 1918 2 0 0 1 561 +6 339.0256 11.300851 30 1918 2 0 0 1 541 +\end{Sinput} +Here, we aim at predicting the rent per square meter with the size of the apartment as well as the construction year, while taking the district of Munich into account. As the effect of both predictors on the rent is of unknown non-linear form, we model these variables using a bivariate tensor spline \citep{wood2013}. The district is accounted for via a varying intercept. + +\begin{Sinput} +fit_rent1 <- brm(rentsqm ~ t2(area, yearc) + (1|district), data = rent99, + chains = 2, cores = 2) +\end{Sinput} +We fit the model using just two chains (instead of the default of four chains) on two processor cores to reduce the model fitting time for the purpose of the present paper. In general, using the default option of four chains (or more) is recommended. + +\begin{Sinput} +summary(fit_rent1) +\end{Sinput} + +\begin{Sinput} + Family: gaussian(identity) +Formula: rentsqm ~ t2(area, yearc) + (1 | district) + Data: rent99 (Number of observations: 3082) +Samples: 2 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 2000 + ICs: LOO = NA; WAIC = NA; R2 = NA + +Smooth Terms: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sds(t2areayearc_1) 4.93 2.32 1.61 10.77 1546 1.00 +sds(t2areayearc_2) 5.78 2.87 1.58 13.15 1175 1.00 +sds(t2areayearc_3) 8.09 3.19 3.66 16.22 1418 1.00 + +Group-Level Effects: +~district (Number of levels: 336) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 0.60 0.06 0.48 0.73 494 1.01 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept 7.80 0.11 7.59 8.02 2000 1.00 +t2areayearc_1 -1.00 0.09 -1.15 -0.83 2000 1.00 +t2areayearc_2 0.75 0.17 0.43 1.09 2000 1.00 +t2areayearc_3 -0.07 0.16 -0.40 0.24 1579 1.00 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sigma 1.95 0.03 1.90 2.01 2000 1.00 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} +For models including splines, the output of \code{summary} is not tremendously helpful, but we get at least some information. Firstly, the credible intervals of the standard deviations of the coefficients forming the splines (under \code{'Smooth Terms'}) are sufficiently far away from zero to indicate non-linearity in the (combined) effect of \code{area} and \code{yearc}. Secondly, even after controlling for these predictors, districts still vary with respect to rent per square meter by a sizable amount as visible under \code{'Group-Level Effects'} in the output. To further understand the effect of the predictor, we apply graphical methods: + +\begin{Sinput} +conditional_effects(fit_rent1, surface = TRUE) +\end{Sinput} +In Figure \ref{me_rent1}, the conditional effects of both predictors are displayed, while the respective other predictor is fixed at its mean. In Figure \ref{me_rent2}, the combined effect is shown, clearly demonstrating an interaction between the variables. In particular, housing rents appear to be highest for small and relatively new apartments. + +\begin{figure}[ht] + \centering + \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent1.pdf} + \caption{Conditional effects plots of the \code{fit\_rent1} model for single predictors.} + \label{me_rent1} +\end{figure} + +\begin{figure}[ht] + \centering + \includegraphics[width=0.7\textwidth,keepaspectratio]{me_rent2.pdf} + \caption{Surface plot of the \code{fit\_rent1} model for the combined effect of \code{area} and \code{yearc}.} + \label{me_rent2} +\end{figure} + +In the above example, we only considered the mean of the response distribution to vary by \code{area} and \code{yearc}, but this my not necessarily reasonable assumption, as the variation of the response might vary with these variables as well. Accordingly, we fit splines and effects of district for both the location and the scale parameter, which is called \code{sigma} in Gaussian models. + +\begin{Sinput} +bform <- bf(rentsqm ~ t2(area, yearc) + (1|ID1|district), + sigma ~ t2(area, yearc) + (1|ID1|district)) +fit_rent2 <- brm(bform, data = rent99, chains = 2, cores = 2) +\end{Sinput} +If not otherwise specified, \code{sigma} is predicted on the log-scale to ensure it is positive no matter how the predictor term looks like. Instead of \code{(1|district)} as in the previous model, we now use \code{(1|ID1|district)} in both formulas. This results in modeling the varying intercepts of both model parts as correlated (see the description of the ID-syntax above). The group-level part of the \code{summary} output looks as follows: + +\begin{Sinput} +Group-Level Effects: +~district (Number of levels: 336) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 0.60 0.06 0.49 0.73 744 1.00 +sd(sigma_Intercept) 0.11 0.02 0.06 0.15 751 1.00 +cor(Intercept,sigma_Intercept) 0.72 0.17 0.35 0.98 648 1.00 +\end{Sinput} +As visible from the positive correlation of the intercepts, districts with overall higher rent per square meter have higher variation at the same time. Lastly, we want to turn our attention to the splines. While \code{conditional\_effects} is used to visualize effects of predictors on the expected response, \code{conditional\_smooths} is used to show just the spline parts of the model: + +\begin{Sinput} +conditional_smooths(fit_rent2) +\end{Sinput} +The plot on the left-hand side of Figure \ref{me_rent3} resembles the one in Figure \ref{me_rent2}, but the scale is different since only the spline is plotted. The right-hand side of \ref{me_rent3} shows the spline for \code{sigma}. Since we apply the log-link on \code{sigma} by default the spline is on the log-scale as well. As visible in the plot, the variation in the rent per square meter is highest for relatively small and old apartments, while the variation is smallest for medium to large apartments build around the 1960s. + +\begin{figure}[ht] + \centering + \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent3.pdf} + \caption{Plots showing the smooth terms of the \code{fit\_rent2} model.} + \label{me_rent3} +\end{figure} + + +\subsection{Example 3: Insurance loss payments} + +On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see \url{http://www.magesblog.com/2015/11/loss-developments-via-growth-curves-and.html}). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows: + +$$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ +$$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ + +The cumulative insurance payments $cum$ will grow over time, and we model this dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters $\theta$ and $\omega$, which are responsible for the growth of the cumulative loss and are for now assumed to be the same across years. We load the data + +\begin{Sinput} +url <- paste0("https://raw.githubusercontent.com/mages/", + "diesunddas/master/Data/ClarkTriangle.csv") +loss <- read.csv(url) +head(loss) +\end{Sinput} + +\begin{Sinput} + AY dev cum +1 1991 6 357.848 +2 1991 18 1124.788 +3 1991 30 1735.330 +4 1991 42 2182.708 +5 1991 54 2745.596 +6 1991 66 3319.994 +\end{Sinput} +and translate the proposed model into a non-linear \pkg{brms} model. + +\begin{Sinput} +nlform <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), + ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE) + +nlprior <- c(prior(normal(5000, 1000), nlpar = "ult"), + prior(normal(1, 2), nlpar = "omega"), + prior(normal(45, 10), nlpar = "theta")) + +fit_loss1 <- brm(formula = nlform, data = loss, family = gaussian(), + prior = nlprior, control = list(adapt_delta = 0.9)) +\end{Sinput} + +In the above functions calls, quite a few things are going on. The formulas are wrapped in \code{bf} to combine them into one object. The first formula specifies the non-linear model. We set argument \code{nl = TRUE} so that \pkg{brms} takes this formula literally and instead of using standard R formula parsing. We specify one additional formula per non-linear parameter (a) to clarify what variables are covariates and what are parameters and (b) to specify the predictor term for the parameters. We estimate a group-level effect of accident year (variable \code{AY}) for the ultimate loss \code{ult}. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in the case of \code{ult}, contains only a varying intercept for year. Both \code{omega} and \code{theta} are assumed to be constant across observations so we just fit a population-level intercept. + +Priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. Otherwise, we may observe that different Markov chains converge to different parameter regions as multiple posterior distribution are equally plausible. Setting prior distributions is a difficult task especially in non-linear models. It requires some experience and knowledge both about the model that is being fitted and about the data at hand. Additionally, there is more to keep in mind to optimize the sampler's performance: Firstly, using non- or weakly informative priors in non-linear models often leads to problems even if the model is generally identified. For instance, if a zero-centered and reasonably wide prior such as \code{normal(0, 10000)} it set on \code{ult}, there is little information about \code{theta} and \code{omega} for samples of \code{ult} being close to zero, which may lead to convergence problems. Secondly, Stan works best when parameters are roughly on the same order of magnitude \citep{stan2017}. In the present example, \code{ult} is of three orders larger than \code{omega}. Still, the sampler seems to work quite well, but this may not be true for other models. One solution is to rescale parameters before model fitting. For instance, for the present example, one could have downscaled \code{ult} by replacing it with \code{ult * 1000} and correspondingly the \code{normal(5000, 1000)} prior with \code{normal(5, 1)}. + +In the \code{control} argument we increase \code{adapt\_delta} to get rid of a few divergent transitions (cf. \citeauthor{stan2017}, \citeyear{stan2017}; \citeauthor{brms1}, \citeyear{brms1}). Again the model is summarized via + +\begin{Sinput} +summary(fit_loss1) +\end{Sinput} + +\begin{Sinput} + Family: gaussian (identity) +Formula: cum ~ ult * (1 - exp(-(dev / theta)^omega)) + ult ~ 1 + (1 | AY) + omega ~ 1 + theta ~ 1 + Data: loss (Number of observations: 55) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: Not computed + +Group-Level Effects: +~AY (Number of levels: 10) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(ult_Intercept) 745.74 231.31 421.05 1306.04 916 1 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +ult_Intercept 5273.70 292.34 4707.11 5852.28 798 1 +omega_Intercept 1.34 0.05 1.24 1.43 2167 1 +theta_Intercept 46.07 2.09 42.38 50.57 1896 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sigma 139.93 15.52 113.6 175.33 2358 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} +as well as + +\begin{Sinput} +conditional_effects(fit_loss1) +\end{Sinput} +\begin{figure}[ht] + \centering + \includegraphics[width=0.7\textwidth,keepaspectratio]{me_loss1.pdf} + \caption{Conditional effects plots of the \code{fit\_loss1} model.} + \label{me_loss1} +\end{figure} +(see Figure \ref{me_loss1}). We can also visualize the cumulative insurance loss over time separately for each year. + +\begin{Sinput} +conditions <- data.frame(AY = unique(loss$AY)) +rownames(conditions) <- unique(loss$AY) +me_year <- conditional_effects(fit_loss1, conditions = conditions, + re_formula = NULL, method = "predict") +plot(me_year, ncol = 5, points = TRUE) +\end{Sinput} +\begin{figure}[ht] + \centering + \includegraphics[width=0.99\textwidth,keepaspectratio]{me_loss1_year.pdf} + \caption{Conditional effects plots of the \code{fit\_loss1} model separately for each accident year.} + \label{me_loss1_year} +\end{figure} +(see Figure \ref{me_loss1_year}). It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. + +In the above model, we considered \code{omega} and \code{delta} to be constant across years, which may not necessarily be true. We can easily investigate this by fitting varying intercepts for all three non-linear parameters also estimating group-level correlation using the above introduced \code{ID} syntax. + +\begin{Sinput} +nlform2 <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), + ult ~ 1 + (1|ID1|AY), omega ~ 1 + (1|ID1|AY), + theta ~ 1 + (1|ID1|AY), nl = TRUE) + +fit_loss2 <- update(fit_loss1, formula = nlform2, + control = list(adapt_delta = 0.90)) +\end{Sinput} +We could have also specified all predictor terms more conveniently within one formula as +\begin{Sinput} +ult + omega + theta ~ 1 + (1|ID1|AY) +\end{Sinput} +because the structure of the predictor terms is identical. To compare model fit, we perform leave-one-out cross-validation. + +\begin{Sinput} +LOO(fit_loss1, fit_loss2) +\end{Sinput} + +\begin{Sinput} + LOOIC SE +fit_loss1 715.44 19.24 +fit_loss2 720.60 19.85 +fit_loss1 - fit_loss2 -5.15 5.34 +\end{Sinput} + +Since smaller values indicate better expected out-of-sample predictions and thus better model fit, the simpler model that only has a varying intercept over parameter \code{ult} is preferred. This may not be overly surprising, given that three varying intercepts as well as three group-level correlations are probably overkill for data containing only 55 observations. Nevertheless, it nicely demonstrates how to apply the \code{ID} syntax in practice. More examples of non-linear models can be found in \code{vignette("brms\_nonlinear")}. + +\subsection{Example 4: Performance of school children} + +Suppose that we want to predict the performance of students in the final exams at the end of the year. There are many variables to consider, but one important factor will clearly be school membership. Schools might differ in the ratio of teachers and students, the general quality of teaching, in the cognitive ability of the students they draw, or other factors we are not aware of that induce dependency among students of the same school. Thus, it is advised to apply a multilevel modeling techniques including school membership as a group-level term. Of course, we should account for class membership and other levels of the educational hierarchy as well, but for the purpose of the present example, we will focus on schools only. Usually, accounting for school membership is pretty-straight forward by simply adding a varying intercept to the formula: \code{(1 | school)}. However, a non-negligible number of students might change schools during the year. This would result in a situation where one student is a member of multiple schools and so we need a multi-membership model. Setting up such a model not only requires information on the different schools students attend during the year, but also the amount of time spend at each school. The latter can be used to weight the influence each school has on its students, since more time attending a school will likely result in greater influence. For now, let us assume that students change schools maximally once a year and spend equal time at each school. We will later see how to relax these assumptions. + +Real educational data are usually relatively large and complex so that we simulate our own data for the purpose of this tutorial paper. We simulate 10 schools and 1000 students, with each school having the same expected number of 100 students. We model 10\% of students as changing schools. + +\begin{Sinput} +data_mm <- sim_multi_mem(nschools = 10, nstudents = 1000, change = 0.1) +head(data_mm) +\end{Sinput} + +\begin{Sinput} + s1 s2 w1 w2 y +1 8 9 0.5 0.5 16.27422 +2 10 9 0.5 0.5 18.71387 +3 5 3 0.5 0.5 23.65319 +4 3 5 0.5 0.5 22.35204 +5 5 3 0.5 0.5 16.38019 +6 10 6 0.5 0.5 17.63494 +\end{Sinput} +The code of function \code{sim\_multi\_mem} can be found in the online supplement of the present paper. For reasons of better illustration, students changing schools appear in the first rows of the data. Data of students being only at a single school looks as follows: + +\begin{Sinput} +data_mm[101:106, ] +\end{Sinput} + +\begin{Sinput} + s1 s2 w1 w2 y +101 2 2 0.5 0.5 27.247851 +102 9 9 0.5 0.5 24.041427 +103 4 4 0.5 0.5 12.575001 +104 2 2 0.5 0.5 21.203644 +105 4 4 0.5 0.5 12.856166 +106 4 4 0.5 0.5 9.740174 +\end{Sinput} +Thus, school variables are identical, but we still have to specify both in order to pass the data appropriately. Incorporating no other predictors into the model for simplicity, a multi-membership model is specified as + +\begin{Sinput} +fit_mm <- brm(y ~ 1 + (1 | mm(s1, s2)), data = data_mm) +\end{Sinput} +The only new syntax element is that multiple grouping factors (\code{s1} and \code{s2}) are wrapped in \code{mm}. Everything else remains exactly the same. Note that we did not specify the relative weights of schools for each student and thus, by default, equal weights are assumed. + +\begin{Sinput} +summary(fit_mm) +\end{Sinput} + +\begin{Sinput} + Family: gaussian (identity) +Formula: y ~ 1 + (1 | mm(s1, s2)) + Data: data_mm (Number of observations: 1000) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: Not computed + +Group-Level Effects: +~mms1s2 (Number of levels: 10) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 2.76 0.82 1.69 4.74 682 1.01 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept 19 0.93 17.06 20.8 610 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sigma 3.58 0.08 3.43 3.75 2117 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} + +With regard to the assumptions made in the above example, it is unlikely that all children who change schools stay in both schools equally long. To relax this assumption, we have to specify weights. First, we amend the simulated data to contain non-equal weights for students changing schools. For all other students, weighting does of course not matter as they stay in the same school anyway. + +\begin{Sinput} +data_mm[1:100, "w1"] <- runif(100, 0, 1) +data_mm[1:100, "w2"] <- 1 - data_mm[1:100, "w1"] +head(data_mm) +\end{Sinput} + +\begin{Sinput} + s1 s2 w1 w2 y +1 8 9 0.3403258 0.65967423 16.27422 +2 10 9 0.1771435 0.82285652 18.71387 +3 5 3 0.9059811 0.09401892 23.65319 +4 3 5 0.4432007 0.55679930 22.35204 +5 5 3 0.8052026 0.19479738 16.38019 +6 10 6 0.5610243 0.43897567 17.63494 +\end{Sinput} +Incorporating these weights into the model is straight forward. + +\begin{Sinput} +fit_mm2 <- brm(y ~ 1 + (1 | mm(s1, s2, weights = cbind(w1, w2))), + data = data_mm) +\end{Sinput} +The summary output is similar to the previous, so we do not show it here. The second assumption that students change schools only once a year, may also easily be relaxed by providing more than two grouping factors, say, \code{mm(s1, s2, s3)}. + +\section{Comparison between packages} + +Over the years, many R packages have been developed that implement MLMs, each being more or less general in their supported models. In \cite{brms1}, I compared \pkg{brms} with \pkg{lme4} \citep{bates2015}, \pkg{MCMCglmm} \citep{hadfield2010}, \pkg{rstanarm} \citep{rstanarm2017}, and \pkg{rethinking} \citep{mcelreath2017}. Since then, quite a few new features have been added in particular to \pkg{brms} and \pkg{rstanarm}. Accordingly, in the present paper, I will update these comparisons, but focus on \pkg{brms}, \pkg{rstanarm}, and \pkg{MCMCglmm} as the possibly most important R packages implementing Bayesian MLMs. While \pkg{brms} and \pkg{rstanarm} are both based on the probabilistic programming language \pkg{Stan}, \pkg{MCMCglmm} implements its own custom MCMC algorithm. Modeling options and other important information of these packages are summarized in Table~\ref{comparison} and will be discussed in detail below. + +Regarding general model classes, all three packages support the most common types such as linear, count data and certain survival models. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. Additionally, they offer support for zero-inflated and hurdle models to account for access zeros in the data (see Example 1 above). For survival / time-to-event models, \pkg{rstanarm} offers great flexibility via the \code{stan\_jm} function, which allows for complex association structures between time-to-event data and one or more models of longitudinal covariates (for details see \url{https://cran.r-project.org/web/packages/rstanarm/vignettes/jm.html}). Model classes currently specific to \pkg{brms} are robust linear models using Student's t-distribution (family \code{student}) as well as response times models via the exponentially modified Gaussian (family \code{exgaussian}) distribution or the Wiener diffusion model (family \code{wiener}). The latter allows to simultaneously model dichotomous decisions and their corresponding response times (for a detailed example see \url{http://singmann.org/wiener-model-analysis-with-brms-part-i/}). + +All three packages offer many additional modeling options, with \pkg{brms} currently having the greatest flexibility (see Table~\ref{comparison} for a summary). Moreover, the packages differ in the general framework, in which they are implemented: \pkg{brms} and \pkg{MCMCglmm} each come with a single model fitting function (\code{brm} and \code{MCMCglmm} respectively), through which all of their models can be specified. Further, their framework allows to seamlessly combine most modeling options with each other in the same model. In contrast, the approach of \pkg{rstanarm} is to emulate existing functions of other packages. This has the advantage of an easier transition between classical and Bayesian models, since the syntax used to specify models stays the same. However, it comes with the main disadvantage that many modeling options cannot be used in combination within the same model. + +Information criteria are available in all three packages. The advantages of WAIC and LOO implemented in \pkg{brms} and \pkg{rstanarm}, are their less restrictive assumptions and that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the packages, \pkg{brms} offers a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, I believe that the way priors are specified in \pkg{brms} is more intuitive as it is directly evident what prior is actually applied. In \pkg{brms}, Bayes factors are available both via Savage-Dickey ratios \citep{wagenmakers2010} and bridge-sampling \citep{bridgesampling2017}, while \pkg{rstanarm} allows for the latter option. For a detailed comparison with respect to sampling efficiency, see \cite{brms1}. + + +\begin{table}[hbtp] +\centering +\begin{tabular}{llll} + & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline +\\ [-1.5ex] +\parbox{6cm}{\textbf{Model classes}} & & & \\ [1ex] +Linear models & yes & yes & yes \\ +Robust linear models & yes & no & no \\ +Count data models & yes & yes & yes \\ +Survival models & yes & yes$^1$ & yes \\ +Response times models & yes & no & no \\ +Beta models & yes & yes & no \\ +Categorical models & yes & yes$^2$ & yes \\ +Multinomial models & no & no & yes \\ +Ordinal models & various & cumulative$^2$ & cumulative \\ +Zero-inflated and hurdle models & yes & no & yes \\ \hline +\\ [-1.5ex] +\parbox{5cm}{\textbf{Modeling options}} & & & \\ [1ex] +Variable link functions & various & various & no \\ +Multilevel structures & yes & yes & yes \\ +Multi-membership & yes & no & yes \\ +Multivariate responses & yes & yes$^3$ & yes \\ +Non-linear predictors & yes & limited$^4$ & no \\ +Distributional regression & yes & no & no \\ +Finite mixtures & yes & no & no \\ +Splines (additive models) & yes & yes & yes \\ +Gaussian Processes & yes & no & no \\ +Temporal autocorrelation & yes & yes$^{2, 5}$ & no \\ +Spatial autocorrelation & yes & yes$^{2, 5}$ & no \\ +Monotonic effects & yes & no & no \\ +Category specific effects & yes & no & no \\ +Measurement error & yes & no & no \\ +Weights & yes & yes & no \\ +Offset & yes & yes & using priors \\ +Censored data & yes & yes$^1$ & yes \\ +Truncated data & yes & no & no \\ +Customized covariances & yes & no & yes \\ +Missing value imputation & no & no & no \\ \hline +\\ [-1.5ex] +\textbf{Bayesian specifics} & & & \\ [1ex] +Population-level priors & flexible & flexible & normal \\ +Group-level priors & normal & normal & normal \\ +Covariance priors & flexible & restricted$^6$ & restricted$^7$ \\ +Bayes factors & yes & yes$^8$ & no \\ +Parallelization & yes & yes & no \\ \hline +\\ [-1.5ex] +\textbf{Other} & & & \\ [1ex] +Estimator & HMC, NUTS & HMC, NUTS & MH, Gibbs$^9$ \\ +Information criterion & WAIC, LOO & WAIC, LOO & DIC \\ +C++ compiler required & yes & no & no \\ \hline +\end{tabular} +\caption{ +Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{MCMCglmm} packages. Notes: (1) Advanced functionality available via \code{stan\_jm}. (2) No group-level terms and related functionality allowed. (3) Cannot be combined with other modeling options such as splines. (4) Functionality limited to linear Gaussian models and certein pre-specified non-linear functions. (5) Functionality available only on GitHub branches (\url{https://github.com/stan-dev/rstanarm}). (6) For details see \cite{hadfield2010}. (7) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}. (8) Available via the \pkg{bridgesampling} package \citep{bridgesampling2017}. (9) Estimator consists of a combination of both algorithms. +} +\label{comparison} +\end{table} + +\section{Conclusion} + +The present paper is meant to introduce R users and developers to the extended \pkg{lme4} formula syntax applied in \pkg{brms}. Only a subset of modeling options were discussed in detail, which ensured the paper was not too broad. For some of the more basic models that \pkg{brms} can fit, see \citet{brms1}. Many more examples can be found in the growing number of vignettes accompanying the package (see \code{vignette(package = "brms")} for an overview). + +To date, \pkg{brms} is already one of the most flexible R packages when it comes to regression modeling. However, for the future, there are quite a few more features that I am planning to implement (see \url{https://github.com/paul-buerkner/brms/issues} for the current list of issues). In addition to smaller, incremental updates, I have two specific features in mind: (1) latent variables estimated via confirmatory factor analysis and (2) missing value imputation. I receive ideas and suggestions from users almost every day -- for which I am always grateful -- and so the list of features that will be implemented in the proceeding versions of \pkg{brms} will continue to grow. + +\section*{Acknowledgments} + +First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language Stan, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Furthermore, I want to thank Heinz Holling, Donald Williams and Ruben Arslan for valuable comments on earlier versions of the paper. I also would like to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. + +\bibliography{citations_multilevel} + +\end{document} Binary files /tmp/tmpt0wkwjq4/DNen8CCOKk/r-cran-brms-2.16.3/inst/doc/brms_multilevel.pdf and /tmp/tmpt0wkwjq4/VQL6MIL24y/r-cran-brms-2.17.0/inst/doc/brms_multilevel.pdf differ diff -Nru r-cran-brms-2.16.3/inst/doc/brms_multivariate.html r-cran-brms-2.17.0/inst/doc/brms_multivariate.html --- r-cran-brms-2.16.3/inst/doc/brms_multivariate.html 2021-11-22 16:20:29.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_multivariate.html 2022-04-11 08:08:51.000000000 +0000 @@ -1,445 +1,445 @@ - - - - - - - - - - - - - - - - -Estimating Multivariate Models with brms - - - - - - - - - - - - - - - - - - - - - - - - - -

Estimating Multivariate Models with brms

-

Paul Bürkner

-

2021-11-22

- - - - -
-

Introduction

-

In the present vignette, we want to discuss how to specify multivariate multilevel models using brms. We call a model multivariate if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the tarsus length as well as the back color of chicks. Half of the brood were put into another fosternest, while the other half stayed in the fosternest of their own dam. This allows to separate genetic from environmental factors. Additionally, we have information about the hatchdate and sex of the chicks (the latter being known for 94% of the animals).

-
data("BTdata", package = "MCMCglmm")
-head(BTdata)
-
       tarsus       back  animal     dam fosternest  hatchdate  sex
-1 -1.89229718  1.1464212 R187142 R187557      F2102 -0.6874021  Fem
-2  1.13610981 -0.7596521 R187154 R187559      F1902 -0.6874021 Male
-3  0.98468946  0.1449373 R187341 R187568       A602 -0.4279814 Male
-4  0.37900806  0.2555847 R046169 R187518      A1302 -1.4656641 Male
-5 -0.07525299 -0.3006992 R046161 R187528      A2602 -1.4656641  Fem
-6 -1.13519543  1.5577219 R187409 R187945      C2302  0.3502805  Fem
-
-
-

Basic Multivariate Models

-

We begin with a relatively simple multivariate normal model.

-
fit1 <- brm(
-  mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam),
-  data = BTdata, chains = 2, cores = 2
-)
-

As can be seen in the model code, we have used mvbind notation to tell brms that both tarsus and back are separate response variables. The term (1|p|fosternest) indicates a varying intercept over fosternest. By writing |p| in between we indicate that all varying effects of fosternest should be modeled as correlated. This makes sense since we actually have two model parts, one for tarsus and one for back. The indicator p is arbitrary and can be replaced by other symbols that comes into your mind (for details about the multilevel syntax of brms, see help("brmsformula") and vignette("brms_multilevel")). Similarly, the term (1|q|dam) indicates correlated varying effects of the genetic mother of the chicks. Alternatively, we could have also modeled the genetic similarities through pedigrees and corresponding relatedness matrices, but this is not the focus of this vignette (please see vignette("brms_phylogenetics")). The model results are readily summarized via

-
fit1 <- add_criterion(fit1, "loo")
-summary(fit1)
-
 Family: MV(gaussian, gaussian) 
-  Links: mu = identity; sigma = identity
-         mu = identity; sigma = identity 
-Formula: tarsus ~ sex + hatchdate + (1 | p | fosternest) + (1 | q | dam) 
-         back ~ sex + hatchdate + (1 | p | fosternest) + (1 | q | dam) 
-   Data: BTdata (Number of observations: 828) 
-  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 2000
-
-Group-Level Effects: 
-~dam (Number of levels: 106) 
-                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
-sd(tarsus_Intercept)                     0.48      0.05     0.39     0.58 1.00      789
-sd(back_Intercept)                       0.24      0.08     0.09     0.39 1.01      286
-cor(tarsus_Intercept,back_Intercept)    -0.52      0.23    -0.95    -0.08 1.01      377
-                                     Tail_ESS
-sd(tarsus_Intercept)                     1353
-sd(back_Intercept)                        606
-cor(tarsus_Intercept,back_Intercept)      695
-
-~fosternest (Number of levels: 104) 
-                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
-sd(tarsus_Intercept)                     0.27      0.05     0.16     0.38 1.00      664
-sd(back_Intercept)                       0.35      0.06     0.23     0.47 1.00      453
-cor(tarsus_Intercept,back_Intercept)     0.68      0.21     0.20     0.98 1.00      316
-                                     Tail_ESS
-sd(tarsus_Intercept)                     1163
-sd(back_Intercept)                        952
-cor(tarsus_Intercept,back_Intercept)      557
-
-Population-Level Effects: 
-                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-tarsus_Intercept    -0.41      0.07    -0.55    -0.27 1.00     1356     1387
-back_Intercept      -0.01      0.06    -0.14     0.11 1.00     2247     1577
-tarsus_sexMale       0.77      0.06     0.66     0.87 1.00     3631     1251
-tarsus_sexUNK        0.23      0.13    -0.03     0.48 1.00     3904     1252
-tarsus_hatchdate    -0.04      0.06    -0.16     0.07 1.00     1221     1286
-back_sexMale         0.01      0.07    -0.12     0.13 1.00     3669     1885
-back_sexUNK          0.15      0.15    -0.13     0.44 1.00     3706     1602
-back_hatchdate      -0.09      0.05    -0.19     0.02 1.00     2152     1551
-
-Family Specific Parameters: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma_tarsus     0.76      0.02     0.72     0.80 1.00     1928     1652
-sigma_back       0.90      0.02     0.85     0.95 1.00     2607     1610
-
-Residual Correlations: 
-                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-rescor(tarsus,back)    -0.05      0.04    -0.13     0.02 1.00     2597     1370
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

The summary output of multivariate models closely resembles those of univariate models, except that the parameters now have the corresponding response variable as prefix. Within dams, tarsus length and back color seem to be negatively correlated, while within fosternests the opposite is true. This indicates differential effects of genetic and environmental factors on these two characteristics. Further, the small residual correlation rescor(tarsus, back) on the bottom of the output indicates that there is little unmodeled dependency between tarsus length and back color. Although not necessary at this point, we have already computed and stored the LOO information criterion of fit1, which we will use for model comparisons. Next, let’s take a look at some posterior-predictive checks, which give us a first impression of the model fit.

-
pp_check(fit1, resp = "tarsus")
-

-
pp_check(fit1, resp = "back")
-

-

This looks pretty solid, but we notice a slight unmodeled left skewness in the distribution of tarsus. We will come back to this later on. Next, we want to investigate how much variation in the response variables can be explained by our model and we use a Bayesian generalization of the \(R^2\) coefficient.

-
bayes_R2(fit1)
-
          Estimate  Est.Error      Q2.5     Q97.5
-R2tarsus 0.4341246 0.02329163 0.3857624 0.4776837
-R2back   0.1977502 0.02836021 0.1408088 0.2523545
-

Clearly, there is much variation in both animal characteristics that we can not explain, but apparently we can explain more of the variation in tarsus length than in back color.

-
-
-

More Complex Multivariate Models

-

Now, suppose we only want to control for sex in tarsus but not in back and vice versa for hatchdate. Not that this is particular reasonable for the present example, but it allows us to illustrate how to specify different formulas for different response variables. We can no longer use mvbind syntax and so we have to use a more verbose approach:

-
bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam))
-bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam))
-fit2 <- brm(bf_tarsus + bf_back, data = BTdata, chains = 2, cores = 2)
-

Note that we have literally added the two model parts via the + operator, which is in this case equivalent to writing mvbf(bf_tarsus, bf_back). See help("brmsformula") and help("mvbrmsformula") for more details about this syntax. Again, we summarize the model first.

-
fit2 <- add_criterion(fit2, "loo")
-summary(fit2)
-
 Family: MV(gaussian, gaussian) 
-  Links: mu = identity; sigma = identity
-         mu = identity; sigma = identity 
-Formula: tarsus ~ sex + (1 | p | fosternest) + (1 | q | dam) 
-         back ~ hatchdate + (1 | p | fosternest) + (1 | q | dam) 
-   Data: BTdata (Number of observations: 828) 
-  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 2000
-
-Group-Level Effects: 
-~dam (Number of levels: 106) 
-                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
-sd(tarsus_Intercept)                     0.48      0.05     0.39     0.59 1.00      800
-sd(back_Intercept)                       0.25      0.07     0.11     0.39 1.00      392
-cor(tarsus_Intercept,back_Intercept)    -0.49      0.22    -0.91    -0.06 1.00      576
-                                     Tail_ESS
-sd(tarsus_Intercept)                     1270
-sd(back_Intercept)                        589
-cor(tarsus_Intercept,back_Intercept)      649
-
-~fosternest (Number of levels: 104) 
-                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
-sd(tarsus_Intercept)                     0.27      0.05     0.17     0.37 1.00      642
-sd(back_Intercept)                       0.35      0.06     0.23     0.45 1.00      511
-cor(tarsus_Intercept,back_Intercept)     0.70      0.20     0.24     0.98 1.00      229
-                                     Tail_ESS
-sd(tarsus_Intercept)                      937
-sd(back_Intercept)                       1098
-cor(tarsus_Intercept,back_Intercept)      311
-
-Population-Level Effects: 
-                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-tarsus_Intercept    -0.42      0.07    -0.55    -0.28 1.00     1248     1372
-back_Intercept       0.00      0.05    -0.10     0.10 1.00     1552     1414
-tarsus_sexMale       0.77      0.06     0.66     0.88 1.00     3231     1537
-tarsus_sexUNK        0.23      0.13    -0.03     0.49 1.00     2914     1644
-back_hatchdate      -0.08      0.05    -0.19     0.02 1.00     2024     1543
-
-Family Specific Parameters: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma_tarsus     0.76      0.02     0.72     0.80 1.00     2089     1584
-sigma_back       0.90      0.02     0.85     0.95 1.00     2066     1532
-
-Residual Correlations: 
-                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-rescor(tarsus,back)    -0.05      0.04    -0.13     0.02 1.00     2480     1767
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

Let’s find out, how model fit changed due to excluding certain effects from the initial model:

-
loo(fit1, fit2)
-
Output of model 'fit1':
-
-Computed from 2000 by 828 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo  -2127.2 33.5
-p_loo       176.2  7.4
-looic      4254.3 67.1
-------
-Monte Carlo SE of elpd_loo is 0.4.
-
-Pareto k diagnostic values:
-                         Count Pct.    Min. n_eff
-(-Inf, 0.5]   (good)     814   98.3%   196       
- (0.5, 0.7]   (ok)        14    1.7%   76        
-   (0.7, 1]   (bad)        0    0.0%   <NA>      
-   (1, Inf)   (very bad)   0    0.0%   <NA>      
-
-All Pareto k estimates are ok (k < 0.7).
-See help('pareto-k-diagnostic') for details.
-
-Output of model 'fit2':
-
-Computed from 2000 by 828 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo  -2124.6 33.6
-p_loo       173.5  7.3
-looic      4249.2 67.3
-------
-Monte Carlo SE of elpd_loo is NA.
-
-Pareto k diagnostic values:
-                         Count Pct.    Min. n_eff
-(-Inf, 0.5]   (good)     813   98.2%   208       
- (0.5, 0.7]   (ok)        14    1.7%   107       
-   (0.7, 1]   (bad)        1    0.1%   32        
-   (1, Inf)   (very bad)   0    0.0%   <NA>      
-See help('pareto-k-diagnostic') for details.
-
-Model comparisons:
-     elpd_diff se_diff
-fit2  0.0       0.0   
-fit1 -2.5       1.4
-

Apparently, there is no noteworthy difference in the model fit. Accordingly, we do not really need to model sex and hatchdate for both response variables, but there is also no harm in including them (so I would probably just include them).

-

To give you a glimpse of the capabilities of brms’ multivariate syntax, we change our model in various directions at the same time. Remember the slight left skewness of tarsus, which we will now model by using the skew_normal family instead of the gaussian family. Since we do not have a multivariate normal (or student-t) model, anymore, estimating residual correlations is no longer possible. We make this explicit using the set_rescor function. Further, we investigate if the relationship of back and hatchdate is really linear as previously assumed by fitting a non-linear spline of hatchdate. On top of it, we model separate residual variances of tarsus for male and female chicks.

-
bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) +
-  lf(sigma ~ 0 + sex) + skew_normal()
-bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) +
-  gaussian()
-
-fit3 <- brm(
-  bf_tarsus + bf_back + set_rescor(FALSE), 
-  data = BTdata, chains = 2, cores = 2,
-  control = list(adapt_delta = 0.95)
-)
-

Again, we summarize the model and look at some posterior-predictive checks.

-
fit3 <- add_criterion(fit3, "loo")
-summary(fit3)
-
 Family: MV(skew_normal, gaussian) 
-  Links: mu = identity; sigma = log; alpha = identity
-         mu = identity; sigma = identity 
-Formula: tarsus ~ sex + (1 | p | fosternest) + (1 | q | dam) 
-         sigma ~ 0 + sex
-         back ~ s(hatchdate) + (1 | p | fosternest) + (1 | q | dam) 
-   Data: BTdata (Number of observations: 828) 
-  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 2000
-
-Smooth Terms: 
-                       Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sds(back_shatchdate_1)     2.10      1.11     0.34     4.66 1.00      563      515
-
-Group-Level Effects: 
-~dam (Number of levels: 106) 
-                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
-sd(tarsus_Intercept)                     0.47      0.05     0.38     0.58 1.00      476
-sd(back_Intercept)                       0.23      0.07     0.08     0.36 1.00      249
-cor(tarsus_Intercept,back_Intercept)    -0.54      0.24    -0.95    -0.05 1.00      458
-                                     Tail_ESS
-sd(tarsus_Intercept)                     1100
-sd(back_Intercept)                        302
-cor(tarsus_Intercept,back_Intercept)      706
-
-~fosternest (Number of levels: 104) 
-                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
-sd(tarsus_Intercept)                     0.26      0.06     0.15     0.37 1.01      362
-sd(back_Intercept)                       0.32      0.06     0.21     0.43 1.00      478
-cor(tarsus_Intercept,back_Intercept)     0.66      0.23     0.16     0.99 1.01      148
-                                     Tail_ESS
-sd(tarsus_Intercept)                      518
-sd(back_Intercept)                        696
-cor(tarsus_Intercept,back_Intercept)      306
-
-Population-Level Effects: 
-                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-tarsus_Intercept        -0.41      0.07    -0.54    -0.27 1.00      797     1161
-back_Intercept           0.00      0.05    -0.10     0.11 1.00     1219     1284
-tarsus_sexMale           0.77      0.06     0.66     0.88 1.00     2604     1442
-tarsus_sexUNK            0.21      0.12    -0.02     0.44 1.00     2548     1583
-sigma_tarsus_sexFem     -0.30      0.04    -0.39    -0.21 1.00     2220     1266
-sigma_tarsus_sexMale    -0.24      0.04    -0.32    -0.16 1.00     1723     1329
-sigma_tarsus_sexUNK     -0.39      0.13    -0.63    -0.14 1.00     1636     1461
-back_shatchdate_1       -0.08      3.24    -5.80     7.09 1.00      880     1003
-
-Family Specific Parameters: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma_back       0.90      0.02     0.86     0.95 1.00     2079     1550
-alpha_tarsus    -1.22      0.43    -1.85     0.10 1.01      922      445
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

We see that the (log) residual standard deviation of tarsus is somewhat larger for chicks whose sex could not be identified as compared to male or female chicks. Further, we see from the negative alpha (skewness) parameter of tarsus that the residuals are indeed slightly left-skewed. Lastly, running

-
conditional_effects(fit3, "hatchdate", resp = "back")
-

-

reveals a non-linear relationship of hatchdate on the back color, which seems to change in waves over the course of the hatch dates.

-

There are many more modeling options for multivariate models, which are not discussed in this vignette. Examples include autocorrelation structures, Gaussian processes, or explicit non-linear predictors (e.g., see help("brmsformula") or vignette("brms_multilevel")). In fact, nearly all the flexibility of univariate models is retained in multivariate models.

-
-
-

References

-

Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic gambit: phenotypic, genetic and environmental correlations of colour. Journal of Evolutionary Biology, 20(2), 549-557.

-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Estimating Multivariate Models with brms + + + + + + + + + + + + + + + + + + + + + + + + + +

Estimating Multivariate Models with brms

+

Paul Bürkner

+

2022-04-11

+ + + + +
+

Introduction

+

In the present vignette, we want to discuss how to specify multivariate multilevel models using brms. We call a model multivariate if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the tarsus length as well as the back color of chicks. Half of the brood were put into another fosternest, while the other half stayed in the fosternest of their own dam. This allows to separate genetic from environmental factors. Additionally, we have information about the hatchdate and sex of the chicks (the latter being known for 94% of the animals).

+
data("BTdata", package = "MCMCglmm")
+head(BTdata)
+
       tarsus       back  animal     dam fosternest  hatchdate  sex
+1 -1.89229718  1.1464212 R187142 R187557      F2102 -0.6874021  Fem
+2  1.13610981 -0.7596521 R187154 R187559      F1902 -0.6874021 Male
+3  0.98468946  0.1449373 R187341 R187568       A602 -0.4279814 Male
+4  0.37900806  0.2555847 R046169 R187518      A1302 -1.4656641 Male
+5 -0.07525299 -0.3006992 R046161 R187528      A2602 -1.4656641  Fem
+6 -1.13519543  1.5577219 R187409 R187945      C2302  0.3502805  Fem
+
+
+

Basic Multivariate Models

+

We begin with a relatively simple multivariate normal model.

+
bform1 <- 
+  bf(mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam)) +
+  set_rescor(TRUE)
+
+fit1 <- brm(bform1, data = BTdata, chains = 2, cores = 2)
+

As can be seen in the model code, we have used mvbind notation to tell brms that both tarsus and back are separate response variables. The term (1|p|fosternest) indicates a varying intercept over fosternest. By writing |p| in between we indicate that all varying effects of fosternest should be modeled as correlated. This makes sense since we actually have two model parts, one for tarsus and one for back. The indicator p is arbitrary and can be replaced by other symbols that comes into your mind (for details about the multilevel syntax of brms, see help("brmsformula") and vignette("brms_multilevel")). Similarly, the term (1|q|dam) indicates correlated varying effects of the genetic mother of the chicks. Alternatively, we could have also modeled the genetic similarities through pedigrees and corresponding relatedness matrices, but this is not the focus of this vignette (please see vignette("brms_phylogenetics")). The model results are readily summarized via

+
fit1 <- add_criterion(fit1, "loo")
+summary(fit1)
+
 Family: MV(gaussian, gaussian) 
+  Links: mu = identity; sigma = identity
+         mu = identity; sigma = identity 
+Formula: tarsus ~ sex + hatchdate + (1 | p | fosternest) + (1 | q | dam) 
+         back ~ sex + hatchdate + (1 | p | fosternest) + (1 | q | dam) 
+   Data: BTdata (Number of observations: 828) 
+  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 2000
+
+Group-Level Effects: 
+~dam (Number of levels: 106) 
+                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
+sd(tarsus_Intercept)                     0.48      0.05     0.39     0.59 1.00      773
+sd(back_Intercept)                       0.25      0.08     0.10     0.39 1.01      253
+cor(tarsus_Intercept,back_Intercept)    -0.51      0.21    -0.91    -0.07 1.00      468
+                                     Tail_ESS
+sd(tarsus_Intercept)                     1301
+sd(back_Intercept)                        445
+cor(tarsus_Intercept,back_Intercept)      759
+
+~fosternest (Number of levels: 104) 
+                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
+sd(tarsus_Intercept)                     0.27      0.06     0.17     0.38 1.00      526
+sd(back_Intercept)                       0.35      0.06     0.23     0.47 1.00      441
+cor(tarsus_Intercept,back_Intercept)     0.69      0.21     0.19     0.99 1.04      136
+                                     Tail_ESS
+sd(tarsus_Intercept)                      862
+sd(back_Intercept)                        947
+cor(tarsus_Intercept,back_Intercept)      517
+
+Population-Level Effects: 
+                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+tarsus_Intercept    -0.41      0.07    -0.55    -0.27 1.00     1303     1307
+back_Intercept      -0.01      0.06    -0.14     0.11 1.00     2243     1668
+tarsus_sexMale       0.77      0.06     0.65     0.88 1.00     4070     1440
+tarsus_sexUNK        0.23      0.13    -0.03     0.48 1.00     3196     1554
+tarsus_hatchdate    -0.04      0.06    -0.16     0.07 1.00     1056     1305
+back_sexMale         0.01      0.07    -0.12     0.14 1.00     4881     1422
+back_sexUNK          0.15      0.14    -0.12     0.42 1.00     3668     1653
+back_hatchdate      -0.09      0.05    -0.19     0.01 1.00     1789     1304
+
+Family Specific Parameters: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma_tarsus     0.76      0.02     0.72     0.80 1.00     2758     1442
+sigma_back       0.90      0.02     0.86     0.95 1.00     3230     1495
+
+Residual Correlations: 
+                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+rescor(tarsus,back)    -0.05      0.04    -0.13     0.02 1.00     3343     1663
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

The summary output of multivariate models closely resembles those of univariate models, except that the parameters now have the corresponding response variable as prefix. Within dams, tarsus length and back color seem to be negatively correlated, while within fosternests the opposite is true. This indicates differential effects of genetic and environmental factors on these two characteristics. Further, the small residual correlation rescor(tarsus, back) on the bottom of the output indicates that there is little unmodeled dependency between tarsus length and back color. Although not necessary at this point, we have already computed and stored the LOO information criterion of fit1, which we will use for model comparisons. Next, let’s take a look at some posterior-predictive checks, which give us a first impression of the model fit.

+
pp_check(fit1, resp = "tarsus")
+

+
pp_check(fit1, resp = "back")
+

+

This looks pretty solid, but we notice a slight unmodeled left skewness in the distribution of tarsus. We will come back to this later on. Next, we want to investigate how much variation in the response variables can be explained by our model and we use a Bayesian generalization of the \(R^2\) coefficient.

+
bayes_R2(fit1)
+
          Estimate  Est.Error      Q2.5     Q97.5
+R2tarsus 0.4339755 0.02387684 0.3845041 0.4763270
+R2back   0.1980269 0.02823697 0.1440005 0.2526271
+

Clearly, there is much variation in both animal characteristics that we can not explain, but apparently we can explain more of the variation in tarsus length than in back color.

+
+
+

More Complex Multivariate Models

+

Now, suppose we only want to control for sex in tarsus but not in back and vice versa for hatchdate. Not that this is particular reasonable for the present example, but it allows us to illustrate how to specify different formulas for different response variables. We can no longer use mvbind syntax and so we have to use a more verbose approach:

+
bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam))
+bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam))
+fit2 <- brm(bf_tarsus + bf_back + set_rescor(TRUE), 
+            data = BTdata, chains = 2, cores = 2)
+

Note that we have literally added the two model parts via the + operator, which is in this case equivalent to writing mvbf(bf_tarsus, bf_back). See help("brmsformula") and help("mvbrmsformula") for more details about this syntax. Again, we summarize the model first.

+
fit2 <- add_criterion(fit2, "loo")
+summary(fit2)
+
 Family: MV(gaussian, gaussian) 
+  Links: mu = identity; sigma = identity
+         mu = identity; sigma = identity 
+Formula: tarsus ~ sex + (1 | p | fosternest) + (1 | q | dam) 
+         back ~ hatchdate + (1 | p | fosternest) + (1 | q | dam) 
+   Data: BTdata (Number of observations: 828) 
+  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 2000
+
+Group-Level Effects: 
+~dam (Number of levels: 106) 
+                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
+sd(tarsus_Intercept)                     0.48      0.05     0.39     0.59 1.00      944
+sd(back_Intercept)                       0.25      0.07     0.10     0.39 1.00      416
+cor(tarsus_Intercept,back_Intercept)    -0.50      0.22    -0.90    -0.07 1.00      791
+                                     Tail_ESS
+sd(tarsus_Intercept)                     1404
+sd(back_Intercept)                        572
+cor(tarsus_Intercept,back_Intercept)     1072
+
+~fosternest (Number of levels: 104) 
+                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
+sd(tarsus_Intercept)                     0.27      0.05     0.16     0.38 1.00      678
+sd(back_Intercept)                       0.35      0.06     0.23     0.47 1.00      558
+cor(tarsus_Intercept,back_Intercept)     0.68      0.21     0.20     0.98 1.00      291
+                                     Tail_ESS
+sd(tarsus_Intercept)                     1227
+sd(back_Intercept)                        874
+cor(tarsus_Intercept,back_Intercept)      681
+
+Population-Level Effects: 
+                 Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+tarsus_Intercept    -0.41      0.07    -0.55    -0.28 1.00     2059     1785
+back_Intercept       0.00      0.05    -0.11     0.11 1.00     2807     1746
+tarsus_sexMale       0.77      0.06     0.66     0.88 1.00     4227     1517
+tarsus_sexUNK        0.23      0.13    -0.02     0.48 1.00     4517     1520
+back_hatchdate      -0.08      0.05    -0.19     0.02 1.00     3182     1470
+
+Family Specific Parameters: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma_tarsus     0.76      0.02     0.72     0.79 1.00     2038     1659
+sigma_back       0.90      0.02     0.86     0.95 1.00     2406     1053
+
+Residual Correlations: 
+                    Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+rescor(tarsus,back)    -0.05      0.04    -0.13     0.02 1.00     3349     1630
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

Let’s find out, how model fit changed due to excluding certain effects from the initial model:

+
loo(fit1, fit2)
+
Output of model 'fit1':
+
+Computed from 2000 by 828 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo  -2126.0 33.6
+p_loo       175.6  7.4
+looic      4252.0 67.3
+------
+Monte Carlo SE of elpd_loo is NA.
+
+Pareto k diagnostic values:
+                         Count Pct.    Min. n_eff
+(-Inf, 0.5]   (good)     803   97.0%   394       
+ (0.5, 0.7]   (ok)        23    2.8%   105       
+   (0.7, 1]   (bad)        2    0.2%   26        
+   (1, Inf)   (very bad)   0    0.0%   <NA>      
+See help('pareto-k-diagnostic') for details.
+
+Output of model 'fit2':
+
+Computed from 2000 by 828 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo  -2123.2 33.7
+p_loo       173.8  7.5
+looic      4246.5 67.4
+------
+Monte Carlo SE of elpd_loo is NA.
+
+Pareto k diagnostic values:
+                         Count Pct.    Min. n_eff
+(-Inf, 0.5]   (good)     809   97.7%   370       
+ (0.5, 0.7]   (ok)        17    2.1%   95        
+   (0.7, 1]   (bad)        2    0.2%   28        
+   (1, Inf)   (very bad)   0    0.0%   <NA>      
+See help('pareto-k-diagnostic') for details.
+
+Model comparisons:
+     elpd_diff se_diff
+fit2  0.0       0.0   
+fit1 -2.8       1.4
+

Apparently, there is no noteworthy difference in the model fit. Accordingly, we do not really need to model sex and hatchdate for both response variables, but there is also no harm in including them (so I would probably just include them).

+

To give you a glimpse of the capabilities of brms’ multivariate syntax, we change our model in various directions at the same time. Remember the slight left skewness of tarsus, which we will now model by using the skew_normal family instead of the gaussian family. Since we do not have a multivariate normal (or student-t) model, anymore, estimating residual correlations is no longer possible. We make this explicit using the set_rescor function. Further, we investigate if the relationship of back and hatchdate is really linear as previously assumed by fitting a non-linear spline of hatchdate. On top of it, we model separate residual variances of tarsus for male and female chicks.

+
bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) +
+  lf(sigma ~ 0 + sex) + skew_normal()
+bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) +
+  gaussian()
+
+fit3 <- brm(
+  bf_tarsus + bf_back + set_rescor(FALSE),
+  data = BTdata, chains = 2, cores = 2,
+  control = list(adapt_delta = 0.95)
+)
+

Again, we summarize the model and look at some posterior-predictive checks.

+
fit3 <- add_criterion(fit3, "loo")
+summary(fit3)
+
 Family: MV(skew_normal, gaussian) 
+  Links: mu = identity; sigma = log; alpha = identity
+         mu = identity; sigma = identity 
+Formula: tarsus ~ sex + (1 | p | fosternest) + (1 | q | dam) 
+         sigma ~ 0 + sex
+         back ~ s(hatchdate) + (1 | p | fosternest) + (1 | q | dam) 
+   Data: BTdata (Number of observations: 828) 
+  Draws: 2 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 2000
+
+Smooth Terms: 
+                       Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sds(back_shatchdate_1)     1.97      0.99     0.25     4.22 1.00      503      338
+
+Group-Level Effects: 
+~dam (Number of levels: 106) 
+                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
+sd(tarsus_Intercept)                     0.48      0.05     0.39     0.58 1.00      832
+sd(back_Intercept)                       0.24      0.07     0.10     0.37 1.01      298
+cor(tarsus_Intercept,back_Intercept)    -0.52      0.22    -0.93    -0.06 1.00      417
+                                     Tail_ESS
+sd(tarsus_Intercept)                     1395
+sd(back_Intercept)                        681
+cor(tarsus_Intercept,back_Intercept)      445
+
+~fosternest (Number of levels: 104) 
+                                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS
+sd(tarsus_Intercept)                     0.26      0.05     0.15     0.37 1.00      535
+sd(back_Intercept)                       0.31      0.06     0.20     0.42 1.00      512
+cor(tarsus_Intercept,back_Intercept)     0.65      0.22     0.13     0.98 1.00      255
+                                     Tail_ESS
+sd(tarsus_Intercept)                      856
+sd(back_Intercept)                       1060
+cor(tarsus_Intercept,back_Intercept)      530
+
+Population-Level Effects: 
+                     Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+tarsus_Intercept        -0.41      0.07    -0.54    -0.28 1.00      977     1420
+back_Intercept           0.00      0.05    -0.10     0.11 1.00     1475     1602
+tarsus_sexMale           0.77      0.06     0.65     0.88 1.00     3099     1461
+tarsus_sexUNK            0.21      0.12    -0.02     0.45 1.00     2394     1305
+sigma_tarsus_sexFem     -0.30      0.04    -0.38    -0.22 1.00     2537     1613
+sigma_tarsus_sexMale    -0.25      0.04    -0.33    -0.17 1.00     2200     1266
+sigma_tarsus_sexUNK     -0.39      0.13    -0.64    -0.12 1.00     1839     1461
+back_shatchdate_1       -0.35      3.16    -6.14     6.59 1.00     1044     1029
+
+Family Specific Parameters: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma_back       0.90      0.02     0.85     0.95 1.00     2296     1301
+alpha_tarsus    -1.22      0.43    -1.89     0.07 1.00     1626      682
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

We see that the (log) residual standard deviation of tarsus is somewhat larger for chicks whose sex could not be identified as compared to male or female chicks. Further, we see from the negative alpha (skewness) parameter of tarsus that the residuals are indeed slightly left-skewed. Lastly, running

+
conditional_effects(fit3, "hatchdate", resp = "back")
+

+

reveals a non-linear relationship of hatchdate on the back color, which seems to change in waves over the course of the hatch dates.

+

There are many more modeling options for multivariate models, which are not discussed in this vignette. Examples include autocorrelation structures, Gaussian processes, or explicit non-linear predictors (e.g., see help("brmsformula") or vignette("brms_multilevel")). In fact, nearly all the flexibility of univariate models is retained in multivariate models.

+
+
+

References

+

Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic gambit: phenotypic, genetic and environmental correlations of colour. Journal of Evolutionary Biology, 20(2), 549-557.

+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_multivariate.R r-cran-brms-2.17.0/inst/doc/brms_multivariate.R --- r-cran-brms-2.16.3/inst/doc/brms_multivariate.R 2021-11-22 16:20:29.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_multivariate.R 2022-04-11 08:08:51.000000000 +0000 @@ -1,73 +1,75 @@ -params <- -list(EVAL = TRUE) - -## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) - -## ----data------------------------------------------------------------------------------- -data("BTdata", package = "MCMCglmm") -head(BTdata) - -## ----fit1, message=FALSE, warning=FALSE, results='hide'--------------------------------- -fit1 <- brm( - mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam), - data = BTdata, chains = 2, cores = 2 -) - -## ----summary1, warning=FALSE------------------------------------------------------------ -fit1 <- add_criterion(fit1, "loo") -summary(fit1) - -## ----pp_check1, message=FALSE----------------------------------------------------------- -pp_check(fit1, resp = "tarsus") -pp_check(fit1, resp = "back") - -## ----R2_1------------------------------------------------------------------------------- -bayes_R2(fit1) - -## ----fit2, message=FALSE, warning=FALSE, results='hide'--------------------------------- -bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) -bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) -fit2 <- brm(bf_tarsus + bf_back, data = BTdata, chains = 2, cores = 2) - -## ----summary2, warning=FALSE------------------------------------------------------------ -fit2 <- add_criterion(fit2, "loo") -summary(fit2) - -## ----loo12------------------------------------------------------------------------------ -loo(fit1, fit2) - -## ----fit3, message=FALSE, warning=FALSE, results='hide'--------------------------------- -bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + - lf(sigma ~ 0 + sex) + skew_normal() -bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + - gaussian() - -fit3 <- brm( - bf_tarsus + bf_back + set_rescor(FALSE), - data = BTdata, chains = 2, cores = 2, - control = list(adapt_delta = 0.95) -) - -## ----summary3, warning=FALSE------------------------------------------------------------ -fit3 <- add_criterion(fit3, "loo") -summary(fit3) - -## ----me3-------------------------------------------------------------------------------- -conditional_effects(fit3, "hatchdate", resp = "back") - +params <- +list(EVAL = TRUE) + +## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) + +## ----data------------------------------------------------------------------------------- +data("BTdata", package = "MCMCglmm") +head(BTdata) + +## ----fit1, message=FALSE, warning=FALSE, results='hide'--------------------------------- +bform1 <- + bf(mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam)) + + set_rescor(TRUE) + +fit1 <- brm(bform1, data = BTdata, chains = 2, cores = 2) + +## ----summary1, warning=FALSE------------------------------------------------------------ +fit1 <- add_criterion(fit1, "loo") +summary(fit1) + +## ----pp_check1, message=FALSE----------------------------------------------------------- +pp_check(fit1, resp = "tarsus") +pp_check(fit1, resp = "back") + +## ----R2_1------------------------------------------------------------------------------- +bayes_R2(fit1) + +## ----fit2, message=FALSE, warning=FALSE, results='hide'--------------------------------- +bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) +bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) +fit2 <- brm(bf_tarsus + bf_back + set_rescor(TRUE), + data = BTdata, chains = 2, cores = 2) + +## ----summary2, warning=FALSE------------------------------------------------------------ +fit2 <- add_criterion(fit2, "loo") +summary(fit2) + +## ----loo12------------------------------------------------------------------------------ +loo(fit1, fit2) + +## ----fit3, message=FALSE, warning=FALSE, results='hide'--------------------------------- +bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + + lf(sigma ~ 0 + sex) + skew_normal() +bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + + gaussian() + +fit3 <- brm( + bf_tarsus + bf_back + set_rescor(FALSE), + data = BTdata, chains = 2, cores = 2, + control = list(adapt_delta = 0.95) +) + +## ----summary3, warning=FALSE------------------------------------------------------------ +fit3 <- add_criterion(fit3, "loo") +summary(fit3) + +## ----me3-------------------------------------------------------------------------------- +conditional_effects(fit3, "hatchdate", resp = "back") + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_multivariate.Rmd r-cran-brms-2.17.0/inst/doc/brms_multivariate.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_multivariate.Rmd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_multivariate.Rmd 2022-04-11 07:21:22.000000000 +0000 @@ -1,193 +1,195 @@ ---- -title: "Estimating Multivariate Models with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Multivariate Models with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -In the present vignette, we want to discuss how to specify multivariate multilevel models using **brms**. We call a model *multivariate* if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the `tarsus` length as well as the `back` color of chicks. Half of the brood were put into another `fosternest`, while the other half stayed in the fosternest of their own `dam`. This allows to separate genetic from environmental factors. Additionally, we have information about the `hatchdate` and `sex` of the chicks (the latter being known for 94\% of the animals). - -```{r data} -data("BTdata", package = "MCMCglmm") -head(BTdata) -``` - -## Basic Multivariate Models - -We begin with a relatively simple multivariate normal model. - -```{r fit1, message=FALSE, warning=FALSE, results='hide'} -fit1 <- brm( - mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam), - data = BTdata, chains = 2, cores = 2 -) -``` - -As can be seen in the model code, we have used `mvbind` notation to tell -**brms** that both `tarsus` and `back` are separate response variables. The term -`(1|p|fosternest)` indicates a varying intercept over `fosternest`. By writing -`|p|` in between we indicate that all varying effects of `fosternest` should be -modeled as correlated. This makes sense since we actually have two model parts, -one for `tarsus` and one for `back`. The indicator `p` is arbitrary and can be -replaced by other symbols that comes into your mind (for details about the -multilevel syntax of **brms**, see `help("brmsformula")` and -`vignette("brms_multilevel")`). Similarly, the term `(1|q|dam)` indicates -correlated varying effects of the genetic mother of the chicks. Alternatively, -we could have also modeled the genetic similarities through pedigrees and -corresponding relatedness matrices, but this is not the focus of this vignette -(please see `vignette("brms_phylogenetics")`). The model results are readily -summarized via - -```{r summary1, warning=FALSE} -fit1 <- add_criterion(fit1, "loo") -summary(fit1) -``` - -The summary output of multivariate models closely resembles those of univariate -models, except that the parameters now have the corresponding response variable -as prefix. Within dams, tarsus length and back color seem to be negatively -correlated, while within fosternests the opposite is true. This indicates -differential effects of genetic and environmental factors on these two -characteristics. Further, the small residual correlation `rescor(tarsus, back)` -on the bottom of the output indicates that there is little unmodeled dependency -between tarsus length and back color. Although not necessary at this point, we -have already computed and stored the LOO information criterion of `fit1`, which -we will use for model comparisons. Next, let's take a look at some -posterior-predictive checks, which give us a first impression of the model fit. - -```{r pp_check1, message=FALSE} -pp_check(fit1, resp = "tarsus") -pp_check(fit1, resp = "back") -``` - -This looks pretty solid, but we notice a slight unmodeled left skewness in the -distribution of `tarsus`. We will come back to this later on. Next, we want to -investigate how much variation in the response variables can be explained by our -model and we use a Bayesian generalization of the $R^2$ coefficient. - -```{r R2_1} -bayes_R2(fit1) -``` - -Clearly, there is much variation in both animal characteristics that we can not -explain, but apparently we can explain more of the variation in tarsus length -than in back color. - -## More Complex Multivariate Models - -Now, suppose we only want to control for `sex` in `tarsus` but not in `back` and -vice versa for `hatchdate`. Not that this is particular reasonable for the -present example, but it allows us to illustrate how to specify different -formulas for different response variables. We can no longer use `mvbind` syntax -and so we have to use a more verbose approach: - -```{r fit2, message=FALSE, warning=FALSE, results='hide'} -bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) -bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) -fit2 <- brm(bf_tarsus + bf_back, data = BTdata, chains = 2, cores = 2) -``` - -Note that we have literally *added* the two model parts via the `+` operator, -which is in this case equivalent to writing `mvbf(bf_tarsus, bf_back)`. See -`help("brmsformula")` and `help("mvbrmsformula")` for more details about this -syntax. Again, we summarize the model first. - -```{r summary2, warning=FALSE} -fit2 <- add_criterion(fit2, "loo") -summary(fit2) -``` - -Let's find out, how model fit changed due to excluding certain effects from the -initial model: - -```{r loo12} -loo(fit1, fit2) -``` - -Apparently, there is no noteworthy difference in the model fit. Accordingly, we -do not really need to model `sex` and `hatchdate` for both response variables, -but there is also no harm in including them (so I would probably just include -them). - -To give you a glimpse of the capabilities of **brms**' multivariate syntax, we -change our model in various directions at the same time. Remember the slight -left skewness of `tarsus`, which we will now model by using the `skew_normal` -family instead of the `gaussian` family. Since we do not have a multivariate -normal (or student-t) model, anymore, estimating residual correlations is no -longer possible. We make this explicit using the `set_rescor` function. Further, -we investigate if the relationship of `back` and `hatchdate` is really linear as -previously assumed by fitting a non-linear spline of `hatchdate`. On top of it, -we model separate residual variances of `tarsus` for male and female chicks. - -```{r fit3, message=FALSE, warning=FALSE, results='hide'} -bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + - lf(sigma ~ 0 + sex) + skew_normal() -bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + - gaussian() - -fit3 <- brm( - bf_tarsus + bf_back + set_rescor(FALSE), - data = BTdata, chains = 2, cores = 2, - control = list(adapt_delta = 0.95) -) -``` - -Again, we summarize the model and look at some posterior-predictive checks. - -```{r summary3, warning=FALSE} -fit3 <- add_criterion(fit3, "loo") -summary(fit3) -``` - -We see that the (log) residual standard deviation of `tarsus` is somewhat larger -for chicks whose sex could not be identified as compared to male or female -chicks. Further, we see from the negative `alpha` (skewness) parameter of -`tarsus` that the residuals are indeed slightly left-skewed. Lastly, running - -```{r me3} -conditional_effects(fit3, "hatchdate", resp = "back") -``` - -reveals a non-linear relationship of `hatchdate` on the `back` color, which -seems to change in waves over the course of the hatch dates. - -There are many more modeling options for multivariate models, which are not -discussed in this vignette. Examples include autocorrelation structures, -Gaussian processes, or explicit non-linear predictors (e.g., see -`help("brmsformula")` or `vignette("brms_multilevel")`). In fact, nearly all the -flexibility of univariate models is retained in multivariate models. - -## References - -Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic -gambit: phenotypic, genetic and environmental correlations of colour. -*Journal of Evolutionary Biology*, 20(2), 549-557. +--- +title: "Estimating Multivariate Models with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Multivariate Models with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +In the present vignette, we want to discuss how to specify multivariate multilevel models using **brms**. We call a model *multivariate* if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the `tarsus` length as well as the `back` color of chicks. Half of the brood were put into another `fosternest`, while the other half stayed in the fosternest of their own `dam`. This allows to separate genetic from environmental factors. Additionally, we have information about the `hatchdate` and `sex` of the chicks (the latter being known for 94\% of the animals). + +```{r data} +data("BTdata", package = "MCMCglmm") +head(BTdata) +``` + +## Basic Multivariate Models + +We begin with a relatively simple multivariate normal model. + +```{r fit1, message=FALSE, warning=FALSE, results='hide'} +bform1 <- + bf(mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam)) + + set_rescor(TRUE) + +fit1 <- brm(bform1, data = BTdata, chains = 2, cores = 2) +``` + +As can be seen in the model code, we have used `mvbind` notation to tell +**brms** that both `tarsus` and `back` are separate response variables. The term +`(1|p|fosternest)` indicates a varying intercept over `fosternest`. By writing +`|p|` in between we indicate that all varying effects of `fosternest` should be +modeled as correlated. This makes sense since we actually have two model parts, +one for `tarsus` and one for `back`. The indicator `p` is arbitrary and can be +replaced by other symbols that comes into your mind (for details about the +multilevel syntax of **brms**, see `help("brmsformula")` and +`vignette("brms_multilevel")`). Similarly, the term `(1|q|dam)` indicates +correlated varying effects of the genetic mother of the chicks. Alternatively, +we could have also modeled the genetic similarities through pedigrees and +corresponding relatedness matrices, but this is not the focus of this vignette +(please see `vignette("brms_phylogenetics")`). The model results are readily +summarized via + +```{r summary1, warning=FALSE} +fit1 <- add_criterion(fit1, "loo") +summary(fit1) +``` + +The summary output of multivariate models closely resembles those of univariate +models, except that the parameters now have the corresponding response variable +as prefix. Within dams, tarsus length and back color seem to be negatively +correlated, while within fosternests the opposite is true. This indicates +differential effects of genetic and environmental factors on these two +characteristics. Further, the small residual correlation `rescor(tarsus, back)` +on the bottom of the output indicates that there is little unmodeled dependency +between tarsus length and back color. Although not necessary at this point, we +have already computed and stored the LOO information criterion of `fit1`, which +we will use for model comparisons. Next, let's take a look at some +posterior-predictive checks, which give us a first impression of the model fit. + +```{r pp_check1, message=FALSE} +pp_check(fit1, resp = "tarsus") +pp_check(fit1, resp = "back") +``` + +This looks pretty solid, but we notice a slight unmodeled left skewness in the +distribution of `tarsus`. We will come back to this later on. Next, we want to +investigate how much variation in the response variables can be explained by our +model and we use a Bayesian generalization of the $R^2$ coefficient. + +```{r R2_1} +bayes_R2(fit1) +``` + +Clearly, there is much variation in both animal characteristics that we can not +explain, but apparently we can explain more of the variation in tarsus length +than in back color. + +## More Complex Multivariate Models + +Now, suppose we only want to control for `sex` in `tarsus` but not in `back` and +vice versa for `hatchdate`. Not that this is particular reasonable for the +present example, but it allows us to illustrate how to specify different +formulas for different response variables. We can no longer use `mvbind` syntax +and so we have to use a more verbose approach: + +```{r fit2, message=FALSE, warning=FALSE, results='hide'} +bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) +bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) +fit2 <- brm(bf_tarsus + bf_back + set_rescor(TRUE), + data = BTdata, chains = 2, cores = 2) +``` + +Note that we have literally *added* the two model parts via the `+` operator, +which is in this case equivalent to writing `mvbf(bf_tarsus, bf_back)`. See +`help("brmsformula")` and `help("mvbrmsformula")` for more details about this +syntax. Again, we summarize the model first. + +```{r summary2, warning=FALSE} +fit2 <- add_criterion(fit2, "loo") +summary(fit2) +``` + +Let's find out, how model fit changed due to excluding certain effects from the +initial model: + +```{r loo12} +loo(fit1, fit2) +``` + +Apparently, there is no noteworthy difference in the model fit. Accordingly, we +do not really need to model `sex` and `hatchdate` for both response variables, +but there is also no harm in including them (so I would probably just include +them). + +To give you a glimpse of the capabilities of **brms**' multivariate syntax, we +change our model in various directions at the same time. Remember the slight +left skewness of `tarsus`, which we will now model by using the `skew_normal` +family instead of the `gaussian` family. Since we do not have a multivariate +normal (or student-t) model, anymore, estimating residual correlations is no +longer possible. We make this explicit using the `set_rescor` function. Further, +we investigate if the relationship of `back` and `hatchdate` is really linear as +previously assumed by fitting a non-linear spline of `hatchdate`. On top of it, +we model separate residual variances of `tarsus` for male and female chicks. + +```{r fit3, message=FALSE, warning=FALSE, results='hide'} +bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + + lf(sigma ~ 0 + sex) + skew_normal() +bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + + gaussian() + +fit3 <- brm( + bf_tarsus + bf_back + set_rescor(FALSE), + data = BTdata, chains = 2, cores = 2, + control = list(adapt_delta = 0.95) +) +``` + +Again, we summarize the model and look at some posterior-predictive checks. + +```{r summary3, warning=FALSE} +fit3 <- add_criterion(fit3, "loo") +summary(fit3) +``` + +We see that the (log) residual standard deviation of `tarsus` is somewhat larger +for chicks whose sex could not be identified as compared to male or female +chicks. Further, we see from the negative `alpha` (skewness) parameter of +`tarsus` that the residuals are indeed slightly left-skewed. Lastly, running + +```{r me3} +conditional_effects(fit3, "hatchdate", resp = "back") +``` + +reveals a non-linear relationship of `hatchdate` on the `back` color, which +seems to change in waves over the course of the hatch dates. + +There are many more modeling options for multivariate models, which are not +discussed in this vignette. Examples include autocorrelation structures, +Gaussian processes, or explicit non-linear predictors (e.g., see +`help("brmsformula")` or `vignette("brms_multilevel")`). In fact, nearly all the +flexibility of univariate models is retained in multivariate models. + +## References + +Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic +gambit: phenotypic, genetic and environmental correlations of colour. +*Journal of Evolutionary Biology*, 20(2), 549-557. diff -Nru r-cran-brms-2.16.3/inst/doc/brms_nonlinear.html r-cran-brms-2.17.0/inst/doc/brms_nonlinear.html --- r-cran-brms-2.16.3/inst/doc/brms_nonlinear.html 2021-11-22 16:27:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_nonlinear.html 2022-04-11 08:11:12.000000000 +0000 @@ -1,488 +1,493 @@ - - - - - - - - - - - - - - - - -Estimating Non-Linear Models with brms - - - - - - - - - - - - - - - - - - - - - - - - - -

Estimating Non-Linear Models with brms

-

Paul Bürkner

-

2021-11-22

- - - - -
-

Introduction

-

This vignette provides an introduction on how to fit non-linear multilevel models with brms. Non-linear models are incredibly flexible and powerful, but require much more care with respect to model specification and priors than typical generalized linear models. Ignoring group-level effects for the moment, the predictor term \(\eta_n\) of a generalized linear model for observation \(n\) can be written as follows:

-

\[\eta_n = \sum_{i = 1}^K b_i x_{ni}\]

-

where \(b_i\) is the regression coefficient of predictor \(i\) and \(x_{ni}\) is the data of predictor \(i\) for observation \(n\). This also compromises interaction terms and various other data transformations. However, the structure of \(\eta_n\) is always linear in the sense that the regression coefficients \(b_i\) are multiplied by some predictor values and then summed up. This implies that the hypothetical predictor term

-

\[\eta_n = b_1 \exp(b_2 x_n)\]

-

would not be a linear predictor anymore and we could not fit it using classical techniques of generalized linear models. We thus need a more general model class, which we will call non-linear models. Note that the term ‘non-linear’ does not say anything about the assumed distribution of the response variable. In particular it does not mean ‘not normally distributed’ as we can apply non-linear predictor terms to all kinds of response distributions (for more details on response distributions available in brms see vignette("brms_families")).

-
-
-

A Simple Non-Linear Model

-

We begin with a simple example using simulated data.

-
b <- c(2, 0.75)
-x <- rnorm(100)
-y <- rnorm(100, mean = b[1] * exp(b[2] * x))
-dat1 <- data.frame(x, y)
-

As stated above, we cannot use a generalized linear model to estimate \(b\) so we go ahead an specify a non-linear model.

-
prior1 <- prior(normal(1, 2), nlpar = "b1") +
-  prior(normal(0, 2), nlpar = "b2")
-fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE),
-            data = dat1, prior = prior1)
-

When looking at the above code, the first thing that becomes obvious is that we changed the formula syntax to display the non-linear formula including predictors (i.e., x) and parameters (i.e., b1 and b2) wrapped in a call to bf. This stands in contrast to classical R formulas, where only predictors are given and parameters are implicit. The argument b1 + b2 ~ 1 serves two purposes. First, it provides information, which variables in formula are parameters, and second, it specifies the linear predictor terms for each parameter. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves (see also the following examples). In the present case, we have no further variables to predict b1 and b2 and thus we just fit intercepts that represent our estimates of \(b_1\) and \(b_2\) in the model equation above. The formula b1 + b2 ~ 1 is a short form of b1 ~ 1, b2 ~ 1 that can be used if multiple non-linear parameters share the same formula. Setting nl = TRUE tells brms that the formula should be treated as non-linear.

-

In contrast to generalized linear models, priors on population-level parameters (i.e., ‘fixed effects’) are often mandatory to identify a non-linear model. Thus, brms requires the user to explicitly specify these priors. In the present example, we used a normal(1, 2) prior on (the population-level intercept of) b1, while we used a normal(0, 2) prior on (the population-level intercept of) b2. Setting priors is a non-trivial task in all kinds of models, especially in non-linear models, so you should always invest some time to think of appropriate priors. Quite often, you may be forced to change your priors after fitting a non-linear model for the first time, when you observe different MCMC chains converging to different posterior regions. This is a clear sign of an identification problem and one solution is to set stronger (i.e., more narrow) priors.

-

To obtain summaries of the fitted model, we apply

-
summary(fit1)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: y ~ b1 * exp(b2 * x) 
-         b1 ~ 1
-         b2 ~ 1
-   Data: dat1 (Number of observations: 100) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-b1_Intercept     2.04      0.13     1.78     2.30 1.00     1678     1777
-b2_Intercept     0.74      0.04     0.66     0.83 1.00     1650     1934
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     1.15      0.08     1.00     1.32 1.00     2288     2211
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(fit1)
-

-
plot(conditional_effects(fit1), points = TRUE)
-

-

The summary method reveals that we were able to recover the true parameter values pretty nicely. According to the plot method, our MCMC chains have converged well and to the same posterior. The conditional_effects method visualizes the model-implied (non-linear) regression line.

-

We might be also interested in comparing our non-linear model to a classical linear model.

-
fit2 <- brm(y ~ x, data = dat1)
-
summary(fit2)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: y ~ x 
-   Data: dat1 (Number of observations: 100) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept     2.76      0.15     2.48     3.05 1.00     3348     2515
-x             1.92      0.14     1.65     2.20 1.00     3921     2910
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     1.50      0.11     1.30     1.72 1.00     4319     2719
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

To investigate and compare model fit, we can apply graphical posterior predictive checks, which make use of the bayesplot package on the backend.

-
pp_check(fit1)
-

-
pp_check(fit2)
-

-

We can also easily compare model fit using leave-one-out cross-validation.

-
loo(fit1, fit2)
-
Output of model 'fit1':
-
-Computed from 4000 by 100 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -156.7  6.4
-p_loo         2.7  0.4
-looic       313.5 12.8
-------
-Monte Carlo SE of elpd_loo is 0.0.
-
-All Pareto k estimates are good (k < 0.5).
-See help('pareto-k-diagnostic') for details.
-
-Output of model 'fit2':
-
-Computed from 4000 by 100 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -183.6  7.8
-p_loo         3.6  1.0
-looic       367.3 15.5
-------
-Monte Carlo SE of elpd_loo is 0.0.
-
-All Pareto k estimates are good (k < 0.5).
-See help('pareto-k-diagnostic') for details.
-
-Model comparisons:
-     elpd_diff se_diff
-fit1   0.0       0.0  
-fit2 -26.9       7.8
-

Since smaller LOOIC values indicate better model fit, it is immediately evident that the non-linear model fits the data better, which is of course not too surprising since we simulated the data from exactly that model.

-
-
-

A Real-World Non-Linear model

-

On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows:

-

\[cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)\] \[\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)\]

-

The cumulative insurance payments \(cum\) will grow over time, and we model this dependency using the variable \(dev\). Further, \(ult_{AY}\) is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters \(\theta\) and \(\omega\), which are responsible for the growth of the cumulative loss and are assumed to be the same across years. The data is already shipped with brms.

-
data(loss)
-head(loss)
-
    AY dev      cum premium
-1 1991   6  357.848   10000
-2 1991  18 1124.788   10000
-3 1991  30 1735.330   10000
-4 1991  42 2182.708   10000
-5 1991  54 2745.596   10000
-6 1991  66 3319.994   10000
-

and translate the proposed model into a non-linear brms model.

-
fit_loss <- brm(
-  bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)),
-     ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, 
-     nl = TRUE),
-  data = loss, family = gaussian(),
-  prior = c(
-    prior(normal(5000, 1000), nlpar = "ult"),
-    prior(normal(1, 2), nlpar = "omega"),
-    prior(normal(45, 10), nlpar = "theta")
-  ),
-  control = list(adapt_delta = 0.9)
-)
-

We estimate a group-level effect of accident year (variable AY) for the ultimate loss ult. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in case of ult, contains only an varying intercept over year. Again, priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. We summarize the model using well known methods.

-
summary(fit_loss)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: cum ~ ult * (1 - exp(-(dev/theta)^omega)) 
-         ult ~ 1 + (1 | AY)
-         omega ~ 1
-         theta ~ 1
-   Data: loss (Number of observations: 55) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Group-Level Effects: 
-~AY (Number of levels: 10) 
-                  Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(ult_Intercept)   753.14    228.84   440.06  1351.81 1.00     1144     1832
-
-Population-Level Effects: 
-                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-ult_Intercept    5306.00    289.73  4751.68  5907.33 1.00     1136     1603
-omega_Intercept     1.33      0.05     1.24     1.43 1.00     2407     2385
-theta_Intercept    46.26      2.15    42.52    51.00 1.00     2382     2039
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma   140.01     15.62   113.70   175.42 1.00     2923     2557
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(fit_loss, N = 3, ask = FALSE)
-

-
conditional_effects(fit_loss)
-

-

Next, we show marginal effects separately for each year.

-
conditions <- data.frame(AY = unique(loss$AY))
-rownames(conditions) <- unique(loss$AY)
-me_loss <- conditional_effects(
-  fit_loss, conditions = conditions, 
-  re_formula = NULL, method = "predict"
-)
-plot(me_loss, ncol = 5, points = TRUE)
-

-

It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. For a more detailed discussion of this data set, see Section 4.5 in Gesmann & Morris (2020).

-
-
-

Advanced Item-Response Models

-

As a third example, we want to show how to model more advanced item-response models using the non-linear model framework of brms. For simplicity, suppose we have a single forced choice item with three alternatives of which only one is correct. Our response variable is whether a person answers the item correctly (1) or not (0). Person are assumed to vary in their ability to answer the item correctly. However, every person has a 33% chance of getting the item right just by guessing. We thus simulate some data to reflect this situation.

-
inv_logit <- function(x) 1 / (1 + exp(-x))
-ability <- rnorm(300)
-p <- 0.33 + 0.67 * inv_logit(ability)
-answer <- ifelse(runif(300, 0, 1) < p, 1, 0)
-dat_ir <- data.frame(ability, answer)
-

The most basic item-response model is equivalent to a simple logistic regression model.

-
fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli())
-

However, this model completely ignores the guessing probability and will thus likely come to biased estimates and predictions.

-
summary(fit_ir1)
-
 Family: bernoulli 
-  Links: mu = logit 
-Formula: answer ~ ability 
-   Data: dat_ir (Number of observations: 300) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept     0.99      0.14     0.73     1.26 1.00     2924     2922
-ability       0.73      0.13     0.47     0.99 1.00     2893     2508
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(conditional_effects(fit_ir1), points = TRUE)
-

-

A more sophisticated approach incorporating the guessing probability looks as follows:

-
fit_ir2 <- brm(
-  bf(answer ~ 0.33 + 0.67 * inv_logit(eta),
-     eta ~ ability, nl = TRUE),
-  data = dat_ir, family = bernoulli("identity"), 
-  prior = prior(normal(0, 5), nlpar = "eta")
-)
-

It is very important to set the link function of the bernoulli family to identity or else we will apply two link functions. This is because our non-linear predictor term already contains the desired link function (0.33 + 0.67 * inv_logit), but the bernoulli family applies the default logit link on top of it. This will of course lead to strange and uninterpretable results. Thus, please make sure that you set the link function to identity, whenever your non-linear predictor term already contains the desired link function.

-
summary(fit_ir2)
-
 Family: bernoulli 
-  Links: mu = identity 
-Formula: answer ~ 0.33 + 0.67 * inv_logit(eta) 
-         eta ~ ability
-   Data: dat_ir (Number of observations: 300) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-eta_Intercept     0.24      0.20    -0.19     0.61 1.00     2421     2251
-eta_ability       1.18      0.27     0.71     1.77 1.00     2282     2094
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(conditional_effects(fit_ir2), points = TRUE)
-

-

Comparing model fit via leave-one-out cross-validation

-
loo(fit_ir1, fit_ir2)
-
Output of model 'fit_ir1':
-
-Computed from 4000 by 300 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -165.6  8.3
-p_loo         2.0  0.2
-looic       331.2 16.5
-------
-Monte Carlo SE of elpd_loo is 0.0.
-
-All Pareto k estimates are good (k < 0.5).
-See help('pareto-k-diagnostic') for details.
-
-Output of model 'fit_ir2':
-
-Computed from 4000 by 300 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -164.5  8.5
-p_loo         2.4  0.3
-looic       329.1 17.0
-------
-Monte Carlo SE of elpd_loo is 0.0.
-
-All Pareto k estimates are good (k < 0.5).
-See help('pareto-k-diagnostic') for details.
-
-Model comparisons:
-        elpd_diff se_diff
-fit_ir2  0.0       0.0   
-fit_ir1 -1.1       1.5
-

shows that both model fit the data equally well, but remember that predictions of the first model might still be misleading as they may well be below the guessing probability for low ability values. Now, suppose that we don’t know the guessing probability and want to estimate it from the data. This can easily be done changing the previous model just a bit.

-
fit_ir3 <- brm(
-  bf(answer ~ guess + (1 - guess) * inv_logit(eta), 
-    eta ~ 0 + ability, guess ~ 1, nl = TRUE),
-  data = dat_ir, family = bernoulli("identity"), 
-  prior = c(
-    prior(normal(0, 5), nlpar = "eta"),
-    prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1)
-  )
-)
-

Here, we model the guessing probability as a non-linear parameter making sure that it cannot exceed the interval \([0, 1]\). We did not estimate an intercept for eta, as this will lead to a bias in the estimated guessing parameter (try it out; this is an excellent example of how careful one has to be in non-linear models).

-
summary(fit_ir3)
-
 Family: bernoulli 
-  Links: mu = identity 
-Formula: answer ~ guess + (1 - guess) * inv_logit(eta) 
-         eta ~ 0 + ability
-         guess ~ 1
-   Data: dat_ir (Number of observations: 300) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Population-Level Effects: 
-                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-eta_ability         1.32      0.27     0.83     1.88 1.00     3286     2860
-guess_Intercept     0.41      0.05     0.31     0.50 1.00     3108     2765
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(fit_ir3)
-

-
plot(conditional_effects(fit_ir3), points = TRUE)
-

-

The results show that we are able to recover the simulated model parameters with this non-linear model. Of course, real item-response data have multiple items so that accounting for item and person variability (e.g., using a multilevel model with varying intercepts) becomes necessary as we have multiple observations per item and person. Luckily, this can all be done within the non-linear framework of brms and I hope that this vignette serves as a good starting point.

-
-
-

References

-

Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. CAS Research Papers.

-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Estimating Non-Linear Models with brms + + + + + + + + + + + + + + + + + + + + + + + + + +

Estimating Non-Linear Models with brms

+

Paul Bürkner

+

2022-04-11

+ + + + +
+

Introduction

+

This vignette provides an introduction on how to fit non-linear multilevel models with brms. Non-linear models are incredibly flexible and powerful, but require much more care with respect to model specification and priors than typical generalized linear models. Ignoring group-level effects for the moment, the predictor term \(\eta_n\) of a generalized linear model for observation \(n\) can be written as follows:

+

\[\eta_n = \sum_{i = 1}^K b_i x_{ni}\]

+

where \(b_i\) is the regression coefficient of predictor \(i\) and \(x_{ni}\) is the data of predictor \(i\) for observation \(n\). This also comprises interaction terms and various other data transformations. However, the structure of \(\eta_n\) is always linear in the sense that the regression coefficients \(b_i\) are multiplied by some predictor values and then summed up. This implies that the hypothetical predictor term

+

\[\eta_n = b_1 \exp(b_2 x_n)\]

+

would not be a linear predictor anymore and we could not fit it using classical techniques of generalized linear models. We thus need a more general model class, which we will call non-linear models. Note that the term ‘non-linear’ does not say anything about the assumed distribution of the response variable. In particular it does not mean ‘not normally distributed’ as we can apply non-linear predictor terms to all kinds of response distributions (for more details on response distributions available in brms see vignette("brms_families")).

+
+
+

A Simple Non-Linear Model

+

We begin with a simple example using simulated data.

+
b <- c(2, 0.75)
+x <- rnorm(100)
+y <- rnorm(100, mean = b[1] * exp(b[2] * x))
+dat1 <- data.frame(x, y)
+

As stated above, we cannot use a generalized linear model to estimate \(b\) so we go ahead an specify a non-linear model.

+
prior1 <- prior(normal(1, 2), nlpar = "b1") +
+  prior(normal(0, 2), nlpar = "b2")
+fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE),
+            data = dat1, prior = prior1)
+

When looking at the above code, the first thing that becomes obvious is that we changed the formula syntax to display the non-linear formula including predictors (i.e., x) and parameters (i.e., b1 and b2) wrapped in a call to bf. This stands in contrast to classical R formulas, where only predictors are given and parameters are implicit. The argument b1 + b2 ~ 1 serves two purposes. First, it provides information, which variables in formula are parameters, and second, it specifies the linear predictor terms for each parameter. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves (see also the following examples). In the present case, we have no further variables to predict b1 and b2 and thus we just fit intercepts that represent our estimates of \(b_1\) and \(b_2\) in the model equation above. The formula b1 + b2 ~ 1 is a short form of b1 ~ 1, b2 ~ 1 that can be used if multiple non-linear parameters share the same formula. Setting nl = TRUE tells brms that the formula should be treated as non-linear.

+

In contrast to generalized linear models, priors on population-level parameters (i.e., ‘fixed effects’) are often mandatory to identify a non-linear model. Thus, brms requires the user to explicitly specify these priors. In the present example, we used a normal(1, 2) prior on (the population-level intercept of) b1, while we used a normal(0, 2) prior on (the population-level intercept of) b2. Setting priors is a non-trivial task in all kinds of models, especially in non-linear models, so you should always invest some time to think of appropriate priors. Quite often, you may be forced to change your priors after fitting a non-linear model for the first time, when you observe different MCMC chains converging to different posterior regions. This is a clear sign of an identification problem and one solution is to set stronger (i.e., more narrow) priors.

+

To obtain summaries of the fitted model, we apply

+
summary(fit1)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: y ~ b1 * exp(b2 * x) 
+         b1 ~ 1
+         b2 ~ 1
+   Data: dat1 (Number of observations: 100) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+b1_Intercept     2.02      0.10     1.83     2.21 1.00     1473     1548
+b2_Intercept     0.76      0.02     0.72     0.79 1.00     1493     1527
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     0.99      0.07     0.86     1.14 1.00     2150     2211
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(fit1)
+

+
plot(conditional_effects(fit1), points = TRUE)
+

+

The summary method reveals that we were able to recover the true parameter values pretty nicely. According to the plot method, our MCMC chains have converged well and to the same posterior. The conditional_effects method visualizes the model-implied (non-linear) regression line.

+

We might be also interested in comparing our non-linear model to a classical linear model.

+
fit2 <- brm(y ~ x, data = dat1)
+
summary(fit2)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: y ~ x 
+   Data: dat1 (Number of observations: 100) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept     2.83      0.23     2.38     3.29 1.00     3559     2791
+x             2.91      0.22     2.48     3.35 1.00     3553     2954
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     2.34      0.17     2.04     2.71 1.00     3769     2749
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

To investigate and compare model fit, we can apply graphical posterior predictive checks, which make use of the bayesplot package on the backend.

+
pp_check(fit1)
+

+
pp_check(fit2)
+

+

We can also easily compare model fit using leave-one-out cross-validation.

+
loo(fit1, fit2)
+
Output of model 'fit1':
+
+Computed from 4000 by 100 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -141.6  6.2
+p_loo         2.4  0.5
+looic       283.2 12.3
+------
+Monte Carlo SE of elpd_loo is 0.0.
+
+All Pareto k estimates are good (k < 0.5).
+See help('pareto-k-diagnostic') for details.
+
+Output of model 'fit2':
+
+Computed from 4000 by 100 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -233.6 22.7
+p_loo        12.4  7.8
+looic       467.3 45.4
+------
+Monte Carlo SE of elpd_loo is NA.
+
+Pareto k diagnostic values:
+                         Count Pct.    Min. n_eff
+(-Inf, 0.5]   (good)     98    98.0%   2556      
+ (0.5, 0.7]   (ok)        0     0.0%   <NA>      
+   (0.7, 1]   (bad)       0     0.0%   <NA>      
+   (1, Inf)   (very bad)  2     2.0%   27        
+See help('pareto-k-diagnostic') for details.
+
+Model comparisons:
+     elpd_diff se_diff
+fit1   0.0       0.0  
+fit2 -92.1      23.3
+

Since smaller LOOIC values indicate better model fit, it is immediately evident that the non-linear model fits the data better, which is of course not too surprising since we simulated the data from exactly that model.

+
+
+

A Real-World Non-Linear model

+

On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows:

+

\[cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)\] \[\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)\]

+

The cumulative insurance payments \(cum\) will grow over time, and we model this dependency using the variable \(dev\). Further, \(ult_{AY}\) is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters \(\theta\) and \(\omega\), which are responsible for the growth of the cumulative loss and are assumed to be the same across years. The data is already shipped with brms.

+
data(loss)
+head(loss)
+
    AY dev      cum premium
+1 1991   6  357.848   10000
+2 1991  18 1124.788   10000
+3 1991  30 1735.330   10000
+4 1991  42 2182.708   10000
+5 1991  54 2745.596   10000
+6 1991  66 3319.994   10000
+

and translate the proposed model into a non-linear brms model.

+
fit_loss <- brm(
+  bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)),
+     ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1,
+     nl = TRUE),
+  data = loss, family = gaussian(),
+  prior = c(
+    prior(normal(5000, 1000), nlpar = "ult"),
+    prior(normal(1, 2), nlpar = "omega"),
+    prior(normal(45, 10), nlpar = "theta")
+  ),
+  control = list(adapt_delta = 0.9)
+)
+

We estimate a group-level effect of accident year (variable AY) for the ultimate loss ult. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in case of ult, contains only an varying intercept over year. Again, priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. We summarize the model using well known methods.

+
summary(fit_loss)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: cum ~ ult * (1 - exp(-(dev/theta)^omega)) 
+         ult ~ 1 + (1 | AY)
+         omega ~ 1
+         theta ~ 1
+   Data: loss (Number of observations: 55) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Group-Level Effects: 
+~AY (Number of levels: 10) 
+                  Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(ult_Intercept)   734.69    222.97   425.23  1278.98 1.00     1272     1813
+
+Population-Level Effects: 
+                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+ult_Intercept    5298.16    287.81  4753.23  5873.93 1.00     1067     1873
+omega_Intercept     1.34      0.05     1.24     1.43 1.00     2536     2836
+theta_Intercept    46.15      2.13    42.38    50.84 1.00     2525     2389
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma   139.99     15.18   114.37   173.78 1.00     3045     2830
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(fit_loss, N = 3, ask = FALSE)
+

+
conditional_effects(fit_loss)
+

+

Next, we show marginal effects separately for each year.

+
conditions <- data.frame(AY = unique(loss$AY))
+rownames(conditions) <- unique(loss$AY)
+me_loss <- conditional_effects(
+  fit_loss, conditions = conditions,
+  re_formula = NULL, method = "predict"
+)
+plot(me_loss, ncol = 5, points = TRUE)
+

+

It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. For a more detailed discussion of this data set, see Section 4.5 in Gesmann & Morris (2020).

+
+
+

Advanced Item-Response Models

+

As a third example, we want to show how to model more advanced item-response models using the non-linear model framework of brms. For simplicity, suppose we have a single forced choice item with three alternatives of which only one is correct. Our response variable is whether a person answers the item correctly (1) or not (0). Person are assumed to vary in their ability to answer the item correctly. However, every person has a 33% chance of getting the item right just by guessing. We thus simulate some data to reflect this situation.

+
inv_logit <- function(x) 1 / (1 + exp(-x))
+ability <- rnorm(300)
+p <- 0.33 + 0.67 * inv_logit(ability)
+answer <- ifelse(runif(300, 0, 1) < p, 1, 0)
+dat_ir <- data.frame(ability, answer)
+

The most basic item-response model is equivalent to a simple logistic regression model.

+
fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli())
+

However, this model completely ignores the guessing probability and will thus likely come to biased estimates and predictions.

+
summary(fit_ir1)
+
 Family: bernoulli 
+  Links: mu = logit 
+Formula: answer ~ ability 
+   Data: dat_ir (Number of observations: 300) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept     0.88      0.14     0.61     1.15 1.00     2607     2301
+ability       0.69      0.15     0.40     0.99 1.00     2932     2155
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(conditional_effects(fit_ir1), points = TRUE)
+

+

A more sophisticated approach incorporating the guessing probability looks as follows:

+
fit_ir2 <- brm(
+  bf(answer ~ 0.33 + 0.67 * inv_logit(eta),
+     eta ~ ability, nl = TRUE),
+  data = dat_ir, family = bernoulli("identity"),
+  prior = prior(normal(0, 5), nlpar = "eta")
+)
+

It is very important to set the link function of the bernoulli family to identity or else we will apply two link functions. This is because our non-linear predictor term already contains the desired link function (0.33 + 0.67 * inv_logit), but the bernoulli family applies the default logit link on top of it. This will of course lead to strange and uninterpretable results. Thus, please make sure that you set the link function to identity, whenever your non-linear predictor term already contains the desired link function.

+
summary(fit_ir2)
+
 Family: bernoulli 
+  Links: mu = identity 
+Formula: answer ~ 0.33 + 0.67 * inv_logit(eta) 
+         eta ~ ability
+   Data: dat_ir (Number of observations: 300) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+eta_Intercept     0.15      0.19    -0.22     0.50 1.00     2637     2129
+eta_ability       0.99      0.24     0.56     1.48 1.00     3104     2284
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(conditional_effects(fit_ir2), points = TRUE)
+

+

Comparing model fit via leave-one-out cross-validation

+
loo(fit_ir1, fit_ir2)
+
Output of model 'fit_ir1':
+
+Computed from 4000 by 300 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -177.6  7.3
+p_loo         1.9  0.1
+looic       355.1 14.5
+------
+Monte Carlo SE of elpd_loo is 0.0.
+
+All Pareto k estimates are good (k < 0.5).
+See help('pareto-k-diagnostic') for details.
+
+Output of model 'fit_ir2':
+
+Computed from 4000 by 300 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -177.3  7.2
+p_loo         1.9  0.2
+looic       354.6 14.4
+------
+Monte Carlo SE of elpd_loo is 0.0.
+
+All Pareto k estimates are good (k < 0.5).
+See help('pareto-k-diagnostic') for details.
+
+Model comparisons:
+        elpd_diff se_diff
+fit_ir2  0.0       0.0   
+fit_ir1 -0.3       0.7
+

shows that both model fit the data equally well, but remember that predictions of the first model might still be misleading as they may well be below the guessing probability for low ability values. Now, suppose that we don’t know the guessing probability and want to estimate it from the data. This can easily be done changing the previous model just a bit.

+
fit_ir3 <- brm(
+  bf(answer ~ guess + (1 - guess) * inv_logit(eta),
+    eta ~ 0 + ability, guess ~ 1, nl = TRUE),
+  data = dat_ir, family = bernoulli("identity"),
+  prior = c(
+    prior(normal(0, 5), nlpar = "eta"),
+    prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1)
+  )
+)
+

Here, we model the guessing probability as a non-linear parameter making sure that it cannot exceed the interval \([0, 1]\). We did not estimate an intercept for eta, as this will lead to a bias in the estimated guessing parameter (try it out; this is an excellent example of how careful one has to be in non-linear models).

+
summary(fit_ir3)
+
 Family: bernoulli 
+  Links: mu = identity 
+Formula: answer ~ guess + (1 - guess) * inv_logit(eta) 
+         eta ~ 0 + ability
+         guess ~ 1
+   Data: dat_ir (Number of observations: 300) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Population-Level Effects: 
+                Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+eta_ability         1.07      0.26     0.59     1.63 1.00     2901     2794
+guess_Intercept     0.38      0.05     0.28     0.48 1.00     3102     2578
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(fit_ir3)
+

+
plot(conditional_effects(fit_ir3), points = TRUE)
+

+

The results show that we are able to recover the simulated model parameters with this non-linear model. Of course, real item-response data have multiple items so that accounting for item and person variability (e.g., using a multilevel model with varying intercepts) becomes necessary as we have multiple observations per item and person. Luckily, this can all be done within the non-linear framework of brms and I hope that this vignette serves as a good starting point.

+
+
+

References

+

Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. CAS Research Papers.

+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_nonlinear.R r-cran-brms-2.17.0/inst/doc/brms_nonlinear.R --- r-cran-brms-2.16.3/inst/doc/brms_nonlinear.R 2021-11-22 16:27:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_nonlinear.R 2022-04-11 08:11:11.000000000 +0000 @@ -1,128 +1,128 @@ -params <- -list(EVAL = TRUE) - -## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) - -## --------------------------------------------------------------------------------------- -b <- c(2, 0.75) -x <- rnorm(100) -y <- rnorm(100, mean = b[1] * exp(b[2] * x)) -dat1 <- data.frame(x, y) - -## ---- results='hide'-------------------------------------------------------------------- -prior1 <- prior(normal(1, 2), nlpar = "b1") + - prior(normal(0, 2), nlpar = "b2") -fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), - data = dat1, prior = prior1) - -## --------------------------------------------------------------------------------------- -summary(fit1) -plot(fit1) -plot(conditional_effects(fit1), points = TRUE) - -## ---- results='hide'-------------------------------------------------------------------- -fit2 <- brm(y ~ x, data = dat1) - -## --------------------------------------------------------------------------------------- -summary(fit2) - -## --------------------------------------------------------------------------------------- -pp_check(fit1) -pp_check(fit2) - -## --------------------------------------------------------------------------------------- -loo(fit1, fit2) - -## --------------------------------------------------------------------------------------- -data(loss) -head(loss) - -## ---- results='hide'-------------------------------------------------------------------- -fit_loss <- brm( - bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), - ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, - nl = TRUE), - data = loss, family = gaussian(), - prior = c( - prior(normal(5000, 1000), nlpar = "ult"), - prior(normal(1, 2), nlpar = "omega"), - prior(normal(45, 10), nlpar = "theta") - ), - control = list(adapt_delta = 0.9) -) - -## --------------------------------------------------------------------------------------- -summary(fit_loss) -plot(fit_loss, N = 3, ask = FALSE) -conditional_effects(fit_loss) - -## --------------------------------------------------------------------------------------- -conditions <- data.frame(AY = unique(loss$AY)) -rownames(conditions) <- unique(loss$AY) -me_loss <- conditional_effects( - fit_loss, conditions = conditions, - re_formula = NULL, method = "predict" -) -plot(me_loss, ncol = 5, points = TRUE) - -## --------------------------------------------------------------------------------------- -inv_logit <- function(x) 1 / (1 + exp(-x)) -ability <- rnorm(300) -p <- 0.33 + 0.67 * inv_logit(ability) -answer <- ifelse(runif(300, 0, 1) < p, 1, 0) -dat_ir <- data.frame(ability, answer) - -## ---- results='hide'-------------------------------------------------------------------- -fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) - -## --------------------------------------------------------------------------------------- -summary(fit_ir1) -plot(conditional_effects(fit_ir1), points = TRUE) - -## ---- results='hide'-------------------------------------------------------------------- -fit_ir2 <- brm( - bf(answer ~ 0.33 + 0.67 * inv_logit(eta), - eta ~ ability, nl = TRUE), - data = dat_ir, family = bernoulli("identity"), - prior = prior(normal(0, 5), nlpar = "eta") -) - -## --------------------------------------------------------------------------------------- -summary(fit_ir2) -plot(conditional_effects(fit_ir2), points = TRUE) - -## --------------------------------------------------------------------------------------- -loo(fit_ir1, fit_ir2) - -## ---- results='hide'-------------------------------------------------------------------- -fit_ir3 <- brm( - bf(answer ~ guess + (1 - guess) * inv_logit(eta), - eta ~ 0 + ability, guess ~ 1, nl = TRUE), - data = dat_ir, family = bernoulli("identity"), - prior = c( - prior(normal(0, 5), nlpar = "eta"), - prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) - ) -) - -## --------------------------------------------------------------------------------------- -summary(fit_ir3) -plot(fit_ir3) -plot(conditional_effects(fit_ir3), points = TRUE) - +params <- +list(EVAL = TRUE) + +## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) + +## --------------------------------------------------------------------------------------- +b <- c(2, 0.75) +x <- rnorm(100) +y <- rnorm(100, mean = b[1] * exp(b[2] * x)) +dat1 <- data.frame(x, y) + +## ---- results='hide'-------------------------------------------------------------------- +prior1 <- prior(normal(1, 2), nlpar = "b1") + + prior(normal(0, 2), nlpar = "b2") +fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), + data = dat1, prior = prior1) + +## --------------------------------------------------------------------------------------- +summary(fit1) +plot(fit1) +plot(conditional_effects(fit1), points = TRUE) + +## ---- results='hide'-------------------------------------------------------------------- +fit2 <- brm(y ~ x, data = dat1) + +## --------------------------------------------------------------------------------------- +summary(fit2) + +## --------------------------------------------------------------------------------------- +pp_check(fit1) +pp_check(fit2) + +## --------------------------------------------------------------------------------------- +loo(fit1, fit2) + +## --------------------------------------------------------------------------------------- +data(loss) +head(loss) + +## ---- results='hide'-------------------------------------------------------------------- +fit_loss <- brm( + bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), + ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, + nl = TRUE), + data = loss, family = gaussian(), + prior = c( + prior(normal(5000, 1000), nlpar = "ult"), + prior(normal(1, 2), nlpar = "omega"), + prior(normal(45, 10), nlpar = "theta") + ), + control = list(adapt_delta = 0.9) +) + +## --------------------------------------------------------------------------------------- +summary(fit_loss) +plot(fit_loss, N = 3, ask = FALSE) +conditional_effects(fit_loss) + +## --------------------------------------------------------------------------------------- +conditions <- data.frame(AY = unique(loss$AY)) +rownames(conditions) <- unique(loss$AY) +me_loss <- conditional_effects( + fit_loss, conditions = conditions, + re_formula = NULL, method = "predict" +) +plot(me_loss, ncol = 5, points = TRUE) + +## --------------------------------------------------------------------------------------- +inv_logit <- function(x) 1 / (1 + exp(-x)) +ability <- rnorm(300) +p <- 0.33 + 0.67 * inv_logit(ability) +answer <- ifelse(runif(300, 0, 1) < p, 1, 0) +dat_ir <- data.frame(ability, answer) + +## ---- results='hide'-------------------------------------------------------------------- +fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) + +## --------------------------------------------------------------------------------------- +summary(fit_ir1) +plot(conditional_effects(fit_ir1), points = TRUE) + +## ---- results='hide'-------------------------------------------------------------------- +fit_ir2 <- brm( + bf(answer ~ 0.33 + 0.67 * inv_logit(eta), + eta ~ ability, nl = TRUE), + data = dat_ir, family = bernoulli("identity"), + prior = prior(normal(0, 5), nlpar = "eta") +) + +## --------------------------------------------------------------------------------------- +summary(fit_ir2) +plot(conditional_effects(fit_ir2), points = TRUE) + +## --------------------------------------------------------------------------------------- +loo(fit_ir1, fit_ir2) + +## ---- results='hide'-------------------------------------------------------------------- +fit_ir3 <- brm( + bf(answer ~ guess + (1 - guess) * inv_logit(eta), + eta ~ 0 + ability, guess ~ 1, nl = TRUE), + data = dat_ir, family = bernoulli("identity"), + prior = c( + prior(normal(0, 5), nlpar = "eta"), + prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) + ) +) + +## --------------------------------------------------------------------------------------- +summary(fit_ir3) +plot(fit_ir3) +plot(conditional_effects(fit_ir3), points = TRUE) + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_nonlinear.Rmd r-cran-brms-2.17.0/inst/doc/brms_nonlinear.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_nonlinear.Rmd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_nonlinear.Rmd 2022-04-11 07:21:28.000000000 +0000 @@ -1,331 +1,331 @@ ---- -title: "Estimating Non-Linear Models with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Non-Linear Models with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -This vignette provides an introduction on how to fit non-linear multilevel -models with **brms**. Non-linear models are incredibly flexible and powerful, -but require much more care with respect to model specification and priors than -typical generalized linear models. Ignoring group-level effects for the moment, -the predictor term $\eta_n$ of a generalized linear model for observation $n$ -can be written as follows: - -$$\eta_n = \sum_{i = 1}^K b_i x_{ni}$$ - -where $b_i$ is the regression coefficient of predictor $i$ and $x_{ni}$ is the -data of predictor $i$ for observation $n$. This also compromises interaction -terms and various other data transformations. However, the structure of $\eta_n$ -is always linear in the sense that the regression coefficients $b_i$ are -multiplied by some predictor values and then summed up. This implies that the -hypothetical predictor term - -$$\eta_n = b_1 \exp(b_2 x_n)$$ - -would *not* be a *linear* predictor anymore and we could not fit it using -classical techniques of generalized linear models. We thus need a more general -model class, which we will call *non-linear* models. Note that the term -'non-linear' does not say anything about the assumed distribution of the -response variable. In particular it does not mean 'not normally distributed' as -we can apply non-linear predictor terms to all kinds of response distributions -(for more details on response distributions available in **brms** see -`vignette("brms_families")`). - -## A Simple Non-Linear Model - -We begin with a simple example using simulated data. - -```{r} -b <- c(2, 0.75) -x <- rnorm(100) -y <- rnorm(100, mean = b[1] * exp(b[2] * x)) -dat1 <- data.frame(x, y) -``` - -As stated above, we cannot use a generalized linear model to estimate $b$ so we -go ahead an specify a non-linear model. - -```{r, results='hide'} -prior1 <- prior(normal(1, 2), nlpar = "b1") + - prior(normal(0, 2), nlpar = "b2") -fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), - data = dat1, prior = prior1) -``` - -When looking at the above code, the first thing that becomes obvious is that we -changed the `formula` syntax to display the non-linear formula including -predictors (i.e., `x`) and parameters (i.e., `b1` and `b2`) wrapped in a call to -`bf`. This stands in contrast to classical **R** formulas, where only predictors -are given and parameters are implicit. The argument `b1 + b2 ~ 1` serves two -purposes. First, it provides information, which variables in `formula` are -parameters, and second, it specifies the linear predictor terms for each -parameter. In fact, we should think of non-linear parameters as placeholders for -linear predictor terms rather than as parameters themselves (see also the -following examples). In the present case, we have no further variables to -predict `b1` and `b2` and thus we just fit intercepts that represent our -estimates of $b_1$ and $b_2$ in the model equation above. The formula `b1 + b2 ~ -1` is a short form of `b1 ~ 1, b2 ~ 1` that can be used if multiple non-linear -parameters share the same formula. Setting `nl = TRUE` tells **brms** that the -formula should be treated as non-linear. - -In contrast to generalized linear models, priors on population-level parameters -(i.e., 'fixed effects') are often mandatory to identify a non-linear model. -Thus, **brms** requires the user to explicitly specify these priors. In the -present example, we used a `normal(1, 2)` prior on (the population-level -intercept of) `b1`, while we used a `normal(0, 2)` prior on (the -population-level intercept of) `b2`. Setting priors is a non-trivial task in all -kinds of models, especially in non-linear models, so you should always invest -some time to think of appropriate priors. Quite often, you may be forced to -change your priors after fitting a non-linear model for the first time, when you -observe different MCMC chains converging to different posterior regions. This is -a clear sign of an identification problem and one solution is to set stronger -(i.e., more narrow) priors. - -To obtain summaries of the fitted model, we apply - -```{r} -summary(fit1) -plot(fit1) -plot(conditional_effects(fit1), points = TRUE) -``` - -The `summary` method reveals that we were able to recover the true parameter -values pretty nicely. According to the `plot` method, our MCMC chains have -converged well and to the same posterior. The `conditional_effects` method -visualizes the model-implied (non-linear) regression line. - -We might be also interested in comparing our non-linear model to a classical -linear model. - -```{r, results='hide'} -fit2 <- brm(y ~ x, data = dat1) -``` - -```{r} -summary(fit2) -``` - -To investigate and compare model fit, we can apply graphical posterior -predictive checks, which make use of the **bayesplot** package on the backend. - -```{r} -pp_check(fit1) -pp_check(fit2) -``` - -We can also easily compare model fit using leave-one-out cross-validation. - -```{r} -loo(fit1, fit2) -``` - -Since smaller `LOOIC` values indicate better model fit, it is immediately -evident that the non-linear model fits the data better, which is of course not -too surprising since we simulated the data from exactly that model. - -## A Real-World Non-Linear model - -On his blog, Markus Gesmann predicts the growth of cumulative insurance loss -payments over time, originated from different origin years (see -https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). -We will use a slightly simplified version of his model for demonstration -purposes here. It looks as follows: - -$$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ -$$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ - -The cumulative insurance payments $cum$ will grow over time, and we model this -dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be -estimated) ultimate loss of accident each year. It constitutes a non-linear -parameter in our framework along with the parameters $\theta$ and $\omega$, -which are responsible for the growth of the cumulative loss and are assumed to -be the same across years. The data is already shipped with brms. - -```{r} -data(loss) -head(loss) -``` - -and translate the proposed model into a non-linear **brms** model. - -```{r, results='hide'} -fit_loss <- brm( - bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), - ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, - nl = TRUE), - data = loss, family = gaussian(), - prior = c( - prior(normal(5000, 1000), nlpar = "ult"), - prior(normal(1, 2), nlpar = "omega"), - prior(normal(45, 10), nlpar = "theta") - ), - control = list(adapt_delta = 0.9) -) -``` - -We estimate a group-level effect of accident year (variable `AY`) for the -ultimate loss `ult`. This also shows nicely how a non-linear parameter is -actually a placeholder for a linear predictor, which in case of `ult`, contains -only an varying intercept over year. Again, priors on population-level effects -are required and, for the present model, are actually mandatory to ensure -identifiability. We summarize the model using well known methods. - -```{r} -summary(fit_loss) -plot(fit_loss, N = 3, ask = FALSE) -conditional_effects(fit_loss) -``` - -Next, we show marginal effects separately for each year. - -```{r} -conditions <- data.frame(AY = unique(loss$AY)) -rownames(conditions) <- unique(loss$AY) -me_loss <- conditional_effects( - fit_loss, conditions = conditions, - re_formula = NULL, method = "predict" -) -plot(me_loss, ncol = 5, points = TRUE) -``` - -It is evident that there is some variation in cumulative loss across accident -years, for instance due to natural disasters happening only in certain years. -Further, we see that the uncertainty in the predicted cumulative loss is larger -for later years with fewer available data points. For a more detailed discussion -of this data set, see Section 4.5 in Gesmann & Morris (2020). - -## Advanced Item-Response Models - -As a third example, we want to show how to model more advanced item-response -models using the non-linear model framework of **brms**. For simplicity, suppose -we have a single forced choice item with three alternatives of which only one is -correct. Our response variable is whether a person answers the item correctly -(1) or not (0). Person are assumed to vary in their ability to answer the item -correctly. However, every person has a 33% chance of getting the item right just -by guessing. We thus simulate some data to reflect this situation. - -```{r} -inv_logit <- function(x) 1 / (1 + exp(-x)) -ability <- rnorm(300) -p <- 0.33 + 0.67 * inv_logit(ability) -answer <- ifelse(runif(300, 0, 1) < p, 1, 0) -dat_ir <- data.frame(ability, answer) -``` - -The most basic item-response model is equivalent to a simple logistic regression -model. - -```{r, results='hide'} -fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) -``` - -However, this model completely ignores the guessing probability and will thus -likely come to biased estimates and predictions. - -```{r} -summary(fit_ir1) -plot(conditional_effects(fit_ir1), points = TRUE) -``` - -A more sophisticated approach incorporating the guessing probability looks as -follows: - -```{r, results='hide'} -fit_ir2 <- brm( - bf(answer ~ 0.33 + 0.67 * inv_logit(eta), - eta ~ ability, nl = TRUE), - data = dat_ir, family = bernoulli("identity"), - prior = prior(normal(0, 5), nlpar = "eta") -) -``` - -It is very important to set the link function of the `bernoulli` family to -`identity` or else we will apply two link functions. This is because our -non-linear predictor term already contains the desired link function (`0.33 + -0.67 * inv_logit`), but the `bernoulli` family applies the default `logit` link -on top of it. This will of course lead to strange and uninterpretable results. -Thus, please make sure that you set the link function to `identity`, whenever -your non-linear predictor term already contains the desired link function. - -```{r} -summary(fit_ir2) -plot(conditional_effects(fit_ir2), points = TRUE) -``` - -Comparing model fit via leave-one-out cross-validation - -```{r} -loo(fit_ir1, fit_ir2) -``` - -shows that both model fit the data equally well, but remember that predictions -of the first model might still be misleading as they may well be below the -guessing probability for low ability values. Now, suppose that we don't know the -guessing probability and want to estimate it from the data. This can easily be -done changing the previous model just a bit. - -```{r, results='hide'} -fit_ir3 <- brm( - bf(answer ~ guess + (1 - guess) * inv_logit(eta), - eta ~ 0 + ability, guess ~ 1, nl = TRUE), - data = dat_ir, family = bernoulli("identity"), - prior = c( - prior(normal(0, 5), nlpar = "eta"), - prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) - ) -) -``` - -Here, we model the guessing probability as a non-linear parameter making sure -that it cannot exceed the interval $[0, 1]$. We did not estimate an intercept -for `eta`, as this will lead to a bias in the estimated guessing parameter (try -it out; this is an excellent example of how careful one has to be in non-linear -models). - -```{r} -summary(fit_ir3) -plot(fit_ir3) -plot(conditional_effects(fit_ir3), points = TRUE) -``` - -The results show that we are able to recover the simulated model parameters with -this non-linear model. Of course, real item-response data have multiple items so -that accounting for item and person variability (e.g., using a multilevel model -with varying intercepts) becomes necessary as we have multiple observations per -item and person. Luckily, this can all be done within the non-linear framework -of **brms** and I hope that this vignette serves as a good starting point. - -## References - -Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. -*CAS Research Papers*. +--- +title: "Estimating Non-Linear Models with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Non-Linear Models with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +This vignette provides an introduction on how to fit non-linear multilevel +models with **brms**. Non-linear models are incredibly flexible and powerful, +but require much more care with respect to model specification and priors than +typical generalized linear models. Ignoring group-level effects for the moment, +the predictor term $\eta_n$ of a generalized linear model for observation $n$ +can be written as follows: + +$$\eta_n = \sum_{i = 1}^K b_i x_{ni}$$ + +where $b_i$ is the regression coefficient of predictor $i$ and $x_{ni}$ is the +data of predictor $i$ for observation $n$. This also comprises interaction +terms and various other data transformations. However, the structure of $\eta_n$ +is always linear in the sense that the regression coefficients $b_i$ are +multiplied by some predictor values and then summed up. This implies that the +hypothetical predictor term + +$$\eta_n = b_1 \exp(b_2 x_n)$$ + +would *not* be a *linear* predictor anymore and we could not fit it using +classical techniques of generalized linear models. We thus need a more general +model class, which we will call *non-linear* models. Note that the term +'non-linear' does not say anything about the assumed distribution of the +response variable. In particular it does not mean 'not normally distributed' as +we can apply non-linear predictor terms to all kinds of response distributions +(for more details on response distributions available in **brms** see +`vignette("brms_families")`). + +## A Simple Non-Linear Model + +We begin with a simple example using simulated data. + +```{r} +b <- c(2, 0.75) +x <- rnorm(100) +y <- rnorm(100, mean = b[1] * exp(b[2] * x)) +dat1 <- data.frame(x, y) +``` + +As stated above, we cannot use a generalized linear model to estimate $b$ so we +go ahead an specify a non-linear model. + +```{r, results='hide'} +prior1 <- prior(normal(1, 2), nlpar = "b1") + + prior(normal(0, 2), nlpar = "b2") +fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), + data = dat1, prior = prior1) +``` + +When looking at the above code, the first thing that becomes obvious is that we +changed the `formula` syntax to display the non-linear formula including +predictors (i.e., `x`) and parameters (i.e., `b1` and `b2`) wrapped in a call to +`bf`. This stands in contrast to classical **R** formulas, where only predictors +are given and parameters are implicit. The argument `b1 + b2 ~ 1` serves two +purposes. First, it provides information, which variables in `formula` are +parameters, and second, it specifies the linear predictor terms for each +parameter. In fact, we should think of non-linear parameters as placeholders for +linear predictor terms rather than as parameters themselves (see also the +following examples). In the present case, we have no further variables to +predict `b1` and `b2` and thus we just fit intercepts that represent our +estimates of $b_1$ and $b_2$ in the model equation above. The formula `b1 + b2 ~ +1` is a short form of `b1 ~ 1, b2 ~ 1` that can be used if multiple non-linear +parameters share the same formula. Setting `nl = TRUE` tells **brms** that the +formula should be treated as non-linear. + +In contrast to generalized linear models, priors on population-level parameters +(i.e., 'fixed effects') are often mandatory to identify a non-linear model. +Thus, **brms** requires the user to explicitly specify these priors. In the +present example, we used a `normal(1, 2)` prior on (the population-level +intercept of) `b1`, while we used a `normal(0, 2)` prior on (the +population-level intercept of) `b2`. Setting priors is a non-trivial task in all +kinds of models, especially in non-linear models, so you should always invest +some time to think of appropriate priors. Quite often, you may be forced to +change your priors after fitting a non-linear model for the first time, when you +observe different MCMC chains converging to different posterior regions. This is +a clear sign of an identification problem and one solution is to set stronger +(i.e., more narrow) priors. + +To obtain summaries of the fitted model, we apply + +```{r} +summary(fit1) +plot(fit1) +plot(conditional_effects(fit1), points = TRUE) +``` + +The `summary` method reveals that we were able to recover the true parameter +values pretty nicely. According to the `plot` method, our MCMC chains have +converged well and to the same posterior. The `conditional_effects` method +visualizes the model-implied (non-linear) regression line. + +We might be also interested in comparing our non-linear model to a classical +linear model. + +```{r, results='hide'} +fit2 <- brm(y ~ x, data = dat1) +``` + +```{r} +summary(fit2) +``` + +To investigate and compare model fit, we can apply graphical posterior +predictive checks, which make use of the **bayesplot** package on the backend. + +```{r} +pp_check(fit1) +pp_check(fit2) +``` + +We can also easily compare model fit using leave-one-out cross-validation. + +```{r} +loo(fit1, fit2) +``` + +Since smaller `LOOIC` values indicate better model fit, it is immediately +evident that the non-linear model fits the data better, which is of course not +too surprising since we simulated the data from exactly that model. + +## A Real-World Non-Linear model + +On his blog, Markus Gesmann predicts the growth of cumulative insurance loss +payments over time, originated from different origin years (see +https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). +We will use a slightly simplified version of his model for demonstration +purposes here. It looks as follows: + +$$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ +$$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ + +The cumulative insurance payments $cum$ will grow over time, and we model this +dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be +estimated) ultimate loss of accident each year. It constitutes a non-linear +parameter in our framework along with the parameters $\theta$ and $\omega$, +which are responsible for the growth of the cumulative loss and are assumed to +be the same across years. The data is already shipped with brms. + +```{r} +data(loss) +head(loss) +``` + +and translate the proposed model into a non-linear **brms** model. + +```{r, results='hide'} +fit_loss <- brm( + bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), + ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, + nl = TRUE), + data = loss, family = gaussian(), + prior = c( + prior(normal(5000, 1000), nlpar = "ult"), + prior(normal(1, 2), nlpar = "omega"), + prior(normal(45, 10), nlpar = "theta") + ), + control = list(adapt_delta = 0.9) +) +``` + +We estimate a group-level effect of accident year (variable `AY`) for the +ultimate loss `ult`. This also shows nicely how a non-linear parameter is +actually a placeholder for a linear predictor, which in case of `ult`, contains +only an varying intercept over year. Again, priors on population-level effects +are required and, for the present model, are actually mandatory to ensure +identifiability. We summarize the model using well known methods. + +```{r} +summary(fit_loss) +plot(fit_loss, N = 3, ask = FALSE) +conditional_effects(fit_loss) +``` + +Next, we show marginal effects separately for each year. + +```{r} +conditions <- data.frame(AY = unique(loss$AY)) +rownames(conditions) <- unique(loss$AY) +me_loss <- conditional_effects( + fit_loss, conditions = conditions, + re_formula = NULL, method = "predict" +) +plot(me_loss, ncol = 5, points = TRUE) +``` + +It is evident that there is some variation in cumulative loss across accident +years, for instance due to natural disasters happening only in certain years. +Further, we see that the uncertainty in the predicted cumulative loss is larger +for later years with fewer available data points. For a more detailed discussion +of this data set, see Section 4.5 in Gesmann & Morris (2020). + +## Advanced Item-Response Models + +As a third example, we want to show how to model more advanced item-response +models using the non-linear model framework of **brms**. For simplicity, suppose +we have a single forced choice item with three alternatives of which only one is +correct. Our response variable is whether a person answers the item correctly +(1) or not (0). Person are assumed to vary in their ability to answer the item +correctly. However, every person has a 33% chance of getting the item right just +by guessing. We thus simulate some data to reflect this situation. + +```{r} +inv_logit <- function(x) 1 / (1 + exp(-x)) +ability <- rnorm(300) +p <- 0.33 + 0.67 * inv_logit(ability) +answer <- ifelse(runif(300, 0, 1) < p, 1, 0) +dat_ir <- data.frame(ability, answer) +``` + +The most basic item-response model is equivalent to a simple logistic regression +model. + +```{r, results='hide'} +fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) +``` + +However, this model completely ignores the guessing probability and will thus +likely come to biased estimates and predictions. + +```{r} +summary(fit_ir1) +plot(conditional_effects(fit_ir1), points = TRUE) +``` + +A more sophisticated approach incorporating the guessing probability looks as +follows: + +```{r, results='hide'} +fit_ir2 <- brm( + bf(answer ~ 0.33 + 0.67 * inv_logit(eta), + eta ~ ability, nl = TRUE), + data = dat_ir, family = bernoulli("identity"), + prior = prior(normal(0, 5), nlpar = "eta") +) +``` + +It is very important to set the link function of the `bernoulli` family to +`identity` or else we will apply two link functions. This is because our +non-linear predictor term already contains the desired link function (`0.33 + +0.67 * inv_logit`), but the `bernoulli` family applies the default `logit` link +on top of it. This will of course lead to strange and uninterpretable results. +Thus, please make sure that you set the link function to `identity`, whenever +your non-linear predictor term already contains the desired link function. + +```{r} +summary(fit_ir2) +plot(conditional_effects(fit_ir2), points = TRUE) +``` + +Comparing model fit via leave-one-out cross-validation + +```{r} +loo(fit_ir1, fit_ir2) +``` + +shows that both model fit the data equally well, but remember that predictions +of the first model might still be misleading as they may well be below the +guessing probability for low ability values. Now, suppose that we don't know the +guessing probability and want to estimate it from the data. This can easily be +done changing the previous model just a bit. + +```{r, results='hide'} +fit_ir3 <- brm( + bf(answer ~ guess + (1 - guess) * inv_logit(eta), + eta ~ 0 + ability, guess ~ 1, nl = TRUE), + data = dat_ir, family = bernoulli("identity"), + prior = c( + prior(normal(0, 5), nlpar = "eta"), + prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) + ) +) +``` + +Here, we model the guessing probability as a non-linear parameter making sure +that it cannot exceed the interval $[0, 1]$. We did not estimate an intercept +for `eta`, as this will lead to a bias in the estimated guessing parameter (try +it out; this is an excellent example of how careful one has to be in non-linear +models). + +```{r} +summary(fit_ir3) +plot(fit_ir3) +plot(conditional_effects(fit_ir3), points = TRUE) +``` + +The results show that we are able to recover the simulated model parameters with +this non-linear model. Of course, real item-response data have multiple items so +that accounting for item and person variability (e.g., using a multilevel model +with varying intercepts) becomes necessary as we have multiple observations per +item and person. Luckily, this can all be done within the non-linear framework +of **brms** and I hope that this vignette serves as a good starting point. + +## References + +Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. +*CAS Research Papers*. diff -Nru r-cran-brms-2.16.3/inst/doc/brms_overview.ltx r-cran-brms-2.17.0/inst/doc/brms_overview.ltx --- r-cran-brms-2.16.3/inst/doc/brms_overview.ltx 2020-07-08 07:08:40.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_overview.ltx 2022-03-13 16:10:29.000000000 +0000 @@ -1,522 +1,522 @@ -\documentclass[article, nojss]{jss} - -%\VignetteIndexEntry{Overview of the brms Package} -%\VignetteEngine{R.rsp::tex} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% almost as usual -\author{Paul-Christian B\"urkner} -\title{\pkg{brms}: An \proglang{R} Package for Bayesian Multilevel Models using \pkg{Stan}} - -%% for pretty printing and a nice hypersummary also set: -\Plainauthor{Paul-Christian B\"urkner} %% comma-separated -\Plaintitle{brms: An R Package for Bayesian Multilevel Models using Stan} %% without formatting -\Shorttitle{\pkg{brms}: Bayesian Multilevel Models using Stan} %% a short title (if necessary) - -%% an abstract and keywords -\Abstract{ - The \pkg{brms} package implements Bayesian multilevel models in \proglang{R} using the probabilistic programming language \pkg{Stan}. A wide range of distributions and link functions are supported, allowing users to fit -- among others -- linear, robust linear, binomial, Poisson, survival, response times, ordinal, quantile, zero-inflated, hurdle, and even non-linear models all in a multilevel context. Further modeling options include autocorrelation of the response variable, user defined covariance structures, censored data, as well as meta-analytic standard errors. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. In addition, model fit can easily be assessed and compared using posterior-predictive checks and leave-one-out cross-validation. If you use \pkg{brms}, please cite this article as published in the Journal of Statistical Software \citep{brms1}. -} -\Keywords{Bayesian inference, multilevel model, ordinal data, MCMC, \proglang{Stan}, \proglang{R}} -\Plainkeywords{Bayesian inference, multilevel model, ordinal data, MCMC, Stan, R} %% without formatting -%% at least one keyword must be supplied - -%% publication information -%% NOTE: Typically, this can be left commented and will be filled out by the technical editor -%% \Volume{50} -%% \Issue{9} -%% \Month{June} -%% \Year{2012} -%% \Submitdate{2012-06-04} -%% \Acceptdate{2012-06-04} - -%% The address of (at least) one author should be given -%% in the following format: -\Address{ - Paul-Christian B\"urkner\\ - E-mail: \email{paul.buerkner@gmail.com}\\ - URL: \url{https://paul-buerkner.github.io} -} -%% It is also possible to add a telephone and fax number -%% before the e-mail in the following format: -%% Telephone: +43/512/507-7103 -%% Fax: +43/512/507-2851 - - -%% for those who use Sweave please include the following line (with % symbols): -%% need no \usepackage{Sweave.sty} - -%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\begin{document} - -%% include your article here, just as usual -%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. - -\section{Introduction} - -Multilevel models (MLMs) offer a great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow the modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for \proglang{R} \citep{Rcore2015} have been developed to fit MLMs. Possibly the most widely known package in this area is \pkg{lme4} \citep{bates2015}, which uses maximum likelihood or restricted maximum likelihood methods for model fitting. Although alternative Bayesian methods have several advantages over frequentist approaches (e.g., the possibility of explicitly incorporating prior knowledge about parameters into the model), their practical use was limited for a long time because the posterior distributions of more complex models (such as MLMs) could not be found analytically. Markov chain Monte Carlo (MCMC) algorithms allowing to draw random samples from the posterior were not available or too time-consuming. In the last few decades, however, this has changed with the development of new algorithms and the rapid increase of general computing power. Today, several software packages implement these techniques, for instance \pkg{WinBugs} \citep{lunn2000, spiegelhalter2003}, \pkg{OpenBugs} \citep{spiegelhalter2007}, \pkg{JAGS} \citep{plummer2013}, \pkg{MCMCglmm} \citep{hadfield2010} and \pkg{Stan} \citep{stan2017, carpenter2017} to mention only a few. With the exception of the latter, all of these programs are primarily using combinations of Metropolis-Hastings updates \citep{metropolis1953,hastings1970} and Gibbs-sampling \citep{geman1984,gelfand1990}, sometimes also coupled with slice-sampling \citep{damien1999,neal2003}. One of the main problems of these algorithms is their rather slow convergence for high-dimensional models with correlated parameters \citep{neal2011,hoffman2014,gelman2014}. Furthermore, Gibbs-sampling requires priors to be conjugate to the likelihood of parameters in order to work efficiently \citep{gelman2014}, thus reducing the freedom of the researcher in choosing a prior that reflects his or her beliefs. In contrast, \pkg{Stan} implements Hamiltonian Monte Carlo \citep{duane1987, neal2011} and its extension, the No-U-Turn Sampler (NUTS) \citep{hoffman2014}. These algorithms converge much more quickly especially for high-dimensional models regardless of whether the priors are conjugate or not \citep{hoffman2014}. - -Similar to software packages like \pkg{WinBugs}, \pkg{Stan} comes with its own programming language, allowing for great modeling flexibility (cf., \citeauthor{stanM2017} \citeyear{stanM2017}; \citeauthor{carpenter2017} \citeyear{carpenter2017}). Many researchers may still hesitate to use \pkg{Stan} directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error prone process even for researchers familiar with Bayesian inference. The package \pkg{brms}, presented in this paper, aims at closing this gap (at least for MLMs) allowing the user to benefit from the merits of \pkg{Stan} only by using simple, \pkg{lme4}-like formula syntax. \pkg{brms} supports a wide range of distributions and link functions, allows for multiple grouping factors each with multiple group-level effects, autocorrelation of the response variable, user defined covariance structures, as well as flexible and explicit prior specifications. - -The purpose of the present article is to provide a general overview of the \pkg{brms} package (version 0.10.0). We begin by explaining the underlying structure of MLMs. Next, the software is introduced in detail using recurrence times of infection in kidney patients \citep{mcgilchrist1991} and ratings of inhaler instructions \citep{ezzet1991} as examples. We end by comparing \pkg{brms} to other \proglang{R} packages implementing MLMs and describe future plans for extending the package. - -\section{Model description} -\label{model} - -The core of every MLM is the prediction of the response $y$ through the linear combination $\eta$ of predictors transformed by the inverse link function $f$ assuming a certain distribution $D$ for $y$. We write -$$y_i \sim D(f(\eta_i), \theta)$$ -to stress the dependency on the $i\textsuperscript{th}$ data point. In many \proglang{R} packages, $D$ is also called the `family' and we will use this term in the following. The parameter $\theta$ describes additional family specific parameters that typically do not vary across data points, such as the standard deviation $\sigma$ in normal models or the shape $\alpha$ in Gamma or negative binomial models. The linear predictor can generally be written as -$$\eta = \mathbf{X} \beta + \mathbf{Z} u$$ -In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The response $y$ as well as $\mathbf{X}$ and $\mathbf{Z}$ make up the data, whereas $\beta$, $u$, and $\theta$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects. However, we avoid these terms in the present paper following the recommendations of \cite{gelmanMLM2006}, as they are not used unambiguously in the literature. Also, we want to make explicit that $u$ is a model parameter in the same manner as $\beta$ so that uncertainty in its estimates can be naturally evaluated. In fact, this is an important advantage of Bayesian MCMC methods as compared to maximum likelihood approaches, which do not treat $u$ as a parameter, but assume that it is part of the error term instead (cf., \citeauthor{fox2011}, \citeyear{fox2011}). - -Except for linear models, we do not incorporate an additional error term for every observation by default. If desired, such an error term can always be modeled using a grouping factor with as many levels as observations in the data. - -\subsection{Prior distributions} - -\subsubsection{Regression parameters at population-level} - -In \pkg{brms}, population-level parameters are not restricted to have normal priors. Instead, every parameter can have every one-dimensional prior implemented in \pkg{Stan}, for instance uniform, Cauchy or even Gamma priors. As a negative side effect of this flexibility, correlations between them cannot be modeled as parameters. If desired, point estimates of the correlations can be obtained after sampling has been done. By default, population level parameters have an improper flat prior over the reals. - -\subsubsection{Regression parameters at group-level} - -The group-level parameters $u$ are assumed to come from a multivariate normal distribution with mean zero and unknown covariance matrix $\mathbf{\Sigma}$: -$$u \sim N(0, \mathbf{\Sigma})$$ -As is generally the case, covariances between group-level parameters of different grouping factors are assumed to be zero. This implies that $\mathbf{Z}$ and $u$ can be split up into several matrices $\mathbf{Z_k}$ and parameter vectors $u_k$, where $k$ indexes grouping factors, so that the model can be simplified to -$$u_k \sim N(0, \mathbf{\Sigma_k})$$ -Usually, but not always, we can also assume group-level parameters associated with different levels (indexed by $j$) of the same grouping factor to be independent leading to -$$u_{kj} \sim N(0, \mathbf{V_k})$$ -The covariance matrices $\mathbf{V_k}$ are modeled as parameters. In most packages, an Inverse-Wishart distribution is used as a prior for $\mathbf{V_k}$. This is mostly because its conjugacy leads to good properties of Gibbs-Samplers \citep{gelman2014}. However, there are good arguments against the Inverse-Wishart prior \citep{natarajan2000, kass2006}. The NUTS-Sampler implemented in \pkg{Stan} does not require priors to be conjugate. This advantage is utilized in \pkg{brms}: $\mathbf{V_k}$ is parameterized in terms of a correlation matrix $\mathbf{\Omega_k}$ and a vector of standard deviations $\sigma_k$ through -$$\mathbf{V_k} = \mathbf{D}(\sigma_k) \mathbf{\Omega_k} \mathbf{D}(\sigma_k)$$ -where $\mathbf{D}(\sigma_k)$ denotes the diagonal matrix with diagonal elements $\sigma_k$. Priors are then specified for the parameters on the right hand side of the equation. For $\mathbf{\Omega_k}$, we use the LKJ-Correlation prior with parameter $\zeta > 0$ by \cite{lewandowski2009}\footnote{Internally, the Cholesky factor of the correlation matrix is used, as it is more efficient and numerically stable.}: -$$\mathbf{\Omega_k} \sim \mathrm{LKJ}(\zeta)$$ -The expected value of the LKJ-prior is the identity matrix (implying correlations of zero) for any positive value of $\zeta$, which can be interpreted like the shape parameter of a symmetric beta distribution \citep{stanM2017}. If $\zeta = 1$ (the default in \pkg{brms}) the density is uniform over correlation matrices of the respective dimension. If $\zeta > 1$, the identity matrix is the mode of the prior, with a sharper peak in the density for larger values of $\zeta$. If $0 < \zeta < 1$ the prior is U-shaped having a trough at the identity matrix, which leads to higher probabilities for non-zero correlations. For every element of $\sigma_k$, any prior can be applied that is defined on the non-negative reals only. As default in \pkg{brms}, we use a half Student-t prior with 3 degrees of freedom. This prior often leads to better convergence of the models than a half Cauchy prior, while still being relatively weakly informative. - -Sometimes -- for instance when modeling pedigrees -- different levels of the same grouping factor cannot be assumed to be independent. In this case, the covariance matrix of $u_k$ becomes -$$\mathbf{\Sigma_k} = \mathbf{V_k} \otimes \mathbf{A_k}$$ -where $\mathbf{A_k}$ is the known covariance matrix between levels and $\otimes$ is the Kronecker product. - -\subsubsection{Family specific parameters} - -For some families, additional parameters need to be estimated. In the current section, we only name the most important ones. Normal and Student's distributions need the parameter $\sigma$ to account for residual error variance. By default, $\sigma$ has a half Cauchy prior with a scale parameter that depends on the standard deviation of the response variable to remain only weakly informative regardless of response variable's scaling. Furthermore, Student's distributions needs the parameter $\nu$ representing the degrees of freedom. By default, $\nu$ has a wide gamma prior as proposed by \cite{juarez2010}. Gamma, Weibull, and negative binomial distributions need the shape parameter $\alpha$ that also has a wide gamma prior by default. - -\section{Parameter estimation} - -The \pkg{brms} package does not fit models itself but uses \pkg{Stan} on the back-end. Accordingly, all samplers implemented in \pkg{Stan} can be used to fit \pkg{brms} models. Currently, these are the static Hamiltonian Monte-Carlo (HMC) Sampler sometimes also referred to as Hybrid Monte-Carlo \citep{neal2011, neal2003, duane1987} and its extension the No-U-Turn Sampler (NUTS) by \cite{hoffman2014}. HMC-like algorithms produce samples that are much less autocorrelated than those of other samplers such as the random-walk Metropolis algorithm \citep{hoffman2014, Creutz1988}. The main drawback of this increased efficiency is the need to calculate the gradient of the log-posterior, which can be automated using algorithmic differentiation \citep{griewank2008} but is still a time-consuming process for more complex models. Thus, using HMC leads to higher quality samples but takes more time per sample than other algorithms typically applied. Another drawback of HMC is the need to pre-specify at least two parameters, which are both critical for the performance of HMC. The NUTS Sampler allows setting these parameters automatically thus eliminating the need for any hand-tuning, while still being at least as efficient as a well tuned HMC \citep{hoffman2014}. For more details on the sampling algorithms applied in \pkg{Stan}, see the \pkg{Stan} user's manual \citep{stanM2017} as well as \cite{hoffman2014}. - -In addition to the estimation of model parameters, \pkg{brms} allows drawing samples from the posterior predictive distribution as well as from the pointwise log-likelihood. Both can be used to assess model fit. The former allows a comparison between the actual response $y$ and the response $\hat{y}$ predicted by the model. The pointwise log-likelihood can be used, among others, to calculate the widely applicable information criterion (WAIC) proposed by \cite{watanabe2010} and leave-one-out cross-validation (LOO; \citealp{gelfand1992}; \citealp{vehtari2015}; see also \citealp{ionides2008}) both allowing to compare different models applied to the same data (lower WAICs and LOOs indicate better model fit). The WAIC can be viewed as an improvement of the popular deviance information criterion (DIC), which has been criticized by several authors (\citealp{vehtari2015}; \citealp{plummer2008}; \citealp{vanderlinde2005}; see also the discussion at the end of the original DIC paper by \citealp{spiegelhalter2002}) in part because of problems arising from fact that the DIC is only a point estimate. In \pkg{brms}, WAIC and LOO are implemented using the \pkg{loo} package \citep{loo2016} also following the recommendations of \cite{vehtari2015}. - -\section{Software} -\label{software} - -The \pkg{brms} package provides functions for fitting MLMs using \pkg{Stan} for full Bayesian inference. To install the latest release version of \pkg{brms} from CRAN, type \code{install.packages("brms")} within \proglang{R}. The current developmental version can be downloaded from GitHub via -\begin{Sinput} -devtools::install_github("paul-buerkner/brms") -\end{Sinput} -Additionally, a \proglang{C++} compiler is required. This is because \pkg{brms} internally creates \pkg{Stan} code, which is translated to \proglang{C++} and compiled afterwards. The program \pkg{Rtools} \citep{Rtools2015} comes with a \proglang{C++} compiler for Windows\footnote{During the installation process, there is an option to change the system \code{PATH}. Please make sure to check this options, because otherwise \pkg{Rtools} will not be available within \proglang{R}.}. -On OS X, one should use \pkg{Xcode} \citep{Xcode2015} from the App Store. To check whether the compiler can be called within \proglang{R}, run \code{system("g++ -v")} when using \pkg{Rtools} or \code{system("clang++ -v")} when using \pkg{Xcode}. If no warning occurs and a few lines of difficult to read system code are printed out, the compiler should work correctly. For more detailed instructions on how to get the compilers running, see the prerequisites section on \url{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}. - -Models are fitted in \pkg{brms} using the following procedure, which is also summarized in Figure~\ref{flowchart}. First, the user specifies the model using the \code{brm} function in a way typical for most model fitting \proglang{R} functions, that is by defining \code{formula}, \code{data}, and \code{family}, as well as some other optional arguments. Second, this information is processed and the \code{make_stancode} and \code{make_standata} functions are called. The former generates the model code in \pkg{Stan} language and the latter prepares the data for use in \pkg{Stan}. These two are the mandatory parts of every \pkg{Stan} model and without \pkg{brms}, users would have to specify them themselves. Third, \pkg{Stan} code and data as well as additional arguments (such as the number of iterations and chains) are passed to functions of the \pkg{rstan} package (the \proglang{R} interface of \pkg{Stan}; \citeauthor{stan2017}, \citeyear{stan2017}). Fourth, the model is fitted by \pkg{Stan} after translating and compiling it in \proglang{C++}. Fifth, after the model has been fitted and returned by \pkg{rstan}, the fitted model object is post-processed in \pkg{brms} among others by renaming the model parameters to be understood by the user. Sixth, the results can be investigated in \proglang{R} using various methods such as \code{summary}, \code{plot}, or \code{predict} (for a complete list of methods type \code{methods(class = "brmsfit")}). - -\begin{figure}[ht] - \centering - \includegraphics[height = 0.4\textheight, keepaspectratio]{flowchart.pdf} - \caption{High level description of the model fitting procedure used in \pkg{brms}.} - \label{flowchart} -\end{figure} - -\subsection{A worked example} - -In the following, we use an example about the recurrence time of an infection in kidney patients initially published by \cite{mcgilchrist1991}. The data set consists of 76 entries of 7 variables: -\begin{Sinput} -R> library("brms") -R> data("kidney") -R> head(kidney, n = 3) -\end{Sinput} -\begin{Soutput} - time censored patient recur age sex disease -1 8 0 1 1 28 male other -2 23 0 2 1 48 female GN -3 22 0 3 1 32 male other -\end{Soutput} -Variable \code{time} represents the recurrence time of the infection, -\code{censored} indicates if \code{time} is right censored (\code{1}) or not censored (\code{0}), variable \code{patient} is the patient id, and -\code{recur} indicates if it is the first or second recurrence in that patient. Finally, variables \code{age}, \code{sex}, and \code{disease} make up the predictors. - -\subsection[Fitting models with brms]{Fitting models with \pkg{brms}} - -The core of the \pkg{brms} package is the \code{brm} function and we will explain its argument structure using the example above. Suppose we want to predict the (possibly censored) recurrence time using a log-normal model, in which the intercept as well as the effect of \code{age} is nested within patients. Then, we may use the following code: -\begin{Sinput} -fit1 <- brm(formula = time | cens(censored) ~ age * sex + disease - + (1 + age|patient), - data = kidney, family = lognormal(), - prior = c(set_prior("normal(0,5)", class = "b"), - set_prior("cauchy(0,2)", class = "sd"), - set_prior("lkj(2)", class = "cor")), - warmup = 1000, iter = 2000, chains = 4, - control = list(adapt_delta = 0.95)) -\end{Sinput} - -\subsection[formula: Information on the response and predictors]{\code{formula}: Information on the response and predictors} - -Without doubt, \code{formula} is the most complicated argument, as it contains information on the response variable as well as on predictors at different levels of the model. Everything before the $\sim$ sign relates to the response part of \code{formula}. In the usual and most simple case, this is just one variable name (e.g., \code{time}). However, to incorporate additional information about the response, one can add one or more terms of the form \code{| fun(variable)}. \code{fun} may be one of a few functions defined internally in \pkg{brms} and \code{variable} corresponds to a variable in the data set supplied by the user. In this example, \code{cens} makes up the internal function that handles censored data, and \code{censored} is the variable that contains information on the censoring. Other available functions in this context are \code{weights} and \code{disp} to allow different sorts of weighting, \code{se} to specify known standard errors primarily for meta-analysis, \code{trunc} to define truncation boundaries, \code{trials} for binomial models\footnote{In functions such as \code{glm} or \code{glmer}, the binomial response is typically passed as \code{cbind(success, failure)}. In \pkg{brms}, the equivalent syntax is \code{success | trials(success + failure)}.}, and \code{cat} to specify the number of categories for ordinal models. - -Everything on the right side of $\sim$ specifies predictors. Here, the syntax exactly matches that of \pkg{lme4}. For both, population-level and group-level terms, the \code{+} is used to separate different effects from each other. Group-level terms are of the form \code{(coefs | group)}, where \code{coefs} contains one or more variables whose effects are assumed to vary with the levels of the grouping factor given in \code{group}. Multiple grouping factors each with multiple group-level coefficients are possible. In the present example, only one group-level term is specified in which \code{1 + age} are the coefficients varying with the grouping factor \code{patient}. This implies that the intercept of the model as well as the effect of age is supposed to vary between patients. By default, group-level coefficients within a grouping factor are assumed to be correlated. Correlations can be set to zero by using the \code{(coefs || group)} syntax\footnote{In contrast to \pkg{lme4}, the \code{||} operator in \pkg{brms} splits up the design matrix computed from \code{coefs} instead of decomposing \code{coefs} in its terms. This implies that columns of the design matrix originating from the same factor are also assumed to be uncorrelated, whereas \pkg{lme4} estimates the correlations in this case. For a way to achieve \pkg{brms}-like behavior with \pkg{lme4}, see the \code{mixed} function of the \pkg{afex} package by \cite{afex2015}.}. Everything on the right side of \code{formula} that is not recognized as part of a group-level term is treated as a population-level effect. In this example, the population-level effects are \code{age}, \code{sex}, and \code{disease}. - -\subsection[family: Distribution of the response variable]{\code{family}: Distribution of the response variable} - -Argument \code{family} should usually be a family function, a call to a family function or a character string naming the family. If not otherwise specified, default link functions are applied. \pkg{brms} comes with a large variety of families. Linear and robust linear regression can be performed using the \code{gaussian} or \code{student} family combined with the \code{identity} link. For dichotomous and categorical data, families \code{bernoulli}, \code{binomial}, and \code{categorical} combined with the \code{logit} link, by default, are perfectly suited. Families \code{poisson}, \code{negbinomial}, and \code{geometric} allow for modeling count data. Families \code{lognormal}, \code{Gamma}, \code{exponential}, and \code{weibull} can be used (among others) for survival regression. Ordinal regression can be performed using the families \code{cumulative}, \code{cratio}, \code{sratio}, and \code{acat}. Finally, families \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, \code{zero_inflated_beta}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, and \code{hurdle_gamma} can be used to adequately model excess zeros in the response. In our example, we use \code{family = lognormal()} implying a log-normal ``survival'' model for the response variable \code{time}. - -\subsection[prior: Prior distributions of model parameters]{\code{prior}: Prior distributions of model parameters} - -Every population-level effect has its corresponding regression parameter. These parameters are named as \code{b\_}, where \code{} represents the name of the corresponding population-level effect. The default prior is an improper flat prior over the reals. Suppose, for instance, that we want to set a normal prior with mean \code{0} and standard deviation \code{10} on the effect of \code{age} and a Cauchy prior with location \code{1} and scale \code{2} on \code{sexfemale}\footnote{When factors are used as predictors, parameter names will depend on the factor levels. To get an overview of all parameters and parameter classes for which priors can be specified, use function \code{get\_prior}. For the present example, \code{get\_prior(time | cens(censored) $\sim$ age * sex + disease + (1 + age|patient), data = kidney, family = lognormal())} does the desired.}. Then, we may write -\begin{Sinput} -prior <- c(set_prior("normal(0,10)", class = "b", coef = "age"), - set_prior("cauchy(1,2)", class = "b", coef = "sexfemale")) -\end{Sinput} -To put the same prior (e.g., a normal prior) on all population-level effects at once, we may write as a shortcut \code{set_prior("normal(0,10)", class = "b")}. This also leads to faster sampling, because priors can be vectorized in this case. Note that we could also omit the \code{class} argument for population-level effects, as it is the default class in \code{set_prior}. - -A special shrinkage prior to be applied on population-level effects is the horseshoe prior \citep{carvalho2009, carvalho2010}. It is symmetric around zero with fat tails and an infinitely large spike at zero. This makes it ideal for sparse models that have many regression coefficients, although only a minority of them is non-zero. The horseshoe prior can be applied on all population-level effects at once (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. -The $1$ implies that the Student-$t$ prior of the local shrinkage parameters has 1 degrees of freedom. In \pkg{brms} it is possible to increase the degrees of freedom (which will often improve convergence), although the prior no longer resembles a horseshoe in this case\footnote{This class of priors is often referred to as hierarchical shrinkage family, which contains the original horseshoe prior as a special case.}. For more details see \cite{carvalho2009, carvalho2010}. - -Each group-level effect of each grouping factor has a standard deviation parameter, which is restricted to be non-negative and, by default, has a half Student-$t$ prior with $3$ degrees of freedom and a scale parameter that is minimally $10$. For non-ordinal models, \pkg{brms} tries to evaluate if the scale is large enough to be considered only weakly informative for the model at hand by comparing it with the standard deviation of the response after applying the link function. If this is not the case, it will increase the scale based on the aforementioned standard deviation\footnote{Changing priors based on the data is not truly Bayesian and might rightly be criticized. However, it helps avoiding the problem of too informative default priors without always forcing users to define their own priors. The latter would also be problematic as not all users can be expected to be well educated Bayesians and reasonable default priors will help them a lot in using Bayesian methods.}. \pkg{Stan} implicitly defines a half Student-$t$ prior by using a Student-$t$ prior on a restricted parameter \citep{stanM2017}. For other reasonable priors on standard deviations see \cite{gelman2006}. In \pkg{brms}, standard deviation parameters are named as \code{sd\_\_} so that \code{sd\_patient\_Intercept} and \code{sd\_patient\_age} are the parameter names in the example. If desired, it is possible to set a different prior on each parameter, but statements such as \code{set_prior("student_t(3,0,5)", class = "sd", group = "patient")} or even \code{set_prior("student_t(3,0,5)", class = "sd")} may also be used and are again faster because of vectorization. - -If there is more than one group-level effect per grouping factor, correlations between group-level effects are estimated. As mentioned in Section~\ref{model}, the LKJ-Correlation prior with parameter $\zeta > 0$ \citep{lewandowski2009} is used for this purpose. In \pkg{brms}, this prior is abbreviated as \code{"lkj(zeta)"} and correlation matrix parameters are named as \code{cor\_}, (e.g., \code{cor_patient}), so that \code{set_prior("lkj(2)", class = "cor", group = "patient")} is a valid statement. To set the same prior on every correlation matrix in the model, \code{set_prior("lkj(2)", class = "cor")} is also allowed, but does not come with any efficiency increases. - -Other model parameters such as the residual standard deviation \code{sigma} in normal models or the \code{shape} in Gamma models have their priors defined in the same way, where each of them is treated as having its own parameter class. A complete overview on possible prior distributions is given in the \pkg{Stan} user's manual \citep{stanM2017}. Note that \pkg{brms} does not thoroughly check if the priors are written in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their syntactical correctness when the model is parsed to \proglang{C++} and return an error if they are not. This, however, does not imply that priors are always meaningful if they are accepted by \pkg{Stan}. Although \pkg{brms} tries to find common problems (e.g., setting bounded priors on unbounded parameters), there is no guarantee that the defined priors are reasonable for the model. - -\subsection[control Adjusting the sampling behavior of Stan]{\code{control}: Adjusting the sampling behavior of \pkg{Stan}} - -In addition to choosing the number of iterations, warmup samples, and chains, users can control the behavior of the NUTS sampler by using the \code{control} argument. The most important reason to use \code{control} is to decrease (or eliminate at best) the number of divergent transitions that cause a bias in the obtained posterior samples. Whenever you see the warning \code{"There were x divergent transitions after warmup."}, you should really think about increasing \code{adapt_delta}. To do this, write \code{control = list(adapt_delta = )}, where \code{} should usually be a value between \code{0.8} (current default) and \code{1}. Increasing \code{adapt_delta} will slow down the sampler but will decrease the number of divergent transitions threatening the validity of your posterior samples. - -Another problem arises when the depth of the tree being evaluated in each iteration is exceeded. This is less common than having divergent transitions, but may also bias the posterior samples. When it happens, \pkg{Stan} will throw out a warning suggesting to increase \code{max_treedepth}, which can be accomplished by writing \code{control = list(max_treedepth = )} with a positive integer \code{} that should usually be larger than the current default of \code{10}. - -\subsection{Analyzing the results} - -The example model \code{fit1} is fitted using 4 chains, each with 2000 iterations of which the first 1000 are warmup to calibrate the sampler, leading to a total of 4000 posterior samples\footnote{To save time, chains may also run in parallel when using argument \code{cluster}.}. For researchers familiar with Gibbs or Metropolis-Hastings sampling, this number may seem far too small to achieve good convergence and reasonable results, especially for multilevel models. However, as \pkg{brms} utilizes the NUTS sampler \citep{hoffman2014} implemented in \pkg{Stan}, even complex models can often be fitted with not more than a few thousand samples. Of course, every iteration is more computationally intensive and time-consuming than the iterations of other algorithms, but the quality of the samples (i.e., the effective sample size per iteration) is usually higher. - -After the posterior samples have been computed, the \code{brm} function returns an \proglang{R} object, containing (among others) the fully commented model code in \pkg{Stan} language, the data to fit the model, and the posterior samples themselves. The model code and data for the present example can be extracted through \code{stancode(fit1)} and \code{standata(fit1)} respectively\footnote{Both model code and data may be amended and used to fit new models. That way, \pkg{brms} can also serve as a good starting point in building more complicated models in \pkg{Stan}, directly.}. A model summary is readily available using - -\begin{Sinput} -R> summary(fit1, waic = TRUE) -\end{Sinput} -\begin{Soutput} - Family: lognormal (identity) -Formula: time | cens(censored) ~ age * sex + disease + (1 + age | patient) - Data: kidney (Number of observations: 76) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: 673.51 - -Group-Level Effects: -~patient (Number of levels: 38) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 0.40 0.28 0.01 1.01 1731 1 -sd(age) 0.01 0.01 0.00 0.02 1137 1 -cor(Intercept,age) -0.13 0.46 -0.88 0.76 3159 1 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept 2.73 0.96 0.82 4.68 2139 1 -age 0.01 0.02 -0.03 0.06 1614 1 -sexfemale 2.42 1.13 0.15 4.64 2065 1 -diseaseGN -0.40 0.53 -1.45 0.64 2664 1 -diseaseAN -0.52 0.50 -1.48 0.48 2713 1 -diseasePKD 0.60 0.74 -0.86 2.02 2968 1 -age:sexfemale -0.02 0.03 -0.07 0.03 1956 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sigma 1.15 0.13 0.91 1.44 4000 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Soutput} - -On the top of the output, some general information on the model is given, such as family, formula, number of iterations and chains, as well as the WAIC. Next, group-level effects are displayed separately for each grouping factor in terms of standard deviations and correlations between group-level effects. On the bottom of the output, population-level effects are displayed. If incorporated, autocorrelation and family specific parameters (e.g., the residual standard deviation \code{sigma}) are also given. - -In general, every parameter is summarized using the mean (\code{Estimate}) and the standard deviation (\code{Est.Error}) of the posterior distribution as well as two-sided 95\% Credible intervals (\code{l-95\% CI} and \code{u-95\% CI}) based on quantiles. -The \code{Eff.Sample} value is an estimation of the effective sample size; that is the number of independent samples from the posterior distribution that would be expected to yield the same standard error of the posterior mean as is obtained from the dependent samples returned by the MCMC algorithm. The \code{Rhat} value provides information on the convergence of the algorithm (cf., \citeauthor{gelman1992}, \citeyear{gelman1992}). If \code{Rhat} is considerably greater than 1 (i.e., $> 1.1$), the chains have not yet converged and it is necessary to run more iterations and/or set stronger priors. - -To visually investigate the chains as well as the posterior distribution, the \code{plot} method can be used (see Figure~\ref{kidney_plot}). An even more detailed investigation can be achieved by applying the \pkg{shinystan} package \citep{gabry2015} through method \code{launch_shiny}. With respect to the above summary, \code{sexfemale} seems to be the only population-level effect with considerable influence on the response. Because the mean of \code{sexfemale} is positive, the model predicts longer periods without an infection for females than for males. Effects of population-level predictors can also be visualized with the \code{conditional_effects} method (see Figure~\ref{kidney_conditional_effects}). - -\begin{figure}[ht] - \centering - \includegraphics[width=0.95\textwidth]{kidney_plot.pdf} - \caption{Trace and Density plots of all relevant parameters of the kidney model discussed in Section~\ref{software}.} - \label{kidney_plot} -\end{figure} - -\begin{figure}[ht] - \centering - \includegraphics[height=0.90\textheight]{kidney_conditional_effects.pdf} - \caption{Conditional effects plots of all population-level predictors of the kidney model discussed in Section~\ref{software}.} - \label{kidney_conditional_effects} -\end{figure} - -Looking at the group-level effects, the standard deviation parameter of \code{age} is suspiciously small. To test whether it is smaller than the standard deviation parameter of \code{Intercept}, we apply the \code{hypothesis} method: -\begin{Sinput} -R> hypothesis(fit1, "Intercept - age > 0", class = "sd", group = "patient") -\end{Sinput} -\begin{Soutput} -Hypothesis Tests for class sd_patient: - Estimate Est.Error l-95% CI u-95% CI Evid.Ratio -Intercept-age > 0 0.39 0.27 0.03 Inf 67.97 * ---- -'*': The expected value under the hypothesis lies outside the 95% CI. -\end{Soutput} -The one-sided 95\% credibility interval does not contain zero, thus indicating that the standard deviations differ from each other in the expected direction. In accordance with this finding, the \code{Evid.Ratio} shows that the hypothesis being tested (i.e., \code{Intercept - age > 0}) is about $68$ times more likely than the alternative hypothesis \code{Intercept - age < 0}. It is important to note that this kind of comparison is not easily possible when applying frequentist methods, because in this case only point estimates are available for group-level standard deviations and correlations. - -When looking at the correlation between both group-level effects, its distribution displayed in Figure~\ref{kidney_plot} and the 95\% credibility interval in the summary output appear to be rather wide. This indicates that there is not enough evidence in the data to reasonably estimate the correlation. Together, the small standard deviation of \code{age} and the uncertainty in the correlation raise the question if \code{age} should be modeled as a group specific term at all. To answer this question, we fit another model without this term: -\begin{Sinput} -R> fit2 <- update(fit1, formula. = ~ . - (1 + age|patient) + (1|patient)) -\end{Sinput} - -A good way to compare both models is leave-one-out cross-validation (LOO)\footnote{The WAIC is an approximation of LOO that is faster and easier to compute. However, according to \cite{vehtari2015}, LOO may be the preferred method to perform model comparisons.}, which can be called in \pkg{brms} using -\begin{Sinput} -R> LOO(fit1, fit2) -\end{Sinput} -\begin{Soutput} - LOOIC SE -fit1 675.45 45.18 -fit2 674.17 45.06 -fit1 - fit2 1.28 0.99 -\end{Soutput} -In the output, the LOO information criterion for each model as well as the difference of the LOOs each with its corresponding standard error is shown. Both LOO and WAIC are approximately normal if the number of observations is large so that the standard errors can be very helpful in evaluating differences in the information criteria. However, for small sample sizes, standard errors should be interpreted with care \citep{vehtari2015}. For the present example, it is immediately evident that both models have very similar fit, indicating that there is little benefit in adding group specific coefficients for \code{age}. - -\subsection{Modeling ordinal data} - -In the following, we want to briefly discuss a second example to demonstrate the capabilities of \pkg{brms} in handling ordinal data. \cite{ezzet1991} analyze data from a two-treatment, two-period crossover trial to compare 2 inhalation devices for delivering the drug salbutamol in 286 asthma patients. Patients were asked to rate the clarity of leaflet instructions accompanying each device, using a four-point ordinal scale. Ratings are predicted by \code{treat} to indicate which of the two inhaler devices was used, \code{period} to indicate the time of administration, and \code{carry} to model possible carry over effects. -\begin{Sinput} -R> data("inhaler") -R> head(inhaler, n = 1) -\end{Sinput} -\begin{Soutput} - subject rating treat period carry -1 1 1 0.5 0.5 0 -\end{Soutput} - -Typically, the ordinal response is assumed to originate from the categorization of a latent continuous variable. That is there are $K$ latent thresholds (model intercepts), which partition the continuous scale into the $K + 1$ observable, ordered categories. Following this approach leads to the cumulative or graded-response model \citep{samejima1969} for ordinal data implemented in many \proglang{R} packages. In \pkg{brms}, it is available via family \code{cumulative}. Fitting the cumulative model to the inhaler data, also incorporating an intercept varying by subjects, may look this: -\begin{Sinput} -fit3 <- brm(formula = rating ~ treat + period + carry + (1|subject), - data = inhaler, family = cumulative) -\end{Sinput} -While the support for ordinal data in most \proglang{R} packages ends here\footnote{Exceptions known to us are the packages \pkg{ordinal} \citep{christensen2015} and \pkg{VGAM} \citep{yee2010}. The former supports only cumulative models but with different modeling option for the thresholds. The latter supports all four ordinal families also implemented in \pkg{brms} as well as category specific effects but no group-specific effects.}, \pkg{brms} allows changes to this basic model in at least three ways. First of all, three additional ordinal families are implemented. Families \code{sratio} (stopping ratio) and \code{cratio} (continuation ratio) are so called sequential models \citep{tutz1990}. Both are equivalent to each other for symmetric link functions such as \code{logit} but will differ for asymmetric ones such as \code{cloglog}. The fourth ordinal family is \code{acat} (adjacent category) also known as partial credits model \citep{masters1982, andrich1978a}. Second, restrictions to the thresholds can be applied. By default, thresholds are ordered for family \code{cumulative} or are completely free to vary for the other families. This is indicated by argument \code{threshold = "flexible"} (default) in \code{brm}. Using \code{threshold = "equidistant"} forces the distance between two adjacent thresholds to be the same, that is -$$\tau_k = \tau_1 + (k-1)\delta$$ -for thresholds $\tau_k$ and distance $\delta$ (see also \citealp{andrich1978b}; \citealp{andrich1978a}; \citealp{andersen1977}). -Third, the assumption that predictors have constant effects across categories may be relaxed for non-cumulative ordinal models \citep{vanderark2001, tutz2000} leading to category specific effects. For instance, variable \code{treat} may -only have an impact on the decision between category 3 and 4, but not on the lower categories. Without using category specific effects, such a pattern would remain invisible. - -To illustrate all three modeling options at once, we fit a (hardly theoretically justified) stopping ratio model with equidistant thresholds and category specific effects for variable \code{treat} on which we apply an informative prior. -\begin{Sinput} -fit4 <- brm(formula = rating ~ period + carry + cs(treat) + (1|subject), - data = inhaler, family = sratio, threshold = "equidistant", - prior = set_prior("normal(-1,2)", coef = "treat")) -\end{Sinput} -Note that priors are defined on category specific effects in the same way as for other population-level effects. A model summary can be obtained in the same way as before: -\begin{Sinput} -R> summary(fit4, waic = TRUE) -\end{Sinput} -\begin{Soutput} - Family: sratio (logit) -Formula: rating ~ period + carry + cs(treat) + (1 | subject) - Data: inhaler (Number of observations: 572) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: 911.9 - -Group-Level Effects: -~subject (Number of levels: 286) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 1.05 0.23 0.56 1.5 648 1 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept[1] 0.72 0.13 0.48 0.99 2048 1 -Intercept[2] 2.67 0.35 2.00 3.39 969 1 -Intercept[3] 4.62 0.66 3.36 5.95 1037 1 -period 0.25 0.18 -0.09 0.61 4000 1 -carry -0.26 0.22 -0.70 0.17 1874 1 -treat[1] -0.96 0.30 -1.56 -0.40 1385 1 -treat[2] -0.65 0.49 -1.60 0.27 4000 1 -treat[3] -2.65 1.21 -5.00 -0.29 4000 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -delta 1.95 0.32 1.33 2.6 1181 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Soutput} -Trace and density plots of the model parameters as produced by \code{plot(fit4)} can be found in Figure~\ref{inhaler_plot}. We see that three intercepts (thresholds) and three effects of \code{treat} have been estimated, because a four-point scale was used for the ratings. The treatment effect seems to be strongest between category 3 and 4. At the same time, however, the credible interval is also much larger. In fact, the intervals of all three effects of \code{treat} are highly overlapping, which indicates that there is not enough evidence in the data to support category specific effects. On the bottom of the output, parameter \code{delta} specifies the distance between two adjacent thresholds and indeed the intercepts differ from each other by the magnitude of \code{delta}. - -\begin{figure}[ht] - \centering - \includegraphics[width=0.95\textwidth]{inhaler_plot.pdf} - \caption{Trace and Density plots of all relevant parameters of the inhaler model discussed in Section~\ref{software}.} - \label{inhaler_plot} -\end{figure} - - -\section[Comparison]{Comparison between packages} - -Over the years, many \proglang{R} packages have been developed that implement MLMs, each being more or less general in their supported models. Comparing all of them to \pkg{brms} would be too extensive and barely helpful for the purpose of the present paper. Accordingly, we concentrate on a comparison with four packages. These are \pkg{lme4} \citep{bates2015} and \pkg{MCMCglmm} \citep{hadfield2010}, which are possibly the most general and widely applied \proglang{R} packages for MLMs, as well as \pkg{rstanarm} \citep{rstanarm2016} and \pkg{rethinking} \citep{mcelreath2016}, which are both based on \pkg{Stan}. As opposed to the other packages, \pkg{rethinking} was primarily written for teaching purposes and requires the user to specify the full model explicitly using its own simplified \pkg{BUGS}-like syntax thus helping users to better understand the models that are fitted to their data. - -Regarding model families, all five packages support the most common types such as linear and binomial models as well as Poisson models for count data. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. In addition, \pkg{brms} supports robust linear regression using Student's distribution, which is also implemented on a GitHub branch of \pkg{rstanarm}. \pkg{MCMCglmm} allows fitting multinomial models that are currently not available in the other packages. - -Generalizing classical MLMs, \pkg{brms} and \pkg{MCMCglmm} allow fiting zero-inflated and hurdle models dealing with excess zeros in the response. Furthermore, \pkg{brms} supports non-linear models similar to the \pkg{nlme} package \citep{nlme2016} providing great flexibility but also requiring more care to produce reasonable results. Another flexible model class are generalized additive mixed models \citep{hastie1990,wood2011,zuur2014}, which can be fitted with \pkg{brms} and \pkg{rstanarm}. - -In all five packages, there are quite a few additional modeling options. Variable link functions can be specified in all packages except for \pkg{MCMCglmm}, in which only one link is available per family. \pkg{MCMCglmm} generally supports multivariate responses using data in wide format, whereas \pkg{brms} currently only offers this option for families \code{gaussian} and \code{student}. It should be noted that it is always possible to transform data from wide to long format for compatibility with the other packages. Autocorrelation of the response can only be fitted in \pkg{brms}, which supports auto-regressive as well as moving-average effects. For ordinal models in \pkg{brms}, effects of predictors may vary across different levels of the response as explained in the inhaler example. A feature currently exclusive to \pkg{rethinking} is the possibility to impute missing values in the predictor variables. - -Information criteria are available in all three packages. The advantage of WAIC and LOO implemented in \pkg{brms}, \pkg{rstanarm}, and \pkg{rethinking} is that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the Bayesian packages, \pkg{brms} and \pkg{rethinking} offer a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, we believe that the way priors are specified in \pkg{brms} and \pkg{rethinking} is more intuitive as it is directly evident what prior is actually applied. A more detailed comparison of the packages can be found in Table~\ref{comparison1} and Table~\ref{comparison2}. To facilitate the understanding of the model formulation in \pkg{brms}, Table~\ref{syntax} shows \pkg{lme4} function calls to fit sample models along with the equivalent \pkg{brms} syntax. - -So far the focus was only on capabilities. Another important topic is speed, especially for more complex models. Of course, \pkg{lme4} is usually much faster than the other packages as it uses maximum likelihood methods instead of MCMC algorithms, which are slower by design. To compare the efficiency of the four Bayesian packages, we fitted multilevel models on real data sets using the minimum effective sample size divided by sampling time as a measure of sampling efficiency. One should always aim at running multiple chains as one cannot be sure that a single chain really explores the whole posterior distribution. However, as \pkg{MCMCglmm} does not come with a built-in option to run multiple chains, we used only a single chain to fit the models after making sure that it leads to the same results as multiple chains. The \proglang{R} code allowing to replicate the results is available as supplemental material. - -The first thing that becomes obvious when fitting the models is that \pkg{brms} and \pkg{rethinking} need to compile the \proglang{C++} model before actually fitting it, because the \pkg{Stan} code being parsed to \proglang{C++} is generated on the fly based on the user's input. Compilation takes about a half to one minute depending on the model complexity and computing power of the machine. This is not required by \pkg{rstanarm} and \pkg{MCMCglmm}, although the former is also based on \pkg{Stan}, as compilation takes place only once at installation time. While the latter approach saves the compilation time, the former is more flexible when it comes to model specification. For small and simple models, compilation time dominates the overall computation time, but for larger and more complex models, sampling will take several minutes or hours so that one minute more or less will not really matter, anymore. Accordingly, the following comparisons do not include the compilation time. - -In models containing only group-specific intercepts, \pkg{MCMCglmm} is usually more efficient than the \pkg{Stan} packages. However, when also estimating group-specific slopes, \pkg{MCMCglmm} falls behind the other packages and quite often refuses to sample at all unless one carefully specifies informative priors. Note that these results are obtained by running only a single chain. For all three \pkg{Stan} packages, sampling efficiency can easily be increased by running multiple chains in parallel. Comparing the \pkg{Stan} packages to each other, \pkg{brms} is usually most efficient for models with group-specific terms, whereas \pkg{rstanarm} tends to be roughly $50\%$ to $75\%$ as efficient at least for the analyzed data sets. The efficiency of \pkg{rethinking} is more variable depending on the model formulation and data, sometimes being slightly ahead of the other two packages, but usually being considerably less efficient. Generally, \pkg{rethinking} loses efficiency for models with many population-level effects presumably because one cannot use design matrices and vectorized prior specifications for population-level parameters. Note that it was not possible to specify the exact same priors across packages due to varying parameterizations. Of course, efficiency depends heavily on the model, chosen priors, and data at hand so that the present results should not be over-interpreted. - -\begin{table}[hbtp] -\centering -\begin{tabular}{llll} - & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{lme4}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline -\\ [-1.5ex] -\parbox{6cm}{Supported model types:} & & & \\ [1ex] -Linear models & yes & yes & yes \\ -Robust linear models & yes & no & no \\ -Binomial models & yes & yes & yes \\ -Categorical models & yes & no & yes \\ -Multinomial models & no & no & yes \\ -Count data models & yes & yes & yes \\ -Survival models & yes$^1$ & yes & yes \\ -Ordinal models & various & no & cumulative \\ -Zero-inflated and hurdle models & yes & no & yes \\ -Generalized additive models & yes & no & no \\ -Non-linear models & yes & no & no \\ \hline -\\ [-1.5ex] -\parbox{5cm}{Additional modeling options:} & & & \\ [1ex] -Variable link functions & various & various & no \\ -Weights & yes & yes & no \\ -Offset & yes & yes & using priors \\ -Multivariate responses & limited & no & yes \\ -Autocorrelation effects & yes & no & no \\ -Category specific effects & yes & no & no \\ -Standard errors for meta-analysis & yes & no & yes \\ -Censored data & yes & no & yes \\ -Truncated data & yes & no & no \\ -Customized covariances & yes & no & yes \\ -Missing value imputation & no & no & no \\ \hline -\\ [-1.5ex] -Bayesian specifics: & & & \\ [1ex] -parallelization & yes & -- & no \\ -population-level priors & flexible & --$^3$ & normal \\ -group-level priors & normal & --$^3$ & normal \\ -covariance priors & flexible & --$^3$ & restricted$^4$ \\ \hline -\\ [-1.5ex] -Other: & & & \\ [1ex] -Estimator & HMC, NUTS & ML, REML & MH, Gibbs$^2$ \\ -Information criterion & WAIC, LOO & AIC, BIC & DIC \\ -\proglang{C++} compiler required & yes & no & no \\ -Modularized & no & yes & no \\ \hline -\end{tabular} -\caption{Comparison of the capabilities of the \pkg{brms}, \pkg{lme4} and \pkg{MCMCglmm} package. Notes: (1) Weibull family only available in \pkg{brms}. (2) Estimator consists of a combination of both algorithms. (3) Priors may be imposed using the \pkg{blme} package \citep{chung2013}. (4) For details see \cite{hadfield2010}.} -\label{comparison1} -\end{table} - - -\begin{table}[hbtp] -\centering -\begin{tabular}{llll} - & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{rethinking}} \\ \hline -\\ [-1.5ex] -\parbox{6cm}{Supported model types:} & & & \\ [1ex] -Linear models & yes & yes & yes \\ -Robust linear models & yes & yes$^1$ & no \\ -Binomial models & yes & yes & yes \\ -Categorical models & yes & no & no \\ -Multinomial models & no & no & no \\ -Count data models & yes & yes & yes \\ -Survival models & yes$^2$ & yes & yes \\ -Ordinal models & various & cumulative$^3$ & no \\ -Zero-inflated and hurdle models & yes & no & no \\ -Generalized additive models & yes & yes & no \\ -Non-linear models & yes & no & limited$^4$ \\ \hline -\\ [-1.5ex] -\parbox{5cm}{Additional modeling options:} & & & \\ [1ex] -Variable link functions & various & various & various \\ -Weights & yes & yes & no \\ -Offset & yes & yes & yes \\ -Multivariate responses & limited & no & no \\ -Autocorrelation effects & yes & no & no \\ -Category specific effects & yes & no & no \\ -Standard errors for meta-analysis & yes & no & no \\ -Censored data & yes & no & no \\ -Truncated data & yes & no & yes \\ -Customized covariances & yes & no & no \\ -Missing value imputation & no & no & yes \\ \hline -\\ [-1.5ex] -Bayesian specifics: & & & \\ [1ex] -parallelization & yes & yes & yes \\ -population-level priors & flexible & normal, Student-t & flexible \\ -group-level priors & normal & normal & normal \\ -covariance priors & flexible & restricted$^5$ & flexible \\ \hline -\\ [-1.5ex] -Other: & & & \\ [1ex] -Estimator & HMC, NUTS & HMC, NUTS & HMC, NUTS \\ -Information criterion & WAIC, LOO & AIC, LOO & AIC, LOO \\ -\proglang{C++} compiler required & yes & no & yes \\ -Modularized & no & no & no \\ \hline -\end{tabular} -\caption{Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{rethinking} package. Notes: (1) Currently only implemented on a branch on GitHub. (2) Weibull family only available in \pkg{brms}. (3) No group-level terms allowed. (4) The parser is mainly written for linear models but also accepts some non-linear model specifications. (5) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}.} -\label{comparison2} -\end{table} - - -\begin{table}[hbtp] -\centering -%\renewcommand{\arraystretch}{2} -\begin{tabular}{ll} - Dataset & \parbox{10cm}{Function call} \\ \hline -\\ [-1.5ex] -\parbox{2cm}{cake} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{lmer(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{5ex} data = cake)}} \\ [3ex] -\pkg{brms} & \parbox{13cm}{\code{brm(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{4ex} data = cake)}} \\ [2ex] \hline -\\ [-1.5ex] -\parbox{2cm}{sleepstudy} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{lmer(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [1.5ex] -\pkg{brms} & \parbox{13cm}{\code{brm(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [2ex] \hline -\\ [-1.5ex] -\parbox{2cm}{cbpp$^1$} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{glmer(cbind(incidence, size - incidence) $\sim$ period + (1 | herd), \\ \hspace*{6ex} family = binomial("logit"), data = cbpp)}} \\ [3ex] -\pkg{brms} & \parbox{13cm}{\code{brm(incidence | trials(size) $\sim$ period + (1 | herd), \\ \hspace*{4ex} family = binomial("logit"), data = cbpp)}} \\ [2ex] \hline -\\ [-1.5ex] -\parbox{2cm}{grouseticks$^1$} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{glmer(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{6ex} family = poisson("log"), data = grouseticks)}} \\ [3ex] -\pkg{brms} & \parbox{13cm}{\code{brm(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{4ex} family = poisson("log"), data = grouseticks)}} \\ [2ex] \hline -\\ [-1ex] -\parbox{2cm}{VerbAgg$^2$} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{glmer(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{6ex} + (1|item), family = binomial, data = VerbAgg)}} \\ [3ex] -\pkg{brms} & \parbox{13cm}{\code{brm(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{4ex} + (1|item), family = bernoulli, data = VerbAgg)}} \\ [2ex] \hline -\\ [-1.5ex] -\end{tabular} -\caption{Comparison of the model syntax of \pkg{lme4} and \pkg{brms} using data sets included in \pkg{lme4}. Notes: (1) Default links are used to that the link argument may be omitted. (2) Fitting this model takes some time. A proper prior on the population-level effects (e.g., \code{prior = set\_prior("normal(0,5)")}) may help in increasing sampling speed.} -\label{syntax} -\end{table} - -\section{Conclusion} -The present paper is meant to provide a general overview on the \proglang{R} package \pkg{brms} implementing MLMs using the probabilistic programming language \pkg{Stan} for full Bayesian inference. Although only a small selection of the modeling options available in \pkg{brms} are discussed in detail, I hope that this article can serve as a good starting point to further explore the capabilities of the package. - -For the future, I have several plans on how to improve the functionality of \pkg{brms}. I want to include multivariate models that can handle multiple response variables coming from different distributions as well as new correlation structures for instance for spatial data. Similarily, distributional regression models as well as mixture response distributions appear to be valuable extensions of the package. I am always grateful for any suggestions and ideas regarding new features. - -\section*{Acknowledgments} - -First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language \pkg{Stan}, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Two anonymous reviewers provided very detailed and thoughtful suggestions to substantially improve both the package and the paper. Furthermore, Prof. Philipp Doebler and Prof. Heinz Holling have given valuable feedback on earlier versions of the paper. Lastly, I want to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. - -\bibliography{citations_overview} - -\end{document} +\documentclass[article, nojss]{jss} + +%\VignetteIndexEntry{Overview of the brms Package} +%\VignetteEngine{R.rsp::tex} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% almost as usual +\author{Paul-Christian B\"urkner} +\title{\pkg{brms}: An \proglang{R} Package for Bayesian Multilevel Models using \pkg{Stan}} + +%% for pretty printing and a nice hypersummary also set: +\Plainauthor{Paul-Christian B\"urkner} %% comma-separated +\Plaintitle{brms: An R Package for Bayesian Multilevel Models using Stan} %% without formatting +\Shorttitle{\pkg{brms}: Bayesian Multilevel Models using Stan} %% a short title (if necessary) + +%% an abstract and keywords +\Abstract{ + The \pkg{brms} package implements Bayesian multilevel models in \proglang{R} using the probabilistic programming language \pkg{Stan}. A wide range of distributions and link functions are supported, allowing users to fit -- among others -- linear, robust linear, binomial, Poisson, survival, response times, ordinal, quantile, zero-inflated, hurdle, and even non-linear models all in a multilevel context. Further modeling options include autocorrelation of the response variable, user defined covariance structures, censored data, as well as meta-analytic standard errors. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. In addition, model fit can easily be assessed and compared using posterior-predictive checks and leave-one-out cross-validation. If you use \pkg{brms}, please cite this article as published in the Journal of Statistical Software \citep{brms1}. +} +\Keywords{Bayesian inference, multilevel model, ordinal data, MCMC, \proglang{Stan}, \proglang{R}} +\Plainkeywords{Bayesian inference, multilevel model, ordinal data, MCMC, Stan, R} %% without formatting +%% at least one keyword must be supplied + +%% publication information +%% NOTE: Typically, this can be left commented and will be filled out by the technical editor +%% \Volume{50} +%% \Issue{9} +%% \Month{June} +%% \Year{2012} +%% \Submitdate{2012-06-04} +%% \Acceptdate{2012-06-04} + +%% The address of (at least) one author should be given +%% in the following format: +\Address{ + Paul-Christian B\"urkner\\ + E-mail: \email{paul.buerkner@gmail.com}\\ + URL: \url{https://paul-buerkner.github.io} +} +%% It is also possible to add a telephone and fax number +%% before the e-mail in the following format: +%% Telephone: +43/512/507-7103 +%% Fax: +43/512/507-2851 + + +%% for those who use Sweave please include the following line (with % symbols): +%% need no \usepackage{Sweave.sty} + +%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{document} + +%% include your article here, just as usual +%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. + +\section{Introduction} + +Multilevel models (MLMs) offer a great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow the modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for \proglang{R} \citep{Rcore2015} have been developed to fit MLMs. Possibly the most widely known package in this area is \pkg{lme4} \citep{bates2015}, which uses maximum likelihood or restricted maximum likelihood methods for model fitting. Although alternative Bayesian methods have several advantages over frequentist approaches (e.g., the possibility of explicitly incorporating prior knowledge about parameters into the model), their practical use was limited for a long time because the posterior distributions of more complex models (such as MLMs) could not be found analytically. Markov chain Monte Carlo (MCMC) algorithms allowing to draw random samples from the posterior were not available or too time-consuming. In the last few decades, however, this has changed with the development of new algorithms and the rapid increase of general computing power. Today, several software packages implement these techniques, for instance \pkg{WinBugs} \citep{lunn2000, spiegelhalter2003}, \pkg{OpenBugs} \citep{spiegelhalter2007}, \pkg{JAGS} \citep{plummer2013}, \pkg{MCMCglmm} \citep{hadfield2010} and \pkg{Stan} \citep{stan2017, carpenter2017} to mention only a few. With the exception of the latter, all of these programs are primarily using combinations of Metropolis-Hastings updates \citep{metropolis1953,hastings1970} and Gibbs-sampling \citep{geman1984,gelfand1990}, sometimes also coupled with slice-sampling \citep{damien1999,neal2003}. One of the main problems of these algorithms is their rather slow convergence for high-dimensional models with correlated parameters \citep{neal2011,hoffman2014,gelman2014}. Furthermore, Gibbs-sampling requires priors to be conjugate to the likelihood of parameters in order to work efficiently \citep{gelman2014}, thus reducing the freedom of the researcher in choosing a prior that reflects his or her beliefs. In contrast, \pkg{Stan} implements Hamiltonian Monte Carlo \citep{duane1987, neal2011} and its extension, the No-U-Turn Sampler (NUTS) \citep{hoffman2014}. These algorithms converge much more quickly especially for high-dimensional models regardless of whether the priors are conjugate or not \citep{hoffman2014}. + +Similar to software packages like \pkg{WinBugs}, \pkg{Stan} comes with its own programming language, allowing for great modeling flexibility (cf., \citeauthor{stanM2017} \citeyear{stanM2017}; \citeauthor{carpenter2017} \citeyear{carpenter2017}). Many researchers may still hesitate to use \pkg{Stan} directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error prone process even for researchers familiar with Bayesian inference. The package \pkg{brms}, presented in this paper, aims at closing this gap (at least for MLMs) allowing the user to benefit from the merits of \pkg{Stan} only by using simple, \pkg{lme4}-like formula syntax. \pkg{brms} supports a wide range of distributions and link functions, allows for multiple grouping factors each with multiple group-level effects, autocorrelation of the response variable, user defined covariance structures, as well as flexible and explicit prior specifications. + +The purpose of the present article is to provide a general overview of the \pkg{brms} package (version 0.10.0). We begin by explaining the underlying structure of MLMs. Next, the software is introduced in detail using recurrence times of infection in kidney patients \citep{mcgilchrist1991} and ratings of inhaler instructions \citep{ezzet1991} as examples. We end by comparing \pkg{brms} to other \proglang{R} packages implementing MLMs and describe future plans for extending the package. + +\section{Model description} +\label{model} + +The core of every MLM is the prediction of the response $y$ through the linear combination $\eta$ of predictors transformed by the inverse link function $f$ assuming a certain distribution $D$ for $y$. We write +$$y_i \sim D(f(\eta_i), \theta)$$ +to stress the dependency on the $i\textsuperscript{th}$ data point. In many \proglang{R} packages, $D$ is also called the `family' and we will use this term in the following. The parameter $\theta$ describes additional family specific parameters that typically do not vary across data points, such as the standard deviation $\sigma$ in normal models or the shape $\alpha$ in Gamma or negative binomial models. The linear predictor can generally be written as +$$\eta = \mathbf{X} \beta + \mathbf{Z} u$$ +In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The response $y$ as well as $\mathbf{X}$ and $\mathbf{Z}$ make up the data, whereas $\beta$, $u$, and $\theta$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects. However, we avoid these terms in the present paper following the recommendations of \cite{gelmanMLM2006}, as they are not used unambiguously in the literature. Also, we want to make explicit that $u$ is a model parameter in the same manner as $\beta$ so that uncertainty in its estimates can be naturally evaluated. In fact, this is an important advantage of Bayesian MCMC methods as compared to maximum likelihood approaches, which do not treat $u$ as a parameter, but assume that it is part of the error term instead (cf., \citeauthor{fox2011}, \citeyear{fox2011}). + +Except for linear models, we do not incorporate an additional error term for every observation by default. If desired, such an error term can always be modeled using a grouping factor with as many levels as observations in the data. + +\subsection{Prior distributions} + +\subsubsection{Regression parameters at population-level} + +In \pkg{brms}, population-level parameters are not restricted to have normal priors. Instead, every parameter can have every one-dimensional prior implemented in \pkg{Stan}, for instance uniform, Cauchy or even Gamma priors. As a negative side effect of this flexibility, correlations between them cannot be modeled as parameters. If desired, point estimates of the correlations can be obtained after sampling has been done. By default, population level parameters have an improper flat prior over the reals. + +\subsubsection{Regression parameters at group-level} + +The group-level parameters $u$ are assumed to come from a multivariate normal distribution with mean zero and unknown covariance matrix $\mathbf{\Sigma}$: +$$u \sim N(0, \mathbf{\Sigma})$$ +As is generally the case, covariances between group-level parameters of different grouping factors are assumed to be zero. This implies that $\mathbf{Z}$ and $u$ can be split up into several matrices $\mathbf{Z_k}$ and parameter vectors $u_k$, where $k$ indexes grouping factors, so that the model can be simplified to +$$u_k \sim N(0, \mathbf{\Sigma_k})$$ +Usually, but not always, we can also assume group-level parameters associated with different levels (indexed by $j$) of the same grouping factor to be independent leading to +$$u_{kj} \sim N(0, \mathbf{V_k})$$ +The covariance matrices $\mathbf{V_k}$ are modeled as parameters. In most packages, an Inverse-Wishart distribution is used as a prior for $\mathbf{V_k}$. This is mostly because its conjugacy leads to good properties of Gibbs-Samplers \citep{gelman2014}. However, there are good arguments against the Inverse-Wishart prior \citep{natarajan2000, kass2006}. The NUTS-Sampler implemented in \pkg{Stan} does not require priors to be conjugate. This advantage is utilized in \pkg{brms}: $\mathbf{V_k}$ is parameterized in terms of a correlation matrix $\mathbf{\Omega_k}$ and a vector of standard deviations $\sigma_k$ through +$$\mathbf{V_k} = \mathbf{D}(\sigma_k) \mathbf{\Omega_k} \mathbf{D}(\sigma_k)$$ +where $\mathbf{D}(\sigma_k)$ denotes the diagonal matrix with diagonal elements $\sigma_k$. Priors are then specified for the parameters on the right hand side of the equation. For $\mathbf{\Omega_k}$, we use the LKJ-Correlation prior with parameter $\zeta > 0$ by \cite{lewandowski2009}\footnote{Internally, the Cholesky factor of the correlation matrix is used, as it is more efficient and numerically stable.}: +$$\mathbf{\Omega_k} \sim \mathrm{LKJ}(\zeta)$$ +The expected value of the LKJ-prior is the identity matrix (implying correlations of zero) for any positive value of $\zeta$, which can be interpreted like the shape parameter of a symmetric beta distribution \citep{stanM2017}. If $\zeta = 1$ (the default in \pkg{brms}) the density is uniform over correlation matrices of the respective dimension. If $\zeta > 1$, the identity matrix is the mode of the prior, with a sharper peak in the density for larger values of $\zeta$. If $0 < \zeta < 1$ the prior is U-shaped having a trough at the identity matrix, which leads to higher probabilities for non-zero correlations. For every element of $\sigma_k$, any prior can be applied that is defined on the non-negative reals only. As default in \pkg{brms}, we use a half Student-t prior with 3 degrees of freedom. This prior often leads to better convergence of the models than a half Cauchy prior, while still being relatively weakly informative. + +Sometimes -- for instance when modeling pedigrees -- different levels of the same grouping factor cannot be assumed to be independent. In this case, the covariance matrix of $u_k$ becomes +$$\mathbf{\Sigma_k} = \mathbf{V_k} \otimes \mathbf{A_k}$$ +where $\mathbf{A_k}$ is the known covariance matrix between levels and $\otimes$ is the Kronecker product. + +\subsubsection{Family specific parameters} + +For some families, additional parameters need to be estimated. In the current section, we only name the most important ones. Normal and Student's distributions need the parameter $\sigma$ to account for residual error variance. By default, $\sigma$ has a half Cauchy prior with a scale parameter that depends on the standard deviation of the response variable to remain only weakly informative regardless of response variable's scaling. Furthermore, Student's distributions needs the parameter $\nu$ representing the degrees of freedom. By default, $\nu$ has a wide gamma prior as proposed by \cite{juarez2010}. Gamma, Weibull, and negative binomial distributions need the shape parameter $\alpha$ that also has a wide gamma prior by default. + +\section{Parameter estimation} + +The \pkg{brms} package does not fit models itself but uses \pkg{Stan} on the back-end. Accordingly, all samplers implemented in \pkg{Stan} can be used to fit \pkg{brms} models. Currently, these are the static Hamiltonian Monte-Carlo (HMC) Sampler sometimes also referred to as Hybrid Monte-Carlo \citep{neal2011, neal2003, duane1987} and its extension the No-U-Turn Sampler (NUTS) by \cite{hoffman2014}. HMC-like algorithms produce samples that are much less autocorrelated than those of other samplers such as the random-walk Metropolis algorithm \citep{hoffman2014, Creutz1988}. The main drawback of this increased efficiency is the need to calculate the gradient of the log-posterior, which can be automated using algorithmic differentiation \citep{griewank2008} but is still a time-consuming process for more complex models. Thus, using HMC leads to higher quality samples but takes more time per sample than other algorithms typically applied. Another drawback of HMC is the need to pre-specify at least two parameters, which are both critical for the performance of HMC. The NUTS Sampler allows setting these parameters automatically thus eliminating the need for any hand-tuning, while still being at least as efficient as a well tuned HMC \citep{hoffman2014}. For more details on the sampling algorithms applied in \pkg{Stan}, see the \pkg{Stan} user's manual \citep{stanM2017} as well as \cite{hoffman2014}. + +In addition to the estimation of model parameters, \pkg{brms} allows drawing samples from the posterior predictive distribution as well as from the pointwise log-likelihood. Both can be used to assess model fit. The former allows a comparison between the actual response $y$ and the response $\hat{y}$ predicted by the model. The pointwise log-likelihood can be used, among others, to calculate the widely applicable information criterion (WAIC) proposed by \cite{watanabe2010} and leave-one-out cross-validation (LOO; \citealp{gelfand1992}; \citealp{vehtari2015}; see also \citealp{ionides2008}) both allowing to compare different models applied to the same data (lower WAICs and LOOs indicate better model fit). The WAIC can be viewed as an improvement of the popular deviance information criterion (DIC), which has been criticized by several authors (\citealp{vehtari2015}; \citealp{plummer2008}; \citealp{vanderlinde2005}; see also the discussion at the end of the original DIC paper by \citealp{spiegelhalter2002}) in part because of problems arising from fact that the DIC is only a point estimate. In \pkg{brms}, WAIC and LOO are implemented using the \pkg{loo} package \citep{loo2016} also following the recommendations of \cite{vehtari2015}. + +\section{Software} +\label{software} + +The \pkg{brms} package provides functions for fitting MLMs using \pkg{Stan} for full Bayesian inference. To install the latest release version of \pkg{brms} from CRAN, type \code{install.packages("brms")} within \proglang{R}. The current developmental version can be downloaded from GitHub via +\begin{Sinput} +devtools::install_github("paul-buerkner/brms") +\end{Sinput} +Additionally, a \proglang{C++} compiler is required. This is because \pkg{brms} internally creates \pkg{Stan} code, which is translated to \proglang{C++} and compiled afterwards. The program \pkg{Rtools} \citep{Rtools2015} comes with a \proglang{C++} compiler for Windows\footnote{During the installation process, there is an option to change the system \code{PATH}. Please make sure to check this options, because otherwise \pkg{Rtools} will not be available within \proglang{R}.}. +On OS X, one should use \pkg{Xcode} \citep{Xcode2015} from the App Store. To check whether the compiler can be called within \proglang{R}, run \code{system("g++ -v")} when using \pkg{Rtools} or \code{system("clang++ -v")} when using \pkg{Xcode}. If no warning occurs and a few lines of difficult to read system code are printed out, the compiler should work correctly. For more detailed instructions on how to get the compilers running, see the prerequisites section on \url{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}. + +Models are fitted in \pkg{brms} using the following procedure, which is also summarized in Figure~\ref{flowchart}. First, the user specifies the model using the \code{brm} function in a way typical for most model fitting \proglang{R} functions, that is by defining \code{formula}, \code{data}, and \code{family}, as well as some other optional arguments. Second, this information is processed and the \code{make_stancode} and \code{make_standata} functions are called. The former generates the model code in \pkg{Stan} language and the latter prepares the data for use in \pkg{Stan}. These two are the mandatory parts of every \pkg{Stan} model and without \pkg{brms}, users would have to specify them themselves. Third, \pkg{Stan} code and data as well as additional arguments (such as the number of iterations and chains) are passed to functions of the \pkg{rstan} package (the \proglang{R} interface of \pkg{Stan}; \citeauthor{stan2017}, \citeyear{stan2017}). Fourth, the model is fitted by \pkg{Stan} after translating and compiling it in \proglang{C++}. Fifth, after the model has been fitted and returned by \pkg{rstan}, the fitted model object is post-processed in \pkg{brms} among others by renaming the model parameters to be understood by the user. Sixth, the results can be investigated in \proglang{R} using various methods such as \code{summary}, \code{plot}, or \code{predict} (for a complete list of methods type \code{methods(class = "brmsfit")}). + +\begin{figure}[ht] + \centering + \includegraphics[height = 0.4\textheight, keepaspectratio]{flowchart.pdf} + \caption{High level description of the model fitting procedure used in \pkg{brms}.} + \label{flowchart} +\end{figure} + +\subsection{A worked example} + +In the following, we use an example about the recurrence time of an infection in kidney patients initially published by \cite{mcgilchrist1991}. The data set consists of 76 entries of 7 variables: +\begin{Sinput} +R> library("brms") +R> data("kidney") +R> head(kidney, n = 3) +\end{Sinput} +\begin{Soutput} + time censored patient recur age sex disease +1 8 0 1 1 28 male other +2 23 0 2 1 48 female GN +3 22 0 3 1 32 male other +\end{Soutput} +Variable \code{time} represents the recurrence time of the infection, +\code{censored} indicates if \code{time} is right censored (\code{1}) or not censored (\code{0}), variable \code{patient} is the patient id, and +\code{recur} indicates if it is the first or second recurrence in that patient. Finally, variables \code{age}, \code{sex}, and \code{disease} make up the predictors. + +\subsection[Fitting models with brms]{Fitting models with \pkg{brms}} + +The core of the \pkg{brms} package is the \code{brm} function and we will explain its argument structure using the example above. Suppose we want to predict the (possibly censored) recurrence time using a log-normal model, in which the intercept as well as the effect of \code{age} is nested within patients. Then, we may use the following code: +\begin{Sinput} +fit1 <- brm(formula = time | cens(censored) ~ age * sex + disease + + (1 + age|patient), + data = kidney, family = lognormal(), + prior = c(set_prior("normal(0,5)", class = "b"), + set_prior("cauchy(0,2)", class = "sd"), + set_prior("lkj(2)", class = "cor")), + warmup = 1000, iter = 2000, chains = 4, + control = list(adapt_delta = 0.95)) +\end{Sinput} + +\subsection[formula: Information on the response and predictors]{\code{formula}: Information on the response and predictors} + +Without doubt, \code{formula} is the most complicated argument, as it contains information on the response variable as well as on predictors at different levels of the model. Everything before the $\sim$ sign relates to the response part of \code{formula}. In the usual and most simple case, this is just one variable name (e.g., \code{time}). However, to incorporate additional information about the response, one can add one or more terms of the form \code{| fun(variable)}. \code{fun} may be one of a few functions defined internally in \pkg{brms} and \code{variable} corresponds to a variable in the data set supplied by the user. In this example, \code{cens} makes up the internal function that handles censored data, and \code{censored} is the variable that contains information on the censoring. Other available functions in this context are \code{weights} and \code{disp} to allow different sorts of weighting, \code{se} to specify known standard errors primarily for meta-analysis, \code{trunc} to define truncation boundaries, \code{trials} for binomial models\footnote{In functions such as \code{glm} or \code{glmer}, the binomial response is typically passed as \code{cbind(success, failure)}. In \pkg{brms}, the equivalent syntax is \code{success | trials(success + failure)}.}, and \code{cat} to specify the number of categories for ordinal models. + +Everything on the right side of $\sim$ specifies predictors. Here, the syntax exactly matches that of \pkg{lme4}. For both, population-level and group-level terms, the \code{+} is used to separate different effects from each other. Group-level terms are of the form \code{(coefs | group)}, where \code{coefs} contains one or more variables whose effects are assumed to vary with the levels of the grouping factor given in \code{group}. Multiple grouping factors each with multiple group-level coefficients are possible. In the present example, only one group-level term is specified in which \code{1 + age} are the coefficients varying with the grouping factor \code{patient}. This implies that the intercept of the model as well as the effect of age is supposed to vary between patients. By default, group-level coefficients within a grouping factor are assumed to be correlated. Correlations can be set to zero by using the \code{(coefs || group)} syntax\footnote{In contrast to \pkg{lme4}, the \code{||} operator in \pkg{brms} splits up the design matrix computed from \code{coefs} instead of decomposing \code{coefs} in its terms. This implies that columns of the design matrix originating from the same factor are also assumed to be uncorrelated, whereas \pkg{lme4} estimates the correlations in this case. For a way to achieve \pkg{brms}-like behavior with \pkg{lme4}, see the \code{mixed} function of the \pkg{afex} package by \cite{afex2015}.}. Everything on the right side of \code{formula} that is not recognized as part of a group-level term is treated as a population-level effect. In this example, the population-level effects are \code{age}, \code{sex}, and \code{disease}. + +\subsection[family: Distribution of the response variable]{\code{family}: Distribution of the response variable} + +Argument \code{family} should usually be a family function, a call to a family function or a character string naming the family. If not otherwise specified, default link functions are applied. \pkg{brms} comes with a large variety of families. Linear and robust linear regression can be performed using the \code{gaussian} or \code{student} family combined with the \code{identity} link. For dichotomous and categorical data, families \code{bernoulli}, \code{binomial}, and \code{categorical} combined with the \code{logit} link, by default, are perfectly suited. Families \code{poisson}, \code{negbinomial}, and \code{geometric} allow for modeling count data. Families \code{lognormal}, \code{Gamma}, \code{exponential}, and \code{weibull} can be used (among others) for survival regression. Ordinal regression can be performed using the families \code{cumulative}, \code{cratio}, \code{sratio}, and \code{acat}. Finally, families \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, \code{zero_inflated_beta}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, and \code{hurdle_gamma} can be used to adequately model excess zeros in the response. In our example, we use \code{family = lognormal()} implying a log-normal ``survival'' model for the response variable \code{time}. + +\subsection[prior: Prior distributions of model parameters]{\code{prior}: Prior distributions of model parameters} + +Every population-level effect has its corresponding regression parameter. These parameters are named as \code{b\_}, where \code{} represents the name of the corresponding population-level effect. The default prior is an improper flat prior over the reals. Suppose, for instance, that we want to set a normal prior with mean \code{0} and standard deviation \code{10} on the effect of \code{age} and a Cauchy prior with location \code{1} and scale \code{2} on \code{sexfemale}\footnote{When factors are used as predictors, parameter names will depend on the factor levels. To get an overview of all parameters and parameter classes for which priors can be specified, use function \code{get\_prior}. For the present example, \code{get\_prior(time | cens(censored) $\sim$ age * sex + disease + (1 + age|patient), data = kidney, family = lognormal())} does the desired.}. Then, we may write +\begin{Sinput} +prior <- c(set_prior("normal(0,10)", class = "b", coef = "age"), + set_prior("cauchy(1,2)", class = "b", coef = "sexfemale")) +\end{Sinput} +To put the same prior (e.g., a normal prior) on all population-level effects at once, we may write as a shortcut \code{set_prior("normal(0,10)", class = "b")}. This also leads to faster sampling, because priors can be vectorized in this case. Note that we could also omit the \code{class} argument for population-level effects, as it is the default class in \code{set_prior}. + +A special shrinkage prior to be applied on population-level effects is the horseshoe prior \citep{carvalho2009, carvalho2010}. It is symmetric around zero with fat tails and an infinitely large spike at zero. This makes it ideal for sparse models that have many regression coefficients, although only a minority of them is non-zero. The horseshoe prior can be applied on all population-level effects at once (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. +The $1$ implies that the Student-$t$ prior of the local shrinkage parameters has 1 degrees of freedom. In \pkg{brms} it is possible to increase the degrees of freedom (which will often improve convergence), although the prior no longer resembles a horseshoe in this case\footnote{This class of priors is often referred to as hierarchical shrinkage family, which contains the original horseshoe prior as a special case.}. For more details see \cite{carvalho2009, carvalho2010}. + +Each group-level effect of each grouping factor has a standard deviation parameter, which is restricted to be non-negative and, by default, has a half Student-$t$ prior with $3$ degrees of freedom and a scale parameter that is minimally $10$. For non-ordinal models, \pkg{brms} tries to evaluate if the scale is large enough to be considered only weakly informative for the model at hand by comparing it with the standard deviation of the response after applying the link function. If this is not the case, it will increase the scale based on the aforementioned standard deviation\footnote{Changing priors based on the data is not truly Bayesian and might rightly be criticized. However, it helps avoiding the problem of too informative default priors without always forcing users to define their own priors. The latter would also be problematic as not all users can be expected to be well educated Bayesians and reasonable default priors will help them a lot in using Bayesian methods.}. \pkg{Stan} implicitly defines a half Student-$t$ prior by using a Student-$t$ prior on a restricted parameter \citep{stanM2017}. For other reasonable priors on standard deviations see \cite{gelman2006}. In \pkg{brms}, standard deviation parameters are named as \code{sd\_\_} so that \code{sd\_patient\_Intercept} and \code{sd\_patient\_age} are the parameter names in the example. If desired, it is possible to set a different prior on each parameter, but statements such as \code{set_prior("student_t(3,0,5)", class = "sd", group = "patient")} or even \code{set_prior("student_t(3,0,5)", class = "sd")} may also be used and are again faster because of vectorization. + +If there is more than one group-level effect per grouping factor, correlations between group-level effects are estimated. As mentioned in Section~\ref{model}, the LKJ-Correlation prior with parameter $\zeta > 0$ \citep{lewandowski2009} is used for this purpose. In \pkg{brms}, this prior is abbreviated as \code{"lkj(zeta)"} and correlation matrix parameters are named as \code{cor\_}, (e.g., \code{cor_patient}), so that \code{set_prior("lkj(2)", class = "cor", group = "patient")} is a valid statement. To set the same prior on every correlation matrix in the model, \code{set_prior("lkj(2)", class = "cor")} is also allowed, but does not come with any efficiency increases. + +Other model parameters such as the residual standard deviation \code{sigma} in normal models or the \code{shape} in Gamma models have their priors defined in the same way, where each of them is treated as having its own parameter class. A complete overview on possible prior distributions is given in the \pkg{Stan} user's manual \citep{stanM2017}. Note that \pkg{brms} does not thoroughly check if the priors are written in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their syntactical correctness when the model is parsed to \proglang{C++} and return an error if they are not. This, however, does not imply that priors are always meaningful if they are accepted by \pkg{Stan}. Although \pkg{brms} tries to find common problems (e.g., setting bounded priors on unbounded parameters), there is no guarantee that the defined priors are reasonable for the model. + +\subsection[control Adjusting the sampling behavior of Stan]{\code{control}: Adjusting the sampling behavior of \pkg{Stan}} + +In addition to choosing the number of iterations, warmup samples, and chains, users can control the behavior of the NUTS sampler by using the \code{control} argument. The most important reason to use \code{control} is to decrease (or eliminate at best) the number of divergent transitions that cause a bias in the obtained posterior samples. Whenever you see the warning \code{"There were x divergent transitions after warmup."}, you should really think about increasing \code{adapt_delta}. To do this, write \code{control = list(adapt_delta = )}, where \code{} should usually be a value between \code{0.8} (current default) and \code{1}. Increasing \code{adapt_delta} will slow down the sampler but will decrease the number of divergent transitions threatening the validity of your posterior samples. + +Another problem arises when the depth of the tree being evaluated in each iteration is exceeded. This is less common than having divergent transitions, but may also bias the posterior samples. When it happens, \pkg{Stan} will throw out a warning suggesting to increase \code{max_treedepth}, which can be accomplished by writing \code{control = list(max_treedepth = )} with a positive integer \code{} that should usually be larger than the current default of \code{10}. + +\subsection{Analyzing the results} + +The example model \code{fit1} is fitted using 4 chains, each with 2000 iterations of which the first 1000 are warmup to calibrate the sampler, leading to a total of 4000 posterior samples\footnote{To save time, chains may also run in parallel when using argument \code{cluster}.}. For researchers familiar with Gibbs or Metropolis-Hastings sampling, this number may seem far too small to achieve good convergence and reasonable results, especially for multilevel models. However, as \pkg{brms} utilizes the NUTS sampler \citep{hoffman2014} implemented in \pkg{Stan}, even complex models can often be fitted with not more than a few thousand samples. Of course, every iteration is more computationally intensive and time-consuming than the iterations of other algorithms, but the quality of the samples (i.e., the effective sample size per iteration) is usually higher. + +After the posterior samples have been computed, the \code{brm} function returns an \proglang{R} object, containing (among others) the fully commented model code in \pkg{Stan} language, the data to fit the model, and the posterior samples themselves. The model code and data for the present example can be extracted through \code{stancode(fit1)} and \code{standata(fit1)} respectively\footnote{Both model code and data may be amended and used to fit new models. That way, \pkg{brms} can also serve as a good starting point in building more complicated models in \pkg{Stan}, directly.}. A model summary is readily available using + +\begin{Sinput} +R> summary(fit1, waic = TRUE) +\end{Sinput} +\begin{Soutput} + Family: lognormal (identity) +Formula: time | cens(censored) ~ age * sex + disease + (1 + age | patient) + Data: kidney (Number of observations: 76) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: 673.51 + +Group-Level Effects: +~patient (Number of levels: 38) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 0.40 0.28 0.01 1.01 1731 1 +sd(age) 0.01 0.01 0.00 0.02 1137 1 +cor(Intercept,age) -0.13 0.46 -0.88 0.76 3159 1 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept 2.73 0.96 0.82 4.68 2139 1 +age 0.01 0.02 -0.03 0.06 1614 1 +sexfemale 2.42 1.13 0.15 4.64 2065 1 +diseaseGN -0.40 0.53 -1.45 0.64 2664 1 +diseaseAN -0.52 0.50 -1.48 0.48 2713 1 +diseasePKD 0.60 0.74 -0.86 2.02 2968 1 +age:sexfemale -0.02 0.03 -0.07 0.03 1956 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sigma 1.15 0.13 0.91 1.44 4000 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Soutput} + +On the top of the output, some general information on the model is given, such as family, formula, number of iterations and chains, as well as the WAIC. Next, group-level effects are displayed separately for each grouping factor in terms of standard deviations and correlations between group-level effects. On the bottom of the output, population-level effects are displayed. If incorporated, autocorrelation and family specific parameters (e.g., the residual standard deviation \code{sigma}) are also given. + +In general, every parameter is summarized using the mean (\code{Estimate}) and the standard deviation (\code{Est.Error}) of the posterior distribution as well as two-sided 95\% Credible intervals (\code{l-95\% CI} and \code{u-95\% CI}) based on quantiles. +The \code{Eff.Sample} value is an estimation of the effective sample size; that is the number of independent samples from the posterior distribution that would be expected to yield the same standard error of the posterior mean as is obtained from the dependent samples returned by the MCMC algorithm. The \code{Rhat} value provides information on the convergence of the algorithm (cf., \citeauthor{gelman1992}, \citeyear{gelman1992}). If \code{Rhat} is considerably greater than 1 (i.e., $> 1.1$), the chains have not yet converged and it is necessary to run more iterations and/or set stronger priors. + +To visually investigate the chains as well as the posterior distribution, the \code{plot} method can be used (see Figure~\ref{kidney_plot}). An even more detailed investigation can be achieved by applying the \pkg{shinystan} package \citep{gabry2015} through method \code{launch_shiny}. With respect to the above summary, \code{sexfemale} seems to be the only population-level effect with considerable influence on the response. Because the mean of \code{sexfemale} is positive, the model predicts longer periods without an infection for females than for males. Effects of population-level predictors can also be visualized with the \code{conditional_effects} method (see Figure~\ref{kidney_conditional_effects}). + +\begin{figure}[ht] + \centering + \includegraphics[width=0.95\textwidth]{kidney_plot.pdf} + \caption{Trace and Density plots of all relevant parameters of the kidney model discussed in Section~\ref{software}.} + \label{kidney_plot} +\end{figure} + +\begin{figure}[ht] + \centering + \includegraphics[height=0.90\textheight]{kidney_conditional_effects.pdf} + \caption{Conditional effects plots of all population-level predictors of the kidney model discussed in Section~\ref{software}.} + \label{kidney_conditional_effects} +\end{figure} + +Looking at the group-level effects, the standard deviation parameter of \code{age} is suspiciously small. To test whether it is smaller than the standard deviation parameter of \code{Intercept}, we apply the \code{hypothesis} method: +\begin{Sinput} +R> hypothesis(fit1, "Intercept - age > 0", class = "sd", group = "patient") +\end{Sinput} +\begin{Soutput} +Hypothesis Tests for class sd_patient: + Estimate Est.Error l-95% CI u-95% CI Evid.Ratio +Intercept-age > 0 0.39 0.27 0.03 Inf 67.97 * +--- +'*': The expected value under the hypothesis lies outside the 95% CI. +\end{Soutput} +The one-sided 95\% credibility interval does not contain zero, thus indicating that the standard deviations differ from each other in the expected direction. In accordance with this finding, the \code{Evid.Ratio} shows that the hypothesis being tested (i.e., \code{Intercept - age > 0}) is about $68$ times more likely than the alternative hypothesis \code{Intercept - age < 0}. It is important to note that this kind of comparison is not easily possible when applying frequentist methods, because in this case only point estimates are available for group-level standard deviations and correlations. + +When looking at the correlation between both group-level effects, its distribution displayed in Figure~\ref{kidney_plot} and the 95\% credibility interval in the summary output appear to be rather wide. This indicates that there is not enough evidence in the data to reasonably estimate the correlation. Together, the small standard deviation of \code{age} and the uncertainty in the correlation raise the question if \code{age} should be modeled as a group specific term at all. To answer this question, we fit another model without this term: +\begin{Sinput} +R> fit2 <- update(fit1, formula. = ~ . - (1 + age|patient) + (1|patient)) +\end{Sinput} + +A good way to compare both models is leave-one-out cross-validation (LOO)\footnote{The WAIC is an approximation of LOO that is faster and easier to compute. However, according to \cite{vehtari2015}, LOO may be the preferred method to perform model comparisons.}, which can be called in \pkg{brms} using +\begin{Sinput} +R> LOO(fit1, fit2) +\end{Sinput} +\begin{Soutput} + LOOIC SE +fit1 675.45 45.18 +fit2 674.17 45.06 +fit1 - fit2 1.28 0.99 +\end{Soutput} +In the output, the LOO information criterion for each model as well as the difference of the LOOs each with its corresponding standard error is shown. Both LOO and WAIC are approximately normal if the number of observations is large so that the standard errors can be very helpful in evaluating differences in the information criteria. However, for small sample sizes, standard errors should be interpreted with care \citep{vehtari2015}. For the present example, it is immediately evident that both models have very similar fit, indicating that there is little benefit in adding group specific coefficients for \code{age}. + +\subsection{Modeling ordinal data} + +In the following, we want to briefly discuss a second example to demonstrate the capabilities of \pkg{brms} in handling ordinal data. \cite{ezzet1991} analyze data from a two-treatment, two-period crossover trial to compare 2 inhalation devices for delivering the drug salbutamol in 286 asthma patients. Patients were asked to rate the clarity of leaflet instructions accompanying each device, using a four-point ordinal scale. Ratings are predicted by \code{treat} to indicate which of the two inhaler devices was used, \code{period} to indicate the time of administration, and \code{carry} to model possible carry over effects. +\begin{Sinput} +R> data("inhaler") +R> head(inhaler, n = 1) +\end{Sinput} +\begin{Soutput} + subject rating treat period carry +1 1 1 0.5 0.5 0 +\end{Soutput} + +Typically, the ordinal response is assumed to originate from the categorization of a latent continuous variable. That is there are $K$ latent thresholds (model intercepts), which partition the continuous scale into the $K + 1$ observable, ordered categories. Following this approach leads to the cumulative or graded-response model \citep{samejima1969} for ordinal data implemented in many \proglang{R} packages. In \pkg{brms}, it is available via family \code{cumulative}. Fitting the cumulative model to the inhaler data, also incorporating an intercept varying by subjects, may look this: +\begin{Sinput} +fit3 <- brm(formula = rating ~ treat + period + carry + (1|subject), + data = inhaler, family = cumulative) +\end{Sinput} +While the support for ordinal data in most \proglang{R} packages ends here\footnote{Exceptions known to us are the packages \pkg{ordinal} \citep{christensen2015} and \pkg{VGAM} \citep{yee2010}. The former supports only cumulative models but with different modeling option for the thresholds. The latter supports all four ordinal families also implemented in \pkg{brms} as well as category specific effects but no group-specific effects.}, \pkg{brms} allows changes to this basic model in at least three ways. First of all, three additional ordinal families are implemented. Families \code{sratio} (stopping ratio) and \code{cratio} (continuation ratio) are so called sequential models \citep{tutz1990}. Both are equivalent to each other for symmetric link functions such as \code{logit} but will differ for asymmetric ones such as \code{cloglog}. The fourth ordinal family is \code{acat} (adjacent category) also known as partial credits model \citep{masters1982, andrich1978a}. Second, restrictions to the thresholds can be applied. By default, thresholds are ordered for family \code{cumulative} or are completely free to vary for the other families. This is indicated by argument \code{threshold = "flexible"} (default) in \code{brm}. Using \code{threshold = "equidistant"} forces the distance between two adjacent thresholds to be the same, that is +$$\tau_k = \tau_1 + (k-1)\delta$$ +for thresholds $\tau_k$ and distance $\delta$ (see also \citealp{andrich1978b}; \citealp{andrich1978a}; \citealp{andersen1977}). +Third, the assumption that predictors have constant effects across categories may be relaxed for non-cumulative ordinal models \citep{vanderark2001, tutz2000} leading to category specific effects. For instance, variable \code{treat} may +only have an impact on the decision between category 3 and 4, but not on the lower categories. Without using category specific effects, such a pattern would remain invisible. + +To illustrate all three modeling options at once, we fit a (hardly theoretically justified) stopping ratio model with equidistant thresholds and category specific effects for variable \code{treat} on which we apply an informative prior. +\begin{Sinput} +fit4 <- brm(formula = rating ~ period + carry + cs(treat) + (1|subject), + data = inhaler, family = sratio, threshold = "equidistant", + prior = set_prior("normal(-1,2)", coef = "treat")) +\end{Sinput} +Note that priors are defined on category specific effects in the same way as for other population-level effects. A model summary can be obtained in the same way as before: +\begin{Sinput} +R> summary(fit4, waic = TRUE) +\end{Sinput} +\begin{Soutput} + Family: sratio (logit) +Formula: rating ~ period + carry + cs(treat) + (1 | subject) + Data: inhaler (Number of observations: 572) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: 911.9 + +Group-Level Effects: +~subject (Number of levels: 286) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 1.05 0.23 0.56 1.5 648 1 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept[1] 0.72 0.13 0.48 0.99 2048 1 +Intercept[2] 2.67 0.35 2.00 3.39 969 1 +Intercept[3] 4.62 0.66 3.36 5.95 1037 1 +period 0.25 0.18 -0.09 0.61 4000 1 +carry -0.26 0.22 -0.70 0.17 1874 1 +treat[1] -0.96 0.30 -1.56 -0.40 1385 1 +treat[2] -0.65 0.49 -1.60 0.27 4000 1 +treat[3] -2.65 1.21 -5.00 -0.29 4000 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +delta 1.95 0.32 1.33 2.6 1181 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Soutput} +Trace and density plots of the model parameters as produced by \code{plot(fit4)} can be found in Figure~\ref{inhaler_plot}. We see that three intercepts (thresholds) and three effects of \code{treat} have been estimated, because a four-point scale was used for the ratings. The treatment effect seems to be strongest between category 3 and 4. At the same time, however, the credible interval is also much larger. In fact, the intervals of all three effects of \code{treat} are highly overlapping, which indicates that there is not enough evidence in the data to support category specific effects. On the bottom of the output, parameter \code{delta} specifies the distance between two adjacent thresholds and indeed the intercepts differ from each other by the magnitude of \code{delta}. + +\begin{figure}[ht] + \centering + \includegraphics[width=0.95\textwidth]{inhaler_plot.pdf} + \caption{Trace and Density plots of all relevant parameters of the inhaler model discussed in Section~\ref{software}.} + \label{inhaler_plot} +\end{figure} + + +\section[Comparison]{Comparison between packages} + +Over the years, many \proglang{R} packages have been developed that implement MLMs, each being more or less general in their supported models. Comparing all of them to \pkg{brms} would be too extensive and barely helpful for the purpose of the present paper. Accordingly, we concentrate on a comparison with four packages. These are \pkg{lme4} \citep{bates2015} and \pkg{MCMCglmm} \citep{hadfield2010}, which are possibly the most general and widely applied \proglang{R} packages for MLMs, as well as \pkg{rstanarm} \citep{rstanarm2016} and \pkg{rethinking} \citep{mcelreath2016}, which are both based on \pkg{Stan}. As opposed to the other packages, \pkg{rethinking} was primarily written for teaching purposes and requires the user to specify the full model explicitly using its own simplified \pkg{BUGS}-like syntax thus helping users to better understand the models that are fitted to their data. + +Regarding model families, all five packages support the most common types such as linear and binomial models as well as Poisson models for count data. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. In addition, \pkg{brms} supports robust linear regression using Student's distribution, which is also implemented on a GitHub branch of \pkg{rstanarm}. \pkg{MCMCglmm} allows fitting multinomial models that are currently not available in the other packages. + +Generalizing classical MLMs, \pkg{brms} and \pkg{MCMCglmm} allow fiting zero-inflated and hurdle models dealing with excess zeros in the response. Furthermore, \pkg{brms} supports non-linear models similar to the \pkg{nlme} package \citep{nlme2016} providing great flexibility but also requiring more care to produce reasonable results. Another flexible model class are generalized additive mixed models \citep{hastie1990,wood2011,zuur2014}, which can be fitted with \pkg{brms} and \pkg{rstanarm}. + +In all five packages, there are quite a few additional modeling options. Variable link functions can be specified in all packages except for \pkg{MCMCglmm}, in which only one link is available per family. \pkg{MCMCglmm} generally supports multivariate responses using data in wide format, whereas \pkg{brms} currently only offers this option for families \code{gaussian} and \code{student}. It should be noted that it is always possible to transform data from wide to long format for compatibility with the other packages. Autocorrelation of the response can only be fitted in \pkg{brms}, which supports auto-regressive as well as moving-average effects. For ordinal models in \pkg{brms}, effects of predictors may vary across different levels of the response as explained in the inhaler example. A feature currently exclusive to \pkg{rethinking} is the possibility to impute missing values in the predictor variables. + +Information criteria are available in all three packages. The advantage of WAIC and LOO implemented in \pkg{brms}, \pkg{rstanarm}, and \pkg{rethinking} is that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the Bayesian packages, \pkg{brms} and \pkg{rethinking} offer a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, we believe that the way priors are specified in \pkg{brms} and \pkg{rethinking} is more intuitive as it is directly evident what prior is actually applied. A more detailed comparison of the packages can be found in Table~\ref{comparison1} and Table~\ref{comparison2}. To facilitate the understanding of the model formulation in \pkg{brms}, Table~\ref{syntax} shows \pkg{lme4} function calls to fit sample models along with the equivalent \pkg{brms} syntax. + +So far the focus was only on capabilities. Another important topic is speed, especially for more complex models. Of course, \pkg{lme4} is usually much faster than the other packages as it uses maximum likelihood methods instead of MCMC algorithms, which are slower by design. To compare the efficiency of the four Bayesian packages, we fitted multilevel models on real data sets using the minimum effective sample size divided by sampling time as a measure of sampling efficiency. One should always aim at running multiple chains as one cannot be sure that a single chain really explores the whole posterior distribution. However, as \pkg{MCMCglmm} does not come with a built-in option to run multiple chains, we used only a single chain to fit the models after making sure that it leads to the same results as multiple chains. The \proglang{R} code allowing to replicate the results is available as supplemental material. + +The first thing that becomes obvious when fitting the models is that \pkg{brms} and \pkg{rethinking} need to compile the \proglang{C++} model before actually fitting it, because the \pkg{Stan} code being parsed to \proglang{C++} is generated on the fly based on the user's input. Compilation takes about a half to one minute depending on the model complexity and computing power of the machine. This is not required by \pkg{rstanarm} and \pkg{MCMCglmm}, although the former is also based on \pkg{Stan}, as compilation takes place only once at installation time. While the latter approach saves the compilation time, the former is more flexible when it comes to model specification. For small and simple models, compilation time dominates the overall computation time, but for larger and more complex models, sampling will take several minutes or hours so that one minute more or less will not really matter, anymore. Accordingly, the following comparisons do not include the compilation time. + +In models containing only group-specific intercepts, \pkg{MCMCglmm} is usually more efficient than the \pkg{Stan} packages. However, when also estimating group-specific slopes, \pkg{MCMCglmm} falls behind the other packages and quite often refuses to sample at all unless one carefully specifies informative priors. Note that these results are obtained by running only a single chain. For all three \pkg{Stan} packages, sampling efficiency can easily be increased by running multiple chains in parallel. Comparing the \pkg{Stan} packages to each other, \pkg{brms} is usually most efficient for models with group-specific terms, whereas \pkg{rstanarm} tends to be roughly $50\%$ to $75\%$ as efficient at least for the analyzed data sets. The efficiency of \pkg{rethinking} is more variable depending on the model formulation and data, sometimes being slightly ahead of the other two packages, but usually being considerably less efficient. Generally, \pkg{rethinking} loses efficiency for models with many population-level effects presumably because one cannot use design matrices and vectorized prior specifications for population-level parameters. Note that it was not possible to specify the exact same priors across packages due to varying parameterizations. Of course, efficiency depends heavily on the model, chosen priors, and data at hand so that the present results should not be over-interpreted. + +\begin{table}[hbtp] +\centering +\begin{tabular}{llll} + & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{lme4}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline +\\ [-1.5ex] +\parbox{6cm}{Supported model types:} & & & \\ [1ex] +Linear models & yes & yes & yes \\ +Robust linear models & yes & no & no \\ +Binomial models & yes & yes & yes \\ +Categorical models & yes & no & yes \\ +Multinomial models & no & no & yes \\ +Count data models & yes & yes & yes \\ +Survival models & yes$^1$ & yes & yes \\ +Ordinal models & various & no & cumulative \\ +Zero-inflated and hurdle models & yes & no & yes \\ +Generalized additive models & yes & no & no \\ +Non-linear models & yes & no & no \\ \hline +\\ [-1.5ex] +\parbox{5cm}{Additional modeling options:} & & & \\ [1ex] +Variable link functions & various & various & no \\ +Weights & yes & yes & no \\ +Offset & yes & yes & using priors \\ +Multivariate responses & limited & no & yes \\ +Autocorrelation effects & yes & no & no \\ +Category specific effects & yes & no & no \\ +Standard errors for meta-analysis & yes & no & yes \\ +Censored data & yes & no & yes \\ +Truncated data & yes & no & no \\ +Customized covariances & yes & no & yes \\ +Missing value imputation & no & no & no \\ \hline +\\ [-1.5ex] +Bayesian specifics: & & & \\ [1ex] +parallelization & yes & -- & no \\ +population-level priors & flexible & --$^3$ & normal \\ +group-level priors & normal & --$^3$ & normal \\ +covariance priors & flexible & --$^3$ & restricted$^4$ \\ \hline +\\ [-1.5ex] +Other: & & & \\ [1ex] +Estimator & HMC, NUTS & ML, REML & MH, Gibbs$^2$ \\ +Information criterion & WAIC, LOO & AIC, BIC & DIC \\ +\proglang{C++} compiler required & yes & no & no \\ +Modularized & no & yes & no \\ \hline +\end{tabular} +\caption{Comparison of the capabilities of the \pkg{brms}, \pkg{lme4} and \pkg{MCMCglmm} package. Notes: (1) Weibull family only available in \pkg{brms}. (2) Estimator consists of a combination of both algorithms. (3) Priors may be imposed using the \pkg{blme} package \citep{chung2013}. (4) For details see \cite{hadfield2010}.} +\label{comparison1} +\end{table} + + +\begin{table}[hbtp] +\centering +\begin{tabular}{llll} + & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{rethinking}} \\ \hline +\\ [-1.5ex] +\parbox{6cm}{Supported model types:} & & & \\ [1ex] +Linear models & yes & yes & yes \\ +Robust linear models & yes & yes$^1$ & no \\ +Binomial models & yes & yes & yes \\ +Categorical models & yes & no & no \\ +Multinomial models & no & no & no \\ +Count data models & yes & yes & yes \\ +Survival models & yes$^2$ & yes & yes \\ +Ordinal models & various & cumulative$^3$ & no \\ +Zero-inflated and hurdle models & yes & no & no \\ +Generalized additive models & yes & yes & no \\ +Non-linear models & yes & no & limited$^4$ \\ \hline +\\ [-1.5ex] +\parbox{5cm}{Additional modeling options:} & & & \\ [1ex] +Variable link functions & various & various & various \\ +Weights & yes & yes & no \\ +Offset & yes & yes & yes \\ +Multivariate responses & limited & no & no \\ +Autocorrelation effects & yes & no & no \\ +Category specific effects & yes & no & no \\ +Standard errors for meta-analysis & yes & no & no \\ +Censored data & yes & no & no \\ +Truncated data & yes & no & yes \\ +Customized covariances & yes & no & no \\ +Missing value imputation & no & no & yes \\ \hline +\\ [-1.5ex] +Bayesian specifics: & & & \\ [1ex] +parallelization & yes & yes & yes \\ +population-level priors & flexible & normal, Student-t & flexible \\ +group-level priors & normal & normal & normal \\ +covariance priors & flexible & restricted$^5$ & flexible \\ \hline +\\ [-1.5ex] +Other: & & & \\ [1ex] +Estimator & HMC, NUTS & HMC, NUTS & HMC, NUTS \\ +Information criterion & WAIC, LOO & AIC, LOO & AIC, LOO \\ +\proglang{C++} compiler required & yes & no & yes \\ +Modularized & no & no & no \\ \hline +\end{tabular} +\caption{Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{rethinking} package. Notes: (1) Currently only implemented on a branch on GitHub. (2) Weibull family only available in \pkg{brms}. (3) No group-level terms allowed. (4) The parser is mainly written for linear models but also accepts some non-linear model specifications. (5) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}.} +\label{comparison2} +\end{table} + + +\begin{table}[hbtp] +\centering +%\renewcommand{\arraystretch}{2} +\begin{tabular}{ll} + Dataset & \parbox{10cm}{Function call} \\ \hline +\\ [-1.5ex] +\parbox{2cm}{cake} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{lmer(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{5ex} data = cake)}} \\ [3ex] +\pkg{brms} & \parbox{13cm}{\code{brm(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{4ex} data = cake)}} \\ [2ex] \hline +\\ [-1.5ex] +\parbox{2cm}{sleepstudy} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{lmer(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [1.5ex] +\pkg{brms} & \parbox{13cm}{\code{brm(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [2ex] \hline +\\ [-1.5ex] +\parbox{2cm}{cbpp$^1$} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{glmer(cbind(incidence, size - incidence) $\sim$ period + (1 | herd), \\ \hspace*{6ex} family = binomial("logit"), data = cbpp)}} \\ [3ex] +\pkg{brms} & \parbox{13cm}{\code{brm(incidence | trials(size) $\sim$ period + (1 | herd), \\ \hspace*{4ex} family = binomial("logit"), data = cbpp)}} \\ [2ex] \hline +\\ [-1.5ex] +\parbox{2cm}{grouseticks$^1$} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{glmer(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{6ex} family = poisson("log"), data = grouseticks)}} \\ [3ex] +\pkg{brms} & \parbox{13cm}{\code{brm(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{4ex} family = poisson("log"), data = grouseticks)}} \\ [2ex] \hline +\\ [-1ex] +\parbox{2cm}{VerbAgg$^2$} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{glmer(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{6ex} + (1|item), family = binomial, data = VerbAgg)}} \\ [3ex] +\pkg{brms} & \parbox{13cm}{\code{brm(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{4ex} + (1|item), family = bernoulli, data = VerbAgg)}} \\ [2ex] \hline +\\ [-1.5ex] +\end{tabular} +\caption{Comparison of the model syntax of \pkg{lme4} and \pkg{brms} using data sets included in \pkg{lme4}. Notes: (1) Default links are used to that the link argument may be omitted. (2) Fitting this model takes some time. A proper prior on the population-level effects (e.g., \code{prior = set\_prior("normal(0,5)")}) may help in increasing sampling speed.} +\label{syntax} +\end{table} + +\section{Conclusion} +The present paper is meant to provide a general overview on the \proglang{R} package \pkg{brms} implementing MLMs using the probabilistic programming language \pkg{Stan} for full Bayesian inference. Although only a small selection of the modeling options available in \pkg{brms} are discussed in detail, I hope that this article can serve as a good starting point to further explore the capabilities of the package. + +For the future, I have several plans on how to improve the functionality of \pkg{brms}. I want to include multivariate models that can handle multiple response variables coming from different distributions as well as new correlation structures for instance for spatial data. Similarily, distributional regression models as well as mixture response distributions appear to be valuable extensions of the package. I am always grateful for any suggestions and ideas regarding new features. + +\section*{Acknowledgments} + +First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language \pkg{Stan}, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Two anonymous reviewers provided very detailed and thoughtful suggestions to substantially improve both the package and the paper. Furthermore, Prof. Philipp Doebler and Prof. Heinz Holling have given valuable feedback on earlier versions of the paper. Lastly, I want to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. + +\bibliography{citations_overview} + +\end{document} Binary files /tmp/tmpt0wkwjq4/DNen8CCOKk/r-cran-brms-2.16.3/inst/doc/brms_overview.pdf and /tmp/tmpt0wkwjq4/VQL6MIL24y/r-cran-brms-2.17.0/inst/doc/brms_overview.pdf differ diff -Nru r-cran-brms-2.16.3/inst/doc/brms_phylogenetics.html r-cran-brms-2.17.0/inst/doc/brms_phylogenetics.html --- r-cran-brms-2.16.3/inst/doc/brms_phylogenetics.html 2021-11-22 16:48:13.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_phylogenetics.html 2022-04-11 08:19:11.000000000 +0000 @@ -1,596 +1,596 @@ - - - - - - - - - - - - - - - - -Estimating Phylogenetic Multilevel Models with brms - - - - - - - - - - - - - - - - - - - - - - - - - -

Estimating Phylogenetic Multilevel Models with brms

-

Paul Bürkner

-

2021-11-22

- - - - -
-

Introduction

-

In the present vignette, we want to discuss how to specify phylogenetic multilevel models using brms. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. The usual approach would be to model species as a grouping factor in a multilevel model and estimate varying intercepts (and possibly also varying slopes) over species. However, species are not independent as they come from the same phylogenetic tree and we thus have to adjust our model to incorporate this dependency. The examples discussed here are from chapter 11 of the book Modern Phylogenetic Comparative Methods and the application in Evolutionary Biology (de Villemeruil & Nakagawa, 2014). The necessary data can be downloaded from the corresponding website (http://www.mpcm-evolution.com/). Some of these models may take a few minutes to fit.

-
-
-

A Simple Phylogenetic Model

-

Assume we have measurements of a phenotype, phen (say the body size), and a cofactor variable (say the temperature of the environment). We prepare the data using the following code.

-
phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex")
-data_simple <- read.table(
-  "https://paul-buerkner.github.io/data/data_simple.txt", 
-  header = TRUE
-)
-head(data_simple)
-
       phen  cofactor phylo
-1 107.06595 10.309588  sp_1
-2  79.61086  9.690507  sp_2
-3 116.38186 15.007825  sp_3
-4 143.28705 19.087673  sp_4
-5 139.60993 15.658404  sp_5
-6  68.50657  6.005236  sp_6
-

The phylo object contains information on the relationship between species. Using this information, we can construct a covariance matrix of species (Hadfield & Nakagawa, 2010).

-
A <- ape::vcv.phylo(phylo)
-

Now we are ready to fit our first phylogenetic multilevel model:

-
model_simple <- brm(
-  phen ~ cofactor + (1|gr(phylo, cov = A)), 
-  data = data_simple, 
-  family = gaussian(), 
-  data2 = list(A = A),
-  prior = c(
-    prior(normal(0, 10), "b"),
-    prior(normal(0, 50), "Intercept"),
-    prior(student_t(3, 0, 20), "sd"),
-    prior(student_t(3, 0, 20), "sigma")
-  )
-)
-

With the exception of (1|gr(phylo, cov = A)) instead of (1|phylo) this is a basic multilevel model with a varying intercept over species (phylo is an indicator of species in this data set). However, by using cov = A in the gr function, we make sure that species are correlated as specified by the covariance matrix A. We pass A itself via the data2 argument which can be used for any kinds of data that does not fit into the regular structure of the data argument. Setting priors is not required for achieving good convergence for this model, but it improves sampling speed a bit. After fitting, the results can be investigated in detail.

-
summary(model_simple)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: phen ~ cofactor + (1 | gr(phylo, cov = A)) 
-   Data: data_simple (Number of observations: 200) 
-  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
-         total post-warmup draws = 4000
-
-Group-Level Effects: 
-~phylo (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)    14.44      2.15    10.30    18.74 1.01      836     1500
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    38.36      7.22    24.12    52.57 1.00     1924     2149
-cofactor      5.17      0.14     4.90     5.45 1.00     6221     3394
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     9.24      0.73     7.85    10.72 1.00     1129     2173
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(model_simple, N = 2, ask = FALSE)
-

-
plot(conditional_effects(model_simple), points = TRUE)
-

-

The so called phylogenetic signal (often symbolize by \(\lambda\)) can be computed with the hypothesis method and is roughly \(\lambda = 0.7\) for this example.

-
hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0"
-(hyp <- hypothesis(model_simple, hyp, class = NULL))
-
Hypothesis Tests for class :
-                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
-1 (sd_phylo__Interc... = 0      0.7      0.09     0.51     0.84         NA        NA    *
----
-'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
-'*': For one-sided hypotheses, the posterior probability exceeds 95%;
-for two-sided hypotheses, the value tested against lies outside the 95%-CI.
-Posterior probabilities of point hypotheses assume equal prior probabilities.
-
plot(hyp)
-

-

Note that the phylogenetic signal is just a synonym of the intra-class correlation (ICC) used in the context phylogenetic analysis.

-
-
-

A Phylogenetic Model with Repeated Measurements

-

Often, we have multiple observations per species and this allows to fit more complicated phylogenetic models.

-
data_repeat <- read.table(
-  "https://paul-buerkner.github.io/data/data_repeat.txt", 
-  header = TRUE
-)
-data_repeat$spec_mean_cf <- 
-  with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo])
-head(data_repeat)
-
       phen  cofactor species phylo spec_mean_cf
-1 107.41919 11.223724    sp_1  sp_1    10.309588
-2 109.16403  9.805934    sp_1  sp_1    10.309588
-3  91.88672 10.308423    sp_1  sp_1    10.309588
-4 121.54341  8.355349    sp_1  sp_1    10.309588
-5 105.31638 11.854510    sp_1  sp_1    10.309588
-6  64.99859  4.314015    sp_2  sp_2     3.673914
-

The variable spec_mean_cf just contains the mean of the cofactor for each species. The code for the repeated measurement phylogenetic model looks as follows:

-
model_repeat1 <- brm(
-  phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), 
-  data = data_repeat, 
-  family = gaussian(), 
-  data2 = list(A = A),
-  prior = c(
-    prior(normal(0,10), "b"),
-    prior(normal(0,50), "Intercept"),
-    prior(student_t(3,0,20), "sd"),
-    prior(student_t(3,0,20), "sigma")
-  ),
-  sample_prior = TRUE, chains = 2, cores = 2, 
-  iter = 4000, warmup = 1000
-)
-

The variables phylo and species are identical as they are both identifiers of the species. However, we model the phylogenetic covariance only for phylo and thus the species variable accounts for any specific effect that would be independent of the phylogenetic relationship between species (e.g., environmental or niche effects). Again we can obtain model summaries as well as estimates of the phylogenetic signal.

-
summary(model_repeat1)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: phen ~ spec_mean_cf + (1 | gr(phylo, cov = A)) + (1 | species) 
-   Data: data_repeat (Number of observations: 1000) 
-  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
-         total post-warmup draws = 6000
-
-Group-Level Effects: 
-~phylo (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)    16.39      1.92    12.79    20.32 1.00     1389     1848
-
-~species (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     4.99      0.84     3.31     6.56 1.00     1046     1442
-
-Population-Level Effects: 
-             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept       36.18      7.80    20.95    51.26 1.00     4161     3464
-spec_mean_cf     5.10      0.10     4.90     5.30 1.00     8003     4395
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     8.11      0.20     7.73     8.51 1.00     5286     4336
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
hyp <- paste(
-  "sd_phylo__Intercept^2 /", 
-  "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0"
-)
-(hyp <- hypothesis(model_repeat1, hyp, class = NULL))
-
Hypothesis Tests for class :
-                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
-1 (sd_phylo__Interc... = 0     0.74      0.06     0.61     0.84          0         0    *
----
-'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
-'*': For one-sided hypotheses, the posterior probability exceeds 95%;
-for two-sided hypotheses, the value tested against lies outside the 95%-CI.
-Posterior probabilities of point hypotheses assume equal prior probabilities.
-
plot(hyp)
-

-

So far, we have completely ignored the variability of the cofactor within species. To incorporate this into the model, we define

-
data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf
-

and then fit it again using within_spec_cf as an additional predictor.

-
model_repeat2 <- update(
-  model_repeat1, formula = ~ . + within_spec_cf,
-  newdata = data_repeat, chains = 2, cores = 2, 
-  iter = 4000, warmup = 1000
-)
-

The results are almost unchanged, with apparently no relationship between the phenotype and the within species variance of cofactor.

-
summary(model_repeat2)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: phen ~ spec_mean_cf + (1 | gr(phylo, cov = A)) + (1 | species) + within_spec_cf 
-   Data: data_repeat (Number of observations: 1000) 
-  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
-         total post-warmup draws = 6000
-
-Group-Level Effects: 
-~phylo (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)    16.37      1.90    12.88    20.30 1.00     1675     2450
-
-~species (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     5.01      0.84     3.30     6.57 1.00     1179     1617
-
-Population-Level Effects: 
-               Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept         36.19      7.69    21.16    50.86 1.00     4249     3995
-spec_mean_cf       5.10      0.11     4.88     5.30 1.00     8382     3830
-within_spec_cf    -0.06      0.18    -0.43     0.30 1.00     9757     4098
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     8.11      0.21     7.73     8.53 1.00     5397     4137
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

Also, the phylogenetic signal remains more or less the same.

-
hyp <- paste(
-  "sd_phylo__Intercept^2 /", 
-  "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0"
-)
-(hyp <- hypothesis(model_repeat2, hyp, class = NULL))
-
Hypothesis Tests for class :
-                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
-1 (sd_phylo__Interc... = 0     0.74      0.06     0.62     0.84          0         0    *
----
-'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
-'*': For one-sided hypotheses, the posterior probability exceeds 95%;
-for two-sided hypotheses, the value tested against lies outside the 95%-CI.
-Posterior probabilities of point hypotheses assume equal prior probabilities.
-
-
-

A Phylogenetic Meta-Analysis

-

Let’s say we have Fisher’s z-transformed correlation coefficients \(Zr\) per species along with corresponding sample sizes (e.g., correlations between male coloration and reproductive success):

-
data_fisher <- read.table(
-  "https://paul-buerkner.github.io/data/data_effect.txt", 
-  header = TRUE
-)
-data_fisher$obs <- 1:nrow(data_fisher)
-head(data_fisher)
-
          Zr  N phylo obs
-1 0.28917549 13  sp_1   1
-2 0.02415579 40  sp_2   2
-3 0.19513651 39  sp_3   3
-4 0.09831239 40  sp_4   4
-5 0.13780152 66  sp_5   5
-6 0.13710587 41  sp_6   6
-

We assume the sampling variance to be known and as \(V(Zr) = \frac{1}{N - 3}\) for Fisher’s values, where \(N\) is the sample size per species. Incorporating the known sampling variance into the model is straight forward. One has to keep in mind though, that brms requires the sampling standard deviation (square root of the variance) as input instead of the variance itself. The group-level effect of obs represents the residual variance, which we have to model explicitly in a meta-analytic model.

-
model_fisher <- brm(
-  Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), 
-  data = data_fisher, family = gaussian(), 
-  data2 = list(A = A),
-  prior = c(
-    prior(normal(0, 10), "Intercept"),
-    prior(student_t(3, 0, 10), "sd")
-  ),
-  control = list(adapt_delta = 0.95),
-  chains = 2, cores = 2, iter = 4000, warmup = 1000
-)
-

A summary of the fitted model is obtained via

-
summary(model_fisher)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: Zr | se(sqrt(1/(N - 3))) ~ 1 + (1 | gr(phylo, cov = A)) + (1 | obs) 
-   Data: data_fisher (Number of observations: 200) 
-  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
-         total post-warmup draws = 6000
-
-Group-Level Effects: 
-~obs (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     0.05      0.03     0.00     0.10 1.00      757     1399
-
-~phylo (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     0.07      0.04     0.00     0.15 1.00      724     1482
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept     0.16      0.04     0.08     0.23 1.00     3015     2716
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     0.00      0.00     0.00     0.00   NA       NA       NA
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(model_fisher)
-

-

The meta-analytic mean (i.e., the model intercept) is \(0.16\) with a credible interval of \([0.08, 0.25]\). Thus the mean correlation across species is positive according to the model.

-
-
-

A phylogenetic count-data model

-

Suppose that we analyze a phenotype that consists of counts instead of being a continuous variable. In such a case, the normality assumption will likely not be justified and it is recommended to use a distribution explicitly suited for count data, for instance the Poisson distribution. The following data set (again retrieved from mpcm-evolution.org) provides an example.

-
data_pois <- read.table(
-  "https://paul-buerkner.github.io/data/data_pois.txt", 
-  header = TRUE
-)
-data_pois$obs <- 1:nrow(data_pois)
-head(data_pois)
-
  phen_pois   cofactor phylo obs
-1         1  7.8702830  sp_1   1
-2         0  3.4690529  sp_2   2
-3         1  2.5478774  sp_3   3
-4        14 18.2286628  sp_4   4
-5         1  2.5302806  sp_5   5
-6         1  0.5145559  sp_6   6
-

As the Poisson distribution does not have a natural overdispersion parameter, we model the residual variance via the group-level effects of obs (e.g., see Lawless, 1987).

-
model_pois <- brm(
-  phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), 
-  data = data_pois, family = poisson("log"), 
-  data2 = list(A = A),
-  chains = 2, cores = 2, iter = 4000,
-  control = list(adapt_delta = 0.95)
-)
-

Again, we obtain a summary of the fitted model via

-
summary(model_pois)
-
 Family: poisson 
-  Links: mu = log 
-Formula: phen_pois ~ cofactor + (1 | gr(phylo, cov = A)) + (1 | obs) 
-   Data: data_pois (Number of observations: 200) 
-  Draws: 2 chains, each with iter = 4000; warmup = 2000; thin = 1;
-         total post-warmup draws = 4000
-
-Group-Level Effects: 
-~obs (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     0.18      0.09     0.02     0.34 1.00      687      886
-
-~phylo (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     0.18      0.10     0.03     0.41 1.00     1072     1418
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    -2.09      0.20    -2.50    -1.68 1.00     4260     2762
-cofactor      0.25      0.01     0.23     0.27 1.00     5743     2852
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-
plot(conditional_effects(model_pois), points = TRUE)
-

-

Now, assume we ignore the fact that the phenotype is count data and fit a linear normal model instead.

-
model_normal <- brm(
-  phen_pois ~ cofactor + (1|gr(phylo, cov = A)), 
-  data = data_pois, family = gaussian(), 
-  data2 = list(A = A),
-  chains = 2, cores = 2, iter = 4000,
-  control = list(adapt_delta = 0.95)
-)
-
summary(model_normal)
-
 Family: gaussian 
-  Links: mu = identity; sigma = identity 
-Formula: phen_pois ~ cofactor + (1 | gr(phylo, cov = A)) 
-   Data: data_pois (Number of observations: 200) 
-  Draws: 2 chains, each with iter = 4000; warmup = 2000; thin = 1;
-         total post-warmup draws = 4000
-
-Group-Level Effects: 
-~phylo (Number of levels: 200) 
-              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sd(Intercept)     0.70      0.53     0.03     1.98 1.00      889     1415
-
-Population-Level Effects: 
-          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-Intercept    -3.09      0.65    -4.37    -1.80 1.00     3011     1836
-cofactor      0.68      0.04     0.60     0.77 1.00     8183     2819
-
-Family Specific Parameters: 
-      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
-sigma     3.44      0.18     3.08     3.81 1.00     5132     2648
-
-Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
-and Tail_ESS are effective sample size measures, and Rhat is the potential
-scale reduction factor on split chains (at convergence, Rhat = 1).
-

We see that cofactor has a positive relationship with the phenotype in both models. One should keep in mind, though, that the estimates of the Poisson model are on the log-scale, as we applied the canonical log-link function in this example. Therefore, estimates are not comparable to a linear normal model even if applied to the same data. What we can compare, however, is the model fit, for instance graphically via posterior predictive checks.

-
pp_check(model_pois)
-

-
pp_check(model_normal)
-

-

Apparently, the distribution of the phenotype predicted by the Poisson model resembles the original distribution of the phenotype pretty closely, while the normal models fails to do so. We can also apply leave-one-out cross-validation for direct numerical comparison of model fit.

-
loo(model_pois, model_normal)
-
Output of model 'model_pois':
-
-Computed from 4000 by 200 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -348.2 17.0
-p_loo        30.0  3.4
-looic       696.5 34.0
-------
-Monte Carlo SE of elpd_loo is NA.
-
-Pareto k diagnostic values:
-                         Count Pct.    Min. n_eff
-(-Inf, 0.5]   (good)     170   85.0%   694       
- (0.5, 0.7]   (ok)        26   13.0%   143       
-   (0.7, 1]   (bad)        4    2.0%   352       
-   (1, Inf)   (very bad)   0    0.0%   <NA>      
-See help('pareto-k-diagnostic') for details.
-
-Output of model 'model_normal':
-
-Computed from 4000 by 200 log-likelihood matrix
-
-         Estimate   SE
-elpd_loo   -536.1 15.9
-p_loo        10.5  2.3
-looic      1072.3 31.7
-------
-Monte Carlo SE of elpd_loo is 0.1.
-
-Pareto k diagnostic values:
-                         Count Pct.    Min. n_eff
-(-Inf, 0.5]   (good)     194   97.0%   488       
- (0.5, 0.7]   (ok)         6    3.0%   2289      
-   (0.7, 1]   (bad)        0    0.0%   <NA>      
-   (1, Inf)   (very bad)   0    0.0%   <NA>      
-
-All Pareto k estimates are ok (k < 0.7).
-See help('pareto-k-diagnostic') for details.
-
-Model comparisons:
-             elpd_diff se_diff
-model_pois      0.0       0.0 
-model_normal -187.9      18.0
-

Since smaller values of loo indicate better fit, it is again evident that the Poisson model fits the data better than the normal model. Of course, the Poisson model is not the only reasonable option here. For instance, you could use a negative binomial model (via family negative_binomial), which already contains an overdispersion parameter so that modeling a varying intercept of obs becomes obsolete.

-
-
-

Phylogenetic models with multiple group-level effects

-

In the above examples, we have only used a single group-level effect (i.e., a varying intercept) for the phylogenetic grouping factors. In brms, it is also possible to estimate multiple group-level effects (e.g., a varying intercept and a varying slope) for these grouping factors. However, it requires repeatedly computing Kronecker products of covariance matrices while fitting the model. This will be very slow especially when the grouping factors have many levels and matrices are thus large.

-
-
-

References

-

de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for comparative biology. In: Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice (ed. Garamszegi L.) Springer, New York. pp. 287-303.

-

Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for comparative biology: phylogenies, taxonomies, and multi-trait models for continuous and categorical characters. Journal of Evolutionary Biology. 23. 494-508.

-

Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. Canadian Journal of Statistics, 15(3), 209-225.

-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Estimating Phylogenetic Multilevel Models with brms + + + + + + + + + + + + + + + + + + + + + + + + + +

Estimating Phylogenetic Multilevel Models with brms

+

Paul Bürkner

+

2022-04-11

+ + + + +
+

Introduction

+

In the present vignette, we want to discuss how to specify phylogenetic multilevel models using brms. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. The usual approach would be to model species as a grouping factor in a multilevel model and estimate varying intercepts (and possibly also varying slopes) over species. However, species are not independent as they come from the same phylogenetic tree and we thus have to adjust our model to incorporate this dependency. The examples discussed here are from chapter 11 of the book Modern Phylogenetic Comparative Methods and the application in Evolutionary Biology (de Villemeruil & Nakagawa, 2014). The necessary data can be downloaded from the corresponding website (https://www.mpcm-evolution.com/). Some of these models may take a few minutes to fit.

+
+
+

A Simple Phylogenetic Model

+

Assume we have measurements of a phenotype, phen (say the body size), and a cofactor variable (say the temperature of the environment). We prepare the data using the following code.

+
phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex")
+data_simple <- read.table(
+  "https://paul-buerkner.github.io/data/data_simple.txt",
+  header = TRUE
+)
+head(data_simple)
+
       phen  cofactor phylo
+1 107.06595 10.309588  sp_1
+2  79.61086  9.690507  sp_2
+3 116.38186 15.007825  sp_3
+4 143.28705 19.087673  sp_4
+5 139.60993 15.658404  sp_5
+6  68.50657  6.005236  sp_6
+

The phylo object contains information on the relationship between species. Using this information, we can construct a covariance matrix of species (Hadfield & Nakagawa, 2010).

+
A <- ape::vcv.phylo(phylo)
+

Now we are ready to fit our first phylogenetic multilevel model:

+
model_simple <- brm(
+  phen ~ cofactor + (1|gr(phylo, cov = A)),
+  data = data_simple,
+  family = gaussian(),
+  data2 = list(A = A),
+  prior = c(
+    prior(normal(0, 10), "b"),
+    prior(normal(0, 50), "Intercept"),
+    prior(student_t(3, 0, 20), "sd"),
+    prior(student_t(3, 0, 20), "sigma")
+  )
+)
+

With the exception of (1|gr(phylo, cov = A)) instead of (1|phylo) this is a basic multilevel model with a varying intercept over species (phylo is an indicator of species in this data set). However, by using cov = A in the gr function, we make sure that species are correlated as specified by the covariance matrix A. We pass A itself via the data2 argument which can be used for any kinds of data that does not fit into the regular structure of the data argument. Setting priors is not required for achieving good convergence for this model, but it improves sampling speed a bit. After fitting, the results can be investigated in detail.

+
summary(model_simple)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: phen ~ cofactor + (1 | gr(phylo, cov = A)) 
+   Data: data_simple (Number of observations: 200) 
+  Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1;
+         total post-warmup draws = 4000
+
+Group-Level Effects: 
+~phylo (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)    14.57      2.14    10.45    18.90 1.00      873     1347
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    38.16      7.04    24.55    51.82 1.00     2286     2438
+cofactor      5.18      0.14     4.91     5.45 1.00     6730     3471
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     9.19      0.72     7.85    10.68 1.00     1107     1898
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(model_simple, N = 2, ask = FALSE)
+

+
plot(conditional_effects(model_simple), points = TRUE)
+

+

The so called phylogenetic signal (often symbolize by \(\lambda\)) can be computed with the hypothesis method and is roughly \(\lambda = 0.7\) for this example.

+
hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0"
+(hyp <- hypothesis(model_simple, hyp, class = NULL))
+
Hypothesis Tests for class :
+                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
+1 (sd_phylo__Interc... = 0     0.71      0.08     0.52     0.84         NA        NA    *
+---
+'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
+'*': For one-sided hypotheses, the posterior probability exceeds 95%;
+for two-sided hypotheses, the value tested against lies outside the 95%-CI.
+Posterior probabilities of point hypotheses assume equal prior probabilities.
+
plot(hyp)
+

+

Note that the phylogenetic signal is just a synonym of the intra-class correlation (ICC) used in the context phylogenetic analysis.

+
+
+

A Phylogenetic Model with Repeated Measurements

+

Often, we have multiple observations per species and this allows to fit more complicated phylogenetic models.

+
data_repeat <- read.table(
+  "https://paul-buerkner.github.io/data/data_repeat.txt",
+  header = TRUE
+)
+data_repeat$spec_mean_cf <-
+  with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo])
+head(data_repeat)
+
       phen  cofactor species phylo spec_mean_cf
+1 107.41919 11.223724    sp_1  sp_1    10.309588
+2 109.16403  9.805934    sp_1  sp_1    10.309588
+3  91.88672 10.308423    sp_1  sp_1    10.309588
+4 121.54341  8.355349    sp_1  sp_1    10.309588
+5 105.31638 11.854510    sp_1  sp_1    10.309588
+6  64.99859  4.314015    sp_2  sp_2     3.673914
+

The variable spec_mean_cf just contains the mean of the cofactor for each species. The code for the repeated measurement phylogenetic model looks as follows:

+
model_repeat1 <- brm(
+  phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species),
+  data = data_repeat,
+  family = gaussian(),
+  data2 = list(A = A),
+  prior = c(
+    prior(normal(0,10), "b"),
+    prior(normal(0,50), "Intercept"),
+    prior(student_t(3,0,20), "sd"),
+    prior(student_t(3,0,20), "sigma")
+  ),
+  sample_prior = TRUE, chains = 2, cores = 2,
+  iter = 4000, warmup = 1000
+)
+

The variables phylo and species are identical as they are both identifiers of the species. However, we model the phylogenetic covariance only for phylo and thus the species variable accounts for any specific effect that would be independent of the phylogenetic relationship between species (e.g., environmental or niche effects). Again we can obtain model summaries as well as estimates of the phylogenetic signal.

+
summary(model_repeat1)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: phen ~ spec_mean_cf + (1 | gr(phylo, cov = A)) + (1 | species) 
+   Data: data_repeat (Number of observations: 1000) 
+  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
+         total post-warmup draws = 6000
+
+Group-Level Effects: 
+~phylo (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)    16.42      1.91    12.99    20.44 1.00     1518     2864
+
+~species (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     4.97      0.87     3.15     6.63 1.00     1064     1303
+
+Population-Level Effects: 
+             Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept       36.06      8.02    19.87    51.37 1.00     4798     3967
+spec_mean_cf     5.10      0.10     4.90     5.30 1.00     9830     4733
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     8.11      0.21     7.71     8.53 1.00     6450     4383
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
hyp <- paste(
+  "sd_phylo__Intercept^2 /",
+  "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0"
+)
+(hyp <- hypothesis(model_repeat1, hyp, class = NULL))
+
Hypothesis Tests for class :
+                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
+1 (sd_phylo__Interc... = 0     0.74      0.06     0.62     0.84          0         0    *
+---
+'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
+'*': For one-sided hypotheses, the posterior probability exceeds 95%;
+for two-sided hypotheses, the value tested against lies outside the 95%-CI.
+Posterior probabilities of point hypotheses assume equal prior probabilities.
+
plot(hyp)
+

+

So far, we have completely ignored the variability of the cofactor within species. To incorporate this into the model, we define

+
data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf
+

and then fit it again using within_spec_cf as an additional predictor.

+
model_repeat2 <- update(
+  model_repeat1, formula = ~ . + within_spec_cf,
+  newdata = data_repeat, chains = 2, cores = 2,
+  iter = 4000, warmup = 1000
+)
+

The results are almost unchanged, with apparently no relationship between the phenotype and the within species variance of cofactor.

+
summary(model_repeat2)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: phen ~ spec_mean_cf + (1 | gr(phylo, cov = A)) + (1 | species) + within_spec_cf 
+   Data: data_repeat (Number of observations: 1000) 
+  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
+         total post-warmup draws = 6000
+
+Group-Level Effects: 
+~phylo (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)    16.43      1.88    12.92    20.31 1.00     1488     2614
+
+~species (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     5.00      0.84     3.33     6.57 1.00     1232     1814
+
+Population-Level Effects: 
+               Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept         36.01      7.83    20.47    51.43 1.00     5071     4453
+spec_mean_cf       5.10      0.11     4.88     5.30 1.00    10713     4422
+within_spec_cf    -0.06      0.19    -0.43     0.32 1.00    10836     3503
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     8.11      0.21     7.71     8.53 1.00     5608     3964
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

Also, the phylogenetic signal remains more or less the same.

+
hyp <- paste(
+  "sd_phylo__Intercept^2 /",
+  "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0"
+)
+(hyp <- hypothesis(model_repeat2, hyp, class = NULL))
+
Hypothesis Tests for class :
+                Hypothesis Estimate Est.Error CI.Lower CI.Upper Evid.Ratio Post.Prob Star
+1 (sd_phylo__Interc... = 0     0.74      0.06     0.62     0.84          0         0    *
+---
+'CI': 90%-CI for one-sided and 95%-CI for two-sided hypotheses.
+'*': For one-sided hypotheses, the posterior probability exceeds 95%;
+for two-sided hypotheses, the value tested against lies outside the 95%-CI.
+Posterior probabilities of point hypotheses assume equal prior probabilities.
+
+
+

A Phylogenetic Meta-Analysis

+

Let’s say we have Fisher’s z-transformed correlation coefficients \(Zr\) per species along with corresponding sample sizes (e.g., correlations between male coloration and reproductive success):

+
data_fisher <- read.table(
+  "https://paul-buerkner.github.io/data/data_effect.txt",
+  header = TRUE
+)
+data_fisher$obs <- 1:nrow(data_fisher)
+head(data_fisher)
+
          Zr  N phylo obs
+1 0.28917549 13  sp_1   1
+2 0.02415579 40  sp_2   2
+3 0.19513651 39  sp_3   3
+4 0.09831239 40  sp_4   4
+5 0.13780152 66  sp_5   5
+6 0.13710587 41  sp_6   6
+

We assume the sampling variance to be known and as \(V(Zr) = \frac{1}{N - 3}\) for Fisher’s values, where \(N\) is the sample size per species. Incorporating the known sampling variance into the model is straight forward. One has to keep in mind though, that brms requires the sampling standard deviation (square root of the variance) as input instead of the variance itself. The group-level effect of obs represents the residual variance, which we have to model explicitly in a meta-analytic model.

+
model_fisher <- brm(
+  Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs),
+  data = data_fisher, family = gaussian(),
+  data2 = list(A = A),
+  prior = c(
+    prior(normal(0, 10), "Intercept"),
+    prior(student_t(3, 0, 10), "sd")
+  ),
+  control = list(adapt_delta = 0.95),
+  chains = 2, cores = 2, iter = 4000, warmup = 1000
+)
+

A summary of the fitted model is obtained via

+
summary(model_fisher)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: Zr | se(sqrt(1/(N - 3))) ~ 1 + (1 | gr(phylo, cov = A)) + (1 | obs) 
+   Data: data_fisher (Number of observations: 200) 
+  Draws: 2 chains, each with iter = 4000; warmup = 1000; thin = 1;
+         total post-warmup draws = 6000
+
+Group-Level Effects: 
+~obs (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     0.05      0.03     0.00     0.11 1.00      632      893
+
+~phylo (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     0.07      0.04     0.00     0.15 1.00      567     1167
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept     0.16      0.04     0.08     0.25 1.00     1736     1972
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     0.00      0.00     0.00     0.00   NA       NA       NA
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(model_fisher)
+

+

The meta-analytic mean (i.e., the model intercept) is \(0.16\) with a credible interval of \([0.08, 0.25]\). Thus the mean correlation across species is positive according to the model.

+
+
+

A phylogenetic count-data model

+

Suppose that we analyze a phenotype that consists of counts instead of being a continuous variable. In such a case, the normality assumption will likely not be justified and it is recommended to use a distribution explicitly suited for count data, for instance the Poisson distribution. The following data set (again retrieved from mpcm-evolution.org) provides an example.

+
data_pois <- read.table(
+  "https://paul-buerkner.github.io/data/data_pois.txt",
+  header = TRUE
+)
+data_pois$obs <- 1:nrow(data_pois)
+head(data_pois)
+
  phen_pois   cofactor phylo obs
+1         1  7.8702830  sp_1   1
+2         0  3.4690529  sp_2   2
+3         1  2.5478774  sp_3   3
+4        14 18.2286628  sp_4   4
+5         1  2.5302806  sp_5   5
+6         1  0.5145559  sp_6   6
+

As the Poisson distribution does not have a natural overdispersion parameter, we model the residual variance via the group-level effects of obs (e.g., see Lawless, 1987).

+
model_pois <- brm(
+  phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs),
+  data = data_pois, family = poisson("log"),
+  data2 = list(A = A),
+  chains = 2, cores = 2, iter = 4000,
+  control = list(adapt_delta = 0.95)
+)
+

Again, we obtain a summary of the fitted model via

+
summary(model_pois)
+
 Family: poisson 
+  Links: mu = log 
+Formula: phen_pois ~ cofactor + (1 | gr(phylo, cov = A)) + (1 | obs) 
+   Data: data_pois (Number of observations: 200) 
+  Draws: 2 chains, each with iter = 4000; warmup = 2000; thin = 1;
+         total post-warmup draws = 4000
+
+Group-Level Effects: 
+~obs (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     0.19      0.08     0.02     0.35 1.00      470      784
+
+~phylo (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     0.18      0.10     0.02     0.41 1.00      830     1048
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    -2.09      0.21    -2.50    -1.70 1.00     2450     2195
+cofactor      0.25      0.01     0.23     0.27 1.00     3357     2661
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+
plot(conditional_effects(model_pois), points = TRUE)
+

+

Now, assume we ignore the fact that the phenotype is count data and fit a linear normal model instead.

+
model_normal <- brm(
+  phen_pois ~ cofactor + (1|gr(phylo, cov = A)),
+  data = data_pois, family = gaussian(),
+  data2 = list(A = A),
+  chains = 2, cores = 2, iter = 4000,
+  control = list(adapt_delta = 0.95)
+)
+
summary(model_normal)
+
 Family: gaussian 
+  Links: mu = identity; sigma = identity 
+Formula: phen_pois ~ cofactor + (1 | gr(phylo, cov = A)) 
+   Data: data_pois (Number of observations: 200) 
+  Draws: 2 chains, each with iter = 4000; warmup = 2000; thin = 1;
+         total post-warmup draws = 4000
+
+Group-Level Effects: 
+~phylo (Number of levels: 200) 
+              Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sd(Intercept)     0.70      0.53     0.03     1.97 1.00      804     1074
+
+Population-Level Effects: 
+          Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+Intercept    -3.07      0.62    -4.37    -1.86 1.00     3828     2069
+cofactor      0.68      0.04     0.60     0.76 1.00     8910     2767
+
+Family Specific Parameters: 
+      Estimate Est.Error l-95% CI u-95% CI Rhat Bulk_ESS Tail_ESS
+sigma     3.43      0.18     3.07     3.80 1.00     3475     1392
+
+Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS
+and Tail_ESS are effective sample size measures, and Rhat is the potential
+scale reduction factor on split chains (at convergence, Rhat = 1).
+

We see that cofactor has a positive relationship with the phenotype in both models. One should keep in mind, though, that the estimates of the Poisson model are on the log-scale, as we applied the canonical log-link function in this example. Therefore, estimates are not comparable to a linear normal model even if applied to the same data. What we can compare, however, is the model fit, for instance graphically via posterior predictive checks.

+
pp_check(model_pois)
+

+
pp_check(model_normal)
+

+

Apparently, the distribution of the phenotype predicted by the Poisson model resembles the original distribution of the phenotype pretty closely, while the normal models fails to do so. We can also apply leave-one-out cross-validation for direct numerical comparison of model fit.

+
loo(model_pois, model_normal)
+
Output of model 'model_pois':
+
+Computed from 4000 by 200 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -348.2 17.0
+p_loo        30.2  3.4
+looic       696.4 33.9
+------
+Monte Carlo SE of elpd_loo is NA.
+
+Pareto k diagnostic values:
+                         Count Pct.    Min. n_eff
+(-Inf, 0.5]   (good)     165   82.5%   648       
+ (0.5, 0.7]   (ok)        30   15.0%   238       
+   (0.7, 1]   (bad)        5    2.5%   226       
+   (1, Inf)   (very bad)   0    0.0%   <NA>      
+See help('pareto-k-diagnostic') for details.
+
+Output of model 'model_normal':
+
+Computed from 4000 by 200 log-likelihood matrix
+
+         Estimate   SE
+elpd_loo   -535.8 15.8
+p_loo        10.0  2.2
+looic      1071.5 31.7
+------
+Monte Carlo SE of elpd_loo is 0.1.
+
+Pareto k diagnostic values:
+                         Count Pct.    Min. n_eff
+(-Inf, 0.5]   (good)     194   97.0%   526       
+ (0.5, 0.7]   (ok)         6    3.0%   529       
+   (0.7, 1]   (bad)        0    0.0%   <NA>      
+   (1, Inf)   (very bad)   0    0.0%   <NA>      
+
+All Pareto k estimates are ok (k < 0.7).
+See help('pareto-k-diagnostic') for details.
+
+Model comparisons:
+             elpd_diff se_diff
+model_pois      0.0       0.0 
+model_normal -187.6      18.1
+

Since smaller values of loo indicate better fit, it is again evident that the Poisson model fits the data better than the normal model. Of course, the Poisson model is not the only reasonable option here. For instance, you could use a negative binomial model (via family negative_binomial), which already contains an overdispersion parameter so that modeling a varying intercept of obs becomes obsolete.

+
+
+

Phylogenetic models with multiple group-level effects

+

In the above examples, we have only used a single group-level effect (i.e., a varying intercept) for the phylogenetic grouping factors. In brms, it is also possible to estimate multiple group-level effects (e.g., a varying intercept and a varying slope) for these grouping factors. However, it requires repeatedly computing Kronecker products of covariance matrices while fitting the model. This will be very slow especially when the grouping factors have many levels and matrices are thus large.

+
+
+

References

+

de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for comparative biology. In: Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice (ed. Garamszegi L.) Springer, New York. pp. 287-303.

+

Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for comparative biology: phylogenies, taxonomies, and multi-trait models for continuous and categorical characters. Journal of Evolutionary Biology. 23. 494-508.

+

Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. Canadian Journal of Statistics, 15(3), 209-225.

+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_phylogenetics.R r-cran-brms-2.17.0/inst/doc/brms_phylogenetics.R --- r-cran-brms-2.16.3/inst/doc/brms_phylogenetics.R 2021-11-22 16:48:13.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_phylogenetics.R 2022-04-11 08:19:11.000000000 +0000 @@ -1,177 +1,177 @@ -params <- -list(EVAL = TRUE) - -## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) - -## --------------------------------------------------------------------------------------- -phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") -data_simple <- read.table( - "https://paul-buerkner.github.io/data/data_simple.txt", - header = TRUE -) -head(data_simple) - -## --------------------------------------------------------------------------------------- -A <- ape::vcv.phylo(phylo) - -## ---- results='hide'-------------------------------------------------------------------- -model_simple <- brm( - phen ~ cofactor + (1|gr(phylo, cov = A)), - data = data_simple, - family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0, 10), "b"), - prior(normal(0, 50), "Intercept"), - prior(student_t(3, 0, 20), "sd"), - prior(student_t(3, 0, 20), "sigma") - ) -) - -## --------------------------------------------------------------------------------------- -summary(model_simple) -plot(model_simple, N = 2, ask = FALSE) -plot(conditional_effects(model_simple), points = TRUE) - -## --------------------------------------------------------------------------------------- -hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" -(hyp <- hypothesis(model_simple, hyp, class = NULL)) -plot(hyp) - -## --------------------------------------------------------------------------------------- -data_repeat <- read.table( - "https://paul-buerkner.github.io/data/data_repeat.txt", - header = TRUE -) -data_repeat$spec_mean_cf <- - with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) -head(data_repeat) - -## ---- results='hide'-------------------------------------------------------------------- -model_repeat1 <- brm( - phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), - data = data_repeat, - family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0,10), "b"), - prior(normal(0,50), "Intercept"), - prior(student_t(3,0,20), "sd"), - prior(student_t(3,0,20), "sigma") - ), - sample_prior = TRUE, chains = 2, cores = 2, - iter = 4000, warmup = 1000 -) - -## --------------------------------------------------------------------------------------- -summary(model_repeat1) - -## --------------------------------------------------------------------------------------- -hyp <- paste( - "sd_phylo__Intercept^2 /", - "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" -) -(hyp <- hypothesis(model_repeat1, hyp, class = NULL)) -plot(hyp) - -## --------------------------------------------------------------------------------------- -data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf - -## ---- results='hide'-------------------------------------------------------------------- -model_repeat2 <- update( - model_repeat1, formula = ~ . + within_spec_cf, - newdata = data_repeat, chains = 2, cores = 2, - iter = 4000, warmup = 1000 -) - -## --------------------------------------------------------------------------------------- -summary(model_repeat2) - -## --------------------------------------------------------------------------------------- -hyp <- paste( - "sd_phylo__Intercept^2 /", - "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" -) -(hyp <- hypothesis(model_repeat2, hyp, class = NULL)) - -## --------------------------------------------------------------------------------------- -data_fisher <- read.table( - "https://paul-buerkner.github.io/data/data_effect.txt", - header = TRUE -) -data_fisher$obs <- 1:nrow(data_fisher) -head(data_fisher) - -## ---- results='hide'-------------------------------------------------------------------- -model_fisher <- brm( - Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), - data = data_fisher, family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0, 10), "Intercept"), - prior(student_t(3, 0, 10), "sd") - ), - control = list(adapt_delta = 0.95), - chains = 2, cores = 2, iter = 4000, warmup = 1000 -) - -## --------------------------------------------------------------------------------------- -summary(model_fisher) -plot(model_fisher) - -## --------------------------------------------------------------------------------------- -data_pois <- read.table( - "https://paul-buerkner.github.io/data/data_pois.txt", - header = TRUE -) -data_pois$obs <- 1:nrow(data_pois) -head(data_pois) - -## ---- results='hide'-------------------------------------------------------------------- -model_pois <- brm( - phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), - data = data_pois, family = poisson("log"), - data2 = list(A = A), - chains = 2, cores = 2, iter = 4000, - control = list(adapt_delta = 0.95) -) - -## --------------------------------------------------------------------------------------- -summary(model_pois) -plot(conditional_effects(model_pois), points = TRUE) - -## ---- results='hide'-------------------------------------------------------------------- -model_normal <- brm( - phen_pois ~ cofactor + (1|gr(phylo, cov = A)), - data = data_pois, family = gaussian(), - data2 = list(A = A), - chains = 2, cores = 2, iter = 4000, - control = list(adapt_delta = 0.95) -) - -## --------------------------------------------------------------------------------------- -summary(model_normal) - -## --------------------------------------------------------------------------------------- -pp_check(model_pois) -pp_check(model_normal) - -## --------------------------------------------------------------------------------------- -loo(model_pois, model_normal) - +params <- +list(EVAL = TRUE) + +## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) + +## --------------------------------------------------------------------------------------- +phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") +data_simple <- read.table( + "https://paul-buerkner.github.io/data/data_simple.txt", + header = TRUE +) +head(data_simple) + +## --------------------------------------------------------------------------------------- +A <- ape::vcv.phylo(phylo) + +## ---- results='hide'-------------------------------------------------------------------- +model_simple <- brm( + phen ~ cofactor + (1|gr(phylo, cov = A)), + data = data_simple, + family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0, 10), "b"), + prior(normal(0, 50), "Intercept"), + prior(student_t(3, 0, 20), "sd"), + prior(student_t(3, 0, 20), "sigma") + ) +) + +## --------------------------------------------------------------------------------------- +summary(model_simple) +plot(model_simple, N = 2, ask = FALSE) +plot(conditional_effects(model_simple), points = TRUE) + +## --------------------------------------------------------------------------------------- +hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" +(hyp <- hypothesis(model_simple, hyp, class = NULL)) +plot(hyp) + +## --------------------------------------------------------------------------------------- +data_repeat <- read.table( + "https://paul-buerkner.github.io/data/data_repeat.txt", + header = TRUE +) +data_repeat$spec_mean_cf <- + with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) +head(data_repeat) + +## ---- results='hide'-------------------------------------------------------------------- +model_repeat1 <- brm( + phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), + data = data_repeat, + family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0,10), "b"), + prior(normal(0,50), "Intercept"), + prior(student_t(3,0,20), "sd"), + prior(student_t(3,0,20), "sigma") + ), + sample_prior = TRUE, chains = 2, cores = 2, + iter = 4000, warmup = 1000 +) + +## --------------------------------------------------------------------------------------- +summary(model_repeat1) + +## --------------------------------------------------------------------------------------- +hyp <- paste( + "sd_phylo__Intercept^2 /", + "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" +) +(hyp <- hypothesis(model_repeat1, hyp, class = NULL)) +plot(hyp) + +## --------------------------------------------------------------------------------------- +data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf + +## ---- results='hide'-------------------------------------------------------------------- +model_repeat2 <- update( + model_repeat1, formula = ~ . + within_spec_cf, + newdata = data_repeat, chains = 2, cores = 2, + iter = 4000, warmup = 1000 +) + +## --------------------------------------------------------------------------------------- +summary(model_repeat2) + +## --------------------------------------------------------------------------------------- +hyp <- paste( + "sd_phylo__Intercept^2 /", + "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" +) +(hyp <- hypothesis(model_repeat2, hyp, class = NULL)) + +## --------------------------------------------------------------------------------------- +data_fisher <- read.table( + "https://paul-buerkner.github.io/data/data_effect.txt", + header = TRUE +) +data_fisher$obs <- 1:nrow(data_fisher) +head(data_fisher) + +## ---- results='hide'-------------------------------------------------------------------- +model_fisher <- brm( + Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), + data = data_fisher, family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0, 10), "Intercept"), + prior(student_t(3, 0, 10), "sd") + ), + control = list(adapt_delta = 0.95), + chains = 2, cores = 2, iter = 4000, warmup = 1000 +) + +## --------------------------------------------------------------------------------------- +summary(model_fisher) +plot(model_fisher) + +## --------------------------------------------------------------------------------------- +data_pois <- read.table( + "https://paul-buerkner.github.io/data/data_pois.txt", + header = TRUE +) +data_pois$obs <- 1:nrow(data_pois) +head(data_pois) + +## ---- results='hide'-------------------------------------------------------------------- +model_pois <- brm( + phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), + data = data_pois, family = poisson("log"), + data2 = list(A = A), + chains = 2, cores = 2, iter = 4000, + control = list(adapt_delta = 0.95) +) + +## --------------------------------------------------------------------------------------- +summary(model_pois) +plot(conditional_effects(model_pois), points = TRUE) + +## ---- results='hide'-------------------------------------------------------------------- +model_normal <- brm( + phen_pois ~ cofactor + (1|gr(phylo, cov = A)), + data = data_pois, family = gaussian(), + data2 = list(A = A), + chains = 2, cores = 2, iter = 4000, + control = list(adapt_delta = 0.95) +) + +## --------------------------------------------------------------------------------------- +summary(model_normal) + +## --------------------------------------------------------------------------------------- +pp_check(model_pois) +pp_check(model_normal) + +## --------------------------------------------------------------------------------------- +loo(model_pois, model_normal) + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_phylogenetics.Rmd r-cran-brms-2.17.0/inst/doc/brms_phylogenetics.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_phylogenetics.Rmd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_phylogenetics.Rmd 2022-04-11 07:21:34.000000000 +0000 @@ -1,365 +1,365 @@ ---- -title: "Estimating Phylogenetic Multilevel Models with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Phylogenetic Multilevel Models with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -In the present vignette, we want to discuss how to specify phylogenetic -multilevel models using **brms**. These models are relevant in evolutionary -biology when data of many species are analyzed at the same time. The usual -approach would be to model species as a grouping factor in a multilevel model -and estimate varying intercepts (and possibly also varying slopes) over species. -However, species are not independent as they come from the same phylogenetic -tree and we thus have to adjust our model to incorporate this dependency. The -examples discussed here are from chapter 11 of the book *Modern Phylogenetic -Comparative Methods and the application in Evolutionary Biology* (de Villemeruil -& Nakagawa, 2014). The necessary data can be downloaded from the corresponding -website (http://www.mpcm-evolution.com/). Some of these models may take a few -minutes to fit. - -## A Simple Phylogenetic Model - -Assume we have measurements of a phenotype, `phen` (say the body size), and a -`cofactor` variable (say the temperature of the environment). We prepare the -data using the following code. - -```{r} -phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") -data_simple <- read.table( - "https://paul-buerkner.github.io/data/data_simple.txt", - header = TRUE -) -head(data_simple) -``` - -The `phylo` object contains information on the relationship between species. -Using this information, we can construct a covariance matrix of species -(Hadfield & Nakagawa, 2010). - -```{r} -A <- ape::vcv.phylo(phylo) -``` - -Now we are ready to fit our first phylogenetic multilevel model: - -```{r, results='hide'} -model_simple <- brm( - phen ~ cofactor + (1|gr(phylo, cov = A)), - data = data_simple, - family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0, 10), "b"), - prior(normal(0, 50), "Intercept"), - prior(student_t(3, 0, 20), "sd"), - prior(student_t(3, 0, 20), "sigma") - ) -) -``` - -With the exception of `(1|gr(phylo, cov = A))` instead of `(1|phylo)` this is a -basic multilevel model with a varying intercept over species (`phylo` is an -indicator of species in this data set). However, by using `cov = A` in the `gr` -function, we make sure that species are correlated as specified by the -covariance matrix `A`. We pass `A` itself via the `data2` argument which can be -used for any kinds of data that does not fit into the regular structure of the -`data` argument. Setting priors is not required for achieving good convergence -for this model, but it improves sampling speed a bit. After fitting, the results -can be investigated in detail. - -```{r} -summary(model_simple) -plot(model_simple, N = 2, ask = FALSE) -plot(conditional_effects(model_simple), points = TRUE) -``` - -The so called phylogenetic signal (often symbolize by $\lambda$) can be computed -with the `hypothesis` method and is roughly $\lambda = 0.7$ for this example. - -```{r} -hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" -(hyp <- hypothesis(model_simple, hyp, class = NULL)) -plot(hyp) -``` - -Note that the phylogenetic signal is just a synonym of the intra-class -correlation (ICC) used in the context phylogenetic analysis. - - -## A Phylogenetic Model with Repeated Measurements - -Often, we have multiple observations per species and this allows to fit more -complicated phylogenetic models. - -```{r} -data_repeat <- read.table( - "https://paul-buerkner.github.io/data/data_repeat.txt", - header = TRUE -) -data_repeat$spec_mean_cf <- - with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) -head(data_repeat) -``` - -The variable `spec_mean_cf` just contains the mean of the cofactor for each -species. The code for the repeated measurement phylogenetic model looks as -follows: - -```{r, results='hide'} -model_repeat1 <- brm( - phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), - data = data_repeat, - family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0,10), "b"), - prior(normal(0,50), "Intercept"), - prior(student_t(3,0,20), "sd"), - prior(student_t(3,0,20), "sigma") - ), - sample_prior = TRUE, chains = 2, cores = 2, - iter = 4000, warmup = 1000 -) -``` - -The variables `phylo` and `species` are identical as they are both identifiers -of the species. However, we model the phylogenetic covariance only for `phylo` -and thus the `species` variable accounts for any specific effect that would be -independent of the phylogenetic relationship between species (e.g., -environmental or niche effects). Again we can obtain model summaries as well as -estimates of the phylogenetic signal. - -```{r} -summary(model_repeat1) -``` - -```{r} -hyp <- paste( - "sd_phylo__Intercept^2 /", - "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" -) -(hyp <- hypothesis(model_repeat1, hyp, class = NULL)) -plot(hyp) -``` - -So far, we have completely ignored the variability of the cofactor within -species. To incorporate this into the model, we define - -```{r} -data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf -``` - -and then fit it again using `within_spec_cf` as an additional predictor. - -```{r, results='hide'} -model_repeat2 <- update( - model_repeat1, formula = ~ . + within_spec_cf, - newdata = data_repeat, chains = 2, cores = 2, - iter = 4000, warmup = 1000 -) -``` - -The results are almost unchanged, with apparently no relationship between the -phenotype and the within species variance of `cofactor`. - -```{r} -summary(model_repeat2) -``` - -Also, the phylogenetic signal remains more or less the same. - -```{r} -hyp <- paste( - "sd_phylo__Intercept^2 /", - "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" -) -(hyp <- hypothesis(model_repeat2, hyp, class = NULL)) -``` - - -## A Phylogenetic Meta-Analysis - -Let's say we have Fisher's z-transformed correlation coefficients $Zr$ per -species along with corresponding sample sizes (e.g., correlations between male -coloration and reproductive success): - -```{r} -data_fisher <- read.table( - "https://paul-buerkner.github.io/data/data_effect.txt", - header = TRUE -) -data_fisher$obs <- 1:nrow(data_fisher) -head(data_fisher) -``` - -We assume the sampling variance to be known and as $V(Zr) = \frac{1}{N - 3}$ for -Fisher's values, where $N$ is the sample size per species. Incorporating the -known sampling variance into the model is straight forward. One has to keep in -mind though, that **brms** requires the sampling standard deviation (square root -of the variance) as input instead of the variance itself. The group-level effect -of `obs` represents the residual variance, which we have to model explicitly in -a meta-analytic model. - -```{r, results='hide'} -model_fisher <- brm( - Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), - data = data_fisher, family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0, 10), "Intercept"), - prior(student_t(3, 0, 10), "sd") - ), - control = list(adapt_delta = 0.95), - chains = 2, cores = 2, iter = 4000, warmup = 1000 -) -``` - -A summary of the fitted model is obtained via - -```{r} -summary(model_fisher) -plot(model_fisher) -``` - -The meta-analytic mean (i.e., the model intercept) is $0.16$ with a credible -interval of $[0.08, 0.25]$. Thus the mean correlation across species is positive -according to the model. - - -## A phylogenetic count-data model - -Suppose that we analyze a phenotype that consists of counts instead of being a -continuous variable. In such a case, the normality assumption will likely not be -justified and it is recommended to use a distribution explicitly suited for -count data, for instance the Poisson distribution. The following data set (again -retrieved from mpcm-evolution.org) provides an example. - -```{r} -data_pois <- read.table( - "https://paul-buerkner.github.io/data/data_pois.txt", - header = TRUE -) -data_pois$obs <- 1:nrow(data_pois) -head(data_pois) -``` - -As the Poisson distribution does not have a natural overdispersion parameter, we -model the residual variance via the group-level effects of `obs` (e.g., see -Lawless, 1987). - -```{r, results='hide'} -model_pois <- brm( - phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), - data = data_pois, family = poisson("log"), - data2 = list(A = A), - chains = 2, cores = 2, iter = 4000, - control = list(adapt_delta = 0.95) -) -``` - -Again, we obtain a summary of the fitted model via - -```{r} -summary(model_pois) -plot(conditional_effects(model_pois), points = TRUE) -``` - -Now, assume we ignore the fact that the phenotype is count data and fit a linear -normal model instead. - -```{r, results='hide'} -model_normal <- brm( - phen_pois ~ cofactor + (1|gr(phylo, cov = A)), - data = data_pois, family = gaussian(), - data2 = list(A = A), - chains = 2, cores = 2, iter = 4000, - control = list(adapt_delta = 0.95) -) -``` - -```{r} -summary(model_normal) -``` - -We see that `cofactor` has a positive relationship with the phenotype in both -models. One should keep in mind, though, that the estimates of the Poisson model -are on the log-scale, as we applied the canonical log-link function in this -example. Therefore, estimates are not comparable to a linear normal model even -if applied to the same data. What we can compare, however, is the model fit, for -instance graphically via posterior predictive checks. - -```{r} -pp_check(model_pois) -pp_check(model_normal) -``` - -Apparently, the distribution of the phenotype predicted by the Poisson model -resembles the original distribution of the phenotype pretty closely, while the -normal models fails to do so. We can also apply leave-one-out cross-validation -for direct numerical comparison of model fit. - -```{r} -loo(model_pois, model_normal) -``` - -Since smaller values of loo indicate better fit, it is again evident that the -Poisson model fits the data better than the normal model. Of course, the Poisson -model is not the only reasonable option here. For instance, you could use a -negative binomial model (via family `negative_binomial`), which already contains -an overdispersion parameter so that modeling a varying intercept of `obs` -becomes obsolete. - -## Phylogenetic models with multiple group-level effects - -In the above examples, we have only used a single group-level effect (i.e., a -varying intercept) for the phylogenetic grouping factors. In **brms**, it is -also possible to estimate multiple group-level effects (e.g., a varying -intercept and a varying slope) for these grouping factors. However, it requires -repeatedly computing Kronecker products of covariance matrices while fitting the -model. This will be very slow especially when the grouping factors have many -levels and matrices are thus large. - -## References - -de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for -comparative biology. In: -*Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice* -(ed. Garamszegi L.) Springer, New York. pp. 287-303. - -Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for -comparative biology: phylogenies, taxonomies, and multi-trait models for -continuous and categorical characters. *Journal of Evolutionary Biology*. 23. -494-508. - -Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. -*Canadian Journal of Statistics*, 15(3), 209-225. +--- +title: "Estimating Phylogenetic Multilevel Models with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Phylogenetic Multilevel Models with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +In the present vignette, we want to discuss how to specify phylogenetic +multilevel models using **brms**. These models are relevant in evolutionary +biology when data of many species are analyzed at the same time. The usual +approach would be to model species as a grouping factor in a multilevel model +and estimate varying intercepts (and possibly also varying slopes) over species. +However, species are not independent as they come from the same phylogenetic +tree and we thus have to adjust our model to incorporate this dependency. The +examples discussed here are from chapter 11 of the book *Modern Phylogenetic +Comparative Methods and the application in Evolutionary Biology* (de Villemeruil +& Nakagawa, 2014). The necessary data can be downloaded from the corresponding +website (https://www.mpcm-evolution.com/). Some of these models may take a few +minutes to fit. + +## A Simple Phylogenetic Model + +Assume we have measurements of a phenotype, `phen` (say the body size), and a +`cofactor` variable (say the temperature of the environment). We prepare the +data using the following code. + +```{r} +phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") +data_simple <- read.table( + "https://paul-buerkner.github.io/data/data_simple.txt", + header = TRUE +) +head(data_simple) +``` + +The `phylo` object contains information on the relationship between species. +Using this information, we can construct a covariance matrix of species +(Hadfield & Nakagawa, 2010). + +```{r} +A <- ape::vcv.phylo(phylo) +``` + +Now we are ready to fit our first phylogenetic multilevel model: + +```{r, results='hide'} +model_simple <- brm( + phen ~ cofactor + (1|gr(phylo, cov = A)), + data = data_simple, + family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0, 10), "b"), + prior(normal(0, 50), "Intercept"), + prior(student_t(3, 0, 20), "sd"), + prior(student_t(3, 0, 20), "sigma") + ) +) +``` + +With the exception of `(1|gr(phylo, cov = A))` instead of `(1|phylo)` this is a +basic multilevel model with a varying intercept over species (`phylo` is an +indicator of species in this data set). However, by using `cov = A` in the `gr` +function, we make sure that species are correlated as specified by the +covariance matrix `A`. We pass `A` itself via the `data2` argument which can be +used for any kinds of data that does not fit into the regular structure of the +`data` argument. Setting priors is not required for achieving good convergence +for this model, but it improves sampling speed a bit. After fitting, the results +can be investigated in detail. + +```{r} +summary(model_simple) +plot(model_simple, N = 2, ask = FALSE) +plot(conditional_effects(model_simple), points = TRUE) +``` + +The so called phylogenetic signal (often symbolize by $\lambda$) can be computed +with the `hypothesis` method and is roughly $\lambda = 0.7$ for this example. + +```{r} +hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" +(hyp <- hypothesis(model_simple, hyp, class = NULL)) +plot(hyp) +``` + +Note that the phylogenetic signal is just a synonym of the intra-class +correlation (ICC) used in the context phylogenetic analysis. + + +## A Phylogenetic Model with Repeated Measurements + +Often, we have multiple observations per species and this allows to fit more +complicated phylogenetic models. + +```{r} +data_repeat <- read.table( + "https://paul-buerkner.github.io/data/data_repeat.txt", + header = TRUE +) +data_repeat$spec_mean_cf <- + with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) +head(data_repeat) +``` + +The variable `spec_mean_cf` just contains the mean of the cofactor for each +species. The code for the repeated measurement phylogenetic model looks as +follows: + +```{r, results='hide'} +model_repeat1 <- brm( + phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), + data = data_repeat, + family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0,10), "b"), + prior(normal(0,50), "Intercept"), + prior(student_t(3,0,20), "sd"), + prior(student_t(3,0,20), "sigma") + ), + sample_prior = TRUE, chains = 2, cores = 2, + iter = 4000, warmup = 1000 +) +``` + +The variables `phylo` and `species` are identical as they are both identifiers +of the species. However, we model the phylogenetic covariance only for `phylo` +and thus the `species` variable accounts for any specific effect that would be +independent of the phylogenetic relationship between species (e.g., +environmental or niche effects). Again we can obtain model summaries as well as +estimates of the phylogenetic signal. + +```{r} +summary(model_repeat1) +``` + +```{r} +hyp <- paste( + "sd_phylo__Intercept^2 /", + "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" +) +(hyp <- hypothesis(model_repeat1, hyp, class = NULL)) +plot(hyp) +``` + +So far, we have completely ignored the variability of the cofactor within +species. To incorporate this into the model, we define + +```{r} +data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf +``` + +and then fit it again using `within_spec_cf` as an additional predictor. + +```{r, results='hide'} +model_repeat2 <- update( + model_repeat1, formula = ~ . + within_spec_cf, + newdata = data_repeat, chains = 2, cores = 2, + iter = 4000, warmup = 1000 +) +``` + +The results are almost unchanged, with apparently no relationship between the +phenotype and the within species variance of `cofactor`. + +```{r} +summary(model_repeat2) +``` + +Also, the phylogenetic signal remains more or less the same. + +```{r} +hyp <- paste( + "sd_phylo__Intercept^2 /", + "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" +) +(hyp <- hypothesis(model_repeat2, hyp, class = NULL)) +``` + + +## A Phylogenetic Meta-Analysis + +Let's say we have Fisher's z-transformed correlation coefficients $Zr$ per +species along with corresponding sample sizes (e.g., correlations between male +coloration and reproductive success): + +```{r} +data_fisher <- read.table( + "https://paul-buerkner.github.io/data/data_effect.txt", + header = TRUE +) +data_fisher$obs <- 1:nrow(data_fisher) +head(data_fisher) +``` + +We assume the sampling variance to be known and as $V(Zr) = \frac{1}{N - 3}$ for +Fisher's values, where $N$ is the sample size per species. Incorporating the +known sampling variance into the model is straight forward. One has to keep in +mind though, that **brms** requires the sampling standard deviation (square root +of the variance) as input instead of the variance itself. The group-level effect +of `obs` represents the residual variance, which we have to model explicitly in +a meta-analytic model. + +```{r, results='hide'} +model_fisher <- brm( + Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), + data = data_fisher, family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0, 10), "Intercept"), + prior(student_t(3, 0, 10), "sd") + ), + control = list(adapt_delta = 0.95), + chains = 2, cores = 2, iter = 4000, warmup = 1000 +) +``` + +A summary of the fitted model is obtained via + +```{r} +summary(model_fisher) +plot(model_fisher) +``` + +The meta-analytic mean (i.e., the model intercept) is $0.16$ with a credible +interval of $[0.08, 0.25]$. Thus the mean correlation across species is positive +according to the model. + + +## A phylogenetic count-data model + +Suppose that we analyze a phenotype that consists of counts instead of being a +continuous variable. In such a case, the normality assumption will likely not be +justified and it is recommended to use a distribution explicitly suited for +count data, for instance the Poisson distribution. The following data set (again +retrieved from mpcm-evolution.org) provides an example. + +```{r} +data_pois <- read.table( + "https://paul-buerkner.github.io/data/data_pois.txt", + header = TRUE +) +data_pois$obs <- 1:nrow(data_pois) +head(data_pois) +``` + +As the Poisson distribution does not have a natural overdispersion parameter, we +model the residual variance via the group-level effects of `obs` (e.g., see +Lawless, 1987). + +```{r, results='hide'} +model_pois <- brm( + phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), + data = data_pois, family = poisson("log"), + data2 = list(A = A), + chains = 2, cores = 2, iter = 4000, + control = list(adapt_delta = 0.95) +) +``` + +Again, we obtain a summary of the fitted model via + +```{r} +summary(model_pois) +plot(conditional_effects(model_pois), points = TRUE) +``` + +Now, assume we ignore the fact that the phenotype is count data and fit a linear +normal model instead. + +```{r, results='hide'} +model_normal <- brm( + phen_pois ~ cofactor + (1|gr(phylo, cov = A)), + data = data_pois, family = gaussian(), + data2 = list(A = A), + chains = 2, cores = 2, iter = 4000, + control = list(adapt_delta = 0.95) +) +``` + +```{r} +summary(model_normal) +``` + +We see that `cofactor` has a positive relationship with the phenotype in both +models. One should keep in mind, though, that the estimates of the Poisson model +are on the log-scale, as we applied the canonical log-link function in this +example. Therefore, estimates are not comparable to a linear normal model even +if applied to the same data. What we can compare, however, is the model fit, for +instance graphically via posterior predictive checks. + +```{r} +pp_check(model_pois) +pp_check(model_normal) +``` + +Apparently, the distribution of the phenotype predicted by the Poisson model +resembles the original distribution of the phenotype pretty closely, while the +normal models fails to do so. We can also apply leave-one-out cross-validation +for direct numerical comparison of model fit. + +```{r} +loo(model_pois, model_normal) +``` + +Since smaller values of loo indicate better fit, it is again evident that the +Poisson model fits the data better than the normal model. Of course, the Poisson +model is not the only reasonable option here. For instance, you could use a +negative binomial model (via family `negative_binomial`), which already contains +an overdispersion parameter so that modeling a varying intercept of `obs` +becomes obsolete. + +## Phylogenetic models with multiple group-level effects + +In the above examples, we have only used a single group-level effect (i.e., a +varying intercept) for the phylogenetic grouping factors. In **brms**, it is +also possible to estimate multiple group-level effects (e.g., a varying +intercept and a varying slope) for these grouping factors. However, it requires +repeatedly computing Kronecker products of covariance matrices while fitting the +model. This will be very slow especially when the grouping factors have many +levels and matrices are thus large. + +## References + +de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for +comparative biology. In: +*Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice* +(ed. Garamszegi L.) Springer, New York. pp. 287-303. + +Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for +comparative biology: phylogenies, taxonomies, and multi-trait models for +continuous and categorical characters. *Journal of Evolutionary Biology*. 23. +494-508. + +Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. +*Canadian Journal of Statistics*, 15(3), 209-225. diff -Nru r-cran-brms-2.16.3/inst/doc/brms_threading.html r-cran-brms-2.17.0/inst/doc/brms_threading.html --- r-cran-brms-2.16.3/inst/doc/brms_threading.html 2021-11-22 17:06:12.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_threading.html 2022-04-11 08:20:27.000000000 +0000 @@ -1,744 +1,771 @@ - - - - - - - - - - - - - - - - -Running brms models with within-chain parallelization - - - - - - - - - - - - - - - - - - - - - - - - - -

Running brms models with within-chain parallelization

-

Sebastian Weber & Paul Bürkner

-

2021-11-22

- - - - -
-

Introduction

-

Full Bayesian inference is a computationally very demanding task and often we wish to run our models faster in shorter walltime. With modern computers we nowadays have multiple processors available on a given machine such that the use of running the inference in parallel will shorten the overall walltime. While between-chain parallelization is straightforward by merely launching multiple chains at the same time, the use of within-chain parallelization is more complicated in various ways. This vignette aims to introduce the user to within-chain parallelization with brms, since its efficient use depends on various aspects specific to the users model.

-
-
-

Quick summary

-

Assuming you have a brms model which you wish to evaluate faster by using more cores per chain, for example:

-
fit_serial <- brm(
-  count ~ zAge + zBase * Trt + (1|patient),
-  data = epilepsy, family = poisson(),
-  chains = 4, cores = 4, backend = "cmdstanr"
-)
-

Then running this model with threading requires cmdstanr as backend and you can simply add threading support to an existing model with the update mechanism as:

-
fit_parallel <- update(
-  fit_serial, chains = 2, cores = 2,
-  backend = "cmdstanr", threads = threading(2)
-)
-

The example above assumes that 4 cores are available which are best used without within-chain parallelization by running 4 chains in parallel. When using within chain parallelization it is still advisable to use just as many threads in total as you have CPU cores. It’s thus sensible in this case to reduce the number of chains running in parallel to just 2, but allow each chain to use 2 threads. Obviously this will reduce the number of iterations in the posterior here as we assumed a fixed amount of 4 cores.

-
    -
  • Only apply within-chain parallelization to large problems which take more than a few minutes at least to calculate. The epilepsy example above is actually too small to gain in speed (just a few seconds per chain on this machine).
    • -
  • Within-chain parallelization is less efficient than between-chain parallelization. So only use within-chain parallelism if more CPUs can be used to run the entire analysis.
    • -
  • Due to details of the model and data-set, speedups with more cores can be very limited. Not every model amends to within-chain parallelization and an empirical evaluation is in some cases advisable.
    • -
  • Enabling threading usually slows down any model to some extent and this slowdown must be offset by sufficient cores per chain in order to really gain in execution speed.
    • -
  • Doubling the execution speed with few cores is a lot easier than obtaining larger speedups with even more cores.
    • -
  • Models with computationally expensive likelihoods are easier to parallelize than less expensive likelihoods. For example, the Poisson distribution involves expensive \(\log\Gamma\) functions whereas the normal likelihood is very cheap to calculate in comparison.
    • -
  • Models with many parameters (e.g., multilevel models) carry a large overhead when running in parallel.
    • -
  • With a larger overhead of the model, the likelihood must be sufficiently expensive such that the relative computational cost of likelihood to parallelization overhead is favorable.
    • -
  • Avoid using hyper-threading, that is, only use as many threads as you have physical cores available.
    • -
  • Ensure that the data is randomly sorted such that consecutive subsets of the data are roughly of the same computational effort.
    • -
-
-
-

Within-chain parallelization

-

The within-chain parallelization implemented in brms is based on the reduce_sum facility in Stan. The basic principle that reduce_sum uses is to split a large summation into arbitrary smaller partial sums. Due to the commutativity and associativity of the sum operation these smaller partial sums can be evaluated in any order and in parallel from one another. brms leverages reduce_sum to evaluate the log-likelihood of the model in parallel as for example

-

\[ -\begin{aligned} -l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ - &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). -\end{aligned} -\]

-

As a consequence, the within-chain parallelization requires mutually independent log-likelihood terms which restricts its applicability to some degree.

-

Furthermore, the within-chain parallelization is only applicable to the evaluation of the data likelihood while all other parts of the model, for example priors, will remain running serially. Thus, only a partial fraction of the entire Stan model will run in parallel which limits the potential speedup one may obtain. The theoretical speedup for a partially in parallel running program is described by Amdahl‘s law. For example, with 90% of the computational load running in parallel one can essentially double the execution speed with 2 cores while 8 cores may only speedup the program by at most 5x. How large the computational cost of the log-likelihood is in relation to the entire model is very dependent on the model of the user.

-

In practice, the speedups are even smaller than the theoretical speedups. This is caused by the additional overhead implied by forming multiple smaller sums than just one large one. For example, for each partial sum formed the entire parameter vector \(\theta\) has to be copied in memory for Stan to be able to calculate the gradient of the log-likelihood. Hence, with more partial sums, more copying is necessary as opposed to evaluating just one large sum. Whether the additional copying is indeed relevant depends on the computational cost of the log-likelihood of each term and the number of parameters. For a model with a computationally cheap normal log-likelihood, this effect is more important than for a model with a Poisson log-likelihood, and for multilevel models with many parameters more copying is needed than for simpler regression models. It may therefore be necessary to form sufficiently large partial sums to warrant an efficient parallel execution. The size of the partial sums is referred to as the grainsize, which is set to a reasonable default value. However, for some models this tuning parameter requires some attention from the user for optimal performance.

-

Finally, it is important to note that by default the exact size and order of the partial sums is not stable as it is adjusted to the load of the system. As a result, exact numerical reproducibility is not guaranteed by default. In order to warrant the same size and order of the partial sums, the static option must be used and set to TRUE, which uses a deterministic scheduler for the parallel work.

-
-
-

Example model

-

As a toy demonstration, we use here a multilevel Poisson model. The model is a varying intercept model with \(10^{4}\) data observation which are grouped into \(1000\) groups. Each data item has \(3\) continuous covariates. The simulation code for the fake data can be found in the appendix and it’s first \(10\) rows are:

-
kable(head(fake, 10), digits = 3)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
gx1x2x3thetaetamuy
3820.4960.6230.069-0.2620.5100.2480
578-0.748-0.300-0.768-0.903-0.032-0.9340
772-1.124-0.161-0.882-1.047-0.551-1.5981
7740.992-0.5931.0071.578-0.0451.5332
7290.641-1.563-0.491-0.291-1.460-1.7510
897-0.085-0.531-0.978-1.296-0.929-2.2260
110-0.7721.364-0.629-1.3510.124-1.2270
248-1.4410.6991.2842.072-1.0201.0531
754-1.3200.837-0.137-0.2371.4521.2153
682-1.345-2.673-1.628-1.146-0.388-1.5340
-

The brms model fitting this data is:

-
model_poisson <- brm(
-  y ~ 1 + x1 + x2 + (1 | g),
-  data = fake,
-  family = poisson(),
-  iter = 500, # short sampling to speedup example
-  chains = 2,
-  prior = prior(normal(0,1), class = b) +
-    prior(constant(1), class = sd, group = g),
-  backend = "cmdstanr",
-  threads = threading(4)
-)
-

Here we have fixed the standard deviation of the between-group variation for the intercept to the true value of \(1\) as used in the simulation. This is to avoid unfavorable geometry of the problem allowing us to concentrate on computational aspects alone.

-

The Poisson likelihood is a relatively expensive likelihood due to the use of \(\log\Gamma\) function as opposed to, for example, a normal likelihood which does is by far less expensive operations. Moreover, this example is chosen in order to demonstrate parallelization overhead implied by a large number of parameters.

-
-
-

Managing parallelization overhead

-

As discussed above, the key mechanism to run Stan programs with parallelization is to split the large sum over independent log likelihood terms into arbitrary smaller partial sums. Creating more partial sums allows to increase simultaneous parallel computations in a granular way, but at the same time additional overhead is introduced through the requirement to copy the entire parameter vector for each partial sum formed along with further overhead due to splitting up a single large task into multiple smaller ones.

-

By default, brms will choose a sensible grainsize which defines how large a given partial sum will roughly be. The actual chunk size is automatically tuned whenever the default non-static scheduler is used, which is the recommended choice to start with. As noted before, only the static scheduler is giving fully deterministic results since the chunk size and order of partial sums will be the same during sampling.

-

While we expect that the default grainsize in brms is reasonably good for many models, it can improve performance if one tunes the grainsize specifically to a given model and data-set. We suggest to increase successively the number of chunks a given data set is split into with the static scheduler and run this on a single core. This way one can control the number of partial sum accurately and monitor the execution time as it increases. These experiments are run with only a single chain and very short iteration numbers as we are not interested in the statistical results, but rather aim to be able to explore the tuning parameter space of the chunk size as quickly as possible. The number of iterations needed to get reliable runtime estimates for a given chunk size will depend on many details and the easiest way to determine this is to run this benchmark with multiple number of iterations. Whenever their results match approximately, then the iteration numbers are sufficient. In order to decrease the variation between runs, we also fix the random seed, initial value and the tuning parameters of the sampler (step size and mass matrix).

-

Below is an example R code demonstrating such a benchmark. The utility function benchmark_threading is shown and explained in the appendix.

-
chunking_bench <- transform(
-    data.frame(chunks = 4^(0:3)),
-    grainsize = ceiling(N / chunks)
-)
-
-iter_test <- c(10, 20, 40)  # very short test runs
-scaling_chunking <- benchmark_threading(
-  model_poisson,
-  cores = 1,                         
-  grainsize = chunking_bench$grainsize,  # test various grainsizes
-  iter = iter_test,  
-  static = TRUE  # with static partitioner
-)
-
-# run as reference the model *without* reduce_sum
-ref <- benchmark_reference(model_poisson, iter_test)
-
-# for additional data munging please refer to the appendix
-

Graphically summarizing the results shows that with more than 8 chunks the overhead is about 10% and increasing further with more chunks. For models without many parameters, no such overhead should be observed. Furthermore, one can see that 25 and 50 iterations give similar results implying that 25 iterations suffice for stable runtime estimates for these (and the following) benchmarks. The overhead of up to 20% in this example with 16 chunks may seem large due to the scaling of the plot. One must not forget that when we start to use more CPU cores, the overhead is easily offset, but it limits the maximal speedup we can get. For example, some 2 units of computation become 2.4 units due to the overhead such that on 2 cores we don’t quite double the execution speed, but rather get a 1.6x increase in speed instead of a 2x speedup.

-

Considering in addition the time per leapfrog step of the NUTS sampler shows on an absolute scale similar information as before. The upside of this representation is that we can visualize the slowdown in relation to the program without reduce_sum. As we can see, the additional overhead due to merely enabling reduce_sum is substantial in this example. This is attributed in the specific example to the large number of random effects.

-
ggplot(scaling_chunking) +
-    aes(chunks, slowdown, colour = iter, shape = iter) +
-    geom_line() + geom_point() +
-    scale_x_log10(breaks = scaling_chunking$chunks) +
-    scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) +
-    ggtitle("Slowdown with increasing number of chunks")
-

-
ggplot(scaling_chunking) +
-    aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) +
-    geom_line() + geom_point() +
-    scale_x_log10(breaks = scaling_chunking$chunks) +
-    scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) +
-    geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) +
-    ggtitle("Time per leapfrog step vs number of chunks",
-            "Dashed line is reference model without reduce_sum") +
-    ylab("Time per leapfrog step [ms]")
-

-
-
-

Parallelization speedup

-

In practice, we are often interested in so-called “hard-scaling” properties of the parallelization system. That is, for a fixed problem size we would like to know how much faster we can execute the Stan program with increasing number of threads. As nowadays CPUs usually run with so-called hyper-threading, it is also of interest if this technique is beneficial for Stan programs as well (spoiler alert: it’s not useful). As we have seen before, the grainsize can have an impact on the performance and is as such a tuning parameter. Below we demonstrate some exemplary R code which runs a benchmark with varying number of CPU cores and varying number of grainsizes.

-
num_cpu <- parallel::detectCores(logical = FALSE)
-num_cpu_logical <- parallel::detectCores(logical = TRUE)
-grainsize_default <- ceiling(N / (2 * num_cpu))
-cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical)
-cores <- sort(unique(cores))
-grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4)
-grainsize <- round(grainsize)
-
-iter_scaling <- 20
-scaling_cores <- benchmark_threading(
-  model_poisson,
-  cores = cores,
-  grainsize = grainsize,
-  iter = iter_scaling,
-  static = FALSE
-)
-
-single_core  <- transform(
-    subset(scaling_cores, cores == 1),
-    runtime_single = runtime,
-    num_leapfrog=NULL, runtime=NULL, cores = NULL
-)
-
-scaling_cores <- transform(
-  merge(scaling_cores, single_core),
-  speedup = runtime_single/runtime,
-  grainsize = factor(grainsize)
-)
-

It is important to consider the absolute runtime and the relative speedup vs. running on a single core. The relative speedup can be misleading if the single core runtime is very slow in which case speed gains on more CPUs may look overly good. Considering instead the absolute runtime avoids this problem. After all, we are interested in the shortest walltime we can get rather than any relative speedups.

-
ggplot(scaling_cores) +
-    aes(cores, runtime, shape = grainsize, color = grainsize) +
-    geom_vline(xintercept = num_cpu, linetype = 3) +
-    geom_line() + geom_point() + 
-    scale_x_log10(breaks = scaling_cores$cores) +
-    scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) +
-    theme(legend.position = c(0.85, 0.8)) +
-    geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) +
-    ggtitle("Runtime with varying number of cores",
-            "Dashed line is reference model without reduce_sum")
-

-
ggplot(scaling_cores) +
-  aes(cores, speedup, shape = grainsize, color = grainsize) +
-  geom_abline(slope = 1, intercept = 0, linetype = 2) +
-  geom_vline(xintercept = num_cpu, linetype = 3) +
-  geom_line() + geom_point() +
-  scale_x_log10(breaks=scaling_cores$cores) +
-  scale_y_log10(breaks=scaling_cores$cores) +
-  theme(aspect.ratio = 1) +
-  coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) +
-  ggtitle("Relative speedup vs 1 core")
-

-

The vertical dotted line marks the physical number of CPU cores on the machine this was run. The horizontal dashed line in the plot with absolute runtime marks the respective runtime of the model without reduce_sum and the dashed unity line in the plot with the relative speedup marks the theoretical maximal speedup. We can see that there is no further reduction in execution time when increasing the thread count to be greater than the number of physical CPUs. Hence, the use of hyper-threading is not helpful when aiming to maximize the speed of a Stan program. Moreover, the use of threading outperforms the single core runtime only when using more than 4 cores in this example.

-

For this example, the shown grainsizes matter on some machines but not on others, so your results may look quite different from what is shown here. The overall speedups may not seem impressive in this case, which is attributed in this case to the large number of parameters relative to the number of observations. However, we can still outperform the single core runtime when using many cores. Though the most important advantage of threading is that with an increasing data set size, the user has the option to use a brute-force approach to balance the increase in walltime needed.

-
kable(scaling_cores, digits = 2)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
grainsizeitercoresnum_leapfrogruntimeruntime_singlespeedup
12502013000.420.421.00
12502023000.300.421.43
12502043000.240.421.76
12502083000.270.421.59
3122013000.580.581.00
3122023000.330.581.79
3122043000.260.582.27
3122083000.270.582.19
6252013000.470.471.00
6252023000.300.471.59
6252043000.260.471.84
6252083000.240.471.92
-

For a given Stan model one should usually choose the number of chains and the number of threads per chain to be equal to the number of (physical) cores one wishes to use. Only if different chains of the model have relatively different execution times (which they should not have, but it occurs sometimes in practice), then one may consider the use of hyper-threading. Doing so will share the resources evenly across all chains and whenever the fastest chain finishes, the freed resources can be given to the still running chains.

-
-
-

Appendix

-
-

Fake data simulation

-
set.seed(54647)
-# number of observations
-N <- 1E4
-# number of group levels
-G <- round(N / 10)
-# number of predictors
-P <- 3
-# regression coefficients
-beta <- rnorm(P)
-
-# sampled covariates, group means and fake data
-fake <- matrix(rnorm(N * P), ncol = P)
-dimnames(fake) <- list(NULL, paste0("x", 1:P))
-
-# fixed effect part and sampled group membership
-fake <- transform(
-  as.data.frame(fake),
-  theta = fake %*% beta,
-  g = sample.int(G, N, replace=TRUE)
-)
-
-# add random intercept by group
-fake  <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g")
-
-# linear predictor
-fake  <- transform(fake, mu = theta + eta)
-
-# sample Poisson data
-fake  <- transform(fake, y = rpois(N, exp(mu)))
-
-# shuffle order of data rows to ensure even distribution of computational effort
-fake <- fake[sample.int(N, N),]
-
-# drop not needed row names
-rownames(fake) <- NULL
-
-
-

Poisson example model

-
model_poisson <- brm(
-  y ~ 1 + x1 + x2 + (1 | g),
-  data = fake,
-  family = poisson(),
-  iter = 500, # short sampling to speedup example
-  chains = 2,
-  prior = prior(normal(0,1), class = b) +
-    prior(constant(1), class = sd, group = g),
-  backend = "cmdstanr",
-  threads = threading(4)
-)
-
-
-

Threading benchmark function

-
# Benchmarks given model with cross-product of tuning parameters CPU
-# cores, grainsize and iterations. Models are run with either static
-# or non-static scheduler and inits is set by default to 0 on the
-# unconstrained scale. Function returns a data-frame with the
-# cross-product of the tuning parameters and as result column the
-# respective runtime.
-benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, 
-                                static = FALSE) {
-
-    winfo <- extract_warmup_info(model)
-    sims  <- rstan::extract(model$fit)
-    init <- list(extract_draw(sims, 1))
-
-    scaling_model <- update(
-        model, refresh = 0, 
-        threads = threading(1, grainsize = grainsize[1], static = static), 
-        chains = 1, iter = 2, backend = "cmdstanr"
-    )
-
-    run_benchmark <- function(cores, size, iter) {
-        bench_fit <- update(
-            scaling_model, warmup=0, iter = iter,
-            chains = 1, seed = 1234, inits = init, refresh = 0, save_warmup=TRUE,
-            threads = threading(cores, grainsize = size, static = static),
-            inv_metric=winfo$inv_metric[[1]],
-            step_size=winfo$step_size[[1]],
-            adapt_engaged=FALSE
-        )
-        lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value)
-        elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit)))
-
-        c(num_leapfrog=lf, runtime=elapsed)
-    }
-
-    cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter)
-    res <- with(cases, mapply(run_benchmark, cores, grainsize, iter))
-    cbind(cases, as.data.frame(t(res)))
-}
-
-benchmark_reference <- function(model, iter=100, inits=0) {
-    winfo <- extract_warmup_info(model)
-    sims  <- rstan::extract(model$fit)
-    init <- list(extract_draw(sims, 1))
-
-    ref_model <- update(
-        model, refresh = 0, 
-        threads = NULL,
-        chains = 1, iter = 2, backend = "cmdstanr"
-    )
-
-    run_benchmark_ref <- function(iter_bench) {
-        bench_fit <- update(
-            ref_model, warmup=0, iter = iter_bench,
-            chains = 1, seed = 1234, inits = init, refresh = 0,
-            inv_metric=winfo$inv_metric[[1]],
-            step_size=winfo$step_size[[1]],
-            adapt_engaged=FALSE
-        )
-
-        lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value)
-        elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit)))
-
-        c(num_leapfrog=lf, runtime=elapsed)
-    }
-    
-    ref <- sapply(iter, run_benchmark_ref)
-    ref <- cbind(as.data.frame(t(ref)), iter=iter)
-    ref
-}
-
-extract_warmup_info <- function(bfit) {
-    adapt  <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n")
-    step_size  <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2]))
-    inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]]))
-    list(step_size=step_size, inv_metric=inv_metric)
-}
-
-extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE)
-
-
-

Munging of slowdown with chunking data

-
scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize")
-
-single_chunk  <- transform(
-    subset(scaling_chunking, chunks == 1),
-    num_leapfrog_single = num_leapfrog, num_leapfrog = NULL,
-    runtime_single = runtime, runtime = NULL, 
-    grainsize = NULL, chunks=NULL
-)
-
-scaling_chunking <- transform(
-    merge(scaling_chunking, single_chunk),
-    slowdown = runtime/runtime_single,
-    iter = factor(iter),
-    runtime_single = NULL
-)
-
-ref <- transform(ref, iter=factor(iter))
-
-
- - - - - - - - - - - + + + + + + + + + + + + + + + + +Running brms models with within-chain parallelization + + + + + + + + + + + + + + + + + + + + + + + + + +

Running brms models with within-chain parallelization

+

Sebastian Weber & Paul Bürkner

+

2022-04-11

+ + + + +
+

Introduction

+

Full Bayesian inference is a computationally very demanding task and often we wish to run our models faster in shorter walltime. With modern computers we nowadays have multiple processors available on a given machine such that the use of running the inference in parallel will shorten the overall walltime. While between-chain parallelization is straightforward by merely launching multiple chains at the same time, the use of within-chain parallelization is more complicated in various ways. This vignette aims to introduce the user to within-chain parallelization with brms, since its efficient use depends on various aspects specific to the users model.

+
+
+

Quick summary

+

Assuming you have a brms model which you wish to evaluate faster by using more cores per chain, for example:

+
fit_serial <- brm(
+  count ~ zAge + zBase * Trt + (1|patient),
+  data = epilepsy, family = poisson(),
+  chains = 4, cores = 4, backend = "cmdstanr"
+)
+

Then running this model with threading requires cmdstanr as backend and you can simply add threading support to an existing model with the update mechanism as:

+
fit_parallel <- update(
+  fit_serial, chains = 2, cores = 2,
+  backend = "cmdstanr", threads = threading(2)
+)
+

The example above assumes that 4 cores are available which are best used without within-chain parallelization by running 4 chains in parallel. When using within chain parallelization it is still advisable to use just as many threads in total as you have CPU cores. It’s thus sensible in this case to reduce the number of chains running in parallel to just 2, but allow each chain to use 2 threads. Obviously this will reduce the number of iterations in the posterior here as we assumed a fixed amount of 4 cores.

+
    +
  • Only apply within-chain parallelization to large problems which take more than a few minutes at least to calculate. The epilepsy example above is actually too small to gain in speed (just a few seconds per chain on this machine).
    • +
  • Within-chain parallelization is less efficient than between-chain parallelization. So only use within-chain parallelism if more CPUs can be used to run the entire analysis.
    • +
  • Due to details of the model and data-set, speedups with more cores can be very limited. Not every model amends to within-chain parallelization and an empirical evaluation is in some cases advisable.
    • +
  • Enabling threading usually slows down any model to some extent and this slowdown must be offset by sufficient cores per chain in order to really gain in execution speed.
    • +
  • Doubling the execution speed with few cores is a lot easier than obtaining larger speedups with even more cores.
    • +
  • Models with computationally expensive likelihoods are easier to parallelize than less expensive likelihoods. For example, the Poisson distribution involves expensive \(\log\Gamma\) functions whereas the normal likelihood is very cheap to calculate in comparison.
    • +
  • Models with many parameters (e.g., multilevel models) carry a large overhead when running in parallel.
    • +
  • With a larger overhead of the model, the likelihood must be sufficiently expensive such that the relative computational cost of likelihood to parallelization overhead is favorable.
    • +
  • Avoid using hyper-threading, that is, only use as many threads as you have physical cores available.
    • +
  • Ensure that the data is randomly sorted such that consecutive subsets of the data are roughly of the same computational effort.
    • +
+
+
+

Within-chain parallelization

+

The within-chain parallelization implemented in brms is based on the reduce_sum facility in Stan. The basic principle that reduce_sum uses is to split a large summation into arbitrary smaller partial sums. Due to the commutativity and associativity of the sum operation these smaller partial sums can be evaluated in any order and in parallel from one another. brms leverages reduce_sum to evaluate the log-likelihood of the model in parallel as for example

+

\[ +\begin{aligned} +l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ + &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). +\end{aligned} +\]

+

As a consequence, the within-chain parallelization requires mutually independent log-likelihood terms which restricts its applicability to some degree.

+

Furthermore, the within-chain parallelization is only applicable to the evaluation of the data likelihood while all other parts of the model, for example priors, will remain running serially. Thus, only a partial fraction of the entire Stan model will run in parallel which limits the potential speedup one may obtain. The theoretical speedup for a partially in parallel running program is described by Amdahl‘s law. For example, with 90% of the computational load running in parallel one can essentially double the execution speed with 2 cores while 8 cores may only speedup the program by at most 5x. How large the computational cost of the log-likelihood is in relation to the entire model is very dependent on the model of the user.

+

In practice, the speedups are even smaller than the theoretical speedups. This is caused by the additional overhead implied by forming multiple smaller sums than just one large one. For example, for each partial sum formed the entire parameter vector \(\theta\) has to be copied in memory for Stan to be able to calculate the gradient of the log-likelihood. Hence, with more partial sums, more copying is necessary as opposed to evaluating just one large sum. Whether the additional copying is indeed relevant depends on the computational cost of the log-likelihood of each term and the number of parameters. For a model with a computationally cheap normal log-likelihood, this effect is more important than for a model with a Poisson log-likelihood, and for multilevel models with many parameters more copying is needed than for simpler regression models. It may therefore be necessary to form sufficiently large partial sums to warrant an efficient parallel execution. The size of the partial sums is referred to as the grainsize, which is set to a reasonable default value. However, for some models this tuning parameter requires some attention from the user for optimal performance.

+

Finally, it is important to note that by default the exact size and order of the partial sums is not stable as it is adjusted to the load of the system. As a result, exact numerical reproducibility is not guaranteed by default. In order to warrant the same size and order of the partial sums, the static option must be used and set to TRUE, which uses a deterministic scheduler for the parallel work.

+
+
+

Example model

+

As a toy demonstration, we use here a multilevel Poisson model. The model is a varying intercept model with \(10^{4}\) data observation which are grouped into \(1000\) groups. Each data item has \(3\) continuous covariates. The simulation code for the fake data can be found in the appendix and it’s first \(10\) rows are:

+
kable(head(fake, 10), digits = 3)
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
gx1x2x3thetaetamuy
3820.4960.6230.069-0.2620.5100.2480
578-0.748-0.300-0.768-0.903-0.032-0.9340
772-1.124-0.161-0.882-1.047-0.551-1.5981
7740.992-0.5931.0071.578-0.0451.5332
7290.641-1.563-0.491-0.291-1.460-1.7510
897-0.085-0.531-0.978-1.296-0.929-2.2260
110-0.7721.364-0.629-1.3510.124-1.2270
248-1.4410.6991.2842.072-1.0201.0531
754-1.3200.837-0.137-0.2371.4521.2153
682-1.345-2.673-1.628-1.146-0.388-1.5340
+

The brms model fitting this data is:

+
model_poisson <- brm(
+  y ~ 1 + x1 + x2 + (1 | g),
+  data = fake,
+  family = poisson(),
+  iter = 500, # short sampling to speedup example
+  chains = 2,
+  prior = prior(normal(0,1), class = b) +
+    prior(constant(1), class = sd, group = g),
+  backend = "cmdstanr",
+  threads = threading(4)
+)
+

Here we have fixed the standard deviation of the between-group variation for the intercept to the true value of \(1\) as used in the simulation. This is to avoid unfavorable geometry of the problem allowing us to concentrate on computational aspects alone.

+

The Poisson likelihood is a relatively expensive likelihood due to the use of \(\log\Gamma\) function as opposed to, for example, a normal likelihood which does is by far less expensive operations. Moreover, this example is chosen in order to demonstrate parallelization overhead implied by a large number of parameters.

+
+
+

Managing parallelization overhead

+

As discussed above, the key mechanism to run Stan programs with parallelization is to split the large sum over independent log likelihood terms into arbitrary smaller partial sums. Creating more partial sums allows to increase simultaneous parallel computations in a granular way, but at the same time additional overhead is introduced through the requirement to copy the entire parameter vector for each partial sum formed along with further overhead due to splitting up a single large task into multiple smaller ones.

+

By default, brms will choose a sensible grainsize which defines how large a given partial sum will roughly be. The actual chunk size is automatically tuned whenever the default non-static scheduler is used, which is the recommended choice to start with. As noted before, only the static scheduler is giving fully deterministic results since the chunk size and order of partial sums will be the same during sampling.

+

While we expect that the default grainsize in brms is reasonably good for many models, it can improve performance if one tunes the grainsize specifically to a given model and data-set. We suggest to increase successively the number of chunks a given data set is split into with the static scheduler and run this on a single core. This way one can control the number of partial sum accurately and monitor the execution time as it increases. These experiments are run with only a single chain and very short iteration numbers as we are not interested in the statistical results, but rather aim to be able to explore the tuning parameter space of the chunk size as quickly as possible. The number of iterations needed to get reliable runtime estimates for a given chunk size will depend on many details and the easiest way to determine this is to run this benchmark with multiple number of iterations. Whenever their results match approximately, then the iteration numbers are sufficient. In order to decrease the variation between runs, we also fix the random seed, initial value and the tuning parameters of the sampler (step size and mass matrix).

+

Below is an example R code demonstrating such a benchmark. The utility function benchmark_threading is shown and explained in the appendix.

+
chunking_bench <- transform(
+    data.frame(chunks = 4^(0:3)),
+    grainsize = ceiling(N / chunks)
+)
+
+iter_test <- c(10, 20, 40)  # very short test runs
+scaling_chunking <- benchmark_threading(
+  model_poisson,
+  cores = 1,
+  grainsize = chunking_bench$grainsize,  # test various grainsizes
+  iter = iter_test,
+  static = TRUE  # with static partitioner
+)
+
+# run as reference the model *without* reduce_sum
+ref <- benchmark_reference(model_poisson, iter_test)
+
+# for additional data munging please refer to the appendix
+

Graphically summarizing the results shows that with more than 8 chunks the overhead is about 10% and increasing further with more chunks. For models without many parameters, no such overhead should be observed. Furthermore, one can see that 25 and 50 iterations give similar results implying that 25 iterations suffice for stable runtime estimates for these (and the following) benchmarks. The overhead of up to 20% in this example with 16 chunks may seem large due to the scaling of the plot. One must not forget that when we start to use more CPU cores, the overhead is easily offset, but it limits the maximal speedup we can get. For example, some 2 units of computation become 2.4 units due to the overhead such that on 2 cores we don’t quite double the execution speed, but rather get a 1.6x increase in speed instead of a 2x speedup.

+

Considering in addition the time per leapfrog step of the NUTS sampler shows on an absolute scale similar information as before. The upside of this representation is that we can visualize the slowdown in relation to the program without reduce_sum. As we can see, the additional overhead due to merely enabling reduce_sum is substantial in this example. This is attributed in the specific example to the large number of random effects.

+
ggplot(scaling_chunking) +
+    aes(chunks, slowdown, colour = iter, shape = iter) +
+    geom_line() + geom_point() +
+    scale_x_log10(breaks = scaling_chunking$chunks) +
+    scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) +
+    ggtitle("Slowdown with increasing number of chunks")
+

+
ggplot(scaling_chunking) +
+    aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) +
+    geom_line() + geom_point() +
+    scale_x_log10(breaks = scaling_chunking$chunks) +
+    scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) +
+    geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) +
+    ggtitle("Time per leapfrog step vs number of chunks",
+            "Dashed line is reference model without reduce_sum") +
+    ylab("Time per leapfrog step [ms]")
+

+
+
+

Parallelization speedup

+

In practice, we are often interested in so-called “hard-scaling” properties of the parallelization system. That is, for a fixed problem size we would like to know how much faster we can execute the Stan program with increasing number of threads. As nowadays CPUs usually run with so-called hyper-threading, it is also of interest if this technique is beneficial for Stan programs as well (spoiler alert: it’s not useful). As we have seen before, the grainsize can have an impact on the performance and is as such a tuning parameter. Below we demonstrate some exemplary R code which runs a benchmark with varying number of CPU cores and varying number of grainsizes.

+
num_cpu <- parallel::detectCores(logical = FALSE)
+num_cpu_logical <- parallel::detectCores(logical = TRUE)
+grainsize_default <- ceiling(N / (2 * num_cpu))
+cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical)
+cores <- sort(unique(cores))
+grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4)
+grainsize <- round(grainsize)
+
+iter_scaling <- 20
+scaling_cores <- benchmark_threading(
+  model_poisson,
+  cores = cores,
+  grainsize = grainsize,
+  iter = iter_scaling,
+  static = FALSE
+)
+
+single_core  <- transform(
+    subset(scaling_cores, cores == 1),
+    runtime_single = runtime,
+    num_leapfrog=NULL, runtime=NULL, cores = NULL
+)
+
+scaling_cores <- transform(
+  merge(scaling_cores, single_core),
+  speedup = runtime_single/runtime,
+  grainsize = factor(grainsize)
+)
+

It is important to consider the absolute runtime and the relative speedup vs. running on a single core. The relative speedup can be misleading if the single core runtime is very slow in which case speed gains on more CPUs may look overly good. Considering instead the absolute runtime avoids this problem. After all, we are interested in the shortest walltime we can get rather than any relative speedups.

+
ggplot(scaling_cores) +
+    aes(cores, runtime, shape = grainsize, color = grainsize) +
+    geom_vline(xintercept = num_cpu, linetype = 3) +
+    geom_line() + geom_point() +
+    scale_x_log10(breaks = scaling_cores$cores) +
+    scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) +
+    theme(legend.position = c(0.85, 0.8)) +
+    geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) +
+    ggtitle("Runtime with varying number of cores",
+            "Dashed line is reference model without reduce_sum")
+

+
ggplot(scaling_cores) +
+  aes(cores, speedup, shape = grainsize, color = grainsize) +
+  geom_abline(slope = 1, intercept = 0, linetype = 2) +
+  geom_vline(xintercept = num_cpu, linetype = 3) +
+  geom_line() + geom_point() +
+  scale_x_log10(breaks=scaling_cores$cores) +
+  scale_y_log10(breaks=scaling_cores$cores) +
+  theme(aspect.ratio = 1) +
+  coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) +
+  ggtitle("Relative speedup vs 1 core")
+

+

The vertical dotted line marks the physical number of CPU cores on the machine this was run. The horizontal dashed line in the plot with absolute runtime marks the respective runtime of the model without reduce_sum and the dashed unity line in the plot with the relative speedup marks the theoretical maximal speedup. We can see that there is no further reduction in execution time when increasing the thread count to be greater than the number of physical CPUs. Hence, the use of hyper-threading is not helpful when aiming to maximize the speed of a Stan program. Moreover, the use of threading outperforms the single core runtime only when using more than 4 cores in this example.

+

For this example, the shown grainsizes matter on some machines but not on others, so your results may look quite different from what is shown here. The overall speedups may not seem impressive in this case, which is attributed in this case to the large number of parameters relative to the number of observations. However, we can still outperform the single core runtime when using many cores. Though the most important advantage of threading is that with an increasing data set size, the user has the option to use a brute-force approach to balance the increase in walltime needed.

+
kable(scaling_cores, digits = 2)
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
grainsizeitercoresnum_leapfrogruntimeruntime_singlespeedup
1252016200.490.491.00
1252026200.320.491.51
1252046200.220.492.19
1252086200.210.492.37
12520106200.210.492.38
2502016200.420.421.00
2502026200.250.421.64
2502046200.190.422.15
2502086200.190.422.17
25020106200.180.422.27
5002016200.400.401.00
5002026200.230.401.72
5002046200.180.402.14
5002086200.180.402.19
50020106200.180.402.24
+

For a given Stan model one should usually choose the number of chains and the number of threads per chain to be equal to the number of (physical) cores one wishes to use. Only if different chains of the model have relatively different execution times (which they should not have, but it occurs sometimes in practice), then one may consider the use of hyper-threading. Doing so will share the resources evenly across all chains and whenever the fastest chain finishes, the freed resources can be given to the still running chains.

+
+
+

Appendix

+
+

Fake data simulation

+
set.seed(54647)
+# number of observations
+N <- 1E4
+# number of group levels
+G <- round(N / 10)
+# number of predictors
+P <- 3
+# regression coefficients
+beta <- rnorm(P)
+
+# sampled covariates, group means and fake data
+fake <- matrix(rnorm(N * P), ncol = P)
+dimnames(fake) <- list(NULL, paste0("x", 1:P))
+
+# fixed effect part and sampled group membership
+fake <- transform(
+  as.data.frame(fake),
+  theta = fake %*% beta,
+  g = sample.int(G, N, replace=TRUE)
+)
+
+# add random intercept by group
+fake  <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g")
+
+# linear predictor
+fake  <- transform(fake, mu = theta + eta)
+
+# sample Poisson data
+fake  <- transform(fake, y = rpois(N, exp(mu)))
+
+# shuffle order of data rows to ensure even distribution of computational effort
+fake <- fake[sample.int(N, N),]
+
+# drop not needed row names
+rownames(fake) <- NULL
+
+
+

Poisson example model

+
model_poisson <- brm(
+  y ~ 1 + x1 + x2 + (1 | g),
+  data = fake,
+  family = poisson(),
+  iter = 500, # short sampling to speedup example
+  chains = 2,
+  prior = prior(normal(0,1), class = b) +
+    prior(constant(1), class = sd, group = g),
+  backend = "cmdstanr",
+  threads = threading(4)
+)
+
+
+

Threading benchmark function

+
# Benchmarks given model with cross-product of tuning parameters CPU
+# cores, grainsize and iterations. Models are run with either static
+# or non-static scheduler and initial values are set by default to 0 on the
+# unconstrained scale. Function returns a data-frame with the
+# cross-product of the tuning parameters and as result column the
+# respective runtime.
+benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100,
+                                static = FALSE) {
+
+    winfo <- extract_warmup_info(model)
+    sims  <- rstan::extract(model$fit)
+    init <- list(extract_draw(sims, 1))
+
+    scaling_model <- update(
+        model, refresh = 0,
+        threads = threading(1, grainsize = grainsize[1], static = static),
+        chains = 1, iter = 2, backend = "cmdstanr"
+    )
+
+    run_benchmark <- function(cores, size, iter) {
+        bench_fit <- update(
+            scaling_model, warmup=0, iter = iter,
+            chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE,
+            threads = threading(cores, grainsize = size, static = static),
+            inv_metric=winfo$inv_metric[[1]],
+            step_size=winfo$step_size[[1]],
+            adapt_engaged=FALSE
+        )
+        lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value)
+        elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit)))
+
+        c(num_leapfrog=lf, runtime=elapsed)
+    }
+
+    cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter)
+    res <- with(cases, mapply(run_benchmark, cores, grainsize, iter))
+    cbind(cases, as.data.frame(t(res)))
+}
+
+benchmark_reference <- function(model, iter=100, init=0) {
+    winfo <- extract_warmup_info(model)
+    sims  <- rstan::extract(model$fit)
+    init <- list(extract_draw(sims, 1))
+
+    ref_model <- update(
+        model, refresh = 0,
+        threads = NULL,
+        chains = 1, iter = 2, backend = "cmdstanr"
+    )
+
+    run_benchmark_ref <- function(iter_bench) {
+        bench_fit <- update(
+            ref_model, warmup=0, iter = iter_bench,
+            chains = 1, seed = 1234, init = init, refresh = 0,
+            inv_metric=winfo$inv_metric[[1]],
+            step_size=winfo$step_size[[1]],
+            adapt_engaged=FALSE
+        )
+
+        lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value)
+        elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit)))
+
+        c(num_leapfrog=lf, runtime=elapsed)
+    }
+
+    ref <- sapply(iter, run_benchmark_ref)
+    ref <- cbind(as.data.frame(t(ref)), iter=iter)
+    ref
+}
+
+extract_warmup_info <- function(bfit) {
+    adapt  <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n")
+    step_size  <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2]))
+    inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]]))
+    list(step_size=step_size, inv_metric=inv_metric)
+}
+
+extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE)
+
+
+

Munging of slowdown with chunking data

+
scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize")
+
+single_chunk  <- transform(
+    subset(scaling_chunking, chunks == 1),
+    num_leapfrog_single = num_leapfrog, num_leapfrog = NULL,
+    runtime_single = runtime, runtime = NULL,
+    grainsize = NULL, chunks=NULL
+)
+
+scaling_chunking <- transform(
+    merge(scaling_chunking, single_chunk),
+    slowdown = runtime/runtime_single,
+    iter = factor(iter),
+    runtime_single = NULL
+)
+
+ref <- transform(ref, iter=factor(iter))
+
+
+ + + + + + + + + + + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_threading.R r-cran-brms-2.17.0/inst/doc/brms_threading.R --- r-cran-brms-2.16.3/inst/doc/brms_threading.R 2021-11-22 17:06:11.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_threading.R 2022-04-11 08:20:27.000000000 +0000 @@ -1,447 +1,447 @@ -params <- -list(EVAL = TRUE) - -## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(ggplot2) -library(brms) -theme_set(theme_default()) - -## ---- fake-data-sim, include=FALSE, eval=TRUE------------------------------------------- -set.seed(54647) -# number of observations -N <- 1E4 -# number of group levels -G <- round(N / 10) -# number of predictors -P <- 3 -# regression coefficients -beta <- rnorm(P) - -# sampled covariates, group means and fake data -fake <- matrix(rnorm(N * P), ncol = P) -dimnames(fake) <- list(NULL, paste0("x", 1:P)) - -# fixed effect part and sampled group membership -fake <- transform( - as.data.frame(fake), - theta = fake %*% beta, - g = sample.int(G, N, replace=TRUE) -) - -# add random intercept by group -fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") - -# linear predictor -fake <- transform(fake, mu = theta + eta) - -# sample Poisson data -fake <- transform(fake, y = rpois(N, exp(mu))) - -# shuffle order of data rows to ensure even distribution of computational effort -fake <- fake[sample.int(N, N),] - -# drop not needed row names -rownames(fake) <- NULL - -## ---- model-poisson, include=FALSE------------------------------------------------------ -model_poisson <- brm( - y ~ 1 + x1 + x2 + (1 | g), - data = fake, - family = poisson(), - iter = 500, # short sampling to speedup example - chains = 2, - prior = prior(normal(0,1), class = b) + - prior(constant(1), class = sd, group = g), - backend = "cmdstanr", - threads = threading(4) -) - -## ---- benchmark, include=FALSE---------------------------------------------------------- -# Benchmarks given model with cross-product of tuning parameters CPU -# cores, grainsize and iterations. Models are run with either static -# or non-static scheduler and inits is set by default to 0 on the -# unconstrained scale. Function returns a data-frame with the -# cross-product of the tuning parameters and as result column the -# respective runtime. -benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, - static = FALSE) { - - winfo <- extract_warmup_info(model) - sims <- rstan::extract(model$fit) - init <- list(extract_draw(sims, 1)) - - scaling_model <- update( - model, refresh = 0, - threads = threading(1, grainsize = grainsize[1], static = static), - chains = 1, iter = 2, backend = "cmdstanr" - ) - - run_benchmark <- function(cores, size, iter) { - bench_fit <- update( - scaling_model, warmup=0, iter = iter, - chains = 1, seed = 1234, inits = init, refresh = 0, save_warmup=TRUE, - threads = threading(cores, grainsize = size, static = static), - inv_metric=winfo$inv_metric[[1]], - step_size=winfo$step_size[[1]], - adapt_engaged=FALSE - ) - lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) - elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) - - c(num_leapfrog=lf, runtime=elapsed) - } - - cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) - res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) - cbind(cases, as.data.frame(t(res))) -} - -benchmark_reference <- function(model, iter=100, inits=0) { - winfo <- extract_warmup_info(model) - sims <- rstan::extract(model$fit) - init <- list(extract_draw(sims, 1)) - - ref_model <- update( - model, refresh = 0, - threads = NULL, - chains = 1, iter = 2, backend = "cmdstanr" - ) - - run_benchmark_ref <- function(iter_bench) { - bench_fit <- update( - ref_model, warmup=0, iter = iter_bench, - chains = 1, seed = 1234, inits = init, refresh = 0, - inv_metric=winfo$inv_metric[[1]], - step_size=winfo$step_size[[1]], - adapt_engaged=FALSE - ) - - lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) - elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) - - c(num_leapfrog=lf, runtime=elapsed) - } - - ref <- sapply(iter, run_benchmark_ref) - ref <- cbind(as.data.frame(t(ref)), iter=iter) - ref -} - -extract_warmup_info <- function(bfit) { - adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") - step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) - inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) - list(step_size=step_size, inv_metric=inv_metric) -} - -extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE) - - -## ---- eval=FALSE------------------------------------------------------------------------ -# fit_serial <- brm( -# count ~ zAge + zBase * Trt + (1|patient), -# data = epilepsy, family = poisson(), -# chains = 4, cores = 4, backend = "cmdstanr" -# ) - -## ---- eval=FALSE------------------------------------------------------------------------ -# fit_parallel <- update( -# fit_serial, chains = 2, cores = 2, -# backend = "cmdstanr", threads = threading(2) -# ) - -## --------------------------------------------------------------------------------------- -kable(head(fake, 10), digits = 3) - -## ---- eval=FALSE------------------------------------------------------------------------ -# model_poisson <- brm( -# y ~ 1 + x1 + x2 + (1 | g), -# data = fake, -# family = poisson(), -# iter = 500, # short sampling to speedup example -# chains = 2, -# prior = prior(normal(0,1), class = b) + -# prior(constant(1), class = sd, group = g), -# backend = "cmdstanr", -# threads = threading(4) -# ) - -## ---- chunking-scale, message=FALSE, warning=FALSE, results='hide'---------------------- -chunking_bench <- transform( - data.frame(chunks = 4^(0:3)), - grainsize = ceiling(N / chunks) -) - -iter_test <- c(10, 20, 40) # very short test runs -scaling_chunking <- benchmark_threading( - model_poisson, - cores = 1, - grainsize = chunking_bench$grainsize, # test various grainsizes - iter = iter_test, - static = TRUE # with static partitioner -) - -# run as reference the model *without* reduce_sum -ref <- benchmark_reference(model_poisson, iter_test) - -# for additional data munging please refer to the appendix - -## ---- munge-chunking-scaling, include=FALSE--------------------------------------------- -scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") - -single_chunk <- transform( - subset(scaling_chunking, chunks == 1), - num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, - runtime_single = runtime, runtime = NULL, - grainsize = NULL, chunks=NULL -) - -scaling_chunking <- transform( - merge(scaling_chunking, single_chunk), - slowdown = runtime/runtime_single, - iter = factor(iter), - runtime_single = NULL -) - -ref <- transform(ref, iter=factor(iter)) - -## --------------------------------------------------------------------------------------- -ggplot(scaling_chunking) + - aes(chunks, slowdown, colour = iter, shape = iter) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_chunking$chunks) + - scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + - ggtitle("Slowdown with increasing number of chunks") - -ggplot(scaling_chunking) + - aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_chunking$chunks) + - scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + - geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + - ggtitle("Time per leapfrog step vs number of chunks", - "Dashed line is reference model without reduce_sum") + - ylab("Time per leapfrog step [ms]") - - - -## ---- speedup-scale, message=FALSE, warning=FALSE, results='hide'----------------------- -num_cpu <- parallel::detectCores(logical = FALSE) -num_cpu_logical <- parallel::detectCores(logical = TRUE) -grainsize_default <- ceiling(N / (2 * num_cpu)) -cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) -cores <- sort(unique(cores)) -grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) -grainsize <- round(grainsize) - -iter_scaling <- 20 -scaling_cores <- benchmark_threading( - model_poisson, - cores = cores, - grainsize = grainsize, - iter = iter_scaling, - static = FALSE -) - -single_core <- transform( - subset(scaling_cores, cores == 1), - runtime_single = runtime, - num_leapfrog=NULL, runtime=NULL, cores = NULL -) - -scaling_cores <- transform( - merge(scaling_cores, single_core), - speedup = runtime_single/runtime, - grainsize = factor(grainsize) -) - -## --------------------------------------------------------------------------------------- -ggplot(scaling_cores) + - aes(cores, runtime, shape = grainsize, color = grainsize) + - geom_vline(xintercept = num_cpu, linetype = 3) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_cores$cores) + - scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + - theme(legend.position = c(0.85, 0.8)) + - geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + - ggtitle("Runtime with varying number of cores", - "Dashed line is reference model without reduce_sum") - -ggplot(scaling_cores) + - aes(cores, speedup, shape = grainsize, color = grainsize) + - geom_abline(slope = 1, intercept = 0, linetype = 2) + - geom_vline(xintercept = num_cpu, linetype = 3) + - geom_line() + geom_point() + - scale_x_log10(breaks=scaling_cores$cores) + - scale_y_log10(breaks=scaling_cores$cores) + - theme(aspect.ratio = 1) + - coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + - ggtitle("Relative speedup vs 1 core") - -## --------------------------------------------------------------------------------------- -kable(scaling_cores, digits = 2) - -## ---- eval=FALSE------------------------------------------------------------------------ -# set.seed(54647) -# # number of observations -# N <- 1E4 -# # number of group levels -# G <- round(N / 10) -# # number of predictors -# P <- 3 -# # regression coefficients -# beta <- rnorm(P) -# -# # sampled covariates, group means and fake data -# fake <- matrix(rnorm(N * P), ncol = P) -# dimnames(fake) <- list(NULL, paste0("x", 1:P)) -# -# # fixed effect part and sampled group membership -# fake <- transform( -# as.data.frame(fake), -# theta = fake %*% beta, -# g = sample.int(G, N, replace=TRUE) -# ) -# -# # add random intercept by group -# fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") -# -# # linear predictor -# fake <- transform(fake, mu = theta + eta) -# -# # sample Poisson data -# fake <- transform(fake, y = rpois(N, exp(mu))) -# -# # shuffle order of data rows to ensure even distribution of computational effort -# fake <- fake[sample.int(N, N),] -# -# # drop not needed row names -# rownames(fake) <- NULL - -## ---- eval=FALSE------------------------------------------------------------------------ -# model_poisson <- brm( -# y ~ 1 + x1 + x2 + (1 | g), -# data = fake, -# family = poisson(), -# iter = 500, # short sampling to speedup example -# chains = 2, -# prior = prior(normal(0,1), class = b) + -# prior(constant(1), class = sd, group = g), -# backend = "cmdstanr", -# threads = threading(4) -# ) - -## ---- eval=FALSE------------------------------------------------------------------------ -# # Benchmarks given model with cross-product of tuning parameters CPU -# # cores, grainsize and iterations. Models are run with either static -# # or non-static scheduler and inits is set by default to 0 on the -# # unconstrained scale. Function returns a data-frame with the -# # cross-product of the tuning parameters and as result column the -# # respective runtime. -# benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, -# static = FALSE) { -# -# winfo <- extract_warmup_info(model) -# sims <- rstan::extract(model$fit) -# init <- list(extract_draw(sims, 1)) -# -# scaling_model <- update( -# model, refresh = 0, -# threads = threading(1, grainsize = grainsize[1], static = static), -# chains = 1, iter = 2, backend = "cmdstanr" -# ) -# -# run_benchmark <- function(cores, size, iter) { -# bench_fit <- update( -# scaling_model, warmup=0, iter = iter, -# chains = 1, seed = 1234, inits = init, refresh = 0, save_warmup=TRUE, -# threads = threading(cores, grainsize = size, static = static), -# inv_metric=winfo$inv_metric[[1]], -# step_size=winfo$step_size[[1]], -# adapt_engaged=FALSE -# ) -# lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) -# elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) -# -# c(num_leapfrog=lf, runtime=elapsed) -# } -# -# cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) -# res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) -# cbind(cases, as.data.frame(t(res))) -# } -# -# benchmark_reference <- function(model, iter=100, inits=0) { -# winfo <- extract_warmup_info(model) -# sims <- rstan::extract(model$fit) -# init <- list(extract_draw(sims, 1)) -# -# ref_model <- update( -# model, refresh = 0, -# threads = NULL, -# chains = 1, iter = 2, backend = "cmdstanr" -# ) -# -# run_benchmark_ref <- function(iter_bench) { -# bench_fit <- update( -# ref_model, warmup=0, iter = iter_bench, -# chains = 1, seed = 1234, inits = init, refresh = 0, -# inv_metric=winfo$inv_metric[[1]], -# step_size=winfo$step_size[[1]], -# adapt_engaged=FALSE -# ) -# -# lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) -# elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) -# -# c(num_leapfrog=lf, runtime=elapsed) -# } -# -# ref <- sapply(iter, run_benchmark_ref) -# ref <- cbind(as.data.frame(t(ref)), iter=iter) -# ref -# } -# -# extract_warmup_info <- function(bfit) { -# adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") -# step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) -# inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) -# list(step_size=step_size, inv_metric=inv_metric) -# } -# -# extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE) -# - -## ---- eval=FALSE------------------------------------------------------------------------ -# scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") -# -# single_chunk <- transform( -# subset(scaling_chunking, chunks == 1), -# num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, -# runtime_single = runtime, runtime = NULL, -# grainsize = NULL, chunks=NULL -# ) -# -# scaling_chunking <- transform( -# merge(scaling_chunking, single_chunk), -# slowdown = runtime/runtime_single, -# iter = factor(iter), -# runtime_single = NULL -# ) -# -# ref <- transform(ref, iter=factor(iter)) - +params <- +list(EVAL = TRUE) + +## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(ggplot2) +library(brms) +theme_set(theme_default()) + +## ---- fake-data-sim, include=FALSE, eval=TRUE------------------------------------------- +set.seed(54647) +# number of observations +N <- 1E4 +# number of group levels +G <- round(N / 10) +# number of predictors +P <- 3 +# regression coefficients +beta <- rnorm(P) + +# sampled covariates, group means and fake data +fake <- matrix(rnorm(N * P), ncol = P) +dimnames(fake) <- list(NULL, paste0("x", 1:P)) + +# fixed effect part and sampled group membership +fake <- transform( + as.data.frame(fake), + theta = fake %*% beta, + g = sample.int(G, N, replace=TRUE) +) + +# add random intercept by group +fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") + +# linear predictor +fake <- transform(fake, mu = theta + eta) + +# sample Poisson data +fake <- transform(fake, y = rpois(N, exp(mu))) + +# shuffle order of data rows to ensure even distribution of computational effort +fake <- fake[sample.int(N, N),] + +# drop not needed row names +rownames(fake) <- NULL + +## ---- model-poisson, include=FALSE------------------------------------------------------ +model_poisson <- brm( + y ~ 1 + x1 + x2 + (1 | g), + data = fake, + family = poisson(), + iter = 500, # short sampling to speedup example + chains = 2, + prior = prior(normal(0,1), class = b) + + prior(constant(1), class = sd, group = g), + backend = "cmdstanr", + threads = threading(4) +) + +## ---- benchmark, include=FALSE---------------------------------------------------------- +# Benchmarks given model with cross-product of tuning parameters CPU +# cores, grainsize and iterations. Models are run with either static +# or non-static scheduler and initial values are set by default to 0 on the +# unconstrained scale. Function returns a data-frame with the +# cross-product of the tuning parameters and as result column the +# respective runtime. +benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, + static = FALSE) { + + winfo <- extract_warmup_info(model) + sims <- rstan::extract(model$fit) + init <- list(extract_draw(sims, 1)) + + scaling_model <- update( + model, refresh = 0, + threads = threading(1, grainsize = grainsize[1], static = static), + chains = 1, iter = 2, backend = "cmdstanr" + ) + + run_benchmark <- function(cores, size, iter) { + bench_fit <- update( + scaling_model, warmup=0, iter = iter, + chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE, + threads = threading(cores, grainsize = size, static = static), + inv_metric=winfo$inv_metric[[1]], + step_size=winfo$step_size[[1]], + adapt_engaged=FALSE + ) + lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) + elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) + + c(num_leapfrog=lf, runtime=elapsed) + } + + cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) + res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) + cbind(cases, as.data.frame(t(res))) +} + +benchmark_reference <- function(model, iter=100, init=0) { + winfo <- extract_warmup_info(model) + sims <- rstan::extract(model$fit) + init <- list(extract_draw(sims, 1)) + + ref_model <- update( + model, refresh = 0, + threads = NULL, + chains = 1, iter = 2, backend = "cmdstanr" + ) + + run_benchmark_ref <- function(iter_bench) { + bench_fit <- update( + ref_model, warmup=0, iter = iter_bench, + chains = 1, seed = 1234, init = init, refresh = 0, + inv_metric=winfo$inv_metric[[1]], + step_size=winfo$step_size[[1]], + adapt_engaged=FALSE + ) + + lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) + elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) + + c(num_leapfrog=lf, runtime=elapsed) + } + + ref <- sapply(iter, run_benchmark_ref) + ref <- cbind(as.data.frame(t(ref)), iter=iter) + ref +} + +extract_warmup_info <- function(bfit) { + adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") + step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) + inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) + list(step_size=step_size, inv_metric=inv_metric) +} + +extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE) + + +## ---- eval=FALSE------------------------------------------------------------------------ +# fit_serial <- brm( +# count ~ zAge + zBase * Trt + (1|patient), +# data = epilepsy, family = poisson(), +# chains = 4, cores = 4, backend = "cmdstanr" +# ) + +## ---- eval=FALSE------------------------------------------------------------------------ +# fit_parallel <- update( +# fit_serial, chains = 2, cores = 2, +# backend = "cmdstanr", threads = threading(2) +# ) + +## --------------------------------------------------------------------------------------- +kable(head(fake, 10), digits = 3) + +## ---- eval=FALSE------------------------------------------------------------------------ +# model_poisson <- brm( +# y ~ 1 + x1 + x2 + (1 | g), +# data = fake, +# family = poisson(), +# iter = 500, # short sampling to speedup example +# chains = 2, +# prior = prior(normal(0,1), class = b) + +# prior(constant(1), class = sd, group = g), +# backend = "cmdstanr", +# threads = threading(4) +# ) + +## ---- chunking-scale, message=FALSE, warning=FALSE, results='hide'---------------------- +chunking_bench <- transform( + data.frame(chunks = 4^(0:3)), + grainsize = ceiling(N / chunks) +) + +iter_test <- c(10, 20, 40) # very short test runs +scaling_chunking <- benchmark_threading( + model_poisson, + cores = 1, + grainsize = chunking_bench$grainsize, # test various grainsizes + iter = iter_test, + static = TRUE # with static partitioner +) + +# run as reference the model *without* reduce_sum +ref <- benchmark_reference(model_poisson, iter_test) + +# for additional data munging please refer to the appendix + +## ---- munge-chunking-scaling, include=FALSE--------------------------------------------- +scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") + +single_chunk <- transform( + subset(scaling_chunking, chunks == 1), + num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, + runtime_single = runtime, runtime = NULL, + grainsize = NULL, chunks=NULL +) + +scaling_chunking <- transform( + merge(scaling_chunking, single_chunk), + slowdown = runtime/runtime_single, + iter = factor(iter), + runtime_single = NULL +) + +ref <- transform(ref, iter=factor(iter)) + +## --------------------------------------------------------------------------------------- +ggplot(scaling_chunking) + + aes(chunks, slowdown, colour = iter, shape = iter) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_chunking$chunks) + + scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + + ggtitle("Slowdown with increasing number of chunks") + +ggplot(scaling_chunking) + + aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_chunking$chunks) + + scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + + geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + + ggtitle("Time per leapfrog step vs number of chunks", + "Dashed line is reference model without reduce_sum") + + ylab("Time per leapfrog step [ms]") + + + +## ---- speedup-scale, message=FALSE, warning=FALSE, results='hide'----------------------- +num_cpu <- parallel::detectCores(logical = FALSE) +num_cpu_logical <- parallel::detectCores(logical = TRUE) +grainsize_default <- ceiling(N / (2 * num_cpu)) +cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) +cores <- sort(unique(cores)) +grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) +grainsize <- round(grainsize) + +iter_scaling <- 20 +scaling_cores <- benchmark_threading( + model_poisson, + cores = cores, + grainsize = grainsize, + iter = iter_scaling, + static = FALSE +) + +single_core <- transform( + subset(scaling_cores, cores == 1), + runtime_single = runtime, + num_leapfrog=NULL, runtime=NULL, cores = NULL +) + +scaling_cores <- transform( + merge(scaling_cores, single_core), + speedup = runtime_single/runtime, + grainsize = factor(grainsize) +) + +## --------------------------------------------------------------------------------------- +ggplot(scaling_cores) + + aes(cores, runtime, shape = grainsize, color = grainsize) + + geom_vline(xintercept = num_cpu, linetype = 3) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_cores$cores) + + scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + + theme(legend.position = c(0.85, 0.8)) + + geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + + ggtitle("Runtime with varying number of cores", + "Dashed line is reference model without reduce_sum") + +ggplot(scaling_cores) + + aes(cores, speedup, shape = grainsize, color = grainsize) + + geom_abline(slope = 1, intercept = 0, linetype = 2) + + geom_vline(xintercept = num_cpu, linetype = 3) + + geom_line() + geom_point() + + scale_x_log10(breaks=scaling_cores$cores) + + scale_y_log10(breaks=scaling_cores$cores) + + theme(aspect.ratio = 1) + + coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + + ggtitle("Relative speedup vs 1 core") + +## --------------------------------------------------------------------------------------- +kable(scaling_cores, digits = 2) + +## ---- eval=FALSE------------------------------------------------------------------------ +# set.seed(54647) +# # number of observations +# N <- 1E4 +# # number of group levels +# G <- round(N / 10) +# # number of predictors +# P <- 3 +# # regression coefficients +# beta <- rnorm(P) +# +# # sampled covariates, group means and fake data +# fake <- matrix(rnorm(N * P), ncol = P) +# dimnames(fake) <- list(NULL, paste0("x", 1:P)) +# +# # fixed effect part and sampled group membership +# fake <- transform( +# as.data.frame(fake), +# theta = fake %*% beta, +# g = sample.int(G, N, replace=TRUE) +# ) +# +# # add random intercept by group +# fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") +# +# # linear predictor +# fake <- transform(fake, mu = theta + eta) +# +# # sample Poisson data +# fake <- transform(fake, y = rpois(N, exp(mu))) +# +# # shuffle order of data rows to ensure even distribution of computational effort +# fake <- fake[sample.int(N, N),] +# +# # drop not needed row names +# rownames(fake) <- NULL + +## ---- eval=FALSE------------------------------------------------------------------------ +# model_poisson <- brm( +# y ~ 1 + x1 + x2 + (1 | g), +# data = fake, +# family = poisson(), +# iter = 500, # short sampling to speedup example +# chains = 2, +# prior = prior(normal(0,1), class = b) + +# prior(constant(1), class = sd, group = g), +# backend = "cmdstanr", +# threads = threading(4) +# ) + +## ---- eval=FALSE------------------------------------------------------------------------ +# # Benchmarks given model with cross-product of tuning parameters CPU +# # cores, grainsize and iterations. Models are run with either static +# # or non-static scheduler and initial values are set by default to 0 on the +# # unconstrained scale. Function returns a data-frame with the +# # cross-product of the tuning parameters and as result column the +# # respective runtime. +# benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, +# static = FALSE) { +# +# winfo <- extract_warmup_info(model) +# sims <- rstan::extract(model$fit) +# init <- list(extract_draw(sims, 1)) +# +# scaling_model <- update( +# model, refresh = 0, +# threads = threading(1, grainsize = grainsize[1], static = static), +# chains = 1, iter = 2, backend = "cmdstanr" +# ) +# +# run_benchmark <- function(cores, size, iter) { +# bench_fit <- update( +# scaling_model, warmup=0, iter = iter, +# chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE, +# threads = threading(cores, grainsize = size, static = static), +# inv_metric=winfo$inv_metric[[1]], +# step_size=winfo$step_size[[1]], +# adapt_engaged=FALSE +# ) +# lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) +# elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) +# +# c(num_leapfrog=lf, runtime=elapsed) +# } +# +# cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) +# res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) +# cbind(cases, as.data.frame(t(res))) +# } +# +# benchmark_reference <- function(model, iter=100, init=0) { +# winfo <- extract_warmup_info(model) +# sims <- rstan::extract(model$fit) +# init <- list(extract_draw(sims, 1)) +# +# ref_model <- update( +# model, refresh = 0, +# threads = NULL, +# chains = 1, iter = 2, backend = "cmdstanr" +# ) +# +# run_benchmark_ref <- function(iter_bench) { +# bench_fit <- update( +# ref_model, warmup=0, iter = iter_bench, +# chains = 1, seed = 1234, init = init, refresh = 0, +# inv_metric=winfo$inv_metric[[1]], +# step_size=winfo$step_size[[1]], +# adapt_engaged=FALSE +# ) +# +# lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) +# elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) +# +# c(num_leapfrog=lf, runtime=elapsed) +# } +# +# ref <- sapply(iter, run_benchmark_ref) +# ref <- cbind(as.data.frame(t(ref)), iter=iter) +# ref +# } +# +# extract_warmup_info <- function(bfit) { +# adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") +# step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) +# inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) +# list(step_size=step_size, inv_metric=inv_metric) +# } +# +# extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE) +# + +## ---- eval=FALSE------------------------------------------------------------------------ +# scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") +# +# single_chunk <- transform( +# subset(scaling_chunking, chunks == 1), +# num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, +# runtime_single = runtime, runtime = NULL, +# grainsize = NULL, chunks=NULL +# ) +# +# scaling_chunking <- transform( +# merge(scaling_chunking, single_chunk), +# slowdown = runtime/runtime_single, +# iter = factor(iter), +# runtime_single = NULL +# ) +# +# ref <- transform(ref, iter=factor(iter)) + diff -Nru r-cran-brms-2.16.3/inst/doc/brms_threading.Rmd r-cran-brms-2.17.0/inst/doc/brms_threading.Rmd --- r-cran-brms-2.16.3/inst/doc/brms_threading.Rmd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/inst/doc/brms_threading.Rmd 2022-04-11 07:21:44.000000000 +0000 @@ -1,579 +1,579 @@ ---- -title: "Running brms models with within-chain parallelization" -author: "Sebastian Weber & Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Running brms models with within-chain parallelization} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(ggplot2) -library(brms) -theme_set(theme_default()) -``` - -```{r, fake-data-sim, include=FALSE, eval=TRUE} -set.seed(54647) -# number of observations -N <- 1E4 -# number of group levels -G <- round(N / 10) -# number of predictors -P <- 3 -# regression coefficients -beta <- rnorm(P) - -# sampled covariates, group means and fake data -fake <- matrix(rnorm(N * P), ncol = P) -dimnames(fake) <- list(NULL, paste0("x", 1:P)) - -# fixed effect part and sampled group membership -fake <- transform( - as.data.frame(fake), - theta = fake %*% beta, - g = sample.int(G, N, replace=TRUE) -) - -# add random intercept by group -fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") - -# linear predictor -fake <- transform(fake, mu = theta + eta) - -# sample Poisson data -fake <- transform(fake, y = rpois(N, exp(mu))) - -# shuffle order of data rows to ensure even distribution of computational effort -fake <- fake[sample.int(N, N),] - -# drop not needed row names -rownames(fake) <- NULL -``` - -```{r, model-poisson, include=FALSE} -model_poisson <- brm( - y ~ 1 + x1 + x2 + (1 | g), - data = fake, - family = poisson(), - iter = 500, # short sampling to speedup example - chains = 2, - prior = prior(normal(0,1), class = b) + - prior(constant(1), class = sd, group = g), - backend = "cmdstanr", - threads = threading(4) -) -``` - -```{r, benchmark, include=FALSE} -# Benchmarks given model with cross-product of tuning parameters CPU -# cores, grainsize and iterations. Models are run with either static -# or non-static scheduler and inits is set by default to 0 on the -# unconstrained scale. Function returns a data-frame with the -# cross-product of the tuning parameters and as result column the -# respective runtime. -benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, - static = FALSE) { - - winfo <- extract_warmup_info(model) - sims <- rstan::extract(model$fit) - init <- list(extract_draw(sims, 1)) - - scaling_model <- update( - model, refresh = 0, - threads = threading(1, grainsize = grainsize[1], static = static), - chains = 1, iter = 2, backend = "cmdstanr" - ) - - run_benchmark <- function(cores, size, iter) { - bench_fit <- update( - scaling_model, warmup=0, iter = iter, - chains = 1, seed = 1234, inits = init, refresh = 0, save_warmup=TRUE, - threads = threading(cores, grainsize = size, static = static), - inv_metric=winfo$inv_metric[[1]], - step_size=winfo$step_size[[1]], - adapt_engaged=FALSE - ) - lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) - elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) - - c(num_leapfrog=lf, runtime=elapsed) - } - - cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) - res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) - cbind(cases, as.data.frame(t(res))) -} - -benchmark_reference <- function(model, iter=100, inits=0) { - winfo <- extract_warmup_info(model) - sims <- rstan::extract(model$fit) - init <- list(extract_draw(sims, 1)) - - ref_model <- update( - model, refresh = 0, - threads = NULL, - chains = 1, iter = 2, backend = "cmdstanr" - ) - - run_benchmark_ref <- function(iter_bench) { - bench_fit <- update( - ref_model, warmup=0, iter = iter_bench, - chains = 1, seed = 1234, inits = init, refresh = 0, - inv_metric=winfo$inv_metric[[1]], - step_size=winfo$step_size[[1]], - adapt_engaged=FALSE - ) - - lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) - elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) - - c(num_leapfrog=lf, runtime=elapsed) - } - - ref <- sapply(iter, run_benchmark_ref) - ref <- cbind(as.data.frame(t(ref)), iter=iter) - ref -} - -extract_warmup_info <- function(bfit) { - adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") - step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) - inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) - list(step_size=step_size, inv_metric=inv_metric) -} - -extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE) - -``` - -## Introduction - -Full Bayesian inference is a computationally very demanding task and often we -wish to run our models faster in shorter walltime. With modern computers we -nowadays have multiple processors available on a given machine such that the use -of running the inference in parallel will shorten the overall walltime. While -between-chain parallelization is straightforward by merely launching multiple -chains at the same time, the use of within-chain parallelization is more -complicated in various ways. This vignette aims to introduce the user to -within-chain parallelization with **brms**, since its efficient use depends on -various aspects specific to the users model. - -## Quick summary - -Assuming you have a **brms** model which you wish to evaluate faster by using -more cores per chain, for example: - -```{r, eval=FALSE} -fit_serial <- brm( - count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson(), - chains = 4, cores = 4, backend = "cmdstanr" -) -``` - -Then running this model with threading requires `cmdstanr` as backend and you -can simply add threading support to an existing model with the `update` -mechanism as: - -```{r, eval=FALSE} -fit_parallel <- update( - fit_serial, chains = 2, cores = 2, - backend = "cmdstanr", threads = threading(2) -) -``` - -The example above assumes that 4 cores are available which are best used without -within-chain parallelization by running 4 chains in parallel. When using within -chain parallelization it is still advisable to use just as many threads -*in total* as you have CPU cores. It's thus sensible in this case to reduce the -number of chains running in parallel to just 2, but allow each chain to use 2 -threads. Obviously this will reduce the number of iterations in the posterior -here as we assumed a fixed amount of 4 cores. - -- Only apply within-chain parallelization to large problems which take - more than a few minutes at least to calculate. The `epilepsy` - example above is actually too small to gain in speed (just a few seconds - per chain on this machine). -- Within-chain parallelization is less efficient than between-chain - parallelization. So only use within-chain parallelism if more CPUs - can be used to run the entire analysis. -- Due to details of the model and data-set, speedups with more cores - can be very limited. Not every model amends to within-chain - parallelization and an empirical evaluation is in some cases - advisable. -- Enabling threading *usually* slows down any model to some extent and - this slowdown must be offset by sufficient cores per chain in order - to really gain in execution speed. -- Doubling the execution speed with few cores is a lot easier than - obtaining larger speedups with even more cores. -- Models with computationally expensive likelihoods are easier to - parallelize than less expensive likelihoods. For example, the Poisson - distribution involves expensive $\log\Gamma$ functions whereas the - normal likelihood is very cheap to calculate in comparison. -- Models with many parameters (e.g., multilevel models) - carry a large overhead when running in parallel. -- With a larger overhead of the model, the likelihood must be - sufficiently expensive such that the relative computational cost of - likelihood to parallelization overhead is favorable. -- Avoid using hyper-threading, that is, only use as many threads as you - have physical cores available. -- Ensure that the data is randomly sorted such that consecutive - subsets of the data are roughly of the same computational effort. - -## Within-chain parallelization - -The within-chain parallelization implemented in **brms** is based on the -`reduce_sum` facility in Stan. The basic principle that `reduce_sum` uses is to -split a large summation into arbitrary smaller partial sums. Due to the -commutativity and associativity of the sum operation these smaller partial sums -can be evaluated in any order and in parallel from one another. **brms** -leverages `reduce_sum` to evaluate the log-likelihood of the model in parallel -as for example - -$$ -\begin{aligned} -l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ - &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). -\end{aligned} -$$ - -As a consequence, the within-chain parallelization requires mutually independent -log-likelihood terms which restricts its applicability to some degree. - -Furthermore, the within-chain parallelization is only applicable to the -evaluation of the data likelihood while all other parts of the model, for -example priors, will remain running serially. Thus, only a partial fraction of -the entire Stan model will run in parallel which limits the potential speedup -one may obtain. The theoretical speedup for a partially in parallel running -program is described by -[Amdahl‘s law](https://en.wikipedia.org/wiki/Amdahl%27s_law). -For example, with 90% of the computational load running in parallel one can -essentially double the execution speed with 2 cores while 8 cores may only -speedup the program by at most 5x. How large the computational cost of the -log-likelihood is in relation to the entire model is very dependent on the -model of the user. - -In practice, the speedups are even smaller than the theoretical speedups. This -is caused by the additional overhead implied by forming multiple smaller sums -than just one large one. For example, for each partial sum formed the entire -parameter vector $\theta$ has to be copied in memory for Stan to be able to -calculate the gradient of the log-likelihood. Hence, with more partial sums, -more copying is necessary as opposed to evaluating just one large sum. Whether -the additional copying is indeed relevant depends on the computational cost of -the log-likelihood of each term and the number of parameters. For a model with a -computationally cheap normal log-likelihood, this effect is more important than -for a model with a Poisson log-likelihood, and for multilevel models with many -parameters more copying is needed than for simpler regression models. It may -therefore be necessary to form sufficiently large partial sums to warrant an -efficient parallel execution. The size of the partial sums is referred to as the -`grainsize`, which is set to a reasonable default value. However, for some -models this tuning parameter requires some attention from the user for optimal -performance. - -Finally, it is important to note that by default the exact size and order of the -partial sums is not stable as it is adjusted to the load of the system. As a -result, exact numerical reproducibility is not guaranteed by default. In order -to warrant the same size and order of the partial sums, the `static` option must -be used and set to `TRUE`, which uses a deterministic scheduler for the parallel -work. - -## Example model - -As a toy demonstration, we use here a multilevel Poisson model. The model is a -varying intercept model with $`r N`$ data observation which are grouped into -$`r G`$ groups. Each data item has $`r P`$ continuous covariates. The -simulation code for the fake data can be found in the appendix and it's first -$10$ rows are: - -```{r} -kable(head(fake, 10), digits = 3) -``` - -The **brms** model fitting this data is: - -```{r, eval=FALSE} -<> -``` - -Here we have fixed the standard deviation of the between-group variation for the -intercept to the true value of $1$ as used in the simulation. This is to avoid -unfavorable geometry of the problem allowing us to concentrate on computational -aspects alone. - -The Poisson likelihood is a relatively expensive likelihood due to the use of -$\log\Gamma$ function as opposed to, for example, a normal likelihood which does -is by far less expensive operations. Moreover, this example is chosen in order -to demonstrate parallelization overhead implied by a large number of parameters. - -## Managing parallelization overhead - -As discussed above, the key mechanism to run Stan programs with parallelization -is to split the large sum over independent log likelihood terms into arbitrary -smaller *partial sums*. Creating more *partial sums* allows to increase -simultaneous parallel computations in a granular way, but at the same time -additional overhead is introduced through the requirement to copy the entire -parameter vector for each *partial sum* formed along with further overhead due -to splitting up a single large task into multiple smaller ones. - -By default, **brms** will choose a sensible `grainsize` which defines how large -a given *partial sum* will roughly be. The actual chunk size is automatically -tuned whenever the default non-static scheduler is used, which is the -recommended choice to start with. As noted before, only the static scheduler is -giving fully deterministic results since the chunk size and order of partial -sums will be the same during sampling. - -While we expect that the default `grainsize` in **brms** is reasonably good for -many models, it can improve performance if one tunes the `grainsize` -specifically to a given model and data-set. We suggest to increase successively -the number of chunks a given data set is split into with the static scheduler -and run this on a single core. This way one can control the number of -*partial sum* accurately and monitor the execution time as it increases. These -experiments are run with only a single chain and very short iteration numbers as -we are not interested in the statistical results, but rather aim to be able to -explore the tuning parameter space of the chunk size as quickly as possible. The -number of iterations needed to get reliable runtime estimates for a given chunk -size will depend on many details and the easiest way to determine this is to run -this benchmark with multiple number of iterations. Whenever their results match -approximately, then the iteration numbers are sufficient. In order to -decrease the variation between runs, we also fix the random seed, -initial value and the tuning parameters of the sampler (step size and -mass matrix). - -Below is an example R code demonstrating such a benchmark. The utility function -`benchmark_threading` is shown and explained in the appendix. - -```{r, chunking-scale, message=FALSE, warning=FALSE, results='hide'} -chunking_bench <- transform( - data.frame(chunks = 4^(0:3)), - grainsize = ceiling(N / chunks) -) - -iter_test <- c(10, 20, 40) # very short test runs -scaling_chunking <- benchmark_threading( - model_poisson, - cores = 1, - grainsize = chunking_bench$grainsize, # test various grainsizes - iter = iter_test, - static = TRUE # with static partitioner -) - -# run as reference the model *without* reduce_sum -ref <- benchmark_reference(model_poisson, iter_test) - -# for additional data munging please refer to the appendix -``` - -```{r, munge-chunking-scaling, include=FALSE} -scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") - -single_chunk <- transform( - subset(scaling_chunking, chunks == 1), - num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, - runtime_single = runtime, runtime = NULL, - grainsize = NULL, chunks=NULL -) - -scaling_chunking <- transform( - merge(scaling_chunking, single_chunk), - slowdown = runtime/runtime_single, - iter = factor(iter), - runtime_single = NULL -) - -ref <- transform(ref, iter=factor(iter)) -``` - -Graphically summarizing the results shows that with more than 8 chunks the -overhead is about 10% and increasing further with more chunks. For models -without many parameters, no such overhead should be observed. Furthermore, one -can see that 25 and 50 iterations give similar results implying that 25 -iterations suffice for stable runtime estimates for these (and the following) -benchmarks. The overhead of up to 20% in this example with 16 chunks may seem -large due to the scaling of the plot. One must not forget that when we start to -use more CPU cores, the overhead is easily offset, but it limits the maximal -speedup we can get. For example, some 2 units of computation become 2.4 units -due to the overhead such that on 2 cores we don't quite double the execution -speed, but rather get a 1.6x increase in speed instead of a 2x -speedup. - -Considering in addition the time per leapfrog step of the NUTS sampler -shows on an absolute scale similar information as before. The upside -of this representation is that we can visualize the slowdown in -relation to the program *without* `reduce_sum`. As we can see, the -additional overhead due to merely enabling `reduce_sum` is substantial -in this example. This is attributed in the specific example to the -large number of random effects. - -```{r} -ggplot(scaling_chunking) + - aes(chunks, slowdown, colour = iter, shape = iter) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_chunking$chunks) + - scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + - ggtitle("Slowdown with increasing number of chunks") - -ggplot(scaling_chunking) + - aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_chunking$chunks) + - scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + - geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + - ggtitle("Time per leapfrog step vs number of chunks", - "Dashed line is reference model without reduce_sum") + - ylab("Time per leapfrog step [ms]") - - -``` - -## Parallelization speedup - -In practice, we are often interested in so-called "hard-scaling" properties of -the parallelization system. That is, for a fixed problem size we would like to -know how much faster we can execute the Stan program with increasing number of -threads. As nowadays CPUs usually run with so-called hyper-threading, it is also -of interest if this technique is beneficial for Stan programs as well (spoiler -alert: it's not useful). As we have seen before, the `grainsize` can have an -impact on the performance and is as such a tuning parameter. Below we -demonstrate some exemplary R code which runs a benchmark with varying number of -CPU cores and varying number of `grainsize`s. - -```{r, speedup-scale, message=FALSE, warning=FALSE, results='hide'} -num_cpu <- parallel::detectCores(logical = FALSE) -num_cpu_logical <- parallel::detectCores(logical = TRUE) -grainsize_default <- ceiling(N / (2 * num_cpu)) -cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) -cores <- sort(unique(cores)) -grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) -grainsize <- round(grainsize) - -iter_scaling <- 20 -scaling_cores <- benchmark_threading( - model_poisson, - cores = cores, - grainsize = grainsize, - iter = iter_scaling, - static = FALSE -) - -single_core <- transform( - subset(scaling_cores, cores == 1), - runtime_single = runtime, - num_leapfrog=NULL, runtime=NULL, cores = NULL -) - -scaling_cores <- transform( - merge(scaling_cores, single_core), - speedup = runtime_single/runtime, - grainsize = factor(grainsize) -) -``` - -It is important to consider the absolute runtime and the relative speedup vs. -running on a single core. The relative speedup can be misleading if the single -core runtime is very slow in which case speed gains on more CPUs may look overly -good. Considering instead the absolute runtime avoids this problem. After -all, we are interested in the shortest walltime we can get rather than any -relative speedups. - -```{r} -ggplot(scaling_cores) + - aes(cores, runtime, shape = grainsize, color = grainsize) + - geom_vline(xintercept = num_cpu, linetype = 3) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_cores$cores) + - scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + - theme(legend.position = c(0.85, 0.8)) + - geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + - ggtitle("Runtime with varying number of cores", - "Dashed line is reference model without reduce_sum") - -ggplot(scaling_cores) + - aes(cores, speedup, shape = grainsize, color = grainsize) + - geom_abline(slope = 1, intercept = 0, linetype = 2) + - geom_vline(xintercept = num_cpu, linetype = 3) + - geom_line() + geom_point() + - scale_x_log10(breaks=scaling_cores$cores) + - scale_y_log10(breaks=scaling_cores$cores) + - theme(aspect.ratio = 1) + - coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + - ggtitle("Relative speedup vs 1 core") -``` - -The vertical dotted line marks the physical number of CPU cores on the machine -this was run. The horizontal dashed line in the plot with absolute -runtime marks the respective runtime of the model *without* -`reduce_sum` and the dashed unity line in the plot with the relative -speedup marks the theoretical maximal speedup. We can see -that there is no further reduction in execution time when increasing the thread -count to be greater than the number of physical CPUs. Hence, the use of -hyper-threading is not helpful when aiming to maximize the speed of a Stan -program. Moreover, the use of threading outperforms the single core -runtime only when using more than 4 cores in this example. - -For this example, the shown `grainsize`s matter on some machines but -not on others, so your results may look quite different from what is shown here. -The overall speedups may not seem impressive in this case, which is attributed -in this case to the large number of parameters relative to the number of -observations. However, we can still outperform the single core -runtime when using many cores. Though the most important advantage of -threading is that with an increasing data set size, the user has the option to -use a brute-force approach to balance the increase in walltime needed. - -```{r} -kable(scaling_cores, digits = 2) -``` - -For a given Stan model one should usually choose the number of chains and the -number of threads per chain to be equal to the number of (physical) cores one -wishes to use. Only if different chains of the model have relatively different -execution times (which they should not have, but it occurs sometimes in -practice), then one may consider the use of hyper-threading. Doing so will share -the resources evenly across all chains and whenever the fastest chain finishes, -the freed resources can be given to the still running chains. - -## Appendix - -### Fake data simulation - -```{r, eval=FALSE} -<> -``` - -### Poisson example model - -```{r, eval=FALSE} -<> -``` - -### Threading benchmark function - -```{r, eval=FALSE} -<> -``` - -### Munging of slowdown with chunking data - -```{r, eval=FALSE} -<> -``` +--- +title: "Running brms models with within-chain parallelization" +author: "Sebastian Weber & Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Running brms models with within-chain parallelization} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(ggplot2) +library(brms) +theme_set(theme_default()) +``` + +```{r, fake-data-sim, include=FALSE, eval=TRUE} +set.seed(54647) +# number of observations +N <- 1E4 +# number of group levels +G <- round(N / 10) +# number of predictors +P <- 3 +# regression coefficients +beta <- rnorm(P) + +# sampled covariates, group means and fake data +fake <- matrix(rnorm(N * P), ncol = P) +dimnames(fake) <- list(NULL, paste0("x", 1:P)) + +# fixed effect part and sampled group membership +fake <- transform( + as.data.frame(fake), + theta = fake %*% beta, + g = sample.int(G, N, replace=TRUE) +) + +# add random intercept by group +fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") + +# linear predictor +fake <- transform(fake, mu = theta + eta) + +# sample Poisson data +fake <- transform(fake, y = rpois(N, exp(mu))) + +# shuffle order of data rows to ensure even distribution of computational effort +fake <- fake[sample.int(N, N),] + +# drop not needed row names +rownames(fake) <- NULL +``` + +```{r, model-poisson, include=FALSE} +model_poisson <- brm( + y ~ 1 + x1 + x2 + (1 | g), + data = fake, + family = poisson(), + iter = 500, # short sampling to speedup example + chains = 2, + prior = prior(normal(0,1), class = b) + + prior(constant(1), class = sd, group = g), + backend = "cmdstanr", + threads = threading(4) +) +``` + +```{r, benchmark, include=FALSE} +# Benchmarks given model with cross-product of tuning parameters CPU +# cores, grainsize and iterations. Models are run with either static +# or non-static scheduler and initial values are set by default to 0 on the +# unconstrained scale. Function returns a data-frame with the +# cross-product of the tuning parameters and as result column the +# respective runtime. +benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, + static = FALSE) { + + winfo <- extract_warmup_info(model) + sims <- rstan::extract(model$fit) + init <- list(extract_draw(sims, 1)) + + scaling_model <- update( + model, refresh = 0, + threads = threading(1, grainsize = grainsize[1], static = static), + chains = 1, iter = 2, backend = "cmdstanr" + ) + + run_benchmark <- function(cores, size, iter) { + bench_fit <- update( + scaling_model, warmup=0, iter = iter, + chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE, + threads = threading(cores, grainsize = size, static = static), + inv_metric=winfo$inv_metric[[1]], + step_size=winfo$step_size[[1]], + adapt_engaged=FALSE + ) + lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) + elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) + + c(num_leapfrog=lf, runtime=elapsed) + } + + cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) + res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) + cbind(cases, as.data.frame(t(res))) +} + +benchmark_reference <- function(model, iter=100, init=0) { + winfo <- extract_warmup_info(model) + sims <- rstan::extract(model$fit) + init <- list(extract_draw(sims, 1)) + + ref_model <- update( + model, refresh = 0, + threads = NULL, + chains = 1, iter = 2, backend = "cmdstanr" + ) + + run_benchmark_ref <- function(iter_bench) { + bench_fit <- update( + ref_model, warmup=0, iter = iter_bench, + chains = 1, seed = 1234, init = init, refresh = 0, + inv_metric=winfo$inv_metric[[1]], + step_size=winfo$step_size[[1]], + adapt_engaged=FALSE + ) + + lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) + elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) + + c(num_leapfrog=lf, runtime=elapsed) + } + + ref <- sapply(iter, run_benchmark_ref) + ref <- cbind(as.data.frame(t(ref)), iter=iter) + ref +} + +extract_warmup_info <- function(bfit) { + adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") + step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) + inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) + list(step_size=step_size, inv_metric=inv_metric) +} + +extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE) + +``` + +## Introduction + +Full Bayesian inference is a computationally very demanding task and often we +wish to run our models faster in shorter walltime. With modern computers we +nowadays have multiple processors available on a given machine such that the use +of running the inference in parallel will shorten the overall walltime. While +between-chain parallelization is straightforward by merely launching multiple +chains at the same time, the use of within-chain parallelization is more +complicated in various ways. This vignette aims to introduce the user to +within-chain parallelization with **brms**, since its efficient use depends on +various aspects specific to the users model. + +## Quick summary + +Assuming you have a **brms** model which you wish to evaluate faster by using +more cores per chain, for example: + +```{r, eval=FALSE} +fit_serial <- brm( + count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson(), + chains = 4, cores = 4, backend = "cmdstanr" +) +``` + +Then running this model with threading requires `cmdstanr` as backend and you +can simply add threading support to an existing model with the `update` +mechanism as: + +```{r, eval=FALSE} +fit_parallel <- update( + fit_serial, chains = 2, cores = 2, + backend = "cmdstanr", threads = threading(2) +) +``` + +The example above assumes that 4 cores are available which are best used without +within-chain parallelization by running 4 chains in parallel. When using within +chain parallelization it is still advisable to use just as many threads +*in total* as you have CPU cores. It's thus sensible in this case to reduce the +number of chains running in parallel to just 2, but allow each chain to use 2 +threads. Obviously this will reduce the number of iterations in the posterior +here as we assumed a fixed amount of 4 cores. + +- Only apply within-chain parallelization to large problems which take + more than a few minutes at least to calculate. The `epilepsy` + example above is actually too small to gain in speed (just a few seconds + per chain on this machine). +- Within-chain parallelization is less efficient than between-chain + parallelization. So only use within-chain parallelism if more CPUs + can be used to run the entire analysis. +- Due to details of the model and data-set, speedups with more cores + can be very limited. Not every model amends to within-chain + parallelization and an empirical evaluation is in some cases + advisable. +- Enabling threading *usually* slows down any model to some extent and + this slowdown must be offset by sufficient cores per chain in order + to really gain in execution speed. +- Doubling the execution speed with few cores is a lot easier than + obtaining larger speedups with even more cores. +- Models with computationally expensive likelihoods are easier to + parallelize than less expensive likelihoods. For example, the Poisson + distribution involves expensive $\log\Gamma$ functions whereas the + normal likelihood is very cheap to calculate in comparison. +- Models with many parameters (e.g., multilevel models) + carry a large overhead when running in parallel. +- With a larger overhead of the model, the likelihood must be + sufficiently expensive such that the relative computational cost of + likelihood to parallelization overhead is favorable. +- Avoid using hyper-threading, that is, only use as many threads as you + have physical cores available. +- Ensure that the data is randomly sorted such that consecutive + subsets of the data are roughly of the same computational effort. + +## Within-chain parallelization + +The within-chain parallelization implemented in **brms** is based on the +`reduce_sum` facility in Stan. The basic principle that `reduce_sum` uses is to +split a large summation into arbitrary smaller partial sums. Due to the +commutativity and associativity of the sum operation these smaller partial sums +can be evaluated in any order and in parallel from one another. **brms** +leverages `reduce_sum` to evaluate the log-likelihood of the model in parallel +as for example + +$$ +\begin{aligned} +l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ + &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). +\end{aligned} +$$ + +As a consequence, the within-chain parallelization requires mutually independent +log-likelihood terms which restricts its applicability to some degree. + +Furthermore, the within-chain parallelization is only applicable to the +evaluation of the data likelihood while all other parts of the model, for +example priors, will remain running serially. Thus, only a partial fraction of +the entire Stan model will run in parallel which limits the potential speedup +one may obtain. The theoretical speedup for a partially in parallel running +program is described by +[Amdahl‘s law](https://en.wikipedia.org/wiki/Amdahl%27s_law). +For example, with 90% of the computational load running in parallel one can +essentially double the execution speed with 2 cores while 8 cores may only +speedup the program by at most 5x. How large the computational cost of the +log-likelihood is in relation to the entire model is very dependent on the +model of the user. + +In practice, the speedups are even smaller than the theoretical speedups. This +is caused by the additional overhead implied by forming multiple smaller sums +than just one large one. For example, for each partial sum formed the entire +parameter vector $\theta$ has to be copied in memory for Stan to be able to +calculate the gradient of the log-likelihood. Hence, with more partial sums, +more copying is necessary as opposed to evaluating just one large sum. Whether +the additional copying is indeed relevant depends on the computational cost of +the log-likelihood of each term and the number of parameters. For a model with a +computationally cheap normal log-likelihood, this effect is more important than +for a model with a Poisson log-likelihood, and for multilevel models with many +parameters more copying is needed than for simpler regression models. It may +therefore be necessary to form sufficiently large partial sums to warrant an +efficient parallel execution. The size of the partial sums is referred to as the +`grainsize`, which is set to a reasonable default value. However, for some +models this tuning parameter requires some attention from the user for optimal +performance. + +Finally, it is important to note that by default the exact size and order of the +partial sums is not stable as it is adjusted to the load of the system. As a +result, exact numerical reproducibility is not guaranteed by default. In order +to warrant the same size and order of the partial sums, the `static` option must +be used and set to `TRUE`, which uses a deterministic scheduler for the parallel +work. + +## Example model + +As a toy demonstration, we use here a multilevel Poisson model. The model is a +varying intercept model with $`r N`$ data observation which are grouped into +$`r G`$ groups. Each data item has $`r P`$ continuous covariates. The +simulation code for the fake data can be found in the appendix and it's first +$10$ rows are: + +```{r} +kable(head(fake, 10), digits = 3) +``` + +The **brms** model fitting this data is: + +```{r, eval=FALSE} +<> +``` + +Here we have fixed the standard deviation of the between-group variation for the +intercept to the true value of $1$ as used in the simulation. This is to avoid +unfavorable geometry of the problem allowing us to concentrate on computational +aspects alone. + +The Poisson likelihood is a relatively expensive likelihood due to the use of +$\log\Gamma$ function as opposed to, for example, a normal likelihood which does +is by far less expensive operations. Moreover, this example is chosen in order +to demonstrate parallelization overhead implied by a large number of parameters. + +## Managing parallelization overhead + +As discussed above, the key mechanism to run Stan programs with parallelization +is to split the large sum over independent log likelihood terms into arbitrary +smaller *partial sums*. Creating more *partial sums* allows to increase +simultaneous parallel computations in a granular way, but at the same time +additional overhead is introduced through the requirement to copy the entire +parameter vector for each *partial sum* formed along with further overhead due +to splitting up a single large task into multiple smaller ones. + +By default, **brms** will choose a sensible `grainsize` which defines how large +a given *partial sum* will roughly be. The actual chunk size is automatically +tuned whenever the default non-static scheduler is used, which is the +recommended choice to start with. As noted before, only the static scheduler is +giving fully deterministic results since the chunk size and order of partial +sums will be the same during sampling. + +While we expect that the default `grainsize` in **brms** is reasonably good for +many models, it can improve performance if one tunes the `grainsize` +specifically to a given model and data-set. We suggest to increase successively +the number of chunks a given data set is split into with the static scheduler +and run this on a single core. This way one can control the number of +*partial sum* accurately and monitor the execution time as it increases. These +experiments are run with only a single chain and very short iteration numbers as +we are not interested in the statistical results, but rather aim to be able to +explore the tuning parameter space of the chunk size as quickly as possible. The +number of iterations needed to get reliable runtime estimates for a given chunk +size will depend on many details and the easiest way to determine this is to run +this benchmark with multiple number of iterations. Whenever their results match +approximately, then the iteration numbers are sufficient. In order to +decrease the variation between runs, we also fix the random seed, +initial value and the tuning parameters of the sampler (step size and +mass matrix). + +Below is an example R code demonstrating such a benchmark. The utility function +`benchmark_threading` is shown and explained in the appendix. + +```{r, chunking-scale, message=FALSE, warning=FALSE, results='hide'} +chunking_bench <- transform( + data.frame(chunks = 4^(0:3)), + grainsize = ceiling(N / chunks) +) + +iter_test <- c(10, 20, 40) # very short test runs +scaling_chunking <- benchmark_threading( + model_poisson, + cores = 1, + grainsize = chunking_bench$grainsize, # test various grainsizes + iter = iter_test, + static = TRUE # with static partitioner +) + +# run as reference the model *without* reduce_sum +ref <- benchmark_reference(model_poisson, iter_test) + +# for additional data munging please refer to the appendix +``` + +```{r, munge-chunking-scaling, include=FALSE} +scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") + +single_chunk <- transform( + subset(scaling_chunking, chunks == 1), + num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, + runtime_single = runtime, runtime = NULL, + grainsize = NULL, chunks=NULL +) + +scaling_chunking <- transform( + merge(scaling_chunking, single_chunk), + slowdown = runtime/runtime_single, + iter = factor(iter), + runtime_single = NULL +) + +ref <- transform(ref, iter=factor(iter)) +``` + +Graphically summarizing the results shows that with more than 8 chunks the +overhead is about 10% and increasing further with more chunks. For models +without many parameters, no such overhead should be observed. Furthermore, one +can see that 25 and 50 iterations give similar results implying that 25 +iterations suffice for stable runtime estimates for these (and the following) +benchmarks. The overhead of up to 20% in this example with 16 chunks may seem +large due to the scaling of the plot. One must not forget that when we start to +use more CPU cores, the overhead is easily offset, but it limits the maximal +speedup we can get. For example, some 2 units of computation become 2.4 units +due to the overhead such that on 2 cores we don't quite double the execution +speed, but rather get a 1.6x increase in speed instead of a 2x +speedup. + +Considering in addition the time per leapfrog step of the NUTS sampler +shows on an absolute scale similar information as before. The upside +of this representation is that we can visualize the slowdown in +relation to the program *without* `reduce_sum`. As we can see, the +additional overhead due to merely enabling `reduce_sum` is substantial +in this example. This is attributed in the specific example to the +large number of random effects. + +```{r} +ggplot(scaling_chunking) + + aes(chunks, slowdown, colour = iter, shape = iter) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_chunking$chunks) + + scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + + ggtitle("Slowdown with increasing number of chunks") + +ggplot(scaling_chunking) + + aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_chunking$chunks) + + scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + + geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + + ggtitle("Time per leapfrog step vs number of chunks", + "Dashed line is reference model without reduce_sum") + + ylab("Time per leapfrog step [ms]") + + +``` + +## Parallelization speedup + +In practice, we are often interested in so-called "hard-scaling" properties of +the parallelization system. That is, for a fixed problem size we would like to +know how much faster we can execute the Stan program with increasing number of +threads. As nowadays CPUs usually run with so-called hyper-threading, it is also +of interest if this technique is beneficial for Stan programs as well (spoiler +alert: it's not useful). As we have seen before, the `grainsize` can have an +impact on the performance and is as such a tuning parameter. Below we +demonstrate some exemplary R code which runs a benchmark with varying number of +CPU cores and varying number of `grainsize`s. + +```{r, speedup-scale, message=FALSE, warning=FALSE, results='hide'} +num_cpu <- parallel::detectCores(logical = FALSE) +num_cpu_logical <- parallel::detectCores(logical = TRUE) +grainsize_default <- ceiling(N / (2 * num_cpu)) +cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) +cores <- sort(unique(cores)) +grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) +grainsize <- round(grainsize) + +iter_scaling <- 20 +scaling_cores <- benchmark_threading( + model_poisson, + cores = cores, + grainsize = grainsize, + iter = iter_scaling, + static = FALSE +) + +single_core <- transform( + subset(scaling_cores, cores == 1), + runtime_single = runtime, + num_leapfrog=NULL, runtime=NULL, cores = NULL +) + +scaling_cores <- transform( + merge(scaling_cores, single_core), + speedup = runtime_single/runtime, + grainsize = factor(grainsize) +) +``` + +It is important to consider the absolute runtime and the relative speedup vs. +running on a single core. The relative speedup can be misleading if the single +core runtime is very slow in which case speed gains on more CPUs may look overly +good. Considering instead the absolute runtime avoids this problem. After +all, we are interested in the shortest walltime we can get rather than any +relative speedups. + +```{r} +ggplot(scaling_cores) + + aes(cores, runtime, shape = grainsize, color = grainsize) + + geom_vline(xintercept = num_cpu, linetype = 3) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_cores$cores) + + scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + + theme(legend.position = c(0.85, 0.8)) + + geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + + ggtitle("Runtime with varying number of cores", + "Dashed line is reference model without reduce_sum") + +ggplot(scaling_cores) + + aes(cores, speedup, shape = grainsize, color = grainsize) + + geom_abline(slope = 1, intercept = 0, linetype = 2) + + geom_vline(xintercept = num_cpu, linetype = 3) + + geom_line() + geom_point() + + scale_x_log10(breaks=scaling_cores$cores) + + scale_y_log10(breaks=scaling_cores$cores) + + theme(aspect.ratio = 1) + + coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + + ggtitle("Relative speedup vs 1 core") +``` + +The vertical dotted line marks the physical number of CPU cores on the machine +this was run. The horizontal dashed line in the plot with absolute +runtime marks the respective runtime of the model *without* +`reduce_sum` and the dashed unity line in the plot with the relative +speedup marks the theoretical maximal speedup. We can see +that there is no further reduction in execution time when increasing the thread +count to be greater than the number of physical CPUs. Hence, the use of +hyper-threading is not helpful when aiming to maximize the speed of a Stan +program. Moreover, the use of threading outperforms the single core +runtime only when using more than 4 cores in this example. + +For this example, the shown `grainsize`s matter on some machines but +not on others, so your results may look quite different from what is shown here. +The overall speedups may not seem impressive in this case, which is attributed +in this case to the large number of parameters relative to the number of +observations. However, we can still outperform the single core +runtime when using many cores. Though the most important advantage of +threading is that with an increasing data set size, the user has the option to +use a brute-force approach to balance the increase in walltime needed. + +```{r} +kable(scaling_cores, digits = 2) +``` + +For a given Stan model one should usually choose the number of chains and the +number of threads per chain to be equal to the number of (physical) cores one +wishes to use. Only if different chains of the model have relatively different +execution times (which they should not have, but it occurs sometimes in +practice), then one may consider the use of hyper-threading. Doing so will share +the resources evenly across all chains and whenever the fastest chain finishes, +the freed resources can be given to the still running chains. + +## Appendix + +### Fake data simulation + +```{r, eval=FALSE} +<> +``` + +### Poisson example model + +```{r, eval=FALSE} +<> +``` + +### Threading benchmark function + +```{r, eval=FALSE} +<> +``` + +### Munging of slowdown with chunking data + +```{r, eval=FALSE} +<> +``` diff -Nru r-cran-brms-2.16.3/man/add_criterion.Rd r-cran-brms-2.17.0/man/add_criterion.Rd --- r-cran-brms-2.16.3/man/add_criterion.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/add_criterion.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,72 +1,72 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo.R -\name{add_criterion} -\alias{add_criterion} -\alias{add_criterion.brmsfit} -\title{Add model fit criteria to model objects} -\usage{ -add_criterion(x, ...) - -\method{add_criterion}{brmsfit}( - x, - criterion, - model_name = NULL, - overwrite = FALSE, - file = NULL, - force_save = FALSE, - ... -) -} -\arguments{ -\item{x}{An \R object typically of class \code{brmsfit}.} - -\item{...}{Further arguments passed to the underlying -functions computing the model fit criteria.} - -\item{criterion}{Names of model fit criteria -to compute. Currently supported are \code{"loo"}, -\code{"waic"}, \code{"kfold"}, \code{"loo_subsample"}, -\code{"bayes_R2"} (Bayesian R-squared), -\code{"loo_R2"} (LOO-adjusted R-squared), and -\code{"marglik"} (log marginal likelihood).} - -\item{model_name}{Optional name of the model. If \code{NULL} -(the default) the name is taken from the call to \code{x}.} - -\item{overwrite}{Logical; Indicates if already stored fit -indices should be overwritten. Defaults to \code{FALSE}.} - -\item{file}{Either \code{NULL} or a character string. In the latter case, the -fitted model object including the newly added criterion values is saved via -\code{\link{saveRDS}} in a file named after the string supplied in -\code{file}. The \code{.rds} extension is added automatically. If \code{x} -was already stored in a file before, the file name will be reused -automatically (with a message) unless overwritten by \code{file}. In any -case, \code{file} only applies if new criteria were actually added via -\code{add_criterion} or if \code{force_save} was set to \code{TRUE}.} - -\item{force_save}{Logical; only relevant if \code{file} is specified and -ignored otherwise. If \code{TRUE}, the fitted model object will be saved -regardless of whether new criteria were added via \code{add_criterion}.} -} -\value{ -An object of the same class as \code{x}, but - with model fit criteria added for later usage. -} -\description{ -Add model fit criteria to model objects -} -\details{ -Functions \code{add_loo} and \code{add_waic} are aliases of - \code{add_criterion} with fixed values for the \code{criterion} argument. -} -\examples{ -\dontrun{ -fit <- brm(count ~ Trt, data = epilepsy) -# add both LOO and WAIC at once -fit <- add_criterion(fit, c("loo", "waic")) -print(fit$criteria$loo) -print(fit$criteria$waic) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo.R +\name{add_criterion} +\alias{add_criterion} +\alias{add_criterion.brmsfit} +\title{Add model fit criteria to model objects} +\usage{ +add_criterion(x, ...) + +\method{add_criterion}{brmsfit}( + x, + criterion, + model_name = NULL, + overwrite = FALSE, + file = NULL, + force_save = FALSE, + ... +) +} +\arguments{ +\item{x}{An \R object typically of class \code{brmsfit}.} + +\item{...}{Further arguments passed to the underlying +functions computing the model fit criteria.} + +\item{criterion}{Names of model fit criteria +to compute. Currently supported are \code{"loo"}, +\code{"waic"}, \code{"kfold"}, \code{"loo_subsample"}, +\code{"bayes_R2"} (Bayesian R-squared), +\code{"loo_R2"} (LOO-adjusted R-squared), and +\code{"marglik"} (log marginal likelihood).} + +\item{model_name}{Optional name of the model. If \code{NULL} +(the default) the name is taken from the call to \code{x}.} + +\item{overwrite}{Logical; Indicates if already stored fit +indices should be overwritten. Defaults to \code{FALSE}.} + +\item{file}{Either \code{NULL} or a character string. In the latter case, the +fitted model object including the newly added criterion values is saved via +\code{\link{saveRDS}} in a file named after the string supplied in +\code{file}. The \code{.rds} extension is added automatically. If \code{x} +was already stored in a file before, the file name will be reused +automatically (with a message) unless overwritten by \code{file}. In any +case, \code{file} only applies if new criteria were actually added via +\code{add_criterion} or if \code{force_save} was set to \code{TRUE}.} + +\item{force_save}{Logical; only relevant if \code{file} is specified and +ignored otherwise. If \code{TRUE}, the fitted model object will be saved +regardless of whether new criteria were added via \code{add_criterion}.} +} +\value{ +An object of the same class as \code{x}, but + with model fit criteria added for later usage. +} +\description{ +Add model fit criteria to model objects +} +\details{ +Functions \code{add_loo} and \code{add_waic} are aliases of + \code{add_criterion} with fixed values for the \code{criterion} argument. +} +\examples{ +\dontrun{ +fit <- brm(count ~ Trt, data = epilepsy) +# add both LOO and WAIC at once +fit <- add_criterion(fit, c("loo", "waic")) +print(fit$criteria$loo) +print(fit$criteria$waic) +} + +} diff -Nru r-cran-brms-2.16.3/man/add_ic.Rd r-cran-brms-2.17.0/man/add_ic.Rd --- r-cran-brms-2.16.3/man/add_ic.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/add_ic.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,42 +1,42 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo.R -\name{add_loo} -\alias{add_loo} -\alias{add_waic} -\alias{add_ic} -\alias{add_ic.brmsfit} -\alias{add_ic<-} -\title{Add model fit criteria to model objects} -\usage{ -add_loo(x, model_name = NULL, ...) - -add_waic(x, model_name = NULL, ...) - -add_ic(x, ...) - -\method{add_ic}{brmsfit}(x, ic = "loo", model_name = NULL, ...) - -add_ic(x, ...) <- value -} -\arguments{ -\item{x}{An \R object typically of class \code{brmsfit}.} - -\item{model_name}{Optional name of the model. If \code{NULL} -(the default) the name is taken from the call to \code{x}.} - -\item{...}{Further arguments passed to the underlying -functions computing the model fit criteria.} - -\item{ic, value}{Names of model fit criteria -to compute. Currently supported are \code{"loo"}, -\code{"waic"}, \code{"kfold"}, \code{"R2"} (R-squared), and -\code{"marglik"} (log marginal likelihood).} -} -\value{ -An object of the same class as \code{x}, but - with model fit criteria added for later usage. - Previously computed criterion objects will be overwritten. -} -\description{ -Deprecated aliases of \code{\link{add_criterion}}. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo.R +\name{add_loo} +\alias{add_loo} +\alias{add_waic} +\alias{add_ic} +\alias{add_ic.brmsfit} +\alias{add_ic<-} +\title{Add model fit criteria to model objects} +\usage{ +add_loo(x, model_name = NULL, ...) + +add_waic(x, model_name = NULL, ...) + +add_ic(x, ...) + +\method{add_ic}{brmsfit}(x, ic = "loo", model_name = NULL, ...) + +add_ic(x, ...) <- value +} +\arguments{ +\item{x}{An \R object typically of class \code{brmsfit}.} + +\item{model_name}{Optional name of the model. If \code{NULL} +(the default) the name is taken from the call to \code{x}.} + +\item{...}{Further arguments passed to the underlying +functions computing the model fit criteria.} + +\item{ic, value}{Names of model fit criteria +to compute. Currently supported are \code{"loo"}, +\code{"waic"}, \code{"kfold"}, \code{"R2"} (R-squared), and +\code{"marglik"} (log marginal likelihood).} +} +\value{ +An object of the same class as \code{x}, but + with model fit criteria added for later usage. + Previously computed criterion objects will be overwritten. +} +\description{ +Deprecated aliases of \code{\link{add_criterion}}. +} diff -Nru r-cran-brms-2.16.3/man/addition-terms.Rd r-cran-brms-2.17.0/man/addition-terms.Rd --- r-cran-brms-2.16.3/man/addition-terms.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/addition-terms.Rd 2022-04-08 11:57:41.000000000 +0000 @@ -1,149 +1,164 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ad.R -\name{addition-terms} -\alias{addition-terms} -\alias{resp_se} -\alias{resp_weights} -\alias{resp_trials} -\alias{resp_thres} -\alias{resp_cat} -\alias{resp_dec} -\alias{resp_cens} -\alias{resp_trunc} -\alias{resp_mi} -\alias{resp_index} -\alias{resp_rate} -\alias{resp_subset} -\alias{resp_vreal} -\alias{resp_vint} -\title{Additional Response Information} -\usage{ -resp_se(x, sigma = FALSE) - -resp_weights(x, scale = FALSE) - -resp_trials(x) - -resp_thres(x, gr = NA) - -resp_cat(x) - -resp_dec(x) - -resp_cens(x, y2 = NA) - -resp_trunc(lb = -Inf, ub = Inf) - -resp_mi(sdy = NA) - -resp_index(x) - -resp_rate(denom) - -resp_subset(x) - -resp_vreal(...) - -resp_vint(...) -} -\arguments{ -\item{x}{A vector; usually a variable defined in the data. Allowed values -depend on the function: \code{resp_se} and \code{resp_weights} require -positive numeric values. \code{resp_trials}, \code{resp_thres}, and -\code{resp_cat} require positive integers. \code{resp_dec} requires -\code{0} and \code{1}, or alternatively \code{'lower'} and \code{'upper'}. -\code{resp_subset} requires \code{0} and \code{1}, or alternatively -\code{FALSE} and \code{TRUE}. \code{resp_cens} requires \code{'left'}, -\code{'none'}, \code{'right'}, and \code{'interval'} (or equivalently -\code{-1}, \code{0}, \code{1}, and \code{2}) to indicate left, no, right, -or interval censoring. \code{resp_index} does not make any requirements -other than the value being unique for each observation.} - -\item{sigma}{Logical; Indicates whether the residual standard deviation -parameter \code{sigma} should be included in addition to the known -measurement error. Defaults to \code{FALSE} for backwards compatibility, -but setting it to \code{TRUE} is usually the better choice.} - -\item{scale}{Logical; Indicates whether weights should be scaled -so that the average weight equals one. Defaults to \code{FALSE}.} - -\item{gr}{A vector of grouping indicators.} - -\item{y2}{A vector specifying the upper bounds in interval censoring. -Will be ignored for non-interval censored observations. However, it -should NOT be \code{NA} even for non-interval censored observations to -avoid accidental exclusion of these observations.} - -\item{lb}{A numeric vector or single numeric value specifying -the lower truncation bound.} - -\item{ub}{A numeric vector or single numeric value specifying -the upper truncation bound.} - -\item{sdy}{Optional known measurement error of the response -treated as standard deviation. If specified, handles -measurement error and (completely) missing values -at the same time using the plausible-values-technique.} - -\item{denom}{A vector of positive numeric values specifying -the denominator values from which the response rates are computed.} - -\item{...}{For \code{resp_vreal}, vectors of real values. -For \code{resp_vint}, vectors of integer values. In Stan, -these variables will be named \code{vreal1}, \code{vreal2}, ..., -and \code{vint1}, \code{vint2}, ..., respectively.} -} -\value{ -A list of additional response information to be processed further - by \pkg{brms}. -} -\description{ -Provide additional information on the response variable -in \pkg{brms} models, such as censoring, truncation, or -known measurement error. -} -\details{ -These functions are almost solely useful when - called in formulas passed to the \pkg{brms} package. - Within formulas, the \code{resp_} prefix may be omitted. - More information is given in the 'Details' section - of \code{\link{brmsformula}}. -} -\examples{ -\dontrun{ -## Random effects meta-analysis -nstudies <- 20 -true_effects <- rnorm(nstudies, 0.5, 0.2) -sei <- runif(nstudies, 0.05, 0.3) -outcomes <- rnorm(nstudies, true_effects, sei) -data1 <- data.frame(outcomes, sei) -fit1 <- brm(outcomes | se(sei, sigma = TRUE) ~ 1, - data = data1) -summary(fit1) - -## Probit regression using the binomial family -n <- sample(1:10, 100, TRUE) # number of trials -success <- rbinom(100, size = n, prob = 0.4) -x <- rnorm(100) -data2 <- data.frame(n, success, x) -fit2 <- brm(success | trials(n) ~ x, data = data2, - family = binomial("probit")) -summary(fit2) - -## Survival regression modeling the time between the first -## and second recurrence of an infection in kidney patients. -fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), - data = kidney, family = lognormal()) -summary(fit3) - -## Poisson model with truncated counts -fit4 <- brm(count | trunc(ub = 104) ~ zBase * Trt, - data = epilepsy, family = poisson()) -summary(fit4) -} - -} -\seealso{ -\code{\link{brm}}, - \code{\link{brmsformula}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ad.R +\name{addition-terms} +\alias{addition-terms} +\alias{se} +\alias{weights} +\alias{trials} +\alias{thres} +\alias{cat} +\alias{dec} +\alias{cens} +\alias{trunc} +\alias{index} +\alias{rate} +\alias{subset} +\alias{vreal} +\alias{vint} +\alias{resp_se} +\alias{resp_weights} +\alias{resp_trials} +\alias{resp_thres} +\alias{resp_cat} +\alias{resp_dec} +\alias{resp_cens} +\alias{resp_trunc} +\alias{resp_mi} +\alias{resp_index} +\alias{resp_rate} +\alias{resp_subset} +\alias{resp_vreal} +\alias{resp_vint} +\title{Additional Response Information} +\usage{ +resp_se(x, sigma = FALSE) + +resp_weights(x, scale = FALSE) + +resp_trials(x) + +resp_thres(x, gr = NA) + +resp_cat(x) + +resp_dec(x) + +resp_cens(x, y2 = NA) + +resp_trunc(lb = -Inf, ub = Inf) + +resp_mi(sdy = NA) + +resp_index(x) + +resp_rate(denom) + +resp_subset(x) + +resp_vreal(...) + +resp_vint(...) +} +\arguments{ +\item{x}{A vector; usually a variable defined in the data. Allowed values +depend on the function: \code{resp_se} and \code{resp_weights} require +positive numeric values. \code{resp_trials}, \code{resp_thres}, and +\code{resp_cat} require positive integers. \code{resp_dec} requires +\code{0} and \code{1}, or alternatively \code{'lower'} and \code{'upper'}. +\code{resp_subset} requires \code{0} and \code{1}, or alternatively +\code{FALSE} and \code{TRUE}. \code{resp_cens} requires \code{'left'}, +\code{'none'}, \code{'right'}, and \code{'interval'} (or equivalently +\code{-1}, \code{0}, \code{1}, and \code{2}) to indicate left, no, right, +or interval censoring. \code{resp_index} does not make any requirements +other than the value being unique for each observation.} + +\item{sigma}{Logical; Indicates whether the residual standard deviation +parameter \code{sigma} should be included in addition to the known +measurement error. Defaults to \code{FALSE} for backwards compatibility, +but setting it to \code{TRUE} is usually the better choice.} + +\item{scale}{Logical; Indicates whether weights should be scaled +so that the average weight equals one. Defaults to \code{FALSE}.} + +\item{gr}{A vector of grouping indicators.} + +\item{y2}{A vector specifying the upper bounds in interval censoring. +Will be ignored for non-interval censored observations. However, it +should NOT be \code{NA} even for non-interval censored observations to +avoid accidental exclusion of these observations.} + +\item{lb}{A numeric vector or single numeric value specifying +the lower truncation bound.} + +\item{ub}{A numeric vector or single numeric value specifying +the upper truncation bound.} + +\item{sdy}{Optional known measurement error of the response +treated as standard deviation. If specified, handles +measurement error and (completely) missing values +at the same time using the plausible-values-technique.} + +\item{denom}{A vector of positive numeric values specifying +the denominator values from which the response rates are computed.} + +\item{...}{For \code{resp_vreal}, vectors of real values. +For \code{resp_vint}, vectors of integer values. In Stan, +these variables will be named \code{vreal1}, \code{vreal2}, ..., +and \code{vint1}, \code{vint2}, ..., respectively.} +} +\value{ +A list of additional response information to be processed further + by \pkg{brms}. +} +\description{ +Provide additional information on the response variable +in \pkg{brms} models, such as censoring, truncation, or +known measurement error. Detailed documentation on the use +of each of these functions can be found in the Details section +of \code{\link{brmsformula}} (under "Additional response information"). +} +\details{ +These functions are almost solely useful when + called in formulas passed to the \pkg{brms} package. + Within formulas, the \code{resp_} prefix may be omitted. + More information is given in the 'Details' section + of \code{\link{brmsformula}} (under "Additional response information"). +} +\examples{ +\dontrun{ +## Random effects meta-analysis +nstudies <- 20 +true_effects <- rnorm(nstudies, 0.5, 0.2) +sei <- runif(nstudies, 0.05, 0.3) +outcomes <- rnorm(nstudies, true_effects, sei) +data1 <- data.frame(outcomes, sei) +fit1 <- brm(outcomes | se(sei, sigma = TRUE) ~ 1, + data = data1) +summary(fit1) + +## Probit regression using the binomial family +n <- sample(1:10, 100, TRUE) # number of trials +success <- rbinom(100, size = n, prob = 0.4) +x <- rnorm(100) +data2 <- data.frame(n, success, x) +fit2 <- brm(success | trials(n) ~ x, data = data2, + family = binomial("probit")) +summary(fit2) + +## Survival regression modeling the time between the first +## and second recurrence of an infection in kidney patients. +fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), + data = kidney, family = lognormal()) +summary(fit3) + +## Poisson model with truncated counts +fit4 <- brm(count | trunc(ub = 104) ~ zBase * Trt, + data = epilepsy, family = poisson()) +summary(fit4) +} + +} +\seealso{ +\code{\link{brm}}, + \code{\link{brmsformula}} +} diff -Nru r-cran-brms-2.16.3/man/add_rstan_model.Rd r-cran-brms-2.17.0/man/add_rstan_model.Rd --- r-cran-brms-2.16.3/man/add_rstan_model.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/add_rstan_model.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,23 +1,23 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-helpers.R -\name{add_rstan_model} -\alias{add_rstan_model} -\title{Add compiled \pkg{rstan} models to \code{brmsfit} objects} -\usage{ -add_rstan_model(x, overwrite = FALSE) -} -\arguments{ -\item{x}{A \code{brmsfit} object to be updated.} - -\item{overwrite}{Logical. If \code{TRUE}, overwrite any existing -\code{\link[rstan:stanmodel-class]{stanmodel}}. Defaults to \code{FALSE}.} -} -\value{ -A (possibly updated) \code{brmsfit} object. -} -\description{ -Compile a \code{\link[rstan:stanmodel-class]{stanmodel}} and add -it to a \code{brmsfit} object. This enables some advanced functionality -of \pkg{rstan}, most notably \code{\link[rstan:log_prob]{log_prob}} -and friends, to be used with brms models fitted with other Stan backends. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-helpers.R +\name{add_rstan_model} +\alias{add_rstan_model} +\title{Add compiled \pkg{rstan} models to \code{brmsfit} objects} +\usage{ +add_rstan_model(x, overwrite = FALSE) +} +\arguments{ +\item{x}{A \code{brmsfit} object to be updated.} + +\item{overwrite}{Logical. If \code{TRUE}, overwrite any existing +\code{\link[rstan:stanmodel-class]{stanmodel}}. Defaults to \code{FALSE}.} +} +\value{ +A (possibly updated) \code{brmsfit} object. +} +\description{ +Compile a \code{\link[rstan:stanmodel-class]{stanmodel}} and add +it to a \code{brmsfit} object. This enables some advanced functionality +of \pkg{rstan}, most notably \code{\link[rstan:log_prob]{log_prob}} +and friends, to be used with brms models fitted with other Stan backends. +} diff -Nru r-cran-brms-2.16.3/man/arma.Rd r-cran-brms-2.17.0/man/arma.Rd --- r-cran-brms-2.16.3/man/arma.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/arma.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,54 +1,54 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ac.R -\name{arma} -\alias{arma} -\title{Set up ARMA(p,q) correlation structures} -\usage{ -arma(time = NA, gr = NA, p = 1, q = 1, cov = FALSE) -} -\arguments{ -\item{time}{An optional time variable specifying the time ordering -of the observations. By default, the existing order of the observations -in the data is used.} - -\item{gr}{An optional grouping variable. If specified, the correlation -structure is assumed to apply only to observations within the same grouping -level.} - -\item{p}{A non-negative integer specifying the autoregressive (AR) -order of the ARMA structure. Default is \code{1}.} - -\item{q}{A non-negative integer specifying the moving average (MA) -order of the ARMA structure. Default is \code{1}.} - -\item{cov}{A flag indicating whether ARMA effects should be estimated by -means of residual covariance matrices. This is currently only possible for -stationary ARMA effects of order 1. If the model family does not have -natural residuals, latent residuals are added automatically. If -\code{FALSE} (the default), a regression formulation is used that is -considerably faster and allows for ARMA effects of order higher than 1 but -is only available for \code{gaussian} models and some of its -generalizations.} -} -\value{ -An object of class \code{'arma_term'}, which is a list - of arguments to be interpreted by the formula - parsing functions of \pkg{brms}. -} -\description{ -Set up an autoregressive moving average (ARMA) term of order (p, q) in -\pkg{brms}. The function does not evaluate its arguments -- it exists purely -to help set up a model with ARMA terms. -} -\examples{ -\dontrun{ -data("LakeHuron") -LakeHuron <- as.data.frame(LakeHuron) -fit <- brm(x ~ arma(p = 2, q = 1), data = LakeHuron) -summary(fit) -} - -} -\seealso{ -\code{\link{autocor-terms}}, \code{\link{ar}}, \code{\link{ma}}, -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ac.R +\name{arma} +\alias{arma} +\title{Set up ARMA(p,q) correlation structures} +\usage{ +arma(time = NA, gr = NA, p = 1, q = 1, cov = FALSE) +} +\arguments{ +\item{time}{An optional time variable specifying the time ordering +of the observations. By default, the existing order of the observations +in the data is used.} + +\item{gr}{An optional grouping variable. If specified, the correlation +structure is assumed to apply only to observations within the same grouping +level.} + +\item{p}{A non-negative integer specifying the autoregressive (AR) +order of the ARMA structure. Default is \code{1}.} + +\item{q}{A non-negative integer specifying the moving average (MA) +order of the ARMA structure. Default is \code{1}.} + +\item{cov}{A flag indicating whether ARMA effects should be estimated by +means of residual covariance matrices. This is currently only possible for +stationary ARMA effects of order 1. If the model family does not have +natural residuals, latent residuals are added automatically. If +\code{FALSE} (the default), a regression formulation is used that is +considerably faster and allows for ARMA effects of order higher than 1 but +is only available for \code{gaussian} models and some of its +generalizations.} +} +\value{ +An object of class \code{'arma_term'}, which is a list + of arguments to be interpreted by the formula + parsing functions of \pkg{brms}. +} +\description{ +Set up an autoregressive moving average (ARMA) term of order (p, q) in +\pkg{brms}. The function does not evaluate its arguments -- it exists purely +to help set up a model with ARMA terms. +} +\examples{ +\dontrun{ +data("LakeHuron") +LakeHuron <- as.data.frame(LakeHuron) +fit <- brm(x ~ arma(p = 2, q = 1), data = LakeHuron) +summary(fit) +} + +} +\seealso{ +\code{\link{autocor-terms}}, \code{\link{ar}}, \code{\link{ma}}, +} diff -Nru r-cran-brms-2.16.3/man/ar.Rd r-cran-brms-2.17.0/man/ar.Rd --- r-cran-brms-2.16.3/man/ar.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/ar.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,51 +1,51 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ac.R -\name{ar} -\alias{ar} -\title{Set up AR(p) correlation structures} -\usage{ -ar(time = NA, gr = NA, p = 1, cov = FALSE) -} -\arguments{ -\item{time}{An optional time variable specifying the time ordering -of the observations. By default, the existing order of the observations -in the data is used.} - -\item{gr}{An optional grouping variable. If specified, the correlation -structure is assumed to apply only to observations within the same grouping -level.} - -\item{p}{A non-negative integer specifying the autoregressive (AR) -order of the ARMA structure. Default is \code{1}.} - -\item{cov}{A flag indicating whether ARMA effects should be estimated by -means of residual covariance matrices. This is currently only possible for -stationary ARMA effects of order 1. If the model family does not have -natural residuals, latent residuals are added automatically. If -\code{FALSE} (the default), a regression formulation is used that is -considerably faster and allows for ARMA effects of order higher than 1 but -is only available for \code{gaussian} models and some of its -generalizations.} -} -\value{ -An object of class \code{'arma_term'}, which is a list - of arguments to be interpreted by the formula - parsing functions of \pkg{brms}. -} -\description{ -Set up an autoregressive (AR) term of order p in \pkg{brms}. The function -does not evaluate its arguments -- it exists purely to help set up a model -with AR terms. -} -\examples{ -\dontrun{ -data("LakeHuron") -LakeHuron <- as.data.frame(LakeHuron) -fit <- brm(x ~ ar(p = 2), data = LakeHuron) -summary(fit) -} - -} -\seealso{ -\code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ma}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ac.R +\name{ar} +\alias{ar} +\title{Set up AR(p) correlation structures} +\usage{ +ar(time = NA, gr = NA, p = 1, cov = FALSE) +} +\arguments{ +\item{time}{An optional time variable specifying the time ordering +of the observations. By default, the existing order of the observations +in the data is used.} + +\item{gr}{An optional grouping variable. If specified, the correlation +structure is assumed to apply only to observations within the same grouping +level.} + +\item{p}{A non-negative integer specifying the autoregressive (AR) +order of the ARMA structure. Default is \code{1}.} + +\item{cov}{A flag indicating whether ARMA effects should be estimated by +means of residual covariance matrices. This is currently only possible for +stationary ARMA effects of order 1. If the model family does not have +natural residuals, latent residuals are added automatically. If +\code{FALSE} (the default), a regression formulation is used that is +considerably faster and allows for ARMA effects of order higher than 1 but +is only available for \code{gaussian} models and some of its +generalizations.} +} +\value{ +An object of class \code{'arma_term'}, which is a list + of arguments to be interpreted by the formula + parsing functions of \pkg{brms}. +} +\description{ +Set up an autoregressive (AR) term of order p in \pkg{brms}. The function +does not evaluate its arguments -- it exists purely to help set up a model +with AR terms. +} +\examples{ +\dontrun{ +data("LakeHuron") +LakeHuron <- as.data.frame(LakeHuron) +fit <- brm(x ~ ar(p = 2), data = LakeHuron) +summary(fit) +} + +} +\seealso{ +\code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ma}} +} diff -Nru r-cran-brms-2.16.3/man/as.data.frame.brmsfit.Rd r-cran-brms-2.17.0/man/as.data.frame.brmsfit.Rd --- r-cran-brms-2.16.3/man/as.data.frame.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/as.data.frame.brmsfit.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,57 +1,57 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior.R -\name{as.data.frame.brmsfit} -\alias{as.data.frame.brmsfit} -\alias{as.matrix.brmsfit} -\alias{as.array.brmsfit} -\title{Extract Posterior Draws} -\usage{ -\method{as.data.frame}{brmsfit}( - x, - row.names = NULL, - optional = TRUE, - pars = NA, - variable = NULL, - draw = NULL, - subset = NULL, - ... -) - -\method{as.matrix}{brmsfit}(x, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) - -\method{as.array}{brmsfit}(x, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) -} -\arguments{ -\item{x}{A \code{brmsfit} object or another \R object for which -the methods are defined.} - -\item{row.names, optional}{Unused and only added for consistency with -the \code{\link[base:as.data.frame]{as.data.frame}} generic.} - -\item{pars}{Deprecated alias of \code{variable}. For reasons of backwards -compatibility, \code{pars} is interpreted as a vector of regular -expressions by default unless \code{fixed = TRUE} is specified.} - -\item{variable}{A character vector providing the variables to extract. -By default, all variables are extracted.} - -\item{draw}{The draw indices to be select. Subsetting draw indices will lead -to an automatic merging of chains.} - -\item{subset}{Deprecated alias of \code{draw}.} - -\item{...}{Further arguments to be passed to the corresponding -\code{\link[brms:draws-brms]{as_draws_*}} methods as well as to -\code{\link[posterior:subset_draws]{subset_draws}}.} -} -\value{ -A data.frame, matrix, or array containing the posterior draws. -} -\description{ -Extract posterior draws in conventional formats -as data.frames, matrices, or arrays. -} -\seealso{ -\code{\link[brms:draws-brms]{as_draws}}, - \code{\link[posterior:subset_draws]{subset_draws}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior.R +\name{as.data.frame.brmsfit} +\alias{as.data.frame.brmsfit} +\alias{as.matrix.brmsfit} +\alias{as.array.brmsfit} +\title{Extract Posterior Draws} +\usage{ +\method{as.data.frame}{brmsfit}( + x, + row.names = NULL, + optional = TRUE, + pars = NA, + variable = NULL, + draw = NULL, + subset = NULL, + ... +) + +\method{as.matrix}{brmsfit}(x, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) + +\method{as.array}{brmsfit}(x, pars = NA, variable = NULL, draw = NULL, subset = NULL, ...) +} +\arguments{ +\item{x}{A \code{brmsfit} object or another \R object for which +the methods are defined.} + +\item{row.names, optional}{Unused and only added for consistency with +the \code{\link[base:as.data.frame]{as.data.frame}} generic.} + +\item{pars}{Deprecated alias of \code{variable}. For reasons of backwards +compatibility, \code{pars} is interpreted as a vector of regular +expressions by default unless \code{fixed = TRUE} is specified.} + +\item{variable}{A character vector providing the variables to extract. +By default, all variables are extracted.} + +\item{draw}{The draw indices to be select. Subsetting draw indices will lead +to an automatic merging of chains.} + +\item{subset}{Deprecated alias of \code{draw}.} + +\item{...}{Further arguments to be passed to the corresponding +\code{\link[brms:draws-brms]{as_draws_*}} methods as well as to +\code{\link[posterior:subset_draws]{subset_draws}}.} +} +\value{ +A data.frame, matrix, or array containing the posterior draws. +} +\description{ +Extract posterior draws in conventional formats +as data.frames, matrices, or arrays. +} +\seealso{ +\code{\link[brms:draws-brms]{as_draws}}, + \code{\link[posterior:subset_draws]{subset_draws}} +} diff -Nru r-cran-brms-2.16.3/man/as.mcmc.brmsfit.Rd r-cran-brms-2.17.0/man/as.mcmc.brmsfit.Rd --- r-cran-brms-2.16.3/man/as.mcmc.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/as.mcmc.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,42 +1,42 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_samples.R -\name{as.mcmc.brmsfit} -\alias{as.mcmc.brmsfit} -\alias{as.mcmc} -\title{Extract posterior samples for use with the \pkg{coda} package} -\usage{ -\method{as.mcmc}{brmsfit}( - x, - pars = NA, - fixed = FALSE, - combine_chains = FALSE, - inc_warmup = FALSE, - ... -) -} -\arguments{ -\item{x}{An \code{R} object typically of class \code{brmsfit}} - -\item{pars}{Names of parameters for which posterior samples -should be returned, as given by a character vector or regular expressions. -By default, all posterior samples of all parameters are extracted.} - -\item{fixed}{Indicates whether parameter names -should be matched exactly (\code{TRUE}) or treated as -regular expressions (\code{FALSE}). Default is \code{FALSE}.} - -\item{combine_chains}{Indicates whether chains should be combined.} - -\item{inc_warmup}{Indicates if the warmup samples should be included. -Default is \code{FALSE}. Warmup samples are used to tune the -parameters of the sampling algorithm and should not be analyzed.} - -\item{...}{currently unused} -} -\value{ -If \code{combine_chains = TRUE} an \code{mcmc} object is returned. - If \code{combine_chains = FALSE} an \code{mcmc.list} object is returned. -} -\description{ -Extract posterior samples for use with the \pkg{coda} package -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_samples.R +\name{as.mcmc.brmsfit} +\alias{as.mcmc.brmsfit} +\alias{as.mcmc} +\title{Extract posterior samples for use with the \pkg{coda} package} +\usage{ +\method{as.mcmc}{brmsfit}( + x, + pars = NA, + fixed = FALSE, + combine_chains = FALSE, + inc_warmup = FALSE, + ... +) +} +\arguments{ +\item{x}{An \code{R} object typically of class \code{brmsfit}} + +\item{pars}{Names of parameters for which posterior samples +should be returned, as given by a character vector or regular expressions. +By default, all posterior samples of all parameters are extracted.} + +\item{fixed}{Indicates whether parameter names +should be matched exactly (\code{TRUE}) or treated as +regular expressions (\code{FALSE}). Default is \code{FALSE}.} + +\item{combine_chains}{Indicates whether chains should be combined.} + +\item{inc_warmup}{Indicates if the warmup samples should be included. +Default is \code{FALSE}. Warmup samples are used to tune the +parameters of the sampling algorithm and should not be analyzed.} + +\item{...}{currently unused} +} +\value{ +If \code{combine_chains = TRUE} an \code{mcmc} object is returned. + If \code{combine_chains = FALSE} an \code{mcmc.list} object is returned. +} +\description{ +Extract posterior samples for use with the \pkg{coda} package +} diff -Nru r-cran-brms-2.16.3/man/AsymLaplace.Rd r-cran-brms-2.17.0/man/AsymLaplace.Rd --- r-cran-brms-2.16.3/man/AsymLaplace.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/AsymLaplace.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,62 +1,62 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{AsymLaplace} -\alias{AsymLaplace} -\alias{dasym_laplace} -\alias{pasym_laplace} -\alias{qasym_laplace} -\alias{rasym_laplace} -\title{The Asymmetric Laplace Distribution} -\usage{ -dasym_laplace(x, mu = 0, sigma = 1, quantile = 0.5, log = FALSE) - -pasym_laplace( - q, - mu = 0, - sigma = 1, - quantile = 0.5, - lower.tail = TRUE, - log.p = FALSE -) - -qasym_laplace( - p, - mu = 0, - sigma = 1, - quantile = 0.5, - lower.tail = TRUE, - log.p = FALSE -) - -rasym_laplace(n, mu = 0, sigma = 1, quantile = 0.5) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{mu}{Vector of locations.} - -\item{sigma}{Vector of scales.} - -\item{quantile}{Asymmetry parameter corresponding to quantiles -in quantile regression (hence the name).} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{p}{Vector of probabilities.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, quantile function and random generation -for the asymmetric Laplace distribution with location \code{mu}, -scale \code{sigma} and asymmetry parameter \code{quantile}. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{AsymLaplace} +\alias{AsymLaplace} +\alias{dasym_laplace} +\alias{pasym_laplace} +\alias{qasym_laplace} +\alias{rasym_laplace} +\title{The Asymmetric Laplace Distribution} +\usage{ +dasym_laplace(x, mu = 0, sigma = 1, quantile = 0.5, log = FALSE) + +pasym_laplace( + q, + mu = 0, + sigma = 1, + quantile = 0.5, + lower.tail = TRUE, + log.p = FALSE +) + +qasym_laplace( + p, + mu = 0, + sigma = 1, + quantile = 0.5, + lower.tail = TRUE, + log.p = FALSE +) + +rasym_laplace(n, mu = 0, sigma = 1, quantile = 0.5) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{mu}{Vector of locations.} + +\item{sigma}{Vector of scales.} + +\item{quantile}{Asymmetry parameter corresponding to quantiles +in quantile regression (hence the name).} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{p}{Vector of probabilities.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, quantile function and random generation +for the asymmetric Laplace distribution with location \code{mu}, +scale \code{sigma} and asymmetry parameter \code{quantile}. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} diff -Nru r-cran-brms-2.16.3/man/autocor.brmsfit.Rd r-cran-brms-2.17.0/man/autocor.brmsfit.Rd --- r-cran-brms-2.16.3/man/autocor.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/autocor.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,26 +1,26 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{autocor.brmsfit} -\alias{autocor.brmsfit} -\alias{autocor} -\title{(Deprecated) Extract Autocorrelation Objects} -\usage{ -\method{autocor}{brmsfit}(object, resp = NULL, ...) - -autocor(object, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{...}{Currently unused.} -} -\value{ -A \code{cor_brms} object or a list of such objects for multivariate - models. Not supported for models fitted with brms 2.11.1 or higher. -} -\description{ -(Deprecated) Extract Autocorrelation Objects -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{autocor.brmsfit} +\alias{autocor.brmsfit} +\alias{autocor} +\title{(Deprecated) Extract Autocorrelation Objects} +\usage{ +\method{autocor}{brmsfit}(object, resp = NULL, ...) + +autocor(object, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{...}{Currently unused.} +} +\value{ +A \code{cor_brms} object or a list of such objects for multivariate + models. Not supported for models fitted with brms 2.11.1 or higher. +} +\description{ +(Deprecated) Extract Autocorrelation Objects +} diff -Nru r-cran-brms-2.16.3/man/autocor-terms.Rd r-cran-brms-2.17.0/man/autocor-terms.Rd --- r-cran-brms-2.16.3/man/autocor-terms.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/autocor-terms.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,36 +1,36 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ac.R -\name{autocor-terms} -\alias{autocor-terms} -\title{Autocorrelation structures} -\description{ -Specify autocorrelation terms in \pkg{brms} models. Currently supported terms -are \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, -\code{\link{cosy}}, \code{\link{sar}}, \code{\link{car}}, and -\code{\link{fcor}}. Terms can be directly specified within the formula, or -passed to the \code{autocor} argument of \code{\link{brmsformula}} in the -form of a one-sided formula. For deprecated ways of specifying -autocorrelation terms, see \code{\link{cor_brms}}. -} -\details{ -The autocor term functions are almost solely useful when called in -formulas passed to the \pkg{brms} package. They do not evaluate its -arguments -- but exist purely to help set up a model with autocorrelation -terms. -} -\examples{ -# specify autocor terms within the formula -y ~ x + arma(p = 1, q = 1) + car(M) - -# specify autocor terms in the 'autocor' argument -bf(y ~ x, autocor = ~ arma(p = 1, q = 1) + car(M)) - -# specify autocor terms via 'acformula' -bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(M)) -} -\seealso{ -\code{\link{brmsformula}}, \code{\link{acformula}}, - \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, - \code{\link{cosy}}, \code{\link{sar}}, \code{\link{car}}, - \code{\link{fcor}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ac.R +\name{autocor-terms} +\alias{autocor-terms} +\title{Autocorrelation structures} +\description{ +Specify autocorrelation terms in \pkg{brms} models. Currently supported terms +are \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, +\code{\link{cosy}}, \code{\link{sar}}, \code{\link{car}}, and +\code{\link{fcor}}. Terms can be directly specified within the formula, or +passed to the \code{autocor} argument of \code{\link{brmsformula}} in the +form of a one-sided formula. For deprecated ways of specifying +autocorrelation terms, see \code{\link{cor_brms}}. +} +\details{ +The autocor term functions are almost solely useful when called in +formulas passed to the \pkg{brms} package. They do not evaluate its +arguments -- but exist purely to help set up a model with autocorrelation +terms. +} +\examples{ +# specify autocor terms within the formula +y ~ x + arma(p = 1, q = 1) + car(M) + +# specify autocor terms in the 'autocor' argument +bf(y ~ x, autocor = ~ arma(p = 1, q = 1) + car(M)) + +# specify autocor terms via 'acformula' +bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(M)) +} +\seealso{ +\code{\link{brmsformula}}, \code{\link{acformula}}, + \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, + \code{\link{cosy}}, \code{\link{sar}}, \code{\link{car}}, + \code{\link{fcor}} +} diff -Nru r-cran-brms-2.16.3/man/bayes_factor.brmsfit.Rd r-cran-brms-2.17.0/man/bayes_factor.brmsfit.Rd --- r-cran-brms-2.16.3/man/bayes_factor.brmsfit.Rd 2021-02-10 15:31:40.000000000 +0000 +++ r-cran-brms-2.17.0/man/bayes_factor.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,72 +1,72 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bridgesampling.R -\name{bayes_factor.brmsfit} -\alias{bayes_factor.brmsfit} -\alias{bayes_factor} -\title{Bayes Factors from Marginal Likelihoods} -\usage{ -\method{bayes_factor}{brmsfit}(x1, x2, log = FALSE, ...) -} -\arguments{ -\item{x1}{A \code{brmsfit} object} - -\item{x2}{Another \code{brmsfit} object based on the same responses.} - -\item{log}{Report Bayes factors on the log-scale?} - -\item{...}{Additional arguments passed to -\code{\link[brms:bridge_sampler.brmsfit]{bridge_sampler}}.} -} -\description{ -Compute Bayes factors from marginal likelihoods. -} -\details{ -Computing the marginal likelihood requires samples - of all variables defined in Stan's \code{parameters} block - to be saved. Otherwise \code{bayes_factor} cannot be computed. - Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, - if you are planning to apply \code{bayes_factor} to your models. - - The computation of Bayes factors based on bridge sampling requires - a lot more posterior samples than usual. A good conservative - rule of thumb is perhaps 10-fold more samples (read: the default of 4000 - samples may not be enough in many cases). If not enough posterior - samples are provided, the bridge sampling algorithm tends to be unstable, - leading to considerably different results each time it is run. - We thus recommend running \code{bayes_factor} - multiple times to check the stability of the results. - - More details are provided under - \code{\link[bridgesampling:bf]{bridgesampling::bayes_factor}}. -} -\examples{ -\dontrun{ -# model with the treatment effect -fit1 <- brm( - count ~ zAge + zBase + Trt, - data = epilepsy, family = negbinomial(), - prior = prior(normal(0, 1), class = b), - save_all_pars = TRUE -) -summary(fit1) - -# model without the treatment effect -fit2 <- brm( - count ~ zAge + zBase, - data = epilepsy, family = negbinomial(), - prior = prior(normal(0, 1), class = b), - save_all_pars = TRUE -) -summary(fit2) - -# compute the bayes factor -bayes_factor(fit1, fit2) -} - -} -\seealso{ -\code{ - \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, - \link[brms:post_prob.brmsfit]{post_prob} -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bridgesampling.R +\name{bayes_factor.brmsfit} +\alias{bayes_factor.brmsfit} +\alias{bayes_factor} +\title{Bayes Factors from Marginal Likelihoods} +\usage{ +\method{bayes_factor}{brmsfit}(x1, x2, log = FALSE, ...) +} +\arguments{ +\item{x1}{A \code{brmsfit} object} + +\item{x2}{Another \code{brmsfit} object based on the same responses.} + +\item{log}{Report Bayes factors on the log-scale?} + +\item{...}{Additional arguments passed to +\code{\link[brms:bridge_sampler.brmsfit]{bridge_sampler}}.} +} +\description{ +Compute Bayes factors from marginal likelihoods. +} +\details{ +Computing the marginal likelihood requires samples + of all variables defined in Stan's \code{parameters} block + to be saved. Otherwise \code{bayes_factor} cannot be computed. + Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, + if you are planning to apply \code{bayes_factor} to your models. + + The computation of Bayes factors based on bridge sampling requires + a lot more posterior samples than usual. A good conservative + rule of thumb is perhaps 10-fold more samples (read: the default of 4000 + samples may not be enough in many cases). If not enough posterior + samples are provided, the bridge sampling algorithm tends to be unstable, + leading to considerably different results each time it is run. + We thus recommend running \code{bayes_factor} + multiple times to check the stability of the results. + + More details are provided under + \code{\link[bridgesampling:bf]{bridgesampling::bayes_factor}}. +} +\examples{ +\dontrun{ +# model with the treatment effect +fit1 <- brm( + count ~ zAge + zBase + Trt, + data = epilepsy, family = negbinomial(), + prior = prior(normal(0, 1), class = b), + save_all_pars = TRUE +) +summary(fit1) + +# model without the treatment effect +fit2 <- brm( + count ~ zAge + zBase, + data = epilepsy, family = negbinomial(), + prior = prior(normal(0, 1), class = b), + save_all_pars = TRUE +) +summary(fit2) + +# compute the bayes factor +bayes_factor(fit1, fit2) +} + +} +\seealso{ +\code{ + \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, + \link[brms:post_prob.brmsfit]{post_prob} +} +} diff -Nru r-cran-brms-2.16.3/man/bayes_R2.brmsfit.Rd r-cran-brms-2.17.0/man/bayes_R2.brmsfit.Rd --- r-cran-brms-2.16.3/man/bayes_R2.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/bayes_R2.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,70 +1,70 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bayes_R2.R -\name{bayes_R2.brmsfit} -\alias{bayes_R2.brmsfit} -\alias{bayes_R2} -\title{Compute a Bayesian version of R-squared for regression models} -\usage{ -\method{bayes_R2}{brmsfit}( - object, - resp = NULL, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{...}{Further arguments passed to -\code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}, -which is used in the computation of the R-squared values.} -} -\value{ -If \code{summary = TRUE}, an M x C matrix is returned - (M = number of response variables and c = \code{length(probs) + 2}) - containing summary statistics of the Bayesian R-squared values. - If \code{summary = FALSE}, the posterior draws of the Bayesian - R-squared values are returned in an S x M matrix (S is the number of draws). -} -\description{ -Compute a Bayesian version of R-squared for regression models -} -\details{ -For an introduction to the approach, see Gelman et al. (2018) - and \url{https://github.com/jgabry/bayes_R2/}. -} -\examples{ -\dontrun{ -fit <- brm(mpg ~ wt + cyl, data = mtcars) -summary(fit) -bayes_R2(fit) - -# compute R2 with new data -nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) -bayes_R2(fit, newdata = nd) -} - -} -\references{ -Andrew Gelman, Ben Goodrich, Jonah Gabry & Aki Vehtari. (2018). - R-squared for Bayesian regression models, \emph{The American Statistician}. - \code{10.1080/00031305.2018.1549100} (Preprint available at - \url{https://stat.columbia.edu/~gelman/research/published/bayes_R2_v3.pdf}) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayes_R2.R +\name{bayes_R2.brmsfit} +\alias{bayes_R2.brmsfit} +\alias{bayes_R2} +\title{Compute a Bayesian version of R-squared for regression models} +\usage{ +\method{bayes_R2}{brmsfit}( + object, + resp = NULL, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{...}{Further arguments passed to +\code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}, +which is used in the computation of the R-squared values.} +} +\value{ +If \code{summary = TRUE}, an M x C matrix is returned + (M = number of response variables and c = \code{length(probs) + 2}) + containing summary statistics of the Bayesian R-squared values. + If \code{summary = FALSE}, the posterior draws of the Bayesian + R-squared values are returned in an S x M matrix (S is the number of draws). +} +\description{ +Compute a Bayesian version of R-squared for regression models +} +\details{ +For an introduction to the approach, see Gelman et al. (2018) + and \url{https://github.com/jgabry/bayes_R2/}. +} +\examples{ +\dontrun{ +fit <- brm(mpg ~ wt + cyl, data = mtcars) +summary(fit) +bayes_R2(fit) + +# compute R2 with new data +nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) +bayes_R2(fit, newdata = nd) +} + +} +\references{ +Andrew Gelman, Ben Goodrich, Jonah Gabry & Aki Vehtari. (2018). + R-squared for Bayesian regression models, \emph{The American Statistician}. + \code{10.1080/00031305.2018.1549100} (Preprint available at + \url{https://stat.columbia.edu/~gelman/research/published/bayes_R2_v3.pdf}) +} diff -Nru r-cran-brms-2.16.3/man/BetaBinomial.Rd r-cran-brms-2.17.0/man/BetaBinomial.Rd --- r-cran-brms-2.16.3/man/BetaBinomial.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-brms-2.17.0/man/BetaBinomial.Rd 2022-04-08 12:23:23.000000000 +0000 @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{BetaBinomial} +\alias{BetaBinomial} +\alias{dbeta_binomial} +\alias{pbeta_binomial} +\alias{rbeta_binomial} +\title{The Beta-binomial Distribution} +\usage{ +dbeta_binomial(x, size, mu, phi, log = FALSE) + +pbeta_binomial(q, size, mu, phi, lower.tail = TRUE, log.p = FALSE) + +rbeta_binomial(n, size, mu, phi) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{size}{Vector of number of trials (zero or more).} + +\item{mu}{Vector of means.} + +\item{phi}{Vector of precisions.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Cumulative density & mass functions, and random number generation for the +Beta-binomial distribution using the following re-parameterisation of the +\href{https://mc-stan.org/docs/2_29/functions-reference/beta-binomial-distribution.html}{Stan +Beta-binomial definition}: +\itemize{ + \item{\code{mu = alpha * beta}} mean probability of trial success. + \item{\code{phi = (1 - mu) * beta}} precision or over-dispersion, component. +} +} diff -Nru r-cran-brms-2.16.3/man/bridge_sampler.brmsfit.Rd r-cran-brms-2.17.0/man/bridge_sampler.brmsfit.Rd --- r-cran-brms-2.16.3/man/bridge_sampler.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/bridge_sampler.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,71 +1,71 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bridgesampling.R -\name{bridge_sampler.brmsfit} -\alias{bridge_sampler.brmsfit} -\alias{bridge_sampler} -\title{Log Marginal Likelihood via Bridge Sampling} -\usage{ -\method{bridge_sampler}{brmsfit}(samples, ...) -} -\arguments{ -\item{samples}{A \code{brmsfit} object.} - -\item{...}{Additional arguments passed to -\code{\link[bridgesampling:bridge_sampler]{bridge_sampler.stanfit}}.} -} -\description{ -Computes log marginal likelihood via bridge sampling, -which can be used in the computation of bayes factors -and posterior model probabilities. -The \code{brmsfit} method is just a thin wrapper around -the corresponding method for \code{stanfit} objects. -} -\details{ -Computing the marginal likelihood requires samples of all variables - defined in Stan's \code{parameters} block to be saved. Otherwise - \code{bridge_sampler} cannot be computed. Thus, please set \code{save_pars - = save_pars(all = TRUE)} in the call to \code{brm}, if you are planning to - apply \code{bridge_sampler} to your models. - - The computation of marginal likelihoods based on bridge sampling requires - a lot more posterior draws than usual. A good conservative - rule of thump is perhaps 10-fold more draws (read: the default of 4000 - draws may not be enough in many cases). If not enough posterior - draws are provided, the bridge sampling algorithm tends to be - unstable leading to considerably different results each time it is run. - We thus recommend running \code{bridge_sampler} - multiple times to check the stability of the results. - - More details are provided under - \code{\link[bridgesampling:bridge_sampler]{bridgesampling::bridge_sampler}}. -} -\examples{ -\dontrun{ -# model with the treatment effect -fit1 <- brm( - count ~ zAge + zBase + Trt, - data = epilepsy, family = negbinomial(), - prior = prior(normal(0, 1), class = b), - save_pars = save_pars(all = TRUE) -) -summary(fit1) -bridge_sampler(fit1) - -# model without the treatment effect -fit2 <- brm( - count ~ zAge + zBase, - data = epilepsy, family = negbinomial(), - prior = prior(normal(0, 1), class = b), - save_pars = save_pars(all = TRUE) -) -summary(fit2) -bridge_sampler(fit2) -} - -} -\seealso{ -\code{ - \link[brms:bayes_factor.brmsfit]{bayes_factor}, - \link[brms:post_prob.brmsfit]{post_prob} -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bridgesampling.R +\name{bridge_sampler.brmsfit} +\alias{bridge_sampler.brmsfit} +\alias{bridge_sampler} +\title{Log Marginal Likelihood via Bridge Sampling} +\usage{ +\method{bridge_sampler}{brmsfit}(samples, ...) +} +\arguments{ +\item{samples}{A \code{brmsfit} object.} + +\item{...}{Additional arguments passed to +\code{\link[bridgesampling:bridge_sampler]{bridge_sampler.stanfit}}.} +} +\description{ +Computes log marginal likelihood via bridge sampling, +which can be used in the computation of bayes factors +and posterior model probabilities. +The \code{brmsfit} method is just a thin wrapper around +the corresponding method for \code{stanfit} objects. +} +\details{ +Computing the marginal likelihood requires samples of all variables + defined in Stan's \code{parameters} block to be saved. Otherwise + \code{bridge_sampler} cannot be computed. Thus, please set \code{save_pars + = save_pars(all = TRUE)} in the call to \code{brm}, if you are planning to + apply \code{bridge_sampler} to your models. + + The computation of marginal likelihoods based on bridge sampling requires + a lot more posterior draws than usual. A good conservative + rule of thump is perhaps 10-fold more draws (read: the default of 4000 + draws may not be enough in many cases). If not enough posterior + draws are provided, the bridge sampling algorithm tends to be + unstable leading to considerably different results each time it is run. + We thus recommend running \code{bridge_sampler} + multiple times to check the stability of the results. + + More details are provided under + \code{\link[bridgesampling:bridge_sampler]{bridgesampling::bridge_sampler}}. +} +\examples{ +\dontrun{ +# model with the treatment effect +fit1 <- brm( + count ~ zAge + zBase + Trt, + data = epilepsy, family = negbinomial(), + prior = prior(normal(0, 1), class = b), + save_pars = save_pars(all = TRUE) +) +summary(fit1) +bridge_sampler(fit1) + +# model without the treatment effect +fit2 <- brm( + count ~ zAge + zBase, + data = epilepsy, family = negbinomial(), + prior = prior(normal(0, 1), class = b), + save_pars = save_pars(all = TRUE) +) +summary(fit2) +bridge_sampler(fit2) +} + +} +\seealso{ +\code{ + \link[brms:bayes_factor.brmsfit]{bayes_factor}, + \link[brms:post_prob.brmsfit]{post_prob} +} +} diff -Nru r-cran-brms-2.16.3/man/brm_multiple.Rd r-cran-brms-2.17.0/man/brm_multiple.Rd --- r-cran-brms-2.16.3/man/brm_multiple.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/brm_multiple.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,217 +1,217 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brm_multiple.R -\name{brm_multiple} -\alias{brm_multiple} -\title{Run the same \pkg{brms} model on multiple datasets} -\usage{ -brm_multiple( - formula, - data, - family = gaussian(), - prior = NULL, - data2 = NULL, - autocor = NULL, - cov_ranef = NULL, - sample_prior = c("no", "yes", "only"), - sparse = NULL, - knots = NULL, - stanvars = NULL, - stan_funs = NULL, - silent = 1, - recompile = FALSE, - combine = TRUE, - fit = NA, - seed = NA, - file = NULL, - file_refit = "never", - ... -) -} -\arguments{ -\item{formula}{An object of class \code{\link[stats:formula]{formula}}, -\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can -be coerced to that classes): A symbolic description of the model to be -fitted. The details of model specification are explained in -\code{\link{brmsformula}}.} - -\item{data}{A \emph{list} of data.frames each of which will be used to fit a -separate model. Alternatively, a \code{mids} object from the \pkg{mice} -package.} - -\item{family}{A description of the response distribution and link function to -be used in the model. This can be a family function, a call to a family -function or a character string naming the family. Every family function has -a \code{link} argument allowing to specify the link function to be applied -on the response variable. If not specified, default links are used. For -details of supported families see \code{\link{brmsfamily}}. By default, a -linear \code{gaussian} model is applied. In multivariate models, -\code{family} might also be a list of families.} - -\item{prior}{One or more \code{brmsprior} objects created by -\code{\link{set_prior}} or related functions and combined using the -\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} -for more help.} - -\item{data2}{A \emph{list} of named lists each of which will be used to fit a -separate model. Each of the named lists contains objects representing data -which cannot be passed via argument \code{data} (see \code{\link{brm}} for -examples). The length of the outer list should match the length of the list -passed to the \code{data} argument.} - -\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object -describing the correlation structure within the response variable (i.e., -the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for -a description of the available correlation structures. Defaults to -\code{NULL}, corresponding to no correlations. In multivariate models, -\code{autocor} might also be a list of autocorrelation structures. -It is now recommend to specify autocorrelation terms directly -within \code{formula}. See \code{\link{brmsformula}} for more details.} - -\item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the -(within) covariance structure of the group-level effects. The names of the -matrices should correspond to columns in \code{data} that are used as -grouping factors. All levels of the grouping factor should appear as -rownames of the corresponding matrix. This argument can be used, among -others to model pedigrees and phylogenetic effects. -It is now recommended to specify those matrices in the formula -interface using the \code{\link{gr}} and related functions. See -\code{vignette("brms_phylogenetics")} for more details.} - -\item{sample_prior}{Indicate if draws from priors should be drawn -additionally to the posterior draws. Options are \code{"no"} (the -default), \code{"yes"}, and \code{"only"}. Among others, these draws can -be used to calculate Bayes factors for point hypotheses via -\code{\link{hypothesis}}. Please note that improper priors are not sampled, -including the default improper priors used by \code{brm}. See -\code{\link{set_prior}} on how to set (proper) priors. Please also note -that prior draws for the overall intercept are not obtained by default -for technical reasons. See \code{\link{brmsformula}} how to obtain prior -draws for the intercept. If \code{sample_prior} is set to \code{"only"}, -draws are drawn solely from the priors ignoring the likelihood, which -allows among others to generate draws from the prior predictive -distribution. In this case, all parameters must have proper priors.} - -\item{sparse}{(Deprecated) Logical; indicates whether the population-level -design matrices should be treated as sparse (defaults to \code{FALSE}). For -design matrices with many zeros, this can considerably reduce required -memory. Sampling speed is currently not improved or even slightly -decreased. It is now recommended to use the \code{sparse} argument of -\code{\link{brmsformula}} and related functions.} - -\item{knots}{Optional list containing user specified knot values to be used -for basis construction of smoothing terms. See -\code{\link[mgcv:gamm]{gamm}} for more details.} - -\item{stanvars}{An optional \code{stanvars} object generated by function -\code{\link{stanvar}} to define additional variables for use in -\pkg{Stan}'s program blocks.} - -\item{stan_funs}{(Deprecated) An optional character string containing -self-defined \pkg{Stan} functions, which will be included in the functions -block of the generated \pkg{Stan} code. It is now recommended to use the -\code{stanvars} argument for this purpose instead.} - -\item{silent}{Verbosity level between \code{0} and \code{2}. -If \code{1} (the default), most of the -informational messages of compiler and sampler are suppressed. -If \code{2}, even more messages are suppressed. The actual -sampling progress is still printed. Set \code{refresh = 0} to turn this off -as well. If using \code{backend = "rstan"} you can also set -\code{open_progress = FALSE} to prevent opening additional progress bars.} - -\item{recompile}{Logical, indicating whether the Stan model should be -recompiled for every imputed data set. Defaults to \code{FALSE}. If -\code{NULL}, \code{brm_multiple} tries to figure out internally, if recompilation -is necessary, for example because data-dependent priors have changed. -Using the default of no recompilation should be fine in most cases.} - -\item{combine}{Logical; Indicates if the fitted models should be combined -into a single fitted model object via \code{\link{combine_models}}. -Defaults to \code{TRUE}.} - -\item{fit}{An instance of S3 class \code{brmsfit_multiple} derived from a -previous fit; defaults to \code{NA}. If \code{fit} is of class -\code{brmsfit_multiple}, the compiled model associated with the fitted -result is re-used and all arguments modifying the model code or data are -ignored. It is not recommended to use this argument directly, but to call -the \code{\link[brms:update.brmsfit_multiple]{update}} method, instead.} - -\item{seed}{The seed for random number generation to make results -reproducible. If \code{NA} (the default), \pkg{Stan} will set the seed -randomly.} - -\item{file}{Either \code{NULL} or a character string. In the latter case, the -fitted model object is saved via \code{\link{saveRDS}} in a file named -after the string supplied in \code{file}. The \code{.rds} extension is -added automatically. If the file already exists, \code{brm} will load and -return the saved model object instead of refitting the model. -Unless you specify the \code{file_refit} argument as well, the existing -files won't be overwritten, you have to manually remove the file in order -to refit and save the model under an existing file name. The file name -is stored in the \code{brmsfit} object for later usage.} - -\item{file_refit}{Modifies when the fit stored via the \code{file} parameter -is re-used. Can be set globally for the current \R session via the -\code{"brms.file_refit"} option (see \code{\link{options}}). -For \code{"never"} (default) the fit is always loaded if it -exists and fitting is skipped. For \code{"always"} the model is always -refitted. If set to \code{"on_change"}, brms will -refit the model if model, data or algorithm as passed to Stan differ from -what is stored in the file. This also covers changes in priors, -\code{sample_prior}, \code{stanvars}, covariance structure, etc. If you -believe there was a false positive, you can use -\code{\link{brmsfit_needs_refit}} to see why refit is deemed necessary. -Refit will not be triggered for changes in additional parameters of the fit -(e.g., initial values, number of iterations, control arguments, ...). A -known limitation is that a refit will be triggered if within-chain -parallelization is switched on/off.} - -\item{...}{Further arguments passed to \code{\link{brm}}.} -} -\value{ -If \code{combine = TRUE} a \code{brmsfit_multiple} object, which - inherits from class \code{brmsfit} and behaves essentially the same. If - \code{combine = FALSE} a list of \code{brmsfit} objects. -} -\description{ -Run the same \pkg{brms} model on multiple datasets and then combine the -results into one fitted model object. This is useful in particular for -multiple missing value imputation, where the same model is fitted on multiple -imputed data sets. Models can be run in parallel using the \pkg{future} -package. -} -\details{ -The combined model may issue false positive convergence warnings, as - the MCMC chains corresponding to different datasets may not necessarily - overlap, even if each of the original models did converge. To find out - whether each of the original models converged, investigate - \code{fit$rhats}, where \code{fit} denotes the output of - \code{brm_multiple}. -} -\examples{ -\dontrun{ -library(mice) -imp <- mice(nhanes2) - -# fit the model using mice and lm -fit_imp1 <- with(lm(bmi ~ age + hyp + chl), data = imp) -summary(pool(fit_imp1)) - -# fit the model using brms -fit_imp2 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) -summary(fit_imp2) -plot(fit_imp2, pars = "^b_") -# investigate convergence of the original models -fit_imp2$rhats - -# use the future package for parallelization -library(future) -plan(multiprocess) -fit_imp3 <- brm_multiple(bmi~age+hyp+chl, data = imp, chains = 1) -summary(fit_imp3) -} - -} -\author{ -Paul-Christian Buerkner \email{paul.buerkner@gmail.com} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brm_multiple.R +\name{brm_multiple} +\alias{brm_multiple} +\title{Run the same \pkg{brms} model on multiple datasets} +\usage{ +brm_multiple( + formula, + data, + family = gaussian(), + prior = NULL, + data2 = NULL, + autocor = NULL, + cov_ranef = NULL, + sample_prior = c("no", "yes", "only"), + sparse = NULL, + knots = NULL, + stanvars = NULL, + stan_funs = NULL, + silent = 1, + recompile = FALSE, + combine = TRUE, + fit = NA, + seed = NA, + file = NULL, + file_refit = "never", + ... +) +} +\arguments{ +\item{formula}{An object of class \code{\link[stats:formula]{formula}}, +\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can +be coerced to that classes): A symbolic description of the model to be +fitted. The details of model specification are explained in +\code{\link{brmsformula}}.} + +\item{data}{A \emph{list} of data.frames each of which will be used to fit a +separate model. Alternatively, a \code{mids} object from the \pkg{mice} +package.} + +\item{family}{A description of the response distribution and link function to +be used in the model. This can be a family function, a call to a family +function or a character string naming the family. Every family function has +a \code{link} argument allowing to specify the link function to be applied +on the response variable. If not specified, default links are used. For +details of supported families see \code{\link{brmsfamily}}. By default, a +linear \code{gaussian} model is applied. In multivariate models, +\code{family} might also be a list of families.} + +\item{prior}{One or more \code{brmsprior} objects created by +\code{\link{set_prior}} or related functions and combined using the +\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} +for more help.} + +\item{data2}{A \emph{list} of named lists each of which will be used to fit a +separate model. Each of the named lists contains objects representing data +which cannot be passed via argument \code{data} (see \code{\link{brm}} for +examples). The length of the outer list should match the length of the list +passed to the \code{data} argument.} + +\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object +describing the correlation structure within the response variable (i.e., +the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for +a description of the available correlation structures. Defaults to +\code{NULL}, corresponding to no correlations. In multivariate models, +\code{autocor} might also be a list of autocorrelation structures. +It is now recommend to specify autocorrelation terms directly +within \code{formula}. See \code{\link{brmsformula}} for more details.} + +\item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the +(within) covariance structure of the group-level effects. The names of the +matrices should correspond to columns in \code{data} that are used as +grouping factors. All levels of the grouping factor should appear as +rownames of the corresponding matrix. This argument can be used, among +others to model pedigrees and phylogenetic effects. +It is now recommended to specify those matrices in the formula +interface using the \code{\link{gr}} and related functions. See +\code{vignette("brms_phylogenetics")} for more details.} + +\item{sample_prior}{Indicate if draws from priors should be drawn +additionally to the posterior draws. Options are \code{"no"} (the +default), \code{"yes"}, and \code{"only"}. Among others, these draws can +be used to calculate Bayes factors for point hypotheses via +\code{\link{hypothesis}}. Please note that improper priors are not sampled, +including the default improper priors used by \code{brm}. See +\code{\link{set_prior}} on how to set (proper) priors. Please also note +that prior draws for the overall intercept are not obtained by default +for technical reasons. See \code{\link{brmsformula}} how to obtain prior +draws for the intercept. If \code{sample_prior} is set to \code{"only"}, +draws are drawn solely from the priors ignoring the likelihood, which +allows among others to generate draws from the prior predictive +distribution. In this case, all parameters must have proper priors.} + +\item{sparse}{(Deprecated) Logical; indicates whether the population-level +design matrices should be treated as sparse (defaults to \code{FALSE}). For +design matrices with many zeros, this can considerably reduce required +memory. Sampling speed is currently not improved or even slightly +decreased. It is now recommended to use the \code{sparse} argument of +\code{\link{brmsformula}} and related functions.} + +\item{knots}{Optional list containing user specified knot values to be used +for basis construction of smoothing terms. See +\code{\link[mgcv:gamm]{gamm}} for more details.} + +\item{stanvars}{An optional \code{stanvars} object generated by function +\code{\link{stanvar}} to define additional variables for use in +\pkg{Stan}'s program blocks.} + +\item{stan_funs}{(Deprecated) An optional character string containing +self-defined \pkg{Stan} functions, which will be included in the functions +block of the generated \pkg{Stan} code. It is now recommended to use the +\code{stanvars} argument for this purpose instead.} + +\item{silent}{Verbosity level between \code{0} and \code{2}. +If \code{1} (the default), most of the +informational messages of compiler and sampler are suppressed. +If \code{2}, even more messages are suppressed. The actual +sampling progress is still printed. Set \code{refresh = 0} to turn this off +as well. If using \code{backend = "rstan"} you can also set +\code{open_progress = FALSE} to prevent opening additional progress bars.} + +\item{recompile}{Logical, indicating whether the Stan model should be +recompiled for every imputed data set. Defaults to \code{FALSE}. If +\code{NULL}, \code{brm_multiple} tries to figure out internally, if recompilation +is necessary, for example because data-dependent priors have changed. +Using the default of no recompilation should be fine in most cases.} + +\item{combine}{Logical; Indicates if the fitted models should be combined +into a single fitted model object via \code{\link{combine_models}}. +Defaults to \code{TRUE}.} + +\item{fit}{An instance of S3 class \code{brmsfit_multiple} derived from a +previous fit; defaults to \code{NA}. If \code{fit} is of class +\code{brmsfit_multiple}, the compiled model associated with the fitted +result is re-used and all arguments modifying the model code or data are +ignored. It is not recommended to use this argument directly, but to call +the \code{\link[brms:update.brmsfit_multiple]{update}} method, instead.} + +\item{seed}{The seed for random number generation to make results +reproducible. If \code{NA} (the default), \pkg{Stan} will set the seed +randomly.} + +\item{file}{Either \code{NULL} or a character string. In the latter case, the +fitted model object is saved via \code{\link{saveRDS}} in a file named +after the string supplied in \code{file}. The \code{.rds} extension is +added automatically. If the file already exists, \code{brm} will load and +return the saved model object instead of refitting the model. +Unless you specify the \code{file_refit} argument as well, the existing +files won't be overwritten, you have to manually remove the file in order +to refit and save the model under an existing file name. The file name +is stored in the \code{brmsfit} object for later usage.} + +\item{file_refit}{Modifies when the fit stored via the \code{file} parameter +is re-used. Can be set globally for the current \R session via the +\code{"brms.file_refit"} option (see \code{\link{options}}). +For \code{"never"} (default) the fit is always loaded if it +exists and fitting is skipped. For \code{"always"} the model is always +refitted. If set to \code{"on_change"}, brms will +refit the model if model, data or algorithm as passed to Stan differ from +what is stored in the file. This also covers changes in priors, +\code{sample_prior}, \code{stanvars}, covariance structure, etc. If you +believe there was a false positive, you can use +\code{\link{brmsfit_needs_refit}} to see why refit is deemed necessary. +Refit will not be triggered for changes in additional parameters of the fit +(e.g., initial values, number of iterations, control arguments, ...). A +known limitation is that a refit will be triggered if within-chain +parallelization is switched on/off.} + +\item{...}{Further arguments passed to \code{\link{brm}}.} +} +\value{ +If \code{combine = TRUE} a \code{brmsfit_multiple} object, which + inherits from class \code{brmsfit} and behaves essentially the same. If + \code{combine = FALSE} a list of \code{brmsfit} objects. +} +\description{ +Run the same \pkg{brms} model on multiple datasets and then combine the +results into one fitted model object. This is useful in particular for +multiple missing value imputation, where the same model is fitted on multiple +imputed data sets. Models can be run in parallel using the \pkg{future} +package. +} +\details{ +The combined model may issue false positive convergence warnings, as + the MCMC chains corresponding to different datasets may not necessarily + overlap, even if each of the original models did converge. To find out + whether each of the original models converged, investigate + \code{fit$rhats}, where \code{fit} denotes the output of + \code{brm_multiple}. +} +\examples{ +\dontrun{ +library(mice) +imp <- mice(nhanes2) + +# fit the model using mice and lm +fit_imp1 <- with(lm(bmi ~ age + hyp + chl), data = imp) +summary(pool(fit_imp1)) + +# fit the model using brms +fit_imp2 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) +summary(fit_imp2) +plot(fit_imp2, pars = "^b_") +# investigate convergence of the original models +fit_imp2$rhats + +# use the future package for parallelization +library(future) +plan(multiprocess) +fit_imp3 <- brm_multiple(bmi~age+hyp+chl, data = imp, chains = 1) +summary(fit_imp3) +} + +} +\author{ +Paul-Christian Buerkner \email{paul.buerkner@gmail.com} +} diff -Nru r-cran-brms-2.16.3/man/brm.Rd r-cran-brms-2.17.0/man/brm.Rd --- r-cran-brms-2.16.3/man/brm.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/brm.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,508 +1,514 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brm.R -\name{brm} -\alias{brm} -\title{Fit Bayesian Generalized (Non-)Linear Multivariate Multilevel Models} -\usage{ -brm( - formula, - data, - family = gaussian(), - prior = NULL, - autocor = NULL, - data2 = NULL, - cov_ranef = NULL, - sample_prior = "no", - sparse = NULL, - knots = NULL, - stanvars = NULL, - stan_funs = NULL, - fit = NA, - save_pars = NULL, - save_ranef = NULL, - save_mevars = NULL, - save_all_pars = NULL, - inits = "random", - chains = 4, - iter = 2000, - warmup = floor(iter/2), - thin = 1, - cores = getOption("mc.cores", 1), - threads = NULL, - opencl = NULL, - normalize = getOption("brms.normalize", TRUE), - control = NULL, - algorithm = getOption("brms.algorithm", "sampling"), - backend = getOption("brms.backend", "rstan"), - future = getOption("future", FALSE), - silent = 1, - seed = NA, - save_model = NULL, - stan_model_args = list(), - file = NULL, - file_refit = getOption("brms.file_refit", "never"), - empty = FALSE, - rename = TRUE, - ... -) -} -\arguments{ -\item{formula}{An object of class \code{\link[stats:formula]{formula}}, -\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can -be coerced to that classes): A symbolic description of the model to be -fitted. The details of model specification are explained in -\code{\link{brmsformula}}.} - -\item{data}{An object of class \code{data.frame} (or one that can be coerced -to that class) containing data of all variables used in the model.} - -\item{family}{A description of the response distribution and link function to -be used in the model. This can be a family function, a call to a family -function or a character string naming the family. Every family function has -a \code{link} argument allowing to specify the link function to be applied -on the response variable. If not specified, default links are used. For -details of supported families see \code{\link{brmsfamily}}. By default, a -linear \code{gaussian} model is applied. In multivariate models, -\code{family} might also be a list of families.} - -\item{prior}{One or more \code{brmsprior} objects created by -\code{\link{set_prior}} or related functions and combined using the -\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} -for more help.} - -\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object -describing the correlation structure within the response variable (i.e., -the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for -a description of the available correlation structures. Defaults to -\code{NULL}, corresponding to no correlations. In multivariate models, -\code{autocor} might also be a list of autocorrelation structures. -It is now recommend to specify autocorrelation terms directly -within \code{formula}. See \code{\link{brmsformula}} for more details.} - -\item{data2}{A named \code{list} of objects containing data, which -cannot be passed via argument \code{data}. Required for some objects -used in autocorrelation structures to specify dependency structures -as well as for within-group covariance matrices.} - -\item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the -(within) covariance structure of the group-level effects. The names of the -matrices should correspond to columns in \code{data} that are used as -grouping factors. All levels of the grouping factor should appear as -rownames of the corresponding matrix. This argument can be used, among -others to model pedigrees and phylogenetic effects. -It is now recommended to specify those matrices in the formula -interface using the \code{\link{gr}} and related functions. See -\code{vignette("brms_phylogenetics")} for more details.} - -\item{sample_prior}{Indicate if draws from priors should be drawn -additionally to the posterior draws. Options are \code{"no"} (the -default), \code{"yes"}, and \code{"only"}. Among others, these draws can -be used to calculate Bayes factors for point hypotheses via -\code{\link{hypothesis}}. Please note that improper priors are not sampled, -including the default improper priors used by \code{brm}. See -\code{\link{set_prior}} on how to set (proper) priors. Please also note -that prior draws for the overall intercept are not obtained by default -for technical reasons. See \code{\link{brmsformula}} how to obtain prior -draws for the intercept. If \code{sample_prior} is set to \code{"only"}, -draws are drawn solely from the priors ignoring the likelihood, which -allows among others to generate draws from the prior predictive -distribution. In this case, all parameters must have proper priors.} - -\item{sparse}{(Deprecated) Logical; indicates whether the population-level -design matrices should be treated as sparse (defaults to \code{FALSE}). For -design matrices with many zeros, this can considerably reduce required -memory. Sampling speed is currently not improved or even slightly -decreased. It is now recommended to use the \code{sparse} argument of -\code{\link{brmsformula}} and related functions.} - -\item{knots}{Optional list containing user specified knot values to be used -for basis construction of smoothing terms. See -\code{\link[mgcv:gamm]{gamm}} for more details.} - -\item{stanvars}{An optional \code{stanvars} object generated by function -\code{\link{stanvar}} to define additional variables for use in -\pkg{Stan}'s program blocks.} - -\item{stan_funs}{(Deprecated) An optional character string containing -self-defined \pkg{Stan} functions, which will be included in the functions -block of the generated \pkg{Stan} code. It is now recommended to use the -\code{stanvars} argument for this purpose instead.} - -\item{fit}{An instance of S3 class \code{brmsfit} derived from a previous -fit; defaults to \code{NA}. If \code{fit} is of class \code{brmsfit}, the -compiled model associated with the fitted result is re-used and all -arguments modifying the model code or data are ignored. It is not -recommended to use this argument directly, but to call the -\code{\link[brms:update.brmsfit]{update}} method, instead.} - -\item{save_pars}{An object generated by \code{\link{save_pars}} controlling -which parameters should be saved in the model. The argument has no -impact on the model fitting itself.} - -\item{save_ranef}{(Deprecated) A flag to indicate if group-level effects for -each level of the grouping factor(s) should be saved (default is -\code{TRUE}). Set to \code{FALSE} to save memory. The argument has no -impact on the model fitting itself.} - -\item{save_mevars}{(Deprecated) A flag to indicate if draws of latent -noise-free variables obtained by using \code{me} and \code{mi} terms should -be saved (default is \code{FALSE}). Saving these draws allows to better -use methods such as \code{predict} with the latent variables but leads to -very large \R objects even for models of moderate size and complexity.} - -\item{save_all_pars}{(Deprecated) A flag to indicate if draws from all -variables defined in Stan's \code{parameters} block should be saved -(default is \code{FALSE}). Saving these draws is required in order to -apply the methods \code{bridge_sampler}, \code{bayes_factor}, and -\code{post_prob}.} - -\item{inits}{Either \code{"random"} or \code{"0"}. If inits is -\code{"random"} (the default), Stan will randomly generate initial values -for parameters. If it is \code{"0"}, all parameters are initialized to -zero. This option is sometimes useful for certain families, as it happens -that default (\code{"random"}) inits cause draws to be essentially -constant. Generally, setting \code{inits = "0"} is worth a try, if chains -do not behave well. Alternatively, \code{inits} can be a list of lists -containing the initial values, or a function (or function name) generating -initial values. The latter options are mainly implemented for internal -testing but are available to users if necessary. If specifying initial -values using a list or a function then currently the parameter names must -correspond to the names used in the generated Stan code (not the names -used in \R). For more details on specifying initial values you can consult -the documentation of the selected \code{backend}.} - -\item{chains}{Number of Markov chains (defaults to 4).} - -\item{iter}{Number of total iterations per chain (including warmup; defaults -to 2000).} - -\item{warmup}{A positive integer specifying number of warmup (aka burnin) -iterations. This also specifies the number of iterations used for stepsize -adaptation, so warmup draws should not be used for inference. The number -of warmup should not be larger than \code{iter} and the default is -\code{iter/2}.} - -\item{thin}{Thinning rate. Must be a positive integer. Set \code{thin > 1} to -save memory and computation time if \code{iter} is large.} - -\item{cores}{Number of cores to use when executing the chains in parallel, -which defaults to 1 but we recommend setting the \code{mc.cores} option to -be as many processors as the hardware and RAM allow (up to the number of -chains). For non-Windows OS in non-interactive \R sessions, forking is used -instead of PSOCK clusters.} - -\item{threads}{Number of threads to use in within-chain parallelization. For -more control over the threading process, \code{threads} may also be a -\code{brmsthreads} object created by \code{\link{threading}}. Within-chain -parallelization is experimental! We recommend its use only if you are -experienced with Stan's \code{reduce_sum} function and have a slow running -model that cannot be sped up by any other means.} - -\item{opencl}{The platform and device IDs of the OpenCL device to use for -fitting using GPU support. If you don't know the IDs of your OpenCL -device, \code{c(0,0)} is most likely what you need. For more details, see -\code{\link{opencl}}.} - -\item{normalize}{Logical. Indicates whether normalization constants should -be included in the Stan code (defaults to \code{TRUE}). Setting it -to \code{FALSE} requires Stan version >= 2.25 to work. If \code{FALSE}, -sampling efficiency may be increased but some post processing functions -such as \code{\link{bridge_sampler}} will not be available. Can be -controlled globally for the current \R session via the `brms.normalize` -option.} - -\item{control}{A named \code{list} of parameters to control the sampler's -behavior. It defaults to \code{NULL} so all the default values are used. -The most important control parameters are discussed in the 'Details' -section below. For a comprehensive overview see -\code{\link[rstan:stan]{stan}}.} - -\item{algorithm}{Character string naming the estimation approach to use. -Options are \code{"sampling"} for MCMC (the default), \code{"meanfield"} for -variational inference with independent normal distributions, -\code{"fullrank"} for variational inference with a multivariate normal -distribution, or \code{"fixed_param"} for sampling from fixed parameter -values. Can be set globally for the current \R session via the -\code{"brms.algorithm"} option (see \code{\link{options}}).} - -\item{backend}{Character string naming the package to use as the backend for -fitting the Stan model. Options are \code{"rstan"} (the default) or -\code{"cmdstanr"}. Can be set globally for the current \R session via the -\code{"brms.backend"} option (see \code{\link{options}}). Details on the -\pkg{rstan} and \pkg{cmdstanr} packages are available at -\url{https://mc-stan.org/rstan/} and \url{https://mc-stan.org/cmdstanr/}, -respectively. Additionally a \code{"mock"} backend is available to make -testing \pkg{brms} and packages that depend on it easier. -The \code{"mock"} backend does not actually do any fitting, it only checks -the generated Stan code for correctness and then returns whatever is passed -in an additional \code{mock_fit} argument as the result of the fit.} - -\item{future}{Logical; If \code{TRUE}, the \pkg{\link[future:future]{future}} -package is used for parallel execution of the chains and argument -\code{cores} will be ignored. Can be set globally for the current \R -session via the \code{"future"} option. The execution type is controlled via -\code{\link[future:plan]{plan}} (see the examples section below).} - -\item{silent}{Verbosity level between \code{0} and \code{2}. -If \code{1} (the default), most of the -informational messages of compiler and sampler are suppressed. -If \code{2}, even more messages are suppressed. The actual -sampling progress is still printed. Set \code{refresh = 0} to turn this off -as well. If using \code{backend = "rstan"} you can also set -\code{open_progress = FALSE} to prevent opening additional progress bars.} - -\item{seed}{The seed for random number generation to make results -reproducible. If \code{NA} (the default), \pkg{Stan} will set the seed -randomly.} - -\item{save_model}{Either \code{NULL} or a character string. In the latter -case, the model's Stan code is saved via \code{\link{cat}} in a text file -named after the string supplied in \code{save_model}.} - -\item{stan_model_args}{A \code{list} of further arguments passed to -\code{\link[rstan:stan_model]{stan_model}}.} - -\item{file}{Either \code{NULL} or a character string. In the latter case, the -fitted model object is saved via \code{\link{saveRDS}} in a file named -after the string supplied in \code{file}. The \code{.rds} extension is -added automatically. If the file already exists, \code{brm} will load and -return the saved model object instead of refitting the model. -Unless you specify the \code{file_refit} argument as well, the existing -files won't be overwritten, you have to manually remove the file in order -to refit and save the model under an existing file name. The file name -is stored in the \code{brmsfit} object for later usage.} - -\item{file_refit}{Modifies when the fit stored via the \code{file} parameter -is re-used. Can be set globally for the current \R session via the -\code{"brms.file_refit"} option (see \code{\link{options}}). -For \code{"never"} (default) the fit is always loaded if it -exists and fitting is skipped. For \code{"always"} the model is always -refitted. If set to \code{"on_change"}, brms will -refit the model if model, data or algorithm as passed to Stan differ from -what is stored in the file. This also covers changes in priors, -\code{sample_prior}, \code{stanvars}, covariance structure, etc. If you -believe there was a false positive, you can use -\code{\link{brmsfit_needs_refit}} to see why refit is deemed necessary. -Refit will not be triggered for changes in additional parameters of the fit -(e.g., initial values, number of iterations, control arguments, ...). A -known limitation is that a refit will be triggered if within-chain -parallelization is switched on/off.} - -\item{empty}{Logical. If \code{TRUE}, the Stan model is not created -and compiled and the corresponding \code{'fit'} slot of the \code{brmsfit} -object will be empty. This is useful if you have estimated a brms-created -Stan model outside of \pkg{brms} and want to feed it back into the package.} - -\item{rename}{For internal use only.} - -\item{...}{Further arguments passed to Stan. -For \code{backend = "rstan"} the arguments are passed to -\code{\link[rstan]{sampling}} or \code{\link[rstan]{vb}}. -For \code{backend = "cmdstanr"} the arguments are passed to the -\code{cmdstanr::sample} or \code{cmdstanr::variational} method.} -} -\value{ -An object of class \code{brmsfit}, which contains the posterior - draws along with many other useful information about the model. Use - \code{methods(class = "brmsfit")} for an overview on available methods. -} -\description{ -Fit Bayesian generalized (non-)linear multivariate multilevel models -using Stan for full Bayesian inference. A wide range of distributions -and link functions are supported, allowing users to fit -- among others -- -linear, robust linear, count data, survival, response times, ordinal, -zero-inflated, hurdle, and even self-defined mixture models all in a -multilevel context. Further modeling options include non-linear and -smooth terms, auto-correlation structures, censored data, meta-analytic -standard errors, and quite a few more. In addition, all parameters of the -response distributions can be predicted in order to perform distributional -regression. Prior specifications are flexible and explicitly encourage -users to apply prior distributions that actually reflect their beliefs. -In addition, model fit can easily be assessed and compared with -posterior predictive checks and leave-one-out cross-validation. -} -\details{ -Fit a generalized (non-)linear multivariate multilevel model via - full Bayesian inference using Stan. A general overview is provided in the - vignettes \code{vignette("brms_overview")} and - \code{vignette("brms_multilevel")}. For a full list of available vignettes - see \code{vignette(package = "brms")}. - - \bold{Formula syntax of brms models} - - Details of the formula syntax applied in \pkg{brms} can be found in - \code{\link{brmsformula}}. - - \bold{Families and link functions} - - Details of families supported by \pkg{brms} can be found in - \code{\link{brmsfamily}}. - - \bold{Prior distributions} - - Priors should be specified using the - \code{\link[brms:set_prior]{set_prior}} function. Its documentation - contains detailed information on how to correctly specify priors. To find - out on which parameters or parameter classes priors can be defined, use - \code{\link[brms:get_prior]{get_prior}}. Default priors are chosen to be - non or very weakly informative so that their influence on the results will - be negligible and you usually don't have to worry about them. However, - after getting more familiar with Bayesian statistics, I recommend you to - start thinking about reasonable informative priors for your model - parameters: Nearly always, there is at least some prior information - available that can be used to improve your inference. - - \bold{Adjusting the sampling behavior of \pkg{Stan}} - - In addition to choosing the number of iterations, warmup draws, and - chains, users can control the behavior of the NUTS sampler, by using the - \code{control} argument. The most important reason to use \code{control} is - to decrease (or eliminate at best) the number of divergent transitions that - cause a bias in the obtained posterior draws. Whenever you see the - warning "There were x divergent transitions after warmup." you should - really think about increasing \code{adapt_delta}. To do this, write - \code{control = list(adapt_delta = )}, where \code{} should usually - be value between \code{0.8} (current default) and \code{1}. Increasing - \code{adapt_delta} will slow down the sampler but will decrease the number - of divergent transitions threatening the validity of your posterior - draws. - - Another problem arises when the depth of the tree being evaluated in each - iteration is exceeded. This is less common than having divergent - transitions, but may also bias the posterior draws. When it happens, - \pkg{Stan} will throw out a warning suggesting to increase - \code{max_treedepth}, which can be accomplished by writing \code{control = - list(max_treedepth = )} with a positive integer \code{} that should - usually be larger than the current default of \code{10}. For more details - on the \code{control} argument see \code{\link[rstan:stan]{stan}}. -} -\examples{ -\dontrun{ -# Poisson regression for the number of seizures in epileptic patients -# using normal priors for population-level effects -# and half-cauchy priors for standard deviations of group-level effects -prior1 <- prior(normal(0,10), class = b) + - prior(cauchy(0,2), class = sd) -fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson(), prior = prior1) - -# generate a summary of the results -summary(fit1) - -# plot the MCMC chains as well as the posterior distributions -plot(fit1, ask = FALSE) - -# predict responses based on the fitted model -head(predict(fit1)) - -# plot conditional effects for each predictor -plot(conditional_effects(fit1), ask = FALSE) - -# investigate model fit -loo(fit1) -pp_check(fit1) - - -# Ordinal regression modeling patient's rating of inhaler instructions -# category specific effects are estimated for variable 'treat' -fit2 <- brm(rating ~ period + carry + cs(treat), - data = inhaler, family = sratio("logit"), - prior = set_prior("normal(0,5)"), chains = 2) -summary(fit2) -plot(fit2, ask = FALSE) -WAIC(fit2) - - -# Survival regression modeling the time between the first -# and second recurrence of an infection in kidney patients. -fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), - data = kidney, family = lognormal()) -summary(fit3) -plot(fit3, ask = FALSE) -plot(conditional_effects(fit3), ask = FALSE) - - -# Probit regression using the binomial family -ntrials <- sample(1:10, 100, TRUE) -success <- rbinom(100, size = ntrials, prob = 0.4) -x <- rnorm(100) -data4 <- data.frame(ntrials, success, x) -fit4 <- brm(success | trials(ntrials) ~ x, data = data4, - family = binomial("probit")) -summary(fit4) - - -# Non-linear Gaussian model -fit5 <- brm( - bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), - ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, - nl = TRUE), - data = loss, family = gaussian(), - prior = c( - prior(normal(5000, 1000), nlpar = "ult"), - prior(normal(1, 2), nlpar = "omega"), - prior(normal(45, 10), nlpar = "theta") - ), - control = list(adapt_delta = 0.9) -) -summary(fit5) -conditional_effects(fit5) - - -# Normal model with heterogeneous variances -data_het <- data.frame( - y = c(rnorm(50), rnorm(50, 1, 2)), - x = factor(rep(c("a", "b"), each = 50)) -) -fit6 <- brm(bf(y ~ x, sigma ~ 0 + x), data = data_het) -summary(fit6) -plot(fit6) -conditional_effects(fit6) - -# extract estimated residual SDs of both groups -sigmas <- exp(as.data.frame(fit6, variable = "^b_sigma_", regex = TRUE)) -ggplot(stack(sigmas), aes(values)) + - geom_density(aes(fill = ind)) - - -# Quantile regression predicting the 25\%-quantile -fit7 <- brm(bf(y ~ x, quantile = 0.25), data = data_het, - family = asym_laplace()) -summary(fit7) -conditional_effects(fit7) - - -# use the future package for more flexible parallelization -library(future) -plan(multiprocess) -fit7 <- update(fit7, future = TRUE) - - -# fit a model manually via rstan -scode <- make_stancode(count ~ Trt, data = epilepsy) -sdata <- make_standata(count ~ Trt, data = epilepsy) -stanfit <- rstan::stan(model_code = scode, data = sdata) -# feed the Stan model back into brms -fit8 <- brm(count ~ Trt, data = epilepsy, empty = TRUE) -fit8$fit <- stanfit -fit8 <- rename_pars(fit8) -summary(fit8) -} - -} -\references{ -Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel -Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. -\code{doi:10.18637/jss.v080.i01} - -Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling -with the R Package brms. \emph{The R Journal}. 10(1), 395–411. -\code{doi:10.32614/RJ-2018-017} -} -\seealso{ -\code{\link{brms}}, \code{\link{brmsformula}}, -\code{\link{brmsfamily}}, \code{\link{brmsfit}} -} -\author{ -Paul-Christian Buerkner \email{paul.buerkner@gmail.com} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brm.R +\name{brm} +\alias{brm} +\title{Fit Bayesian Generalized (Non-)Linear Multivariate Multilevel Models} +\usage{ +brm( + formula, + data, + family = gaussian(), + prior = NULL, + autocor = NULL, + data2 = NULL, + cov_ranef = NULL, + sample_prior = "no", + sparse = NULL, + knots = NULL, + stanvars = NULL, + stan_funs = NULL, + fit = NA, + save_pars = NULL, + save_ranef = NULL, + save_mevars = NULL, + save_all_pars = NULL, + init = NULL, + inits = NULL, + chains = 4, + iter = 2000, + warmup = floor(iter/2), + thin = 1, + cores = getOption("mc.cores", 1), + threads = getOption("brms.threads", NULL), + opencl = getOption("brms.opencl", NULL), + normalize = getOption("brms.normalize", TRUE), + control = NULL, + algorithm = getOption("brms.algorithm", "sampling"), + backend = getOption("brms.backend", "rstan"), + future = getOption("future", FALSE), + silent = 1, + seed = NA, + save_model = NULL, + stan_model_args = list(), + file = NULL, + file_refit = getOption("brms.file_refit", "never"), + empty = FALSE, + rename = TRUE, + ... +) +} +\arguments{ +\item{formula}{An object of class \code{\link[stats:formula]{formula}}, +\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can +be coerced to that classes): A symbolic description of the model to be +fitted. The details of model specification are explained in +\code{\link{brmsformula}}.} + +\item{data}{An object of class \code{data.frame} (or one that can be coerced +to that class) containing data of all variables used in the model.} + +\item{family}{A description of the response distribution and link function to +be used in the model. This can be a family function, a call to a family +function or a character string naming the family. Every family function has +a \code{link} argument allowing to specify the link function to be applied +on the response variable. If not specified, default links are used. For +details of supported families see \code{\link{brmsfamily}}. By default, a +linear \code{gaussian} model is applied. In multivariate models, +\code{family} might also be a list of families.} + +\item{prior}{One or more \code{brmsprior} objects created by +\code{\link{set_prior}} or related functions and combined using the +\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} +for more help.} + +\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object +describing the correlation structure within the response variable (i.e., +the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for +a description of the available correlation structures. Defaults to +\code{NULL}, corresponding to no correlations. In multivariate models, +\code{autocor} might also be a list of autocorrelation structures. +It is now recommend to specify autocorrelation terms directly +within \code{formula}. See \code{\link{brmsformula}} for more details.} + +\item{data2}{A named \code{list} of objects containing data, which +cannot be passed via argument \code{data}. Required for some objects +used in autocorrelation structures to specify dependency structures +as well as for within-group covariance matrices.} + +\item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the +(within) covariance structure of the group-level effects. The names of the +matrices should correspond to columns in \code{data} that are used as +grouping factors. All levels of the grouping factor should appear as +rownames of the corresponding matrix. This argument can be used, among +others to model pedigrees and phylogenetic effects. +It is now recommended to specify those matrices in the formula +interface using the \code{\link{gr}} and related functions. See +\code{vignette("brms_phylogenetics")} for more details.} + +\item{sample_prior}{Indicate if draws from priors should be drawn +additionally to the posterior draws. Options are \code{"no"} (the +default), \code{"yes"}, and \code{"only"}. Among others, these draws can +be used to calculate Bayes factors for point hypotheses via +\code{\link{hypothesis}}. Please note that improper priors are not sampled, +including the default improper priors used by \code{brm}. See +\code{\link{set_prior}} on how to set (proper) priors. Please also note +that prior draws for the overall intercept are not obtained by default +for technical reasons. See \code{\link{brmsformula}} how to obtain prior +draws for the intercept. If \code{sample_prior} is set to \code{"only"}, +draws are drawn solely from the priors ignoring the likelihood, which +allows among others to generate draws from the prior predictive +distribution. In this case, all parameters must have proper priors.} + +\item{sparse}{(Deprecated) Logical; indicates whether the population-level +design matrices should be treated as sparse (defaults to \code{FALSE}). For +design matrices with many zeros, this can considerably reduce required +memory. Sampling speed is currently not improved or even slightly +decreased. It is now recommended to use the \code{sparse} argument of +\code{\link{brmsformula}} and related functions.} + +\item{knots}{Optional list containing user specified knot values to be used +for basis construction of smoothing terms. See +\code{\link[mgcv:gamm]{gamm}} for more details.} + +\item{stanvars}{An optional \code{stanvars} object generated by function +\code{\link{stanvar}} to define additional variables for use in +\pkg{Stan}'s program blocks.} + +\item{stan_funs}{(Deprecated) An optional character string containing +self-defined \pkg{Stan} functions, which will be included in the functions +block of the generated \pkg{Stan} code. It is now recommended to use the +\code{stanvars} argument for this purpose instead.} + +\item{fit}{An instance of S3 class \code{brmsfit} derived from a previous +fit; defaults to \code{NA}. If \code{fit} is of class \code{brmsfit}, the +compiled model associated with the fitted result is re-used and all +arguments modifying the model code or data are ignored. It is not +recommended to use this argument directly, but to call the +\code{\link[brms:update.brmsfit]{update}} method, instead.} + +\item{save_pars}{An object generated by \code{\link{save_pars}} controlling +which parameters should be saved in the model. The argument has no +impact on the model fitting itself.} + +\item{save_ranef}{(Deprecated) A flag to indicate if group-level effects for +each level of the grouping factor(s) should be saved (default is +\code{TRUE}). Set to \code{FALSE} to save memory. The argument has no +impact on the model fitting itself.} + +\item{save_mevars}{(Deprecated) A flag to indicate if draws of latent +noise-free variables obtained by using \code{me} and \code{mi} terms should +be saved (default is \code{FALSE}). Saving these draws allows to better +use methods such as \code{predict} with the latent variables but leads to +very large \R objects even for models of moderate size and complexity.} + +\item{save_all_pars}{(Deprecated) A flag to indicate if draws from all +variables defined in Stan's \code{parameters} block should be saved +(default is \code{FALSE}). Saving these draws is required in order to +apply the methods \code{bridge_sampler}, \code{bayes_factor}, and +\code{post_prob}.} + +\item{init}{Initial values for the sampler. If \code{NULL} (the default) or +\code{"random"}, Stan will randomly generate initial values for parameters +in a reasonable range. If \code{0}, all parameters are initialized to zero +on the unconstrained space. This option is sometimes useful for certain +families, as it happens that default random initial values cause draws to +be essentially constant. Generally, setting \code{init = 0} is worth a try, +if chains do not initialize or behave well. Alternatively, \code{init} can +be a list of lists containing the initial values, or a function (or +function name) generating initial values. The latter options are mainly +implemented for internal testing but are available to users if necessary. +If specifying initial values using a list or a function then currently the +parameter names must correspond to the names used in the generated Stan +code (not the names used in \R). For more details on specifying initial +values you can consult the documentation of the selected \code{backend}.} + +\item{inits}{(Deprecated) Alias of \code{init}.} + +\item{chains}{Number of Markov chains (defaults to 4).} + +\item{iter}{Number of total iterations per chain (including warmup; defaults +to 2000).} + +\item{warmup}{A positive integer specifying number of warmup (aka burnin) +iterations. This also specifies the number of iterations used for stepsize +adaptation, so warmup draws should not be used for inference. The number +of warmup should not be larger than \code{iter} and the default is +\code{iter/2}.} + +\item{thin}{Thinning rate. Must be a positive integer. Set \code{thin > 1} to +save memory and computation time if \code{iter} is large.} + +\item{cores}{Number of cores to use when executing the chains in parallel, +which defaults to 1 but we recommend setting the \code{mc.cores} option to +be as many processors as the hardware and RAM allow (up to the number of +chains). For non-Windows OS in non-interactive \R sessions, forking is used +instead of PSOCK clusters.} + +\item{threads}{Number of threads to use in within-chain parallelization. For +more control over the threading process, \code{threads} may also be a +\code{brmsthreads} object created by \code{\link{threading}}. Within-chain +parallelization is experimental! We recommend its use only if you are +experienced with Stan's \code{reduce_sum} function and have a slow running +model that cannot be sped up by any other means. Can be set globally for +the current \R session via the \code{"brms.threads"} option (see +\code{\link{options}}).} + +\item{opencl}{The platform and device IDs of the OpenCL device to use for +fitting using GPU support. If you don't know the IDs of your OpenCL device, +\code{c(0,0)} is most likely what you need. For more details, see +\code{\link{opencl}}. Can be set globally for the current \R session via +the \code{"brms.opencl"} option} + +\item{normalize}{Logical. Indicates whether normalization constants should +be included in the Stan code (defaults to \code{TRUE}). Setting it +to \code{FALSE} requires Stan version >= 2.25 to work. If \code{FALSE}, +sampling efficiency may be increased but some post processing functions +such as \code{\link{bridge_sampler}} will not be available. Can be +controlled globally for the current \R session via the `brms.normalize` +option.} + +\item{control}{A named \code{list} of parameters to control the sampler's +behavior. It defaults to \code{NULL} so all the default values are used. +The most important control parameters are discussed in the 'Details' +section below. For a comprehensive overview see +\code{\link[rstan:stan]{stan}}.} + +\item{algorithm}{Character string naming the estimation approach to use. +Options are \code{"sampling"} for MCMC (the default), \code{"meanfield"} for +variational inference with independent normal distributions, +\code{"fullrank"} for variational inference with a multivariate normal +distribution, or \code{"fixed_param"} for sampling from fixed parameter +values. Can be set globally for the current \R session via the +\code{"brms.algorithm"} option (see \code{\link{options}}).} + +\item{backend}{Character string naming the package to use as the backend for +fitting the Stan model. Options are \code{"rstan"} (the default) or +\code{"cmdstanr"}. Can be set globally for the current \R session via the +\code{"brms.backend"} option (see \code{\link{options}}). Details on the +\pkg{rstan} and \pkg{cmdstanr} packages are available at +\url{https://mc-stan.org/rstan/} and \url{https://mc-stan.org/cmdstanr/}, +respectively. Additionally a \code{"mock"} backend is available to make +testing \pkg{brms} and packages that depend on it easier. +The \code{"mock"} backend does not actually do any fitting, it only checks +the generated Stan code for correctness and then returns whatever is passed +in an additional \code{mock_fit} argument as the result of the fit.} + +\item{future}{Logical; If \code{TRUE}, the \pkg{\link[future:future]{future}} +package is used for parallel execution of the chains and argument +\code{cores} will be ignored. Can be set globally for the current \R +session via the \code{"future"} option. The execution type is controlled via +\code{\link[future:plan]{plan}} (see the examples section below).} + +\item{silent}{Verbosity level between \code{0} and \code{2}. +If \code{1} (the default), most of the +informational messages of compiler and sampler are suppressed. +If \code{2}, even more messages are suppressed. The actual +sampling progress is still printed. Set \code{refresh = 0} to turn this off +as well. If using \code{backend = "rstan"} you can also set +\code{open_progress = FALSE} to prevent opening additional progress bars.} + +\item{seed}{The seed for random number generation to make results +reproducible. If \code{NA} (the default), \pkg{Stan} will set the seed +randomly.} + +\item{save_model}{Either \code{NULL} or a character string. In the latter +case, the model's Stan code is saved via \code{\link{cat}} in a text file +named after the string supplied in \code{save_model}.} + +\item{stan_model_args}{A \code{list} of further arguments passed to +\code{\link[rstan:stan_model]{stan_model}}.} + +\item{file}{Either \code{NULL} or a character string. In the latter case, the +fitted model object is saved via \code{\link{saveRDS}} in a file named +after the string supplied in \code{file}. The \code{.rds} extension is +added automatically. If the file already exists, \code{brm} will load and +return the saved model object instead of refitting the model. +Unless you specify the \code{file_refit} argument as well, the existing +files won't be overwritten, you have to manually remove the file in order +to refit and save the model under an existing file name. The file name +is stored in the \code{brmsfit} object for later usage.} + +\item{file_refit}{Modifies when the fit stored via the \code{file} parameter +is re-used. Can be set globally for the current \R session via the +\code{"brms.file_refit"} option (see \code{\link{options}}). +For \code{"never"} (default) the fit is always loaded if it +exists and fitting is skipped. For \code{"always"} the model is always +refitted. If set to \code{"on_change"}, brms will +refit the model if model, data or algorithm as passed to Stan differ from +what is stored in the file. This also covers changes in priors, +\code{sample_prior}, \code{stanvars}, covariance structure, etc. If you +believe there was a false positive, you can use +\code{\link{brmsfit_needs_refit}} to see why refit is deemed necessary. +Refit will not be triggered for changes in additional parameters of the fit +(e.g., initial values, number of iterations, control arguments, ...). A +known limitation is that a refit will be triggered if within-chain +parallelization is switched on/off.} + +\item{empty}{Logical. If \code{TRUE}, the Stan model is not created +and compiled and the corresponding \code{'fit'} slot of the \code{brmsfit} +object will be empty. This is useful if you have estimated a brms-created +Stan model outside of \pkg{brms} and want to feed it back into the package.} + +\item{rename}{For internal use only.} + +\item{...}{Further arguments passed to Stan. +For \code{backend = "rstan"} the arguments are passed to +\code{\link[rstan]{sampling}} or \code{\link[rstan]{vb}}. +For \code{backend = "cmdstanr"} the arguments are passed to the +\code{cmdstanr::sample} or \code{cmdstanr::variational} method.} +} +\value{ +An object of class \code{brmsfit}, which contains the posterior + draws along with many other useful information about the model. Use + \code{methods(class = "brmsfit")} for an overview on available methods. +} +\description{ +Fit Bayesian generalized (non-)linear multivariate multilevel models +using Stan for full Bayesian inference. A wide range of distributions +and link functions are supported, allowing users to fit -- among others -- +linear, robust linear, count data, survival, response times, ordinal, +zero-inflated, hurdle, and even self-defined mixture models all in a +multilevel context. Further modeling options include non-linear and +smooth terms, auto-correlation structures, censored data, meta-analytic +standard errors, and quite a few more. In addition, all parameters of the +response distributions can be predicted in order to perform distributional +regression. Prior specifications are flexible and explicitly encourage +users to apply prior distributions that actually reflect their beliefs. +In addition, model fit can easily be assessed and compared with +posterior predictive checks and leave-one-out cross-validation. +} +\details{ +Fit a generalized (non-)linear multivariate multilevel model via + full Bayesian inference using Stan. A general overview is provided in the + vignettes \code{vignette("brms_overview")} and + \code{vignette("brms_multilevel")}. For a full list of available vignettes + see \code{vignette(package = "brms")}. + + \bold{Formula syntax of brms models} + + Details of the formula syntax applied in \pkg{brms} can be found in + \code{\link{brmsformula}}. + + \bold{Families and link functions} + + Details of families supported by \pkg{brms} can be found in + \code{\link{brmsfamily}}. + + \bold{Prior distributions} + + Priors should be specified using the + \code{\link[brms:set_prior]{set_prior}} function. Its documentation + contains detailed information on how to correctly specify priors. To find + out on which parameters or parameter classes priors can be defined, use + \code{\link[brms:get_prior]{get_prior}}. Default priors are chosen to be + non or very weakly informative so that their influence on the results will + be negligible and you usually don't have to worry about them. However, + after getting more familiar with Bayesian statistics, I recommend you to + start thinking about reasonable informative priors for your model + parameters: Nearly always, there is at least some prior information + available that can be used to improve your inference. + + \bold{Adjusting the sampling behavior of \pkg{Stan}} + + In addition to choosing the number of iterations, warmup draws, and + chains, users can control the behavior of the NUTS sampler, by using the + \code{control} argument. The most important reason to use \code{control} is + to decrease (or eliminate at best) the number of divergent transitions that + cause a bias in the obtained posterior draws. Whenever you see the + warning "There were x divergent transitions after warmup." you should + really think about increasing \code{adapt_delta}. To do this, write + \code{control = list(adapt_delta = )}, where \code{} should usually + be value between \code{0.8} (current default) and \code{1}. Increasing + \code{adapt_delta} will slow down the sampler but will decrease the number + of divergent transitions threatening the validity of your posterior + draws. + + Another problem arises when the depth of the tree being evaluated in each + iteration is exceeded. This is less common than having divergent + transitions, but may also bias the posterior draws. When it happens, + \pkg{Stan} will throw out a warning suggesting to increase + \code{max_treedepth}, which can be accomplished by writing \code{control = + list(max_treedepth = )} with a positive integer \code{} that should + usually be larger than the current default of \code{10}. For more details + on the \code{control} argument see \code{\link[rstan:stan]{stan}}. +} +\examples{ +\dontrun{ +# Poisson regression for the number of seizures in epileptic patients +# using normal priors for population-level effects +# and half-cauchy priors for standard deviations of group-level effects +prior1 <- prior(normal(0,10), class = b) + + prior(cauchy(0,2), class = sd) +fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson(), prior = prior1) + +# generate a summary of the results +summary(fit1) + +# plot the MCMC chains as well as the posterior distributions +plot(fit1, ask = FALSE) + +# predict responses based on the fitted model +head(predict(fit1)) + +# plot conditional effects for each predictor +plot(conditional_effects(fit1), ask = FALSE) + +# investigate model fit +loo(fit1) +pp_check(fit1) + + +# Ordinal regression modeling patient's rating of inhaler instructions +# category specific effects are estimated for variable 'treat' +fit2 <- brm(rating ~ period + carry + cs(treat), + data = inhaler, family = sratio("logit"), + prior = set_prior("normal(0,5)"), chains = 2) +summary(fit2) +plot(fit2, ask = FALSE) +WAIC(fit2) + + +# Survival regression modeling the time between the first +# and second recurrence of an infection in kidney patients. +fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), + data = kidney, family = lognormal()) +summary(fit3) +plot(fit3, ask = FALSE) +plot(conditional_effects(fit3), ask = FALSE) + + +# Probit regression using the binomial family +ntrials <- sample(1:10, 100, TRUE) +success <- rbinom(100, size = ntrials, prob = 0.4) +x <- rnorm(100) +data4 <- data.frame(ntrials, success, x) +fit4 <- brm(success | trials(ntrials) ~ x, data = data4, + family = binomial("probit")) +summary(fit4) + + +# Non-linear Gaussian model +fit5 <- brm( + bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), + ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, + nl = TRUE), + data = loss, family = gaussian(), + prior = c( + prior(normal(5000, 1000), nlpar = "ult"), + prior(normal(1, 2), nlpar = "omega"), + prior(normal(45, 10), nlpar = "theta") + ), + control = list(adapt_delta = 0.9) +) +summary(fit5) +conditional_effects(fit5) + + +# Normal model with heterogeneous variances +data_het <- data.frame( + y = c(rnorm(50), rnorm(50, 1, 2)), + x = factor(rep(c("a", "b"), each = 50)) +) +fit6 <- brm(bf(y ~ x, sigma ~ 0 + x), data = data_het) +summary(fit6) +plot(fit6) +conditional_effects(fit6) + +# extract estimated residual SDs of both groups +sigmas <- exp(as.data.frame(fit6, variable = "^b_sigma_", regex = TRUE)) +ggplot(stack(sigmas), aes(values)) + + geom_density(aes(fill = ind)) + + +# Quantile regression predicting the 25\%-quantile +fit7 <- brm(bf(y ~ x, quantile = 0.25), data = data_het, + family = asym_laplace()) +summary(fit7) +conditional_effects(fit7) + + +# use the future package for more flexible parallelization +library(future) +plan(multiprocess) +fit7 <- update(fit7, future = TRUE) + + +# fit a model manually via rstan +scode <- make_stancode(count ~ Trt, data = epilepsy) +sdata <- make_standata(count ~ Trt, data = epilepsy) +stanfit <- rstan::stan(model_code = scode, data = sdata) +# feed the Stan model back into brms +fit8 <- brm(count ~ Trt, data = epilepsy, empty = TRUE) +fit8$fit <- stanfit +fit8 <- rename_pars(fit8) +summary(fit8) +} + +} +\references{ +Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel +Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. +\code{doi:10.18637/jss.v080.i01} + +Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling +with the R Package brms. \emph{The R Journal}. 10(1), 395–411. +\code{doi:10.32614/RJ-2018-017} +} +\seealso{ +\code{\link{brms}}, \code{\link{brmsformula}}, +\code{\link{brmsfamily}}, \code{\link{brmsfit}} +} +\author{ +Paul-Christian Buerkner \email{paul.buerkner@gmail.com} +} diff -Nru r-cran-brms-2.16.3/man/brmsfamily.Rd r-cran-brms-2.17.0/man/brmsfamily.Rd --- r-cran-brms-2.16.3/man/brmsfamily.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/brmsfamily.Rd 2022-04-08 12:23:23.000000000 +0000 @@ -1,348 +1,365 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/families.R -\name{brmsfamily} -\alias{brmsfamily} -\alias{student} -\alias{bernoulli} -\alias{negbinomial} -\alias{geometric} -\alias{lognormal} -\alias{shifted_lognormal} -\alias{skew_normal} -\alias{exponential} -\alias{weibull} -\alias{frechet} -\alias{gen_extreme_value} -\alias{exgaussian} -\alias{wiener} -\alias{Beta} -\alias{dirichlet} -\alias{von_mises} -\alias{asym_laplace} -\alias{cox} -\alias{hurdle_poisson} -\alias{hurdle_negbinomial} -\alias{hurdle_gamma} -\alias{hurdle_lognormal} -\alias{zero_inflated_beta} -\alias{zero_one_inflated_beta} -\alias{zero_inflated_poisson} -\alias{zero_inflated_negbinomial} -\alias{zero_inflated_binomial} -\alias{categorical} -\alias{multinomial} -\alias{cumulative} -\alias{sratio} -\alias{cratio} -\alias{acat} -\title{Special Family Functions for \pkg{brms} Models} -\usage{ -brmsfamily( - family, - link = NULL, - link_sigma = "log", - link_shape = "log", - link_nu = "logm1", - link_phi = "log", - link_kappa = "log", - link_beta = "log", - link_zi = "logit", - link_hu = "logit", - link_zoi = "logit", - link_coi = "logit", - link_disc = "log", - link_bs = "log", - link_ndt = "log", - link_bias = "logit", - link_xi = "log1p", - link_alpha = "identity", - link_quantile = "logit", - threshold = "flexible", - refcat = NULL, - bhaz = NULL -) - -student(link = "identity", link_sigma = "log", link_nu = "logm1") - -bernoulli(link = "logit") - -negbinomial(link = "log", link_shape = "log") - -geometric(link = "log") - -lognormal(link = "identity", link_sigma = "log") - -shifted_lognormal(link = "identity", link_sigma = "log", link_ndt = "log") - -skew_normal(link = "identity", link_sigma = "log", link_alpha = "identity") - -exponential(link = "log") - -weibull(link = "log", link_shape = "log") - -frechet(link = "log", link_nu = "logm1") - -gen_extreme_value(link = "identity", link_sigma = "log", link_xi = "log1p") - -exgaussian(link = "identity", link_sigma = "log", link_beta = "log") - -wiener( - link = "identity", - link_bs = "log", - link_ndt = "log", - link_bias = "logit" -) - -Beta(link = "logit", link_phi = "log") - -dirichlet(link = "logit", link_phi = "log", refcat = NULL) - -von_mises(link = "tan_half", link_kappa = "log") - -asym_laplace(link = "identity", link_sigma = "log", link_quantile = "logit") - -cox(link = "log", bhaz = NULL) - -hurdle_poisson(link = "log") - -hurdle_negbinomial(link = "log", link_shape = "log", link_hu = "logit") - -hurdle_gamma(link = "log", link_shape = "log", link_hu = "logit") - -hurdle_lognormal(link = "identity", link_sigma = "log", link_hu = "logit") - -zero_inflated_beta(link = "logit", link_phi = "log", link_zi = "logit") - -zero_one_inflated_beta( - link = "logit", - link_phi = "log", - link_zoi = "logit", - link_coi = "logit" -) - -zero_inflated_poisson(link = "log", link_zi = "logit") - -zero_inflated_negbinomial(link = "log", link_shape = "log", link_zi = "logit") - -zero_inflated_binomial(link = "logit", link_zi = "logit") - -categorical(link = "logit", refcat = NULL) - -multinomial(link = "logit", refcat = NULL) - -cumulative(link = "logit", link_disc = "log", threshold = "flexible") - -sratio(link = "logit", link_disc = "log", threshold = "flexible") - -cratio(link = "logit", link_disc = "log", threshold = "flexible") - -acat(link = "logit", link_disc = "log", threshold = "flexible") -} -\arguments{ -\item{family}{A character string naming the distribution of the response -variable be used in the model. Currently, the following families are -supported: \code{gaussian}, \code{student}, \code{binomial}, -\code{bernoulli}, \code{poisson}, \code{negbinomial}, \code{geometric}, -\code{Gamma}, \code{skew_normal}, \code{lognormal}, -\code{shifted_lognormal}, \code{exgaussian}, \code{wiener}, -\code{inverse.gaussian}, \code{exponential}, \code{weibull}, -\code{frechet}, \code{Beta}, \code{dirichlet}, \code{von_mises}, -\code{asym_laplace}, \code{gen_extreme_value}, \code{categorical}, -\code{multinomial}, \code{cumulative}, \code{cratio}, \code{sratio}, -\code{acat}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, -\code{hurdle_gamma}, \code{hurdle_lognormal}, -\code{zero_inflated_binomial}, \code{zero_inflated_beta}, -\code{zero_inflated_negbinomial}, \code{zero_inflated_poisson}, and -\code{zero_one_inflated_beta}.} - -\item{link}{A specification for the model link function. This can be a -name/expression or character string. See the 'Details' section for more -information on link functions supported by each family.} - -\item{link_sigma}{Link of auxiliary parameter \code{sigma} if being predicted.} - -\item{link_shape}{Link of auxiliary parameter \code{shape} if being predicted.} - -\item{link_nu}{Link of auxiliary parameter \code{nu} if being predicted.} - -\item{link_phi}{Link of auxiliary parameter \code{phi} if being predicted.} - -\item{link_kappa}{Link of auxiliary parameter \code{kappa} if being predicted.} - -\item{link_beta}{Link of auxiliary parameter \code{beta} if being predicted.} - -\item{link_zi}{Link of auxiliary parameter \code{zi} if being predicted.} - -\item{link_hu}{Link of auxiliary parameter \code{hu} if being predicted.} - -\item{link_zoi}{Link of auxiliary parameter \code{zoi} if being predicted.} - -\item{link_coi}{Link of auxiliary parameter \code{coi} if being predicted.} - -\item{link_disc}{Link of auxiliary parameter \code{disc} if being predicted.} - -\item{link_bs}{Link of auxiliary parameter \code{bs} if being predicted.} - -\item{link_ndt}{Link of auxiliary parameter \code{ndt} if being predicted.} - -\item{link_bias}{Link of auxiliary parameter \code{bias} if being predicted.} - -\item{link_xi}{Link of auxiliary parameter \code{xi} if being predicted.} - -\item{link_alpha}{Link of auxiliary parameter \code{alpha} if being predicted.} - -\item{link_quantile}{Link of auxiliary parameter \code{quantile} if being predicted.} - -\item{threshold}{A character string indicating the type -of thresholds (i.e. intercepts) used in an ordinal model. -\code{"flexible"} provides the standard unstructured thresholds, -\code{"equidistant"} restricts the distance between -consecutive thresholds to the same value, and -\code{"sum_to_zero"} ensures the thresholds sum to zero.} - -\item{refcat}{Optional name of the reference response category used in -categorical, multinomial, and dirichlet models. If \code{NULL} (the -default), the first category is used as the reference. If \code{NA}, all -categories will be predicted, which requires strong priors or carefully -specified predictor terms in order to lead to an identified model.} - -\item{bhaz}{Currently for experimental purposes only.} -} -\description{ -Family objects provide a convenient way to specify the details of the models -used by many model fitting functions. The family functions presented here are -for use with \pkg{brms} only and will **not** work with other model -fitting functions such as \code{glm} or \code{glmer}. -However, the standard family functions as described in -\code{\link[stats:family]{family}} will work with \pkg{brms}. -You can also specify custom families for use in \pkg{brms} with -the \code{\link{custom_family}} function. -} -\details{ -Below, we list common use cases for the different families. - This list is not ment to be exhaustive. - \itemize{ - \item{Family \code{gaussian} can be used for linear regression.} - - \item{Family \code{student} can be used for robust linear regression - that is less influenced by outliers.} - - \item{Family \code{skew_normal} can handle skewed responses in linear - regression.} - - \item{Families \code{poisson}, \code{negbinomial}, and \code{geometric} - can be used for regression of unbounded count data.} - - \item{Families \code{bernoulli} and \code{binomial} can be used for - binary regression (i.e., most commonly logistic regression).} - - \item{Families \code{categorical} and \code{multinomial} can be used for - multi-logistic regression when there are more than two possible outcomes.} - - \item{Families \code{cumulative}, \code{cratio} ('continuation ratio'), - \code{sratio} ('stopping ratio'), and \code{acat} ('adjacent category') - leads to ordinal regression.} - - \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, - \code{lognormal}, \code{frechet}, \code{inverse.gaussian}, and \code{cox} - (Cox proportional hazards model) can be used (among others) for - time-to-event regression also known as survival regression.} - - \item{Families \code{weibull}, \code{frechet}, and \code{gen_extreme_value} - ('generalized extreme value') allow for modeling extremes.} - - \item{Families \code{beta} and \code{dirichlet} can be used to model - responses representing rates or probabilities.} - - \item{Family \code{asym_laplace} allows for quantile regression when fixing - the auxiliary \code{quantile} parameter to the quantile of interest.} - - \item{Family \code{exgaussian} ('exponentially modified Gaussian') and - \code{shifted_lognormal} are especially suited to model reaction times.} - - \item{Family \code{wiener} provides an implementation of the Wiener - diffusion model. For this family, the main formula predicts the drift - parameter 'delta' and all other parameters are modeled as auxiliary parameters - (see \code{\link{brmsformula}} for details).} - - \item{Families \code{hurdle_poisson}, \code{hurdle_negbinomial}, - \code{hurdle_gamma}, \code{hurdle_lognormal}, \code{zero_inflated_poisson}, - \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, - \code{zero_inflated_beta}, and \code{zero_one_inflated_beta} - allow to estimate zero-inflated and hurdle models. - These models can be very helpful when there are many zeros in the data - (or ones in case of one-inflated models) - that cannot be explained by the primary distribution of the response.} - } - - Below, we list all possible links for each family. - The first link mentioned for each family is the default. - \itemize{ - \item{Families \code{gaussian}, \code{student}, \code{skew_normal}, - \code{exgaussian}, \code{asym_laplace}, and \code{gen_extreme_value} - support the links (as names) \code{identity}, \code{log}, \code{inverse}, - and \code{softplus}.} - - \item{Families \code{poisson}, \code{negbinomial}, \code{geometric}, - \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, - \code{hurdle_poisson}, and \code{hurdle_negbinomial} support - \code{log}, \code{identity}, \code{sqrt}, and \code{softplus}.} - - \item{Families \code{binomial}, \code{bernoulli}, \code{Beta}, - \code{zero_inflated_binomial}, \code{zero_inflated_beta}, - and \code{zero_one_inflated_beta} support \code{logit}, - \code{probit}, \code{probit_approx}, \code{cloglog}, - \code{cauchit}, and \code{identity}.} - - \item{Families \code{cumulative}, \code{cratio}, \code{sratio}, - and \code{acat} support \code{logit}, \code{probit}, - \code{probit_approx}, \code{cloglog}, and \code{cauchit}.} - - \item{Families \code{categorical}, \code{multinomial}, and \code{dirichlet} - support \code{logit}.} - - \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, - \code{frechet}, and \code{hurdle_gamma} support - \code{log}, \code{identity}, \code{inverse}, and \code{softplus}.} - - \item{Families \code{lognormal} and \code{hurdle_lognormal} - support \code{identity} and \code{inverse}.} - - \item{Family \code{inverse.gaussian} supports \code{1/mu^2}, - \code{inverse}, \code{identity}, \code{log}, and \code{softplus}.} - - \item{Family \code{von_mises} supports \code{tan_half} and - \code{identity}.} - - \item{Family \code{cox} supports \code{log}, \code{identity}, - and \code{softplus} for the proportional hazards parameter.} - - \item{Family \code{wiener} supports \code{identity}, \code{log}, - and \code{softplus} for the main parameter which represents the - drift rate.} - } - - Please note that when calling the \code{\link[stats:family]{Gamma}} family - function of the \pkg{stats} package, the default link will be - \code{inverse} instead of \code{log} although the latter is the default in - \pkg{brms}. Also, when using the family functions \code{gaussian}, - \code{binomial}, \code{poisson}, and \code{Gamma} of the \pkg{stats} - package (see \code{\link[stats:family]{family}}), special link functions - such as \code{softplus} or \code{cauchit} won't work. In this case, you - have to use \code{brmsfamily} to specify the family with corresponding link - function. -} -\examples{ - # create a family object - (fam1 <- student("log")) - # alternatively use the brmsfamily function - (fam2 <- brmsfamily("student", "log")) - # both leads to the same object - identical(fam1, fam2) - -} -\seealso{ -\code{\link[brms:brm]{brm}}, - \code{\link[stats:family]{family}}, - \code{\link{customfamily}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/families.R +\name{brmsfamily} +\alias{brmsfamily} +\alias{student} +\alias{bernoulli} +\alias{beta_binomial} +\alias{negbinomial} +\alias{geometric} +\alias{lognormal} +\alias{shifted_lognormal} +\alias{skew_normal} +\alias{exponential} +\alias{weibull} +\alias{frechet} +\alias{gen_extreme_value} +\alias{exgaussian} +\alias{wiener} +\alias{Beta} +\alias{dirichlet} +\alias{logistic_normal} +\alias{von_mises} +\alias{asym_laplace} +\alias{cox} +\alias{hurdle_poisson} +\alias{hurdle_negbinomial} +\alias{hurdle_gamma} +\alias{hurdle_lognormal} +\alias{zero_inflated_beta} +\alias{zero_one_inflated_beta} +\alias{zero_inflated_poisson} +\alias{zero_inflated_negbinomial} +\alias{zero_inflated_binomial} +\alias{zero_inflated_beta_binomial} +\alias{categorical} +\alias{multinomial} +\alias{cumulative} +\alias{sratio} +\alias{cratio} +\alias{acat} +\title{Special Family Functions for \pkg{brms} Models} +\usage{ +brmsfamily( + family, + link = NULL, + link_sigma = "log", + link_shape = "log", + link_nu = "logm1", + link_phi = "log", + link_kappa = "log", + link_beta = "log", + link_zi = "logit", + link_hu = "logit", + link_zoi = "logit", + link_coi = "logit", + link_disc = "log", + link_bs = "log", + link_ndt = "log", + link_bias = "logit", + link_xi = "log1p", + link_alpha = "identity", + link_quantile = "logit", + threshold = "flexible", + refcat = NULL, + bhaz = NULL +) + +student(link = "identity", link_sigma = "log", link_nu = "logm1") + +bernoulli(link = "logit") + +beta_binomial(link = "logit", link_phi = "log") + +negbinomial(link = "log", link_shape = "log") + +geometric(link = "log") + +lognormal(link = "identity", link_sigma = "log") + +shifted_lognormal(link = "identity", link_sigma = "log", link_ndt = "log") + +skew_normal(link = "identity", link_sigma = "log", link_alpha = "identity") + +exponential(link = "log") + +weibull(link = "log", link_shape = "log") + +frechet(link = "log", link_nu = "logm1") + +gen_extreme_value(link = "identity", link_sigma = "log", link_xi = "log1p") + +exgaussian(link = "identity", link_sigma = "log", link_beta = "log") + +wiener( + link = "identity", + link_bs = "log", + link_ndt = "log", + link_bias = "logit" +) + +Beta(link = "logit", link_phi = "log") + +dirichlet(link = "logit", link_phi = "log", refcat = NULL) + +logistic_normal(link = "identity", link_sigma = "log", refcat = NULL) + +von_mises(link = "tan_half", link_kappa = "log") + +asym_laplace(link = "identity", link_sigma = "log", link_quantile = "logit") + +cox(link = "log", bhaz = NULL) + +hurdle_poisson(link = "log") + +hurdle_negbinomial(link = "log", link_shape = "log", link_hu = "logit") + +hurdle_gamma(link = "log", link_shape = "log", link_hu = "logit") + +hurdle_lognormal(link = "identity", link_sigma = "log", link_hu = "logit") + +zero_inflated_beta(link = "logit", link_phi = "log", link_zi = "logit") + +zero_one_inflated_beta( + link = "logit", + link_phi = "log", + link_zoi = "logit", + link_coi = "logit" +) + +zero_inflated_poisson(link = "log", link_zi = "logit") + +zero_inflated_negbinomial(link = "log", link_shape = "log", link_zi = "logit") + +zero_inflated_binomial(link = "logit", link_zi = "logit") + +zero_inflated_beta_binomial( + link = "logit", + link_phi = "log", + link_zi = "logit" +) + +categorical(link = "logit", refcat = NULL) + +multinomial(link = "logit", refcat = NULL) + +cumulative(link = "logit", link_disc = "log", threshold = "flexible") + +sratio(link = "logit", link_disc = "log", threshold = "flexible") + +cratio(link = "logit", link_disc = "log", threshold = "flexible") + +acat(link = "logit", link_disc = "log", threshold = "flexible") +} +\arguments{ +\item{family}{A character string naming the distribution of the response +variable be used in the model. Currently, the following families are +supported: \code{gaussian}, \code{student}, \code{binomial}, +\code{bernoulli}, \code{beta-binomial}, \code{poisson}, \code{negbinomial}, +\code{geometric}, \code{Gamma}, \code{skew_normal}, \code{lognormal}, +\code{shifted_lognormal}, \code{exgaussian}, \code{wiener}, +\code{inverse.gaussian}, \code{exponential}, \code{weibull}, +\code{frechet}, \code{Beta}, \code{dirichlet}, \code{von_mises}, +\code{asym_laplace}, \code{gen_extreme_value}, \code{categorical}, +\code{multinomial}, \code{cumulative}, \code{cratio}, \code{sratio}, +\code{acat}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, +\code{hurdle_gamma}, \code{hurdle_lognormal}, +\code{zero_inflated_binomial}, \code{zero_inflated_beta_binomial}, +\code{zero_inflated_beta}, \code{zero_inflated_negbinomial}, +\code{zero_inflated_poisson}, and \code{zero_one_inflated_beta}.} + +\item{link}{A specification for the model link function. This can be a +name/expression or character string. See the 'Details' section for more +information on link functions supported by each family.} + +\item{link_sigma}{Link of auxiliary parameter \code{sigma} if being predicted.} + +\item{link_shape}{Link of auxiliary parameter \code{shape} if being predicted.} + +\item{link_nu}{Link of auxiliary parameter \code{nu} if being predicted.} + +\item{link_phi}{Link of auxiliary parameter \code{phi} if being predicted.} + +\item{link_kappa}{Link of auxiliary parameter \code{kappa} if being predicted.} + +\item{link_beta}{Link of auxiliary parameter \code{beta} if being predicted.} + +\item{link_zi}{Link of auxiliary parameter \code{zi} if being predicted.} + +\item{link_hu}{Link of auxiliary parameter \code{hu} if being predicted.} + +\item{link_zoi}{Link of auxiliary parameter \code{zoi} if being predicted.} + +\item{link_coi}{Link of auxiliary parameter \code{coi} if being predicted.} + +\item{link_disc}{Link of auxiliary parameter \code{disc} if being predicted.} + +\item{link_bs}{Link of auxiliary parameter \code{bs} if being predicted.} + +\item{link_ndt}{Link of auxiliary parameter \code{ndt} if being predicted.} + +\item{link_bias}{Link of auxiliary parameter \code{bias} if being predicted.} + +\item{link_xi}{Link of auxiliary parameter \code{xi} if being predicted.} + +\item{link_alpha}{Link of auxiliary parameter \code{alpha} if being predicted.} + +\item{link_quantile}{Link of auxiliary parameter \code{quantile} if being predicted.} + +\item{threshold}{A character string indicating the type +of thresholds (i.e. intercepts) used in an ordinal model. +\code{"flexible"} provides the standard unstructured thresholds, +\code{"equidistant"} restricts the distance between +consecutive thresholds to the same value, and +\code{"sum_to_zero"} ensures the thresholds sum to zero.} + +\item{refcat}{Optional name of the reference response category used in +\code{categorical}, \code{multinomial}, \code{dirichlet} and +\code{logistic_normal} models. If \code{NULL} (the default), the first +category is used as the reference. If \code{NA}, all categories will be +predicted, which requires strong priors or carefully specified predictor +terms in order to lead to an identified model.} + +\item{bhaz}{Currently for experimental purposes only.} +} +\description{ +Family objects provide a convenient way to specify the details of the models +used by many model fitting functions. The family functions presented here are +for use with \pkg{brms} only and will **not** work with other model +fitting functions such as \code{glm} or \code{glmer}. +However, the standard family functions as described in +\code{\link[stats:family]{family}} will work with \pkg{brms}. +You can also specify custom families for use in \pkg{brms} with +the \code{\link{custom_family}} function. +} +\details{ +Below, we list common use cases for the different families. + This list is not ment to be exhaustive. + \itemize{ + \item{Family \code{gaussian} can be used for linear regression.} + + \item{Family \code{student} can be used for robust linear regression + that is less influenced by outliers.} + + \item{Family \code{skew_normal} can handle skewed responses in linear + regression.} + + \item{Families \code{poisson}, \code{negbinomial}, and \code{geometric} + can be used for regression of unbounded count data.} + + \item{Families \code{bernoulli}, \code{binomial}, and \code{beta_binomial} + can be used for binary regression (i.e., most commonly logistic + regression).} + + \item{Families \code{categorical} and \code{multinomial} can be used for + multi-logistic regression when there are more than two possible outcomes.} + + \item{Families \code{cumulative}, \code{cratio} ('continuation ratio'), + \code{sratio} ('stopping ratio'), and \code{acat} ('adjacent category') + leads to ordinal regression.} + + \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, + \code{lognormal}, \code{frechet}, \code{inverse.gaussian}, and \code{cox} + (Cox proportional hazards model) can be used (among others) for + time-to-event regression also known as survival regression.} + + \item{Families \code{weibull}, \code{frechet}, and \code{gen_extreme_value} + ('generalized extreme value') allow for modeling extremes.} + + \item{Families \code{beta}, \code{dirichlet}, and \code{logistic_normal} + can be used to model responses representing rates or probabilities.} + + \item{Family \code{asym_laplace} allows for quantile regression when fixing + the auxiliary \code{quantile} parameter to the quantile of interest.} + + \item{Family \code{exgaussian} ('exponentially modified Gaussian') and + \code{shifted_lognormal} are especially suited to model reaction times.} + + \item{Family \code{wiener} provides an implementation of the Wiener + diffusion model. For this family, the main formula predicts the drift + parameter 'delta' and all other parameters are modeled as auxiliary parameters + (see \code{\link{brmsformula}} for details).} + + \item{Families \code{hurdle_poisson}, \code{hurdle_negbinomial}, + \code{hurdle_gamma}, \code{hurdle_lognormal}, \code{zero_inflated_poisson}, + \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, + \code{zero_inflated_beta_binomial}, \code{zero_inflated_beta}, and + \code{zero_one_inflated_beta} allow to estimate zero-inflated and hurdle + models. These models can be very helpful when there are many zeros in the + data (or ones in case of one-inflated models) + that cannot be explained by the primary distribution of the response.} + } + + Below, we list all possible links for each family. + The first link mentioned for each family is the default. + \itemize{ + \item{Families \code{gaussian}, \code{student}, \code{skew_normal}, + \code{exgaussian}, \code{asym_laplace}, and \code{gen_extreme_value} + support the links (as names) \code{identity}, \code{log}, \code{inverse}, + and \code{softplus}.} + + \item{Families \code{poisson}, \code{negbinomial}, \code{geometric}, + \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, + \code{hurdle_poisson}, and \code{hurdle_negbinomial} support + \code{log}, \code{identity}, \code{sqrt}, and \code{softplus}.} + + \item{Families \code{binomial}, \code{bernoulli}, \code{beta_binomial}, + \code{zero_inflated_binomial}, \code{zero_inflated_beta_binomial}, + \code{Beta}, \code{zero_inflated_beta}, and \code{zero_one_inflated_beta} + support \code{logit}, \code{probit}, \code{probit_approx}, \code{cloglog}, + \code{cauchit}, \code{identity}, and \code{log}.} + + \item{Families \code{cumulative}, \code{cratio}, \code{sratio}, + and \code{acat} support \code{logit}, \code{probit}, + \code{probit_approx}, \code{cloglog}, and \code{cauchit}.} + + \item{Families \code{categorical}, \code{multinomial}, and \code{dirichlet} + support \code{logit}.} + + \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, + \code{frechet}, and \code{hurdle_gamma} support + \code{log}, \code{identity}, \code{inverse}, and \code{softplus}.} + + \item{Families \code{lognormal} and \code{hurdle_lognormal} + support \code{identity} and \code{inverse}.} + + \item{Family \code{logistic_normal} supports \code{identity}.} + + \item{Family \code{inverse.gaussian} supports \code{1/mu^2}, + \code{inverse}, \code{identity}, \code{log}, and \code{softplus}.} + + \item{Family \code{von_mises} supports \code{tan_half} and + \code{identity}.} + + \item{Family \code{cox} supports \code{log}, \code{identity}, + and \code{softplus} for the proportional hazards parameter.} + + \item{Family \code{wiener} supports \code{identity}, \code{log}, + and \code{softplus} for the main parameter which represents the + drift rate.} + } + + Please note that when calling the \code{\link[stats:family]{Gamma}} family + function of the \pkg{stats} package, the default link will be + \code{inverse} instead of \code{log} although the latter is the default in + \pkg{brms}. Also, when using the family functions \code{gaussian}, + \code{binomial}, \code{poisson}, and \code{Gamma} of the \pkg{stats} + package (see \code{\link[stats:family]{family}}), special link functions + such as \code{softplus} or \code{cauchit} won't work. In this case, you + have to use \code{brmsfamily} to specify the family with corresponding link + function. +} +\examples{ + # create a family object + (fam1 <- student("log")) + # alternatively use the brmsfamily function + (fam2 <- brmsfamily("student", "log")) + # both leads to the same object + identical(fam1, fam2) + +} +\seealso{ +\code{\link[brms:brm]{brm}}, + \code{\link[stats:family]{family}}, + \code{\link{customfamily}} +} diff -Nru r-cran-brms-2.16.3/man/brmsfit-class.Rd r-cran-brms-2.17.0/man/brmsfit-class.Rd --- r-cran-brms-2.16.3/man/brmsfit-class.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/brmsfit-class.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,76 +1,76 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-class.R -\docType{class} -\name{brmsfit-class} -\alias{brmsfit-class} -\alias{brmsfit} -\title{Class \code{brmsfit} of models fitted with the \pkg{brms} package} -\description{ -Models fitted with the \code{\link[brms:brms-package]{brms}} package are -represented as a \code{brmsfit} object, which contains the posterior -draws (samples), model formula, Stan code, relevant data, and other information. -} -\details{ -See \code{methods(class = "brmsfit")} for an overview of available methods. -} -\section{Slots}{ - -\describe{ -\item{\code{formula}}{A \code{\link{brmsformula}} object.} - -\item{\code{data}}{A \code{data.frame} containing all variables used in the model.} - -\item{\code{data2}}{A \code{list} of data objects which cannot be passed -via \code{data}.} - -\item{\code{prior}}{A \code{\link{brmsprior}} object containing -information on the priors used in the model.} - -\item{\code{stanvars}}{A \code{\link{stanvars}} object.} - -\item{\code{model}}{The model code in \pkg{Stan} language.} - -\item{\code{ranef}}{A \code{data.frame} containing the group-level structure.} - -\item{\code{exclude}}{The names of the parameters for which draws are not saved.} - -\item{\code{algorithm}}{The name of the algorithm used to fit the model.} - -\item{\code{backend}}{The name of the backend used to fit the model.} - -\item{\code{threads}}{An object of class `brmsthreads` created by -\code{\link{threading}}.} - -\item{\code{opencl}}{An object of class `brmsopencl` created by \code{\link{opencl}}.} - -\item{\code{fit}}{An object of class \code{\link[rstan:stanfit-class]{stanfit}} -among others containing the posterior draws.} - -\item{\code{criteria}}{An empty \code{list} for adding model fit criteria -after estimation of the model.} - -\item{\code{file}}{Optional name of a file in which the model object was stored in -or loaded from.} - -\item{\code{version}}{The versions of \pkg{brms} and \pkg{rstan} with -which the model was fitted.} - -\item{\code{family}}{(Deprecated) A \code{\link{brmsfamily}} object.} - -\item{\code{autocor}}{(Deprecated) An \code{\link{cor_brms}} object containing -the autocorrelation structure if specified.} - -\item{\code{cov_ranef}}{(Deprecated) A \code{list} of customized group-level -covariance matrices.} - -\item{\code{stan_funs}}{(Deprecated) A character string of length one or \code{NULL}.} - -\item{\code{data.name}}{(Deprecated) The name of \code{data} as specified by the user.} -}} - -\seealso{ -\code{\link{brms}}, - \code{\link{brm}}, - \code{\link{brmsformula}}, - \code{\link{brmsfamily}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-class.R +\docType{class} +\name{brmsfit-class} +\alias{brmsfit-class} +\alias{brmsfit} +\title{Class \code{brmsfit} of models fitted with the \pkg{brms} package} +\description{ +Models fitted with the \code{\link[brms:brms-package]{brms}} package are +represented as a \code{brmsfit} object, which contains the posterior +draws (samples), model formula, Stan code, relevant data, and other information. +} +\details{ +See \code{methods(class = "brmsfit")} for an overview of available methods. +} +\section{Slots}{ + +\describe{ +\item{\code{formula}}{A \code{\link{brmsformula}} object.} + +\item{\code{data}}{A \code{data.frame} containing all variables used in the model.} + +\item{\code{data2}}{A \code{list} of data objects which cannot be passed +via \code{data}.} + +\item{\code{prior}}{A \code{\link{brmsprior}} object containing +information on the priors used in the model.} + +\item{\code{stanvars}}{A \code{\link{stanvars}} object.} + +\item{\code{model}}{The model code in \pkg{Stan} language.} + +\item{\code{ranef}}{A \code{data.frame} containing the group-level structure.} + +\item{\code{exclude}}{The names of the parameters for which draws are not saved.} + +\item{\code{algorithm}}{The name of the algorithm used to fit the model.} + +\item{\code{backend}}{The name of the backend used to fit the model.} + +\item{\code{threads}}{An object of class `brmsthreads` created by +\code{\link{threading}}.} + +\item{\code{opencl}}{An object of class `brmsopencl` created by \code{\link{opencl}}.} + +\item{\code{fit}}{An object of class \code{\link[rstan:stanfit-class]{stanfit}} +among others containing the posterior draws.} + +\item{\code{criteria}}{An empty \code{list} for adding model fit criteria +after estimation of the model.} + +\item{\code{file}}{Optional name of a file in which the model object was stored in +or loaded from.} + +\item{\code{version}}{The versions of \pkg{brms} and \pkg{rstan} with +which the model was fitted.} + +\item{\code{family}}{(Deprecated) A \code{\link{brmsfamily}} object.} + +\item{\code{autocor}}{(Deprecated) An \code{\link{cor_brms}} object containing +the autocorrelation structure if specified.} + +\item{\code{cov_ranef}}{(Deprecated) A \code{list} of customized group-level +covariance matrices.} + +\item{\code{stan_funs}}{(Deprecated) A character string of length one or \code{NULL}.} + +\item{\code{data.name}}{(Deprecated) The name of \code{data} as specified by the user.} +}} + +\seealso{ +\code{\link{brms}}, + \code{\link{brm}}, + \code{\link{brmsformula}}, + \code{\link{brmsfamily}} +} diff -Nru r-cran-brms-2.16.3/man/brmsfit_needs_refit.Rd r-cran-brms-2.17.0/man/brmsfit_needs_refit.Rd --- r-cran-brms-2.16.3/man/brmsfit_needs_refit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/brmsfit_needs_refit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,50 +1,50 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-helpers.R -\name{brmsfit_needs_refit} -\alias{brmsfit_needs_refit} -\title{Check if cached fit can be used.} -\usage{ -brmsfit_needs_refit( - fit, - sdata = NULL, - scode = NULL, - data = NULL, - algorithm = NULL, - silent = FALSE, - verbose = FALSE -) -} -\arguments{ -\item{fit}{Old \code{brmsfit} object (e.g., loaded from file).} - -\item{sdata}{New Stan data (result of a call to \code{\link{make_standata}}). -Pass \code{NULL} to avoid this data check.} - -\item{scode}{New Stan code (result of a call to \code{\link{make_stancode}}). -Pass \code{NULL} to avoid this code check.} - -\item{data}{New data to check consistency of factor level names. -Pass \code{NULL} to avoid this data check.} - -\item{algorithm}{New algorithm. Pass \code{NULL} to avoid algorithm check.} - -\item{silent}{Logical. If \code{TRUE}, no messages will be given.} - -\item{verbose}{Logical. If \code{TRUE} detailed report of the differences -is printed to the console.} -} -\value{ -A boolean indicating whether a refit is needed. -} -\description{ -Checks whether a given cached fit can be used without refitting when -\code{file_refit = "on_change"} is used. -This function is internal and exposed only to facilitate debugging problems -with cached fits. The function may change or be removed in future versions -and scripts should not use it. -} -\details{ -Use with \code{verbose = TRUE} to get additional info on how the stored -fit differs from the given data and code. -} -\keyword{internal} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-helpers.R +\name{brmsfit_needs_refit} +\alias{brmsfit_needs_refit} +\title{Check if cached fit can be used.} +\usage{ +brmsfit_needs_refit( + fit, + sdata = NULL, + scode = NULL, + data = NULL, + algorithm = NULL, + silent = FALSE, + verbose = FALSE +) +} +\arguments{ +\item{fit}{Old \code{brmsfit} object (e.g., loaded from file).} + +\item{sdata}{New Stan data (result of a call to \code{\link{make_standata}}). +Pass \code{NULL} to avoid this data check.} + +\item{scode}{New Stan code (result of a call to \code{\link{make_stancode}}). +Pass \code{NULL} to avoid this code check.} + +\item{data}{New data to check consistency of factor level names. +Pass \code{NULL} to avoid this data check.} + +\item{algorithm}{New algorithm. Pass \code{NULL} to avoid algorithm check.} + +\item{silent}{Logical. If \code{TRUE}, no messages will be given.} + +\item{verbose}{Logical. If \code{TRUE} detailed report of the differences +is printed to the console.} +} +\value{ +A boolean indicating whether a refit is needed. +} +\description{ +Checks whether a given cached fit can be used without refitting when +\code{file_refit = "on_change"} is used. +This function is internal and exposed only to facilitate debugging problems +with cached fits. The function may change or be removed in future versions +and scripts should not use it. +} +\details{ +Use with \code{verbose = TRUE} to get additional info on how the stored +fit differs from the given data and code. +} +\keyword{internal} diff -Nru r-cran-brms-2.16.3/man/brmsformula-helpers.Rd r-cran-brms-2.17.0/man/brmsformula-helpers.Rd --- r-cran-brms-2.16.3/man/brmsformula-helpers.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/brmsformula-helpers.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,134 +1,134 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsformula.R -\name{brmsformula-helpers} -\alias{brmsformula-helpers} -\alias{bf-helpers} -\alias{nlf} -\alias{lf} -\alias{set_nl} -\alias{set_rescor} -\alias{acformula} -\alias{set_mecor} -\title{Linear and Non-linear formulas in \pkg{brms}} -\usage{ -nlf(formula, ..., flist = NULL, dpar = NULL, resp = NULL, loop = NULL) - -lf( - ..., - flist = NULL, - dpar = NULL, - resp = NULL, - center = NULL, - cmc = NULL, - sparse = NULL, - decomp = NULL -) - -acformula(autocor, resp = NULL) - -set_nl(nl = TRUE, dpar = NULL, resp = NULL) - -set_rescor(rescor = TRUE) - -set_mecor(mecor = TRUE) -} -\arguments{ -\item{formula}{Non-linear formula for a distributional parameter. -The name of the distributional parameter can either be specified -on the left-hand side of \code{formula} or via argument \code{dpar}.} - -\item{...}{Additional \code{formula} objects to specify predictors of -non-linear and distributional parameters. Formulas can either be named -directly or contain names on their left-hand side. Alternatively, -it is possible to fix parameters to certain values by passing -numbers or character strings in which case arguments have to be named -to provide the parameter names. See 'Details' for more information.} - -\item{flist}{Optional list of formulas, which are treated in the -same way as formulas passed via the \code{...} argument.} - -\item{dpar}{Optional character string specifying the distributional -parameter to which the formulas passed via \code{...} and -\code{flist} belong.} - -\item{resp}{Optional character string specifying the response -variable to which the formulas passed via \code{...} and -\code{flist} belong. Only relevant in multivariate models.} - -\item{loop}{Logical; Only used in non-linear models. -Indicates if the computation of the non-linear formula should be -done inside (\code{TRUE}) or outside (\code{FALSE}) a loop -over observations. Defaults to \code{TRUE}.} - -\item{center}{Logical; Indicates if the population-level design -matrix should be centered, which usually increases sampling efficiency. -See the 'Details' section for more information. -Defaults to \code{TRUE} for distributional parameters -and to \code{FALSE} for non-linear parameters.} - -\item{cmc}{Logical; Indicates whether automatic cell-mean coding -should be enabled when removing the intercept by adding \code{0} -to the right-hand of model formulas. Defaults to \code{TRUE} to -mirror the behavior of standard \R formula parsing.} - -\item{sparse}{Logical; indicates whether the population-level design matrices -should be treated as sparse (defaults to \code{FALSE}). For design matrices -with many zeros, this can considerably reduce required memory. Sampling -speed is currently not improved or even slightly decreased.} - -\item{decomp}{Optional name of the decomposition used for the -population-level design matrix. Defaults to \code{NULL} that is -no decomposition. Other options currently available are -\code{"QR"} for the QR decomposition that helps in fitting models -with highly correlated predictors.} - -\item{autocor}{A one sided formula containing autocorrelation -terms. All none autocorrelation terms in \code{autocor} will -be silently ignored.} - -\item{nl}{Logical; Indicates whether \code{formula} should be -treated as specifying a non-linear model. By default, \code{formula} -is treated as an ordinary linear model formula.} - -\item{rescor}{Logical; Indicates if residual correlation between -the response variables should be modeled. Currently this is only -possible in multivariate \code{gaussian} and \code{student} models. -Only relevant in multivariate models.} - -\item{mecor}{Logical; Indicates if correlations between latent variables -defined by \code{\link{me}} terms should be modeled. Defaults to \code{TRUE}.} -} -\value{ -For \code{lf} and \code{nlf} a \code{list} that can be - passed to \code{\link[brms:brmsformula]{brmsformula}} or added - to an existing \code{brmsformula} or \code{mvbrmsformula} object. - For \code{set_nl} and \code{set_rescor} a logical value that can be - added to an existing \code{brmsformula} or \code{mvbrmsformula} object. -} -\description{ -Helper functions to specify linear and non-linear -formulas for use with \code{\link[brms:brmsformula]{brmsformula}}. -} -\examples{ -# add more formulas to the model -bf(y ~ 1) + - nlf(sigma ~ a * exp(b * x)) + - lf(a ~ x, b ~ z + (1|g)) + - gaussian() - -# specify 'nl' later on -bf(y ~ a * inv_logit(x * b)) + - lf(a + b ~ z) + - set_nl(TRUE) - -# specify a multivariate model -bf(y1 ~ x + (1|g)) + - bf(y2 ~ z) + - set_rescor(TRUE) - -# add autocorrelation terms -bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(W)) -} -\seealso{ -\code{\link{brmsformula}}, \code{\link{mvbrmsformula}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsformula.R +\name{brmsformula-helpers} +\alias{brmsformula-helpers} +\alias{bf-helpers} +\alias{nlf} +\alias{lf} +\alias{set_nl} +\alias{set_rescor} +\alias{acformula} +\alias{set_mecor} +\title{Linear and Non-linear formulas in \pkg{brms}} +\usage{ +nlf(formula, ..., flist = NULL, dpar = NULL, resp = NULL, loop = NULL) + +lf( + ..., + flist = NULL, + dpar = NULL, + resp = NULL, + center = NULL, + cmc = NULL, + sparse = NULL, + decomp = NULL +) + +acformula(autocor, resp = NULL) + +set_nl(nl = TRUE, dpar = NULL, resp = NULL) + +set_rescor(rescor = TRUE) + +set_mecor(mecor = TRUE) +} +\arguments{ +\item{formula}{Non-linear formula for a distributional parameter. +The name of the distributional parameter can either be specified +on the left-hand side of \code{formula} or via argument \code{dpar}.} + +\item{...}{Additional \code{formula} objects to specify predictors of +non-linear and distributional parameters. Formulas can either be named +directly or contain names on their left-hand side. Alternatively, +it is possible to fix parameters to certain values by passing +numbers or character strings in which case arguments have to be named +to provide the parameter names. See 'Details' for more information.} + +\item{flist}{Optional list of formulas, which are treated in the +same way as formulas passed via the \code{...} argument.} + +\item{dpar}{Optional character string specifying the distributional +parameter to which the formulas passed via \code{...} and +\code{flist} belong.} + +\item{resp}{Optional character string specifying the response +variable to which the formulas passed via \code{...} and +\code{flist} belong. Only relevant in multivariate models.} + +\item{loop}{Logical; Only used in non-linear models. +Indicates if the computation of the non-linear formula should be +done inside (\code{TRUE}) or outside (\code{FALSE}) a loop +over observations. Defaults to \code{TRUE}.} + +\item{center}{Logical; Indicates if the population-level design +matrix should be centered, which usually increases sampling efficiency. +See the 'Details' section for more information. +Defaults to \code{TRUE} for distributional parameters +and to \code{FALSE} for non-linear parameters.} + +\item{cmc}{Logical; Indicates whether automatic cell-mean coding +should be enabled when removing the intercept by adding \code{0} +to the right-hand of model formulas. Defaults to \code{TRUE} to +mirror the behavior of standard \R formula parsing.} + +\item{sparse}{Logical; indicates whether the population-level design matrices +should be treated as sparse (defaults to \code{FALSE}). For design matrices +with many zeros, this can considerably reduce required memory. Sampling +speed is currently not improved or even slightly decreased.} + +\item{decomp}{Optional name of the decomposition used for the +population-level design matrix. Defaults to \code{NULL} that is +no decomposition. Other options currently available are +\code{"QR"} for the QR decomposition that helps in fitting models +with highly correlated predictors.} + +\item{autocor}{A one sided formula containing autocorrelation +terms. All none autocorrelation terms in \code{autocor} will +be silently ignored.} + +\item{nl}{Logical; Indicates whether \code{formula} should be +treated as specifying a non-linear model. By default, \code{formula} +is treated as an ordinary linear model formula.} + +\item{rescor}{Logical; Indicates if residual correlation between +the response variables should be modeled. Currently this is only +possible in multivariate \code{gaussian} and \code{student} models. +Only relevant in multivariate models.} + +\item{mecor}{Logical; Indicates if correlations between latent variables +defined by \code{\link{me}} terms should be modeled. Defaults to \code{TRUE}.} +} +\value{ +For \code{lf} and \code{nlf} a \code{list} that can be + passed to \code{\link[brms:brmsformula]{brmsformula}} or added + to an existing \code{brmsformula} or \code{mvbrmsformula} object. + For \code{set_nl} and \code{set_rescor} a logical value that can be + added to an existing \code{brmsformula} or \code{mvbrmsformula} object. +} +\description{ +Helper functions to specify linear and non-linear +formulas for use with \code{\link[brms:brmsformula]{brmsformula}}. +} +\examples{ +# add more formulas to the model +bf(y ~ 1) + + nlf(sigma ~ a * exp(b * x)) + + lf(a ~ x, b ~ z + (1|g)) + + gaussian() + +# specify 'nl' later on +bf(y ~ a * inv_logit(x * b)) + + lf(a + b ~ z) + + set_nl(TRUE) + +# specify a multivariate model +bf(y1 ~ x + (1|g)) + + bf(y2 ~ z) + + set_rescor(TRUE) + +# add autocorrelation terms +bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(W)) +} +\seealso{ +\code{\link{brmsformula}}, \code{\link{mvbrmsformula}} +} diff -Nru r-cran-brms-2.16.3/man/brmsformula.Rd r-cran-brms-2.17.0/man/brmsformula.Rd --- r-cran-brms-2.16.3/man/brmsformula.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/brmsformula.Rd 2022-04-08 11:57:41.000000000 +0000 @@ -1,683 +1,683 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsformula.R -\name{brmsformula} -\alias{brmsformula} -\alias{bf} -\title{Set up a model formula for use in \pkg{brms}} -\usage{ -brmsformula( - formula, - ..., - flist = NULL, - family = NULL, - autocor = NULL, - nl = NULL, - loop = NULL, - center = NULL, - cmc = NULL, - sparse = NULL, - decomp = NULL, - unused = NULL -) -} -\arguments{ -\item{formula}{An object of class \code{formula} -(or one that can be coerced to that class): -a symbolic description of the model to be fitted. -The details of model specification are given in 'Details'.} - -\item{...}{Additional \code{formula} objects to specify predictors of -non-linear and distributional parameters. Formulas can either be named -directly or contain names on their left-hand side. Alternatively, -it is possible to fix parameters to certain values by passing -numbers or character strings in which case arguments have to be named -to provide the parameter names. See 'Details' for more information.} - -\item{flist}{Optional list of formulas, which are treated in the -same way as formulas passed via the \code{...} argument.} - -\item{family}{Same argument as in \code{\link{brm}}. -If \code{family} is specified in \code{brmsformula}, it will -overwrite the value specified in other functions.} - -\item{autocor}{An optional \code{formula} which contains -autocorrelation terms as described in \code{\link{autocor-terms}} -or alternatively a \code{\link{cor_brms}} object (deprecated). -If \code{autocor} is specified in \code{brmsformula}, it will -overwrite the value specified in other functions.} - -\item{nl}{Logical; Indicates whether \code{formula} should be -treated as specifying a non-linear model. By default, \code{formula} -is treated as an ordinary linear model formula.} - -\item{loop}{Logical; Only used in non-linear models. -Indicates if the computation of the non-linear formula should be -done inside (\code{TRUE}) or outside (\code{FALSE}) a loop -over observations. Defaults to \code{TRUE}.} - -\item{center}{Logical; Indicates if the population-level design -matrix should be centered, which usually increases sampling efficiency. -See the 'Details' section for more information. -Defaults to \code{TRUE} for distributional parameters -and to \code{FALSE} for non-linear parameters.} - -\item{cmc}{Logical; Indicates whether automatic cell-mean coding -should be enabled when removing the intercept by adding \code{0} -to the right-hand of model formulas. Defaults to \code{TRUE} to -mirror the behavior of standard \R formula parsing.} - -\item{sparse}{Logical; indicates whether the population-level design matrices -should be treated as sparse (defaults to \code{FALSE}). For design matrices -with many zeros, this can considerably reduce required memory. Sampling -speed is currently not improved or even slightly decreased.} - -\item{decomp}{Optional name of the decomposition used for the -population-level design matrix. Defaults to \code{NULL} that is -no decomposition. Other options currently available are -\code{"QR"} for the QR decomposition that helps in fitting models -with highly correlated predictors.} - -\item{unused}{An optional \code{formula} which contains variables -that are unused in the model but should still be stored in the -model's data frame. This can be useful, for example, -if those variables are required for post-processing the model.} -} -\value{ -An object of class \code{brmsformula}, which - is essentially a \code{list} containing all model - formulas as well as some additional information. -} -\description{ -Set up a model formula for use in the \pkg{brms} package -allowing to define (potentially non-linear) additive multilevel -models for all parameters of the assumed response distribution. -} -\details{ -\bold{General formula structure} - - The \code{formula} argument accepts formulas of the following syntax: - - \code{response | aterms ~ pterms + (gterms | group)} - - The \code{pterms} part contains effects that are assumed to be the same - across observations. We call them 'population-level' or 'overall' effects, - or (adopting frequentist vocabulary) 'fixed' effects. The optional - \code{gterms} part may contain effects that are assumed to vary across - grouping variables specified in \code{group}. We call them 'group-level' or - 'varying' effects, or (adopting frequentist vocabulary) 'random' effects, - although the latter name is misleading in a Bayesian context. For more - details type \code{vignette("brms_overview")} and - \code{vignette("brms_multilevel")}. - - \bold{Group-level terms} - - Multiple grouping factors each with multiple group-level effects are - possible. (Of course we can also run models without any group-level - effects.) Instead of \code{|} you may use \code{||} in grouping terms to - prevent correlations from being modeled. Equivalently, the \code{cor} - argument of the \code{\link{gr}} function can be used for this purpose, - for example, \code{(1 + x || g)} is equivalent to - \code{(1 + x | gr(g, cor = FALSE))}. - - It is also possible to model different group-level terms of the same - grouping factor as correlated (even across different formulas, e.g., in - non-linear models) by using \code{||} instead of \code{|}. All - group-level terms sharing the same ID will be modeled as correlated. If, - for instance, one specifies the terms \code{(1+x|i|g)} and \code{(1+z|i|g)} - somewhere in the formulas passed to \code{brmsformula}, correlations - between the corresponding group-level effects will be estimated. In the - above example, \code{i} is not a variable in the data but just a symbol to - indicate correlations between multiple group-level terms. Equivalently, the - \code{id} argument of the \code{\link{gr}} function can be used as well, - for example, \code{(1 + x | gr(g, id = "i"))}. - - If levels of the grouping factor belong to different sub-populations, - it may be reasonable to assume a different covariance matrix for each - of the sub-populations. For instance, the variation within the - treatment group and within the control group in a randomized control - trial might differ. Suppose that \code{y} is the outcome, and - \code{x} is the factor indicating the treatment and control group. - Then, we could estimate different hyper-parameters of the varying - effects (in this case a varying intercept) for treatment and control - group via \code{y ~ x + (1 | gr(subject, by = x))}. - - You can specify multi-membership terms using the \code{\link{mm}} - function. For instance, a multi-membership term with two members - could be \code{(1 | mm(g1, g2))}, where \code{g1} and \code{g2} - specify the first and second member, respectively. Moreover, - if a covariate \code{x} varies across the levels of the grouping-factors - \code{g1} and \code{g2}, we can save the respective covariate values - in the variables \code{x1} and \code{x2} and then model the varying - effect as \code{(1 + mmc(x1, x2) | mm(g1, g2))}. - - \bold{Special predictor terms} - - Flexible non-linear smooth terms can modeled using the \code{\link{s}} - and \code{\link{t2}} functions in the \code{pterms} part - of the model formula. This allows to fit generalized additive mixed - models (GAMMs) with \pkg{brms}. The implementation is similar to that - used in the \pkg{gamm4} package. For more details on this model class - see \code{\link[mgcv:gam]{gam}} and \code{\link[mgcv:gamm]{gamm}}. - - Gaussian process terms can be fitted using the \code{\link{gp}} - function in the \code{pterms} part of the model formula. Similar to - smooth terms, Gaussian processes can be used to model complex non-linear - relationships, for instance temporal or spatial autocorrelation. - However, they are computationally demanding and are thus not recommended - for very large datasets or approximations need to be used. - - The \code{pterms} and \code{gterms} parts may contain four non-standard - effect types namely monotonic, measurement error, missing value, and - category specific effects, which can be specified using terms of the - form \code{mo(predictor)}, \code{me(predictor, sd_predictor)}, - \code{mi(predictor)}, and \code{cs()}, respectively. - Category specific effects can only be estimated in - ordinal models and are explained in more detail in the package's - main vignette (type \code{vignette("brms_overview")}). - The other three effect types are explained in the following. - - A monotonic predictor must either be integer valued or an ordered factor, - which is the first difference to an ordinary continuous predictor. - More importantly, predictor categories (or integers) are not assumed to be - equidistant with respect to their effect on the response variable. - Instead, the distance between adjacent predictor categories (or integers) - is estimated from the data and may vary across categories. - This is realized by parameterizing as follows: - One parameter takes care of the direction and size of the effect similar - to an ordinary regression parameter, while an additional parameter vector - estimates the normalized distances between consecutive predictor categories. - A main application of monotonic effects are ordinal predictors that - can this way be modeled without (falsely) treating them as continuous - or as unordered categorical predictors. For more details and examples - see \code{vignette("brms_monotonic")}. - - Quite often, predictors are measured and as such naturally contain - measurement error. Although most researchers are well aware of this problem, - measurement error in predictors is ignored in most - regression analyses, possibly because only few packages allow - for modeling it. Notably, measurement error can be handled in - structural equation models, but many more general regression models - (such as those featured by \pkg{brms}) cannot be transferred - to the SEM framework. In \pkg{brms}, effects of noise-free predictors - can be modeled using the \code{me} (for 'measurement error') function. - If, say, \code{y} is the response variable and - \code{x} is a measured predictor with known measurement error - \code{sdx}, we can simply include it on the right-hand side of the - model formula via \code{y ~ me(x, sdx)}. - This can easily be extended to more general formulas. - If \code{x2} is another measured predictor with corresponding error - \code{sdx2} and \code{z} is a predictor without error - (e.g., an experimental setting), we can model all main effects - and interactions of the three predictors in the well known manner: - \code{y ~ me(x, sdx) * me(x2, sdx2) * z}. - The \code{me} function is soft deprecated in favor of the more flexible - and consistent \code{mi} function (see below). - - When a variable contains missing values, the corresponding rows will - be excluded from the data by default (row-wise exclusion). However, - quite often we want to keep these rows and instead estimate the missing values. - There are two approaches for this: (a) Impute missing values before - the model fitting for instance via multiple imputation (see - \code{\link{brm_multiple}} for a way to handle multiple imputed datasets). - (b) Impute missing values on the fly during model fitting. The latter - approach is explained in the following. Using a variable with missing - values as predictors requires two things, First, we need to specify that - the predictor contains missings that should to be imputed. - If, say, \code{y} is the primary response, \code{x} is a - predictor with missings and \code{z} is a predictor without missings, - we go for \code{y ~ mi(x) + z}. Second, we need to model \code{x} - as an additional response with corresponding predictors and the - addition term \code{mi()}. In our example, we could write - \code{x | mi() ~ z}. Measurement error may be included via - the \code{sdy} argument, say, \code{x | mi(sdy = se) ~ z}. - See \code{\link{mi}} for examples with real data. - - - \bold{Autocorrelation terms} - - Autocorrelation terms can be directly specified inside the \code{pterms} - part as well. Details can be found in \code{\link{autocor-terms}}. - - \bold{Additional response information} - - Another special of the \pkg{brms} formula syntax is the optional - \code{aterms} part, which may contain multiple terms of the form - \code{fun()} separated by \code{+} each providing special - information on the response variable. \code{fun} can be replaced with - either \code{se}, \code{weights}, \code{subset}, \code{cens}, \code{trunc}, - \code{trials}, \code{cat}, \code{dec}, \code{rate}, \code{vreal}, or - \code{vint}. Their meanings are explained below. - (see also \code{\link{addition-terms}}). - - For families \code{gaussian}, \code{student} and \code{skew_normal}, it is - possible to specify standard errors of the observations, thus allowing - to perform meta-analysis. Suppose that the variable \code{yi} contains - the effect sizes from the studies and \code{sei} the corresponding - standard errors. Then, fixed and random effects meta-analyses can - be conducted using the formulas \code{yi | se(sei) ~ 1} and - \code{yi | se(sei) ~ 1 + (1|study)}, respectively, where - \code{study} is a variable uniquely identifying every study. - If desired, meta-regression can be performed via - \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1|study)} - or \cr \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1 + mod1 + mod2|study)}, - where \code{mod1} and \code{mod2} represent moderator variables. - By default, the standard errors replace the parameter \code{sigma}. - To model \code{sigma} in addition to the known standard errors, - set argument \code{sigma} in function \code{se} to \code{TRUE}, - for instance, \code{yi | se(sei, sigma = TRUE) ~ 1}. - - For all families, weighted regression may be performed using - \code{weights} in the \code{aterms} part. Internally, this is - implemented by multiplying the log-posterior values of each - observation by their corresponding weights. - Suppose that variable \code{wei} contains the weights - and that \code{yi} is the response variable. - Then, formula \code{yi | weights(wei) ~ predictors} - implements a weighted regression. - - For multivariate models, \code{subset} may be used in the \code{aterms} - part, to use different subsets of the data in different univariate - models. For instance, if \code{sub} is a logical variable and - \code{y} is the response of one of the univariate models, we may - write \code{y | subset(sub) ~ predictors} so that \code{y} is - predicted only for those observations for which \code{sub} evaluates - to \code{TRUE}. - - For log-linear models such as poisson models, \code{rate} may be used - in the \code{aterms} part to specify the denominator of a response that - is expressed as a rate. The numerator is given by the actual response - variable and has a distribution according to the family as usual. Using - \code{rate(denom)} is equivalent to adding \code{offset(log(denom))} to - the linear predictor of the main parameter but the former is arguably - more convenient and explicit. - - With the exception of categorical and ordinal families, - left, right, and interval censoring can be modeled through - \code{y | cens(censored) ~ predictors}. The censoring variable - (named \code{censored} in this example) should contain the values - \code{'left'}, \code{'none'}, \code{'right'}, and \code{'interval'} - (or equivalently \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate that - the corresponding observation is left censored, not censored, right censored, - or interval censored. For interval censored data, a second variable - (let's call it \code{y2}) has to be passed to \code{cens}. In this case, - the formula has the structure \code{y | cens(censored, y2) ~ predictors}. - While the lower bounds are given in \code{y}, the upper bounds are given - in \code{y2} for interval censored data. Intervals are assumed to be open - on the left and closed on the right: \code{(y, y2]}. - - With the exception of categorical and ordinal families, - the response distribution can be truncated using the \code{trunc} - function in the addition part. If the response variable is truncated - between, say, 0 and 100, we can specify this via - \code{yi | trunc(lb = 0, ub = 100) ~ predictors}. - Instead of numbers, variables in the data set can also be passed allowing - for varying truncation points across observations. Defining only one of - the two arguments in \code{trunc} leads to one-sided truncation. - - For all continuous families, missing values in the responses can be imputed - within Stan by using the addition term \code{mi}. This is mostly - useful in combination with \code{mi} predictor terms as explained - above under 'Special predictor terms'. - - For families \code{binomial} and \code{zero_inflated_binomial}, - addition should contain a variable indicating the number of trials - underlying each observation. In \code{lme4} syntax, we may write for instance - \code{cbind(success, n - success)}, which is equivalent - to \code{success | trials(n)} in \pkg{brms} syntax. If the number of trials - is constant across all observations, say \code{10}, - we may also write \code{success | trials(10)}. - \bold{Please note that the \code{cbind()} syntax will not work - in \pkg{brms} in the expected way because this syntax is reserved - for other purposes.} - - For all ordinal families, \code{aterms} may contain a term - \code{thres(number)} to specify the number thresholds (e.g, - \code{thres(6)}), which should be equal to the total number of response - categories - 1. If not given, the number of thresholds is calculated from - the data. If different threshold vectors should be used for different - subsets of the data, the \code{gr} argument can be used to provide the - grouping variable (e.g, \code{thres(6, gr = item)}, if \code{item} is the - grouping variable). In this case, the number of thresholds can also be a - variable in the data with different values per group. - - A deprecated quasi alias of \code{thres()} is \code{cat()} with which the - total number of response categories (i.e., number of thresholds + 1) can be - specified. - - In Wiener diffusion models (family \code{wiener}) the addition term - \code{dec} is mandatory to specify the (vector of) binary decisions - corresponding to the reaction times. Non-zero values will be treated - as a response on the upper boundary of the diffusion process and zeros - will be treated as a response on the lower boundary. Alternatively, - the variable passed to \code{dec} might also be a character vector - consisting of \code{'lower'} and \code{'upper'}. - - All families support the \code{index} addition term to uniquely identify - each observation of the corresponding response variable. Currently, - \code{index} is primarily useful in combination with the \code{subset} - addition and \code{\link{mi}} terms. - - For custom families, it is possible to pass an arbitrary number of real and - integer vectors via the addition terms \code{vreal} and \code{vint}, - respectively. An example is provided in - \code{vignette('brms_customfamilies')}. To pass multiple vectors of the - same data type, provide them separated by commas inside a single - \code{vreal} or \code{vint} statement. - - Multiple addition terms of different types may be specified at the same - time using the \code{+} operator. For example, the formula - \code{formula = yi | se(sei) + cens(censored) ~ 1} implies a censored - meta-analytic model. - - The addition argument \code{disp} (short for dispersion) - has been removed in version 2.0. You may instead use the - distributional regression approach by specifying - \code{sigma ~ 1 + offset(log(xdisp))} or - \code{shape ~ 1 + offset(log(xdisp))}, where \code{xdisp} is - the variable being previously passed to \code{disp}. - - \bold{Parameterization of the population-level intercept} - - By default, the population-level intercept (if incorporated) is estimated - separately and not as part of population-level parameter vector \code{b} As - a result, priors on the intercept also have to be specified separately. - Furthermore, to increase sampling efficiency, the population-level design - matrix \code{X} is centered around its column means \code{X_means} if the - intercept is incorporated. This leads to a temporary bias in the intercept - equal to \code{}, where \code{<,>} is the scalar product. The - bias is corrected after fitting the model, but be aware that you are - effectively defining a prior on the intercept of the centered design matrix - not on the real intercept. You can turn off this special handling of the - intercept by setting argument \code{center} to \code{FALSE}. For more - details on setting priors on population-level intercepts, see - \code{\link{set_prior}}. - - This behavior can be avoided by using the reserved - (and internally generated) variable \code{Intercept}. - Instead of \code{y ~ x}, you may write - \code{y ~ 0 + Intercept + x}. This way, priors can be - defined on the real intercept, directly. In addition, - the intercept is just treated as an ordinary population-level effect - and thus priors defined on \code{b} will also apply to it. - Note that this parameterization may be less efficient - than the default parameterization discussed above. - - \bold{Formula syntax for non-linear models} - - In \pkg{brms}, it is possible to specify non-linear models - of arbitrary complexity. - The non-linear model can just be specified within the \code{formula} - argument. Suppose, that we want to predict the response \code{y} - through the predictor \code{x}, where \code{x} is linked to \code{y} - through \code{y = alpha - beta * lambda^x}, with parameters - \code{alpha}, \code{beta}, and \code{lambda}. This is certainly a - non-linear model being defined via - \code{formula = y ~ alpha - beta * lambda^x} (addition arguments - can be added in the same way as for ordinary formulas). - To tell \pkg{brms} that this is a non-linear model, - we set argument \code{nl} to \code{TRUE}. - Now we have to specify a model for each of the non-linear parameters. - Let's say we just want to estimate those three parameters - with no further covariates or random effects. Then we can pass - \code{alpha + beta + lambda ~ 1} or equivalently - (and more flexible) \code{alpha ~ 1, beta ~ 1, lambda ~ 1} - to the \code{...} argument. - This can, of course, be extended. If we have another predictor \code{z} and - observations nested within the grouping factor \code{g}, we may write for - instance \code{alpha ~ 1, beta ~ 1 + z + (1|g), lambda ~ 1}. - The formula syntax described above applies here as well. - In this example, we are using \code{z} and \code{g} only for the - prediction of \code{beta}, but we might also use them for the other - non-linear parameters (provided that the resulting model is still - scientifically reasonable). - - By default, non-linear covariates are treated as real vectors in Stan. - However, if the data of the covariates is of type `integer` in \R (which - can be enforced by the `as.integer` function), the Stan type will be - changed to an integer array. That way, covariates can also be used - for indexing purposes in Stan. - - Non-linear models may not be uniquely identified and / or show bad convergence. - For this reason it is mandatory to specify priors on the non-linear parameters. - For instructions on how to do that, see \code{\link{set_prior}}. - For some examples of non-linear models, see \code{vignette("brms_nonlinear")}. - - \bold{Formula syntax for predicting distributional parameters} - - It is also possible to predict parameters of the response distribution such - as the residual standard deviation \code{sigma} in gaussian models or the - hurdle probability \code{hu} in hurdle models. The syntax closely resembles - that of a non-linear parameter, for instance \code{sigma ~ x + s(z) + - (1+x|g)}. For some examples of distributional models, see - \code{vignette("brms_distreg")}. - - Parameter \code{mu} exists for every family and can be used as an - alternative to specifying terms in \code{formula}. If both \code{mu} and - \code{formula} are given, the right-hand side of \code{formula} is ignored. - Accordingly, specifying terms on the right-hand side of both \code{formula} - and \code{mu} at the same time is deprecated. In future versions, - \code{formula} might be updated by \code{mu}. - - The following are - distributional parameters of specific families (all other parameters are - treated as non-linear parameters): \code{sigma} (residual standard - deviation or scale of the \code{gaussian}, \code{student}, - \code{skew_normal}, \code{lognormal} \code{exgaussian}, and - \code{asym_laplace} families); \code{shape} (shape parameter of the - \code{Gamma}, \code{weibull}, \code{negbinomial}, and related zero-inflated - / hurdle families); \code{nu} (degrees of freedom parameter of the - \code{student} and \code{frechet} families); \code{phi} (precision - parameter of the \code{beta} and \code{zero_inflated_beta} families); - \code{kappa} (precision parameter of the \code{von_mises} family); - \code{beta} (mean parameter of the exponential component of the - \code{exgaussian} family); \code{quantile} (quantile parameter of the - \code{asym_laplace} family); \code{zi} (zero-inflation probability); - \code{hu} (hurdle probability); \code{zoi} (zero-one-inflation - probability); \code{coi} (conditional one-inflation probability); - \code{disc} (discrimination) for ordinal models; \code{bs}, \code{ndt}, and - \code{bias} (boundary separation, non-decision time, and initial bias of - the \code{wiener} diffusion model). By default, distributional parameters - are modeled on the log scale if they can be positive only or on the logit - scale if the can only be within the unit interval. - - Alternatively, one may fix distributional parameters to certain values. - However, this is mainly useful when models become too - complicated and otherwise have convergence issues. - We thus suggest to be generally careful when making use of this option. - The \code{quantile} parameter of the \code{asym_laplace} distribution - is a good example where it is useful. By fixing \code{quantile}, - one can perform quantile regression for the specified quantile. - For instance, \code{quantile = 0.25} allows predicting the 25\%-quantile. - Furthermore, the \code{bias} parameter in drift-diffusion models, - is assumed to be \code{0.5} (i.e. no bias) in many applications. - To achieve this, simply write \code{bias = 0.5}. - Other possible applications are the Cauchy distribution as a - special case of the Student-t distribution with - \code{nu = 1}, or the geometric distribution as a special case of - the negative binomial distribution with \code{shape = 1}. - Furthermore, the parameter \code{disc} ('discrimination') in ordinal - models is fixed to \code{1} by default and not estimated, - but may be modeled as any other distributional parameter if desired - (see examples). For reasons of identification, \code{'disc'} - can only be positive, which is achieved by applying the log-link. - - In categorical models, distributional parameters do not have - fixed names. Instead, they are named after the response categories - (excluding the first one, which serves as the reference category), - with the prefix \code{'mu'}. If, for instance, categories are named - \code{cat1}, \code{cat2}, and \code{cat3}, the distributional parameters - will be named \code{mucat2} and \code{mucat3}. - - Some distributional parameters currently supported by \code{brmsformula} - have to be positive (a negative standard deviation or precision parameter - does not make any sense) or are bounded between 0 and 1 (for zero-inflated / - hurdle probabilities, quantiles, or the initial bias parameter of - drift-diffusion models). - However, linear predictors can be positive or negative, and thus the log link - (for positive parameters) or logit link (for probability parameters) are used - by default to ensure that distributional parameters are within their valid intervals. - This implies that, by default, effects for such distributional parameters are - estimated on the log / logit scale and one has to apply the inverse link - function to get to the effects on the original scale. - Alternatively, it is possible to use the identity link to predict parameters - on their original scale, directly. However, this is much more likely to lead - to problems in the model fitting, if the parameter actually has a restricted range. - - See also \code{\link{brmsfamily}} for an overview of valid link functions. - - \bold{Formula syntax for mixture models} - - The specification of mixture models closely resembles that - of non-mixture models. If not specified otherwise (see below), - all mean parameters of the mixture components are predicted - using the right-hand side of \code{formula}. All types of predictor - terms allowed in non-mixture models are allowed in mixture models - as well. - - Distributional parameters of mixture distributions have the same - name as those of the corresponding ordinary distributions, but with - a number at the end to indicate the mixture component. For instance, if - you use family \code{mixture(gaussian, gaussian)}, the distributional - parameters are \code{sigma1} and \code{sigma2}. - Distributional parameters of the same class can be fixed to the same value. - For the above example, we could write \code{sigma2 = "sigma1"} to make - sure that both components have the same residual standard deviation, - which is in turn estimated from the data. - - In addition, there are two types of special distributional parameters. - The first are named \code{mu}, that allow for modeling different - predictors for the mean parameters of different mixture components. - For instance, if you want to predict the mean of the first component - using predictor \code{x} and the mean of the second component using - predictor \code{z}, you can write \code{mu1 ~ x} as well as \code{mu2 ~ z}. - The second are named \code{theta}, which constitute the mixing - proportions. If the mixing proportions are fixed to certain values, - they are internally normalized to form a probability vector. - If one seeks to predict the mixing proportions, all but - one of the them has to be predicted, while the remaining one is used - as the reference category to identify the model. The \code{softmax} - function is applied on the linear predictor terms to form a - probability vector. - - For more information on mixture models, see - the documentation of \code{\link{mixture}}. - - \bold{Formula syntax for multivariate models} - - Multivariate models may be specified using \code{mvbind} notation - or with help of the \code{\link{mvbf}} function. - Suppose that \code{y1} and \code{y2} are response variables - and \code{x} is a predictor. Then \code{mvbind(y1, y2) ~ x} - specifies a multivariate model. - The effects of all terms specified at the RHS of the formula - are assumed to vary across response variables. - For instance, two parameters will be estimated for \code{x}, - one for the effect on \code{y1} and another for the effect on \code{y2}. - This is also true for group-level effects. When writing, for instance, - \code{mvbind(y1, y2) ~ x + (1+x|g)}, group-level effects will be - estimated separately for each response. To model these effects - as correlated across responses, use the ID syntax (see above). - For the present example, this would look as follows: - \code{mvbind(y1, y2) ~ x + (1+x|2|g)}. Of course, you could also use - any value other than \code{2} as ID. - - It is also possible to specify different formulas for different responses. - If, for instance, \code{y1} should be predicted by \code{x} and \code{y2} - should be predicted by \code{z}, we could write \code{mvbf(y1 ~ x, y2 ~ z)}. - Alternatively, multiple \code{brmsformula} objects can be added to - specify a joint multivariate model (see 'Examples'). -} -\examples{ -# multilevel model with smoothing terms -brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2)) - -# additionally predict 'sigma' -brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2), - sigma ~ x1 + (1|g2)) - -# use the shorter alias 'bf' -(formula1 <- brmsformula(y ~ x + (x|g))) -(formula2 <- bf(y ~ x + (x|g))) -# will be TRUE -identical(formula1, formula2) - -# incorporate censoring -bf(y | cens(censor_variable) ~ predictors) - -# define a simple non-linear model -bf(y ~ a1 - a2^x, a1 + a2 ~ 1, nl = TRUE) - -# predict a1 and a2 differently -bf(y ~ a1 - a2^x, a1 ~ 1, a2 ~ x + (x|g), nl = TRUE) - -# correlated group-level effects across parameters -bf(y ~ a1 - a2^x, a1 ~ 1 + (1 |2| g), a2 ~ x + (x |2| g), nl = TRUE) -# alternative but equivalent way to specify the above model -bf(y ~ a1 - a2^x, a1 ~ 1 + (1 | gr(g, id = 2)), - a2 ~ x + (x | gr(g, id = 2)), nl = TRUE) - -# define a multivariate model -bf(mvbind(y1, y2) ~ x * z + (1|g)) - -# define a zero-inflated model -# also predicting the zero-inflation part -bf(y ~ x * z + (1+x|ID1|g), zi ~ x + (1|ID1|g)) - -# specify a predictor as monotonic -bf(y ~ mo(x) + more_predictors) - -# for ordinal models only -# specify a predictor as category specific -bf(y ~ cs(x) + more_predictors) -# add a category specific group-level intercept -bf(y ~ cs(x) + (cs(1)|g)) -# specify parameter 'disc' -bf(y ~ person + item, disc ~ item) - -# specify variables containing measurement error -bf(y ~ me(x, sdx)) - -# specify predictors on all parameters of the wiener diffusion model -# the main formula models the drift rate 'delta' -bf(rt | dec(decision) ~ x, bs ~ x, ndt ~ x, bias ~ x) - -# fix the bias parameter to 0.5 -bf(rt | dec(decision) ~ x, bias = 0.5) - -# specify different predictors for different mixture components -mix <- mixture(gaussian, gaussian) -bf(y ~ 1, mu1 ~ x, mu2 ~ z, family = mix) - -# fix both residual standard deviations to the same value -bf(y ~ x, sigma2 = "sigma1", family = mix) - -# use the '+' operator to specify models -bf(y ~ 1) + - nlf(sigma ~ a * exp(b * x), a ~ x) + - lf(b ~ z + (1|g), dpar = "sigma") + - gaussian() - -# specify a multivariate model using the '+' operator -bf(y1 ~ x + (1|g)) + - gaussian() + cor_ar(~1|g) + - bf(y2 ~ z) + poisson() - -# specify correlated residuals of a gaussian and a poisson model -form1 <- bf(y1 ~ 1 + x + (1|c|obs), sigma = 1) + gaussian() -form2 <- bf(y2 ~ 1 + x + (1|c|obs)) + poisson() - -# model missing values in predictors -bf(bmi ~ age * mi(chl)) + - bf(chl | mi() ~ age) + - set_rescor(FALSE) - -# model sigma as a function of the mean -bf(y ~ eta, nl = TRUE) + - lf(eta ~ 1 + x) + - nlf(sigma ~ tau * sqrt(eta)) + - lf(tau ~ 1) - -} -\seealso{ -\code{\link{mvbrmsformula}}, \code{\link{brmsformula-helpers}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsformula.R +\name{brmsformula} +\alias{brmsformula} +\alias{bf} +\title{Set up a model formula for use in \pkg{brms}} +\usage{ +brmsformula( + formula, + ..., + flist = NULL, + family = NULL, + autocor = NULL, + nl = NULL, + loop = NULL, + center = NULL, + cmc = NULL, + sparse = NULL, + decomp = NULL, + unused = NULL +) +} +\arguments{ +\item{formula}{An object of class \code{formula} +(or one that can be coerced to that class): +a symbolic description of the model to be fitted. +The details of model specification are given in 'Details'.} + +\item{...}{Additional \code{formula} objects to specify predictors of +non-linear and distributional parameters. Formulas can either be named +directly or contain names on their left-hand side. Alternatively, +it is possible to fix parameters to certain values by passing +numbers or character strings in which case arguments have to be named +to provide the parameter names. See 'Details' for more information.} + +\item{flist}{Optional list of formulas, which are treated in the +same way as formulas passed via the \code{...} argument.} + +\item{family}{Same argument as in \code{\link{brm}}. +If \code{family} is specified in \code{brmsformula}, it will +overwrite the value specified in other functions.} + +\item{autocor}{An optional \code{formula} which contains +autocorrelation terms as described in \code{\link{autocor-terms}} +or alternatively a \code{\link{cor_brms}} object (deprecated). +If \code{autocor} is specified in \code{brmsformula}, it will +overwrite the value specified in other functions.} + +\item{nl}{Logical; Indicates whether \code{formula} should be +treated as specifying a non-linear model. By default, \code{formula} +is treated as an ordinary linear model formula.} + +\item{loop}{Logical; Only used in non-linear models. +Indicates if the computation of the non-linear formula should be +done inside (\code{TRUE}) or outside (\code{FALSE}) a loop +over observations. Defaults to \code{TRUE}.} + +\item{center}{Logical; Indicates if the population-level design +matrix should be centered, which usually increases sampling efficiency. +See the 'Details' section for more information. +Defaults to \code{TRUE} for distributional parameters +and to \code{FALSE} for non-linear parameters.} + +\item{cmc}{Logical; Indicates whether automatic cell-mean coding +should be enabled when removing the intercept by adding \code{0} +to the right-hand of model formulas. Defaults to \code{TRUE} to +mirror the behavior of standard \R formula parsing.} + +\item{sparse}{Logical; indicates whether the population-level design matrices +should be treated as sparse (defaults to \code{FALSE}). For design matrices +with many zeros, this can considerably reduce required memory. Sampling +speed is currently not improved or even slightly decreased.} + +\item{decomp}{Optional name of the decomposition used for the +population-level design matrix. Defaults to \code{NULL} that is +no decomposition. Other options currently available are +\code{"QR"} for the QR decomposition that helps in fitting models +with highly correlated predictors.} + +\item{unused}{An optional \code{formula} which contains variables +that are unused in the model but should still be stored in the +model's data frame. This can be useful, for example, +if those variables are required for post-processing the model.} +} +\value{ +An object of class \code{brmsformula}, which + is essentially a \code{list} containing all model + formulas as well as some additional information. +} +\description{ +Set up a model formula for use in the \pkg{brms} package +allowing to define (potentially non-linear) additive multilevel +models for all parameters of the assumed response distribution. +} +\details{ +\bold{General formula structure} + + The \code{formula} argument accepts formulas of the following syntax: + + \code{response | aterms ~ pterms + (gterms | group)} + + The \code{pterms} part contains effects that are assumed to be the same + across observations. We call them 'population-level' or 'overall' effects, + or (adopting frequentist vocabulary) 'fixed' effects. The optional + \code{gterms} part may contain effects that are assumed to vary across + grouping variables specified in \code{group}. We call them 'group-level' or + 'varying' effects, or (adopting frequentist vocabulary) 'random' effects, + although the latter name is misleading in a Bayesian context. For more + details type \code{vignette("brms_overview")} and + \code{vignette("brms_multilevel")}. + + \bold{Group-level terms} + + Multiple grouping factors each with multiple group-level effects are + possible. (Of course we can also run models without any group-level + effects.) Instead of \code{|} you may use \code{||} in grouping terms to + prevent correlations from being modeled. Equivalently, the \code{cor} + argument of the \code{\link{gr}} function can be used for this purpose, + for example, \code{(1 + x || g)} is equivalent to + \code{(1 + x | gr(g, cor = FALSE))}. + + It is also possible to model different group-level terms of the same + grouping factor as correlated (even across different formulas, e.g., in + non-linear models) by using \code{||} instead of \code{|}. All + group-level terms sharing the same ID will be modeled as correlated. If, + for instance, one specifies the terms \code{(1+x|i|g)} and \code{(1+z|i|g)} + somewhere in the formulas passed to \code{brmsformula}, correlations + between the corresponding group-level effects will be estimated. In the + above example, \code{i} is not a variable in the data but just a symbol to + indicate correlations between multiple group-level terms. Equivalently, the + \code{id} argument of the \code{\link{gr}} function can be used as well, + for example, \code{(1 + x | gr(g, id = "i"))}. + + If levels of the grouping factor belong to different sub-populations, + it may be reasonable to assume a different covariance matrix for each + of the sub-populations. For instance, the variation within the + treatment group and within the control group in a randomized control + trial might differ. Suppose that \code{y} is the outcome, and + \code{x} is the factor indicating the treatment and control group. + Then, we could estimate different hyper-parameters of the varying + effects (in this case a varying intercept) for treatment and control + group via \code{y ~ x + (1 | gr(subject, by = x))}. + + You can specify multi-membership terms using the \code{\link{mm}} + function. For instance, a multi-membership term with two members + could be \code{(1 | mm(g1, g2))}, where \code{g1} and \code{g2} + specify the first and second member, respectively. Moreover, + if a covariate \code{x} varies across the levels of the grouping-factors + \code{g1} and \code{g2}, we can save the respective covariate values + in the variables \code{x1} and \code{x2} and then model the varying + effect as \code{(1 + mmc(x1, x2) | mm(g1, g2))}. + + \bold{Special predictor terms} + + Flexible non-linear smooth terms can modeled using the \code{\link{s}} + and \code{\link{t2}} functions in the \code{pterms} part + of the model formula. This allows to fit generalized additive mixed + models (GAMMs) with \pkg{brms}. The implementation is similar to that + used in the \pkg{gamm4} package. For more details on this model class + see \code{\link[mgcv:gam]{gam}} and \code{\link[mgcv:gamm]{gamm}}. + + Gaussian process terms can be fitted using the \code{\link{gp}} + function in the \code{pterms} part of the model formula. Similar to + smooth terms, Gaussian processes can be used to model complex non-linear + relationships, for instance temporal or spatial autocorrelation. + However, they are computationally demanding and are thus not recommended + for very large datasets or approximations need to be used. + + The \code{pterms} and \code{gterms} parts may contain four non-standard + effect types namely monotonic, measurement error, missing value, and + category specific effects, which can be specified using terms of the + form \code{mo(predictor)}, \code{me(predictor, sd_predictor)}, + \code{mi(predictor)}, and \code{cs()}, respectively. + Category specific effects can only be estimated in + ordinal models and are explained in more detail in the package's + main vignette (type \code{vignette("brms_overview")}). + The other three effect types are explained in the following. + + A monotonic predictor must either be integer valued or an ordered factor, + which is the first difference to an ordinary continuous predictor. + More importantly, predictor categories (or integers) are not assumed to be + equidistant with respect to their effect on the response variable. + Instead, the distance between adjacent predictor categories (or integers) + is estimated from the data and may vary across categories. + This is realized by parameterizing as follows: + One parameter takes care of the direction and size of the effect similar + to an ordinary regression parameter, while an additional parameter vector + estimates the normalized distances between consecutive predictor categories. + A main application of monotonic effects are ordinal predictors that + can this way be modeled without (falsely) treating them as continuous + or as unordered categorical predictors. For more details and examples + see \code{vignette("brms_monotonic")}. + + Quite often, predictors are measured and as such naturally contain + measurement error. Although most researchers are well aware of this problem, + measurement error in predictors is ignored in most + regression analyses, possibly because only few packages allow + for modeling it. Notably, measurement error can be handled in + structural equation models, but many more general regression models + (such as those featured by \pkg{brms}) cannot be transferred + to the SEM framework. In \pkg{brms}, effects of noise-free predictors + can be modeled using the \code{me} (for 'measurement error') function. + If, say, \code{y} is the response variable and + \code{x} is a measured predictor with known measurement error + \code{sdx}, we can simply include it on the right-hand side of the + model formula via \code{y ~ me(x, sdx)}. + This can easily be extended to more general formulas. + If \code{x2} is another measured predictor with corresponding error + \code{sdx2} and \code{z} is a predictor without error + (e.g., an experimental setting), we can model all main effects + and interactions of the three predictors in the well known manner: + \code{y ~ me(x, sdx) * me(x2, sdx2) * z}. + The \code{me} function is soft deprecated in favor of the more flexible + and consistent \code{mi} function (see below). + + When a variable contains missing values, the corresponding rows will + be excluded from the data by default (row-wise exclusion). However, + quite often we want to keep these rows and instead estimate the missing values. + There are two approaches for this: (a) Impute missing values before + the model fitting for instance via multiple imputation (see + \code{\link{brm_multiple}} for a way to handle multiple imputed datasets). + (b) Impute missing values on the fly during model fitting. The latter + approach is explained in the following. Using a variable with missing + values as predictors requires two things, First, we need to specify that + the predictor contains missings that should to be imputed. + If, say, \code{y} is the primary response, \code{x} is a + predictor with missings and \code{z} is a predictor without missings, + we go for \code{y ~ mi(x) + z}. Second, we need to model \code{x} + as an additional response with corresponding predictors and the + addition term \code{mi()}. In our example, we could write + \code{x | mi() ~ z}. Measurement error may be included via + the \code{sdy} argument, say, \code{x | mi(sdy = se) ~ z}. + See \code{\link{mi}} for examples with real data. + + + \bold{Autocorrelation terms} + + Autocorrelation terms can be directly specified inside the \code{pterms} + part as well. Details can be found in \code{\link{autocor-terms}}. + + \bold{Additional response information} + + Another special of the \pkg{brms} formula syntax is the optional + \code{aterms} part, which may contain multiple terms of the form + \code{fun()} separated by \code{+} each providing special + information on the response variable. \code{fun} can be replaced with + either \code{se}, \code{weights}, \code{subset}, \code{cens}, \code{trunc}, + \code{trials}, \code{cat}, \code{dec}, \code{rate}, \code{vreal}, or + \code{vint}. Their meanings are explained below + (see also \code{\link{addition-terms}}). + + For families \code{gaussian}, \code{student} and \code{skew_normal}, it is + possible to specify standard errors of the observations, thus allowing + to perform meta-analysis. Suppose that the variable \code{yi} contains + the effect sizes from the studies and \code{sei} the corresponding + standard errors. Then, fixed and random effects meta-analyses can + be conducted using the formulas \code{yi | se(sei) ~ 1} and + \code{yi | se(sei) ~ 1 + (1|study)}, respectively, where + \code{study} is a variable uniquely identifying every study. + If desired, meta-regression can be performed via + \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1|study)} + or \cr \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1 + mod1 + mod2|study)}, + where \code{mod1} and \code{mod2} represent moderator variables. + By default, the standard errors replace the parameter \code{sigma}. + To model \code{sigma} in addition to the known standard errors, + set argument \code{sigma} in function \code{se} to \code{TRUE}, + for instance, \code{yi | se(sei, sigma = TRUE) ~ 1}. + + For all families, weighted regression may be performed using + \code{weights} in the \code{aterms} part. Internally, this is + implemented by multiplying the log-posterior values of each + observation by their corresponding weights. + Suppose that variable \code{wei} contains the weights + and that \code{yi} is the response variable. + Then, formula \code{yi | weights(wei) ~ predictors} + implements a weighted regression. + + For multivariate models, \code{subset} may be used in the \code{aterms} + part, to use different subsets of the data in different univariate + models. For instance, if \code{sub} is a logical variable and + \code{y} is the response of one of the univariate models, we may + write \code{y | subset(sub) ~ predictors} so that \code{y} is + predicted only for those observations for which \code{sub} evaluates + to \code{TRUE}. + + For log-linear models such as poisson models, \code{rate} may be used + in the \code{aterms} part to specify the denominator of a response that + is expressed as a rate. The numerator is given by the actual response + variable and has a distribution according to the family as usual. Using + \code{rate(denom)} is equivalent to adding \code{offset(log(denom))} to + the linear predictor of the main parameter but the former is arguably + more convenient and explicit. + + With the exception of categorical and ordinal families, + left, right, and interval censoring can be modeled through + \code{y | cens(censored) ~ predictors}. The censoring variable + (named \code{censored} in this example) should contain the values + \code{'left'}, \code{'none'}, \code{'right'}, and \code{'interval'} + (or equivalently \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate that + the corresponding observation is left censored, not censored, right censored, + or interval censored. For interval censored data, a second variable + (let's call it \code{y2}) has to be passed to \code{cens}. In this case, + the formula has the structure \code{y | cens(censored, y2) ~ predictors}. + While the lower bounds are given in \code{y}, the upper bounds are given + in \code{y2} for interval censored data. Intervals are assumed to be open + on the left and closed on the right: \code{(y, y2]}. + + With the exception of categorical and ordinal families, + the response distribution can be truncated using the \code{trunc} + function in the addition part. If the response variable is truncated + between, say, 0 and 100, we can specify this via + \code{yi | trunc(lb = 0, ub = 100) ~ predictors}. + Instead of numbers, variables in the data set can also be passed allowing + for varying truncation points across observations. Defining only one of + the two arguments in \code{trunc} leads to one-sided truncation. + + For all continuous families, missing values in the responses can be imputed + within Stan by using the addition term \code{mi}. This is mostly + useful in combination with \code{mi} predictor terms as explained + above under 'Special predictor terms'. + + For families \code{binomial} and \code{zero_inflated_binomial}, + addition should contain a variable indicating the number of trials + underlying each observation. In \code{lme4} syntax, we may write for instance + \code{cbind(success, n - success)}, which is equivalent + to \code{success | trials(n)} in \pkg{brms} syntax. If the number of trials + is constant across all observations, say \code{10}, + we may also write \code{success | trials(10)}. + \bold{Please note that the \code{cbind()} syntax will not work + in \pkg{brms} in the expected way because this syntax is reserved + for other purposes.} + + For all ordinal families, \code{aterms} may contain a term + \code{thres(number)} to specify the number thresholds (e.g, + \code{thres(6)}), which should be equal to the total number of response + categories - 1. If not given, the number of thresholds is calculated from + the data. If different threshold vectors should be used for different + subsets of the data, the \code{gr} argument can be used to provide the + grouping variable (e.g, \code{thres(6, gr = item)}, if \code{item} is the + grouping variable). In this case, the number of thresholds can also be a + variable in the data with different values per group. + + A deprecated quasi alias of \code{thres()} is \code{cat()} with which the + total number of response categories (i.e., number of thresholds + 1) can be + specified. + + In Wiener diffusion models (family \code{wiener}) the addition term + \code{dec} is mandatory to specify the (vector of) binary decisions + corresponding to the reaction times. Non-zero values will be treated + as a response on the upper boundary of the diffusion process and zeros + will be treated as a response on the lower boundary. Alternatively, + the variable passed to \code{dec} might also be a character vector + consisting of \code{'lower'} and \code{'upper'}. + + All families support the \code{index} addition term to uniquely identify + each observation of the corresponding response variable. Currently, + \code{index} is primarily useful in combination with the \code{subset} + addition and \code{\link{mi}} terms. + + For custom families, it is possible to pass an arbitrary number of real and + integer vectors via the addition terms \code{vreal} and \code{vint}, + respectively. An example is provided in + \code{vignette('brms_customfamilies')}. To pass multiple vectors of the + same data type, provide them separated by commas inside a single + \code{vreal} or \code{vint} statement. + + Multiple addition terms of different types may be specified at the same + time using the \code{+} operator. For example, the formula + \code{formula = yi | se(sei) + cens(censored) ~ 1} implies a censored + meta-analytic model. + + The addition argument \code{disp} (short for dispersion) + has been removed in version 2.0. You may instead use the + distributional regression approach by specifying + \code{sigma ~ 1 + offset(log(xdisp))} or + \code{shape ~ 1 + offset(log(xdisp))}, where \code{xdisp} is + the variable being previously passed to \code{disp}. + + \bold{Parameterization of the population-level intercept} + + By default, the population-level intercept (if incorporated) is estimated + separately and not as part of population-level parameter vector \code{b} As + a result, priors on the intercept also have to be specified separately. + Furthermore, to increase sampling efficiency, the population-level design + matrix \code{X} is centered around its column means \code{X_means} if the + intercept is incorporated. This leads to a temporary bias in the intercept + equal to \code{}, where \code{<,>} is the scalar product. The + bias is corrected after fitting the model, but be aware that you are + effectively defining a prior on the intercept of the centered design matrix + not on the real intercept. You can turn off this special handling of the + intercept by setting argument \code{center} to \code{FALSE}. For more + details on setting priors on population-level intercepts, see + \code{\link{set_prior}}. + + This behavior can be avoided by using the reserved + (and internally generated) variable \code{Intercept}. + Instead of \code{y ~ x}, you may write + \code{y ~ 0 + Intercept + x}. This way, priors can be + defined on the real intercept, directly. In addition, + the intercept is just treated as an ordinary population-level effect + and thus priors defined on \code{b} will also apply to it. + Note that this parameterization may be less efficient + than the default parameterization discussed above. + + \bold{Formula syntax for non-linear models} + + In \pkg{brms}, it is possible to specify non-linear models + of arbitrary complexity. + The non-linear model can just be specified within the \code{formula} + argument. Suppose, that we want to predict the response \code{y} + through the predictor \code{x}, where \code{x} is linked to \code{y} + through \code{y = alpha - beta * lambda^x}, with parameters + \code{alpha}, \code{beta}, and \code{lambda}. This is certainly a + non-linear model being defined via + \code{formula = y ~ alpha - beta * lambda^x} (addition arguments + can be added in the same way as for ordinary formulas). + To tell \pkg{brms} that this is a non-linear model, + we set argument \code{nl} to \code{TRUE}. + Now we have to specify a model for each of the non-linear parameters. + Let's say we just want to estimate those three parameters + with no further covariates or random effects. Then we can pass + \code{alpha + beta + lambda ~ 1} or equivalently + (and more flexible) \code{alpha ~ 1, beta ~ 1, lambda ~ 1} + to the \code{...} argument. + This can, of course, be extended. If we have another predictor \code{z} and + observations nested within the grouping factor \code{g}, we may write for + instance \code{alpha ~ 1, beta ~ 1 + z + (1|g), lambda ~ 1}. + The formula syntax described above applies here as well. + In this example, we are using \code{z} and \code{g} only for the + prediction of \code{beta}, but we might also use them for the other + non-linear parameters (provided that the resulting model is still + scientifically reasonable). + + By default, non-linear covariates are treated as real vectors in Stan. + However, if the data of the covariates is of type `integer` in \R (which + can be enforced by the `as.integer` function), the Stan type will be + changed to an integer array. That way, covariates can also be used + for indexing purposes in Stan. + + Non-linear models may not be uniquely identified and / or show bad convergence. + For this reason it is mandatory to specify priors on the non-linear parameters. + For instructions on how to do that, see \code{\link{set_prior}}. + For some examples of non-linear models, see \code{vignette("brms_nonlinear")}. + + \bold{Formula syntax for predicting distributional parameters} + + It is also possible to predict parameters of the response distribution such + as the residual standard deviation \code{sigma} in gaussian models or the + hurdle probability \code{hu} in hurdle models. The syntax closely resembles + that of a non-linear parameter, for instance \code{sigma ~ x + s(z) + + (1+x|g)}. For some examples of distributional models, see + \code{vignette("brms_distreg")}. + + Parameter \code{mu} exists for every family and can be used as an + alternative to specifying terms in \code{formula}. If both \code{mu} and + \code{formula} are given, the right-hand side of \code{formula} is ignored. + Accordingly, specifying terms on the right-hand side of both \code{formula} + and \code{mu} at the same time is deprecated. In future versions, + \code{formula} might be updated by \code{mu}. + + The following are + distributional parameters of specific families (all other parameters are + treated as non-linear parameters): \code{sigma} (residual standard + deviation or scale of the \code{gaussian}, \code{student}, + \code{skew_normal}, \code{lognormal} \code{exgaussian}, and + \code{asym_laplace} families); \code{shape} (shape parameter of the + \code{Gamma}, \code{weibull}, \code{negbinomial}, and related zero-inflated + / hurdle families); \code{nu} (degrees of freedom parameter of the + \code{student} and \code{frechet} families); \code{phi} (precision + parameter of the \code{beta} and \code{zero_inflated_beta} families); + \code{kappa} (precision parameter of the \code{von_mises} family); + \code{beta} (mean parameter of the exponential component of the + \code{exgaussian} family); \code{quantile} (quantile parameter of the + \code{asym_laplace} family); \code{zi} (zero-inflation probability); + \code{hu} (hurdle probability); \code{zoi} (zero-one-inflation + probability); \code{coi} (conditional one-inflation probability); + \code{disc} (discrimination) for ordinal models; \code{bs}, \code{ndt}, and + \code{bias} (boundary separation, non-decision time, and initial bias of + the \code{wiener} diffusion model). By default, distributional parameters + are modeled on the log scale if they can be positive only or on the logit + scale if the can only be within the unit interval. + + Alternatively, one may fix distributional parameters to certain values. + However, this is mainly useful when models become too + complicated and otherwise have convergence issues. + We thus suggest to be generally careful when making use of this option. + The \code{quantile} parameter of the \code{asym_laplace} distribution + is a good example where it is useful. By fixing \code{quantile}, + one can perform quantile regression for the specified quantile. + For instance, \code{quantile = 0.25} allows predicting the 25\%-quantile. + Furthermore, the \code{bias} parameter in drift-diffusion models, + is assumed to be \code{0.5} (i.e. no bias) in many applications. + To achieve this, simply write \code{bias = 0.5}. + Other possible applications are the Cauchy distribution as a + special case of the Student-t distribution with + \code{nu = 1}, or the geometric distribution as a special case of + the negative binomial distribution with \code{shape = 1}. + Furthermore, the parameter \code{disc} ('discrimination') in ordinal + models is fixed to \code{1} by default and not estimated, + but may be modeled as any other distributional parameter if desired + (see examples). For reasons of identification, \code{'disc'} + can only be positive, which is achieved by applying the log-link. + + In categorical models, distributional parameters do not have + fixed names. Instead, they are named after the response categories + (excluding the first one, which serves as the reference category), + with the prefix \code{'mu'}. If, for instance, categories are named + \code{cat1}, \code{cat2}, and \code{cat3}, the distributional parameters + will be named \code{mucat2} and \code{mucat3}. + + Some distributional parameters currently supported by \code{brmsformula} + have to be positive (a negative standard deviation or precision parameter + does not make any sense) or are bounded between 0 and 1 (for zero-inflated / + hurdle probabilities, quantiles, or the initial bias parameter of + drift-diffusion models). + However, linear predictors can be positive or negative, and thus the log link + (for positive parameters) or logit link (for probability parameters) are used + by default to ensure that distributional parameters are within their valid intervals. + This implies that, by default, effects for such distributional parameters are + estimated on the log / logit scale and one has to apply the inverse link + function to get to the effects on the original scale. + Alternatively, it is possible to use the identity link to predict parameters + on their original scale, directly. However, this is much more likely to lead + to problems in the model fitting, if the parameter actually has a restricted range. + + See also \code{\link{brmsfamily}} for an overview of valid link functions. + + \bold{Formula syntax for mixture models} + + The specification of mixture models closely resembles that + of non-mixture models. If not specified otherwise (see below), + all mean parameters of the mixture components are predicted + using the right-hand side of \code{formula}. All types of predictor + terms allowed in non-mixture models are allowed in mixture models + as well. + + Distributional parameters of mixture distributions have the same + name as those of the corresponding ordinary distributions, but with + a number at the end to indicate the mixture component. For instance, if + you use family \code{mixture(gaussian, gaussian)}, the distributional + parameters are \code{sigma1} and \code{sigma2}. + Distributional parameters of the same class can be fixed to the same value. + For the above example, we could write \code{sigma2 = "sigma1"} to make + sure that both components have the same residual standard deviation, + which is in turn estimated from the data. + + In addition, there are two types of special distributional parameters. + The first are named \code{mu}, that allow for modeling different + predictors for the mean parameters of different mixture components. + For instance, if you want to predict the mean of the first component + using predictor \code{x} and the mean of the second component using + predictor \code{z}, you can write \code{mu1 ~ x} as well as \code{mu2 ~ z}. + The second are named \code{theta}, which constitute the mixing + proportions. If the mixing proportions are fixed to certain values, + they are internally normalized to form a probability vector. + If one seeks to predict the mixing proportions, all but + one of the them has to be predicted, while the remaining one is used + as the reference category to identify the model. The \code{softmax} + function is applied on the linear predictor terms to form a + probability vector. + + For more information on mixture models, see + the documentation of \code{\link{mixture}}. + + \bold{Formula syntax for multivariate models} + + Multivariate models may be specified using \code{mvbind} notation + or with help of the \code{\link{mvbf}} function. + Suppose that \code{y1} and \code{y2} are response variables + and \code{x} is a predictor. Then \code{mvbind(y1, y2) ~ x} + specifies a multivariate model. + The effects of all terms specified at the RHS of the formula + are assumed to vary across response variables. + For instance, two parameters will be estimated for \code{x}, + one for the effect on \code{y1} and another for the effect on \code{y2}. + This is also true for group-level effects. When writing, for instance, + \code{mvbind(y1, y2) ~ x + (1+x|g)}, group-level effects will be + estimated separately for each response. To model these effects + as correlated across responses, use the ID syntax (see above). + For the present example, this would look as follows: + \code{mvbind(y1, y2) ~ x + (1+x|2|g)}. Of course, you could also use + any value other than \code{2} as ID. + + It is also possible to specify different formulas for different responses. + If, for instance, \code{y1} should be predicted by \code{x} and \code{y2} + should be predicted by \code{z}, we could write \code{mvbf(y1 ~ x, y2 ~ z)}. + Alternatively, multiple \code{brmsformula} objects can be added to + specify a joint multivariate model (see 'Examples'). +} +\examples{ +# multilevel model with smoothing terms +brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2)) + +# additionally predict 'sigma' +brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2), + sigma ~ x1 + (1|g2)) + +# use the shorter alias 'bf' +(formula1 <- brmsformula(y ~ x + (x|g))) +(formula2 <- bf(y ~ x + (x|g))) +# will be TRUE +identical(formula1, formula2) + +# incorporate censoring +bf(y | cens(censor_variable) ~ predictors) + +# define a simple non-linear model +bf(y ~ a1 - a2^x, a1 + a2 ~ 1, nl = TRUE) + +# predict a1 and a2 differently +bf(y ~ a1 - a2^x, a1 ~ 1, a2 ~ x + (x|g), nl = TRUE) + +# correlated group-level effects across parameters +bf(y ~ a1 - a2^x, a1 ~ 1 + (1 |2| g), a2 ~ x + (x |2| g), nl = TRUE) +# alternative but equivalent way to specify the above model +bf(y ~ a1 - a2^x, a1 ~ 1 + (1 | gr(g, id = 2)), + a2 ~ x + (x | gr(g, id = 2)), nl = TRUE) + +# define a multivariate model +bf(mvbind(y1, y2) ~ x * z + (1|g)) + +# define a zero-inflated model +# also predicting the zero-inflation part +bf(y ~ x * z + (1+x|ID1|g), zi ~ x + (1|ID1|g)) + +# specify a predictor as monotonic +bf(y ~ mo(x) + more_predictors) + +# for ordinal models only +# specify a predictor as category specific +bf(y ~ cs(x) + more_predictors) +# add a category specific group-level intercept +bf(y ~ cs(x) + (cs(1)|g)) +# specify parameter 'disc' +bf(y ~ person + item, disc ~ item) + +# specify variables containing measurement error +bf(y ~ me(x, sdx)) + +# specify predictors on all parameters of the wiener diffusion model +# the main formula models the drift rate 'delta' +bf(rt | dec(decision) ~ x, bs ~ x, ndt ~ x, bias ~ x) + +# fix the bias parameter to 0.5 +bf(rt | dec(decision) ~ x, bias = 0.5) + +# specify different predictors for different mixture components +mix <- mixture(gaussian, gaussian) +bf(y ~ 1, mu1 ~ x, mu2 ~ z, family = mix) + +# fix both residual standard deviations to the same value +bf(y ~ x, sigma2 = "sigma1", family = mix) + +# use the '+' operator to specify models +bf(y ~ 1) + + nlf(sigma ~ a * exp(b * x), a ~ x) + + lf(b ~ z + (1|g), dpar = "sigma") + + gaussian() + +# specify a multivariate model using the '+' operator +bf(y1 ~ x + (1|g)) + + gaussian() + cor_ar(~1|g) + + bf(y2 ~ z) + poisson() + +# specify correlated residuals of a gaussian and a poisson model +form1 <- bf(y1 ~ 1 + x + (1|c|obs), sigma = 1) + gaussian() +form2 <- bf(y2 ~ 1 + x + (1|c|obs)) + poisson() + +# model missing values in predictors +bf(bmi ~ age * mi(chl)) + + bf(chl | mi() ~ age) + + set_rescor(FALSE) + +# model sigma as a function of the mean +bf(y ~ eta, nl = TRUE) + + lf(eta ~ 1 + x) + + nlf(sigma ~ tau * sqrt(eta)) + + lf(tau ~ 1) + +} +\seealso{ +\code{\link{mvbrmsformula}}, \code{\link{brmsformula-helpers}} +} diff -Nru r-cran-brms-2.16.3/man/brmshypothesis.Rd r-cran-brms-2.17.0/man/brmshypothesis.Rd --- r-cran-brms-2.16.3/man/brmshypothesis.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/brmshypothesis.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,72 +1,72 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hypothesis.R -\name{brmshypothesis} -\alias{brmshypothesis} -\alias{print.brmshypothesis} -\alias{plot.brmshypothesis} -\title{Descriptions of \code{brmshypothesis} Objects} -\usage{ -\method{print}{brmshypothesis}(x, digits = 2, chars = 20, ...) - -\method{plot}{brmshypothesis}( - x, - N = 5, - ignore_prior = FALSE, - chars = 40, - colors = NULL, - theme = NULL, - ask = TRUE, - plot = TRUE, - ... -) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}.} - -\item{digits}{Minimal number of significant digits, -see \code{\link[base:print.default]{print.default}}.} - -\item{chars}{Maximum number of characters of each hypothesis -to print or plot. If \code{NULL}, print the full hypotheses. -Defaults to \code{20}.} - -\item{...}{Currently ignored.} - -\item{N}{The number of parameters plotted per page.} - -\item{ignore_prior}{A flag indicating if prior distributions -should also be plotted. Only used if priors were specified on -the relevant parameters.} - -\item{colors}{Two values specifying the colors of the posterior -and prior density respectively. If \code{NULL} (the default) -colors are taken from the current color scheme of -the \pkg{bayesplot} package.} - -\item{theme}{A \code{\link[ggplot2:theme]{theme}} object -modifying the appearance of the plots. -For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} -and \code{\link[bayesplot:theme_default]{theme_default}}.} - -\item{ask}{Logical; indicates if the user is prompted -before a new page is plotted. -Only used if \code{plot} is \code{TRUE}.} - -\item{plot}{Logical; indicates if plots should be -plotted directly in the active graphic device. -Defaults to \code{TRUE}.} -} -\description{ -A \code{brmshypothesis} object contains posterior draws -as well as summary statistics of non-linear hypotheses as -returned by \code{\link{hypothesis}}. -} -\details{ -The two most important elements of a \code{brmshypothesis} object are -\code{hypothesis}, which is a data.frame containing the summary estimates -of the hypotheses, and \code{samples}, which is a data.frame containing -the corresponding posterior draws. -} -\seealso{ -\code{\link{hypothesis}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hypothesis.R +\name{brmshypothesis} +\alias{brmshypothesis} +\alias{print.brmshypothesis} +\alias{plot.brmshypothesis} +\title{Descriptions of \code{brmshypothesis} Objects} +\usage{ +\method{print}{brmshypothesis}(x, digits = 2, chars = 20, ...) + +\method{plot}{brmshypothesis}( + x, + N = 5, + ignore_prior = FALSE, + chars = 40, + colors = NULL, + theme = NULL, + ask = TRUE, + plot = TRUE, + ... +) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}.} + +\item{digits}{Minimal number of significant digits, +see \code{\link[base:print.default]{print.default}}.} + +\item{chars}{Maximum number of characters of each hypothesis +to print or plot. If \code{NULL}, print the full hypotheses. +Defaults to \code{20}.} + +\item{...}{Currently ignored.} + +\item{N}{The number of parameters plotted per page.} + +\item{ignore_prior}{A flag indicating if prior distributions +should also be plotted. Only used if priors were specified on +the relevant parameters.} + +\item{colors}{Two values specifying the colors of the posterior +and prior density respectively. If \code{NULL} (the default) +colors are taken from the current color scheme of +the \pkg{bayesplot} package.} + +\item{theme}{A \code{\link[ggplot2:theme]{theme}} object +modifying the appearance of the plots. +For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} +and \code{\link[bayesplot:theme_default]{theme_default}}.} + +\item{ask}{Logical; indicates if the user is prompted +before a new page is plotted. +Only used if \code{plot} is \code{TRUE}.} + +\item{plot}{Logical; indicates if plots should be +plotted directly in the active graphic device. +Defaults to \code{TRUE}.} +} +\description{ +A \code{brmshypothesis} object contains posterior draws +as well as summary statistics of non-linear hypotheses as +returned by \code{\link{hypothesis}}. +} +\details{ +The two most important elements of a \code{brmshypothesis} object are +\code{hypothesis}, which is a data.frame containing the summary estimates +of the hypotheses, and \code{samples}, which is a data.frame containing +the corresponding posterior draws. +} +\seealso{ +\code{\link{hypothesis}} +} diff -Nru r-cran-brms-2.16.3/man/brms-package.Rd r-cran-brms-2.17.0/man/brms-package.Rd --- r-cran-brms-2.16.3/man/brms-package.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/brms-package.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,84 +1,84 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brms-package.R -\docType{package} -\name{brms-package} -\alias{brms-package} -\alias{brms} -\title{Bayesian Regression Models using 'Stan'} -\description{ -\if{html}{ - \figure{stanlogo.png}{options: width="50px" alt="https://mc-stan.org/about/logo/"} - \emph{Stan Development Team} -} - -The \pkg{brms} package provides an interface to fit Bayesian generalized -multivariate (non-)linear multilevel models using \pkg{Stan}, which is a C++ -package for obtaining full Bayesian inference (see -\url{https://mc-stan.org/}). The formula syntax is an extended version of the -syntax applied in the \pkg{lme4} package to provide a familiar and simple -interface for performing regression analyses. -} -\details{ -The main function of \pkg{brms} is \code{\link{brm}}, which uses -formula syntax to specify a wide range of complex Bayesian models -(see \code{\link{brmsformula}} for details). Based on the supplied -formulas, data, and additional information, it writes the Stan code -on the fly via \code{\link{make_stancode}}, prepares the data via -\code{\link{make_standata}}, and fits the model using -\pkg{\link[rstan:rstan]{Stan}}. - -Subsequently, a large number of post-processing methods can be applied: -To get an overview on the estimated parameters, -\code{\link[brms:summary.brmsfit]{summary}} or -\code{\link[brms:conditional_effects.brmsfit]{conditional_effects}} -are perfectly suited. Detailed visual analyses can be performed by applying -the \code{\link{pp_check}} and \code{\link{stanplot}} methods, which both -rely on the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} package. -Model comparisons can be done via \code{\link{loo}} and \code{\link{waic}}, -which make use of the \pkg{\link[loo:loo-package]{loo}} package as well as -via \code{\link{bayes_factor}} which relies on the \pkg{bridgesampling} package. -For a full list of methods to apply, type \code{methods(class = "brmsfit")}. - -Because \pkg{brms} is based on \pkg{Stan}, a C++ compiler is required. The -program Rtools (available on -\url{https://cran.r-project.org/bin/windows/Rtools/}) comes with a C++ -compiler for Windows. On Mac, you should use Xcode. For further instructions -on how to get the compilers running, see the prerequisites section at the -\href{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}{RStan-Getting-Started} -page. - -When comparing other packages fitting multilevel models to \pkg{brms}, keep -in mind that the latter needs to compile models before actually fitting them, -which will require between 20 and 40 seconds depending on your machine, -operating system and overall model complexity. - -Thus, fitting smaller models may be relatively slow as compilation time makes -up the majority of the whole running time. For larger / more complex -models however, fitting my take several minutes or even hours, so that the -compilation time won't make much of a difference for these models. - -See \code{vignette("brms_overview")} and \code{vignette("brms_multilevel")} -for a general introduction and overview of \pkg{brms}. For a full list of -available vignettes, type \code{vignette(package = "brms")}. -} -\references{ -Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel -Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. -\code{doi:10.18637/jss.v080.i01} - -Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling -with the R Package brms. \emph{The R Journal}. 10(1), 395–411. -\code{doi:10.32614/RJ-2018-017} - -The Stan Development Team. \emph{Stan Modeling Language User's Guide and -Reference Manual}. \url{https://mc-stan.org/users/documentation/}. - -Stan Development Team (2020). RStan: the R interface to Stan. R package -version 2.21.2. \url{https://mc-stan.org/} -} -\seealso{ -\code{\link{brm}}, -\code{\link{brmsformula}}, -\code{\link{brmsfamily}}, -\code{\link{brmsfit}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brms-package.R +\docType{package} +\name{brms-package} +\alias{brms-package} +\alias{brms} +\title{Bayesian Regression Models using 'Stan'} +\description{ +\if{html}{ + \figure{stanlogo.png}{options: width="50" alt="https://mc-stan.org/about/logo/"} + \emph{Stan Development Team} +} + +The \pkg{brms} package provides an interface to fit Bayesian generalized +multivariate (non-)linear multilevel models using \pkg{Stan}, which is a C++ +package for obtaining full Bayesian inference (see +\url{https://mc-stan.org/}). The formula syntax is an extended version of the +syntax applied in the \pkg{lme4} package to provide a familiar and simple +interface for performing regression analyses. +} +\details{ +The main function of \pkg{brms} is \code{\link{brm}}, which uses +formula syntax to specify a wide range of complex Bayesian models +(see \code{\link{brmsformula}} for details). Based on the supplied +formulas, data, and additional information, it writes the Stan code +on the fly via \code{\link{make_stancode}}, prepares the data via +\code{\link{make_standata}}, and fits the model using +\pkg{\link[rstan:rstan]{Stan}}. + +Subsequently, a large number of post-processing methods can be applied: +To get an overview on the estimated parameters, +\code{\link[brms:summary.brmsfit]{summary}} or +\code{\link[brms:conditional_effects.brmsfit]{conditional_effects}} +are perfectly suited. Detailed visual analyses can be performed by applying +the \code{\link{pp_check}} and \code{\link{stanplot}} methods, which both +rely on the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} package. +Model comparisons can be done via \code{\link{loo}} and \code{\link{waic}}, +which make use of the \pkg{\link[loo:loo-package]{loo}} package as well as +via \code{\link{bayes_factor}} which relies on the \pkg{bridgesampling} package. +For a full list of methods to apply, type \code{methods(class = "brmsfit")}. + +Because \pkg{brms} is based on \pkg{Stan}, a C++ compiler is required. The +program Rtools (available on +\url{https://cran.r-project.org/bin/windows/Rtools/}) comes with a C++ +compiler for Windows. On Mac, you should use Xcode. For further instructions +on how to get the compilers running, see the prerequisites section at the +\href{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}{RStan-Getting-Started} +page. + +When comparing other packages fitting multilevel models to \pkg{brms}, keep +in mind that the latter needs to compile models before actually fitting them, +which will require between 20 and 40 seconds depending on your machine, +operating system and overall model complexity. + +Thus, fitting smaller models may be relatively slow as compilation time makes +up the majority of the whole running time. For larger / more complex +models however, fitting my take several minutes or even hours, so that the +compilation time won't make much of a difference for these models. + +See \code{vignette("brms_overview")} and \code{vignette("brms_multilevel")} +for a general introduction and overview of \pkg{brms}. For a full list of +available vignettes, type \code{vignette(package = "brms")}. +} +\references{ +Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel +Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. +\code{doi:10.18637/jss.v080.i01} + +Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling +with the R Package brms. \emph{The R Journal}. 10(1), 395–411. +\code{doi:10.32614/RJ-2018-017} + +The Stan Development Team. \emph{Stan Modeling Language User's Guide and +Reference Manual}. \url{https://mc-stan.org/users/documentation/}. + +Stan Development Team (2020). RStan: the R interface to Stan. R package +version 2.21.2. \url{https://mc-stan.org/} +} +\seealso{ +\code{\link{brm}}, +\code{\link{brmsformula}}, +\code{\link{brmsfamily}}, +\code{\link{brmsfit}} +} diff -Nru r-cran-brms-2.16.3/man/brmsterms.Rd r-cran-brms-2.17.0/man/brmsterms.Rd --- r-cran-brms-2.16.3/man/brmsterms.Rd 2020-07-08 07:08:40.000000000 +0000 +++ r-cran-brms-2.17.0/man/brmsterms.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,58 +1,58 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsterms.R -\name{brmsterms} -\alias{brmsterms} -\alias{parse_bf} -\alias{brmsterms.default} -\alias{brmsterms.brmsformula} -\alias{brmsterms.mvbrmsformula} -\title{Parse Formulas of \pkg{brms} Models} -\usage{ -brmsterms(formula, ...) - -\method{brmsterms}{default}(formula, ...) - -\method{brmsterms}{brmsformula}(formula, check_response = TRUE, resp_rhs_all = TRUE, ...) - -\method{brmsterms}{mvbrmsformula}(formula, ...) -} -\arguments{ -\item{formula}{An object of class \code{\link[stats:formula]{formula}}, -\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can -be coerced to that classes): A symbolic description of the model to be -fitted. The details of model specification are explained in -\code{\link{brmsformula}}.} - -\item{...}{Further arguments passed to or from other methods.} - -\item{check_response}{Logical; Indicates whether the left-hand side -of \code{formula} (i.e. response variables and addition arguments) -should be parsed. If \code{FALSE}, \code{formula} may also be one-sided.} - -\item{resp_rhs_all}{Logical; Indicates whether to also include response -variables on the right-hand side of formula \code{.$allvars}, -where \code{.} represents the output of \code{brmsterms}.} -} -\value{ -An object of class \code{brmsterms} or \code{mvbrmsterms} - (for multivariate models), which is a \code{list} containing all - required information initially stored in \code{formula} - in an easier to use format, basically a list of formulas - (not an abstract syntax tree). -} -\description{ -Parse formulas objects for use in \pkg{brms}. -} -\details{ -This is the main formula parsing function of \pkg{brms}. - It should usually not be called directly, but is exported to allow - package developers making use of the formula syntax implemented - in \pkg{brms}. As long as no other packages depend on this functions, - it may be changed without deprecation warnings, when new features make - this necessary. -} -\seealso{ -\code{\link{brm}}, - \code{\link{brmsformula}}, - \code{\link{mvbrmsformula}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsterms.R +\name{brmsterms} +\alias{brmsterms} +\alias{parse_bf} +\alias{brmsterms.default} +\alias{brmsterms.brmsformula} +\alias{brmsterms.mvbrmsformula} +\title{Parse Formulas of \pkg{brms} Models} +\usage{ +brmsterms(formula, ...) + +\method{brmsterms}{default}(formula, ...) + +\method{brmsterms}{brmsformula}(formula, check_response = TRUE, resp_rhs_all = TRUE, ...) + +\method{brmsterms}{mvbrmsformula}(formula, ...) +} +\arguments{ +\item{formula}{An object of class \code{\link[stats:formula]{formula}}, +\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can +be coerced to that classes): A symbolic description of the model to be +fitted. The details of model specification are explained in +\code{\link{brmsformula}}.} + +\item{...}{Further arguments passed to or from other methods.} + +\item{check_response}{Logical; Indicates whether the left-hand side +of \code{formula} (i.e. response variables and addition arguments) +should be parsed. If \code{FALSE}, \code{formula} may also be one-sided.} + +\item{resp_rhs_all}{Logical; Indicates whether to also include response +variables on the right-hand side of formula \code{.$allvars}, +where \code{.} represents the output of \code{brmsterms}.} +} +\value{ +An object of class \code{brmsterms} or \code{mvbrmsterms} + (for multivariate models), which is a \code{list} containing all + required information initially stored in \code{formula} + in an easier to use format, basically a list of formulas + (not an abstract syntax tree). +} +\description{ +Parse formulas objects for use in \pkg{brms}. +} +\details{ +This is the main formula parsing function of \pkg{brms}. + It should usually not be called directly, but is exported to allow + package developers making use of the formula syntax implemented + in \pkg{brms}. As long as no other packages depend on this functions, + it may be changed without deprecation warnings, when new features make + this necessary. +} +\seealso{ +\code{\link{brm}}, + \code{\link{brmsformula}}, + \code{\link{mvbrmsformula}} +} diff -Nru r-cran-brms-2.16.3/man/car.Rd r-cran-brms-2.17.0/man/car.Rd --- r-cran-brms-2.16.3/man/car.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/car.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,76 +1,76 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ac.R -\name{car} -\alias{car} -\title{Spatial conditional autoregressive (CAR) structures} -\usage{ -car(M, gr = NA, type = "escar") -} -\arguments{ -\item{M}{Adjacency matrix of locations. All non-zero entries are treated as -if the two locations are adjacent. If \code{gr} is specified, the row names -of \code{M} have to match the levels of the grouping factor.} - -\item{gr}{An optional grouping factor mapping observations to spatial -locations. If not specified, each observation is treated as a separate -location. It is recommended to always specify a grouping factor to allow -for handling of new data in post-processing methods.} - -\item{type}{Type of the CAR structure. Currently implemented are -\code{"escar"} (exact sparse CAR), \code{"esicar"} (exact sparse intrinsic -CAR), \code{"icar"} (intrinsic CAR), and \code{"bym2"}. More information is -provided in the 'Details' section.} -} -\value{ -An object of class \code{'car_term'}, which is a list - of arguments to be interpreted by the formula - parsing functions of \pkg{brms}. -} -\description{ -Set up an spatial conditional autoregressive (CAR) term in \pkg{brms}. The -function does not evaluate its arguments -- it exists purely to help set up a -model with CAR terms. -} -\details{ -The \code{escar} and \code{esicar} types are - implemented based on the case study of Max Joseph - (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and - \code{bym2} type is implemented based on the case study of Mitzi Morris - (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). -} -\examples{ -\dontrun{ -# generate some spatial data -east <- north <- 1:10 -Grid <- expand.grid(east, north) -K <- nrow(Grid) - -# set up distance and neighbourhood matrices -distance <- as.matrix(dist(Grid)) -W <- array(0, c(K, K)) -W[distance == 1] <- 1 - -# generate the covariates and response data -x1 <- rnorm(K) -x2 <- rnorm(K) -theta <- rnorm(K, sd = 0.05) -phi <- rmulti_normal( - 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) -) -eta <- x1 + x2 + phi -prob <- exp(eta) / (1 + exp(eta)) -size <- rep(50, K) -y <- rbinom(n = K, size = size, prob = prob) -dat <- data.frame(y, size, x1, x2) - -# fit a CAR model -fit <- brm(y | trials(size) ~ x1 + x2 + car(W), - data = dat, data2 = list(W = W), - family = binomial()) -summary(fit) -} - -} -\seealso{ -\code{\link{autocor-terms}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ac.R +\name{car} +\alias{car} +\title{Spatial conditional autoregressive (CAR) structures} +\usage{ +car(M, gr = NA, type = "escar") +} +\arguments{ +\item{M}{Adjacency matrix of locations. All non-zero entries are treated as +if the two locations are adjacent. If \code{gr} is specified, the row names +of \code{M} have to match the levels of the grouping factor.} + +\item{gr}{An optional grouping factor mapping observations to spatial +locations. If not specified, each observation is treated as a separate +location. It is recommended to always specify a grouping factor to allow +for handling of new data in post-processing methods.} + +\item{type}{Type of the CAR structure. Currently implemented are +\code{"escar"} (exact sparse CAR), \code{"esicar"} (exact sparse intrinsic +CAR), \code{"icar"} (intrinsic CAR), and \code{"bym2"}. More information is +provided in the 'Details' section.} +} +\value{ +An object of class \code{'car_term'}, which is a list + of arguments to be interpreted by the formula + parsing functions of \pkg{brms}. +} +\description{ +Set up an spatial conditional autoregressive (CAR) term in \pkg{brms}. The +function does not evaluate its arguments -- it exists purely to help set up a +model with CAR terms. +} +\details{ +The \code{escar} and \code{esicar} types are + implemented based on the case study of Max Joseph + (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and + \code{bym2} type is implemented based on the case study of Mitzi Morris + (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). +} +\examples{ +\dontrun{ +# generate some spatial data +east <- north <- 1:10 +Grid <- expand.grid(east, north) +K <- nrow(Grid) + +# set up distance and neighbourhood matrices +distance <- as.matrix(dist(Grid)) +W <- array(0, c(K, K)) +W[distance == 1] <- 1 + +# generate the covariates and response data +x1 <- rnorm(K) +x2 <- rnorm(K) +theta <- rnorm(K, sd = 0.05) +phi <- rmulti_normal( + 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) +) +eta <- x1 + x2 + phi +prob <- exp(eta) / (1 + exp(eta)) +size <- rep(50, K) +y <- rbinom(n = K, size = size, prob = prob) +dat <- data.frame(y, size, x1, x2) + +# fit a CAR model +fit <- brm(y | trials(size) ~ x1 + x2 + car(W), + data = dat, data2 = list(W = W), + family = binomial()) +summary(fit) +} + +} +\seealso{ +\code{\link{autocor-terms}} +} diff -Nru r-cran-brms-2.16.3/man/coef.brmsfit.Rd r-cran-brms-2.17.0/man/coef.brmsfit.Rd --- r-cran-brms-2.16.3/man/coef.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/coef.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,53 +1,53 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{coef.brmsfit} -\alias{coef.brmsfit} -\title{Extract Model Coefficients} -\usage{ -\method{coef}{brmsfit}(object, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{...}{Further arguments passed to \code{\link{fixef.brmsfit}} -and \code{\link{ranef.brmsfit}}.} -} -\value{ -A list of 3D arrays (one per grouping factor). - If \code{summary} is \code{TRUE}, - the 1st dimension contains the factor levels, - the 2nd dimension contains the summary statistics - (see \code{\link{posterior_summary}}), and - the 3rd dimension contains the group-level effects. - If \code{summary} is \code{FALSE}, the 1st dimension contains - the posterior draws, the 2nd dimension contains the factor levels, - and the 3rd dimension contains the group-level effects. -} -\description{ -Extract model coefficients, which are the sum of population-level -effects and corresponding group-level effects -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), - data = epilepsy, family = gaussian(), chains = 2) -## extract population and group-level coefficients separately -fixef(fit) -ranef(fit) -## extract combined coefficients -coef(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{coef.brmsfit} +\alias{coef.brmsfit} +\title{Extract Model Coefficients} +\usage{ +\method{coef}{brmsfit}(object, summary = TRUE, robust = FALSE, probs = c(0.025, 0.975), ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{...}{Further arguments passed to \code{\link{fixef.brmsfit}} +and \code{\link{ranef.brmsfit}}.} +} +\value{ +A list of 3D arrays (one per grouping factor). + If \code{summary} is \code{TRUE}, + the 1st dimension contains the factor levels, + the 2nd dimension contains the summary statistics + (see \code{\link{posterior_summary}}), and + the 3rd dimension contains the group-level effects. + If \code{summary} is \code{FALSE}, the 1st dimension contains + the posterior draws, the 2nd dimension contains the factor levels, + and the 3rd dimension contains the group-level effects. +} +\description{ +Extract model coefficients, which are the sum of population-level +effects and corresponding group-level effects +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), + data = epilepsy, family = gaussian(), chains = 2) +## extract population and group-level coefficients separately +fixef(fit) +ranef(fit) +## extract combined coefficients +coef(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/combine_models.Rd r-cran-brms-2.17.0/man/combine_models.Rd --- r-cran-brms-2.16.3/man/combine_models.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/combine_models.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,30 +1,30 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brm_multiple.R -\name{combine_models} -\alias{combine_models} -\title{Combine Models fitted with \pkg{brms}} -\usage{ -combine_models(..., mlist = NULL, check_data = TRUE) -} -\arguments{ -\item{...}{One or more \code{brmsfit} objects.} - -\item{mlist}{Optional list of one or more \code{brmsfit} objects.} - -\item{check_data}{Logical; indicates if the data should be checked -for being the same across models (defaults to \code{TRUE}). -Setting it to \code{FALSE} may be useful for instance -when combining models fitted on multiple imputed data sets.} -} -\value{ -A \code{brmsfit} object. -} -\description{ -Combine multiple \code{brmsfit} objects, which fitted the same model. -This is usefully for instance when having manually run models in parallel. -} -\details{ -This function just takes the first model and replaces - its \code{stanfit} object (slot \code{fit}) by the combined - \code{stanfit} objects of all models. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brm_multiple.R +\name{combine_models} +\alias{combine_models} +\title{Combine Models fitted with \pkg{brms}} +\usage{ +combine_models(..., mlist = NULL, check_data = TRUE) +} +\arguments{ +\item{...}{One or more \code{brmsfit} objects.} + +\item{mlist}{Optional list of one or more \code{brmsfit} objects.} + +\item{check_data}{Logical; indicates if the data should be checked +for being the same across models (defaults to \code{TRUE}). +Setting it to \code{FALSE} may be useful for instance +when combining models fitted on multiple imputed data sets.} +} +\value{ +A \code{brmsfit} object. +} +\description{ +Combine multiple \code{brmsfit} objects, which fitted the same model. +This is usefully for instance when having manually run models in parallel. +} +\details{ +This function just takes the first model and replaces + its \code{stanfit} object (slot \code{fit}) by the combined + \code{stanfit} objects of all models. +} diff -Nru r-cran-brms-2.16.3/man/compare_ic.Rd r-cran-brms-2.17.0/man/compare_ic.Rd --- r-cran-brms-2.16.3/man/compare_ic.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/compare_ic.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,57 +1,57 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo.R -\name{compare_ic} -\alias{compare_ic} -\title{Compare Information Criteria of Different Models} -\usage{ -compare_ic(..., x = NULL, ic = c("loo", "waic", "kfold")) -} -\arguments{ -\item{...}{At least two objects returned by -\code{\link{waic}} or \code{\link{loo}}. -Alternatively, \code{brmsfit} objects with information -criteria precomputed via \code{\link{add_ic}} -may be passed, as well.} - -\item{x}{A \code{list} containing the same types of objects as -can be passed via \code{...}.} - -\item{ic}{The name of the information criterion to be extracted -from \code{brmsfit} objects. Ignored if information -criterion objects are only passed directly.} -} -\value{ -An object of class \code{iclist}. -} -\description{ -Compare information criteria of different models fitted -with \code{\link{waic}} or \code{\link{loo}}. -Deprecated and will be removed in the future. Please use -\code{\link{loo_compare}} instead. -} -\details{ -See \code{\link{loo_compare}} for the recommended way - of comparing models with the \pkg{loo} package. -} -\examples{ -\dontrun{ -# model with population-level effects only -fit1 <- brm(rating ~ treat + period + carry, - data = inhaler) -waic1 <- waic(fit1) - -# model with an additional varying intercept for subjects -fit2 <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler) -waic2 <- waic(fit2) - -# compare both models -compare_ic(waic1, waic2) -} - -} -\seealso{ -\code{\link{loo}}, - \code{\link{loo_compare}} - \code{\link{add_criterion}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo.R +\name{compare_ic} +\alias{compare_ic} +\title{Compare Information Criteria of Different Models} +\usage{ +compare_ic(..., x = NULL, ic = c("loo", "waic", "kfold")) +} +\arguments{ +\item{...}{At least two objects returned by +\code{\link{waic}} or \code{\link{loo}}. +Alternatively, \code{brmsfit} objects with information +criteria precomputed via \code{\link{add_ic}} +may be passed, as well.} + +\item{x}{A \code{list} containing the same types of objects as +can be passed via \code{...}.} + +\item{ic}{The name of the information criterion to be extracted +from \code{brmsfit} objects. Ignored if information +criterion objects are only passed directly.} +} +\value{ +An object of class \code{iclist}. +} +\description{ +Compare information criteria of different models fitted +with \code{\link{waic}} or \code{\link{loo}}. +Deprecated and will be removed in the future. Please use +\code{\link{loo_compare}} instead. +} +\details{ +See \code{\link{loo_compare}} for the recommended way + of comparing models with the \pkg{loo} package. +} +\examples{ +\dontrun{ +# model with population-level effects only +fit1 <- brm(rating ~ treat + period + carry, + data = inhaler) +waic1 <- waic(fit1) + +# model with an additional varying intercept for subjects +fit2 <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler) +waic2 <- waic(fit2) + +# compare both models +compare_ic(waic1, waic2) +} + +} +\seealso{ +\code{\link{loo}}, + \code{\link{loo_compare}} + \code{\link{add_criterion}} +} diff -Nru r-cran-brms-2.16.3/man/conditional_effects.brmsfit.Rd r-cran-brms-2.17.0/man/conditional_effects.brmsfit.Rd --- r-cran-brms-2.16.3/man/conditional_effects.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/conditional_effects.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,322 +1,322 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/conditional_effects.R -\name{conditional_effects.brmsfit} -\alias{conditional_effects.brmsfit} -\alias{marginal_effects} -\alias{marginal_effects.brmsfit} -\alias{conditional_effects} -\alias{plot.brms_conditional_effects} -\title{Display Conditional Effects of Predictors} -\usage{ -\method{conditional_effects}{brmsfit}( - x, - effects = NULL, - conditions = NULL, - int_conditions = NULL, - re_formula = NA, - prob = 0.95, - robust = TRUE, - method = "posterior_epred", - spaghetti = FALSE, - surface = FALSE, - categorical = FALSE, - ordinal = FALSE, - transform = NULL, - resolution = 100, - select_points = 0, - too_far = 0, - probs = NULL, - ... -) - -conditional_effects(x, ...) - -\method{plot}{brms_conditional_effects}( - x, - ncol = NULL, - points = FALSE, - rug = FALSE, - mean = TRUE, - jitter_width = 0, - stype = c("contour", "raster"), - line_args = list(), - cat_args = list(), - errorbar_args = list(), - surface_args = list(), - spaghetti_args = list(), - point_args = list(), - rug_args = list(), - facet_args = list(), - theme = NULL, - ask = TRUE, - plot = TRUE, - ... -) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}.} - -\item{effects}{An optional character vector naming effects (main effects or -interactions) for which to compute conditional plots. Interactions are -specified by a \code{:} between variable names. If \code{NULL} (the -default), plots are generated for all main effects and two-way interactions -estimated in the model. When specifying \code{effects} manually, \emph{all} -two-way interactions (including grouping variables) may be plotted -even if not originally modeled.} - -\item{conditions}{An optional \code{data.frame} containing variable values -to condition on. Each effect defined in \code{effects} will -be plotted separately for each row of \code{conditions}. Values in the -\code{cond__} column will be used as titles of the subplots. If \code{cond__} -is not given, the row names will be used for this purpose instead. -It is recommended to only define a few rows in order to keep the plots clear. -See \code{\link{make_conditions}} for an easy way to define conditions. -If \code{NULL} (the default), numeric variables will be conditionalized by -using their means and factors will get their first level assigned. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{int_conditions}{An optional named \code{list} whose elements are -vectors of values of the variables specified in \code{effects}. -At these values, predictions are evaluated. The names of -\code{int_conditions} have to match the variable names exactly. -Additionally, the elements of the vectors may be named themselves, -in which case their names appear as labels for the conditions in the plots. -Instead of vectors, functions returning vectors may be passed and are -applied on the original values of the corresponding variable. -If \code{NULL} (the default), predictions are evaluated at the -\eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at -all categories for factor-like predictors.} - -\item{re_formula}{A formula containing group-level effects to be considered -in the conditional predictions. If \code{NULL}, include all group-level -effects; if \code{NA} (default), include no group-level effects.} - -\item{prob}{A value between 0 and 1 indicating the desired probability -to be covered by the uncertainty intervals. The default is 0.95.} - -\item{robust}{If \code{TRUE} (the default) the median is used as the -measure of central tendency. If \code{FALSE} the mean is used instead.} - -\item{method}{Method used to obtain predictions. Can be set to -\code{"posterior_epred"} (the default), \code{"posterior_predict"}, -or \code{"posterior_linpred"}. For more details, see the respective -function documentations.} - -\item{spaghetti}{Logical. Indicates if predictions should -be visualized via spaghetti plots. Only applied for numeric -predictors. If \code{TRUE}, it is recommended -to set argument \code{ndraws} to a relatively small value -(e.g., \code{100}) in order to reduce computation time.} - -\item{surface}{Logical. Indicates if interactions or -two-dimensional smooths should be visualized as a surface. -Defaults to \code{FALSE}. The surface type can be controlled -via argument \code{stype} of the related plotting method.} - -\item{categorical}{Logical. Indicates if effects of categorical -or ordinal models should be shown in terms of probabilities -of response categories. Defaults to \code{FALSE}.} - -\item{ordinal}{(Deprecated) Please use argument \code{categorical}. -Logical. Indicates if effects in ordinal models -should be visualized as a raster with the response categories -on the y-axis. Defaults to \code{FALSE}.} - -\item{transform}{A function or a character string naming -a function to be applied on the predicted responses -before summary statistics are computed. Only allowed -if \code{method = "posterior_predict"}.} - -\item{resolution}{Number of support points used to generate -the plots. Higher resolution leads to smoother plots. -Defaults to \code{100}. If \code{surface} is \code{TRUE}, -this implies \code{10000} support points for interaction terms, -so it might be necessary to reduce \code{resolution} -when only few RAM is available.} - -\item{select_points}{Positive number. -Only relevant if \code{points} or \code{rug} are set to \code{TRUE}: -Actual data points of numeric variables that -are too far away from the values specified in \code{conditions} -can be excluded from the plot. Values are scaled into -the unit interval and then points more than \code{select_points} -from the values in \code{conditions} are excluded. -By default, all points are used.} - -\item{too_far}{Positive number. -For surface plots only: Grid points that are too -far away from the actual data points can be excluded from the plot. -\code{too_far} determines what is too far. The grid is scaled into -the unit square and then grid points more than \code{too_far} -from the predictor variables are excluded. By default, all -grid points are used. Ignored for non-surface plots.} - -\item{probs}{(Deprecated) The quantiles to be used in the computation of -uncertainty intervals. Please use argument \code{prob} instead.} - -\item{...}{Further arguments such as \code{draw_ids} or \code{ndraws} -passed to \code{\link{posterior_predict}} or \code{\link{posterior_epred}}.} - -\item{ncol}{Number of plots to display per column for each effect. -If \code{NULL} (default), \code{ncol} is computed internally based -on the number of rows of \code{conditions}.} - -\item{points}{Logical. Indicates if the original data points -should be added via \code{\link{geom_jitter}}. -Default is \code{FALSE}. Note that only those data points will be added -that match the specified conditions defined in \code{conditions}. -For categorical predictors, the conditions have to match exactly. -For numeric predictors, argument \code{select_points} is used to -determine, which points do match a condition.} - -\item{rug}{Logical. Indicates if a rug representation of predictor -values should be added via \code{\link{geom_rug}}. -Default is \code{FALSE}. Depends on \code{select_points} in the same -way as \code{points} does.} - -\item{mean}{Logical. Only relevant for spaghetti plots. -If \code{TRUE} (the default), display the mean regression -line on top of the regression lines for each sample.} - -\item{jitter_width}{Only used if \code{points = TRUE}: -Amount of horizontal jittering of the data points. -Mainly useful for ordinal models. Defaults to \code{0} that -is no jittering.} - -\item{stype}{Indicates how surface plots should be displayed. -Either \code{"contour"} or \code{"raster"}.} - -\item{line_args}{Only used in plots of continuous predictors: -A named list of arguments passed to -\code{\link{geom_smooth}}.} - -\item{cat_args}{Only used in plots of categorical predictors: -A named list of arguments passed to -\code{\link{geom_point}}.} - -\item{errorbar_args}{Only used in plots of categorical predictors: -A named list of arguments passed to -\code{\link{geom_errorbar}}.} - -\item{surface_args}{Only used in surface plots: -A named list of arguments passed to -\code{\link{geom_contour}} or -\code{\link{geom_raster}} -(depending on argument \code{stype}).} - -\item{spaghetti_args}{Only used in spaghetti plots: -A named list of arguments passed to -\code{\link{geom_smooth}}.} - -\item{point_args}{Only used if \code{points = TRUE}: -A named list of arguments passed to -\code{\link{geom_jitter}}.} - -\item{rug_args}{Only used if \code{rug = TRUE}: -A named list of arguments passed to -\code{\link{geom_rug}}.} - -\item{facet_args}{Only used if if multiple condtions are provided: -A named list of arguments passed to -\code{\link{facet_wrap}}.} - -\item{theme}{A \code{\link[ggplot2:theme]{theme}} object -modifying the appearance of the plots. -For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} -and \code{\link[bayesplot:theme_default]{theme_default}}.} - -\item{ask}{Logical; indicates if the user is prompted -before a new page is plotted. -Only used if \code{plot} is \code{TRUE}.} - -\item{plot}{Logical; indicates if plots should be -plotted directly in the active graphic device. -Defaults to \code{TRUE}.} -} -\value{ -An object of class \code{'brms_conditional_effects'} which is a - named list with one data.frame per effect containing all information - required to generate conditional effects plots. Among others, these - data.frames contain some special variables, namely \code{estimate__} - (predicted values of the response), \code{se__} (standard error of the - predicted response), \code{lower__} and \code{upper__} (lower and upper - bounds of the uncertainty interval of the response), as well as - \code{cond__} (used in faceting when \code{conditions} contains multiple - rows). - - The corresponding \code{plot} method returns a named - list of \code{\link{ggplot}} objects, which can be further - customized using the \pkg{ggplot2} package. -} -\description{ -Display conditional effects of one or more numeric and/or categorical -predictors including two-way interaction effects. -} -\details{ -When creating \code{conditional_effects} for a particular predictor - (or interaction of two predictors), one has to choose the values of all - other predictors to condition on. By default, the mean is used for - continuous variables and the reference category is used for factors, but - you may change these values via argument \code{conditions}. This also has - an implication for the \code{points} argument: In the created plots, only - those points will be shown that correspond to the factor levels actually - used in the conditioning, in order not to create the false impression of - bad model fit, where it is just due to conditioning on certain factor - levels. - - To fully change colors of the created plots, one has to amend both - \code{scale_colour} and \code{scale_fill}. See - \code{\link{scale_colour_grey}} or \code{\link{scale_colour_gradient}} for - more details. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt + (1 | patient), - data = epilepsy, family = poisson()) - -## plot all conditional effects -plot(conditional_effects(fit), ask = FALSE) - -## change colours to grey scale -library(ggplot2) -me <- conditional_effects(fit, "zBase:Trt") -plot(me, plot = FALSE)[[1]] + - scale_color_grey() + - scale_fill_grey() - -## only plot the conditional interaction effect of 'zBase:Trt' -## for different values for 'zAge' -conditions <- data.frame(zAge = c(-1, 0, 1)) -plot(conditional_effects(fit, effects = "zBase:Trt", - conditions = conditions)) - -## also incorporate group-level effects variance over patients -## also add data points and a rug representation of predictor values -plot(conditional_effects(fit, effects = "zBase:Trt", - conditions = conditions, re_formula = NULL), - points = TRUE, rug = TRUE) - -## change handling of two-way interactions -int_conditions <- list( - zBase = setNames(c(-2, 1, 0), c("b", "c", "a")) -) -conditional_effects(fit, effects = "Trt:zBase", - int_conditions = int_conditions) -conditional_effects(fit, effects = "Trt:zBase", - int_conditions = list(zBase = quantile)) - -## fit a model to illustrate how to plot 3-way interactions -fit3way <- brm(count ~ zAge * zBase * Trt, data = epilepsy) -conditions <- make_conditions(fit3way, "zAge") -conditional_effects(fit3way, "zBase:Trt", conditions = conditions) -## only include points close to the specified values of zAge -me <- conditional_effects( - fit3way, "zBase:Trt", conditions = conditions, - select_points = 0.1 -) -plot(me, points = TRUE) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/conditional_effects.R +\name{conditional_effects.brmsfit} +\alias{conditional_effects.brmsfit} +\alias{marginal_effects} +\alias{marginal_effects.brmsfit} +\alias{conditional_effects} +\alias{plot.brms_conditional_effects} +\title{Display Conditional Effects of Predictors} +\usage{ +\method{conditional_effects}{brmsfit}( + x, + effects = NULL, + conditions = NULL, + int_conditions = NULL, + re_formula = NA, + prob = 0.95, + robust = TRUE, + method = "posterior_epred", + spaghetti = FALSE, + surface = FALSE, + categorical = FALSE, + ordinal = FALSE, + transform = NULL, + resolution = 100, + select_points = 0, + too_far = 0, + probs = NULL, + ... +) + +conditional_effects(x, ...) + +\method{plot}{brms_conditional_effects}( + x, + ncol = NULL, + points = FALSE, + rug = FALSE, + mean = TRUE, + jitter_width = 0, + stype = c("contour", "raster"), + line_args = list(), + cat_args = list(), + errorbar_args = list(), + surface_args = list(), + spaghetti_args = list(), + point_args = list(), + rug_args = list(), + facet_args = list(), + theme = NULL, + ask = TRUE, + plot = TRUE, + ... +) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}.} + +\item{effects}{An optional character vector naming effects (main effects or +interactions) for which to compute conditional plots. Interactions are +specified by a \code{:} between variable names. If \code{NULL} (the +default), plots are generated for all main effects and two-way interactions +estimated in the model. When specifying \code{effects} manually, \emph{all} +two-way interactions (including grouping variables) may be plotted +even if not originally modeled.} + +\item{conditions}{An optional \code{data.frame} containing variable values +to condition on. Each effect defined in \code{effects} will +be plotted separately for each row of \code{conditions}. Values in the +\code{cond__} column will be used as titles of the subplots. If \code{cond__} +is not given, the row names will be used for this purpose instead. +It is recommended to only define a few rows in order to keep the plots clear. +See \code{\link{make_conditions}} for an easy way to define conditions. +If \code{NULL} (the default), numeric variables will be conditionalized by +using their means and factors will get their first level assigned. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{int_conditions}{An optional named \code{list} whose elements are +vectors of values of the variables specified in \code{effects}. +At these values, predictions are evaluated. The names of +\code{int_conditions} have to match the variable names exactly. +Additionally, the elements of the vectors may be named themselves, +in which case their names appear as labels for the conditions in the plots. +Instead of vectors, functions returning vectors may be passed and are +applied on the original values of the corresponding variable. +If \code{NULL} (the default), predictions are evaluated at the +\eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at +all categories for factor-like predictors.} + +\item{re_formula}{A formula containing group-level effects to be considered +in the conditional predictions. If \code{NULL}, include all group-level +effects; if \code{NA} (default), include no group-level effects.} + +\item{prob}{A value between 0 and 1 indicating the desired probability +to be covered by the uncertainty intervals. The default is 0.95.} + +\item{robust}{If \code{TRUE} (the default) the median is used as the +measure of central tendency. If \code{FALSE} the mean is used instead.} + +\item{method}{Method used to obtain predictions. Can be set to +\code{"posterior_epred"} (the default), \code{"posterior_predict"}, +or \code{"posterior_linpred"}. For more details, see the respective +function documentations.} + +\item{spaghetti}{Logical. Indicates if predictions should +be visualized via spaghetti plots. Only applied for numeric +predictors. If \code{TRUE}, it is recommended +to set argument \code{ndraws} to a relatively small value +(e.g., \code{100}) in order to reduce computation time.} + +\item{surface}{Logical. Indicates if interactions or +two-dimensional smooths should be visualized as a surface. +Defaults to \code{FALSE}. The surface type can be controlled +via argument \code{stype} of the related plotting method.} + +\item{categorical}{Logical. Indicates if effects of categorical +or ordinal models should be shown in terms of probabilities +of response categories. Defaults to \code{FALSE}.} + +\item{ordinal}{(Deprecated) Please use argument \code{categorical}. +Logical. Indicates if effects in ordinal models +should be visualized as a raster with the response categories +on the y-axis. Defaults to \code{FALSE}.} + +\item{transform}{A function or a character string naming +a function to be applied on the predicted responses +before summary statistics are computed. Only allowed +if \code{method = "posterior_predict"}.} + +\item{resolution}{Number of support points used to generate +the plots. Higher resolution leads to smoother plots. +Defaults to \code{100}. If \code{surface} is \code{TRUE}, +this implies \code{10000} support points for interaction terms, +so it might be necessary to reduce \code{resolution} +when only few RAM is available.} + +\item{select_points}{Positive number. +Only relevant if \code{points} or \code{rug} are set to \code{TRUE}: +Actual data points of numeric variables that +are too far away from the values specified in \code{conditions} +can be excluded from the plot. Values are scaled into +the unit interval and then points more than \code{select_points} +from the values in \code{conditions} are excluded. +By default, all points are used.} + +\item{too_far}{Positive number. +For surface plots only: Grid points that are too +far away from the actual data points can be excluded from the plot. +\code{too_far} determines what is too far. The grid is scaled into +the unit square and then grid points more than \code{too_far} +from the predictor variables are excluded. By default, all +grid points are used. Ignored for non-surface plots.} + +\item{probs}{(Deprecated) The quantiles to be used in the computation of +uncertainty intervals. Please use argument \code{prob} instead.} + +\item{...}{Further arguments such as \code{draw_ids} or \code{ndraws} +passed to \code{\link{posterior_predict}} or \code{\link{posterior_epred}}.} + +\item{ncol}{Number of plots to display per column for each effect. +If \code{NULL} (default), \code{ncol} is computed internally based +on the number of rows of \code{conditions}.} + +\item{points}{Logical. Indicates if the original data points +should be added via \code{\link{geom_jitter}}. +Default is \code{FALSE}. Note that only those data points will be added +that match the specified conditions defined in \code{conditions}. +For categorical predictors, the conditions have to match exactly. +For numeric predictors, argument \code{select_points} is used to +determine, which points do match a condition.} + +\item{rug}{Logical. Indicates if a rug representation of predictor +values should be added via \code{\link{geom_rug}}. +Default is \code{FALSE}. Depends on \code{select_points} in the same +way as \code{points} does.} + +\item{mean}{Logical. Only relevant for spaghetti plots. +If \code{TRUE} (the default), display the mean regression +line on top of the regression lines for each sample.} + +\item{jitter_width}{Only used if \code{points = TRUE}: +Amount of horizontal jittering of the data points. +Mainly useful for ordinal models. Defaults to \code{0} that +is no jittering.} + +\item{stype}{Indicates how surface plots should be displayed. +Either \code{"contour"} or \code{"raster"}.} + +\item{line_args}{Only used in plots of continuous predictors: +A named list of arguments passed to +\code{\link{geom_smooth}}.} + +\item{cat_args}{Only used in plots of categorical predictors: +A named list of arguments passed to +\code{\link{geom_point}}.} + +\item{errorbar_args}{Only used in plots of categorical predictors: +A named list of arguments passed to +\code{\link{geom_errorbar}}.} + +\item{surface_args}{Only used in surface plots: +A named list of arguments passed to +\code{\link{geom_contour}} or +\code{\link{geom_raster}} +(depending on argument \code{stype}).} + +\item{spaghetti_args}{Only used in spaghetti plots: +A named list of arguments passed to +\code{\link{geom_smooth}}.} + +\item{point_args}{Only used if \code{points = TRUE}: +A named list of arguments passed to +\code{\link{geom_jitter}}.} + +\item{rug_args}{Only used if \code{rug = TRUE}: +A named list of arguments passed to +\code{\link{geom_rug}}.} + +\item{facet_args}{Only used if if multiple condtions are provided: +A named list of arguments passed to +\code{\link{facet_wrap}}.} + +\item{theme}{A \code{\link[ggplot2:theme]{theme}} object +modifying the appearance of the plots. +For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} +and \code{\link[bayesplot:theme_default]{theme_default}}.} + +\item{ask}{Logical; indicates if the user is prompted +before a new page is plotted. +Only used if \code{plot} is \code{TRUE}.} + +\item{plot}{Logical; indicates if plots should be +plotted directly in the active graphic device. +Defaults to \code{TRUE}.} +} +\value{ +An object of class \code{'brms_conditional_effects'} which is a + named list with one data.frame per effect containing all information + required to generate conditional effects plots. Among others, these + data.frames contain some special variables, namely \code{estimate__} + (predicted values of the response), \code{se__} (standard error of the + predicted response), \code{lower__} and \code{upper__} (lower and upper + bounds of the uncertainty interval of the response), as well as + \code{cond__} (used in faceting when \code{conditions} contains multiple + rows). + + The corresponding \code{plot} method returns a named + list of \code{\link{ggplot}} objects, which can be further + customized using the \pkg{ggplot2} package. +} +\description{ +Display conditional effects of one or more numeric and/or categorical +predictors including two-way interaction effects. +} +\details{ +When creating \code{conditional_effects} for a particular predictor + (or interaction of two predictors), one has to choose the values of all + other predictors to condition on. By default, the mean is used for + continuous variables and the reference category is used for factors, but + you may change these values via argument \code{conditions}. This also has + an implication for the \code{points} argument: In the created plots, only + those points will be shown that correspond to the factor levels actually + used in the conditioning, in order not to create the false impression of + bad model fit, where it is just due to conditioning on certain factor + levels. + + To fully change colors of the created plots, one has to amend both + \code{scale_colour} and \code{scale_fill}. See + \code{\link{scale_colour_grey}} or \code{\link{scale_colour_gradient}} for + more details. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + (1 | patient), + data = epilepsy, family = poisson()) + +## plot all conditional effects +plot(conditional_effects(fit), ask = FALSE) + +## change colours to grey scale +library(ggplot2) +me <- conditional_effects(fit, "zBase:Trt") +plot(me, plot = FALSE)[[1]] + + scale_color_grey() + + scale_fill_grey() + +## only plot the conditional interaction effect of 'zBase:Trt' +## for different values for 'zAge' +conditions <- data.frame(zAge = c(-1, 0, 1)) +plot(conditional_effects(fit, effects = "zBase:Trt", + conditions = conditions)) + +## also incorporate group-level effects variance over patients +## also add data points and a rug representation of predictor values +plot(conditional_effects(fit, effects = "zBase:Trt", + conditions = conditions, re_formula = NULL), + points = TRUE, rug = TRUE) + +## change handling of two-way interactions +int_conditions <- list( + zBase = setNames(c(-2, 1, 0), c("b", "c", "a")) +) +conditional_effects(fit, effects = "Trt:zBase", + int_conditions = int_conditions) +conditional_effects(fit, effects = "Trt:zBase", + int_conditions = list(zBase = quantile)) + +## fit a model to illustrate how to plot 3-way interactions +fit3way <- brm(count ~ zAge * zBase * Trt, data = epilepsy) +conditions <- make_conditions(fit3way, "zAge") +conditional_effects(fit3way, "zBase:Trt", conditions = conditions) +## only include points close to the specified values of zAge +me <- conditional_effects( + fit3way, "zBase:Trt", conditions = conditions, + select_points = 0.1 +) +plot(me, points = TRUE) +} + +} diff -Nru r-cran-brms-2.16.3/man/conditional_smooths.brmsfit.Rd r-cran-brms-2.17.0/man/conditional_smooths.brmsfit.Rd --- r-cran-brms-2.16.3/man/conditional_smooths.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/conditional_smooths.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,120 +1,120 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/conditional_smooths.R -\name{conditional_smooths.brmsfit} -\alias{conditional_smooths.brmsfit} -\alias{marginal_smooths} -\alias{marginal_smooths.brmsfit} -\alias{conditional_smooths} -\title{Display Smooth Terms} -\usage{ -\method{conditional_smooths}{brmsfit}( - x, - smooths = NULL, - int_conditions = NULL, - prob = 0.95, - spaghetti = FALSE, - resolution = 100, - too_far = 0, - ndraws = NULL, - draw_ids = NULL, - nsamples = NULL, - subset = NULL, - probs = NULL, - ... -) - -conditional_smooths(x, ...) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}.} - -\item{smooths}{Optional character vector of smooth terms -to display. If \code{NULL} (the default) all smooth terms -are shown.} - -\item{int_conditions}{An optional named \code{list} whose elements are -vectors of values of the variables specified in \code{effects}. -At these values, predictions are evaluated. The names of -\code{int_conditions} have to match the variable names exactly. -Additionally, the elements of the vectors may be named themselves, -in which case their names appear as labels for the conditions in the plots. -Instead of vectors, functions returning vectors may be passed and are -applied on the original values of the corresponding variable. -If \code{NULL} (the default), predictions are evaluated at the -\eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at -all categories for factor-like predictors.} - -\item{prob}{A value between 0 and 1 indicating the desired probability -to be covered by the uncertainty intervals. The default is 0.95.} - -\item{spaghetti}{Logical. Indicates if predictions should -be visualized via spaghetti plots. Only applied for numeric -predictors. If \code{TRUE}, it is recommended -to set argument \code{ndraws} to a relatively small value -(e.g., \code{100}) in order to reduce computation time.} - -\item{resolution}{Number of support points used to generate -the plots. Higher resolution leads to smoother plots. -Defaults to \code{100}. If \code{surface} is \code{TRUE}, -this implies \code{10000} support points for interaction terms, -so it might be necessary to reduce \code{resolution} -when only few RAM is available.} - -\item{too_far}{Positive number. -For surface plots only: Grid points that are too -far away from the actual data points can be excluded from the plot. -\code{too_far} determines what is too far. The grid is scaled into -the unit square and then grid points more than \code{too_far} -from the predictor variables are excluded. By default, all -grid points are used. Ignored for non-surface plots.} - -\item{ndraws}{Positive integer indicating how many -posterior draws should be used. -If \code{NULL} (the default) all draws are used. -Ignored if \code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying -the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{nsamples}{Deprecated alias of \code{ndraws}.} - -\item{subset}{Deprecated alias of \code{draw_ids}.} - -\item{probs}{(Deprecated) The quantiles to be used in the computation of -uncertainty intervals. Please use argument \code{prob} instead.} - -\item{...}{Currently ignored.} -} -\value{ -For the \code{brmsfit} method, -an object of class \code{brms_conditional_effects}. See -\code{\link{conditional_effects}} for -more details and documentation of the related plotting function. -} -\description{ -Display smooth \code{s} and \code{t2} terms of models -fitted with \pkg{brms}. -} -\details{ -Two-dimensional smooth terms will be visualized using - either contour or raster plots. -} -\examples{ -\dontrun{ -set.seed(0) -dat <- mgcv::gamSim(1, n = 200, scale = 2) -fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) -# show all smooth terms -plot(conditional_smooths(fit), rug = TRUE, ask = FALSE) -# show only the smooth term s(x2) -plot(conditional_smooths(fit, smooths = "s(x2)"), ask = FALSE) - -# fit and plot a two-dimensional smooth term -fit2 <- brm(y ~ t2(x0, x2), data = dat) -ms <- conditional_smooths(fit2) -plot(ms, stype = "contour") -plot(ms, stype = "raster") -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/conditional_smooths.R +\name{conditional_smooths.brmsfit} +\alias{conditional_smooths.brmsfit} +\alias{marginal_smooths} +\alias{marginal_smooths.brmsfit} +\alias{conditional_smooths} +\title{Display Smooth Terms} +\usage{ +\method{conditional_smooths}{brmsfit}( + x, + smooths = NULL, + int_conditions = NULL, + prob = 0.95, + spaghetti = FALSE, + resolution = 100, + too_far = 0, + ndraws = NULL, + draw_ids = NULL, + nsamples = NULL, + subset = NULL, + probs = NULL, + ... +) + +conditional_smooths(x, ...) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}.} + +\item{smooths}{Optional character vector of smooth terms +to display. If \code{NULL} (the default) all smooth terms +are shown.} + +\item{int_conditions}{An optional named \code{list} whose elements are +vectors of values of the variables specified in \code{effects}. +At these values, predictions are evaluated. The names of +\code{int_conditions} have to match the variable names exactly. +Additionally, the elements of the vectors may be named themselves, +in which case their names appear as labels for the conditions in the plots. +Instead of vectors, functions returning vectors may be passed and are +applied on the original values of the corresponding variable. +If \code{NULL} (the default), predictions are evaluated at the +\eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at +all categories for factor-like predictors.} + +\item{prob}{A value between 0 and 1 indicating the desired probability +to be covered by the uncertainty intervals. The default is 0.95.} + +\item{spaghetti}{Logical. Indicates if predictions should +be visualized via spaghetti plots. Only applied for numeric +predictors. If \code{TRUE}, it is recommended +to set argument \code{ndraws} to a relatively small value +(e.g., \code{100}) in order to reduce computation time.} + +\item{resolution}{Number of support points used to generate +the plots. Higher resolution leads to smoother plots. +Defaults to \code{100}. If \code{surface} is \code{TRUE}, +this implies \code{10000} support points for interaction terms, +so it might be necessary to reduce \code{resolution} +when only few RAM is available.} + +\item{too_far}{Positive number. +For surface plots only: Grid points that are too +far away from the actual data points can be excluded from the plot. +\code{too_far} determines what is too far. The grid is scaled into +the unit square and then grid points more than \code{too_far} +from the predictor variables are excluded. By default, all +grid points are used. Ignored for non-surface plots.} + +\item{ndraws}{Positive integer indicating how many +posterior draws should be used. +If \code{NULL} (the default) all draws are used. +Ignored if \code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying +the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{nsamples}{Deprecated alias of \code{ndraws}.} + +\item{subset}{Deprecated alias of \code{draw_ids}.} + +\item{probs}{(Deprecated) The quantiles to be used in the computation of +uncertainty intervals. Please use argument \code{prob} instead.} + +\item{...}{Currently ignored.} +} +\value{ +For the \code{brmsfit} method, +an object of class \code{brms_conditional_effects}. See +\code{\link{conditional_effects}} for +more details and documentation of the related plotting function. +} +\description{ +Display smooth \code{s} and \code{t2} terms of models +fitted with \pkg{brms}. +} +\details{ +Two-dimensional smooth terms will be visualized using + either contour or raster plots. +} +\examples{ +\dontrun{ +set.seed(0) +dat <- mgcv::gamSim(1, n = 200, scale = 2) +fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) +# show all smooth terms +plot(conditional_smooths(fit), rug = TRUE, ask = FALSE) +# show only the smooth term s(x2) +plot(conditional_smooths(fit, smooths = "s(x2)"), ask = FALSE) + +# fit and plot a two-dimensional smooth term +fit2 <- brm(y ~ t2(x0, x2), data = dat) +ms <- conditional_smooths(fit2) +plot(ms, stype = "contour") +plot(ms, stype = "raster") +} + +} diff -Nru r-cran-brms-2.16.3/man/control_params.Rd r-cran-brms-2.17.0/man/control_params.Rd --- r-cran-brms-2.16.3/man/control_params.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/control_params.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,27 +1,27 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/diagnostics.R -\name{control_params} -\alias{control_params} -\alias{control_params.brmsfit} -\title{Extract Control Parameters of the NUTS Sampler} -\usage{ -control_params(x, ...) - -\method{control_params}{brmsfit}(x, pars = NULL, ...) -} -\arguments{ -\item{x}{An \R object} - -\item{...}{Currently ignored.} - -\item{pars}{Optional names of the control parameters to be returned. -If \code{NULL} (the default) all control parameters are returned. -See \code{\link[rstan:stan]{stan}} for more details.} -} -\value{ -A named \code{list} with control parameter values. -} -\description{ -Extract control parameters of the NUTS sampler such as -\code{adapt_delta} or \code{max_treedepth}. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/diagnostics.R +\name{control_params} +\alias{control_params} +\alias{control_params.brmsfit} +\title{Extract Control Parameters of the NUTS Sampler} +\usage{ +control_params(x, ...) + +\method{control_params}{brmsfit}(x, pars = NULL, ...) +} +\arguments{ +\item{x}{An \R object} + +\item{...}{Currently ignored.} + +\item{pars}{Optional names of the control parameters to be returned. +If \code{NULL} (the default) all control parameters are returned. +See \code{\link[rstan:stan]{stan}} for more details.} +} +\value{ +A named \code{list} with control parameter values. +} +\description{ +Extract control parameters of the NUTS sampler such as +\code{adapt_delta} or \code{max_treedepth}. +} diff -Nru r-cran-brms-2.16.3/man/cor_arma.Rd r-cran-brms-2.17.0/man/cor_arma.Rd --- r-cran-brms-2.16.3/man/cor_arma.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_arma.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,53 +1,53 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_arma} -\alias{cor_arma} -\alias{cor_arma-class} -\title{(Deprecated) ARMA(p,q) correlation structure} -\usage{ -cor_arma(formula = ~1, p = 0, q = 0, r = 0, cov = FALSE) -} -\arguments{ -\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, -specifying a time covariate \code{t} and, optionally, a grouping factor -\code{g}. A covariate for this correlation structure must be integer -valued. When a grouping factor is present in \code{formula}, the -correlation structure is assumed to apply only to observations within the -same grouping level; observations with different grouping levels are -assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to -using the order of the observations in the data as a covariate, and no -groups.} - -\item{p}{A non-negative integer specifying the autoregressive (AR) -order of the ARMA structure. Default is 0.} - -\item{q}{A non-negative integer specifying the moving average (MA) -order of the ARMA structure. Default is 0.} - -\item{r}{No longer supported.} - -\item{cov}{A flag indicating whether ARMA effects should be estimated by -means of residual covariance matrices. This is currently only possible for -stationary ARMA effects of order 1. If the model family does not have -natural residuals, latent residuals are added automatically. If -\code{FALSE} (the default) a regression formulation is used that is -considerably faster and allows for ARMA effects of order higher than 1 but -is only available for \code{gaussian} models and some of its -generalizations.} -} -\value{ -An object of class \code{cor_arma}, representing an - autoregression-moving-average correlation structure. -} -\description{ -This function is deprecated. Please see \code{\link{arma}} for the new syntax. -This functions is a constructor for the \code{cor_arma} class, representing -an autoregression-moving average correlation structure of order (p, q). -} -\examples{ -cor_arma(~ visit | patient, p = 2, q = 2) - -} -\seealso{ -\code{\link{cor_ar}}, \code{\link{cor_ma}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_arma} +\alias{cor_arma} +\alias{cor_arma-class} +\title{(Deprecated) ARMA(p,q) correlation structure} +\usage{ +cor_arma(formula = ~1, p = 0, q = 0, r = 0, cov = FALSE) +} +\arguments{ +\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, +specifying a time covariate \code{t} and, optionally, a grouping factor +\code{g}. A covariate for this correlation structure must be integer +valued. When a grouping factor is present in \code{formula}, the +correlation structure is assumed to apply only to observations within the +same grouping level; observations with different grouping levels are +assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to +using the order of the observations in the data as a covariate, and no +groups.} + +\item{p}{A non-negative integer specifying the autoregressive (AR) +order of the ARMA structure. Default is 0.} + +\item{q}{A non-negative integer specifying the moving average (MA) +order of the ARMA structure. Default is 0.} + +\item{r}{No longer supported.} + +\item{cov}{A flag indicating whether ARMA effects should be estimated by +means of residual covariance matrices. This is currently only possible for +stationary ARMA effects of order 1. If the model family does not have +natural residuals, latent residuals are added automatically. If +\code{FALSE} (the default) a regression formulation is used that is +considerably faster and allows for ARMA effects of order higher than 1 but +is only available for \code{gaussian} models and some of its +generalizations.} +} +\value{ +An object of class \code{cor_arma}, representing an + autoregression-moving-average correlation structure. +} +\description{ +This function is deprecated. Please see \code{\link{arma}} for the new syntax. +This functions is a constructor for the \code{cor_arma} class, representing +an autoregression-moving average correlation structure of order (p, q). +} +\examples{ +cor_arma(~ visit | patient, p = 2, q = 2) + +} +\seealso{ +\code{\link{cor_ar}}, \code{\link{cor_ma}} +} diff -Nru r-cran-brms-2.16.3/man/cor_ar.Rd r-cran-brms-2.17.0/man/cor_ar.Rd --- r-cran-brms-2.16.3/man/cor_ar.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_ar.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,52 +1,52 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_ar} -\alias{cor_ar} -\title{(Deprecated) AR(p) correlation structure} -\usage{ -cor_ar(formula = ~1, p = 1, cov = FALSE) -} -\arguments{ -\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, -specifying a time covariate \code{t} and, optionally, a grouping factor -\code{g}. A covariate for this correlation structure must be integer -valued. When a grouping factor is present in \code{formula}, the -correlation structure is assumed to apply only to observations within the -same grouping level; observations with different grouping levels are -assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to -using the order of the observations in the data as a covariate, and no -groups.} - -\item{p}{A non-negative integer specifying the autoregressive (AR) -order of the ARMA structure. Default is 1.} - -\item{cov}{A flag indicating whether ARMA effects should be estimated by -means of residual covariance matrices. This is currently only possible for -stationary ARMA effects of order 1. If the model family does not have -natural residuals, latent residuals are added automatically. If -\code{FALSE} (the default) a regression formulation is used that is -considerably faster and allows for ARMA effects of order higher than 1 but -is only available for \code{gaussian} models and some of its -generalizations.} -} -\value{ -An object of class \code{cor_arma} containing solely autoregression terms. -} -\description{ -This function is deprecated. Please see \code{\link{ar}} for the new syntax. -This function is a constructor for the \code{cor_arma} class, -allowing for autoregression terms only. -} -\details{ -AR refers to autoregressive effects of residuals, which - is what is typically understood as autoregressive effects. - However, one may also model autoregressive effects of the response - variable, which is called ARR in \pkg{brms}. -} -\examples{ -cor_ar(~visit|patient, p = 2) - -} -\seealso{ -\code{\link{cor_arma}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_ar} +\alias{cor_ar} +\title{(Deprecated) AR(p) correlation structure} +\usage{ +cor_ar(formula = ~1, p = 1, cov = FALSE) +} +\arguments{ +\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, +specifying a time covariate \code{t} and, optionally, a grouping factor +\code{g}. A covariate for this correlation structure must be integer +valued. When a grouping factor is present in \code{formula}, the +correlation structure is assumed to apply only to observations within the +same grouping level; observations with different grouping levels are +assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to +using the order of the observations in the data as a covariate, and no +groups.} + +\item{p}{A non-negative integer specifying the autoregressive (AR) +order of the ARMA structure. Default is 1.} + +\item{cov}{A flag indicating whether ARMA effects should be estimated by +means of residual covariance matrices. This is currently only possible for +stationary ARMA effects of order 1. If the model family does not have +natural residuals, latent residuals are added automatically. If +\code{FALSE} (the default) a regression formulation is used that is +considerably faster and allows for ARMA effects of order higher than 1 but +is only available for \code{gaussian} models and some of its +generalizations.} +} +\value{ +An object of class \code{cor_arma} containing solely autoregression terms. +} +\description{ +This function is deprecated. Please see \code{\link{ar}} for the new syntax. +This function is a constructor for the \code{cor_arma} class, +allowing for autoregression terms only. +} +\details{ +AR refers to autoregressive effects of residuals, which + is what is typically understood as autoregressive effects. + However, one may also model autoregressive effects of the response + variable, which is called ARR in \pkg{brms}. +} +\examples{ +cor_ar(~visit|patient, p = 2) + +} +\seealso{ +\code{\link{cor_arma}} +} diff -Nru r-cran-brms-2.16.3/man/cor_arr.Rd r-cran-brms-2.17.0/man/cor_arr.Rd --- r-cran-brms-2.16.3/man/cor_arr.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_arr.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,25 +1,25 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_arr} -\alias{cor_arr} -\title{(Defunct) ARR correlation structure} -\usage{ -cor_arr(formula = ~1, r = 1) -} -\arguments{ -\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, -specifying a time covariate \code{t} and, optionally, a grouping factor -\code{g}. A covariate for this correlation structure must be integer -valued. When a grouping factor is present in \code{formula}, the -correlation structure is assumed to apply only to observations within the -same grouping level; observations with different grouping levels are -assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to -using the order of the observations in the data as a covariate, and no -groups.} - -\item{r}{No longer supported.} -} -\description{ -The ARR correlation structure is no longer supported. -} -\keyword{internal} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_arr} +\alias{cor_arr} +\title{(Defunct) ARR correlation structure} +\usage{ +cor_arr(formula = ~1, r = 1) +} +\arguments{ +\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, +specifying a time covariate \code{t} and, optionally, a grouping factor +\code{g}. A covariate for this correlation structure must be integer +valued. When a grouping factor is present in \code{formula}, the +correlation structure is assumed to apply only to observations within the +same grouping level; observations with different grouping levels are +assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to +using the order of the observations in the data as a covariate, and no +groups.} + +\item{r}{No longer supported.} +} +\description{ +The ARR correlation structure is no longer supported. +} +\keyword{internal} diff -Nru r-cran-brms-2.16.3/man/cor_brms.Rd r-cran-brms-2.17.0/man/cor_brms.Rd --- r-cran-brms-2.16.3/man/cor_brms.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_brms.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,29 +1,29 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_brms} -\alias{cor_brms} -\alias{cor_brms-class} -\title{(Deprecated) Correlation structure classes for the \pkg{brms} package} -\description{ -Classes of correlation structures available in the \pkg{brms} package. -\code{cor_brms} is not a correlation structure itself, -but the class common to all correlation structures implemented in \pkg{brms}. -} -\section{Available correlation structures}{ - -\describe{ - \item{cor_arma}{autoregressive-moving average (ARMA) structure, - with arbitrary orders for the autoregressive and moving - average components} - \item{cor_ar}{autoregressive (AR) structure of arbitrary order} - \item{cor_ma}{moving average (MA) structure of arbitrary order} - \item{cor_car}{Spatial conditional autoregressive (CAR) structure} - \item{cor_sar}{Spatial simultaneous autoregressive (SAR) structure} - \item{cor_fixed}{fixed user-defined covariance structure} -} -} - -\seealso{ -\code{\link{cor_arma}, \link{cor_ar}, \link{cor_ma}, - \link{cor_car}, \link{cor_sar}, \link{cor_fixed}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_brms} +\alias{cor_brms} +\alias{cor_brms-class} +\title{(Deprecated) Correlation structure classes for the \pkg{brms} package} +\description{ +Classes of correlation structures available in the \pkg{brms} package. +\code{cor_brms} is not a correlation structure itself, +but the class common to all correlation structures implemented in \pkg{brms}. +} +\section{Available correlation structures}{ + +\describe{ + \item{cor_arma}{autoregressive-moving average (ARMA) structure, + with arbitrary orders for the autoregressive and moving + average components} + \item{cor_ar}{autoregressive (AR) structure of arbitrary order} + \item{cor_ma}{moving average (MA) structure of arbitrary order} + \item{cor_car}{Spatial conditional autoregressive (CAR) structure} + \item{cor_sar}{Spatial simultaneous autoregressive (SAR) structure} + \item{cor_fixed}{fixed user-defined covariance structure} +} +} + +\seealso{ +\code{\link{cor_arma}, \link{cor_ar}, \link{cor_ma}, + \link{cor_car}, \link{cor_sar}, \link{cor_fixed}} +} diff -Nru r-cran-brms-2.16.3/man/cor_bsts.Rd r-cran-brms-2.17.0/man/cor_bsts.Rd --- r-cran-brms-2.16.3/man/cor_bsts.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_bsts.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,23 +1,23 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_bsts} -\alias{cor_bsts} -\title{(Defunct) Basic Bayesian Structural Time Series} -\usage{ -cor_bsts(formula = ~1) -} -\arguments{ -\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, -specifying a time covariate \code{t} and, optionally, a grouping factor -\code{g}. A covariate for this correlation structure must be integer -valued. When a grouping factor is present in \code{formula}, the -correlation structure is assumed to apply only to observations within the -same grouping level; observations with different grouping levels are -assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to -using the order of the observations in the data as a covariate, and no -groups.} -} -\description{ -The BSTS correlation structure is no longer supported. -} -\keyword{internal} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_bsts} +\alias{cor_bsts} +\title{(Defunct) Basic Bayesian Structural Time Series} +\usage{ +cor_bsts(formula = ~1) +} +\arguments{ +\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, +specifying a time covariate \code{t} and, optionally, a grouping factor +\code{g}. A covariate for this correlation structure must be integer +valued. When a grouping factor is present in \code{formula}, the +correlation structure is assumed to apply only to observations within the +same grouping level; observations with different grouping levels are +assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to +using the order of the observations in the data as a covariate, and no +groups.} +} +\description{ +The BSTS correlation structure is no longer supported. +} +\keyword{internal} diff -Nru r-cran-brms-2.16.3/man/cor_car.Rd r-cran-brms-2.17.0/man/cor_car.Rd --- r-cran-brms-2.16.3/man/cor_car.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_car.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,74 +1,74 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_car} -\alias{cor_car} -\alias{cor_icar} -\title{(Deprecated) Spatial conditional autoregressive (CAR) structures} -\usage{ -cor_car(W, formula = ~1, type = "escar") - -cor_icar(W, formula = ~1) -} -\arguments{ -\item{W}{Adjacency matrix of locations. -All non-zero entries are treated as if the two locations -are adjacent. If \code{formula} contains a grouping factor, -the row names of \code{W} have to match the levels -of the grouping factor.} - -\item{formula}{An optional one-sided formula of the form -\code{~ 1 | g}, where \code{g} is a grouping factor mapping -observations to spatial locations. If not specified, -each observation is treated as a separate location. -It is recommended to always specify a grouping factor -to allow for handling of new data in post-processing methods.} - -\item{type}{Type of the CAR structure. Currently implemented -are \code{"escar"} (exact sparse CAR), \code{"esicar"} -(exact sparse intrinsic CAR), \code{"icar"} (intrinsic CAR), -and \code{"bym2"}. More information is provided in the 'Details' section.} -} -\description{ -These function are deprecated. Please see \code{\link{car}} for the new -syntax. These functions are constructors for the \code{cor_car} class -implementing spatial conditional autoregressive structures. -} -\details{ -The \code{escar} and \code{esicar} types are - implemented based on the case study of Max Joseph - (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and - \code{bym2} type is implemented based on the case study of Mitzi Morris - (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). -} -\examples{ -\dontrun{ -# generate some spatial data -east <- north <- 1:10 -Grid <- expand.grid(east, north) -K <- nrow(Grid) - -# set up distance and neighbourhood matrices -distance <- as.matrix(dist(Grid)) -W <- array(0, c(K, K)) -W[distance == 1] <- 1 - -# generate the covariates and response data -x1 <- rnorm(K) -x2 <- rnorm(K) -theta <- rnorm(K, sd = 0.05) -phi <- rmulti_normal( - 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) -) -eta <- x1 + x2 + phi -prob <- exp(eta) / (1 + exp(eta)) -size <- rep(50, K) -y <- rbinom(n = K, size = size, prob = prob) -dat <- data.frame(y, size, x1, x2) - -# fit a CAR model -fit <- brm(y | trials(size) ~ x1 + x2, data = dat, - family = binomial(), autocor = cor_car(W)) -summary(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_car} +\alias{cor_car} +\alias{cor_icar} +\title{(Deprecated) Spatial conditional autoregressive (CAR) structures} +\usage{ +cor_car(W, formula = ~1, type = "escar") + +cor_icar(W, formula = ~1) +} +\arguments{ +\item{W}{Adjacency matrix of locations. +All non-zero entries are treated as if the two locations +are adjacent. If \code{formula} contains a grouping factor, +the row names of \code{W} have to match the levels +of the grouping factor.} + +\item{formula}{An optional one-sided formula of the form +\code{~ 1 | g}, where \code{g} is a grouping factor mapping +observations to spatial locations. If not specified, +each observation is treated as a separate location. +It is recommended to always specify a grouping factor +to allow for handling of new data in post-processing methods.} + +\item{type}{Type of the CAR structure. Currently implemented +are \code{"escar"} (exact sparse CAR), \code{"esicar"} +(exact sparse intrinsic CAR), \code{"icar"} (intrinsic CAR), +and \code{"bym2"}. More information is provided in the 'Details' section.} +} +\description{ +These function are deprecated. Please see \code{\link{car}} for the new +syntax. These functions are constructors for the \code{cor_car} class +implementing spatial conditional autoregressive structures. +} +\details{ +The \code{escar} and \code{esicar} types are + implemented based on the case study of Max Joseph + (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and + \code{bym2} type is implemented based on the case study of Mitzi Morris + (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). +} +\examples{ +\dontrun{ +# generate some spatial data +east <- north <- 1:10 +Grid <- expand.grid(east, north) +K <- nrow(Grid) + +# set up distance and neighbourhood matrices +distance <- as.matrix(dist(Grid)) +W <- array(0, c(K, K)) +W[distance == 1] <- 1 + +# generate the covariates and response data +x1 <- rnorm(K) +x2 <- rnorm(K) +theta <- rnorm(K, sd = 0.05) +phi <- rmulti_normal( + 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) +) +eta <- x1 + x2 + phi +prob <- exp(eta) / (1 + exp(eta)) +size <- rep(50, K) +y <- rbinom(n = K, size = size, prob = prob) +dat <- data.frame(y, size, x1, x2) + +# fit a CAR model +fit <- brm(y | trials(size) ~ x1 + x2, data = dat, + family = binomial(), autocor = cor_car(W)) +summary(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/cor_cosy.Rd r-cran-brms-2.17.0/man/cor_cosy.Rd --- r-cran-brms-2.16.3/man/cor_cosy.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_cosy.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,33 +1,33 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_cosy} -\alias{cor_cosy} -\alias{cor_cosy-class} -\title{(Deprecated) Compound Symmetry (COSY) Correlation Structure} -\usage{ -cor_cosy(formula = ~1) -} -\arguments{ -\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, -specifying a time covariate \code{t} and, optionally, a grouping factor -\code{g}. A covariate for this correlation structure must be integer -valued. When a grouping factor is present in \code{formula}, the -correlation structure is assumed to apply only to observations within the -same grouping level; observations with different grouping levels are -assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to -using the order of the observations in the data as a covariate, and no -groups.} -} -\value{ -An object of class \code{cor_cosy}, representing a compound symmetry - correlation structure. -} -\description{ -This function is deprecated. Please see \code{\link{cosy}} for the new syntax. -This functions is a constructor for the \code{cor_cosy} class, representing -a compound symmetry structure corresponding to uniform correlation. -} -\examples{ -cor_cosy(~ visit | patient) - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_cosy} +\alias{cor_cosy} +\alias{cor_cosy-class} +\title{(Deprecated) Compound Symmetry (COSY) Correlation Structure} +\usage{ +cor_cosy(formula = ~1) +} +\arguments{ +\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, +specifying a time covariate \code{t} and, optionally, a grouping factor +\code{g}. A covariate for this correlation structure must be integer +valued. When a grouping factor is present in \code{formula}, the +correlation structure is assumed to apply only to observations within the +same grouping level; observations with different grouping levels are +assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to +using the order of the observations in the data as a covariate, and no +groups.} +} +\value{ +An object of class \code{cor_cosy}, representing a compound symmetry + correlation structure. +} +\description{ +This function is deprecated. Please see \code{\link{cosy}} for the new syntax. +This functions is a constructor for the \code{cor_cosy} class, representing +a compound symmetry structure corresponding to uniform correlation. +} +\examples{ +cor_cosy(~ visit | patient) + +} diff -Nru r-cran-brms-2.16.3/man/cor_fixed.Rd r-cran-brms-2.17.0/man/cor_fixed.Rd --- r-cran-brms-2.16.3/man/cor_fixed.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_fixed.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,30 +1,30 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_fixed} -\alias{cor_fixed} -\alias{cov_fixed} -\title{(Deprecated) Fixed user-defined covariance matrices} -\usage{ -cor_fixed(V) -} -\arguments{ -\item{V}{Known covariance matrix of the response variable. -If a vector is passed, it will be used as diagonal entries -(variances) and covariances will be set to zero.} -} -\value{ -An object of class \code{cor_fixed}. -} -\description{ -This function is deprecated. Please see \code{\link{fcor}} for the new -syntax. Define a fixed covariance matrix of the response variable for -instance to model multivariate effect sizes in meta-analysis. -} -\examples{ -\dontrun{ -dat <- data.frame(y = rnorm(3)) -V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) -fit <- brm(y~1, data = dat, autocor = cor_fixed(V)) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_fixed} +\alias{cor_fixed} +\alias{cov_fixed} +\title{(Deprecated) Fixed user-defined covariance matrices} +\usage{ +cor_fixed(V) +} +\arguments{ +\item{V}{Known covariance matrix of the response variable. +If a vector is passed, it will be used as diagonal entries +(variances) and covariances will be set to zero.} +} +\value{ +An object of class \code{cor_fixed}. +} +\description{ +This function is deprecated. Please see \code{\link{fcor}} for the new +syntax. Define a fixed covariance matrix of the response variable for +instance to model multivariate effect sizes in meta-analysis. +} +\examples{ +\dontrun{ +dat <- data.frame(y = rnorm(3)) +V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) +fit <- brm(y~1, data = dat, autocor = cor_fixed(V)) +} + +} diff -Nru r-cran-brms-2.16.3/man/cor_ma.Rd r-cran-brms-2.17.0/man/cor_ma.Rd --- r-cran-brms-2.16.3/man/cor_ma.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_ma.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,47 +1,47 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_ma} -\alias{cor_ma} -\title{(Deprecated) MA(q) correlation structure} -\usage{ -cor_ma(formula = ~1, q = 1, cov = FALSE) -} -\arguments{ -\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, -specifying a time covariate \code{t} and, optionally, a grouping factor -\code{g}. A covariate for this correlation structure must be integer -valued. When a grouping factor is present in \code{formula}, the -correlation structure is assumed to apply only to observations within the -same grouping level; observations with different grouping levels are -assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to -using the order of the observations in the data as a covariate, and no -groups.} - -\item{q}{A non-negative integer specifying the moving average (MA) -order of the ARMA structure. Default is 1.} - -\item{cov}{A flag indicating whether ARMA effects should be estimated by -means of residual covariance matrices. This is currently only possible for -stationary ARMA effects of order 1. If the model family does not have -natural residuals, latent residuals are added automatically. If -\code{FALSE} (the default) a regression formulation is used that is -considerably faster and allows for ARMA effects of order higher than 1 but -is only available for \code{gaussian} models and some of its -generalizations.} -} -\value{ -An object of class \code{cor_arma} containing solely moving -average terms. -} -\description{ -This function is deprecated. Please see \code{\link{ma}} for the new syntax. -This function is a constructor for the \code{cor_arma} class, -allowing for moving average terms only. -} -\examples{ -cor_ma(~visit|patient, q = 2) - -} -\seealso{ -\code{\link{cor_arma}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_ma} +\alias{cor_ma} +\title{(Deprecated) MA(q) correlation structure} +\usage{ +cor_ma(formula = ~1, q = 1, cov = FALSE) +} +\arguments{ +\item{formula}{A one sided formula of the form \code{~ t}, or \code{~ t | g}, +specifying a time covariate \code{t} and, optionally, a grouping factor +\code{g}. A covariate for this correlation structure must be integer +valued. When a grouping factor is present in \code{formula}, the +correlation structure is assumed to apply only to observations within the +same grouping level; observations with different grouping levels are +assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to +using the order of the observations in the data as a covariate, and no +groups.} + +\item{q}{A non-negative integer specifying the moving average (MA) +order of the ARMA structure. Default is 1.} + +\item{cov}{A flag indicating whether ARMA effects should be estimated by +means of residual covariance matrices. This is currently only possible for +stationary ARMA effects of order 1. If the model family does not have +natural residuals, latent residuals are added automatically. If +\code{FALSE} (the default) a regression formulation is used that is +considerably faster and allows for ARMA effects of order higher than 1 but +is only available for \code{gaussian} models and some of its +generalizations.} +} +\value{ +An object of class \code{cor_arma} containing solely moving +average terms. +} +\description{ +This function is deprecated. Please see \code{\link{ma}} for the new syntax. +This function is a constructor for the \code{cor_arma} class, +allowing for moving average terms only. +} +\examples{ +cor_ma(~visit|patient, q = 2) + +} +\seealso{ +\code{\link{cor_arma}} +} diff -Nru r-cran-brms-2.16.3/man/cor_sar.Rd r-cran-brms-2.17.0/man/cor_sar.Rd --- r-cran-brms-2.16.3/man/cor_sar.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cor_sar.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,60 +1,60 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{cor_sar} -\alias{cor_sar} -\alias{cor_lagsar} -\alias{cor_errorsar} -\title{(Deprecated) Spatial simultaneous autoregressive (SAR) structures} -\usage{ -cor_sar(W, type = c("lag", "error")) - -cor_lagsar(W) - -cor_errorsar(W) -} -\arguments{ -\item{W}{An object specifying the spatial weighting matrix. -Can be either the spatial weight matrix itself or an -object of class \code{listw} or \code{nb}, from which -the spatial weighting matrix can be computed.} - -\item{type}{Type of the SAR structure. Either \code{"lag"} -(for SAR of the response values) or \code{"error"} -(for SAR of the residuals).} -} -\value{ -An object of class \code{cor_sar} to be used in calls to - \code{\link{brm}}. -} -\description{ -Thse functions are deprecated. Please see \code{\link{sar}} for the new -syntax. These functions are constructors for the \code{cor_sar} class -implementing spatial simultaneous autoregressive structures. -The \code{lagsar} structure implements SAR of the response values: -\deqn{y = \rho W y + \eta + e} -The \code{errorsar} structure implements SAR of the residuals: -\deqn{y = \eta + u, u = \rho W u + e} -In the above equations, \eqn{\eta} is the predictor term and -\eqn{e} are independent normally or t-distributed residuals. -} -\details{ -Currently, only families \code{gaussian} and \code{student} - support SAR structures. -} -\examples{ -\dontrun{ -data(oldcol, package = "spdep") -fit1 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, - autocor = cor_lagsar(COL.nb), - chains = 2, cores = 2) -summary(fit1) -plot(fit1) - -fit2 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, - autocor = cor_errorsar(COL.nb), - chains = 2, cores = 2) -summary(fit2) -plot(fit2) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{cor_sar} +\alias{cor_sar} +\alias{cor_lagsar} +\alias{cor_errorsar} +\title{(Deprecated) Spatial simultaneous autoregressive (SAR) structures} +\usage{ +cor_sar(W, type = c("lag", "error")) + +cor_lagsar(W) + +cor_errorsar(W) +} +\arguments{ +\item{W}{An object specifying the spatial weighting matrix. +Can be either the spatial weight matrix itself or an +object of class \code{listw} or \code{nb}, from which +the spatial weighting matrix can be computed.} + +\item{type}{Type of the SAR structure. Either \code{"lag"} +(for SAR of the response values) or \code{"error"} +(for SAR of the residuals).} +} +\value{ +An object of class \code{cor_sar} to be used in calls to + \code{\link{brm}}. +} +\description{ +Thse functions are deprecated. Please see \code{\link{sar}} for the new +syntax. These functions are constructors for the \code{cor_sar} class +implementing spatial simultaneous autoregressive structures. +The \code{lagsar} structure implements SAR of the response values: +\deqn{y = \rho W y + \eta + e} +The \code{errorsar} structure implements SAR of the residuals: +\deqn{y = \eta + u, u = \rho W u + e} +In the above equations, \eqn{\eta} is the predictor term and +\eqn{e} are independent normally or t-distributed residuals. +} +\details{ +Currently, only families \code{gaussian} and \code{student} + support SAR structures. +} +\examples{ +\dontrun{ +data(oldcol, package = "spdep") +fit1 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, + autocor = cor_lagsar(COL.nb), + chains = 2, cores = 2) +summary(fit1) +plot(fit1) + +fit2 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, + autocor = cor_errorsar(COL.nb), + chains = 2, cores = 2) +summary(fit2) +plot(fit2) +} + +} diff -Nru r-cran-brms-2.16.3/man/cosy.Rd r-cran-brms-2.17.0/man/cosy.Rd --- r-cran-brms-2.16.3/man/cosy.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cosy.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,39 +1,39 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ac.R -\name{cosy} -\alias{cosy} -\title{Set up COSY correlation structures} -\usage{ -cosy(time = NA, gr = NA) -} -\arguments{ -\item{time}{An optional time variable specifying the time ordering -of the observations. By default, the existing order of the observations -in the data is used.} - -\item{gr}{An optional grouping variable. If specified, the correlation -structure is assumed to apply only to observations within the same grouping -level.} -} -\value{ -An object of class \code{'cosy_term'}, which is a list - of arguments to be interpreted by the formula - parsing functions of \pkg{brms}. -} -\description{ -Set up a compounds symmetry (COSY) term in \pkg{brms}. The function does -not evaluate its arguments -- it exists purely to help set up a model with -COSY terms. -} -\examples{ -\dontrun{ -data("lh") -lh <- as.data.frame(lh) -fit <- brm(x ~ cosy(), data = lh) -summary(fit) -} - -} -\seealso{ -\code{\link{autocor-terms}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ac.R +\name{cosy} +\alias{cosy} +\title{Set up COSY correlation structures} +\usage{ +cosy(time = NA, gr = NA) +} +\arguments{ +\item{time}{An optional time variable specifying the time ordering +of the observations. By default, the existing order of the observations +in the data is used.} + +\item{gr}{An optional grouping variable. If specified, the correlation +structure is assumed to apply only to observations within the same grouping +level.} +} +\value{ +An object of class \code{'cosy_term'}, which is a list + of arguments to be interpreted by the formula + parsing functions of \pkg{brms}. +} +\description{ +Set up a compounds symmetry (COSY) term in \pkg{brms}. The function does +not evaluate its arguments -- it exists purely to help set up a model with +COSY terms. +} +\examples{ +\dontrun{ +data("lh") +lh <- as.data.frame(lh) +fit <- brm(x ~ cosy(), data = lh) +summary(fit) +} + +} +\seealso{ +\code{\link{autocor-terms}} +} diff -Nru r-cran-brms-2.16.3/man/cs.Rd r-cran-brms-2.17.0/man/cs.Rd --- r-cran-brms-2.16.3/man/cs.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/cs.Rd 2022-04-08 11:57:41.000000000 +0000 @@ -1,38 +1,37 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-cs.R -\name{cs} -\alias{cs} -\alias{cse} -\title{Category Specific Predictors in \pkg{brms} Models} -\usage{ -cs(expr) -} -\arguments{ -\item{expr}{Expression containing predictors, -for which category specific effects should be estimated. -For evaluation, \R formula syntax is applied.} -} -\description{ -Category Specific Predictors in \pkg{brms} Models -} -\details{ -For detailed documentation see \code{help(brmsformula)} - as well as \code{vignette("brms_overview")}. - -This function is almost solely useful when -called in formulas passed to the \pkg{brms} package. -} -\examples{ - -\dontrun{ -fit <- brm(rating ~ period + carry + cs(treat), - data = inhaler, family = sratio("cloglog"), - prior = set_prior("normal(0,5)"), chains = 2) -summary(fit) -plot(fit, ask = FALSE) -} - -} -\seealso{ -\code{\link{brmsformula}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-cs.R +\name{cs} +\alias{cs} +\alias{cse} +\title{Category Specific Predictors in \pkg{brms} Models} +\usage{ +cs(expr) +} +\arguments{ +\item{expr}{Expression containing predictors, +for which category specific effects should be estimated. +For evaluation, \R formula syntax is applied.} +} +\description{ +Category Specific Predictors in \pkg{brms} Models +} +\details{ +For detailed documentation see \code{help(brmsformula)} + as well as \code{vignette("brms_overview")}. + +This function is almost solely useful when +called in formulas passed to the \pkg{brms} package. +} +\examples{ +\dontrun{ +fit <- brm(rating ~ period + carry + cs(treat), + data = inhaler, family = sratio("cloglog"), + prior = set_prior("normal(0,5)"), chains = 2) +summary(fit) +plot(fit, ask = FALSE) +} + +} +\seealso{ +\code{\link{brmsformula}} +} diff -Nru r-cran-brms-2.16.3/man/custom_family.Rd r-cran-brms-2.17.0/man/custom_family.Rd --- r-cran-brms-2.16.3/man/custom_family.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/custom_family.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,182 +1,182 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/families.R -\name{custom_family} -\alias{custom_family} -\alias{customfamily} -\title{Custom Families in \pkg{brms} Models} -\usage{ -custom_family( - name, - dpars = "mu", - links = "identity", - type = c("real", "int"), - lb = NA, - ub = NA, - vars = NULL, - loop = TRUE, - specials = NULL, - threshold = "flexible", - log_lik = NULL, - posterior_predict = NULL, - posterior_epred = NULL, - predict = NULL, - fitted = NULL, - env = parent.frame() -) -} -\arguments{ -\item{name}{Name of the custom family.} - -\item{dpars}{Names of the distributional parameters of -the family. One parameter must be named \code{"mu"} and -the main formula of the model will correspond to that -parameter.} - -\item{links}{Names of the link functions of the -distributional parameters.} - -\item{type}{Indicates if the response distribution is -continuous (\code{"real"}) or discrete (\code{"int"}). This controls -if the corresponding density function will be named with -\code{_lpdf} or \code{_lpmf}.} - -\item{lb}{Vector of lower bounds of the distributional -parameters. Defaults to \code{NA} that is no lower bound.} - -\item{ub}{Vector of upper bounds of the distributional -parameters. Defaults to \code{NA} that is no upper bound.} - -\item{vars}{Names of variables that are part of the likelihood function -without being distributional parameters. That is, \code{vars} can be used -to pass data to the likelihood. Such arguments will be added to the list of -function arguments at the end, after the distributional parameters. See -\code{\link{stanvar}} for details about adding self-defined data to the -generated \pkg{Stan} model. Addition arguments \code{vreal} and \code{vint} -may be used for this purpose as well (see Examples below). See also -\code{\link{brmsformula}} and \code{\link{addition-terms}} for more -details.} - -\item{loop}{Logical; Should the likelihood be evaluated via a loop -(\code{TRUE}; the default) over observations in Stan? -If \code{FALSE}, the Stan code will be written in a vectorized -manner over observations if possible.} - -\item{specials}{A character vector of special options to enable -for this custom family. Currently for internal use only.} - -\item{threshold}{Optional threshold type for custom ordinal families. -Ignored for non-ordinal families.} - -\item{log_lik}{Optional function to compute log-likelihood values of -the model in \R. This is only relevant if one wants to ensure -compatibility with method \code{\link[brms:log_lik.brmsfit]{log_lik}}.} - -\item{posterior_predict}{Optional function to compute posterior prediction of -the model in \R. This is only relevant if one wants to ensure compatibility -with method \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}.} - -\item{posterior_epred}{Optional function to compute expected values of the -posterior predictive distribution of the model in \R. This is only relevant -if one wants to ensure compatibility with method -\code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}.} - -\item{predict}{Deprecated alias of `posterior_predict`.} - -\item{fitted}{Deprecated alias of `posterior_epred`.} - -\item{env}{An \code{\link{environment}} in which certain post-processing -functions related to the custom family can be found, if there were not -directly passed to \code{custom_family}. This is only -relevant if one wants to ensure compatibility with the methods -\code{\link[brms:log_lik.brmsfit]{log_lik}}, -\code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}, or -\code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. -By default, \code{env} is the environment from which -\code{custom_family} is called.} -} -\value{ -An object of class \code{customfamily} inheriting - from class \code{\link{brmsfamily}}. -} -\description{ -Define custom families (i.e. response distribution) for use in -\pkg{brms} models. It allows users to benefit from the modeling -flexibility of \pkg{brms}, while applying their self-defined likelihood -functions. All of the post-processing methods for \code{brmsfit} -objects can be made compatible with custom families. -See \code{vignette("brms_customfamilies")} for more details. -For a list of built-in families see \code{\link{brmsfamily}}. -} -\details{ -The corresponding probability density or mass \code{Stan} - functions need to have the same name as the custom family. - That is if a family is called \code{myfamily}, then the - \pkg{Stan} functions should be called \code{myfamily_lpdf} or - \code{myfamily_lpmf} depending on whether it defines a - continuous or discrete distribution. -} -\examples{ -\dontrun{ -## demonstrate how to fit a beta-binomial model -## generate some fake data -phi <- 0.7 -n <- 300 -z <- rnorm(n, sd = 0.2) -ntrials <- sample(1:10, n, replace = TRUE) -eta <- 1 + z -mu <- exp(eta) / (1 + exp(eta)) -a <- mu * phi -b <- (1 - mu) * phi -p <- rbeta(n, a, b) -y <- rbinom(n, ntrials, p) -dat <- data.frame(y, z, ntrials) - -# define a custom family -beta_binomial2 <- custom_family( - "beta_binomial2", dpars = c("mu", "phi"), - links = c("logit", "log"), lb = c(NA, 0), - type = "int", vars = "vint1[n]" -) - -# define the corresponding Stan density function -stan_density <- " - real beta_binomial2_lpmf(int y, real mu, real phi, int N) { - return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); - } -" -stanvars <- stanvar(scode = stan_density, block = "functions") - -# fit the model -fit <- brm(y | vint(ntrials) ~ z, data = dat, - family = beta_binomial2, stanvars = stanvars) -summary(fit) - - -# define a *vectorized* custom family (no loop over observations) -# notice also that 'vint' no longer has an observation index -beta_binomial2_vec <- custom_family( - "beta_binomial2", dpars = c("mu", "phi"), - links = c("logit", "log"), lb = c(NA, 0), - type = "int", vars = "vint1", loop = FALSE -) - -# define the corresponding Stan density function -stan_density_vec <- " - real beta_binomial2_lpmf(int[] y, vector mu, real phi, int[] N) { - return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); - } -" -stanvars_vec <- stanvar(scode = stan_density_vec, block = "functions") - -# fit the model -fit_vec <- brm(y | vint(ntrials) ~ z, data = dat, - family = beta_binomial2_vec, - stanvars = stanvars_vec) -summary(fit_vec) -} - -} -\seealso{ -\code{\link{brmsfamily}}, \code{\link{brmsformula}}, - \code{\link{stanvar}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/families.R +\name{custom_family} +\alias{custom_family} +\alias{customfamily} +\title{Custom Families in \pkg{brms} Models} +\usage{ +custom_family( + name, + dpars = "mu", + links = "identity", + type = c("real", "int"), + lb = NA, + ub = NA, + vars = NULL, + loop = TRUE, + specials = NULL, + threshold = "flexible", + log_lik = NULL, + posterior_predict = NULL, + posterior_epred = NULL, + predict = NULL, + fitted = NULL, + env = parent.frame() +) +} +\arguments{ +\item{name}{Name of the custom family.} + +\item{dpars}{Names of the distributional parameters of +the family. One parameter must be named \code{"mu"} and +the main formula of the model will correspond to that +parameter.} + +\item{links}{Names of the link functions of the +distributional parameters.} + +\item{type}{Indicates if the response distribution is +continuous (\code{"real"}) or discrete (\code{"int"}). This controls +if the corresponding density function will be named with +\code{_lpdf} or \code{_lpmf}.} + +\item{lb}{Vector of lower bounds of the distributional +parameters. Defaults to \code{NA} that is no lower bound.} + +\item{ub}{Vector of upper bounds of the distributional +parameters. Defaults to \code{NA} that is no upper bound.} + +\item{vars}{Names of variables that are part of the likelihood function +without being distributional parameters. That is, \code{vars} can be used +to pass data to the likelihood. Such arguments will be added to the list of +function arguments at the end, after the distributional parameters. See +\code{\link{stanvar}} for details about adding self-defined data to the +generated \pkg{Stan} model. Addition arguments \code{vreal} and \code{vint} +may be used for this purpose as well (see Examples below). See also +\code{\link{brmsformula}} and \code{\link{addition-terms}} for more +details.} + +\item{loop}{Logical; Should the likelihood be evaluated via a loop +(\code{TRUE}; the default) over observations in Stan? +If \code{FALSE}, the Stan code will be written in a vectorized +manner over observations if possible.} + +\item{specials}{A character vector of special options to enable +for this custom family. Currently for internal use only.} + +\item{threshold}{Optional threshold type for custom ordinal families. +Ignored for non-ordinal families.} + +\item{log_lik}{Optional function to compute log-likelihood values of +the model in \R. This is only relevant if one wants to ensure +compatibility with method \code{\link[brms:log_lik.brmsfit]{log_lik}}.} + +\item{posterior_predict}{Optional function to compute posterior prediction of +the model in \R. This is only relevant if one wants to ensure compatibility +with method \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}.} + +\item{posterior_epred}{Optional function to compute expected values of the +posterior predictive distribution of the model in \R. This is only relevant +if one wants to ensure compatibility with method +\code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}.} + +\item{predict}{Deprecated alias of `posterior_predict`.} + +\item{fitted}{Deprecated alias of `posterior_epred`.} + +\item{env}{An \code{\link{environment}} in which certain post-processing +functions related to the custom family can be found, if there were not +directly passed to \code{custom_family}. This is only +relevant if one wants to ensure compatibility with the methods +\code{\link[brms:log_lik.brmsfit]{log_lik}}, +\code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}, or +\code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. +By default, \code{env} is the environment from which +\code{custom_family} is called.} +} +\value{ +An object of class \code{customfamily} inheriting + from class \code{\link{brmsfamily}}. +} +\description{ +Define custom families (i.e. response distribution) for use in +\pkg{brms} models. It allows users to benefit from the modeling +flexibility of \pkg{brms}, while applying their self-defined likelihood +functions. All of the post-processing methods for \code{brmsfit} +objects can be made compatible with custom families. +See \code{vignette("brms_customfamilies")} for more details. +For a list of built-in families see \code{\link{brmsfamily}}. +} +\details{ +The corresponding probability density or mass \code{Stan} + functions need to have the same name as the custom family. + That is if a family is called \code{myfamily}, then the + \pkg{Stan} functions should be called \code{myfamily_lpdf} or + \code{myfamily_lpmf} depending on whether it defines a + continuous or discrete distribution. +} +\examples{ +\dontrun{ +## demonstrate how to fit a beta-binomial model +## generate some fake data +phi <- 0.7 +n <- 300 +z <- rnorm(n, sd = 0.2) +ntrials <- sample(1:10, n, replace = TRUE) +eta <- 1 + z +mu <- exp(eta) / (1 + exp(eta)) +a <- mu * phi +b <- (1 - mu) * phi +p <- rbeta(n, a, b) +y <- rbinom(n, ntrials, p) +dat <- data.frame(y, z, ntrials) + +# define a custom family +beta_binomial2 <- custom_family( + "beta_binomial2", dpars = c("mu", "phi"), + links = c("logit", "log"), lb = c(NA, 0), + type = "int", vars = "vint1[n]" +) + +# define the corresponding Stan density function +stan_density <- " + real beta_binomial2_lpmf(int y, real mu, real phi, int N) { + return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); + } +" +stanvars <- stanvar(scode = stan_density, block = "functions") + +# fit the model +fit <- brm(y | vint(ntrials) ~ z, data = dat, + family = beta_binomial2, stanvars = stanvars) +summary(fit) + + +# define a *vectorized* custom family (no loop over observations) +# notice also that 'vint' no longer has an observation index +beta_binomial2_vec <- custom_family( + "beta_binomial2", dpars = c("mu", "phi"), + links = c("logit", "log"), lb = c(NA, 0), + type = "int", vars = "vint1", loop = FALSE +) + +# define the corresponding Stan density function +stan_density_vec <- " + real beta_binomial2_lpmf(int[] y, vector mu, real phi, int[] N) { + return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); + } +" +stanvars_vec <- stanvar(scode = stan_density_vec, block = "functions") + +# fit the model +fit_vec <- brm(y | vint(ntrials) ~ z, data = dat, + family = beta_binomial2_vec, + stanvars = stanvars_vec) +summary(fit_vec) +} + +} +\seealso{ +\code{\link{brmsfamily}}, \code{\link{brmsformula}}, + \code{\link{stanvar}} +} diff -Nru r-cran-brms-2.16.3/man/data_predictor.Rd r-cran-brms-2.17.0/man/data_predictor.Rd --- r-cran-brms-2.16.3/man/data_predictor.Rd 2020-02-27 16:28:56.000000000 +0000 +++ r-cran-brms-2.17.0/man/data_predictor.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -15,7 +15,7 @@ A named list of data related to predictor variables. } \description{ -Prepare data related to predictor variables in \pkg{brms}. +Prepare data related to predictor variables in \pkg{brms}. Only exported for use in package development. } \keyword{internal} diff -Nru r-cran-brms-2.16.3/man/data_response.Rd r-cran-brms-2.17.0/man/data_response.Rd --- r-cran-brms-2.16.3/man/data_response.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/data_response.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,21 +1,21 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data-response.R -\name{data_response} -\alias{data_response} -\title{Prepare Response Data} -\usage{ -data_response(x, ...) -} -\arguments{ -\item{x}{An \R object.} - -\item{...}{Further arguments passed to or from other methods.} -} -\value{ -A named list of data related to response variables. -} -\description{ -Prepare data related to response variables in \pkg{brms}. -Only exported for use in package development. -} -\keyword{internal} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data-response.R +\name{data_response} +\alias{data_response} +\title{Prepare Response Data} +\usage{ +data_response(x, ...) +} +\arguments{ +\item{x}{An \R object.} + +\item{...}{Further arguments passed to or from other methods.} +} +\value{ +A named list of data related to response variables. +} +\description{ +Prepare data related to response variables in \pkg{brms}. +Only exported for use in package development. +} +\keyword{internal} diff -Nru r-cran-brms-2.16.3/man/density_ratio.Rd r-cran-brms-2.17.0/man/density_ratio.Rd --- r-cran-brms-2.16.3/man/density_ratio.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/density_ratio.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,44 +1,44 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hypothesis.R -\name{density_ratio} -\alias{density_ratio} -\title{Compute Density Ratios} -\usage{ -density_ratio(x, y = NULL, point = 0, n = 4096, ...) -} -\arguments{ -\item{x}{Vector of draws from the first distribution, usually the posterior -distribution of the quantity of interest.} - -\item{y}{Optional vector of draws from the second distribution, usually the -prior distribution of the quantity of interest. If \code{NULL} (the -default), only the density of \code{x} will be evaluated.} - -\item{point}{Numeric values at which to evaluate and compare the densities. -Defaults to \code{0}.} - -\item{n}{Single numeric value. Influences the accuracy of the density -estimation. See \code{\link[stats:density]{density}} for details.} - -\item{...}{Further arguments passed to \code{\link[stats:density]{density}}.} -} -\value{ -A vector of length equal to \code{length(point)}. If \code{y} is - provided, the density ratio of \code{x} against \code{y} is returned. Else, - only the density of \code{x} is returned. -} -\description{ -Compute the ratio of two densities at given points based on draws of the -corresponding distributions. -} -\details{ -In order to achieve sufficient accuracy in the density estimation, - more draws than usual are required. That is you may need an effective - sample size of 10,000 or more to reliably estimate the densities. -} -\examples{ -x <- rnorm(10000) -y <- rnorm(10000, mean = 1) -density_ratio(x, y, point = c(0, 1)) - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hypothesis.R +\name{density_ratio} +\alias{density_ratio} +\title{Compute Density Ratios} +\usage{ +density_ratio(x, y = NULL, point = 0, n = 4096, ...) +} +\arguments{ +\item{x}{Vector of draws from the first distribution, usually the posterior +distribution of the quantity of interest.} + +\item{y}{Optional vector of draws from the second distribution, usually the +prior distribution of the quantity of interest. If \code{NULL} (the +default), only the density of \code{x} will be evaluated.} + +\item{point}{Numeric values at which to evaluate and compare the densities. +Defaults to \code{0}.} + +\item{n}{Single numeric value. Influences the accuracy of the density +estimation. See \code{\link[stats:density]{density}} for details.} + +\item{...}{Further arguments passed to \code{\link[stats:density]{density}}.} +} +\value{ +A vector of length equal to \code{length(point)}. If \code{y} is + provided, the density ratio of \code{x} against \code{y} is returned. Else, + only the density of \code{x} is returned. +} +\description{ +Compute the ratio of two densities at given points based on draws of the +corresponding distributions. +} +\details{ +In order to achieve sufficient accuracy in the density estimation, + more draws than usual are required. That is you may need an effective + sample size of 10,000 or more to reliably estimate the densities. +} +\examples{ +x <- rnorm(10000) +y <- rnorm(10000, mean = 1) +density_ratio(x, y, point = c(0, 1)) + +} diff -Nru r-cran-brms-2.16.3/man/diagnostic-quantities.Rd r-cran-brms-2.17.0/man/diagnostic-quantities.Rd --- r-cran-brms-2.16.3/man/diagnostic-quantities.Rd 2021-05-16 19:09:11.000000000 +0000 +++ r-cran-brms-2.17.0/man/diagnostic-quantities.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,59 +1,59 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/diagnostics.R -\name{diagnostic-quantities} -\alias{diagnostic-quantities} -\alias{log_posterior} -\alias{nuts_params} -\alias{rhat} -\alias{neff_ratio} -\alias{log_posterior.brmsfit} -\alias{nuts_params.brmsfit} -\alias{rhat.brmsfit} -\alias{neff_ratio.brmsfit} -\title{Extract Diagnostic Quantities of \pkg{brms} Models} -\usage{ -\method{log_posterior}{brmsfit}(object, ...) - -\method{nuts_params}{brmsfit}(object, pars = NULL, ...) - -\method{rhat}{brmsfit}(object, pars = NULL, ...) - -\method{neff_ratio}{brmsfit}(object, pars = NULL, ...) -} -\arguments{ -\item{object}{A \code{brmsfit} object.} - -\item{...}{Arguments passed to individual methods.} - -\item{pars}{An optional character vector of parameter names. -For \code{nuts_params} these will be NUTS sampler parameter -names rather than model parameters. If pars is omitted -all parameters are included.} -} -\value{ -The exact form of the output depends on the method. -} -\description{ -Extract quantities that can be used to diagnose sampling behavior -of the algorithms applied by \pkg{Stan} at the back-end of \pkg{brms}. -} -\details{ -For more details see - \code{\link[bayesplot:bayesplot-extractors]{bayesplot-extractors}}. -} -\examples{ -\dontrun{ -fit <- brm(time ~ age * sex, data = kidney) - -lp <- log_posterior(fit) -head(lp) - -np <- nuts_params(fit) -str(np) -# extract the number of divergence transitions -sum(subset(np, Parameter == "divergent__")$Value) - -head(rhat(fit)) -head(neff_ratio(fit)) -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/diagnostics.R +\name{diagnostic-quantities} +\alias{diagnostic-quantities} +\alias{log_posterior} +\alias{nuts_params} +\alias{rhat} +\alias{neff_ratio} +\alias{log_posterior.brmsfit} +\alias{nuts_params.brmsfit} +\alias{rhat.brmsfit} +\alias{neff_ratio.brmsfit} +\title{Extract Diagnostic Quantities of \pkg{brms} Models} +\usage{ +\method{log_posterior}{brmsfit}(object, ...) + +\method{nuts_params}{brmsfit}(object, pars = NULL, ...) + +\method{rhat}{brmsfit}(object, pars = NULL, ...) + +\method{neff_ratio}{brmsfit}(object, pars = NULL, ...) +} +\arguments{ +\item{object}{A \code{brmsfit} object.} + +\item{...}{Arguments passed to individual methods.} + +\item{pars}{An optional character vector of parameter names. +For \code{nuts_params} these will be NUTS sampler parameter +names rather than model parameters. If pars is omitted +all parameters are included.} +} +\value{ +The exact form of the output depends on the method. +} +\description{ +Extract quantities that can be used to diagnose sampling behavior +of the algorithms applied by \pkg{Stan} at the back-end of \pkg{brms}. +} +\details{ +For more details see + \code{\link[bayesplot:bayesplot-extractors]{bayesplot-extractors}}. +} +\examples{ +\dontrun{ +fit <- brm(time ~ age * sex, data = kidney) + +lp <- log_posterior(fit) +head(lp) + +np <- nuts_params(fit) +str(np) +# extract the number of divergence transitions +sum(subset(np, Parameter == "divergent__")$Value) + +head(rhat(fit)) +head(neff_ratio(fit)) +} +} diff -Nru r-cran-brms-2.16.3/man/Dirichlet.Rd r-cran-brms-2.17.0/man/Dirichlet.Rd --- r-cran-brms-2.16.3/man/Dirichlet.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/Dirichlet.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,30 +1,30 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{Dirichlet} -\alias{Dirichlet} -\alias{ddirichlet} -\alias{rdirichlet} -\title{The Dirichlet Distribution} -\usage{ -ddirichlet(x, alpha, log = FALSE) - -rdirichlet(n, alpha) -} -\arguments{ -\item{x}{Matrix of quantiles. Each row corresponds to one probability vector.} - -\item{alpha}{Matrix of positive shape parameters. Each row corresponds to one -probability vector.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density function and random number generation for the dirichlet -distribution with shape parameter vector \code{alpha}. -} -\details{ -See \code{vignette("brms_families")} for details on the -parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{Dirichlet} +\alias{Dirichlet} +\alias{ddirichlet} +\alias{rdirichlet} +\title{The Dirichlet Distribution} +\usage{ +ddirichlet(x, alpha, log = FALSE) + +rdirichlet(n, alpha) +} +\arguments{ +\item{x}{Matrix of quantiles. Each row corresponds to one probability vector.} + +\item{alpha}{Matrix of positive shape parameters. Each row corresponds to one +probability vector.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density function and random number generation for the dirichlet +distribution with shape parameter vector \code{alpha}. +} +\details{ +See \code{vignette("brms_families")} for details on the +parameterization. +} diff -Nru r-cran-brms-2.16.3/man/do_call.Rd r-cran-brms-2.17.0/man/do_call.Rd --- r-cran-brms-2.16.3/man/do_call.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/do_call.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,30 +1,30 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/misc.R -\name{do_call} -\alias{do_call} -\title{Execute a Function Call} -\usage{ -do_call(what, args, pkg = NULL, envir = parent.frame()) -} -\arguments{ -\item{what}{Either a function or a non-empty character string naming the -function to be called.} - -\item{args}{A list of arguments to the function call. The names attribute of -\code{args} gives the argument names.} - -\item{pkg}{Optional name of the package in which to search for the -function if \code{what} is a character string.} - -\item{envir}{An environment within which to evaluate the call.} -} -\value{ -The result of the (evaluated) function call. -} -\description{ -Execute a function call similar to \code{\link{do.call}}, but without -deparsing function arguments. For large number of arguments (i.e., more -than a few thousand) this function currently is somewhat inefficient -and should be used with care in this case. -} -\keyword{internal} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/misc.R +\name{do_call} +\alias{do_call} +\title{Execute a Function Call} +\usage{ +do_call(what, args, pkg = NULL, envir = parent.frame()) +} +\arguments{ +\item{what}{Either a function or a non-empty character string naming the +function to be called.} + +\item{args}{A list of arguments to the function call. The names attribute of +\code{args} gives the argument names.} + +\item{pkg}{Optional name of the package in which to search for the +function if \code{what} is a character string.} + +\item{envir}{An environment within which to evaluate the call.} +} +\value{ +The result of the (evaluated) function call. +} +\description{ +Execute a function call similar to \code{\link{do.call}}, but without +deparsing function arguments. For large number of arguments (i.e., more +than a few thousand) this function currently is somewhat inefficient +and should be used with care in this case. +} +\keyword{internal} diff -Nru r-cran-brms-2.16.3/man/draws-brms.Rd r-cran-brms-2.17.0/man/draws-brms.Rd --- r-cran-brms-2.16.3/man/draws-brms.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/draws-brms.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,76 +1,76 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior.R -\name{draws-brms} -\alias{draws-brms} -\alias{as_draws} -\alias{as_draws_matrix} -\alias{as_draws_array} -\alias{as_draws_df} -\alias{as_draws_rvars} -\alias{as_draws_list} -\alias{as_draws.brmsfit} -\alias{as_draws_matrix.brmsfit} -\alias{as_draws_array.brmsfit} -\alias{as_draws_df.brmsfit} -\alias{as_draws_list.brmsfit} -\alias{as_draws_rvars.brmsfit} -\title{Transform \code{brmsfit} to \code{draws} objects} -\usage{ -\method{as_draws}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) - -\method{as_draws_matrix}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) - -\method{as_draws_array}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) - -\method{as_draws_df}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) - -\method{as_draws_list}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) - -\method{as_draws_rvars}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) -} -\arguments{ -\item{x}{A \code{brmsfit} object or another \R object for which -the methods are defined.} - -\item{variable}{A character vector providing the variables to extract. -By default, all variables are extracted.} - -\item{regex}{Logical; Should variable should be treated as a (vector of) -regular expressions? Any variable in \code{x} matching at least one of the -regular expressions will be selected. Defaults to \code{FALSE}.} - -\item{inc_warmup}{Should warmup draws be included? Defaults to \code{FALSE}.} - -\item{...}{Arguments passed to individual methods (if applicable).} -} -\description{ -Transform a \code{brmsfit} object to a format supported by the -\pkg{posterior} package. -} -\details{ -To subset iterations, chains, or draws, use the - \code{\link[posterior:subset_draws]{subset_draws}} method after - transforming the \code{brmsfit} to a \code{draws} object. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson()) - -# extract posterior draws in an array format -(draws_fit <- as_draws_array(fit)) -posterior::summarize_draws(draws_fit) - -# extract only certain variables -as_draws_array(fit, variable = "r_patient") -as_draws_array(fit, variable = "^b_", regex = TRUE) - -# extract posterior draws in a random variables format -as_draws_rvars(fit) -} - -} -\seealso{ -\code{\link[posterior:draws]{draws}} - \code{\link[posterior:subset_draws]{subset_draws}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior.R +\name{draws-brms} +\alias{draws-brms} +\alias{as_draws} +\alias{as_draws_matrix} +\alias{as_draws_array} +\alias{as_draws_df} +\alias{as_draws_rvars} +\alias{as_draws_list} +\alias{as_draws.brmsfit} +\alias{as_draws_matrix.brmsfit} +\alias{as_draws_array.brmsfit} +\alias{as_draws_df.brmsfit} +\alias{as_draws_list.brmsfit} +\alias{as_draws_rvars.brmsfit} +\title{Transform \code{brmsfit} to \code{draws} objects} +\usage{ +\method{as_draws}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) + +\method{as_draws_matrix}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) + +\method{as_draws_array}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) + +\method{as_draws_df}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) + +\method{as_draws_list}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) + +\method{as_draws_rvars}{brmsfit}(x, variable = NULL, regex = FALSE, inc_warmup = FALSE, ...) +} +\arguments{ +\item{x}{A \code{brmsfit} object or another \R object for which +the methods are defined.} + +\item{variable}{A character vector providing the variables to extract. +By default, all variables are extracted.} + +\item{regex}{Logical; Should variable should be treated as a (vector of) +regular expressions? Any variable in \code{x} matching at least one of the +regular expressions will be selected. Defaults to \code{FALSE}.} + +\item{inc_warmup}{Should warmup draws be included? Defaults to \code{FALSE}.} + +\item{...}{Arguments passed to individual methods (if applicable).} +} +\description{ +Transform a \code{brmsfit} object to a format supported by the +\pkg{posterior} package. +} +\details{ +To subset iterations, chains, or draws, use the + \code{\link[posterior:subset_draws]{subset_draws}} method after + transforming the \code{brmsfit} to a \code{draws} object. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson()) + +# extract posterior draws in an array format +(draws_fit <- as_draws_array(fit)) +posterior::summarize_draws(draws_fit) + +# extract only certain variables +as_draws_array(fit, variable = "r_patient") +as_draws_array(fit, variable = "^b_", regex = TRUE) + +# extract posterior draws in a random variables format +as_draws_rvars(fit) +} + +} +\seealso{ +\code{\link[posterior:draws]{draws}} + \code{\link[posterior:subset_draws]{subset_draws}} +} diff -Nru r-cran-brms-2.16.3/man/draws-index-brms.Rd r-cran-brms-2.17.0/man/draws-index-brms.Rd --- r-cran-brms-2.16.3/man/draws-index-brms.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/draws-index-brms.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,41 +1,41 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior.R -\name{draws-index-brms} -\alias{draws-index-brms} -\alias{variables} -\alias{nvariables} -\alias{niterations} -\alias{nchains} -\alias{ndraws} -\alias{Index} -\alias{variables,} -\alias{iterations,} -\alias{chains,} -\alias{and} -\alias{draws.} -\alias{variables.brmsfit} -\alias{nvariables.brmsfit} -\alias{niterations.brmsfit} -\alias{nchains.brmsfit} -\alias{ndraws.brmsfit} -\title{Index \code{brmsfit} objects} -\usage{ -\method{variables}{brmsfit}(x, ...) - -\method{nvariables}{brmsfit}(x, ...) - -\method{niterations}{brmsfit}(x) - -\method{nchains}{brmsfit}(x) - -\method{ndraws}{brmsfit}(x) -} -\arguments{ -\item{x}{A \code{brmsfit} object or another \R object for which -the methods are defined.} - -\item{...}{Arguments passed to individual methods (if applicable).} -} -\description{ -Index \code{brmsfit} objects -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior.R +\name{draws-index-brms} +\alias{draws-index-brms} +\alias{variables} +\alias{nvariables} +\alias{niterations} +\alias{nchains} +\alias{ndraws} +\alias{Index} +\alias{variables,} +\alias{iterations,} +\alias{chains,} +\alias{and} +\alias{draws.} +\alias{variables.brmsfit} +\alias{nvariables.brmsfit} +\alias{niterations.brmsfit} +\alias{nchains.brmsfit} +\alias{ndraws.brmsfit} +\title{Index \code{brmsfit} objects} +\usage{ +\method{variables}{brmsfit}(x, ...) + +\method{nvariables}{brmsfit}(x, ...) + +\method{niterations}{brmsfit}(x) + +\method{nchains}{brmsfit}(x) + +\method{ndraws}{brmsfit}(x) +} +\arguments{ +\item{x}{A \code{brmsfit} object or another \R object for which +the methods are defined.} + +\item{...}{Arguments passed to individual methods (if applicable).} +} +\description{ +Index \code{brmsfit} objects +} diff -Nru r-cran-brms-2.16.3/man/emmeans-brms-helpers.Rd r-cran-brms-2.17.0/man/emmeans-brms-helpers.Rd --- r-cran-brms-2.16.3/man/emmeans-brms-helpers.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/emmeans-brms-helpers.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,89 +1,89 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/emmeans.R -\name{emmeans-brms-helpers} -\alias{emmeans-brms-helpers} -\alias{recover_data.brmsfit} -\alias{emm_basis.brmsfit} -\title{Support Functions for \pkg{emmeans}} -\usage{ -recover_data.brmsfit( - object, - data, - resp = NULL, - dpar = NULL, - nlpar = NULL, - re_formula = NA, - epred = FALSE, - ... -) - -emm_basis.brmsfit( - object, - trms, - xlev, - grid, - vcov., - resp = NULL, - dpar = NULL, - nlpar = NULL, - re_formula = NA, - epred = FALSE, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{data, trms, xlev, grid, vcov.}{Arguments required by \pkg{emmeans}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{dpar}{Optional name of a predicted distributional parameter. -If specified, expected predictions of this parameters are returned.} - -\item{nlpar}{Optional name of a predicted non-linear parameter. -If specified, expected predictions of this parameters are returned.} - -\item{re_formula}{Optional formula containing group-level effects to be -considered in the prediction. If \code{NULL}, include all group-level -effects; if \code{NA} (default), include no group-level effects.} - -\item{epred}{Logical. If \code{TRUE} compute predictions of -the posterior predictive distribution's mean -(see \code{\link{posterior_epred.brmsfit}}) while ignoring -arguments \code{dpar} and \code{nlpar}. Defaults to \code{FALSE}.} - -\item{...}{Additional arguments passed to \pkg{emmeans}.} -} -\description{ -Functions required for compatibility of \pkg{brms} with \pkg{emmeans}. -Users are not required to call these functions themselves. Instead, -they will be called automatically by the \code{emmeans} function -of the \pkg{emmeans} package. -} -\details{ -In order to ensure compatibility of most \pkg{brms} models with -\pkg{emmeans}, predictions are not generated 'manually' via a design matrix -and coefficient vector, but rather via \code{\link{posterior_linpred.brmsfit}}. -This appears to generally work well, but note that it produces an `.@linfct` -slot that contains the computed predictions as columns instead of the -coefficients. -} -\examples{ -\dontrun{ -fit <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), - data = kidney, family = lognormal()) -summary(fit) - -# summarize via 'emmeans' -library(emmeans) -rg <- ref_grid(fit) -em <- emmeans(rg, "disease") -summary(em, point.est = mean) - -# obtain estimates for the posterior predictive distribution's mean -epred <- emmeans(fit, "disease", epred = TRUE) -summary(epred, point.est = mean) -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/emmeans.R +\name{emmeans-brms-helpers} +\alias{emmeans-brms-helpers} +\alias{recover_data.brmsfit} +\alias{emm_basis.brmsfit} +\title{Support Functions for \pkg{emmeans}} +\usage{ +recover_data.brmsfit( + object, + data, + resp = NULL, + dpar = NULL, + nlpar = NULL, + re_formula = NA, + epred = FALSE, + ... +) + +emm_basis.brmsfit( + object, + trms, + xlev, + grid, + vcov., + resp = NULL, + dpar = NULL, + nlpar = NULL, + re_formula = NA, + epred = FALSE, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{data, trms, xlev, grid, vcov.}{Arguments required by \pkg{emmeans}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{dpar}{Optional name of a predicted distributional parameter. +If specified, expected predictions of this parameters are returned.} + +\item{nlpar}{Optional name of a predicted non-linear parameter. +If specified, expected predictions of this parameters are returned.} + +\item{re_formula}{Optional formula containing group-level effects to be +considered in the prediction. If \code{NULL}, include all group-level +effects; if \code{NA} (default), include no group-level effects.} + +\item{epred}{Logical. If \code{TRUE} compute predictions of +the posterior predictive distribution's mean +(see \code{\link{posterior_epred.brmsfit}}) while ignoring +arguments \code{dpar} and \code{nlpar}. Defaults to \code{FALSE}.} + +\item{...}{Additional arguments passed to \pkg{emmeans}.} +} +\description{ +Functions required for compatibility of \pkg{brms} with \pkg{emmeans}. +Users are not required to call these functions themselves. Instead, +they will be called automatically by the \code{emmeans} function +of the \pkg{emmeans} package. +} +\details{ +In order to ensure compatibility of most \pkg{brms} models with +\pkg{emmeans}, predictions are not generated 'manually' via a design matrix +and coefficient vector, but rather via \code{\link{posterior_linpred.brmsfit}}. +This appears to generally work well, but note that it produces an `.@linfct` +slot that contains the computed predictions as columns instead of the +coefficients. +} +\examples{ +\dontrun{ +fit <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), + data = kidney, family = lognormal()) +summary(fit) + +# summarize via 'emmeans' +library(emmeans) +rg <- ref_grid(fit) +em <- emmeans(rg, "disease") +summary(em, point.est = mean) + +# obtain estimates for the posterior predictive distribution's mean +epred <- emmeans(fit, "disease", epred = TRUE) +summary(epred, point.est = mean) +} +} diff -Nru r-cran-brms-2.16.3/man/epilepsy.Rd r-cran-brms-2.17.0/man/epilepsy.Rd --- r-cran-brms-2.16.3/man/epilepsy.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/epilepsy.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,62 +1,62 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/datasets.R -\docType{data} -\name{epilepsy} -\alias{epilepsy} -\title{Epileptic seizure counts} -\format{ -A data frame of 236 observations containing information - on the following 9 variables. -\describe{ - \item{Age}{The age of the patients in years} - \item{Base}{The seizure count at 8-weeks baseline} - \item{Trt}{Either \code{0} or \code{1} indicating - if the patient received anti-convulsant therapy} - \item{patient}{The patient number} - \item{visit}{The session number from \code{1} (first visit) - to \code{4} (last visit)} - \item{count}{The seizure count between two visits} - \item{obs}{The observation number, that is - a unique identifier for each observation} - \item{zAge}{Standardized \code{Age}} - \item{zBase}{Standardized \code{Base}} -} -} -\source{ -Thall, P. F., & Vail, S. C. (1990). - Some covariance models for longitudinal count data with overdispersion. - \emph{Biometrics, 46(2)}, 657-671. \cr - -Breslow, N. E., & Clayton, D. G. (1993). - Approximate inference in generalized linear mixed models. - \emph{Journal of the American Statistical Association}, 88(421), 9-25. -} -\usage{ -epilepsy -} -\description{ -Breslow and Clayton (1993) analyze data initially - provided by Thall and Vail (1990) concerning - seizure counts in a randomized trial of anti-convulsant - therapy in epilepsy. Covariates are treatment, - 8-week baseline seizure counts, and age of the patients in years. -} -\examples{ -\dontrun{ -## poisson regression without random effects. -fit1 <- brm(count ~ zAge + zBase * Trt, - data = epilepsy, family = poisson()) -summary(fit1) -plot(fit1) - -## poisson regression with varying intercepts of patients -## as well as normal priors for overall effects parameters. -fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson(), - prior = set_prior("normal(0,5)")) -summary(fit2) -plot(fit2) -} - -} -\keyword{datasets} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasets.R +\docType{data} +\name{epilepsy} +\alias{epilepsy} +\title{Epileptic seizure counts} +\format{ +A data frame of 236 observations containing information + on the following 9 variables. +\describe{ + \item{Age}{The age of the patients in years} + \item{Base}{The seizure count at 8-weeks baseline} + \item{Trt}{Either \code{0} or \code{1} indicating + if the patient received anti-convulsant therapy} + \item{patient}{The patient number} + \item{visit}{The session number from \code{1} (first visit) + to \code{4} (last visit)} + \item{count}{The seizure count between two visits} + \item{obs}{The observation number, that is + a unique identifier for each observation} + \item{zAge}{Standardized \code{Age}} + \item{zBase}{Standardized \code{Base}} +} +} +\source{ +Thall, P. F., & Vail, S. C. (1990). + Some covariance models for longitudinal count data with overdispersion. + \emph{Biometrics, 46(2)}, 657-671. \cr + +Breslow, N. E., & Clayton, D. G. (1993). + Approximate inference in generalized linear mixed models. + \emph{Journal of the American Statistical Association}, 88(421), 9-25. +} +\usage{ +epilepsy +} +\description{ +Breslow and Clayton (1993) analyze data initially + provided by Thall and Vail (1990) concerning + seizure counts in a randomized trial of anti-convulsant + therapy in epilepsy. Covariates are treatment, + 8-week baseline seizure counts, and age of the patients in years. +} +\examples{ +\dontrun{ +## poisson regression without random effects. +fit1 <- brm(count ~ zAge + zBase * Trt, + data = epilepsy, family = poisson()) +summary(fit1) +plot(fit1) + +## poisson regression with varying intercepts of patients +## as well as normal priors for overall effects parameters. +fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson(), + prior = set_prior("normal(0,5)")) +summary(fit2) +plot(fit2) +} + +} +\keyword{datasets} diff -Nru r-cran-brms-2.16.3/man/ExGaussian.Rd r-cran-brms-2.17.0/man/ExGaussian.Rd --- r-cran-brms-2.16.3/man/ExGaussian.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/ExGaussian.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,44 +1,44 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{ExGaussian} -\alias{ExGaussian} -\alias{dexgaussian} -\alias{pexgaussian} -\alias{rexgaussian} -\title{The Exponentially Modified Gaussian Distribution} -\usage{ -dexgaussian(x, mu, sigma, beta, log = FALSE) - -pexgaussian(q, mu, sigma, beta, lower.tail = TRUE, log.p = FALSE) - -rexgaussian(n, mu, sigma, beta) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{mu}{Vector of means of the combined distribution.} - -\item{sigma}{Vector of standard deviations of the gaussian component.} - -\item{beta}{Vector of scales of the exponential component.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, and random generation -for the exponentially modified Gaussian distribution with -mean \code{mu} and standard deviation \code{sigma} of the gaussian -component, as well as scale \code{beta} of the exponential -component. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{ExGaussian} +\alias{ExGaussian} +\alias{dexgaussian} +\alias{pexgaussian} +\alias{rexgaussian} +\title{The Exponentially Modified Gaussian Distribution} +\usage{ +dexgaussian(x, mu, sigma, beta, log = FALSE) + +pexgaussian(q, mu, sigma, beta, lower.tail = TRUE, log.p = FALSE) + +rexgaussian(n, mu, sigma, beta) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{mu}{Vector of means of the combined distribution.} + +\item{sigma}{Vector of standard deviations of the gaussian component.} + +\item{beta}{Vector of scales of the exponential component.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, and random generation +for the exponentially modified Gaussian distribution with +mean \code{mu} and standard deviation \code{sigma} of the gaussian +component, as well as scale \code{beta} of the exponential +component. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} diff -Nru r-cran-brms-2.16.3/man/expose_functions.brmsfit.Rd r-cran-brms-2.17.0/man/expose_functions.brmsfit.Rd --- r-cran-brms-2.16.3/man/expose_functions.brmsfit.Rd 2021-05-16 19:09:11.000000000 +0000 +++ r-cran-brms-2.17.0/man/expose_functions.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,29 +1,29 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{expose_functions.brmsfit} -\alias{expose_functions.brmsfit} -\alias{expose_functions} -\title{Expose user-defined \pkg{Stan} functions} -\usage{ -\method{expose_functions}{brmsfit}(x, vectorize = FALSE, env = globalenv(), ...) - -expose_functions(x, ...) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}.} - -\item{vectorize}{Logical; Indicates if the exposed functions -should be vectorized via \code{\link{Vectorize}}. -Defaults to \code{FALSE}.} - -\item{env}{Environment where the functions should be made -available. Defaults to the global environment.} - -\item{...}{Further arguments passed to -\code{\link[rstan:expose_stan_functions]{expose_stan_functions}}.} -} -\description{ -Export user-defined \pkg{Stan} function and -optionally vectorize them. For more details see -\code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{expose_functions.brmsfit} +\alias{expose_functions.brmsfit} +\alias{expose_functions} +\title{Expose user-defined \pkg{Stan} functions} +\usage{ +\method{expose_functions}{brmsfit}(x, vectorize = FALSE, env = globalenv(), ...) + +expose_functions(x, ...) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}.} + +\item{vectorize}{Logical; Indicates if the exposed functions +should be vectorized via \code{\link{Vectorize}}. +Defaults to \code{FALSE}.} + +\item{env}{Environment where the functions should be made +available. Defaults to the global environment.} + +\item{...}{Further arguments passed to +\code{\link[rstan:expose_stan_functions]{expose_stan_functions}}.} +} +\description{ +Export user-defined \pkg{Stan} function and +optionally vectorize them. For more details see +\code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. +} diff -Nru r-cran-brms-2.16.3/man/expp1.Rd r-cran-brms-2.17.0/man/expp1.Rd --- r-cran-brms-2.16.3/man/expp1.Rd 2020-05-21 11:32:10.000000000 +0000 +++ r-cran-brms-2.17.0/man/expp1.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,14 +1,14 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/numeric-helpers.R -\name{expp1} -\alias{expp1} -\title{Exponential function plus one.} -\usage{ -expp1(x) -} -\arguments{ -\item{x}{A numeric or complex vector.} -} -\description{ -Computes \code{exp(x) + 1}. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/numeric-helpers.R +\name{expp1} +\alias{expp1} +\title{Exponential function plus one.} +\usage{ +expp1(x) +} +\arguments{ +\item{x}{A numeric or complex vector.} +} +\description{ +Computes \code{exp(x) + 1}. +} diff -Nru r-cran-brms-2.16.3/man/family.brmsfit.Rd r-cran-brms-2.17.0/man/family.brmsfit.Rd --- r-cran-brms-2.16.3/man/family.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/family.brmsfit.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,23 +1,23 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{family.brmsfit} -\alias{family.brmsfit} -\title{Extract Model Family Objects} -\usage{ -\method{family}{brmsfit}(object, resp = NULL, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{...}{Currently unused.} -} -\value{ -A \code{brmsfamily} object -or a list of such objects for multivariate models. -} -\description{ -Extract Model Family Objects -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{family.brmsfit} +\alias{family.brmsfit} +\title{Extract Model Family Objects} +\usage{ +\method{family}{brmsfit}(object, resp = NULL, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{...}{Currently unused.} +} +\value{ +A \code{brmsfamily} object +or a list of such objects for multivariate models. +} +\description{ +Extract Model Family Objects +} diff -Nru r-cran-brms-2.16.3/man/fcor.Rd r-cran-brms-2.17.0/man/fcor.Rd --- r-cran-brms-2.16.3/man/fcor.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/fcor.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,37 +1,37 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ac.R -\name{fcor} -\alias{fcor} -\title{Fixed residual correlation (FCOR) structures} -\usage{ -fcor(M) -} -\arguments{ -\item{M}{Known correlation/covariance matrix of the response variable. -If a vector is passed, it will be used as diagonal entries -(variances) and correlations/covariances will be set to zero. -The actual covariance matrix used in the likelihood is obtained -by multiplying \code{M} by the square of the residual standard -deviation parameter \code{sigma} estimated as part of the model.} -} -\value{ -An object of class \code{'fcor_term'}, which is a list - of arguments to be interpreted by the formula - parsing functions of \pkg{brms}. -} -\description{ -Set up a fixed residual correlation (FCOR) term in \pkg{brms}. The function -does not evaluate its arguments -- it exists purely to help set up a model -with FCOR terms. -} -\examples{ -\dontrun{ -dat <- data.frame(y = rnorm(3)) -V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) -fit <- brm(y ~ 1 + fcor(V), data = dat, data2 = list(V = V)) -} - -} -\seealso{ -\code{\link{autocor-terms}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ac.R +\name{fcor} +\alias{fcor} +\title{Fixed residual correlation (FCOR) structures} +\usage{ +fcor(M) +} +\arguments{ +\item{M}{Known correlation/covariance matrix of the response variable. +If a vector is passed, it will be used as diagonal entries +(variances) and correlations/covariances will be set to zero. +The actual covariance matrix used in the likelihood is obtained +by multiplying \code{M} by the square of the residual standard +deviation parameter \code{sigma} estimated as part of the model.} +} +\value{ +An object of class \code{'fcor_term'}, which is a list + of arguments to be interpreted by the formula + parsing functions of \pkg{brms}. +} +\description{ +Set up a fixed residual correlation (FCOR) term in \pkg{brms}. The function +does not evaluate its arguments -- it exists purely to help set up a model +with FCOR terms. +} +\examples{ +\dontrun{ +dat <- data.frame(y = rnorm(3)) +V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) +fit <- brm(y ~ 1 + fcor(V), data = dat, data2 = list(V = V)) +} + +} +\seealso{ +\code{\link{autocor-terms}} +} diff -Nru r-cran-brms-2.16.3/man/fitted.brmsfit.Rd r-cran-brms-2.17.0/man/fitted.brmsfit.Rd --- r-cran-brms-2.16.3/man/fitted.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/fitted.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,122 +1,122 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_epred.R -\name{fitted.brmsfit} -\alias{fitted.brmsfit} -\title{Expected Values of the Posterior Predictive Distribution} -\usage{ -\method{fitted}{brmsfit}( - object, - newdata = NULL, - re_formula = NULL, - scale = c("response", "linear"), - resp = NULL, - dpar = NULL, - nlpar = NULL, - ndraws = NULL, - draw_ids = NULL, - sort = FALSE, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{scale}{Either \code{"response"} or \code{"linear"}. -If \code{"response"}, results are returned on the scale -of the response variable. If \code{"linear"}, -results are returned on the scale of the linear predictor term, -that is without applying the inverse link function or -other transformations.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{dpar}{Optional name of a predicted distributional parameter. -If specified, expected predictions of this parameters are returned.} - -\item{nlpar}{Optional name of a predicted non-linear parameter. -If specified, expected predictions of this parameters are returned.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{sort}{Logical. Only relevant for time series models. -Indicating whether to return predicted values in the original -order (\code{FALSE}; default) or in the order of the -time series (\code{TRUE}).} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}..} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -An \code{array} of predicted \emph{mean} response values. - If \code{summary = FALSE} the output resembles those of - \code{\link{posterior_epred.brmsfit}}. - - If \code{summary = TRUE} the output depends on the family: For categorical - and ordinal families, the output is an N x E x C array, where N is the - number of observations, E is the number of summary statistics, and C is the - number of categories. For all other families, the output is an N x E - matrix. The number of summary statistics E is equal to \code{2 + - length(probs)}: The \code{Estimate} column contains point estimates (either - mean or median depending on argument \code{robust}), while the - \code{Est.Error} column contains uncertainty estimates (either standard - deviation or median absolute deviation depending on argument - \code{robust}). The remaining columns starting with \code{Q} contain - quantile estimates as specified via argument \code{probs}. - - In multivariate models, an additional dimension is added to the output - which indexes along the different response variables. -} -\description{ -This method is an alias of \code{\link{posterior_epred.brmsfit}} -with additional arguments for obtaining summaries of the computed draws. -} -\examples{ -\dontrun{ -## fit a model -fit <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler) - -## compute expected predictions -fitted_values <- fitted(fit) -head(fitted_values) - -## plot expected predictions against actual response -dat <- as.data.frame(cbind(Y = standata(fit)$Y, fitted_values)) -ggplot(dat) + geom_point(aes(x = Estimate, y = Y)) -} - -} -\seealso{ -\code{\link{posterior_epred.brmsfit}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_epred.R +\name{fitted.brmsfit} +\alias{fitted.brmsfit} +\title{Expected Values of the Posterior Predictive Distribution} +\usage{ +\method{fitted}{brmsfit}( + object, + newdata = NULL, + re_formula = NULL, + scale = c("response", "linear"), + resp = NULL, + dpar = NULL, + nlpar = NULL, + ndraws = NULL, + draw_ids = NULL, + sort = FALSE, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{scale}{Either \code{"response"} or \code{"linear"}. +If \code{"response"}, results are returned on the scale +of the response variable. If \code{"linear"}, +results are returned on the scale of the linear predictor term, +that is without applying the inverse link function or +other transformations.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{dpar}{Optional name of a predicted distributional parameter. +If specified, expected predictions of this parameters are returned.} + +\item{nlpar}{Optional name of a predicted non-linear parameter. +If specified, expected predictions of this parameters are returned.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{sort}{Logical. Only relevant for time series models. +Indicating whether to return predicted values in the original +order (\code{FALSE}; default) or in the order of the +time series (\code{TRUE}).} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}..} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +An \code{array} of predicted \emph{mean} response values. + If \code{summary = FALSE} the output resembles those of + \code{\link{posterior_epred.brmsfit}}. + + If \code{summary = TRUE} the output depends on the family: For categorical + and ordinal families, the output is an N x E x C array, where N is the + number of observations, E is the number of summary statistics, and C is the + number of categories. For all other families, the output is an N x E + matrix. The number of summary statistics E is equal to \code{2 + + length(probs)}: The \code{Estimate} column contains point estimates (either + mean or median depending on argument \code{robust}), while the + \code{Est.Error} column contains uncertainty estimates (either standard + deviation or median absolute deviation depending on argument + \code{robust}). The remaining columns starting with \code{Q} contain + quantile estimates as specified via argument \code{probs}. + + In multivariate models, an additional dimension is added to the output + which indexes along the different response variables. +} +\description{ +This method is an alias of \code{\link{posterior_epred.brmsfit}} +with additional arguments for obtaining summaries of the computed draws. +} +\examples{ +\dontrun{ +## fit a model +fit <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler) + +## compute expected predictions +fitted_values <- fitted(fit) +head(fitted_values) + +## plot expected predictions against actual response +dat <- as.data.frame(cbind(Y = standata(fit)$Y, fitted_values)) +ggplot(dat) + geom_point(aes(x = Estimate, y = Y)) +} + +} +\seealso{ +\code{\link{posterior_epred.brmsfit}} +} diff -Nru r-cran-brms-2.16.3/man/fixef.brmsfit.Rd r-cran-brms-2.17.0/man/fixef.brmsfit.Rd --- r-cran-brms-2.16.3/man/fixef.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/fixef.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,56 +1,56 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{fixef.brmsfit} -\alias{fixef.brmsfit} -\alias{fixef} -\title{Extract Population-Level Estimates} -\usage{ -\method{fixef}{brmsfit}( - object, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - pars = NULL, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{pars}{Optional names of coefficients to extract. -By default, all coefficients are extracted.} - -\item{...}{Currently ignored.} -} -\value{ -If \code{summary} is \code{TRUE}, a matrix returned - by \code{\link{posterior_summary}} for the population-level effects. - If \code{summary} is \code{FALSE}, a matrix with one row per - posterior draw and one column per population-level effect. -} -\description{ -Extract the population-level ('fixed') effects -from a \code{brmsfit} object. -} -\examples{ -\dontrun{ -fit <- brm(time | cens(censored) ~ age + sex + disease, - data = kidney, family = "exponential") -fixef(fit) -# extract only some coefficients -fixef(fit, pars = c("age", "sex")) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{fixef.brmsfit} +\alias{fixef.brmsfit} +\alias{fixef} +\title{Extract Population-Level Estimates} +\usage{ +\method{fixef}{brmsfit}( + object, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + pars = NULL, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{pars}{Optional names of coefficients to extract. +By default, all coefficients are extracted.} + +\item{...}{Currently ignored.} +} +\value{ +If \code{summary} is \code{TRUE}, a matrix returned + by \code{\link{posterior_summary}} for the population-level effects. + If \code{summary} is \code{FALSE}, a matrix with one row per + posterior draw and one column per population-level effect. +} +\description{ +Extract the population-level ('fixed') effects +from a \code{brmsfit} object. +} +\examples{ +\dontrun{ +fit <- brm(time | cens(censored) ~ age + sex + disease, + data = kidney, family = "exponential") +fixef(fit) +# extract only some coefficients +fixef(fit, pars = c("age", "sex")) +} + +} diff -Nru r-cran-brms-2.16.3/man/Frechet.Rd r-cran-brms-2.17.0/man/Frechet.Rd --- r-cran-brms-2.16.3/man/Frechet.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/Frechet.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,47 +1,47 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{Frechet} -\alias{Frechet} -\alias{dfrechet} -\alias{pfrechet} -\alias{qfrechet} -\alias{rfrechet} -\title{The Frechet Distribution} -\usage{ -dfrechet(x, loc = 0, scale = 1, shape = 1, log = FALSE) - -pfrechet(q, loc = 0, scale = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) - -qfrechet(p, loc = 0, scale = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) - -rfrechet(n, loc = 0, scale = 1, shape = 1) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{loc}{Vector of locations.} - -\item{scale}{Vector of scales.} - -\item{shape}{Vector of shapes.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{p}{Vector of probabilities.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, quantile function and random generation -for the Frechet distribution with location \code{loc}, scale \code{scale}, -and shape \code{shape}. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{Frechet} +\alias{Frechet} +\alias{dfrechet} +\alias{pfrechet} +\alias{qfrechet} +\alias{rfrechet} +\title{The Frechet Distribution} +\usage{ +dfrechet(x, loc = 0, scale = 1, shape = 1, log = FALSE) + +pfrechet(q, loc = 0, scale = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) + +qfrechet(p, loc = 0, scale = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) + +rfrechet(n, loc = 0, scale = 1, shape = 1) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{loc}{Vector of locations.} + +\item{scale}{Vector of scales.} + +\item{shape}{Vector of shapes.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{p}{Vector of probabilities.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, quantile function and random generation +for the Frechet distribution with location \code{loc}, scale \code{scale}, +and shape \code{shape}. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} diff -Nru r-cran-brms-2.16.3/man/GenExtremeValue.Rd r-cran-brms-2.17.0/man/GenExtremeValue.Rd --- r-cran-brms-2.16.3/man/GenExtremeValue.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/GenExtremeValue.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,49 +1,49 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{GenExtremeValue} -\alias{GenExtremeValue} -\alias{dgen_extreme_value} -\alias{pgen_extreme_value} -\alias{rgen_extreme_value} -\title{The Generalized Extreme Value Distribution} -\usage{ -dgen_extreme_value(x, mu = 0, sigma = 1, xi = 0, log = FALSE) - -pgen_extreme_value( - q, - mu = 0, - sigma = 1, - xi = 0, - lower.tail = TRUE, - log.p = FALSE -) - -rgen_extreme_value(n, mu = 0, sigma = 1, xi = 0) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{mu}{Vector of locations.} - -\item{sigma}{Vector of scales.} - -\item{xi}{Vector of shapes.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, and random generation -for the generalized extreme value distribution with -location \code{mu}, scale \code{sigma} and shape \code{xi}. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{GenExtremeValue} +\alias{GenExtremeValue} +\alias{dgen_extreme_value} +\alias{pgen_extreme_value} +\alias{rgen_extreme_value} +\title{The Generalized Extreme Value Distribution} +\usage{ +dgen_extreme_value(x, mu = 0, sigma = 1, xi = 0, log = FALSE) + +pgen_extreme_value( + q, + mu = 0, + sigma = 1, + xi = 0, + lower.tail = TRUE, + log.p = FALSE +) + +rgen_extreme_value(n, mu = 0, sigma = 1, xi = 0) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{mu}{Vector of locations.} + +\item{sigma}{Vector of scales.} + +\item{xi}{Vector of shapes.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, and random generation +for the generalized extreme value distribution with +location \code{mu}, scale \code{sigma} and shape \code{xi}. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} diff -Nru r-cran-brms-2.16.3/man/get_dpar.Rd r-cran-brms-2.17.0/man/get_dpar.Rd --- r-cran-brms-2.16.3/man/get_dpar.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/get_dpar.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,49 +1,49 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-helpers.R -\name{get_dpar} -\alias{get_dpar} -\title{Draws of a Distributional Parameter} -\usage{ -get_dpar(prep, dpar, i = NULL, ilink = NULL) -} -\arguments{ -\item{prep}{A 'brmsprep' or 'mvbrmsprep' object created by -\code{\link[brms:prepare_predictions.brmsfit]{prepare_predictions}}.} - -\item{dpar}{Name of the distributional parameter.} - -\item{i}{The observation numbers for which predictions shall be extracted. -If \code{NULL} (the default), all observation will be extracted. -Ignored if \code{dpar} is not predicted.} - -\item{ilink}{Should the inverse link function be applied? -If \code{NULL} (the default), the value is chosen internally. -In particular, \code{ilink} is \code{TRUE} by default for custom -families.} -} -\value{ -If the parameter is predicted and \code{i} is \code{NULL} or - \code{length(i) > 1}, an \code{S x N} matrix. If the parameter it not - predicted or \code{length(i) == 1}, a vector of length \code{S}. Here - \code{S} is the number of draws and \code{N} is the number of - observations or length of \code{i} if specified. -} -\description{ -Get draws of a distributional parameter from a \code{brmsprep} or -\code{mvbrmsprep} object. This function is primarily useful when developing -custom families or packages depending on \pkg{brms}. -This function lets callers easily handle both the case when the -distributional parameter is predicted directly, via a (non-)linear -predictor or fixed to a constant. See the vignette -\code{vignette("brms_customfamilies")} for an example use case. -} -\examples{ -\dontrun{ -posterior_predict_my_dist <- function(i, prep, ...) { - mu <- brms::get_dpar(prep, "mu", i = i) - mypar <- brms::get_dpar(prep, "mypar", i = i) - my_rng(mu, mypar) -} -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-helpers.R +\name{get_dpar} +\alias{get_dpar} +\title{Draws of a Distributional Parameter} +\usage{ +get_dpar(prep, dpar, i = NULL, inv_link = NULL) +} +\arguments{ +\item{prep}{A 'brmsprep' or 'mvbrmsprep' object created by +\code{\link[brms:prepare_predictions.brmsfit]{prepare_predictions}}.} + +\item{dpar}{Name of the distributional parameter.} + +\item{i}{The observation numbers for which predictions shall be extracted. +If \code{NULL} (the default), all observation will be extracted. +Ignored if \code{dpar} is not predicted.} + +\item{inv_link}{Should the inverse link function be applied? +If \code{NULL} (the default), the value is chosen internally. +In particular, \code{inv_link} is \code{TRUE} by default for custom +families.} +} +\value{ +If the parameter is predicted and \code{i} is \code{NULL} or + \code{length(i) > 1}, an \code{S x N} matrix. If the parameter it not + predicted or \code{length(i) == 1}, a vector of length \code{S}. Here + \code{S} is the number of draws and \code{N} is the number of + observations or length of \code{i} if specified. +} +\description{ +Get draws of a distributional parameter from a \code{brmsprep} or +\code{mvbrmsprep} object. This function is primarily useful when developing +custom families or packages depending on \pkg{brms}. +This function lets callers easily handle both the case when the +distributional parameter is predicted directly, via a (non-)linear +predictor or fixed to a constant. See the vignette +\code{vignette("brms_customfamilies")} for an example use case. +} +\examples{ +\dontrun{ +posterior_predict_my_dist <- function(i, prep, ...) { + mu <- brms::get_dpar(prep, "mu", i = i) + mypar <- brms::get_dpar(prep, "mypar", i = i) + my_rng(mu, mypar) +} +} + +} diff -Nru r-cran-brms-2.16.3/man/get_prior.Rd r-cran-brms-2.17.0/man/get_prior.Rd --- r-cran-brms-2.16.3/man/get_prior.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/get_prior.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,93 +1,93 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/priors.R -\name{get_prior} -\alias{get_prior} -\title{Overview on Priors for \pkg{brms} Models} -\usage{ -get_prior( - formula, - data, - family = gaussian(), - autocor = NULL, - data2 = NULL, - knots = NULL, - sparse = NULL, - ... -) -} -\arguments{ -\item{formula}{An object of class \code{\link[stats:formula]{formula}}, -\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can -be coerced to that classes): A symbolic description of the model to be -fitted. The details of model specification are explained in -\code{\link{brmsformula}}.} - -\item{data}{An object of class \code{data.frame} (or one that can be coerced -to that class) containing data of all variables used in the model.} - -\item{family}{A description of the response distribution and link function to -be used in the model. This can be a family function, a call to a family -function or a character string naming the family. Every family function has -a \code{link} argument allowing to specify the link function to be applied -on the response variable. If not specified, default links are used. For -details of supported families see \code{\link{brmsfamily}}. By default, a -linear \code{gaussian} model is applied. In multivariate models, -\code{family} might also be a list of families.} - -\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object -describing the correlation structure within the response variable (i.e., -the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for -a description of the available correlation structures. Defaults to -\code{NULL}, corresponding to no correlations. In multivariate models, -\code{autocor} might also be a list of autocorrelation structures. -It is now recommend to specify autocorrelation terms directly -within \code{formula}. See \code{\link{brmsformula}} for more details.} - -\item{data2}{A named \code{list} of objects containing data, which -cannot be passed via argument \code{data}. Required for some objects -used in autocorrelation structures to specify dependency structures -as well as for within-group covariance matrices.} - -\item{knots}{Optional list containing user specified knot values to be used -for basis construction of smoothing terms. See -\code{\link[mgcv:gamm]{gamm}} for more details.} - -\item{sparse}{(Deprecated) Logical; indicates whether the population-level -design matrices should be treated as sparse (defaults to \code{FALSE}). For -design matrices with many zeros, this can considerably reduce required -memory. Sampling speed is currently not improved or even slightly -decreased. It is now recommended to use the \code{sparse} argument of -\code{\link{brmsformula}} and related functions.} - -\item{...}{Other arguments for internal usage only.} -} -\value{ -A data.frame with columns \code{prior}, \code{class}, \code{coef}, - and \code{group} and several rows, each providing information on a - parameter (or parameter class) on which priors can be specified. The prior - column is empty except for internal default priors. -} -\description{ -Get information on all parameters (and parameter classes) for which priors -may be specified including default priors. -} -\examples{ -## get all parameters and parameters classes to define priors on -(prior <- get_prior(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), - data = epilepsy, family = poisson())) - -## define a prior on all population-level effects a once -prior$prior[1] <- "normal(0,10)" - -## define a specific prior on the population-level effect of Trt -prior$prior[5] <- "student_t(10, 0, 5)" - -## verify that the priors indeed found their way into Stan's model code -make_stancode(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), - data = epilepsy, family = poisson(), - prior = prior) - -} -\seealso{ -\code{\link{set_prior}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/priors.R +\name{get_prior} +\alias{get_prior} +\title{Overview on Priors for \pkg{brms} Models} +\usage{ +get_prior( + formula, + data, + family = gaussian(), + autocor = NULL, + data2 = NULL, + knots = NULL, + sparse = NULL, + ... +) +} +\arguments{ +\item{formula}{An object of class \code{\link[stats:formula]{formula}}, +\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can +be coerced to that classes): A symbolic description of the model to be +fitted. The details of model specification are explained in +\code{\link{brmsformula}}.} + +\item{data}{An object of class \code{data.frame} (or one that can be coerced +to that class) containing data of all variables used in the model.} + +\item{family}{A description of the response distribution and link function to +be used in the model. This can be a family function, a call to a family +function or a character string naming the family. Every family function has +a \code{link} argument allowing to specify the link function to be applied +on the response variable. If not specified, default links are used. For +details of supported families see \code{\link{brmsfamily}}. By default, a +linear \code{gaussian} model is applied. In multivariate models, +\code{family} might also be a list of families.} + +\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object +describing the correlation structure within the response variable (i.e., +the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for +a description of the available correlation structures. Defaults to +\code{NULL}, corresponding to no correlations. In multivariate models, +\code{autocor} might also be a list of autocorrelation structures. +It is now recommend to specify autocorrelation terms directly +within \code{formula}. See \code{\link{brmsformula}} for more details.} + +\item{data2}{A named \code{list} of objects containing data, which +cannot be passed via argument \code{data}. Required for some objects +used in autocorrelation structures to specify dependency structures +as well as for within-group covariance matrices.} + +\item{knots}{Optional list containing user specified knot values to be used +for basis construction of smoothing terms. See +\code{\link[mgcv:gamm]{gamm}} for more details.} + +\item{sparse}{(Deprecated) Logical; indicates whether the population-level +design matrices should be treated as sparse (defaults to \code{FALSE}). For +design matrices with many zeros, this can considerably reduce required +memory. Sampling speed is currently not improved or even slightly +decreased. It is now recommended to use the \code{sparse} argument of +\code{\link{brmsformula}} and related functions.} + +\item{...}{Other arguments for internal usage only.} +} +\value{ +A data.frame with columns \code{prior}, \code{class}, \code{coef}, + and \code{group} and several rows, each providing information on a + parameter (or parameter class) on which priors can be specified. The prior + column is empty except for internal default priors. +} +\description{ +Get information on all parameters (and parameter classes) for which priors +may be specified including default priors. +} +\examples{ +## get all parameters and parameters classes to define priors on +(prior <- get_prior(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), + data = epilepsy, family = poisson())) + +## define a prior on all population-level effects a once +prior$prior[1] <- "normal(0,10)" + +## define a specific prior on the population-level effect of Trt +prior$prior[5] <- "student_t(10, 0, 5)" + +## verify that the priors indeed found their way into Stan's model code +make_stancode(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), + data = epilepsy, family = poisson(), + prior = prior) + +} +\seealso{ +\code{\link{set_prior}} +} diff -Nru r-cran-brms-2.16.3/man/get_refmodel.brmsfit.Rd r-cran-brms-2.17.0/man/get_refmodel.brmsfit.Rd --- r-cran-brms-2.16.3/man/get_refmodel.brmsfit.Rd 2021-09-10 12:29:53.000000000 +0000 +++ r-cran-brms-2.17.0/man/get_refmodel.brmsfit.Rd 2022-04-03 19:33:18.000000000 +0000 @@ -1,68 +1,78 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/projpred.R -\name{get_refmodel.brmsfit} -\alias{get_refmodel.brmsfit} -\title{Projection Predictive Variable Selection: Get Reference Model} -\usage{ -get_refmodel.brmsfit(object, newdata = NULL, resp = NULL, cvfun = NULL, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{cvfun}{Optional cross-validation function -(see \code{\link[projpred:get-refmodel]{get_refmodel}} for details). -If \code{NULL} (the default), \code{cvfun} is defined internally -based on \code{\link{kfold.brmsfit}}.} - -\item{...}{Further arguments passed to -\code{\link[projpred:get-refmodel]{init_refmodel}}.} -} -\value{ -A \code{refmodel} object to be used in conjunction with the - \pkg{projpred} package. -} -\description{ -The \code{get_refmodel.brmsfit} method can be used to create the reference -model structure which is needed by the \pkg{projpred} package for performing -a projection predictive variable selection. This method is called -automatically when performing variable selection via -\code{\link[projpred:varsel]{varsel}} or -\code{\link[projpred:cv_varsel]{cv_varsel}}, so you will rarely need to call -it manually yourself. -} -\details{ -Note that the \code{extract_model_data} function used internally by - \code{get_refmodel.brmsfit} ignores arguments \code{wrhs}, \code{orhs}, and - \code{extract_y}. This is relevant for - \code{\link[projpred:predict.refmodel]{predict.refmodel}}, for example. -} -\examples{ -\dontrun{ -# fit a simple model -fit <- brm(count ~ zAge + zBase * Trt, - data = epilepsy, family = poisson()) -summary(fit) - -# The following code requires the 'projpred' package to be installed: -library(projpred) - -# perform variable selection without cross-validation -vs <- varsel(fit) -summary(vs) -plot(vs) - -# perform variable selection with cross-validation -cv_vs <- cv_varsel(fit) -summary(cv_vs) -plot(cv_vs) -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/projpred.R +\name{get_refmodel.brmsfit} +\alias{get_refmodel.brmsfit} +\title{Projection Predictive Variable Selection: Get Reference Model} +\usage{ +get_refmodel.brmsfit( + object, + newdata = NULL, + resp = NULL, + cvfun = NULL, + brms_seed = NULL, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{cvfun}{Optional cross-validation function +(see \code{\link[projpred:get_refmodel]{get_refmodel}} for details). +If \code{NULL} (the default), \code{cvfun} is defined internally +based on \code{\link{kfold.brmsfit}}.} + +\item{brms_seed}{A seed used to infer seeds for \code{\link{kfold.brmsfit}} +and for sampling group-level effects for new levels (in multilevel models).} + +\item{...}{Further arguments passed to +\code{\link[projpred:init_refmodel]{init_refmodel}}.} +} +\value{ +A \code{refmodel} object to be used in conjunction with the + \pkg{projpred} package. +} +\description{ +The \code{get_refmodel.brmsfit} method can be used to create the reference +model structure which is needed by the \pkg{projpred} package for performing +a projection predictive variable selection. This method is called +automatically when performing variable selection via +\code{\link[projpred:varsel]{varsel}} or +\code{\link[projpred:cv_varsel]{cv_varsel}}, so you will rarely need to call +it manually yourself. +} +\details{ +Note that the \code{extract_model_data} function used internally by + \code{get_refmodel.brmsfit} ignores arguments \code{wrhs}, \code{orhs}, and + \code{extract_y}. This is relevant for + \code{\link[projpred:predict.refmodel]{predict.refmodel}}, for example. +} +\examples{ +\dontrun{ +# fit a simple model +fit <- brm(count ~ zAge + zBase * Trt, + data = epilepsy, family = poisson()) +summary(fit) + +# The following code requires the 'projpred' package to be installed: +library(projpred) + +# perform variable selection without cross-validation +vs <- varsel(fit) +summary(vs) +plot(vs) + +# perform variable selection with cross-validation +cv_vs <- cv_varsel(fit) +summary(cv_vs) +plot(cv_vs) +} +} diff -Nru r-cran-brms-2.16.3/man/get_y.Rd r-cran-brms-2.17.0/man/get_y.Rd --- r-cran-brms-2.16.3/man/get_y.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/get_y.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,31 +1,31 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data-response.R -\name{get_y} -\alias{get_y} -\title{Extract response values} -\usage{ -get_y(x, resp = NULL, sort = FALSE, warn = FALSE, ...) -} -\arguments{ -\item{x}{A \code{\link{brmsfit}} object.} - -\item{resp}{Optional names of response variables for which to extract values.} - -\item{sort}{Logical. Only relevant for time series models. -Indicating whether to return predicted values in the original -order (\code{FALSE}; default) or in the order of the -time series (\code{TRUE}).} - -\item{warn}{For internal use only.} - -\item{...}{Further arguments passed to \code{\link{standata}}.} -} -\value{ -Returns a vector of response values for univariate models and a - matrix of response values with one column per response variable for - multivariate models. -} -\description{ -Extract response values from a \code{\link{brmsfit}} object. -} -\keyword{internal} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data-response.R +\name{get_y} +\alias{get_y} +\title{Extract response values} +\usage{ +get_y(x, resp = NULL, sort = FALSE, warn = FALSE, ...) +} +\arguments{ +\item{x}{A \code{\link{brmsfit}} object.} + +\item{resp}{Optional names of response variables for which to extract values.} + +\item{sort}{Logical. Only relevant for time series models. +Indicating whether to return predicted values in the original +order (\code{FALSE}; default) or in the order of the +time series (\code{TRUE}).} + +\item{warn}{For internal use only.} + +\item{...}{Further arguments passed to \code{\link{standata}}.} +} +\value{ +Returns a vector of response values for univariate models and a + matrix of response values with one column per response variable for + multivariate models. +} +\description{ +Extract response values from a \code{\link{brmsfit}} object. +} +\keyword{internal} diff -Nru r-cran-brms-2.16.3/man/gp.Rd r-cran-brms-2.17.0/man/gp.Rd --- r-cran-brms-2.16.3/man/gp.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/gp.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,143 +1,143 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-gp.R -\name{gp} -\alias{gp} -\title{Set up Gaussian process terms in \pkg{brms}} -\usage{ -gp( - ..., - by = NA, - k = NA, - cov = "exp_quad", - iso = TRUE, - gr = TRUE, - cmc = TRUE, - scale = TRUE, - c = NULL -) -} -\arguments{ -\item{...}{One or more predictors for the GP.} - -\item{by}{A numeric or factor variable of the same length as -each predictor. In the numeric vector case, the elements multiply -the values returned by the GP. In the factor variable -case, a separate GP is fitted for each factor level.} - -\item{k}{Optional number of basis functions for computing approximate -GPs. If \code{NA} (the default), exact GPs are computed.} - -\item{cov}{Name of the covariance kernel. By default, -the exponentiated-quadratic kernel \code{"exp_quad"} is used.} - -\item{iso}{A flag to indicate whether an isotropic (\code{TRUE}; the -default) of a non-isotropic GP should be used. -In the former case, the same amount of smoothing is applied to all -predictors. In the latter case, predictors may have different smoothing. -Ignored if only a single predictors is supplied.} - -\item{gr}{Logical; Indicates if auto-grouping should be used (defaults -to \code{TRUE}). If enabled, observations sharing the same -predictor values will be represented by the same latent variable -in the GP. This will improve sampling efficiency -drastically if the number of unique predictor combinations is small -relative to the number of observations.} - -\item{cmc}{Logical; Only relevant if \code{by} is a factor. If \code{TRUE} -(the default), cell-mean coding is used for the \code{by}-factor, that is -one GP per level is estimated. If \code{FALSE}, contrast GPs are estimated -according to the contrasts set for the \code{by}-factor.} - -\item{scale}{Logical; If \code{TRUE} (the default), predictors are -scaled so that the maximum Euclidean distance between two points -is 1. This often improves sampling speed and convergence. -Scaling also affects the estimated length-scale parameters -in that they resemble those of scaled predictors (not of the original -predictors) if \code{scale} is \code{TRUE}.} - -\item{c}{Numeric value only used in approximate GPs. Defines the -multiplicative constant of the predictors' range over which -predictions should be computed. A good default could be \code{c = 5/4} -but we are still working on providing better recommendations.} -} -\value{ -An object of class \code{'gp_term'}, which is a list - of arguments to be interpreted by the formula - parsing functions of \pkg{brms}. -} -\description{ -Set up a Gaussian process (GP) term in \pkg{brms}. The function does not -evaluate its arguments -- it exists purely to help set up a model with -GP terms. -} -\details{ -A GP is a stochastic process, which - describes the relation between one or more predictors - \eqn{x = (x_1, ..., x_d)} and a response \eqn{f(x)}, where - \eqn{d} is the number of predictors. A GP is the - generalization of the multivariate normal distribution - to an infinite number of dimensions. Thus, it can be - interpreted as a prior over functions. Any finite sample - realized from this stochastic process is jointly multivariate - normal, with a covariance matrix defined by the covariance - kernel \eqn{k_p(x)}, where \eqn{p} is the vector of parameters - of the GP: - \deqn{f(x) ~ MVN(0, k_p(x))} - The smoothness and general behavior of the function \eqn{f} - depends only on the choice of covariance kernel. - For a more detailed introduction to Gaussian processes, - see \url{https://en.wikipedia.org/wiki/Gaussian_process}. - - Below, we describe the currently supported covariance kernels: - \itemize{ - \item{"exp_quad": }{The exponentiated-quadratic kernel is defined as - \eqn{k(x_i, x_j) = sdgp^2 exp(- || x_i - x_j ||^2 / (2 lscale^2))}, - where \eqn{|| . ||} is the Euclidean norm, \eqn{sdgp} is a - standard deviation parameter, and \eqn{lscale} is characteristic - length-scale parameter. The latter practically measures how close two - points \eqn{x_i} and \eqn{x_j} have to be to influence each other - substantially.} - } - - In the current implementation, \code{"exp_quad"} is the only supported - covariance kernel. More options will follow in the future. -} -\examples{ -\dontrun{ -# simulate data using the mgcv package -dat <- mgcv::gamSim(1, n = 30, scale = 2) - -# fit a simple GP model -fit1 <- brm(y ~ gp(x2), dat, chains = 2) -summary(fit1) -me1 <- conditional_effects(fit1, ndraws = 200, spaghetti = TRUE) -plot(me1, ask = FALSE, points = TRUE) - -# fit a more complicated GP model -fit2 <- brm(y ~ gp(x0) + x1 + gp(x2) + x3, dat, chains = 2) -summary(fit2) -me2 <- conditional_effects(fit2, ndraws = 200, spaghetti = TRUE) -plot(me2, ask = FALSE, points = TRUE) - -# fit a multivariate GP model -fit3 <- brm(y ~ gp(x1, x2), dat, chains = 2) -summary(fit3) -me3 <- conditional_effects(fit3, ndraws = 200, spaghetti = TRUE) -plot(me3, ask = FALSE, points = TRUE) - -# compare model fit -LOO(fit1, fit2, fit3) - -# simulate data with a factor covariate -dat2 <- mgcv::gamSim(4, n = 90, scale = 2) - -# fit separate gaussian processes for different levels of 'fac' -fit4 <- brm(y ~ gp(x2, by = fac), dat2, chains = 2) -summary(fit4) -plot(conditional_effects(fit4), points = TRUE) -} - -} -\seealso{ -\code{\link{brmsformula}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-gp.R +\name{gp} +\alias{gp} +\title{Set up Gaussian process terms in \pkg{brms}} +\usage{ +gp( + ..., + by = NA, + k = NA, + cov = "exp_quad", + iso = TRUE, + gr = TRUE, + cmc = TRUE, + scale = TRUE, + c = NULL +) +} +\arguments{ +\item{...}{One or more predictors for the GP.} + +\item{by}{A numeric or factor variable of the same length as +each predictor. In the numeric vector case, the elements multiply +the values returned by the GP. In the factor variable +case, a separate GP is fitted for each factor level.} + +\item{k}{Optional number of basis functions for computing approximate +GPs. If \code{NA} (the default), exact GPs are computed.} + +\item{cov}{Name of the covariance kernel. By default, +the exponentiated-quadratic kernel \code{"exp_quad"} is used.} + +\item{iso}{A flag to indicate whether an isotropic (\code{TRUE}; the +default) or a non-isotropic GP should be used. +In the former case, the same amount of smoothing is applied to all +predictors. In the latter case, predictors may have different smoothing. +Ignored if only a single predictor is supplied.} + +\item{gr}{Logical; Indicates if auto-grouping should be used (defaults +to \code{TRUE}). If enabled, observations sharing the same +predictor values will be represented by the same latent variable +in the GP. This will improve sampling efficiency +drastically if the number of unique predictor combinations is small +relative to the number of observations.} + +\item{cmc}{Logical; Only relevant if \code{by} is a factor. If \code{TRUE} +(the default), cell-mean coding is used for the \code{by}-factor, that is +one GP per level is estimated. If \code{FALSE}, contrast GPs are estimated +according to the contrasts set for the \code{by}-factor.} + +\item{scale}{Logical; If \code{TRUE} (the default), predictors are +scaled so that the maximum Euclidean distance between two points +is 1. This often improves sampling speed and convergence. +Scaling also affects the estimated length-scale parameters +in that they resemble those of scaled predictors (not of the original +predictors) if \code{scale} is \code{TRUE}.} + +\item{c}{Numeric value only used in approximate GPs. Defines the +multiplicative constant of the predictors' range over which +predictions should be computed. A good default could be \code{c = 5/4} +but we are still working on providing better recommendations.} +} +\value{ +An object of class \code{'gp_term'}, which is a list + of arguments to be interpreted by the formula + parsing functions of \pkg{brms}. +} +\description{ +Set up a Gaussian process (GP) term in \pkg{brms}. The function does not +evaluate its arguments -- it exists purely to help set up a model with +GP terms. +} +\details{ +A GP is a stochastic process, which + describes the relation between one or more predictors + \eqn{x = (x_1, ..., x_d)} and a response \eqn{f(x)}, where + \eqn{d} is the number of predictors. A GP is the + generalization of the multivariate normal distribution + to an infinite number of dimensions. Thus, it can be + interpreted as a prior over functions. The values of \eqn{f( )} + at any finite set of locations are jointly multivariate + normal, with a covariance matrix defined by the covariance + kernel \eqn{k_p(x_i, x_j)}, where \eqn{p} is the vector of parameters + of the GP: + \deqn{(f(x_1), \ldots f(x_n) \sim MVN(0, (k_p(x_i, x_j))_{i,j=1}^n) .} + The smoothness and general behavior of the function \eqn{f} + depends only on the choice of covariance kernel. + For a more detailed introduction to Gaussian processes, + see \url{https://en.wikipedia.org/wiki/Gaussian_process}. + + Below, we describe the currently supported covariance kernels: + \itemize{ + \item{"exp_quad": }{The exponentiated-quadratic kernel is defined as + \eqn{k(x_i, x_j) = sdgp^2 \exp(- || x_i - x_j ||^2 / (2 lscale^2))}, + where \eqn{|| . ||} is the Euclidean norm, \eqn{sdgp} is a + standard deviation parameter, and \eqn{lscale} is characteristic + length-scale parameter. The latter practically measures how close two + points \eqn{x_i} and \eqn{x_j} have to be to influence each other + substantially.} + } + + In the current implementation, \code{"exp_quad"} is the only supported + covariance kernel. More options will follow in the future. +} +\examples{ +\dontrun{ +# simulate data using the mgcv package +dat <- mgcv::gamSim(1, n = 30, scale = 2) + +# fit a simple GP model +fit1 <- brm(y ~ gp(x2), dat, chains = 2) +summary(fit1) +me1 <- conditional_effects(fit1, ndraws = 200, spaghetti = TRUE) +plot(me1, ask = FALSE, points = TRUE) + +# fit a more complicated GP model +fit2 <- brm(y ~ gp(x0) + x1 + gp(x2) + x3, dat, chains = 2) +summary(fit2) +me2 <- conditional_effects(fit2, ndraws = 200, spaghetti = TRUE) +plot(me2, ask = FALSE, points = TRUE) + +# fit a multivariate GP model +fit3 <- brm(y ~ gp(x1, x2), dat, chains = 2) +summary(fit3) +me3 <- conditional_effects(fit3, ndraws = 200, spaghetti = TRUE) +plot(me3, ask = FALSE, points = TRUE) + +# compare model fit +LOO(fit1, fit2, fit3) + +# simulate data with a factor covariate +dat2 <- mgcv::gamSim(4, n = 90, scale = 2) + +# fit separate gaussian processes for different levels of 'fac' +fit4 <- brm(y ~ gp(x2, by = fac), dat2, chains = 2) +summary(fit4) +plot(conditional_effects(fit4), points = TRUE) +} + +} +\seealso{ +\code{\link{brmsformula}} +} diff -Nru r-cran-brms-2.16.3/man/gr.Rd r-cran-brms-2.17.0/man/gr.Rd --- r-cran-brms-2.16.3/man/gr.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/gr.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,59 +1,59 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-re.R -\name{gr} -\alias{gr} -\title{Set up basic grouping terms in \pkg{brms}} -\usage{ -gr(..., by = NULL, cor = TRUE, id = NA, cov = NULL, dist = "gaussian") -} -\arguments{ -\item{...}{One or more terms containing grouping factors.} - -\item{by}{An optional factor variable, specifying sub-populations of the -groups. For each level of the \code{by} variable, a separate -variance-covariance matrix will be fitted. Levels of the grouping factor -must be nested in levels of the \code{by} variable.} - -\item{cor}{Logical. If \code{TRUE} (the default), group-level terms will be -modelled as correlated.} - -\item{id}{Optional character string. All group-level terms across the model -with the same \code{id} will be modeled as correlated (if \code{cor} is -\code{TRUE}). See \code{\link{brmsformula}} for more details.} - -\item{cov}{An optional matrix which is proportional to the withon-group -covariance matrix of the group-level effects. All levels of the grouping -factor should appear as rownames of the corresponding matrix. This argument -can be used, among others, to model pedigrees and phylogenetic effects. See -\code{vignette("brms_phylogenetics")} for more details. By default, levels -of the same grouping factor are modeled as independent of each other.} - -\item{dist}{Name of the distribution of the group-level effects. -Currently \code{"gaussian"} is the only option.} -} -\description{ -Function used to set up a basic grouping term in \pkg{brms}. -The function does not evaluate its arguments -- -it exists purely to help set up a model with grouping terms. -\code{gr} is called implicitly inside the package -and there is usually no need to call it directly. -} -\examples{ -\dontrun{ -# model using basic lme4-style formula -fit1 <- brm(count ~ Trt + (1|patient), data = epilepsy) -summary(fit1) - -# equivalent model using 'gr' which is called anyway internally -fit2 <- brm(count ~ Trt + (1|gr(patient)), data = epilepsy) -summary(fit2) - -# include Trt as a by variable -fit3 <- brm(count ~ Trt + (1|gr(patient, by = Trt)), data = epilepsy) -summary(fit3) -} - -} -\seealso{ -\code{\link{brmsformula}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-re.R +\name{gr} +\alias{gr} +\title{Set up basic grouping terms in \pkg{brms}} +\usage{ +gr(..., by = NULL, cor = TRUE, id = NA, cov = NULL, dist = "gaussian") +} +\arguments{ +\item{...}{One or more terms containing grouping factors.} + +\item{by}{An optional factor variable, specifying sub-populations of the +groups. For each level of the \code{by} variable, a separate +variance-covariance matrix will be fitted. Levels of the grouping factor +must be nested in levels of the \code{by} variable.} + +\item{cor}{Logical. If \code{TRUE} (the default), group-level terms will be +modelled as correlated.} + +\item{id}{Optional character string. All group-level terms across the model +with the same \code{id} will be modeled as correlated (if \code{cor} is +\code{TRUE}). See \code{\link{brmsformula}} for more details.} + +\item{cov}{An optional matrix which is proportional to the withon-group +covariance matrix of the group-level effects. All levels of the grouping +factor should appear as rownames of the corresponding matrix. This argument +can be used, among others, to model pedigrees and phylogenetic effects. See +\code{vignette("brms_phylogenetics")} for more details. By default, levels +of the same grouping factor are modeled as independent of each other.} + +\item{dist}{Name of the distribution of the group-level effects. +Currently \code{"gaussian"} is the only option.} +} +\description{ +Function used to set up a basic grouping term in \pkg{brms}. +The function does not evaluate its arguments -- +it exists purely to help set up a model with grouping terms. +\code{gr} is called implicitly inside the package +and there is usually no need to call it directly. +} +\examples{ +\dontrun{ +# model using basic lme4-style formula +fit1 <- brm(count ~ Trt + (1|patient), data = epilepsy) +summary(fit1) + +# equivalent model using 'gr' which is called anyway internally +fit2 <- brm(count ~ Trt + (1|gr(patient)), data = epilepsy) +summary(fit2) + +# include Trt as a by variable +fit3 <- brm(count ~ Trt + (1|gr(patient, by = Trt)), data = epilepsy) +summary(fit3) +} + +} +\seealso{ +\code{\link{brmsformula}} +} diff -Nru r-cran-brms-2.16.3/man/horseshoe.Rd r-cran-brms-2.17.0/man/horseshoe.Rd --- r-cran-brms-2.16.3/man/horseshoe.Rd 2021-05-16 19:09:11.000000000 +0000 +++ r-cran-brms-2.17.0/man/horseshoe.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,119 +1,119 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/priors.R -\name{horseshoe} -\alias{horseshoe} -\title{Regularized horseshoe priors in \pkg{brms}} -\usage{ -horseshoe( - df = 1, - scale_global = 1, - df_global = 1, - scale_slab = 2, - df_slab = 4, - par_ratio = NULL, - autoscale = TRUE -) -} -\arguments{ -\item{df}{Degrees of freedom of student-t prior of the -local shrinkage parameters. Defaults to \code{1}.} - -\item{scale_global}{Scale of the student-t prior of the global shrinkage -parameter. Defaults to \code{1}. -In linear models, \code{scale_global} will internally be -multiplied by the residual standard deviation parameter \code{sigma}.} - -\item{df_global}{Degrees of freedom of student-t prior of the -global shrinkage parameter. Defaults to \code{1}. If \code{df_global} -is greater \code{1}, the shape of the prior will no longer resemble -a horseshoe and it may be more appropriately called an hierarchical -shrinkage prior in this case.} - -\item{scale_slab}{Scale of the student-t prior of the regularization -parameter. Defaults to \code{2}. The original unregularized horseshoe -prior is obtained by setting \code{scale_slab} to infinite, which -we can approximate in practice by setting it to a very large real value.} - -\item{df_slab}{Degrees of freedom of the student-t prior of -the regularization parameter. Defaults to \code{4}.} - -\item{par_ratio}{Ratio of the expected number of non-zero coefficients -to the expected number of zero coefficients. If specified, -\code{scale_global} is ignored and internally computed as -\code{par_ratio / sqrt(N)}, where \code{N} is the total number -of observations in the data.} - -\item{autoscale}{Logical; indicating whether the horseshoe -prior should be scaled using the residual standard deviation -\code{sigma} if possible and sensible (defaults to \code{TRUE}). -Autoscaling is not applied for distributional parameters or -when the model does not contain the parameter \code{sigma}.} -} -\value{ -A character string obtained by \code{match.call()} with - additional arguments. -} -\description{ -Function used to set up regularized horseshoe priors and related -hierarchical shrinkage priors for population-level effects in \pkg{brms}. The -function does not evaluate its arguments -- it exists purely to help set up -the model. -} -\details{ -The horseshoe prior is a special shrinkage prior initially proposed by - Carvalho et al. (2009). - It is symmetric around zero with fat tails and an infinitely large spike - at zero. This makes it ideal for sparse models that have - many regression coefficients, although only a minority of them is non-zero. - The horseshoe prior can be applied on all population-level effects at once - (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. - The \code{1} implies that the student-t prior of the local shrinkage - parameters has 1 degrees of freedom. This may, however, lead to an - increased number of divergent transition in \pkg{Stan}. - Accordingly, increasing the degrees of freedom to slightly higher values - (e.g., \code{3}) may often be a better option, although the prior - no longer resembles a horseshoe in this case. - Further, the scale of the global shrinkage parameter plays an important role - in amount of shrinkage applied. It defaults to \code{1}, - but this may result in too few shrinkage (Piironen & Vehtari, 2016). - It is thus possible to change the scale using argument \code{scale_global} - of the horseshoe prior, for instance \code{horseshoe(1, scale_global = 0.5)}. - In linear models, \code{scale_global} will internally be multiplied by the - residual standard deviation parameter \code{sigma}. See Piironen and - Vehtari (2016) for recommendations how to properly set the global scale. - The degrees of freedom of the global shrinkage prior may also be - adjusted via argument \code{df_global}. - Piironen and Vehtari (2017) recommend to specifying the ratio of the - expected number of non-zero coefficients to the expected number of zero - coefficients \code{par_ratio} rather than \code{scale_global} directly. - As proposed by Piironen and Vehtari (2017), an additional regularization - is applied that only affects non-zero coefficients. The amount of - regularization can be controlled via \code{scale_slab} and \code{df_slab}. - To make sure that shrinkage can equally affect all coefficients, - predictors should be one the same scale. - Generally, models with horseshoe priors a more likely than other models - to have divergent transitions so that increasing \code{adapt_delta} - from \code{0.8} to values closer to \code{1} will often be necessary. - See the documentation of \code{\link{brm}} for instructions - on how to increase \code{adapt_delta}. -} -\examples{ -set_prior(horseshoe(df = 3, par_ratio = 0.1)) - -} -\references{ -Carvalho, C. M., Polson, N. G., & Scott, J. G. (2009). - Handling sparsity via the horseshoe. - In International Conference on Artificial Intelligence and Statistics (pp. 73-80). - -Piironen J. & Vehtari A. (2016). On the Hyperprior Choice for the Global - Shrinkage Parameter in the Horseshoe Prior. - \url{https://arxiv.org/pdf/1610.05559v1.pdf} - -Piironen, J., and Vehtari, A. (2017). Sparsity information and regularization - in the horseshoe and other shrinkage priors. - \url{https://arxiv.org/abs/1707.01694} -} -\seealso{ -\code{\link{set_prior}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/priors.R +\name{horseshoe} +\alias{horseshoe} +\title{Regularized horseshoe priors in \pkg{brms}} +\usage{ +horseshoe( + df = 1, + scale_global = 1, + df_global = 1, + scale_slab = 2, + df_slab = 4, + par_ratio = NULL, + autoscale = TRUE +) +} +\arguments{ +\item{df}{Degrees of freedom of student-t prior of the +local shrinkage parameters. Defaults to \code{1}.} + +\item{scale_global}{Scale of the student-t prior of the global shrinkage +parameter. Defaults to \code{1}. +In linear models, \code{scale_global} will internally be +multiplied by the residual standard deviation parameter \code{sigma}.} + +\item{df_global}{Degrees of freedom of student-t prior of the +global shrinkage parameter. Defaults to \code{1}. If \code{df_global} +is greater \code{1}, the shape of the prior will no longer resemble +a horseshoe and it may be more appropriately called an hierarchical +shrinkage prior in this case.} + +\item{scale_slab}{Scale of the student-t prior of the regularization +parameter. Defaults to \code{2}. The original unregularized horseshoe +prior is obtained by setting \code{scale_slab} to infinite, which +we can approximate in practice by setting it to a very large real value.} + +\item{df_slab}{Degrees of freedom of the student-t prior of +the regularization parameter. Defaults to \code{4}.} + +\item{par_ratio}{Ratio of the expected number of non-zero coefficients +to the expected number of zero coefficients. If specified, +\code{scale_global} is ignored and internally computed as +\code{par_ratio / sqrt(N)}, where \code{N} is the total number +of observations in the data.} + +\item{autoscale}{Logical; indicating whether the horseshoe +prior should be scaled using the residual standard deviation +\code{sigma} if possible and sensible (defaults to \code{TRUE}). +Autoscaling is not applied for distributional parameters or +when the model does not contain the parameter \code{sigma}.} +} +\value{ +A character string obtained by \code{match.call()} with + additional arguments. +} +\description{ +Function used to set up regularized horseshoe priors and related +hierarchical shrinkage priors for population-level effects in \pkg{brms}. The +function does not evaluate its arguments -- it exists purely to help set up +the model. +} +\details{ +The horseshoe prior is a special shrinkage prior initially proposed by + Carvalho et al. (2009). + It is symmetric around zero with fat tails and an infinitely large spike + at zero. This makes it ideal for sparse models that have + many regression coefficients, although only a minority of them is non-zero. + The horseshoe prior can be applied on all population-level effects at once + (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. + The \code{1} implies that the student-t prior of the local shrinkage + parameters has 1 degrees of freedom. This may, however, lead to an + increased number of divergent transition in \pkg{Stan}. + Accordingly, increasing the degrees of freedom to slightly higher values + (e.g., \code{3}) may often be a better option, although the prior + no longer resembles a horseshoe in this case. + Further, the scale of the global shrinkage parameter plays an important role + in amount of shrinkage applied. It defaults to \code{1}, + but this may result in too few shrinkage (Piironen & Vehtari, 2016). + It is thus possible to change the scale using argument \code{scale_global} + of the horseshoe prior, for instance \code{horseshoe(1, scale_global = 0.5)}. + In linear models, \code{scale_global} will internally be multiplied by the + residual standard deviation parameter \code{sigma}. See Piironen and + Vehtari (2016) for recommendations how to properly set the global scale. + The degrees of freedom of the global shrinkage prior may also be + adjusted via argument \code{df_global}. + Piironen and Vehtari (2017) recommend to specifying the ratio of the + expected number of non-zero coefficients to the expected number of zero + coefficients \code{par_ratio} rather than \code{scale_global} directly. + As proposed by Piironen and Vehtari (2017), an additional regularization + is applied that only affects non-zero coefficients. The amount of + regularization can be controlled via \code{scale_slab} and \code{df_slab}. + To make sure that shrinkage can equally affect all coefficients, + predictors should be one the same scale. + Generally, models with horseshoe priors a more likely than other models + to have divergent transitions so that increasing \code{adapt_delta} + from \code{0.8} to values closer to \code{1} will often be necessary. + See the documentation of \code{\link{brm}} for instructions + on how to increase \code{adapt_delta}. +} +\examples{ +set_prior(horseshoe(df = 3, par_ratio = 0.1)) + +} +\references{ +Carvalho, C. M., Polson, N. G., & Scott, J. G. (2009). + Handling sparsity via the horseshoe. + In International Conference on Artificial Intelligence and Statistics (pp. 73-80). + +Piironen J. & Vehtari A. (2016). On the Hyperprior Choice for the Global + Shrinkage Parameter in the Horseshoe Prior. + \url{https://arxiv.org/pdf/1610.05559v1.pdf} + +Piironen, J., and Vehtari, A. (2017). Sparsity information and regularization + in the horseshoe and other shrinkage priors. + \url{https://arxiv.org/abs/1707.01694} +} +\seealso{ +\code{\link{set_prior}} +} diff -Nru r-cran-brms-2.16.3/man/Hurdle.Rd r-cran-brms-2.17.0/man/Hurdle.Rd --- r-cran-brms-2.16.3/man/Hurdle.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/Hurdle.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,60 +1,60 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{Hurdle} -\alias{Hurdle} -\alias{dhurdle_poisson} -\alias{phurdle_poisson} -\alias{dhurdle_negbinomial} -\alias{phurdle_negbinomial} -\alias{dhurdle_gamma} -\alias{phurdle_gamma} -\alias{dhurdle_lognormal} -\alias{phurdle_lognormal} -\title{Hurdle Distributions} -\usage{ -dhurdle_poisson(x, lambda, hu, log = FALSE) - -phurdle_poisson(q, lambda, hu, lower.tail = TRUE, log.p = FALSE) - -dhurdle_negbinomial(x, mu, shape, hu, log = FALSE) - -phurdle_negbinomial(q, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) - -dhurdle_gamma(x, shape, scale, hu, log = FALSE) - -phurdle_gamma(q, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) - -dhurdle_lognormal(x, mu, sigma, hu, log = FALSE) - -phurdle_lognormal(q, mu, sigma, hu, lower.tail = TRUE, log.p = FALSE) -} -\arguments{ -\item{x}{Vector of quantiles.} - -\item{hu}{hurdle probability} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{q}{Vector of quantiles.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{mu, lambda}{location parameter} - -\item{shape}{shape parameter} - -\item{sigma, scale}{scale parameter} -} -\description{ -Density and distribution functions for hurdle distributions. -} -\details{ -The density of a hurdle distribution can be specified as follows. -If \eqn{x = 0} set \eqn{f(x) = \theta}. Else set -\eqn{f(x) = (1 - \theta) * g(x) / (1 - G(0))} -where \eqn{g(x)} and \eqn{G(x)} are the density and distribution -function of the non-hurdle part, respectively. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{Hurdle} +\alias{Hurdle} +\alias{dhurdle_poisson} +\alias{phurdle_poisson} +\alias{dhurdle_negbinomial} +\alias{phurdle_negbinomial} +\alias{dhurdle_gamma} +\alias{phurdle_gamma} +\alias{dhurdle_lognormal} +\alias{phurdle_lognormal} +\title{Hurdle Distributions} +\usage{ +dhurdle_poisson(x, lambda, hu, log = FALSE) + +phurdle_poisson(q, lambda, hu, lower.tail = TRUE, log.p = FALSE) + +dhurdle_negbinomial(x, mu, shape, hu, log = FALSE) + +phurdle_negbinomial(q, mu, shape, hu, lower.tail = TRUE, log.p = FALSE) + +dhurdle_gamma(x, shape, scale, hu, log = FALSE) + +phurdle_gamma(q, shape, scale, hu, lower.tail = TRUE, log.p = FALSE) + +dhurdle_lognormal(x, mu, sigma, hu, log = FALSE) + +phurdle_lognormal(q, mu, sigma, hu, lower.tail = TRUE, log.p = FALSE) +} +\arguments{ +\item{x}{Vector of quantiles.} + +\item{hu}{hurdle probability} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{q}{Vector of quantiles.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{mu, lambda}{location parameter} + +\item{shape}{shape parameter} + +\item{sigma, scale}{scale parameter} +} +\description{ +Density and distribution functions for hurdle distributions. +} +\details{ +The density of a hurdle distribution can be specified as follows. +If \eqn{x = 0} set \eqn{f(x) = \theta}. Else set +\eqn{f(x) = (1 - \theta) * g(x) / (1 - G(0))} +where \eqn{g(x)} and \eqn{G(x)} are the density and distribution +function of the non-hurdle part, respectively. +} diff -Nru r-cran-brms-2.16.3/man/hypothesis.brmsfit.Rd r-cran-brms-2.17.0/man/hypothesis.brmsfit.Rd --- r-cran-brms-2.16.3/man/hypothesis.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/hypothesis.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,166 +1,166 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/hypothesis.R -\name{hypothesis.brmsfit} -\alias{hypothesis.brmsfit} -\alias{hypothesis} -\alias{hypothesis.default} -\title{Non-Linear Hypothesis Testing} -\usage{ -\method{hypothesis}{brmsfit}( - x, - hypothesis, - class = "b", - group = "", - scope = c("standard", "ranef", "coef"), - alpha = 0.05, - robust = FALSE, - seed = NULL, - ... -) - -hypothesis(x, ...) - -\method{hypothesis}{default}(x, hypothesis, alpha = 0.05, robust = FALSE, ...) -} -\arguments{ -\item{x}{An \code{R} object. If it is no \code{brmsfit} object, -it must be coercible to a \code{data.frame}. -In the latter case, the variables used in the \code{hypothesis} argument -need to correspond to column names of \code{x}, while the rows -are treated as representing posterior draws of the variables.} - -\item{hypothesis}{A character vector specifying one or more -non-linear hypothesis concerning parameters of the model.} - -\item{class}{A string specifying the class of parameters being tested. -Default is "b" for population-level effects. -Other typical options are "sd" or "cor". -If \code{class = NULL}, all parameters can be tested -against each other, but have to be specified with their full name -(see also \code{\link[brms:draws-index-brms]{variables}})} - -\item{group}{Name of a grouping factor to evaluate only -group-level effects parameters related to this grouping factor.} - -\item{scope}{Indicates where to look for the variables specified in -\code{hypothesis}. If \code{"standard"}, use the full parameter names -(subject to the restriction given by \code{class} and \code{group}). -If \code{"coef"} or \code{"ranef"}, compute the hypothesis for all levels -of the grouping factor given in \code{"group"}, based on the -output of \code{\link{coef.brmsfit}} and \code{\link{ranef.brmsfit}}, -respectively.} - -\item{alpha}{The alpha-level of the tests (default is 0.05; -see 'Details' for more information).} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead.} - -\item{seed}{A single numeric value passed to \code{\link{set.seed}} -to make results reproducible.} - -\item{...}{Currently ignored.} -} -\value{ -A \code{\link{brmshypothesis}} object. -} -\description{ -Perform non-linear hypothesis testing for all model parameters. -} -\details{ -Among others, \code{hypothesis} computes an evidence ratio - (\code{Evid.Ratio}) for each hypothesis. For a one-sided hypothesis, this - is just the posterior probability (\code{Post.Prob}) under the hypothesis - against its alternative. That is, when the hypothesis is of the form - \code{a > b}, the evidence ratio is the ratio of the posterior probability - of \code{a > b} and the posterior probability of \code{a < b}. In this - example, values greater than one indicate that the evidence in favor of - \code{a > b} is larger than evidence in favor of \code{a < b}. For an - two-sided (point) hypothesis, the evidence ratio is a Bayes factor between - the hypothesis and its alternative computed via the Savage-Dickey density - ratio method. That is the posterior density at the point of interest - divided by the prior density at that point. Values greater than one - indicate that evidence in favor of the point hypothesis has increased after - seeing the data. In order to calculate this Bayes factor, all parameters - related to the hypothesis must have proper priors and argument - \code{sample_prior} of function \code{brm} must be set to \code{"yes"}. - Otherwise \code{Evid.Ratio} (and \code{Post.Prob}) will be \code{NA}. - Please note that, for technical reasons, we cannot sample from priors of - certain parameters classes. Most notably, these include overall intercept - parameters (prior class \code{"Intercept"}) as well as group-level - coefficients. When interpreting Bayes factors, make sure that your priors - are reasonable and carefully chosen, as the result will depend heavily on - the priors. In particular, avoid using default priors. - - The \code{Evid.Ratio} may sometimes be \code{0} or \code{Inf} implying very - small or large evidence, respectively, in favor of the tested hypothesis. - For one-sided hypotheses pairs, this basically means that all posterior - draws are on the same side of the value dividing the two hypotheses. In - that sense, instead of \code{0} or \code{Inf,} you may rather read it as - \code{Evid.Ratio} smaller \code{1 / S} or greater \code{S}, respectively, - where \code{S} denotes the number of posterior draws used in the - computations. - - The argument \code{alpha} specifies the size of the credible interval - (i.e., Bayesian confidence interval). For instance, if we tested a - two-sided hypothesis and set \code{alpha = 0.05} (5\%) an, the credible - interval will contain \code{1 - alpha = 0.95} (95\%) of the posterior - values. Hence, \code{alpha * 100}\% of the posterior values will - lie outside of the credible interval. Although this allows testing of - hypotheses in a similar manner as in the frequentist null-hypothesis - testing framework, we strongly argue against using arbitrary cutoffs (e.g., - \code{p < .05}) to determine the 'existence' of an effect. -} -\examples{ -\dontrun{ -## define priors -prior <- c(set_prior("normal(0,2)", class = "b"), - set_prior("student_t(10,0,1)", class = "sigma"), - set_prior("student_t(10,0,1)", class = "sd")) - -## fit a linear mixed effects models -fit <- brm(time ~ age + sex + disease + (1 + age|patient), - data = kidney, family = lognormal(), - prior = prior, sample_prior = "yes", - control = list(adapt_delta = 0.95)) - -## perform two-sided hypothesis testing -(hyp1 <- hypothesis(fit, "sexfemale = age + diseasePKD")) -plot(hyp1) -hypothesis(fit, "exp(age) - 3 = 0", alpha = 0.01) - -## perform one-sided hypothesis testing -hypothesis(fit, "diseasePKD + diseaseGN - 3 < 0") - -hypothesis(fit, "age < Intercept", - class = "sd", group = "patient") - -## test the amount of random intercept variance on all variance -h <- paste("sd_patient__Intercept^2 / (sd_patient__Intercept^2 +", - "sd_patient__age^2 + sigma^2) = 0") -(hyp2 <- hypothesis(fit, h, class = NULL)) -plot(hyp2) - -## test more than one hypothesis at once -h <- c("diseaseGN = diseaseAN", "2 * diseaseGN - diseasePKD = 0") -(hyp3 <- hypothesis(fit, h)) -plot(hyp3, ignore_prior = TRUE) - -## compute hypotheses for all levels of a grouping factor -hypothesis(fit, "age = 0", scope = "coef", group = "patient") - -## use the default method -dat <- as.data.frame(fit) -str(dat) -hypothesis(dat, "b_age > 0") -} - -} -\seealso{ -\code{\link{brmshypothesis}} -} -\author{ -Paul-Christian Buerkner \email{paul.buerkner@gmail.com} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hypothesis.R +\name{hypothesis.brmsfit} +\alias{hypothesis.brmsfit} +\alias{hypothesis} +\alias{hypothesis.default} +\title{Non-Linear Hypothesis Testing} +\usage{ +\method{hypothesis}{brmsfit}( + x, + hypothesis, + class = "b", + group = "", + scope = c("standard", "ranef", "coef"), + alpha = 0.05, + robust = FALSE, + seed = NULL, + ... +) + +hypothesis(x, ...) + +\method{hypothesis}{default}(x, hypothesis, alpha = 0.05, robust = FALSE, ...) +} +\arguments{ +\item{x}{An \code{R} object. If it is no \code{brmsfit} object, +it must be coercible to a \code{data.frame}. +In the latter case, the variables used in the \code{hypothesis} argument +need to correspond to column names of \code{x}, while the rows +are treated as representing posterior draws of the variables.} + +\item{hypothesis}{A character vector specifying one or more +non-linear hypothesis concerning parameters of the model.} + +\item{class}{A string specifying the class of parameters being tested. +Default is "b" for population-level effects. +Other typical options are "sd" or "cor". +If \code{class = NULL}, all parameters can be tested +against each other, but have to be specified with their full name +(see also \code{\link[brms:draws-index-brms]{variables}})} + +\item{group}{Name of a grouping factor to evaluate only +group-level effects parameters related to this grouping factor.} + +\item{scope}{Indicates where to look for the variables specified in +\code{hypothesis}. If \code{"standard"}, use the full parameter names +(subject to the restriction given by \code{class} and \code{group}). +If \code{"coef"} or \code{"ranef"}, compute the hypothesis for all levels +of the grouping factor given in \code{"group"}, based on the +output of \code{\link{coef.brmsfit}} and \code{\link{ranef.brmsfit}}, +respectively.} + +\item{alpha}{The alpha-level of the tests (default is 0.05; +see 'Details' for more information).} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead.} + +\item{seed}{A single numeric value passed to \code{\link{set.seed}} +to make results reproducible.} + +\item{...}{Currently ignored.} +} +\value{ +A \code{\link{brmshypothesis}} object. +} +\description{ +Perform non-linear hypothesis testing for all model parameters. +} +\details{ +Among others, \code{hypothesis} computes an evidence ratio + (\code{Evid.Ratio}) for each hypothesis. For a one-sided hypothesis, this + is just the posterior probability (\code{Post.Prob}) under the hypothesis + against its alternative. That is, when the hypothesis is of the form + \code{a > b}, the evidence ratio is the ratio of the posterior probability + of \code{a > b} and the posterior probability of \code{a < b}. In this + example, values greater than one indicate that the evidence in favor of + \code{a > b} is larger than evidence in favor of \code{a < b}. For an + two-sided (point) hypothesis, the evidence ratio is a Bayes factor between + the hypothesis and its alternative computed via the Savage-Dickey density + ratio method. That is the posterior density at the point of interest + divided by the prior density at that point. Values greater than one + indicate that evidence in favor of the point hypothesis has increased after + seeing the data. In order to calculate this Bayes factor, all parameters + related to the hypothesis must have proper priors and argument + \code{sample_prior} of function \code{brm} must be set to \code{"yes"}. + Otherwise \code{Evid.Ratio} (and \code{Post.Prob}) will be \code{NA}. + Please note that, for technical reasons, we cannot sample from priors of + certain parameters classes. Most notably, these include overall intercept + parameters (prior class \code{"Intercept"}) as well as group-level + coefficients. When interpreting Bayes factors, make sure that your priors + are reasonable and carefully chosen, as the result will depend heavily on + the priors. In particular, avoid using default priors. + + The \code{Evid.Ratio} may sometimes be \code{0} or \code{Inf} implying very + small or large evidence, respectively, in favor of the tested hypothesis. + For one-sided hypotheses pairs, this basically means that all posterior + draws are on the same side of the value dividing the two hypotheses. In + that sense, instead of \code{0} or \code{Inf,} you may rather read it as + \code{Evid.Ratio} smaller \code{1 / S} or greater \code{S}, respectively, + where \code{S} denotes the number of posterior draws used in the + computations. + + The argument \code{alpha} specifies the size of the credible interval + (i.e., Bayesian confidence interval). For instance, if we tested a + two-sided hypothesis and set \code{alpha = 0.05} (5\%) an, the credible + interval will contain \code{1 - alpha = 0.95} (95\%) of the posterior + values. Hence, \code{alpha * 100}\% of the posterior values will + lie outside of the credible interval. Although this allows testing of + hypotheses in a similar manner as in the frequentist null-hypothesis + testing framework, we strongly argue against using arbitrary cutoffs (e.g., + \code{p < .05}) to determine the 'existence' of an effect. +} +\examples{ +\dontrun{ +## define priors +prior <- c(set_prior("normal(0,2)", class = "b"), + set_prior("student_t(10,0,1)", class = "sigma"), + set_prior("student_t(10,0,1)", class = "sd")) + +## fit a linear mixed effects models +fit <- brm(time ~ age + sex + disease + (1 + age|patient), + data = kidney, family = lognormal(), + prior = prior, sample_prior = "yes", + control = list(adapt_delta = 0.95)) + +## perform two-sided hypothesis testing +(hyp1 <- hypothesis(fit, "sexfemale = age + diseasePKD")) +plot(hyp1) +hypothesis(fit, "exp(age) - 3 = 0", alpha = 0.01) + +## perform one-sided hypothesis testing +hypothesis(fit, "diseasePKD + diseaseGN - 3 < 0") + +hypothesis(fit, "age < Intercept", + class = "sd", group = "patient") + +## test the amount of random intercept variance on all variance +h <- paste("sd_patient__Intercept^2 / (sd_patient__Intercept^2 +", + "sd_patient__age^2 + sigma^2) = 0") +(hyp2 <- hypothesis(fit, h, class = NULL)) +plot(hyp2) + +## test more than one hypothesis at once +h <- c("diseaseGN = diseaseAN", "2 * diseaseGN - diseasePKD = 0") +(hyp3 <- hypothesis(fit, h)) +plot(hyp3, ignore_prior = TRUE) + +## compute hypotheses for all levels of a grouping factor +hypothesis(fit, "age = 0", scope = "coef", group = "patient") + +## use the default method +dat <- as.data.frame(fit) +str(dat) +hypothesis(dat, "b_age > 0") +} + +} +\seealso{ +\code{\link{brmshypothesis}} +} +\author{ +Paul-Christian Buerkner \email{paul.buerkner@gmail.com} +} diff -Nru r-cran-brms-2.16.3/man/inhaler.Rd r-cran-brms-2.17.0/man/inhaler.Rd --- r-cran-brms-2.16.3/man/inhaler.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/inhaler.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,54 +1,54 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/datasets.R -\docType{data} -\name{inhaler} -\alias{inhaler} -\title{Clarity of inhaler instructions} -\format{ -A data frame of 572 observations containing - information on the following 5 variables. -\describe{ - \item{subject}{The subject number} - \item{rating}{The rating of the inhaler instructions - on a scale ranging from 1 to 4} - \item{treat}{A contrast to indicate which of - the two inhaler devices was used} - \item{period}{A contrast to indicate the time of administration} - \item{carry}{A contrast to indicate possible carry over effects} -} -} -\source{ -Ezzet, F., & Whitehead, J. (1991). - A random effects model for ordinal responses from a crossover trial. - \emph{Statistics in Medicine}, 10(6), 901-907. -} -\usage{ -inhaler -} -\description{ -Ezzet and Whitehead (1991) analyze data from a two-treatment, - two-period crossover trial to compare 2 inhalation devices for - delivering the drug salbutamol in 286 asthma patients. - Patients were asked to rate the clarity of leaflet instructions - accompanying each device, using a 4-point ordinal scale. -} -\examples{ -\dontrun{ -## ordinal regression with family "sratio" -fit1 <- brm(rating ~ treat + period + carry, - data = inhaler, family = sratio(), - prior = set_prior("normal(0,5)")) -summary(fit1) -plot(fit1) - -## ordinal regression with family "cumulative" -## and random intercept over subjects -fit2 <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = cumulative(), - prior = set_prior("normal(0,5)")) -summary(fit2) -plot(fit2) -} - -} -\keyword{datasets} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasets.R +\docType{data} +\name{inhaler} +\alias{inhaler} +\title{Clarity of inhaler instructions} +\format{ +A data frame of 572 observations containing + information on the following 5 variables. +\describe{ + \item{subject}{The subject number} + \item{rating}{The rating of the inhaler instructions + on a scale ranging from 1 to 4} + \item{treat}{A contrast to indicate which of + the two inhaler devices was used} + \item{period}{A contrast to indicate the time of administration} + \item{carry}{A contrast to indicate possible carry over effects} +} +} +\source{ +Ezzet, F., & Whitehead, J. (1991). + A random effects model for ordinal responses from a crossover trial. + \emph{Statistics in Medicine}, 10(6), 901-907. +} +\usage{ +inhaler +} +\description{ +Ezzet and Whitehead (1991) analyze data from a two-treatment, + two-period crossover trial to compare 2 inhalation devices for + delivering the drug salbutamol in 286 asthma patients. + Patients were asked to rate the clarity of leaflet instructions + accompanying each device, using a 4-point ordinal scale. +} +\examples{ +\dontrun{ +## ordinal regression with family "sratio" +fit1 <- brm(rating ~ treat + period + carry, + data = inhaler, family = sratio(), + prior = set_prior("normal(0,5)")) +summary(fit1) +plot(fit1) + +## ordinal regression with family "cumulative" +## and random intercept over subjects +fit2 <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = cumulative(), + prior = set_prior("normal(0,5)")) +summary(fit2) +plot(fit2) +} + +} +\keyword{datasets} diff -Nru r-cran-brms-2.16.3/man/InvGaussian.Rd r-cran-brms-2.17.0/man/InvGaussian.Rd --- r-cran-brms-2.16.3/man/InvGaussian.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/InvGaussian.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,40 +1,40 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{InvGaussian} -\alias{InvGaussian} -\alias{dinv_gaussian} -\alias{pinv_gaussian} -\alias{rinv_gaussian} -\title{The Inverse Gaussian Distribution} -\usage{ -dinv_gaussian(x, mu = 1, shape = 1, log = FALSE) - -pinv_gaussian(q, mu = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) - -rinv_gaussian(n, mu = 1, shape = 1) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{mu}{Vector of locations.} - -\item{shape}{Vector of shapes.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, and random generation -for the inverse Gaussian distribution with location \code{mu}, -and shape \code{shape}. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{InvGaussian} +\alias{InvGaussian} +\alias{dinv_gaussian} +\alias{pinv_gaussian} +\alias{rinv_gaussian} +\title{The Inverse Gaussian Distribution} +\usage{ +dinv_gaussian(x, mu = 1, shape = 1, log = FALSE) + +pinv_gaussian(q, mu = 1, shape = 1, lower.tail = TRUE, log.p = FALSE) + +rinv_gaussian(n, mu = 1, shape = 1) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{mu}{Vector of locations.} + +\item{shape}{Vector of shapes.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, and random generation +for the inverse Gaussian distribution with location \code{mu}, +and shape \code{shape}. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} diff -Nru r-cran-brms-2.16.3/man/is.brmsfit_multiple.Rd r-cran-brms-2.17.0/man/is.brmsfit_multiple.Rd --- r-cran-brms-2.16.3/man/is.brmsfit_multiple.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/is.brmsfit_multiple.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,14 +1,14 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-class.R -\name{is.brmsfit_multiple} -\alias{is.brmsfit_multiple} -\title{Checks if argument is a \code{brmsfit_multiple} object} -\usage{ -is.brmsfit_multiple(x) -} -\arguments{ -\item{x}{An \R object} -} -\description{ -Checks if argument is a \code{brmsfit_multiple} object -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-class.R +\name{is.brmsfit_multiple} +\alias{is.brmsfit_multiple} +\title{Checks if argument is a \code{brmsfit_multiple} object} +\usage{ +is.brmsfit_multiple(x) +} +\arguments{ +\item{x}{An \R object} +} +\description{ +Checks if argument is a \code{brmsfit_multiple} object +} diff -Nru r-cran-brms-2.16.3/man/is.brmsfit.Rd r-cran-brms-2.17.0/man/is.brmsfit.Rd --- r-cran-brms-2.16.3/man/is.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/is.brmsfit.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,14 +1,14 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-class.R -\name{is.brmsfit} -\alias{is.brmsfit} -\title{Checks if argument is a \code{brmsfit} object} -\usage{ -is.brmsfit(x) -} -\arguments{ -\item{x}{An \R object} -} -\description{ -Checks if argument is a \code{brmsfit} object -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-class.R +\name{is.brmsfit} +\alias{is.brmsfit} +\title{Checks if argument is a \code{brmsfit} object} +\usage{ +is.brmsfit(x) +} +\arguments{ +\item{x}{An \R object} +} +\description{ +Checks if argument is a \code{brmsfit} object +} diff -Nru r-cran-brms-2.16.3/man/is.brmsformula.Rd r-cran-brms-2.17.0/man/is.brmsformula.Rd --- r-cran-brms-2.16.3/man/is.brmsformula.Rd 2020-05-21 11:32:10.000000000 +0000 +++ r-cran-brms-2.17.0/man/is.brmsformula.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,14 +1,14 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsformula.R -\name{is.brmsformula} -\alias{is.brmsformula} -\title{Checks if argument is a \code{brmsformula} object} -\usage{ -is.brmsformula(x) -} -\arguments{ -\item{x}{An \R object} -} -\description{ -Checks if argument is a \code{brmsformula} object -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsformula.R +\name{is.brmsformula} +\alias{is.brmsformula} +\title{Checks if argument is a \code{brmsformula} object} +\usage{ +is.brmsformula(x) +} +\arguments{ +\item{x}{An \R object} +} +\description{ +Checks if argument is a \code{brmsformula} object +} diff -Nru r-cran-brms-2.16.3/man/is.brmsprior.Rd r-cran-brms-2.17.0/man/is.brmsprior.Rd --- r-cran-brms-2.16.3/man/is.brmsprior.Rd 2020-05-21 11:32:10.000000000 +0000 +++ r-cran-brms-2.17.0/man/is.brmsprior.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,14 +1,14 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/priors.R -\name{is.brmsprior} -\alias{is.brmsprior} -\title{Checks if argument is a \code{brmsprior} object} -\usage{ -is.brmsprior(x) -} -\arguments{ -\item{x}{An \R object} -} -\description{ -Checks if argument is a \code{brmsprior} object -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/priors.R +\name{is.brmsprior} +\alias{is.brmsprior} +\title{Checks if argument is a \code{brmsprior} object} +\usage{ +is.brmsprior(x) +} +\arguments{ +\item{x}{An \R object} +} +\description{ +Checks if argument is a \code{brmsprior} object +} diff -Nru r-cran-brms-2.16.3/man/is.brmsterms.Rd r-cran-brms-2.17.0/man/is.brmsterms.Rd --- r-cran-brms-2.16.3/man/is.brmsterms.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/is.brmsterms.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,17 +1,17 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsterms.R -\name{is.brmsterms} -\alias{is.brmsterms} -\title{Checks if argument is a \code{brmsterms} object} -\usage{ -is.brmsterms(x) -} -\arguments{ -\item{x}{An \R object} -} -\description{ -Checks if argument is a \code{brmsterms} object -} -\seealso{ -\code{\link[brms:brmsterms]{brmsterms}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsterms.R +\name{is.brmsterms} +\alias{is.brmsterms} +\title{Checks if argument is a \code{brmsterms} object} +\usage{ +is.brmsterms(x) +} +\arguments{ +\item{x}{An \R object} +} +\description{ +Checks if argument is a \code{brmsterms} object +} +\seealso{ +\code{\link[brms:brmsterms]{brmsterms}} +} diff -Nru r-cran-brms-2.16.3/man/is.cor_brms.Rd r-cran-brms-2.17.0/man/is.cor_brms.Rd --- r-cran-brms-2.16.3/man/is.cor_brms.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/is.cor_brms.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,30 +1,30 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/autocor.R -\name{is.cor_brms} -\alias{is.cor_brms} -\alias{is.cor_arma} -\alias{is.cor_cosy} -\alias{is.cor_sar} -\alias{is.cor_car} -\alias{is.cor_fixed} -\title{Check if argument is a correlation structure} -\usage{ -is.cor_brms(x) - -is.cor_arma(x) - -is.cor_cosy(x) - -is.cor_sar(x) - -is.cor_car(x) - -is.cor_fixed(x) -} -\arguments{ -\item{x}{An \R object.} -} -\description{ -Check if argument is one of the correlation structures -used in \pkg{brms}. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autocor.R +\name{is.cor_brms} +\alias{is.cor_brms} +\alias{is.cor_arma} +\alias{is.cor_cosy} +\alias{is.cor_sar} +\alias{is.cor_car} +\alias{is.cor_fixed} +\title{Check if argument is a correlation structure} +\usage{ +is.cor_brms(x) + +is.cor_arma(x) + +is.cor_cosy(x) + +is.cor_sar(x) + +is.cor_car(x) + +is.cor_fixed(x) +} +\arguments{ +\item{x}{An \R object.} +} +\description{ +Check if argument is one of the correlation structures +used in \pkg{brms}. +} diff -Nru r-cran-brms-2.16.3/man/is.mvbrmsformula.Rd r-cran-brms-2.17.0/man/is.mvbrmsformula.Rd --- r-cran-brms-2.16.3/man/is.mvbrmsformula.Rd 2020-05-21 11:32:10.000000000 +0000 +++ r-cran-brms-2.17.0/man/is.mvbrmsformula.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,14 +1,14 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsformula.R -\name{is.mvbrmsformula} -\alias{is.mvbrmsformula} -\title{Checks if argument is a \code{mvbrmsformula} object} -\usage{ -is.mvbrmsformula(x) -} -\arguments{ -\item{x}{An \R object} -} -\description{ -Checks if argument is a \code{mvbrmsformula} object -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsformula.R +\name{is.mvbrmsformula} +\alias{is.mvbrmsformula} +\title{Checks if argument is a \code{mvbrmsformula} object} +\usage{ +is.mvbrmsformula(x) +} +\arguments{ +\item{x}{An \R object} +} +\description{ +Checks if argument is a \code{mvbrmsformula} object +} diff -Nru r-cran-brms-2.16.3/man/is.mvbrmsterms.Rd r-cran-brms-2.17.0/man/is.mvbrmsterms.Rd --- r-cran-brms-2.16.3/man/is.mvbrmsterms.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/is.mvbrmsterms.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,17 +1,17 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsterms.R -\name{is.mvbrmsterms} -\alias{is.mvbrmsterms} -\title{Checks if argument is a \code{mvbrmsterms} object} -\usage{ -is.mvbrmsterms(x) -} -\arguments{ -\item{x}{An \R object} -} -\description{ -Checks if argument is a \code{mvbrmsterms} object -} -\seealso{ -\code{\link[brms:brmsterms]{brmsterms}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsterms.R +\name{is.mvbrmsterms} +\alias{is.mvbrmsterms} +\title{Checks if argument is a \code{mvbrmsterms} object} +\usage{ +is.mvbrmsterms(x) +} +\arguments{ +\item{x}{An \R object} +} +\description{ +Checks if argument is a \code{mvbrmsterms} object +} +\seealso{ +\code{\link[brms:brmsterms]{brmsterms}} +} diff -Nru r-cran-brms-2.16.3/man/kfold.brmsfit.Rd r-cran-brms-2.17.0/man/kfold.brmsfit.Rd --- r-cran-brms-2.16.3/man/kfold.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/kfold.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,140 +1,145 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/kfold.R -\name{kfold.brmsfit} -\alias{kfold.brmsfit} -\alias{kfold} -\title{K-Fold Cross-Validation} -\usage{ -\method{kfold}{brmsfit}( - x, - ..., - K = 10, - Ksub = NULL, - folds = NULL, - group = NULL, - exact_loo = NULL, - compare = TRUE, - resp = NULL, - model_names = NULL, - save_fits = FALSE -) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{K}{The number of subsets of equal (if possible) size -into which the data will be partitioned for performing -\eqn{K}-fold cross-validation. The model is refit \code{K} times, each time -leaving out one of the \code{K} subsets. If \code{K} is equal to the total -number of observations in the data then \eqn{K}-fold cross-validation is -equivalent to exact leave-one-out cross-validation.} - -\item{Ksub}{Optional number of subsets (of those subsets defined by \code{K}) -to be evaluated. If \code{NULL} (the default), \eqn{K}-fold cross-validation -will be performed on all subsets. If \code{Ksub} is a single integer, -\code{Ksub} subsets (out of all \code{K}) subsets will be randomly chosen. -If \code{Ksub} consists of multiple integers or a one-dimensional array -(created via \code{as.array}) potentially of length one, the corresponding -subsets will be used. This argument is primarily useful, if evaluation of -all subsets is infeasible for some reason.} - -\item{folds}{Determines how the subsets are being constructed. -Possible values are \code{NULL} (the default), \code{"stratified"}, -\code{"grouped"}, or \code{"loo"}. May also be a vector of length -equal to the number of observations in the data. Alters the way -\code{group} is handled. More information is provided in the 'Details' -section.} - -\item{group}{Optional name of a grouping variable or factor in the model. -What exactly is done with this variable depends on argument \code{folds}. -More information is provided in the 'Details' section.} - -\item{exact_loo}{Deprecated! Please use \code{folds = "loo"} instead.} - -\item{compare}{A flag indicating if the information criteria -of the models should be compared to each other -via \code{\link{loo_compare}}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} - -\item{save_fits}{If \code{TRUE}, a component \code{fits} is added to -the returned object to store the cross-validated \code{brmsfit} -objects and the indices of the omitted observations for each fold. -Defaults to \code{FALSE}.} -} -\value{ -\code{kfold} returns an object that has a similar structure as the - objects returned by the \code{loo} and \code{waic} methods and - can be used with the same post-processing functions. -} -\description{ -Perform exact K-fold cross-validation by refitting the model \eqn{K} -times each leaving out one-\eqn{K}th of the original data. -Folds can be run in parallel using the \pkg{future} package. -} -\details{ -The \code{kfold} function performs exact \eqn{K}-fold - cross-validation. First the data are partitioned into \eqn{K} folds - (i.e. subsets) of equal (or as close to equal as possible) size by default. - Then the model is refit \eqn{K} times, each time leaving out one of the - \code{K} subsets. If \eqn{K} is equal to the total number of observations - in the data then \eqn{K}-fold cross-validation is equivalent to exact - leave-one-out cross-validation (to which \code{loo} is an efficient - approximation). The \code{compare_ic} function is also compatible with - the objects returned by \code{kfold}. - - The subsets can be constructed in multiple different ways: - \itemize{ - \item If both \code{folds} and \code{group} are \code{NULL}, the subsets - are randomly chosen so that they have equal (or as close to equal as - possible) size. - \item If \code{folds} is \code{NULL} but \code{group} is specified, the - data is split up into subsets, each time omitting all observations of one - of the factor levels, while ignoring argument \code{K}. - \item If \code{folds = "stratified"} the subsets are stratified after - \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_stratified}}. - \item If \code{folds = "grouped"} the subsets are split by - \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_grouped}}. - \item If \code{folds = "loo"} exact leave-one-out cross-validation - will be performed and \code{K} will be ignored. Further, if \code{group} - is specified, all observations corresponding to the factor level of the - currently predicted single value are omitted. Thus, in this case, the - predicted values are only a subset of the omitted ones. - \item If \code{folds} is a numeric vector, it must contain one element per - observation in the data. Each element of the vector is an integer in - \code{1:K} indicating to which of the \code{K} folds the corresponding - observation belongs. There are some convenience functions available in - the \pkg{loo} package that create integer vectors to use for this purpose - (see the Examples section below and also the - \link[loo:kfold-helpers]{kfold-helpers} page). - } -} -\examples{ -\dontrun{ -fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), - data = epilepsy, family = poisson()) -# throws warning about some pareto k estimates being too high -(loo1 <- loo(fit1)) -# perform 10-fold cross validation -(kfold1 <- kfold(fit1, chains = 1)) - -# use the future package for parallelization -library(future) -plan(multiprocess) -kfold(fit1, chains = 1) -} - -} -\seealso{ -\code{\link{loo}}, \code{\link{reloo}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/kfold.R +\name{kfold.brmsfit} +\alias{kfold.brmsfit} +\alias{kfold} +\title{K-Fold Cross-Validation} +\usage{ +\method{kfold}{brmsfit}( + x, + ..., + K = 10, + Ksub = NULL, + folds = NULL, + group = NULL, + exact_loo = NULL, + compare = TRUE, + resp = NULL, + model_names = NULL, + save_fits = FALSE, + future_args = list() +) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{K}{The number of subsets of equal (if possible) size +into which the data will be partitioned for performing +\eqn{K}-fold cross-validation. The model is refit \code{K} times, each time +leaving out one of the \code{K} subsets. If \code{K} is equal to the total +number of observations in the data then \eqn{K}-fold cross-validation is +equivalent to exact leave-one-out cross-validation.} + +\item{Ksub}{Optional number of subsets (of those subsets defined by \code{K}) +to be evaluated. If \code{NULL} (the default), \eqn{K}-fold cross-validation +will be performed on all subsets. If \code{Ksub} is a single integer, +\code{Ksub} subsets (out of all \code{K}) subsets will be randomly chosen. +If \code{Ksub} consists of multiple integers or a one-dimensional array +(created via \code{as.array}) potentially of length one, the corresponding +subsets will be used. This argument is primarily useful, if evaluation of +all subsets is infeasible for some reason.} + +\item{folds}{Determines how the subsets are being constructed. +Possible values are \code{NULL} (the default), \code{"stratified"}, +\code{"grouped"}, or \code{"loo"}. May also be a vector of length +equal to the number of observations in the data. Alters the way +\code{group} is handled. More information is provided in the 'Details' +section.} + +\item{group}{Optional name of a grouping variable or factor in the model. +What exactly is done with this variable depends on argument \code{folds}. +More information is provided in the 'Details' section.} + +\item{exact_loo}{Deprecated! Please use \code{folds = "loo"} instead.} + +\item{compare}{A flag indicating if the information criteria +of the models should be compared to each other +via \code{\link{loo_compare}}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} + +\item{save_fits}{If \code{TRUE}, a component \code{fits} is added to +the returned object to store the cross-validated \code{brmsfit} +objects and the indices of the omitted observations for each fold. +Defaults to \code{FALSE}.} + +\item{future_args}{A list of further arguments passed to +\code{\link[future:future]{future}} for additional control over parallel +execution if activated.} +} +\value{ +\code{kfold} returns an object that has a similar structure as the + objects returned by the \code{loo} and \code{waic} methods and + can be used with the same post-processing functions. +} +\description{ +Perform exact K-fold cross-validation by refitting the model \eqn{K} +times each leaving out one-\eqn{K}th of the original data. +Folds can be run in parallel using the \pkg{future} package. +} +\details{ +The \code{kfold} function performs exact \eqn{K}-fold + cross-validation. First the data are partitioned into \eqn{K} folds + (i.e. subsets) of equal (or as close to equal as possible) size by default. + Then the model is refit \eqn{K} times, each time leaving out one of the + \code{K} subsets. If \eqn{K} is equal to the total number of observations + in the data then \eqn{K}-fold cross-validation is equivalent to exact + leave-one-out cross-validation (to which \code{loo} is an efficient + approximation). The \code{compare_ic} function is also compatible with + the objects returned by \code{kfold}. + + The subsets can be constructed in multiple different ways: + \itemize{ + \item If both \code{folds} and \code{group} are \code{NULL}, the subsets + are randomly chosen so that they have equal (or as close to equal as + possible) size. + \item If \code{folds} is \code{NULL} but \code{group} is specified, the + data is split up into subsets, each time omitting all observations of one + of the factor levels, while ignoring argument \code{K}. + \item If \code{folds = "stratified"} the subsets are stratified after + \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_stratified}}. + \item If \code{folds = "grouped"} the subsets are split by + \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_grouped}}. + \item If \code{folds = "loo"} exact leave-one-out cross-validation + will be performed and \code{K} will be ignored. Further, if \code{group} + is specified, all observations corresponding to the factor level of the + currently predicted single value are omitted. Thus, in this case, the + predicted values are only a subset of the omitted ones. + \item If \code{folds} is a numeric vector, it must contain one element per + observation in the data. Each element of the vector is an integer in + \code{1:K} indicating to which of the \code{K} folds the corresponding + observation belongs. There are some convenience functions available in + the \pkg{loo} package that create integer vectors to use for this purpose + (see the Examples section below and also the + \link[loo:kfold-helpers]{kfold-helpers} page). + } +} +\examples{ +\dontrun{ +fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), + data = epilepsy, family = poisson()) +# throws warning about some pareto k estimates being too high +(loo1 <- loo(fit1)) +# perform 10-fold cross validation +(kfold1 <- kfold(fit1, chains = 1)) + +# use the future package for parallelization +library(future) +plan(multiprocess) +kfold(fit1, chains = 1) +} + +} +\seealso{ +\code{\link{loo}}, \code{\link{reloo}} +} diff -Nru r-cran-brms-2.16.3/man/kfold_predict.Rd r-cran-brms-2.17.0/man/kfold_predict.Rd --- r-cran-brms-2.16.3/man/kfold_predict.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/kfold_predict.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,55 +1,55 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/kfold.R -\name{kfold_predict} -\alias{kfold_predict} -\title{Predictions from K-Fold Cross-Validation} -\usage{ -kfold_predict(x, method = c("predict", "fitted"), resp = NULL, ...) -} -\arguments{ -\item{x}{Object of class \code{'kfold'} computed by \code{\link{kfold}}. -For \code{kfold_predict} to work, the fitted model objects need to have -been stored via argument \code{save_fits} of \code{\link{kfold}}.} - -\item{method}{The method used to make predictions. Either \code{"predict"} -or \code{"fitted"}. See \code{\link{predict.brmsfit}} for details.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -A \code{list} with two slots named \code{'y'} and \code{'yrep'}. - Slot \code{y} contains the vector of observed responses. - Slot \code{yrep} contains the matrix of predicted responses, - with rows being posterior draws and columns being observations. -} -\description{ -Compute and evaluate predictions after performing K-fold -cross-validation via \code{\link{kfold}}. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zBase * Trt + (1|patient), - data = epilepsy, family = poisson()) - -# perform k-fold cross validation -(kf <- kfold(fit, save_fits = TRUE, chains = 1)) - -# define a loss function -rmse <- function(y, yrep) { - yrep_mean <- colMeans(yrep) - sqrt(mean((yrep_mean - y)^2)) -} - -# predict responses and evaluate the loss -kfp <- kfold_predict(kf) -rmse(y = kfp$y, yrep = kfp$yrep) -} - -} -\seealso{ -\code{\link{kfold}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/kfold.R +\name{kfold_predict} +\alias{kfold_predict} +\title{Predictions from K-Fold Cross-Validation} +\usage{ +kfold_predict(x, method = c("predict", "fitted"), resp = NULL, ...) +} +\arguments{ +\item{x}{Object of class \code{'kfold'} computed by \code{\link{kfold}}. +For \code{kfold_predict} to work, the fitted model objects need to have +been stored via argument \code{save_fits} of \code{\link{kfold}}.} + +\item{method}{The method used to make predictions. Either \code{"predict"} +or \code{"fitted"}. See \code{\link{predict.brmsfit}} for details.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +A \code{list} with two slots named \code{'y'} and \code{'yrep'}. + Slot \code{y} contains the vector of observed responses. + Slot \code{yrep} contains the matrix of predicted responses, + with rows being posterior draws and columns being observations. +} +\description{ +Compute and evaluate predictions after performing K-fold +cross-validation via \code{\link{kfold}}. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zBase * Trt + (1|patient), + data = epilepsy, family = poisson()) + +# perform k-fold cross validation +(kf <- kfold(fit, save_fits = TRUE, chains = 1)) + +# define a loss function +rmse <- function(y, yrep) { + yrep_mean <- colMeans(yrep) + sqrt(mean((yrep_mean - y)^2)) +} + +# predict responses and evaluate the loss +kfp <- kfold_predict(kf) +rmse(y = kfp$y, yrep = kfp$yrep) +} + +} +\seealso{ +\code{\link{kfold}} +} diff -Nru r-cran-brms-2.16.3/man/kidney.Rd r-cran-brms-2.17.0/man/kidney.Rd --- r-cran-brms-2.16.3/man/kidney.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/kidney.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,58 +1,58 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/datasets.R -\docType{data} -\name{kidney} -\alias{kidney} -\title{Infections in kidney patients} -\format{ -A data frame of 76 observations containing - information on the following 7 variables. -\describe{ - \item{time}{The time to first or second recurrence of the infection, - or the time of censoring} - \item{recur}{A factor of levels \code{1} or \code{2} - indicating if the infection recurred for the first - or second time for this patient} - \item{censored}{Either \code{0} or \code{1}, where \code{0} indicates - no censoring of recurrence time and \code{1} indicates right censoring} - \item{patient}{The patient number} - \item{age}{The age of the patient} - \item{sex}{The sex of the patient} - \item{disease}{A factor of levels \code{other, GN, AN}, - and \code{PKD} specifying the type of disease} -} -} -\source{ -McGilchrist, C. A., & Aisbett, C. W. (1991). - Regression with frailty in survival analysis. - \emph{Biometrics}, 47(2), 461-466. -} -\usage{ -kidney -} -\description{ -This dataset, originally discussed in - McGilchrist and Aisbett (1991), describes the first and second - (possibly right censored) recurrence time of - infection in kidney patients using portable dialysis equipment. - In addition, information on the risk variables age, sex and disease - type is provided. -} -\examples{ -\dontrun{ -## performing surivival analysis using the "weibull" family -fit1 <- brm(time | cens(censored) ~ age + sex + disease, - data = kidney, family = weibull, inits = "0") -summary(fit1) -plot(fit1) - -## adding random intercepts over patients -fit2 <- brm(time | cens(censored) ~ age + sex + disease + (1|patient), - data = kidney, family = weibull(), inits = "0", - prior = set_prior("cauchy(0,2)", class = "sd")) -summary(fit2) -plot(fit2) -} - -} -\keyword{datasets} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasets.R +\docType{data} +\name{kidney} +\alias{kidney} +\title{Infections in kidney patients} +\format{ +A data frame of 76 observations containing + information on the following 7 variables. +\describe{ + \item{time}{The time to first or second recurrence of the infection, + or the time of censoring} + \item{recur}{A factor of levels \code{1} or \code{2} + indicating if the infection recurred for the first + or second time for this patient} + \item{censored}{Either \code{0} or \code{1}, where \code{0} indicates + no censoring of recurrence time and \code{1} indicates right censoring} + \item{patient}{The patient number} + \item{age}{The age of the patient} + \item{sex}{The sex of the patient} + \item{disease}{A factor of levels \code{other, GN, AN}, + and \code{PKD} specifying the type of disease} +} +} +\source{ +McGilchrist, C. A., & Aisbett, C. W. (1991). + Regression with frailty in survival analysis. + \emph{Biometrics}, 47(2), 461-466. +} +\usage{ +kidney +} +\description{ +This dataset, originally discussed in + McGilchrist and Aisbett (1991), describes the first and second + (possibly right censored) recurrence time of + infection in kidney patients using portable dialysis equipment. + In addition, information on the risk variables age, sex and disease + type is provided. +} +\examples{ +\dontrun{ +## performing surivival analysis using the "weibull" family +fit1 <- brm(time | cens(censored) ~ age + sex + disease, + data = kidney, family = weibull, init = "0") +summary(fit1) +plot(fit1) + +## adding random intercepts over patients +fit2 <- brm(time | cens(censored) ~ age + sex + disease + (1|patient), + data = kidney, family = weibull(), init = "0", + prior = set_prior("cauchy(0,2)", class = "sd")) +summary(fit2) +plot(fit2) +} + +} +\keyword{datasets} diff -Nru r-cran-brms-2.16.3/man/lasso.Rd r-cran-brms-2.17.0/man/lasso.Rd --- r-cran-brms-2.16.3/man/lasso.Rd 2019-11-21 12:19:04.000000000 +0000 +++ r-cran-brms-2.17.0/man/lasso.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -17,15 +17,15 @@ additional arguments. } \description{ -Function used to set up a lasso prior for population-level effects +Function used to set up a lasso prior for population-level effects in \pkg{brms}. The function does not evaluate its arguments -- it exists purely to help set up the model. } \details{ The lasso prior is the Bayesian equivalent to the LASSO method for performing variable selection (Park & Casella, 2008). - With this prior, independent Laplace (i.e. double exponential) priors - are placed on the population-level effects. + With this prior, independent Laplace (i.e. double exponential) priors + are placed on the population-level effects. The scale of the Laplace priors depends on a tuning parameter that controls the amount of shrinkage. In \pkg{brms}, the inverse of the tuning parameter is used so that smaller values imply @@ -33,7 +33,7 @@ and with degrees of freedom controlled via argument \code{df} of function \code{lasso} (defaults to \code{1}). For instance, one can specify a lasso prior using \code{set_prior("lasso(1)")}. - To make sure that shrinkage can equally affect all coefficients, + To make sure that shrinkage can equally affect all coefficients, predictors should be one the same scale. If you do not want to standardized all variables, you can adjust the general scale of the lasso prior via argument @@ -44,7 +44,7 @@ } \references{ -Park, T., & Casella, G. (2008). The Bayesian Lasso. Journal of the American +Park, T., & Casella, G. (2008). The Bayesian Lasso. Journal of the American Statistical Association, 103(482), 681-686. } \seealso{ diff -Nru r-cran-brms-2.16.3/man/launch_shinystan.brmsfit.Rd r-cran-brms-2.17.0/man/launch_shinystan.brmsfit.Rd --- r-cran-brms-2.16.3/man/launch_shinystan.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/launch_shinystan.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,37 +1,37 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/launch_shinystan.R -\name{launch_shinystan.brmsfit} -\alias{launch_shinystan.brmsfit} -\alias{launch_shinystan} -\title{Interface to \pkg{shinystan}} -\usage{ -\method{launch_shinystan}{brmsfit}(object, rstudio = getOption("shinystan.rstudio"), ...) -} -\arguments{ -\item{object}{A fitted model object typically of class \code{brmsfit}.} - -\item{rstudio}{Only relevant for RStudio users. -The default (\code{rstudio=FALSE}) is to launch the app -in the default web browser rather than RStudio's pop-up Viewer. -Users can change the default to \code{TRUE} -by setting the global option \cr \code{options(shinystan.rstudio = TRUE)}.} - -\item{...}{Optional arguments to pass to \code{\link[shiny:runApp]{runApp}}} -} -\value{ -An S4 shinystan object -} -\description{ -Provide an interface to \pkg{shinystan} for models fitted with \pkg{brms} -} -\examples{ -\dontrun{ -fit <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = "gaussian") -launch_shinystan(fit) -} - -} -\seealso{ -\code{\link[shinystan:launch_shinystan]{launch_shinystan}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/launch_shinystan.R +\name{launch_shinystan.brmsfit} +\alias{launch_shinystan.brmsfit} +\alias{launch_shinystan} +\title{Interface to \pkg{shinystan}} +\usage{ +\method{launch_shinystan}{brmsfit}(object, rstudio = getOption("shinystan.rstudio"), ...) +} +\arguments{ +\item{object}{A fitted model object typically of class \code{brmsfit}.} + +\item{rstudio}{Only relevant for RStudio users. +The default (\code{rstudio=FALSE}) is to launch the app +in the default web browser rather than RStudio's pop-up Viewer. +Users can change the default to \code{TRUE} +by setting the global option \cr \code{options(shinystan.rstudio = TRUE)}.} + +\item{...}{Optional arguments to pass to \code{\link[shiny:runApp]{runApp}}} +} +\value{ +An S4 shinystan object +} +\description{ +Provide an interface to \pkg{shinystan} for models fitted with \pkg{brms} +} +\examples{ +\dontrun{ +fit <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = "gaussian") +launch_shinystan(fit) +} + +} +\seealso{ +\code{\link[shinystan:launch_shinystan]{launch_shinystan}} +} diff -Nru r-cran-brms-2.16.3/man/LogisticNormal.Rd r-cran-brms-2.17.0/man/LogisticNormal.Rd --- r-cran-brms-2.16.3/man/LogisticNormal.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-brms-2.17.0/man/LogisticNormal.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{LogisticNormal} +\alias{LogisticNormal} +\alias{dlogistic_normal} +\alias{rlogistic_normal} +\title{The (Multivariate) Logistic Normal Distribution} +\usage{ +dlogistic_normal(x, mu, Sigma, refcat = 1, log = FALSE, check = FALSE) + +rlogistic_normal(n, mu, Sigma, refcat = 1, check = FALSE) +} +\arguments{ +\item{x}{Vector or matrix of quantiles. If \code{x} is a matrix, +each row is taken to be a quantile.} + +\item{mu}{Mean vector with length equal to the number of dimensions.} + +\item{Sigma}{Covariance matrix.} + +\item{refcat}{A single integer indicating the reference category. +Defaults to \code{1}.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{check}{Logical; Indicates whether several input checks +should be performed. Defaults to \code{FALSE} to improve +efficiency.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density function and random generation for the (multivariate) logistic normal +distribution with latent mean vector \code{mu} and covariance matrix \code{Sigma}. +} diff -Nru r-cran-brms-2.16.3/man/logit_scaled.Rd r-cran-brms-2.17.0/man/logit_scaled.Rd --- r-cran-brms-2.16.3/man/logit_scaled.Rd 2020-05-21 11:32:10.000000000 +0000 +++ r-cran-brms-2.17.0/man/logit_scaled.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,21 +1,21 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/numeric-helpers.R -\name{logit_scaled} -\alias{logit_scaled} -\title{Scaled logit-link} -\usage{ -logit_scaled(x, lb = 0, ub = 1) -} -\arguments{ -\item{x}{A numeric or complex vector.} - -\item{lb}{Lower bound defaulting to \code{0}.} - -\item{ub}{Upper bound defaulting to \code{1}.} -} -\value{ -A numeric or complex vector. -} -\description{ -Computes \code{logit((x - lb) / (ub - lb))} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/numeric-helpers.R +\name{logit_scaled} +\alias{logit_scaled} +\title{Scaled logit-link} +\usage{ +logit_scaled(x, lb = 0, ub = 1) +} +\arguments{ +\item{x}{A numeric or complex vector.} + +\item{lb}{Lower bound defaulting to \code{0}.} + +\item{ub}{Upper bound defaulting to \code{1}.} +} +\value{ +A numeric or complex vector. +} +\description{ +Computes \code{logit((x - lb) / (ub - lb))} +} diff -Nru r-cran-brms-2.16.3/man/log_lik.brmsfit.Rd r-cran-brms-2.17.0/man/log_lik.brmsfit.Rd --- r-cran-brms-2.16.3/man/log_lik.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/log_lik.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,94 +1,94 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/log_lik.R -\name{log_lik.brmsfit} -\alias{log_lik.brmsfit} -\alias{log_lik} -\alias{logLik.brmsfit} -\title{Compute the Pointwise Log-Likelihood} -\usage{ -\method{log_lik}{brmsfit}( - object, - newdata = NULL, - re_formula = NULL, - resp = NULL, - ndraws = NULL, - draw_ids = NULL, - pointwise = FALSE, - combine = TRUE, - add_point_estimate = FALSE, - cores = NULL, - ... -) -} -\arguments{ -\item{object}{A fitted model object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{pointwise}{A flag indicating whether to compute the full -log-likelihood matrix at once (the default), or just return -the likelihood function along with all data and draws -required to compute the log-likelihood separately for each -observation. The latter option is rarely useful when -calling \code{log_lik} directly, but rather when computing -\code{\link{waic}} or \code{\link{loo}}.} - -\item{combine}{Only relevant in multivariate models. -Indicates if the log-likelihoods of the submodels should -be combined per observation (i.e. added together; the default) -or if the log-likelihoods should be returned separately.} - -\item{add_point_estimate}{For internal use only. Ensures compatibility -with the \code{\link{loo_subsample}} method.} - -\item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, -this argument can be set globally via the \code{mc.cores} option.} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -Usually, an S x N matrix containing the pointwise log-likelihood - draws, where S is the number of draws and N is the number - of observations in the data. For multivariate models and if - \code{combine} is \code{FALSE}, an S x N x R array is returned, - where R is the number of response variables. - If \code{pointwise = TRUE}, the output is a function - with a \code{draws} attribute containing all relevant - data and posterior draws. -} -\description{ -Compute the Pointwise Log-Likelihood -} -\details{ -\code{NA} values within factors in \code{newdata}, - are interpreted as if all dummy variables of this factor are - zero. This allows, for instance, to make predictions of the grand mean - when using sum coding. - -In multilevel models, it is possible to -allow new levels of grouping factors to be used in the predictions. -This can be controlled via argument \code{allow_new_levels}. -New levels can be sampled in multiple ways, which can be controlled -via argument \code{sample_new_levels}. Both of these arguments are -documented in \code{\link{prepare_predictions}} along with several -other useful arguments to control specific aspects of the predictions. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/log_lik.R +\name{log_lik.brmsfit} +\alias{log_lik.brmsfit} +\alias{log_lik} +\alias{logLik.brmsfit} +\title{Compute the Pointwise Log-Likelihood} +\usage{ +\method{log_lik}{brmsfit}( + object, + newdata = NULL, + re_formula = NULL, + resp = NULL, + ndraws = NULL, + draw_ids = NULL, + pointwise = FALSE, + combine = TRUE, + add_point_estimate = FALSE, + cores = NULL, + ... +) +} +\arguments{ +\item{object}{A fitted model object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{pointwise}{A flag indicating whether to compute the full +log-likelihood matrix at once (the default), or just return +the likelihood function along with all data and draws +required to compute the log-likelihood separately for each +observation. The latter option is rarely useful when +calling \code{log_lik} directly, but rather when computing +\code{\link{waic}} or \code{\link{loo}}.} + +\item{combine}{Only relevant in multivariate models. +Indicates if the log-likelihoods of the submodels should +be combined per observation (i.e. added together; the default) +or if the log-likelihoods should be returned separately.} + +\item{add_point_estimate}{For internal use only. Ensures compatibility +with the \code{\link{loo_subsample}} method.} + +\item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, +this argument can be set globally via the \code{mc.cores} option.} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +Usually, an S x N matrix containing the pointwise log-likelihood + draws, where S is the number of draws and N is the number + of observations in the data. For multivariate models and if + \code{combine} is \code{FALSE}, an S x N x R array is returned, + where R is the number of response variables. + If \code{pointwise = TRUE}, the output is a function + with a \code{draws} attribute containing all relevant + data and posterior draws. +} +\description{ +Compute the Pointwise Log-Likelihood +} +\details{ +\code{NA} values within factors in \code{newdata}, + are interpreted as if all dummy variables of this factor are + zero. This allows, for instance, to make predictions of the grand mean + when using sum coding. + +In multilevel models, it is possible to +allow new levels of grouping factors to be used in the predictions. +This can be controlled via argument \code{allow_new_levels}. +New levels can be sampled in multiple ways, which can be controlled +via argument \code{sample_new_levels}. Both of these arguments are +documented in \code{\link{prepare_predictions}} along with several +other useful arguments to control specific aspects of the predictions. +} diff -Nru r-cran-brms-2.16.3/man/logm1.Rd r-cran-brms-2.17.0/man/logm1.Rd --- r-cran-brms-2.16.3/man/logm1.Rd 2020-05-21 11:32:10.000000000 +0000 +++ r-cran-brms-2.17.0/man/logm1.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,17 +1,17 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/numeric-helpers.R -\name{logm1} -\alias{logm1} -\title{Logarithm with a minus one offset.} -\usage{ -logm1(x, base = exp(1)) -} -\arguments{ -\item{x}{A numeric or complex vector.} - -\item{base}{A positive or complex number: the base with respect to which -logarithms are computed. Defaults to \emph{e} = \code{exp(1)}.} -} -\description{ -Computes \code{log(x - 1)}. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/numeric-helpers.R +\name{logm1} +\alias{logm1} +\title{Logarithm with a minus one offset.} +\usage{ +logm1(x, base = exp(1)) +} +\arguments{ +\item{x}{A numeric or complex vector.} + +\item{base}{A positive or complex number: the base with respect to which +logarithms are computed. Defaults to \emph{e} = \code{exp(1)}.} +} +\description{ +Computes \code{log(x - 1)}. +} diff -Nru r-cran-brms-2.16.3/man/loo.brmsfit.Rd r-cran-brms-2.17.0/man/loo.brmsfit.Rd --- r-cran-brms-2.16.3/man/loo.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/loo.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,118 +1,118 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo.R -\name{loo.brmsfit} -\alias{loo.brmsfit} -\alias{loo} -\alias{LOO} -\alias{LOO.brmsfit} -\title{Efficient approximate leave-one-out cross-validation (LOO)} -\usage{ -\method{loo}{brmsfit}( - x, - ..., - compare = TRUE, - resp = NULL, - pointwise = FALSE, - moment_match = FALSE, - reloo = FALSE, - k_threshold = 0.7, - save_psis = FALSE, - moment_match_args = list(), - reloo_args = list(), - model_names = NULL -) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{compare}{A flag indicating if the information criteria -of the models should be compared to each other -via \code{\link{loo_compare}}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{pointwise}{A flag indicating whether to compute the full -log-likelihood matrix at once or separately for each observation. -The latter approach is usually considerably slower but -requires much less working memory. Accordingly, if one runs -into memory issues, \code{pointwise = TRUE} is the way to go.} - -\item{moment_match}{Logical; Indicate whether \code{\link{loo_moment_match}} -should be applied on problematic observations. Defaults to \code{FALSE}. -For most models, moment matching will only work if you have set -\code{save_pars = save_pars(all = TRUE)} when fitting the model with -\code{\link{brm}}. See \code{\link{loo_moment_match.brmsfit}} for more -details.} - -\item{reloo}{Logical; Indicate whether \code{\link{reloo}} -should be applied on problematic observations. Defaults to \code{FALSE}.} - -\item{k_threshold}{The threshold at which pareto \eqn{k} -estimates are treated as problematic. Defaults to \code{0.7}. -Only used if argument \code{reloo} is \code{TRUE}. -See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} for more details.} - -\item{save_psis}{Should the \code{"psis"} object created internally be saved -in the returned object? For more details see \code{\link[loo:loo]{loo}}.} - -\item{moment_match_args}{Optional \code{list} of additional arguments passed to -\code{\link{loo_moment_match}}.} - -\item{reloo_args}{Optional \code{list} of additional arguments passed to -\code{\link{reloo}}.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} -} -\value{ -If just one object is provided, an object of class \code{loo}. - If multiple objects are provided, an object of class \code{loolist}. -} -\description{ -Perform approximate leave-one-out cross-validation based -on the posterior likelihood using the \pkg{loo} package. -For more details see \code{\link[loo:loo]{loo}}. -} -\details{ -See \code{\link{loo_compare}} for details on model comparisons. - For \code{brmsfit} objects, \code{LOO} is an alias of \code{loo}. - Use method \code{\link{add_criterion}} to store - information criteria in the fitted model object for later usage. -} -\examples{ -\dontrun{ -# model with population-level effects only -fit1 <- brm(rating ~ treat + period + carry, - data = inhaler) -(loo1 <- loo(fit1)) - -# model with an additional varying intercept for subjects -fit2 <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler) -(loo2 <- loo(fit2)) - -# compare both models -loo_compare(loo1, loo2) -} - -} -\references{ -Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model -evaluation using leave-one-out cross-validation and WAIC. In Statistics -and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. - -Gelman, A., Hwang, J., & Vehtari, A. (2014). -Understanding predictive information criteria for Bayesian models. -Statistics and Computing, 24, 997-1016. - -Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation -and widely applicable information criterion in singular learning theory. -The Journal of Machine Learning Research, 11, 3571-3594. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo.R +\name{loo.brmsfit} +\alias{loo.brmsfit} +\alias{loo} +\alias{LOO} +\alias{LOO.brmsfit} +\title{Efficient approximate leave-one-out cross-validation (LOO)} +\usage{ +\method{loo}{brmsfit}( + x, + ..., + compare = TRUE, + resp = NULL, + pointwise = FALSE, + moment_match = FALSE, + reloo = FALSE, + k_threshold = 0.7, + save_psis = FALSE, + moment_match_args = list(), + reloo_args = list(), + model_names = NULL +) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{compare}{A flag indicating if the information criteria +of the models should be compared to each other +via \code{\link{loo_compare}}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{pointwise}{A flag indicating whether to compute the full +log-likelihood matrix at once or separately for each observation. +The latter approach is usually considerably slower but +requires much less working memory. Accordingly, if one runs +into memory issues, \code{pointwise = TRUE} is the way to go.} + +\item{moment_match}{Logical; Indicate whether \code{\link{loo_moment_match}} +should be applied on problematic observations. Defaults to \code{FALSE}. +For most models, moment matching will only work if you have set +\code{save_pars = save_pars(all = TRUE)} when fitting the model with +\code{\link{brm}}. See \code{\link{loo_moment_match.brmsfit}} for more +details.} + +\item{reloo}{Logical; Indicate whether \code{\link{reloo}} +should be applied on problematic observations. Defaults to \code{FALSE}.} + +\item{k_threshold}{The threshold at which pareto \eqn{k} +estimates are treated as problematic. Defaults to \code{0.7}. +Only used if argument \code{reloo} is \code{TRUE}. +See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} for more details.} + +\item{save_psis}{Should the \code{"psis"} object created internally be saved +in the returned object? For more details see \code{\link[loo:loo]{loo}}.} + +\item{moment_match_args}{Optional \code{list} of additional arguments passed to +\code{\link{loo_moment_match}}.} + +\item{reloo_args}{Optional \code{list} of additional arguments passed to +\code{\link{reloo}}.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} +} +\value{ +If just one object is provided, an object of class \code{loo}. + If multiple objects are provided, an object of class \code{loolist}. +} +\description{ +Perform approximate leave-one-out cross-validation based +on the posterior likelihood using the \pkg{loo} package. +For more details see \code{\link[loo:loo]{loo}}. +} +\details{ +See \code{\link{loo_compare}} for details on model comparisons. + For \code{brmsfit} objects, \code{LOO} is an alias of \code{loo}. + Use method \code{\link{add_criterion}} to store + information criteria in the fitted model object for later usage. +} +\examples{ +\dontrun{ +# model with population-level effects only +fit1 <- brm(rating ~ treat + period + carry, + data = inhaler) +(loo1 <- loo(fit1)) + +# model with an additional varying intercept for subjects +fit2 <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler) +(loo2 <- loo(fit2)) + +# compare both models +loo_compare(loo1, loo2) +} + +} +\references{ +Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model +evaluation using leave-one-out cross-validation and WAIC. In Statistics +and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. + +Gelman, A., Hwang, J., & Vehtari, A. (2014). +Understanding predictive information criteria for Bayesian models. +Statistics and Computing, 24, 997-1016. + +Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation +and widely applicable information criterion in singular learning theory. +The Journal of Machine Learning Research, 11, 3571-3594. +} diff -Nru r-cran-brms-2.16.3/man/loo_compare.brmsfit.Rd r-cran-brms-2.17.0/man/loo_compare.brmsfit.Rd --- r-cran-brms-2.16.3/man/loo_compare.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/loo_compare.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,48 +1,48 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo.R -\name{loo_compare.brmsfit} -\alias{loo_compare.brmsfit} -\alias{loo_compare} -\title{Model comparison with the \pkg{loo} package} -\usage{ -\method{loo_compare}{brmsfit}(x, ..., criterion = c("loo", "waic", "kfold"), model_names = NULL) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects.} - -\item{criterion}{The name of the criterion to be extracted -from \code{brmsfit} objects.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} -} -\value{ -An object of class "\code{compare.loo}". -} -\description{ -For more details see \code{\link[loo:loo_compare]{loo_compare}}. -} -\details{ -All \code{brmsfit} objects should contain precomputed - criterion objects. See \code{\link{add_criterion}} for more help. -} -\examples{ -\dontrun{ -# model with population-level effects only -fit1 <- brm(rating ~ treat + period + carry, - data = inhaler) -fit1 <- add_criterion(fit1, "waic") - -# model with an additional varying intercept for subjects -fit2 <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler) -fit2 <- add_criterion(fit2, "waic") - -# compare both models -loo_compare(fit1, fit2, criterion = "waic") -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo.R +\name{loo_compare.brmsfit} +\alias{loo_compare.brmsfit} +\alias{loo_compare} +\title{Model comparison with the \pkg{loo} package} +\usage{ +\method{loo_compare}{brmsfit}(x, ..., criterion = c("loo", "waic", "kfold"), model_names = NULL) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects.} + +\item{criterion}{The name of the criterion to be extracted +from \code{brmsfit} objects.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} +} +\value{ +An object of class "\code{compare.loo}". +} +\description{ +For more details see \code{\link[loo:loo_compare]{loo_compare}}. +} +\details{ +All \code{brmsfit} objects should contain precomputed + criterion objects. See \code{\link{add_criterion}} for more help. +} +\examples{ +\dontrun{ +# model with population-level effects only +fit1 <- brm(rating ~ treat + period + carry, + data = inhaler) +fit1 <- add_criterion(fit1, "waic") + +# model with an additional varying intercept for subjects +fit2 <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler) +fit2 <- add_criterion(fit2, "waic") + +# compare both models +loo_compare(fit1, fit2, criterion = "waic") +} + +} diff -Nru r-cran-brms-2.16.3/man/loo_model_weights.brmsfit.Rd r-cran-brms-2.17.0/man/loo_model_weights.brmsfit.Rd --- r-cran-brms-2.16.3/man/loo_model_weights.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/loo_model_weights.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,41 +1,41 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo.R -\name{loo_model_weights.brmsfit} -\alias{loo_model_weights.brmsfit} -\alias{loo_model_weights} -\title{Model averaging via stacking or pseudo-BMA weighting.} -\usage{ -\method{loo_model_weights}{brmsfit}(x, ..., model_names = NULL) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} -} -\value{ -A named vector of model weights. -} -\description{ -Compute model weights for \code{brmsfit} objects via stacking -or pseudo-BMA weighting. For more details, see -\code{\link[loo:loo_model_weights]{loo::loo_model_weights}}. -} -\examples{ -\dontrun{ -# model with population-level effects only -fit1 <- brm(rating ~ treat + period + carry, - data = inhaler, family = "gaussian") -# model with an additional varying intercept for subjects -fit2 <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = "gaussian") -loo_model_weights(fit1, fit2) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo.R +\name{loo_model_weights.brmsfit} +\alias{loo_model_weights.brmsfit} +\alias{loo_model_weights} +\title{Model averaging via stacking or pseudo-BMA weighting.} +\usage{ +\method{loo_model_weights}{brmsfit}(x, ..., model_names = NULL) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} +} +\value{ +A named vector of model weights. +} +\description{ +Compute model weights for \code{brmsfit} objects via stacking +or pseudo-BMA weighting. For more details, see +\code{\link[loo:loo_model_weights]{loo::loo_model_weights}}. +} +\examples{ +\dontrun{ +# model with population-level effects only +fit1 <- brm(rating ~ treat + period + carry, + data = inhaler, family = "gaussian") +# model with an additional varying intercept for subjects +fit2 <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = "gaussian") +loo_model_weights(fit1, fit2) +} + +} diff -Nru r-cran-brms-2.16.3/man/loo_moment_match.brmsfit.Rd r-cran-brms-2.17.0/man/loo_moment_match.brmsfit.Rd --- r-cran-brms-2.16.3/man/loo_moment_match.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/loo_moment_match.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,77 +1,77 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo_moment_match.R -\name{loo_moment_match.brmsfit} -\alias{loo_moment_match.brmsfit} -\alias{loo_moment_match} -\title{Moment matching for efficient approximate leave-one-out cross-validation} -\usage{ -\method{loo_moment_match}{brmsfit}( - x, - loo, - k_threshold = 0.7, - newdata = NULL, - resp = NULL, - check = TRUE, - ... -) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}.} - -\item{loo}{An object of class \code{loo} originally created from \code{x}.} - -\item{k_threshold}{The threshold at which Pareto \eqn{k} -estimates are treated as problematic. Defaults to \code{0.7}. -See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} -for more details.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{check}{Logical; If \code{TRUE} (the default), some checks -check are performed if the \code{loo} object was generated -from the \code{brmsfit} object passed to argument \code{fit}.} - -\item{...}{Further arguments passed to the underlying methods. -Additional arguments initially passed to \code{\link{loo}}, -for example, \code{newdata} or \code{resp} need to be passed -again to \code{loo_moment_match} in order for the latter -to work correctly.} -} -\value{ -An updated object of class \code{loo}. -} -\description{ -Moment matching for efficient approximate leave-one-out cross-validation -(LOO-CV). See \code{\link[loo:loo_moment_match]{loo_moment_match}} -for more details. -} -\details{ -The moment matching algorithm requires draws of all variables - defined in Stan's \code{parameters} block to be saved. Otherwise - \code{loo_moment_match} cannot be computed. Thus, please set - \code{save_pars = save_pars(all = TRUE)} in the call to \code{\link{brm}}, - if you are planning to apply \code{loo_moment_match} to your models. -} -\examples{ -\dontrun{ -fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson(), - save_pars = save_pars(all = TRUE)) - -# throws warning about some pareto k estimates being too high -(loo1 <- loo(fit1)) -(mmloo1 <- loo_moment_match(fit1, loo = loo1)) -} - -} -\references{ -Paananen, T., Piironen, J., Buerkner, P.-C., Vehtari, A. (2021). - Implicitly Adaptive Importance Sampling. Statistics and Computing. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo_moment_match.R +\name{loo_moment_match.brmsfit} +\alias{loo_moment_match.brmsfit} +\alias{loo_moment_match} +\title{Moment matching for efficient approximate leave-one-out cross-validation} +\usage{ +\method{loo_moment_match}{brmsfit}( + x, + loo, + k_threshold = 0.7, + newdata = NULL, + resp = NULL, + check = TRUE, + ... +) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}.} + +\item{loo}{An object of class \code{loo} originally created from \code{x}.} + +\item{k_threshold}{The threshold at which Pareto \eqn{k} +estimates are treated as problematic. Defaults to \code{0.7}. +See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} +for more details.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{check}{Logical; If \code{TRUE} (the default), some checks +check are performed if the \code{loo} object was generated +from the \code{brmsfit} object passed to argument \code{fit}.} + +\item{...}{Further arguments passed to the underlying methods. +Additional arguments initially passed to \code{\link{loo}}, +for example, \code{newdata} or \code{resp} need to be passed +again to \code{loo_moment_match} in order for the latter +to work correctly.} +} +\value{ +An updated object of class \code{loo}. +} +\description{ +Moment matching for efficient approximate leave-one-out cross-validation +(LOO-CV). See \code{\link[loo:loo_moment_match]{loo_moment_match}} +for more details. +} +\details{ +The moment matching algorithm requires draws of all variables + defined in Stan's \code{parameters} block to be saved. Otherwise + \code{loo_moment_match} cannot be computed. Thus, please set + \code{save_pars = save_pars(all = TRUE)} in the call to \code{\link{brm}}, + if you are planning to apply \code{loo_moment_match} to your models. +} +\examples{ +\dontrun{ +fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson(), + save_pars = save_pars(all = TRUE)) + +# throws warning about some pareto k estimates being too high +(loo1 <- loo(fit1)) +(mmloo1 <- loo_moment_match(fit1, loo = loo1)) +} + +} +\references{ +Paananen, T., Piironen, J., Buerkner, P.-C., Vehtari, A. (2021). + Implicitly Adaptive Importance Sampling. Statistics and Computing. +} diff -Nru r-cran-brms-2.16.3/man/loo_predict.brmsfit.Rd r-cran-brms-2.17.0/man/loo_predict.brmsfit.Rd --- r-cran-brms-2.16.3/man/loo_predict.brmsfit.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/loo_predict.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,94 +1,94 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo_predict.R -\name{loo_predict.brmsfit} -\alias{loo_predict.brmsfit} -\alias{loo_predict} -\alias{loo_linpred} -\alias{loo_predictive_interval} -\alias{loo_linpred.brmsfit} -\alias{loo_predictive_interval.brmsfit} -\title{Compute Weighted Expectations Using LOO} -\usage{ -\method{loo_predict}{brmsfit}( - object, - type = c("mean", "var", "quantile"), - probs = 0.5, - psis_object = NULL, - resp = NULL, - ... -) - -\method{loo_linpred}{brmsfit}( - object, - type = c("mean", "var", "quantile"), - probs = 0.5, - psis_object = NULL, - resp = NULL, - ... -) - -\method{loo_predictive_interval}{brmsfit}(object, prob = 0.9, psis_object = NULL, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{type}{The statistic to be computed on the results. -Can by either \code{"mean"} (default), \code{"var"}, or -\code{"quantile"}.} - -\item{probs}{A vector of quantiles to compute. -Only used if \code{type = quantile}.} - -\item{psis_object}{An optional object returned by \code{\link[loo]{psis}}. -If \code{psis_object} is missing then \code{\link[loo]{psis}} is executed -internally, which may be time consuming for models fit to very large datasets.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{...}{Optional arguments passed to the underlying methods that is -\code{\link[brms:log_lik.brmsfit]{log_lik}}, as well as -\code{\link[brms:posterior_predict.brmsfit]{posterior_predict}} or -\code{\link[brms:posterior_linpred.brmsfit]{posterior_linpred}}.} - -\item{prob}{For \code{loo_predictive_interval}, a scalar in \eqn{(0,1)} -indicating the desired probability mass to include in the intervals. The -default is \code{prob = 0.9} (\eqn{90}\% intervals).} -} -\value{ -\code{loo_predict} and \code{loo_linpred} return a vector with one - element per observation. The only exception is if \code{type = "quantile"} - and \code{length(probs) >= 2}, in which case a separate vector for each - element of \code{probs} is computed and they are returned in a matrix with - \code{length(probs)} rows and one column per observation. - - \code{loo_predictive_interval} returns a matrix with one row per - observation and two columns. - \code{loo_predictive_interval(..., prob = p)} is equivalent to - \code{loo_predict(..., type = "quantile", probs = c(a, 1-a))} with - \code{a = (1 - p)/2}, except it transposes the result and adds informative - column names. -} -\description{ -These functions are wrappers around the \code{\link[loo]{E_loo}} -function of the \pkg{loo} package. -} -\examples{ -\dontrun{ -## data from help("lm") -ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14) -trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69) -d <- data.frame( - weight = c(ctl, trt), - group = gl(2, 10, 20, labels = c("Ctl", "Trt")) -) -fit <- brm(weight ~ group, data = d) -loo_predictive_interval(fit, prob = 0.8) - -## optionally log-weights can be pre-computed and reused -psis <- loo::psis(-log_lik(fit), cores = 2) -loo_predictive_interval(fit, prob = 0.8, psis_object = psis) -loo_predict(fit, type = "var", psis_object = psis) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo_predict.R +\name{loo_predict.brmsfit} +\alias{loo_predict.brmsfit} +\alias{loo_predict} +\alias{loo_linpred} +\alias{loo_predictive_interval} +\alias{loo_linpred.brmsfit} +\alias{loo_predictive_interval.brmsfit} +\title{Compute Weighted Expectations Using LOO} +\usage{ +\method{loo_predict}{brmsfit}( + object, + type = c("mean", "var", "quantile"), + probs = 0.5, + psis_object = NULL, + resp = NULL, + ... +) + +\method{loo_linpred}{brmsfit}( + object, + type = c("mean", "var", "quantile"), + probs = 0.5, + psis_object = NULL, + resp = NULL, + ... +) + +\method{loo_predictive_interval}{brmsfit}(object, prob = 0.9, psis_object = NULL, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{type}{The statistic to be computed on the results. +Can by either \code{"mean"} (default), \code{"var"}, or +\code{"quantile"}.} + +\item{probs}{A vector of quantiles to compute. +Only used if \code{type = quantile}.} + +\item{psis_object}{An optional object returned by \code{\link[loo]{psis}}. +If \code{psis_object} is missing then \code{\link[loo]{psis}} is executed +internally, which may be time consuming for models fit to very large datasets.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{...}{Optional arguments passed to the underlying methods that is +\code{\link[brms:log_lik.brmsfit]{log_lik}}, as well as +\code{\link[brms:posterior_predict.brmsfit]{posterior_predict}} or +\code{\link[brms:posterior_linpred.brmsfit]{posterior_linpred}}.} + +\item{prob}{For \code{loo_predictive_interval}, a scalar in \eqn{(0,1)} +indicating the desired probability mass to include in the intervals. The +default is \code{prob = 0.9} (\eqn{90}\% intervals).} +} +\value{ +\code{loo_predict} and \code{loo_linpred} return a vector with one + element per observation. The only exception is if \code{type = "quantile"} + and \code{length(probs) >= 2}, in which case a separate vector for each + element of \code{probs} is computed and they are returned in a matrix with + \code{length(probs)} rows and one column per observation. + + \code{loo_predictive_interval} returns a matrix with one row per + observation and two columns. + \code{loo_predictive_interval(..., prob = p)} is equivalent to + \code{loo_predict(..., type = "quantile", probs = c(a, 1-a))} with + \code{a = (1 - p)/2}, except it transposes the result and adds informative + column names. +} +\description{ +These functions are wrappers around the \code{\link[loo]{E_loo}} +function of the \pkg{loo} package. +} +\examples{ +\dontrun{ +## data from help("lm") +ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14) +trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69) +d <- data.frame( + weight = c(ctl, trt), + group = gl(2, 10, 20, labels = c("Ctl", "Trt")) +) +fit <- brm(weight ~ group, data = d) +loo_predictive_interval(fit, prob = 0.8) + +## optionally log-weights can be pre-computed and reused +psis <- loo::psis(-log_lik(fit), cores = 2) +loo_predictive_interval(fit, prob = 0.8, psis_object = psis) +loo_predict(fit, type = "var", psis_object = psis) +} + +} diff -Nru r-cran-brms-2.16.3/man/loo_R2.brmsfit.Rd r-cran-brms-2.17.0/man/loo_R2.brmsfit.Rd --- r-cran-brms-2.16.3/man/loo_R2.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/loo_R2.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,61 +1,61 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo_predict.R -\name{loo_R2.brmsfit} -\alias{loo_R2.brmsfit} -\alias{loo_R2} -\title{Compute a LOO-adjusted R-squared for regression models} -\usage{ -\method{loo_R2}{brmsfit}( - object, - resp = NULL, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{...}{Further arguments passed to -\code{\link[brms:posterior_epred.brmsfit]{posterior_epred}} and -\code{\link[brms:log_lik.brmsfit]{log_lik}}, -which are used in the computation of the R-squared values.} -} -\value{ -If \code{summary = TRUE}, an M x C matrix is returned - (M = number of response variables and c = \code{length(probs) + 2}) - containing summary statistics of the LOO-adjusted R-squared values. - If \code{summary = FALSE}, the posterior draws of the LOO-adjusted - R-squared values are returned in an S x M matrix (S is the number of draws). -} -\description{ -Compute a LOO-adjusted R-squared for regression models -} -\examples{ -\dontrun{ -fit <- brm(mpg ~ wt + cyl, data = mtcars) -summary(fit) -loo_R2(fit) - -# compute R2 with new data -nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) -loo_R2(fit, newdata = nd) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo_predict.R +\name{loo_R2.brmsfit} +\alias{loo_R2.brmsfit} +\alias{loo_R2} +\title{Compute a LOO-adjusted R-squared for regression models} +\usage{ +\method{loo_R2}{brmsfit}( + object, + resp = NULL, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{...}{Further arguments passed to +\code{\link[brms:posterior_epred.brmsfit]{posterior_epred}} and +\code{\link[brms:log_lik.brmsfit]{log_lik}}, +which are used in the computation of the R-squared values.} +} +\value{ +If \code{summary = TRUE}, an M x C matrix is returned + (M = number of response variables and c = \code{length(probs) + 2}) + containing summary statistics of the LOO-adjusted R-squared values. + If \code{summary = FALSE}, the posterior draws of the LOO-adjusted + R-squared values are returned in an S x M matrix (S is the number of draws). +} +\description{ +Compute a LOO-adjusted R-squared for regression models +} +\examples{ +\dontrun{ +fit <- brm(mpg ~ wt + cyl, data = mtcars) +summary(fit) +loo_R2(fit) + +# compute R2 with new data +nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) +loo_R2(fit, newdata = nd) +} + +} diff -Nru r-cran-brms-2.16.3/man/loo_subsample.brmsfit.Rd r-cran-brms-2.17.0/man/loo_subsample.brmsfit.Rd --- r-cran-brms-2.16.3/man/loo_subsample.brmsfit.Rd 2021-02-10 15:31:40.000000000 +0000 +++ r-cran-brms-2.17.0/man/loo_subsample.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,52 +1,52 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo_subsample.R -\name{loo_subsample.brmsfit} -\alias{loo_subsample.brmsfit} -\alias{loo_subsample} -\title{Efficient approximate leave-one-out cross-validation (LOO) using subsampling} -\usage{ -\method{loo_subsample}{brmsfit}(x, ..., compare = TRUE, resp = NULL, model_names = NULL) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{compare}{A flag indicating if the information criteria -of the models should be compared to each other -via \code{\link{loo_compare}}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} -} -\description{ -Efficient approximate leave-one-out cross-validation (LOO) using subsampling -} -\details{ -More details can be found on -\code{\link[loo:loo_subsample]{loo_subsample}}. -} -\examples{ -\dontrun{ -# model with population-level effects only -fit1 <- brm(rating ~ treat + period + carry, - data = inhaler) -(loo1 <- loo_subsample(fit1)) - -# model with an additional varying intercept for subjects -fit2 <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler) -(loo2 <- loo_subsample(fit2)) - -# compare both models -loo_compare(loo1, loo2) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo_subsample.R +\name{loo_subsample.brmsfit} +\alias{loo_subsample.brmsfit} +\alias{loo_subsample} +\title{Efficient approximate leave-one-out cross-validation (LOO) using subsampling} +\usage{ +\method{loo_subsample}{brmsfit}(x, ..., compare = TRUE, resp = NULL, model_names = NULL) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{compare}{A flag indicating if the information criteria +of the models should be compared to each other +via \code{\link{loo_compare}}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} +} +\description{ +Efficient approximate leave-one-out cross-validation (LOO) using subsampling +} +\details{ +More details can be found on +\code{\link[loo:loo_subsample]{loo_subsample}}. +} +\examples{ +\dontrun{ +# model with population-level effects only +fit1 <- brm(rating ~ treat + period + carry, + data = inhaler) +(loo1 <- loo_subsample(fit1)) + +# model with an additional varying intercept for subjects +fit2 <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler) +(loo2 <- loo_subsample(fit2)) + +# compare both models +loo_compare(loo1, loo2) +} + +} diff -Nru r-cran-brms-2.16.3/man/loss.Rd r-cran-brms-2.17.0/man/loss.Rd --- r-cran-brms-2.16.3/man/loss.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/loss.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,59 +1,59 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/datasets.R -\docType{data} -\name{loss} -\alias{loss} -\title{Cumulative Insurance Loss Payments} -\format{ -A data frame of 55 observations containing information - on the following 4 variables. -\describe{ - \item{AY}{Origin year of the insurance (1991 to 2000)} - \item{dev}{Deviation from the origin year in months} - \item{cum}{Cumulative loss payments} - \item{premium}{Achieved premiums for the given origin year} -} -} -\source{ -Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving - Models. \emph{CAS Research Papers}. -} -\usage{ -loss -} -\description{ -This dataset, discussed in Gesmann & Morris (2020), contains - cumulative insurance loss payments over the course of ten years. -} -\examples{ -\dontrun{ -# non-linear model to predict cumulative loss payments -fit_loss <- brm( - bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), - ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, - nl = TRUE), - data = loss, family = gaussian(), - prior = c( - prior(normal(5000, 1000), nlpar = "ult"), - prior(normal(1, 2), nlpar = "omega"), - prior(normal(45, 10), nlpar = "theta") - ), - control = list(adapt_delta = 0.9) -) - -# basic summaries -summary(fit_loss) -conditional_effects(fit_loss) - -# plot predictions per origin year -conditions <- data.frame(AY = unique(loss$AY)) -rownames(conditions) <- unique(loss$AY) -me_loss <- conditional_effects( - fit_loss, conditions = conditions, - re_formula = NULL, method = "predict" -) -plot(me_loss, ncol = 5, points = TRUE) -} - -} -\keyword{datasets} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasets.R +\docType{data} +\name{loss} +\alias{loss} +\title{Cumulative Insurance Loss Payments} +\format{ +A data frame of 55 observations containing information + on the following 4 variables. +\describe{ + \item{AY}{Origin year of the insurance (1991 to 2000)} + \item{dev}{Deviation from the origin year in months} + \item{cum}{Cumulative loss payments} + \item{premium}{Achieved premiums for the given origin year} +} +} +\source{ +Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving + Models. \emph{CAS Research Papers}. +} +\usage{ +loss +} +\description{ +This dataset, discussed in Gesmann & Morris (2020), contains + cumulative insurance loss payments over the course of ten years. +} +\examples{ +\dontrun{ +# non-linear model to predict cumulative loss payments +fit_loss <- brm( + bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), + ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, + nl = TRUE), + data = loss, family = gaussian(), + prior = c( + prior(normal(5000, 1000), nlpar = "ult"), + prior(normal(1, 2), nlpar = "omega"), + prior(normal(45, 10), nlpar = "theta") + ), + control = list(adapt_delta = 0.9) +) + +# basic summaries +summary(fit_loss) +conditional_effects(fit_loss) + +# plot predictions per origin year +conditions <- data.frame(AY = unique(loss$AY)) +rownames(conditions) <- unique(loss$AY) +me_loss <- conditional_effects( + fit_loss, conditions = conditions, + re_formula = NULL, method = "predict" +) +plot(me_loss, ncol = 5, points = TRUE) +} + +} +\keyword{datasets} diff -Nru r-cran-brms-2.16.3/man/make_conditions.Rd r-cran-brms-2.17.0/man/make_conditions.Rd --- r-cran-brms-2.16.3/man/make_conditions.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/make_conditions.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,36 +1,36 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/conditional_effects.R -\name{make_conditions} -\alias{make_conditions} -\title{Prepare Fully Crossed Conditions} -\usage{ -make_conditions(x, vars, ...) -} -\arguments{ -\item{x}{An \R object from which to extract the variables -that should be part of the conditions.} - -\item{vars}{Names of the variables that should be part of the conditions.} - -\item{...}{Arguments passed to \code{\link{rows2labels}}.} -} -\value{ -A \code{data.frame} where each row indicates a condition. -} -\description{ -This is a helper function to prepare fully crossed conditions primarily -for use with the \code{conditions} argument of \code{\link{conditional_effects}}. -Automatically creates labels for each row in the \code{cond__} column. -} -\details{ -For factor like variables, all levels are used as conditions. - For numeric variables, \code{mean + (-1:1) * SD} are used as conditions. -} -\examples{ -df <- data.frame(x = c("a", "b"), y = rnorm(10)) -make_conditions(df, vars = c("x", "y")) - -} -\seealso{ -\code{\link{conditional_effects}}, \code{\link{rows2labels}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/conditional_effects.R +\name{make_conditions} +\alias{make_conditions} +\title{Prepare Fully Crossed Conditions} +\usage{ +make_conditions(x, vars, ...) +} +\arguments{ +\item{x}{An \R object from which to extract the variables +that should be part of the conditions.} + +\item{vars}{Names of the variables that should be part of the conditions.} + +\item{...}{Arguments passed to \code{\link{rows2labels}}.} +} +\value{ +A \code{data.frame} where each row indicates a condition. +} +\description{ +This is a helper function to prepare fully crossed conditions primarily +for use with the \code{conditions} argument of \code{\link{conditional_effects}}. +Automatically creates labels for each row in the \code{cond__} column. +} +\details{ +For factor like variables, all levels are used as conditions. + For numeric variables, \code{mean + (-1:1) * SD} are used as conditions. +} +\examples{ +df <- data.frame(x = c("a", "b"), y = rnorm(10)) +make_conditions(df, vars = c("x", "y")) + +} +\seealso{ +\code{\link{conditional_effects}}, \code{\link{rows2labels}} +} diff -Nru r-cran-brms-2.16.3/man/make_stancode.Rd r-cran-brms-2.17.0/man/make_stancode.Rd --- r-cran-brms-2.16.3/man/make_stancode.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/make_stancode.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,143 +1,145 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/make_stancode.R -\name{make_stancode} -\alias{make_stancode} -\title{Stan Code for \pkg{brms} Models} -\usage{ -make_stancode( - formula, - data, - family = gaussian(), - prior = NULL, - autocor = NULL, - data2 = NULL, - cov_ranef = NULL, - sparse = NULL, - sample_prior = "no", - stanvars = NULL, - stan_funs = NULL, - knots = NULL, - threads = NULL, - normalize = getOption("brms.normalize", TRUE), - save_model = NULL, - ... -) -} -\arguments{ -\item{formula}{An object of class \code{\link[stats:formula]{formula}}, -\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can -be coerced to that classes): A symbolic description of the model to be -fitted. The details of model specification are explained in -\code{\link{brmsformula}}.} - -\item{data}{An object of class \code{data.frame} (or one that can be coerced -to that class) containing data of all variables used in the model.} - -\item{family}{A description of the response distribution and link function to -be used in the model. This can be a family function, a call to a family -function or a character string naming the family. Every family function has -a \code{link} argument allowing to specify the link function to be applied -on the response variable. If not specified, default links are used. For -details of supported families see \code{\link{brmsfamily}}. By default, a -linear \code{gaussian} model is applied. In multivariate models, -\code{family} might also be a list of families.} - -\item{prior}{One or more \code{brmsprior} objects created by -\code{\link{set_prior}} or related functions and combined using the -\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} -for more help.} - -\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object -describing the correlation structure within the response variable (i.e., -the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for -a description of the available correlation structures. Defaults to -\code{NULL}, corresponding to no correlations. In multivariate models, -\code{autocor} might also be a list of autocorrelation structures. -It is now recommend to specify autocorrelation terms directly -within \code{formula}. See \code{\link{brmsformula}} for more details.} - -\item{data2}{A named \code{list} of objects containing data, which -cannot be passed via argument \code{data}. Required for some objects -used in autocorrelation structures to specify dependency structures -as well as for within-group covariance matrices.} - -\item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the -(within) covariance structure of the group-level effects. The names of the -matrices should correspond to columns in \code{data} that are used as -grouping factors. All levels of the grouping factor should appear as -rownames of the corresponding matrix. This argument can be used, among -others to model pedigrees and phylogenetic effects. -It is now recommended to specify those matrices in the formula -interface using the \code{\link{gr}} and related functions. See -\code{vignette("brms_phylogenetics")} for more details.} - -\item{sparse}{(Deprecated) Logical; indicates whether the population-level -design matrices should be treated as sparse (defaults to \code{FALSE}). For -design matrices with many zeros, this can considerably reduce required -memory. Sampling speed is currently not improved or even slightly -decreased. It is now recommended to use the \code{sparse} argument of -\code{\link{brmsformula}} and related functions.} - -\item{sample_prior}{Indicate if draws from priors should be drawn -additionally to the posterior draws. Options are \code{"no"} (the -default), \code{"yes"}, and \code{"only"}. Among others, these draws can -be used to calculate Bayes factors for point hypotheses via -\code{\link{hypothesis}}. Please note that improper priors are not sampled, -including the default improper priors used by \code{brm}. See -\code{\link{set_prior}} on how to set (proper) priors. Please also note -that prior draws for the overall intercept are not obtained by default -for technical reasons. See \code{\link{brmsformula}} how to obtain prior -draws for the intercept. If \code{sample_prior} is set to \code{"only"}, -draws are drawn solely from the priors ignoring the likelihood, which -allows among others to generate draws from the prior predictive -distribution. In this case, all parameters must have proper priors.} - -\item{stanvars}{An optional \code{stanvars} object generated by function -\code{\link{stanvar}} to define additional variables for use in -\pkg{Stan}'s program blocks.} - -\item{stan_funs}{(Deprecated) An optional character string containing -self-defined \pkg{Stan} functions, which will be included in the functions -block of the generated \pkg{Stan} code. It is now recommended to use the -\code{stanvars} argument for this purpose instead.} - -\item{knots}{Optional list containing user specified knot values to be used -for basis construction of smoothing terms. See -\code{\link[mgcv:gamm]{gamm}} for more details.} - -\item{threads}{Number of threads to use in within-chain parallelization. For -more control over the threading process, \code{threads} may also be a -\code{brmsthreads} object created by \code{\link{threading}}. Within-chain -parallelization is experimental! We recommend its use only if you are -experienced with Stan's \code{reduce_sum} function and have a slow running -model that cannot be sped up by any other means.} - -\item{normalize}{Logical. Indicates whether normalization constants should -be included in the Stan code (defaults to \code{TRUE}). Setting it -to \code{FALSE} requires Stan version >= 2.25 to work. If \code{FALSE}, -sampling efficiency may be increased but some post processing functions -such as \code{\link{bridge_sampler}} will not be available. Can be -controlled globally for the current \R session via the `brms.normalize` -option.} - -\item{save_model}{Either \code{NULL} or a character string. In the latter -case, the model's Stan code is saved via \code{\link{cat}} in a text file -named after the string supplied in \code{save_model}.} - -\item{...}{Other arguments for internal usage only.} -} -\value{ -A character string containing the fully commented \pkg{Stan} code - to fit a \pkg{brms} model. -} -\description{ -Generate Stan code for \pkg{brms} models -} -\examples{ -make_stancode(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = "cumulative") - -make_stancode(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = "poisson") - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/make_stancode.R +\name{make_stancode} +\alias{make_stancode} +\title{Stan Code for \pkg{brms} Models} +\usage{ +make_stancode( + formula, + data, + family = gaussian(), + prior = NULL, + autocor = NULL, + data2 = NULL, + cov_ranef = NULL, + sparse = NULL, + sample_prior = "no", + stanvars = NULL, + stan_funs = NULL, + knots = NULL, + threads = getOption("brms.threads", NULL), + normalize = getOption("brms.normalize", TRUE), + save_model = NULL, + ... +) +} +\arguments{ +\item{formula}{An object of class \code{\link[stats:formula]{formula}}, +\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can +be coerced to that classes): A symbolic description of the model to be +fitted. The details of model specification are explained in +\code{\link{brmsformula}}.} + +\item{data}{An object of class \code{data.frame} (or one that can be coerced +to that class) containing data of all variables used in the model.} + +\item{family}{A description of the response distribution and link function to +be used in the model. This can be a family function, a call to a family +function or a character string naming the family. Every family function has +a \code{link} argument allowing to specify the link function to be applied +on the response variable. If not specified, default links are used. For +details of supported families see \code{\link{brmsfamily}}. By default, a +linear \code{gaussian} model is applied. In multivariate models, +\code{family} might also be a list of families.} + +\item{prior}{One or more \code{brmsprior} objects created by +\code{\link{set_prior}} or related functions and combined using the +\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} +for more help.} + +\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object +describing the correlation structure within the response variable (i.e., +the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for +a description of the available correlation structures. Defaults to +\code{NULL}, corresponding to no correlations. In multivariate models, +\code{autocor} might also be a list of autocorrelation structures. +It is now recommend to specify autocorrelation terms directly +within \code{formula}. See \code{\link{brmsformula}} for more details.} + +\item{data2}{A named \code{list} of objects containing data, which +cannot be passed via argument \code{data}. Required for some objects +used in autocorrelation structures to specify dependency structures +as well as for within-group covariance matrices.} + +\item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the +(within) covariance structure of the group-level effects. The names of the +matrices should correspond to columns in \code{data} that are used as +grouping factors. All levels of the grouping factor should appear as +rownames of the corresponding matrix. This argument can be used, among +others to model pedigrees and phylogenetic effects. +It is now recommended to specify those matrices in the formula +interface using the \code{\link{gr}} and related functions. See +\code{vignette("brms_phylogenetics")} for more details.} + +\item{sparse}{(Deprecated) Logical; indicates whether the population-level +design matrices should be treated as sparse (defaults to \code{FALSE}). For +design matrices with many zeros, this can considerably reduce required +memory. Sampling speed is currently not improved or even slightly +decreased. It is now recommended to use the \code{sparse} argument of +\code{\link{brmsformula}} and related functions.} + +\item{sample_prior}{Indicate if draws from priors should be drawn +additionally to the posterior draws. Options are \code{"no"} (the +default), \code{"yes"}, and \code{"only"}. Among others, these draws can +be used to calculate Bayes factors for point hypotheses via +\code{\link{hypothesis}}. Please note that improper priors are not sampled, +including the default improper priors used by \code{brm}. See +\code{\link{set_prior}} on how to set (proper) priors. Please also note +that prior draws for the overall intercept are not obtained by default +for technical reasons. See \code{\link{brmsformula}} how to obtain prior +draws for the intercept. If \code{sample_prior} is set to \code{"only"}, +draws are drawn solely from the priors ignoring the likelihood, which +allows among others to generate draws from the prior predictive +distribution. In this case, all parameters must have proper priors.} + +\item{stanvars}{An optional \code{stanvars} object generated by function +\code{\link{stanvar}} to define additional variables for use in +\pkg{Stan}'s program blocks.} + +\item{stan_funs}{(Deprecated) An optional character string containing +self-defined \pkg{Stan} functions, which will be included in the functions +block of the generated \pkg{Stan} code. It is now recommended to use the +\code{stanvars} argument for this purpose instead.} + +\item{knots}{Optional list containing user specified knot values to be used +for basis construction of smoothing terms. See +\code{\link[mgcv:gamm]{gamm}} for more details.} + +\item{threads}{Number of threads to use in within-chain parallelization. For +more control over the threading process, \code{threads} may also be a +\code{brmsthreads} object created by \code{\link{threading}}. Within-chain +parallelization is experimental! We recommend its use only if you are +experienced with Stan's \code{reduce_sum} function and have a slow running +model that cannot be sped up by any other means. Can be set globally for +the current \R session via the \code{"brms.threads"} option (see +\code{\link{options}}).} + +\item{normalize}{Logical. Indicates whether normalization constants should +be included in the Stan code (defaults to \code{TRUE}). Setting it +to \code{FALSE} requires Stan version >= 2.25 to work. If \code{FALSE}, +sampling efficiency may be increased but some post processing functions +such as \code{\link{bridge_sampler}} will not be available. Can be +controlled globally for the current \R session via the `brms.normalize` +option.} + +\item{save_model}{Either \code{NULL} or a character string. In the latter +case, the model's Stan code is saved via \code{\link{cat}} in a text file +named after the string supplied in \code{save_model}.} + +\item{...}{Other arguments for internal usage only.} +} +\value{ +A character string containing the fully commented \pkg{Stan} code + to fit a \pkg{brms} model. +} +\description{ +Generate Stan code for \pkg{brms} models +} +\examples{ +make_stancode(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = "cumulative") + +make_stancode(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = "poisson") + +} diff -Nru r-cran-brms-2.16.3/man/make_standata.Rd r-cran-brms-2.17.0/man/make_standata.Rd --- r-cran-brms-2.16.3/man/make_standata.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/make_standata.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,120 +1,122 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/make_standata.R -\name{make_standata} -\alias{make_standata} -\title{Data for \pkg{brms} Models} -\usage{ -make_standata( - formula, - data, - family = gaussian(), - prior = NULL, - autocor = NULL, - data2 = NULL, - cov_ranef = NULL, - sample_prior = "no", - stanvars = NULL, - threads = NULL, - knots = NULL, - ... -) -} -\arguments{ -\item{formula}{An object of class \code{\link[stats:formula]{formula}}, -\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can -be coerced to that classes): A symbolic description of the model to be -fitted. The details of model specification are explained in -\code{\link{brmsformula}}.} - -\item{data}{An object of class \code{data.frame} (or one that can be coerced -to that class) containing data of all variables used in the model.} - -\item{family}{A description of the response distribution and link function to -be used in the model. This can be a family function, a call to a family -function or a character string naming the family. Every family function has -a \code{link} argument allowing to specify the link function to be applied -on the response variable. If not specified, default links are used. For -details of supported families see \code{\link{brmsfamily}}. By default, a -linear \code{gaussian} model is applied. In multivariate models, -\code{family} might also be a list of families.} - -\item{prior}{One or more \code{brmsprior} objects created by -\code{\link{set_prior}} or related functions and combined using the -\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} -for more help.} - -\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object -describing the correlation structure within the response variable (i.e., -the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for -a description of the available correlation structures. Defaults to -\code{NULL}, corresponding to no correlations. In multivariate models, -\code{autocor} might also be a list of autocorrelation structures. -It is now recommend to specify autocorrelation terms directly -within \code{formula}. See \code{\link{brmsformula}} for more details.} - -\item{data2}{A named \code{list} of objects containing data, which -cannot be passed via argument \code{data}. Required for some objects -used in autocorrelation structures to specify dependency structures -as well as for within-group covariance matrices.} - -\item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the -(within) covariance structure of the group-level effects. The names of the -matrices should correspond to columns in \code{data} that are used as -grouping factors. All levels of the grouping factor should appear as -rownames of the corresponding matrix. This argument can be used, among -others to model pedigrees and phylogenetic effects. -It is now recommended to specify those matrices in the formula -interface using the \code{\link{gr}} and related functions. See -\code{vignette("brms_phylogenetics")} for more details.} - -\item{sample_prior}{Indicate if draws from priors should be drawn -additionally to the posterior draws. Options are \code{"no"} (the -default), \code{"yes"}, and \code{"only"}. Among others, these draws can -be used to calculate Bayes factors for point hypotheses via -\code{\link{hypothesis}}. Please note that improper priors are not sampled, -including the default improper priors used by \code{brm}. See -\code{\link{set_prior}} on how to set (proper) priors. Please also note -that prior draws for the overall intercept are not obtained by default -for technical reasons. See \code{\link{brmsformula}} how to obtain prior -draws for the intercept. If \code{sample_prior} is set to \code{"only"}, -draws are drawn solely from the priors ignoring the likelihood, which -allows among others to generate draws from the prior predictive -distribution. In this case, all parameters must have proper priors.} - -\item{stanvars}{An optional \code{stanvars} object generated by function -\code{\link{stanvar}} to define additional variables for use in -\pkg{Stan}'s program blocks.} - -\item{threads}{Number of threads to use in within-chain parallelization. For -more control over the threading process, \code{threads} may also be a -\code{brmsthreads} object created by \code{\link{threading}}. Within-chain -parallelization is experimental! We recommend its use only if you are -experienced with Stan's \code{reduce_sum} function and have a slow running -model that cannot be sped up by any other means.} - -\item{knots}{Optional list containing user specified knot values to be used -for basis construction of smoothing terms. See -\code{\link[mgcv:gamm]{gamm}} for more details.} - -\item{...}{Other arguments for internal use.} -} -\value{ -A named list of objects containing the required data - to fit a \pkg{brms} model with \pkg{Stan}. -} -\description{ -Generate data for \pkg{brms} models to be passed to \pkg{Stan} -} -\examples{ -sdata1 <- make_standata(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = "cumulative") -str(sdata1) - -sdata2 <- make_standata(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = "poisson") -str(sdata2) - -} -\author{ -Paul-Christian Buerkner \email{paul.buerkner@gmail.com} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/make_standata.R +\name{make_standata} +\alias{make_standata} +\title{Data for \pkg{brms} Models} +\usage{ +make_standata( + formula, + data, + family = gaussian(), + prior = NULL, + autocor = NULL, + data2 = NULL, + cov_ranef = NULL, + sample_prior = "no", + stanvars = NULL, + threads = getOption("brms.threads", NULL), + knots = NULL, + ... +) +} +\arguments{ +\item{formula}{An object of class \code{\link[stats:formula]{formula}}, +\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can +be coerced to that classes): A symbolic description of the model to be +fitted. The details of model specification are explained in +\code{\link{brmsformula}}.} + +\item{data}{An object of class \code{data.frame} (or one that can be coerced +to that class) containing data of all variables used in the model.} + +\item{family}{A description of the response distribution and link function to +be used in the model. This can be a family function, a call to a family +function or a character string naming the family. Every family function has +a \code{link} argument allowing to specify the link function to be applied +on the response variable. If not specified, default links are used. For +details of supported families see \code{\link{brmsfamily}}. By default, a +linear \code{gaussian} model is applied. In multivariate models, +\code{family} might also be a list of families.} + +\item{prior}{One or more \code{brmsprior} objects created by +\code{\link{set_prior}} or related functions and combined using the +\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} +for more help.} + +\item{autocor}{(Deprecated) An optional \code{\link{cor_brms}} object +describing the correlation structure within the response variable (i.e., +the 'autocorrelation'). See the documentation of \code{\link{cor_brms}} for +a description of the available correlation structures. Defaults to +\code{NULL}, corresponding to no correlations. In multivariate models, +\code{autocor} might also be a list of autocorrelation structures. +It is now recommend to specify autocorrelation terms directly +within \code{formula}. See \code{\link{brmsformula}} for more details.} + +\item{data2}{A named \code{list} of objects containing data, which +cannot be passed via argument \code{data}. Required for some objects +used in autocorrelation structures to specify dependency structures +as well as for within-group covariance matrices.} + +\item{cov_ranef}{(Deprecated) A list of matrices that are proportional to the +(within) covariance structure of the group-level effects. The names of the +matrices should correspond to columns in \code{data} that are used as +grouping factors. All levels of the grouping factor should appear as +rownames of the corresponding matrix. This argument can be used, among +others to model pedigrees and phylogenetic effects. +It is now recommended to specify those matrices in the formula +interface using the \code{\link{gr}} and related functions. See +\code{vignette("brms_phylogenetics")} for more details.} + +\item{sample_prior}{Indicate if draws from priors should be drawn +additionally to the posterior draws. Options are \code{"no"} (the +default), \code{"yes"}, and \code{"only"}. Among others, these draws can +be used to calculate Bayes factors for point hypotheses via +\code{\link{hypothesis}}. Please note that improper priors are not sampled, +including the default improper priors used by \code{brm}. See +\code{\link{set_prior}} on how to set (proper) priors. Please also note +that prior draws for the overall intercept are not obtained by default +for technical reasons. See \code{\link{brmsformula}} how to obtain prior +draws for the intercept. If \code{sample_prior} is set to \code{"only"}, +draws are drawn solely from the priors ignoring the likelihood, which +allows among others to generate draws from the prior predictive +distribution. In this case, all parameters must have proper priors.} + +\item{stanvars}{An optional \code{stanvars} object generated by function +\code{\link{stanvar}} to define additional variables for use in +\pkg{Stan}'s program blocks.} + +\item{threads}{Number of threads to use in within-chain parallelization. For +more control over the threading process, \code{threads} may also be a +\code{brmsthreads} object created by \code{\link{threading}}. Within-chain +parallelization is experimental! We recommend its use only if you are +experienced with Stan's \code{reduce_sum} function and have a slow running +model that cannot be sped up by any other means. Can be set globally for +the current \R session via the \code{"brms.threads"} option (see +\code{\link{options}}).} + +\item{knots}{Optional list containing user specified knot values to be used +for basis construction of smoothing terms. See +\code{\link[mgcv:gamm]{gamm}} for more details.} + +\item{...}{Other arguments for internal use.} +} +\value{ +A named list of objects containing the required data + to fit a \pkg{brms} model with \pkg{Stan}. +} +\description{ +Generate data for \pkg{brms} models to be passed to \pkg{Stan} +} +\examples{ +sdata1 <- make_standata(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = "cumulative") +str(sdata1) + +sdata2 <- make_standata(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = "poisson") +str(sdata2) + +} +\author{ +Paul-Christian Buerkner \email{paul.buerkner@gmail.com} +} diff -Nru r-cran-brms-2.16.3/man/ma.Rd r-cran-brms-2.17.0/man/ma.Rd --- r-cran-brms-2.16.3/man/ma.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/ma.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,51 +1,51 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ac.R -\name{ma} -\alias{ma} -\title{Set up MA(q) correlation structures} -\usage{ -ma(time = NA, gr = NA, q = 1, cov = FALSE) -} -\arguments{ -\item{time}{An optional time variable specifying the time ordering -of the observations. By default, the existing order of the observations -in the data is used.} - -\item{gr}{An optional grouping variable. If specified, the correlation -structure is assumed to apply only to observations within the same grouping -level.} - -\item{q}{A non-negative integer specifying the moving average (MA) -order of the ARMA structure. Default is \code{1}.} - -\item{cov}{A flag indicating whether ARMA effects should be estimated by -means of residual covariance matrices. This is currently only possible for -stationary ARMA effects of order 1. If the model family does not have -natural residuals, latent residuals are added automatically. If -\code{FALSE} (the default), a regression formulation is used that is -considerably faster and allows for ARMA effects of order higher than 1 but -is only available for \code{gaussian} models and some of its -generalizations.} -} -\value{ -An object of class \code{'arma_term'}, which is a list - of arguments to be interpreted by the formula - parsing functions of \pkg{brms}. -} -\description{ -Set up a moving average (MA) term of order q in \pkg{brms}. The function does -not evaluate its arguments -- it exists purely to help set up a model with -MA terms. -} -\examples{ -\dontrun{ -data("LakeHuron") -LakeHuron <- as.data.frame(LakeHuron) -fit <- brm(x ~ ma(p = 2), data = LakeHuron) -summary(fit) -} - -} -\seealso{ -\code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ar}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ac.R +\name{ma} +\alias{ma} +\title{Set up MA(q) correlation structures} +\usage{ +ma(time = NA, gr = NA, q = 1, cov = FALSE) +} +\arguments{ +\item{time}{An optional time variable specifying the time ordering +of the observations. By default, the existing order of the observations +in the data is used.} + +\item{gr}{An optional grouping variable. If specified, the correlation +structure is assumed to apply only to observations within the same grouping +level.} + +\item{q}{A non-negative integer specifying the moving average (MA) +order of the ARMA structure. Default is \code{1}.} + +\item{cov}{A flag indicating whether ARMA effects should be estimated by +means of residual covariance matrices. This is currently only possible for +stationary ARMA effects of order 1. If the model family does not have +natural residuals, latent residuals are added automatically. If +\code{FALSE} (the default), a regression formulation is used that is +considerably faster and allows for ARMA effects of order higher than 1 but +is only available for \code{gaussian} models and some of its +generalizations.} +} +\value{ +An object of class \code{'arma_term'}, which is a list + of arguments to be interpreted by the formula + parsing functions of \pkg{brms}. +} +\description{ +Set up a moving average (MA) term of order q in \pkg{brms}. The function does +not evaluate its arguments -- it exists purely to help set up a model with +MA terms. +} +\examples{ +\dontrun{ +data("LakeHuron") +LakeHuron <- as.data.frame(LakeHuron) +fit <- brm(x ~ ma(p = 2), data = LakeHuron) +summary(fit) +} + +} +\seealso{ +\code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ar}} +} diff -Nru r-cran-brms-2.16.3/man/mcmc_plot.brmsfit.Rd r-cran-brms-2.17.0/man/mcmc_plot.brmsfit.Rd --- r-cran-brms-2.16.3/man/mcmc_plot.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/mcmc_plot.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,92 +1,92 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R -\name{mcmc_plot.brmsfit} -\alias{mcmc_plot.brmsfit} -\alias{stanplot} -\alias{stanplot.brmsfit} -\alias{mcmc_plot} -\title{MCMC Plots Implemented in \pkg{bayesplot}} -\usage{ -\method{mcmc_plot}{brmsfit}( - object, - pars = NA, - type = "intervals", - variable = NULL, - regex = FALSE, - fixed = FALSE, - ... -) - -mcmc_plot(object, ...) -} -\arguments{ -\item{object}{An \R object typically of class \code{brmsfit}} - -\item{pars}{Deprecated alias of \code{variable}. -Names of the parameters to plot, as given by a -character vector or a regular expression.} - -\item{type}{The type of the plot. -Supported types are (as names) \code{hist}, \code{dens}, -\code{hist_by_chain}, \code{dens_overlay}, -\code{violin}, \code{intervals}, \code{areas}, \code{acf}, -\code{acf_bar},\code{trace}, \code{trace_highlight}, \code{scatter}, -\code{rhat}, \code{rhat_hist}, \code{neff}, \code{neff_hist} -\code{nuts_acceptance}, \code{nuts_divergence}, -\code{nuts_stepsize}, \code{nuts_treedepth}, and \code{nuts_energy}. -For an overview on the various plot types see -\code{\link[bayesplot:MCMC-overview]{MCMC-overview}}.} - -\item{variable}{Names of the variables (parameters) to plot, as given by a -character vector or a regular expression (if \code{regex = TRUE}). By -default, a hopefully not too large selection of variables is plotted.} - -\item{regex}{Logical; Indicates whether \code{variable} should -be treated as regular expressions. Defaults to \code{FALSE}.} - -\item{fixed}{(Deprecated) Indicates whether parameter names -should be matched exactly (\code{TRUE}) or treated as -regular expressions (\code{FALSE}). Default is \code{FALSE} -and only works with argument \code{pars}.} - -\item{...}{Additional arguments passed to the plotting functions. -See \code{\link[bayesplot:MCMC-overview]{MCMC-overview}} for -more details.} -} -\value{ -A \code{\link[ggplot2:ggplot]{ggplot}} object - that can be further customized using the \pkg{ggplot2} package. -} -\description{ -Convenient way to call MCMC plotting functions -implemented in the \pkg{bayesplot} package. -} -\details{ -Also consider using the \pkg{shinystan} package available via - method \code{\link{launch_shinystan}} in \pkg{brms} for flexible - and interactive visual analysis. -} -\examples{ -\dontrun{ -model <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = "poisson") - -# plot posterior intervals -mcmc_plot(model) - -# only show population-level effects in the plots -mcmc_plot(model, variable = "^b_", regex = TRUE) - -# show histograms of the posterior distributions -mcmc_plot(model, type = "hist") - -# plot some diagnostics of the sampler -mcmc_plot(model, type = "neff") -mcmc_plot(model, type = "rhat") - -# plot some diagnostics specific to the NUTS sampler -mcmc_plot(model, type = "nuts_acceptance") -mcmc_plot(model, type = "nuts_divergence") -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.R +\name{mcmc_plot.brmsfit} +\alias{mcmc_plot.brmsfit} +\alias{stanplot} +\alias{stanplot.brmsfit} +\alias{mcmc_plot} +\title{MCMC Plots Implemented in \pkg{bayesplot}} +\usage{ +\method{mcmc_plot}{brmsfit}( + object, + pars = NA, + type = "intervals", + variable = NULL, + regex = FALSE, + fixed = FALSE, + ... +) + +mcmc_plot(object, ...) +} +\arguments{ +\item{object}{An \R object typically of class \code{brmsfit}} + +\item{pars}{Deprecated alias of \code{variable}. +Names of the parameters to plot, as given by a +character vector or a regular expression.} + +\item{type}{The type of the plot. +Supported types are (as names) \code{hist}, \code{dens}, +\code{hist_by_chain}, \code{dens_overlay}, +\code{violin}, \code{intervals}, \code{areas}, \code{acf}, +\code{acf_bar},\code{trace}, \code{trace_highlight}, \code{scatter}, +\code{rhat}, \code{rhat_hist}, \code{neff}, \code{neff_hist} +\code{nuts_acceptance}, \code{nuts_divergence}, +\code{nuts_stepsize}, \code{nuts_treedepth}, and \code{nuts_energy}. +For an overview on the various plot types see +\code{\link[bayesplot:MCMC-overview]{MCMC-overview}}.} + +\item{variable}{Names of the variables (parameters) to plot, as given by a +character vector or a regular expression (if \code{regex = TRUE}). By +default, a hopefully not too large selection of variables is plotted.} + +\item{regex}{Logical; Indicates whether \code{variable} should +be treated as regular expressions. Defaults to \code{FALSE}.} + +\item{fixed}{(Deprecated) Indicates whether parameter names +should be matched exactly (\code{TRUE}) or treated as +regular expressions (\code{FALSE}). Default is \code{FALSE} +and only works with argument \code{pars}.} + +\item{...}{Additional arguments passed to the plotting functions. +See \code{\link[bayesplot:MCMC-overview]{MCMC-overview}} for +more details.} +} +\value{ +A \code{\link[ggplot2:ggplot]{ggplot}} object + that can be further customized using the \pkg{ggplot2} package. +} +\description{ +Convenient way to call MCMC plotting functions +implemented in the \pkg{bayesplot} package. +} +\details{ +Also consider using the \pkg{shinystan} package available via + method \code{\link{launch_shinystan}} in \pkg{brms} for flexible + and interactive visual analysis. +} +\examples{ +\dontrun{ +model <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = "poisson") + +# plot posterior intervals +mcmc_plot(model) + +# only show population-level effects in the plots +mcmc_plot(model, variable = "^b_", regex = TRUE) + +# show histograms of the posterior distributions +mcmc_plot(model, type = "hist") + +# plot some diagnostics of the sampler +mcmc_plot(model, type = "neff") +mcmc_plot(model, type = "rhat") + +# plot some diagnostics specific to the NUTS sampler +mcmc_plot(model, type = "nuts_acceptance") +mcmc_plot(model, type = "nuts_divergence") +} + +} diff -Nru r-cran-brms-2.16.3/man/me.Rd r-cran-brms-2.17.0/man/me.Rd --- r-cran-brms-2.16.3/man/me.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/me.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,54 +1,54 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-sp.R -\name{me} -\alias{me} -\title{Predictors with Measurement Error in \pkg{brms} Models} -\usage{ -me(x, sdx, gr = NULL) -} -\arguments{ -\item{x}{The variable measured with error.} - -\item{sdx}{Known measurement error of \code{x} -treated as standard deviation.} - -\item{gr}{Optional grouping factor to specify which -values of \code{x} correspond to the same value of the -latent variable. If \code{NULL} (the default) each -observation will have its own value of the latent variable.} -} -\description{ -(Soft deprecated) Specify predictors with measurement error. The function -does not evaluate its arguments -- it exists purely to help set up a model. -} -\details{ -For detailed documentation see \code{help(brmsformula)}. -\code{me} terms are soft deprecated in favor of the more -general and consistent \code{\link{mi}} terms. -By default, latent noise-free variables are assumed -to be correlated. To change that, add \code{set_mecor(FALSE)} -to your model formula object (see examples). -} -\examples{ -\dontrun{ -# sample some data -N <- 100 -dat <- data.frame( - y = rnorm(N), x1 = rnorm(N), - x2 = rnorm(N), sdx = abs(rnorm(N, 1)) - ) -# fit a simple error-in-variables model -fit1 <- brm(y ~ me(x1, sdx) + me(x2, sdx), data = dat, - save_pars = save_pars(latent = TRUE)) -summary(fit1) - -# turn off modeling of correlations -bform <- bf(y ~ me(x1, sdx) + me(x2, sdx)) + set_mecor(FALSE) -fit2 <- brm(bform, data = dat, save_pars = save_pars(latent = TRUE)) -summary(fit2) -} - -} -\seealso{ -\code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-sp.R +\name{me} +\alias{me} +\title{Predictors with Measurement Error in \pkg{brms} Models} +\usage{ +me(x, sdx, gr = NULL) +} +\arguments{ +\item{x}{The variable measured with error.} + +\item{sdx}{Known measurement error of \code{x} +treated as standard deviation.} + +\item{gr}{Optional grouping factor to specify which +values of \code{x} correspond to the same value of the +latent variable. If \code{NULL} (the default) each +observation will have its own value of the latent variable.} +} +\description{ +(Soft deprecated) Specify predictors with measurement error. The function +does not evaluate its arguments -- it exists purely to help set up a model. +} +\details{ +For detailed documentation see \code{help(brmsformula)}. +\code{me} terms are soft deprecated in favor of the more +general and consistent \code{\link{mi}} terms. +By default, latent noise-free variables are assumed +to be correlated. To change that, add \code{set_mecor(FALSE)} +to your model formula object (see examples). +} +\examples{ +\dontrun{ +# sample some data +N <- 100 +dat <- data.frame( + y = rnorm(N), x1 = rnorm(N), + x2 = rnorm(N), sdx = abs(rnorm(N, 1)) + ) +# fit a simple error-in-variables model +fit1 <- brm(y ~ me(x1, sdx) + me(x2, sdx), data = dat, + save_pars = save_pars(latent = TRUE)) +summary(fit1) + +# turn off modeling of correlations +bform <- bf(y ~ me(x1, sdx) + me(x2, sdx)) + set_mecor(FALSE) +fit2 <- brm(bform, data = dat, save_pars = save_pars(latent = TRUE)) +summary(fit2) +} + +} +\seealso{ +\code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} +} diff -Nru r-cran-brms-2.16.3/man/mi.Rd r-cran-brms-2.17.0/man/mi.Rd --- r-cran-brms-2.16.3/man/mi.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/mi.Rd 2022-04-08 11:57:41.000000000 +0000 @@ -1,75 +1,77 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-sp.R -\name{mi} -\alias{mi} -\title{Predictors with Missing Values in \pkg{brms} Models} -\usage{ -mi(x, idx = NA) -} -\arguments{ -\item{x}{The variable containing missing values.} - -\item{idx}{An optional variable containing indices of observations in `x` -that are to be used in the model. This is mostly relevant in partially -subsetted models (via \code{resp_subset}) but may also have other -applications that I haven't thought of.} -} -\description{ -Specify predictor term with missing values in \pkg{brms}. The function does -not evaluate its arguments -- it exists purely to help set up a model. -} -\details{ -For detailed documentation see \code{help(brmsformula)}. -} -\examples{ -\dontrun{ -data("nhanes", package = "mice") -N <- nrow(nhanes) - -# simple model with missing data -bform1 <- bf(bmi | mi() ~ age * mi(chl)) + - bf(chl | mi() ~ age) + - set_rescor(FALSE) - -fit1 <- brm(bform1, data = nhanes) - -summary(fit1) -plot(conditional_effects(fit1, resp = "bmi"), ask = FALSE) -loo(fit1, newdata = na.omit(fit1$data)) - -# simulate some measurement noise -nhanes$se <- rexp(N, 2) - -# measurement noise can be handled within 'mi' terms -# with or without the presence of missing values -bform2 <- bf(bmi | mi() ~ age * mi(chl)) + - bf(chl | mi(se) ~ age) + - set_rescor(FALSE) - -fit2 <- brm(bform2, data = nhanes) - -summary(fit2) -plot(conditional_effects(fit2, resp = "bmi"), ask = FALSE) - -# 'mi' terms can also be used when some responses are subsetted -nhanes$sub <- TRUE -nhanes$sub[1:2] <- FALSE -nhanes$id <- 1:N -nhanes$idx <- sample(3:N, N, TRUE) - -# this requires the addition term 'index' being specified -# in the subsetted part of the model -bform3 <- bf(bmi | mi() ~ age * mi(chl, idx)) + - bf(chl | mi(se) + subset(sub) + index(id) ~ age) + - set_rescor(FALSE) - -fit3 <- brm(bform3, data = nhanes) - -summary(fit3) -plot(conditional_effects(fit3, resp = "bmi"), ask = FALSE) -} - -} -\seealso{ -\code{\link{brmsformula}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-sp.R +\name{mi} +\alias{mi} +\title{Predictors with Missing Values in \pkg{brms} Models} +\usage{ +mi(x, idx = NA) +} +\arguments{ +\item{x}{The variable containing missing values.} + +\item{idx}{An optional variable containing indices of observations in `x` +that are to be used in the model. This is mostly relevant in partially +subsetted models (via \code{resp_subset}) but may also have other +applications that I haven't thought of.} +} +\description{ +Specify predictor term with missing values in \pkg{brms}. The function does +not evaluate its arguments -- it exists purely to help set up a model. +For documentation on how to specify missing values in response variables, +see \code{\link{resp_mi}}. +} +\details{ +For detailed documentation see \code{help(brmsformula)}. +} +\examples{ +\dontrun{ +data("nhanes", package = "mice") +N <- nrow(nhanes) + +# simple model with missing data +bform1 <- bf(bmi | mi() ~ age * mi(chl)) + + bf(chl | mi() ~ age) + + set_rescor(FALSE) + +fit1 <- brm(bform1, data = nhanes) + +summary(fit1) +plot(conditional_effects(fit1, resp = "bmi"), ask = FALSE) +loo(fit1, newdata = na.omit(fit1$data)) + +# simulate some measurement noise +nhanes$se <- rexp(N, 2) + +# measurement noise can be handled within 'mi' terms +# with or without the presence of missing values +bform2 <- bf(bmi | mi() ~ age * mi(chl)) + + bf(chl | mi(se) ~ age) + + set_rescor(FALSE) + +fit2 <- brm(bform2, data = nhanes) + +summary(fit2) +plot(conditional_effects(fit2, resp = "bmi"), ask = FALSE) + +# 'mi' terms can also be used when some responses are subsetted +nhanes$sub <- TRUE +nhanes$sub[1:2] <- FALSE +nhanes$id <- 1:N +nhanes$idx <- sample(3:N, N, TRUE) + +# this requires the addition term 'index' being specified +# in the subsetted part of the model +bform3 <- bf(bmi | mi() ~ age * mi(chl, idx)) + + bf(chl | mi(se) + subset(sub) + index(id) ~ age) + + set_rescor(FALSE) + +fit3 <- brm(bform3, data = nhanes) + +summary(fit3) +plot(conditional_effects(fit3, resp = "bmi"), ask = FALSE) +} + +} +\seealso{ +\code{\link{brmsformula}} +} diff -Nru r-cran-brms-2.16.3/man/mixture.Rd r-cran-brms-2.17.0/man/mixture.Rd --- r-cran-brms-2.16.3/man/mixture.Rd 2020-02-27 16:28:56.000000000 +0000 +++ r-cran-brms-2.17.0/man/mixture.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -7,17 +7,17 @@ mixture(..., flist = NULL, nmix = 1, order = NULL) } \arguments{ -\item{...}{One or more objects providing a description of the -response distributions to be combined in the mixture model. -These can be family functions, calls to family functions or -character strings naming the families. For details of supported +\item{...}{One or more objects providing a description of the +response distributions to be combined in the mixture model. +These can be family functions, calls to family functions or +character strings naming the families. For details of supported families see \code{\link{brmsfamily}}.} -\item{flist}{Optional list of objects, which are treated in the +\item{flist}{Optional list of objects, which are treated in the same way as objects passed via the \code{...} argument.} \item{nmix}{Optional numeric vector specifying the number of times -each family is repeated. If specified, it must have the same length +each family is repeated. If specified, it must have the same length as the number of families passed via \code{...} and \code{flist}.} \item{order}{Ordering constraint to identify mixture components. @@ -50,7 +50,7 @@ For most mixture models, you may want to specify priors on the population-level intercepts via \code{\link{set_prior}} to improve -convergence. In addition, it is sometimes necessary to set \code{inits = 0} +convergence. In addition, it is sometimes necessary to set \code{init = 0} in the call to \code{\link{brm}} to allow chains to initialize properly. For more details on the specification of mixture @@ -61,7 +61,7 @@ ## simulate some data set.seed(1234) dat <- data.frame( - y = c(rnorm(200), rnorm(100, 6)), + y = c(rnorm(200), rnorm(100, 6)), x = rnorm(300), z = sample(0:1, 300, TRUE) ) @@ -73,31 +73,31 @@ prior(normal(5, 7), Intercept, dpar = mu2) ) fit1 <- brm(bf(y ~ x + z), dat, family = mix, - prior = prior, chains = 2) + prior = prior, chains = 2) summary(fit1) pp_check(fit1) ## use different predictors for the components fit2 <- brm(bf(y ~ 1, mu1 ~ x, mu2 ~ z), dat, family = mix, - prior = prior, chains = 2) + prior = prior, chains = 2) summary(fit2) ## fix the mixing proportions -fit3 <- brm(bf(y ~ x + z, theta1 = 1, theta2 = 2), - dat, family = mix, prior = prior, - inits = 0, chains = 2) +fit3 <- brm(bf(y ~ x + z, theta1 = 1, theta2 = 2), + dat, family = mix, prior = prior, + init = 0, chains = 2) summary(fit3) -pp_check(fit3) +pp_check(fit3) ## predict the mixing proportions -fit4 <- brm(bf(y ~ x + z, theta2 ~ x), - dat, family = mix, prior = prior, - inits = 0, chains = 2) +fit4 <- brm(bf(y ~ x + z, theta2 ~ x), + dat, family = mix, prior = prior, + init = 0, chains = 2) summary(fit4) -pp_check(fit4) +pp_check(fit4) ## compare model fit -LOO(fit1, fit2, fit3, fit4) +LOO(fit1, fit2, fit3, fit4) } } diff -Nru r-cran-brms-2.16.3/man/mmc.Rd r-cran-brms-2.17.0/man/mmc.Rd --- r-cran-brms-2.16.3/man/mmc.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/mmc.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,41 +1,41 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-re.R -\name{mmc} -\alias{mmc} -\title{Multi-Membership Covariates} -\usage{ -mmc(...) -} -\arguments{ -\item{...}{One or more terms containing covariates -corresponding to the grouping levels specified in \code{\link{mm}}.} -} -\value{ -A matrix with covariates as columns. -} -\description{ -Specify covariates that vary over different levels -of multi-membership grouping factors thus requiring -special treatment. This function is almost solely useful, -when called in combination with \code{\link{mm}}. -Outside of multi-membership terms it will behave -very much like \code{\link{cbind}}. -} -\examples{ -\dontrun{ -# simulate some data -dat <- data.frame( - y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), - g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) -) - -# multi-membership model with level specific covariate values -dat$xc <- (dat$x1 + dat$x2) / 2 -fit <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) -summary(fit) -} - -} -\seealso{ -\code{\link{mm}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-re.R +\name{mmc} +\alias{mmc} +\title{Multi-Membership Covariates} +\usage{ +mmc(...) +} +\arguments{ +\item{...}{One or more terms containing covariates +corresponding to the grouping levels specified in \code{\link{mm}}.} +} +\value{ +A matrix with covariates as columns. +} +\description{ +Specify covariates that vary over different levels +of multi-membership grouping factors thus requiring +special treatment. This function is almost solely useful, +when called in combination with \code{\link{mm}}. +Outside of multi-membership terms it will behave +very much like \code{\link{cbind}}. +} +\examples{ +\dontrun{ +# simulate some data +dat <- data.frame( + y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), + g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) +) + +# multi-membership model with level specific covariate values +dat$xc <- (dat$x1 + dat$x2) / 2 +fit <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) +summary(fit) +} + +} +\seealso{ +\code{\link{mm}} +} diff -Nru r-cran-brms-2.16.3/man/mm.Rd r-cran-brms-2.17.0/man/mm.Rd --- r-cran-brms-2.16.3/man/mm.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/mm.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,85 +1,85 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-re.R -\name{mm} -\alias{mm} -\title{Set up multi-membership grouping terms in \pkg{brms}} -\usage{ -mm( - ..., - weights = NULL, - scale = TRUE, - by = NULL, - cor = TRUE, - id = NA, - cov = NULL, - dist = "gaussian" -) -} -\arguments{ -\item{...}{One or more terms containing grouping factors.} - -\item{weights}{A matrix specifying the weights of each member. -It should have as many columns as grouping terms specified in \code{...}. -If \code{NULL} (the default), equally weights are used.} - -\item{scale}{Logical; if \code{TRUE} (the default), -weights are standardized in order to sum to one per row. -If negative weights are specified, \code{scale} needs -to be set to \code{FALSE}.} - -\item{by}{An optional factor matrix, specifying sub-populations of the -groups. It should have as many columns as grouping terms specified in -\code{...}. For each level of the \code{by} variable, a separate -variance-covariance matrix will be fitted. Levels of the grouping factor -must be nested in levels of the \code{by} variable matrix.} - -\item{cor}{Logical. If \code{TRUE} (the default), group-level terms will be -modelled as correlated.} - -\item{id}{Optional character string. All group-level terms across the model -with the same \code{id} will be modeled as correlated (if \code{cor} is -\code{TRUE}). See \code{\link{brmsformula}} for more details.} - -\item{cov}{An optional matrix which is proportional to the withon-group -covariance matrix of the group-level effects. All levels of the grouping -factor should appear as rownames of the corresponding matrix. This argument -can be used, among others, to model pedigrees and phylogenetic effects. See -\code{vignette("brms_phylogenetics")} for more details. By default, levels -of the same grouping factor are modeled as independent of each other.} - -\item{dist}{Name of the distribution of the group-level effects. -Currently \code{"gaussian"} is the only option.} -} -\description{ -Function to set up a multi-membership grouping term in \pkg{brms}. -The function does not evaluate its arguments -- -it exists purely to help set up a model with grouping terms. -} -\examples{ -\dontrun{ -# simulate some data -dat <- data.frame( - y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), - g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) -) - -# multi-membership model with two members per group and equal weights -fit1 <- brm(y ~ x1 + (1|mm(g1, g2)), data = dat) -summary(fit1) - -# weight the first member two times for than the second member -dat$w1 <- rep(2, 100) -dat$w2 <- rep(1, 100) -fit2 <- brm(y ~ x1 + (1|mm(g1, g2, weights = cbind(w1, w2))), data = dat) -summary(fit2) - -# multi-membership model with level specific covariate values -dat$xc <- (dat$x1 + dat$x2) / 2 -fit3 <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) -summary(fit3) -} - -} -\seealso{ -\code{\link{brmsformula}}, \code{\link{mmc}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-re.R +\name{mm} +\alias{mm} +\title{Set up multi-membership grouping terms in \pkg{brms}} +\usage{ +mm( + ..., + weights = NULL, + scale = TRUE, + by = NULL, + cor = TRUE, + id = NA, + cov = NULL, + dist = "gaussian" +) +} +\arguments{ +\item{...}{One or more terms containing grouping factors.} + +\item{weights}{A matrix specifying the weights of each member. +It should have as many columns as grouping terms specified in \code{...}. +If \code{NULL} (the default), equally weights are used.} + +\item{scale}{Logical; if \code{TRUE} (the default), +weights are standardized in order to sum to one per row. +If negative weights are specified, \code{scale} needs +to be set to \code{FALSE}.} + +\item{by}{An optional factor matrix, specifying sub-populations of the +groups. It should have as many columns as grouping terms specified in +\code{...}. For each level of the \code{by} variable, a separate +variance-covariance matrix will be fitted. Levels of the grouping factor +must be nested in levels of the \code{by} variable matrix.} + +\item{cor}{Logical. If \code{TRUE} (the default), group-level terms will be +modelled as correlated.} + +\item{id}{Optional character string. All group-level terms across the model +with the same \code{id} will be modeled as correlated (if \code{cor} is +\code{TRUE}). See \code{\link{brmsformula}} for more details.} + +\item{cov}{An optional matrix which is proportional to the withon-group +covariance matrix of the group-level effects. All levels of the grouping +factor should appear as rownames of the corresponding matrix. This argument +can be used, among others, to model pedigrees and phylogenetic effects. See +\code{vignette("brms_phylogenetics")} for more details. By default, levels +of the same grouping factor are modeled as independent of each other.} + +\item{dist}{Name of the distribution of the group-level effects. +Currently \code{"gaussian"} is the only option.} +} +\description{ +Function to set up a multi-membership grouping term in \pkg{brms}. +The function does not evaluate its arguments -- +it exists purely to help set up a model with grouping terms. +} +\examples{ +\dontrun{ +# simulate some data +dat <- data.frame( + y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), + g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) +) + +# multi-membership model with two members per group and equal weights +fit1 <- brm(y ~ x1 + (1|mm(g1, g2)), data = dat) +summary(fit1) + +# weight the first member two times for than the second member +dat$w1 <- rep(2, 100) +dat$w2 <- rep(1, 100) +fit2 <- brm(y ~ x1 + (1|mm(g1, g2, weights = cbind(w1, w2))), data = dat) +summary(fit2) + +# multi-membership model with level specific covariate values +dat$xc <- (dat$x1 + dat$x2) / 2 +fit3 <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) +summary(fit3) +} + +} +\seealso{ +\code{\link{brmsformula}}, \code{\link{mmc}} +} diff -Nru r-cran-brms-2.16.3/man/model_weights.brmsfit.Rd r-cran-brms-2.17.0/man/model_weights.brmsfit.Rd --- r-cran-brms-2.16.3/man/model_weights.brmsfit.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/model_weights.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,58 +1,58 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model_weights.R -\name{model_weights.brmsfit} -\alias{model_weights.brmsfit} -\alias{model_weights} -\title{Model Weighting Methods} -\usage{ -\method{model_weights}{brmsfit}(x, ..., weights = "stacking", model_names = NULL) - -model_weights(x, ...) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{weights}{Name of the criterion to compute weights from. Should be one -of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current -default), or \code{"bma"}, \code{"pseudobma"}, For the former three -options, Akaike weights will be computed based on the information criterion -values returned by the respective methods. For \code{"stacking"} and -\code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to -obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be -used to compute Bayesian model averaging weights based on log marginal -likelihood values (make sure to specify reasonable priors in this case). -For some methods, \code{weights} may also be a numeric vector of -pre-specified weights.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} -} -\value{ -A numeric vector of weights for the models. -} -\description{ -Compute model weights in various ways, for instance, via -stacking of posterior predictive distributions, Akaike weights, -or marginal likelihoods. -} -\examples{ -\dontrun{ -# model with 'treat' as predictor -fit1 <- brm(rating ~ treat + period + carry, data = inhaler) -summary(fit1) - -# model without 'treat' as predictor -fit2 <- brm(rating ~ period + carry, data = inhaler) -summary(fit2) - -# obtain Akaike weights based on the WAIC -model_weights(fit1, fit2, weights = "waic") -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/model_weights.R +\name{model_weights.brmsfit} +\alias{model_weights.brmsfit} +\alias{model_weights} +\title{Model Weighting Methods} +\usage{ +\method{model_weights}{brmsfit}(x, ..., weights = "stacking", model_names = NULL) + +model_weights(x, ...) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{weights}{Name of the criterion to compute weights from. Should be one +of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current +default), or \code{"bma"}, \code{"pseudobma"}, For the former three +options, Akaike weights will be computed based on the information criterion +values returned by the respective methods. For \code{"stacking"} and +\code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to +obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be +used to compute Bayesian model averaging weights based on log marginal +likelihood values (make sure to specify reasonable priors in this case). +For some methods, \code{weights} may also be a numeric vector of +pre-specified weights.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} +} +\value{ +A numeric vector of weights for the models. +} +\description{ +Compute model weights in various ways, for instance, via +stacking of posterior predictive distributions, Akaike weights, +or marginal likelihoods. +} +\examples{ +\dontrun{ +# model with 'treat' as predictor +fit1 <- brm(rating ~ treat + period + carry, data = inhaler) +summary(fit1) + +# model without 'treat' as predictor +fit2 <- brm(rating ~ period + carry, data = inhaler) +summary(fit2) + +# obtain Akaike weights based on the WAIC +model_weights(fit1, fit2, weights = "waic") +} + +} diff -Nru r-cran-brms-2.16.3/man/mo.Rd r-cran-brms-2.17.0/man/mo.Rd --- r-cran-brms-2.16.3/man/mo.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/mo.Rd 2022-04-08 11:57:41.000000000 +0000 @@ -1,65 +1,64 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-sp.R -\name{mo} -\alias{mo} -\title{Monotonic Predictors in \pkg{brms} Models} -\usage{ -mo(x, id = NA) -} -\arguments{ -\item{x}{An integer variable or an ordered factor to be modeled as monotonic.} - -\item{id}{Optional character string. All monotonic terms -with the same \code{id} within one formula will be modeled as -having the same simplex (shape) parameter vector. If all monotonic terms -of the same predictor have the same \code{id}, the resulting -predictions will be conditionally monotonic for all values of -interacting covariates (Bürkner & Charpentier, 2020).} -} -\description{ -Specify a monotonic predictor term in \pkg{brms}. The function does not -evaluate its arguments -- it exists purely to help set up a model. -} -\details{ -See Bürkner and Charpentier (2020) for the underlying theory. For - detailed documentation of the formula syntax used for monotonic terms, - see \code{help(brmsformula)} as well as \code{vignette("brms_monotonic")}. -} -\examples{ - -\dontrun{ -# generate some data -income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") -income <- factor(sample(income_options, 100, TRUE), - levels = income_options, ordered = TRUE) -mean_ls <- c(30, 60, 70, 75) -ls <- mean_ls[income] + rnorm(100, sd = 7) -dat <- data.frame(income, ls) - -# fit a simple monotonic model -fit1 <- brm(ls ~ mo(income), data = dat) -summary(fit1) -plot(fit1, N = 6) -plot(conditional_effects(fit1), points = TRUE) - -# model interaction with other variables -dat$x <- sample(c("a", "b", "c"), 100, TRUE) -fit2 <- brm(ls ~ mo(income)*x, data = dat) -summary(fit2) -plot(conditional_effects(fit2), points = TRUE) - -# ensure conditional monotonicity -fit3 <- brm(ls ~ mo(income, id = "i")*x, data = dat) -summary(fit3) -plot(conditional_effects(fit3), points = TRUE) -} - -} -\references{ -Bürkner P. C. & Charpentier E. (2020). Modeling Monotonic Effects of Ordinal -Predictors in Regression Models. British Journal of Mathematical and -Statistical Psychology. doi:10.1111/bmsp.12195 -} -\seealso{ -\code{\link{brmsformula}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-sp.R +\name{mo} +\alias{mo} +\title{Monotonic Predictors in \pkg{brms} Models} +\usage{ +mo(x, id = NA) +} +\arguments{ +\item{x}{An integer variable or an ordered factor to be modeled as monotonic.} + +\item{id}{Optional character string. All monotonic terms +with the same \code{id} within one formula will be modeled as +having the same simplex (shape) parameter vector. If all monotonic terms +of the same predictor have the same \code{id}, the resulting +predictions will be conditionally monotonic for all values of +interacting covariates (Bürkner & Charpentier, 2020).} +} +\description{ +Specify a monotonic predictor term in \pkg{brms}. The function does not +evaluate its arguments -- it exists purely to help set up a model. +} +\details{ +See Bürkner and Charpentier (2020) for the underlying theory. For + detailed documentation of the formula syntax used for monotonic terms, + see \code{help(brmsformula)} as well as \code{vignette("brms_monotonic")}. +} +\examples{ +\dontrun{ +# generate some data +income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") +income <- factor(sample(income_options, 100, TRUE), + levels = income_options, ordered = TRUE) +mean_ls <- c(30, 60, 70, 75) +ls <- mean_ls[income] + rnorm(100, sd = 7) +dat <- data.frame(income, ls) + +# fit a simple monotonic model +fit1 <- brm(ls ~ mo(income), data = dat) +summary(fit1) +plot(fit1, N = 6) +plot(conditional_effects(fit1), points = TRUE) + +# model interaction with other variables +dat$x <- sample(c("a", "b", "c"), 100, TRUE) +fit2 <- brm(ls ~ mo(income)*x, data = dat) +summary(fit2) +plot(conditional_effects(fit2), points = TRUE) + +# ensure conditional monotonicity +fit3 <- brm(ls ~ mo(income, id = "i")*x, data = dat) +summary(fit3) +plot(conditional_effects(fit3), points = TRUE) +} + +} +\references{ +Bürkner P. C. & Charpentier E. (2020). Modeling Monotonic Effects of Ordinal +Predictors in Regression Models. British Journal of Mathematical and +Statistical Psychology. doi:10.1111/bmsp.12195 +} +\seealso{ +\code{\link{brmsformula}} +} diff -Nru r-cran-brms-2.16.3/man/MultiNormal.Rd r-cran-brms-2.17.0/man/MultiNormal.Rd --- r-cran-brms-2.16.3/man/MultiNormal.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/MultiNormal.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,36 +1,36 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{MultiNormal} -\alias{MultiNormal} -\alias{dmulti_normal} -\alias{rmulti_normal} -\title{The Multivariate Normal Distribution} -\usage{ -dmulti_normal(x, mu, Sigma, log = FALSE, check = FALSE) - -rmulti_normal(n, mu, Sigma, check = FALSE) -} -\arguments{ -\item{x}{Vector or matrix of quantiles. If \code{x} is a matrix, -each row is taken to be a quantile.} - -\item{mu}{Mean vector with length equal to the number of dimensions.} - -\item{Sigma}{Covariance matrix.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{check}{Logical; Indicates whether several input checks -should be performed. Defaults to \code{FALSE} to improve -efficiency.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density function and random generation for the multivariate normal -distribution with mean vector \code{mu} and covariance matrix \code{Sigma}. -} -\details{ -See the Stan user's manual \url{https://mc-stan.org/documentation/} -for details on the parameterization -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{MultiNormal} +\alias{MultiNormal} +\alias{dmulti_normal} +\alias{rmulti_normal} +\title{The Multivariate Normal Distribution} +\usage{ +dmulti_normal(x, mu, Sigma, log = FALSE, check = FALSE) + +rmulti_normal(n, mu, Sigma, check = FALSE) +} +\arguments{ +\item{x}{Vector or matrix of quantiles. If \code{x} is a matrix, +each row is taken to be a quantile.} + +\item{mu}{Mean vector with length equal to the number of dimensions.} + +\item{Sigma}{Covariance matrix.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{check}{Logical; Indicates whether several input checks +should be performed. Defaults to \code{FALSE} to improve +efficiency.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density function and random generation for the multivariate normal +distribution with mean vector \code{mu} and covariance matrix \code{Sigma}. +} +\details{ +See the Stan user's manual \url{https://mc-stan.org/documentation/} +for details on the parameterization +} diff -Nru r-cran-brms-2.16.3/man/MultiStudentT.Rd r-cran-brms-2.17.0/man/MultiStudentT.Rd --- r-cran-brms-2.16.3/man/MultiStudentT.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/MultiStudentT.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,39 +1,39 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{MultiStudentT} -\alias{MultiStudentT} -\alias{dmulti_student_t} -\alias{rmulti_student_t} -\title{The Multivariate Student-t Distribution} -\usage{ -dmulti_student_t(x, df, mu, Sigma, log = FALSE, check = FALSE) - -rmulti_student_t(n, df, mu, Sigma, check = FALSE) -} -\arguments{ -\item{x}{Vector or matrix of quantiles. If \code{x} is a matrix, -each row is taken to be a quantile.} - -\item{df}{Vector of degrees of freedom.} - -\item{mu}{Location vector with length equal to the number of dimensions.} - -\item{Sigma}{Covariance matrix.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{check}{Logical; Indicates whether several input checks -should be performed. Defaults to \code{FALSE} to improve -efficiency.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density function and random generation for the multivariate Student-t -distribution with location vector \code{mu}, covariance matrix \code{Sigma}, -and degrees of freedom \code{df}. -} -\details{ -See the Stan user's manual \url{https://mc-stan.org/documentation/} - for details on the parameterization -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{MultiStudentT} +\alias{MultiStudentT} +\alias{dmulti_student_t} +\alias{rmulti_student_t} +\title{The Multivariate Student-t Distribution} +\usage{ +dmulti_student_t(x, df, mu, Sigma, log = FALSE, check = FALSE) + +rmulti_student_t(n, df, mu, Sigma, check = FALSE) +} +\arguments{ +\item{x}{Vector or matrix of quantiles. If \code{x} is a matrix, +each row is taken to be a quantile.} + +\item{df}{Vector of degrees of freedom.} + +\item{mu}{Location vector with length equal to the number of dimensions.} + +\item{Sigma}{Covariance matrix.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{check}{Logical; Indicates whether several input checks +should be performed. Defaults to \code{FALSE} to improve +efficiency.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density function and random generation for the multivariate Student-t +distribution with location vector \code{mu}, covariance matrix \code{Sigma}, +and degrees of freedom \code{df}. +} +\details{ +See the Stan user's manual \url{https://mc-stan.org/documentation/} + for details on the parameterization +} diff -Nru r-cran-brms-2.16.3/man/mvbrmsformula.Rd r-cran-brms-2.17.0/man/mvbrmsformula.Rd --- r-cran-brms-2.16.3/man/mvbrmsformula.Rd 2019-11-21 12:19:03.000000000 +0000 +++ r-cran-brms-2.17.0/man/mvbrmsformula.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -8,27 +8,27 @@ mvbrmsformula(..., flist = NULL, rescor = NULL) } \arguments{ -\item{...}{Objects of class \code{formula} or \code{brmsformula}, +\item{...}{Objects of class \code{formula} or \code{brmsformula}, each specifying a univariate model. See \code{\link{brmsformula}} for details on how to specify univariate models.} -\item{flist}{Optional list of formulas, which are treated in the +\item{flist}{Optional list of formulas, which are treated in the same way as formulas passed via the \code{...} argument.} \item{rescor}{Logical; Indicates if residual correlation between the response variables should be modeled. Currently, this is only possible in multivariate \code{gaussian} and \code{student} models. -If \code{NULL} (the default), \code{rescor} is internally set to +If \code{NULL} (the default), \code{rescor} is internally set to \code{TRUE} when possible.} } \value{ An object of class \code{mvbrmsformula}, which - is essentially a \code{list} containing all model formulas + is essentially a \code{list} containing all model formulas as well as some additional information for multivariate models. } \description{ Set up a multivariate model formula for use in the \pkg{brms} package -allowing to define (potentially non-linear) additive multilevel +allowing to define (potentially non-linear) additive multilevel models for all parameters of the assumed response distributions. } \details{ diff -Nru r-cran-brms-2.16.3/man/ngrps.brmsfit.Rd r-cran-brms-2.17.0/man/ngrps.brmsfit.Rd --- r-cran-brms-2.16.3/man/ngrps.brmsfit.Rd 2020-07-08 07:08:40.000000000 +0000 +++ r-cran-brms-2.17.0/man/ngrps.brmsfit.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,23 +1,23 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{ngrps.brmsfit} -\alias{ngrps.brmsfit} -\alias{ngrps} -\title{Number of Grouping Factor Levels} -\usage{ -\method{ngrps}{brmsfit}(object, ...) - -ngrps(object, ...) -} -\arguments{ -\item{object}{An \R object.} - -\item{...}{Currently ignored.} -} -\value{ -A named list containing the number of levels per - grouping factor. -} -\description{ -Extract the number of levels of one or more grouping factors. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{ngrps.brmsfit} +\alias{ngrps.brmsfit} +\alias{ngrps} +\title{Number of Grouping Factor Levels} +\usage{ +\method{ngrps}{brmsfit}(object, ...) + +ngrps(object, ...) +} +\arguments{ +\item{object}{An \R object.} + +\item{...}{Currently ignored.} +} +\value{ +A named list containing the number of levels per + grouping factor. +} +\description{ +Extract the number of levels of one or more grouping factors. +} diff -Nru r-cran-brms-2.16.3/man/nsamples.brmsfit.Rd r-cran-brms-2.17.0/man/nsamples.brmsfit.Rd --- r-cran-brms-2.16.3/man/nsamples.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/nsamples.brmsfit.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,25 +1,25 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{nsamples.brmsfit} -\alias{nsamples.brmsfit} -\alias{nsamples} -\title{(Deprecated) Number of Posterior Samples} -\usage{ -\method{nsamples}{brmsfit}(object, subset = NULL, incl_warmup = FALSE, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{subset}{An optional integer vector defining a subset of samples -to be considered.} - -\item{incl_warmup}{A flag indicating whether to also count warmup / burn-in -samples.} - -\item{...}{Currently ignored.} -} -\description{ -Extract the number of posterior samples (draws) stored in a fitted Bayesian -model. Method \code{nsamples} is deprecated. Please use \code{ndraws} -instead. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{nsamples.brmsfit} +\alias{nsamples.brmsfit} +\alias{nsamples} +\title{(Deprecated) Number of Posterior Samples} +\usage{ +\method{nsamples}{brmsfit}(object, subset = NULL, incl_warmup = FALSE, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{subset}{An optional integer vector defining a subset of samples +to be considered.} + +\item{incl_warmup}{A flag indicating whether to also count warmup / burn-in +samples.} + +\item{...}{Currently ignored.} +} +\description{ +Extract the number of posterior samples (draws) stored in a fitted Bayesian +model. Method \code{nsamples} is deprecated. Please use \code{ndraws} +instead. +} diff -Nru r-cran-brms-2.16.3/man/opencl.Rd r-cran-brms-2.17.0/man/opencl.Rd --- r-cran-brms-2.16.3/man/opencl.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/opencl.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,39 +1,39 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/backends.R -\name{opencl} -\alias{opencl} -\title{GPU support in Stan via OpenCL} -\usage{ -opencl(ids = NULL) -} -\arguments{ -\item{ids}{(integer vector of length 2) The platform and device IDs of the -OpenCL device to use for fitting. If you don't know the IDs of your OpenCL -device, \code{c(0,0)} is most likely what you need.} -} -\value{ -A \code{brmsopencl} object which can be passed to the - \code{opencl} argument of \code{brm} and related functions. -} -\description{ -Use OpenCL for GPU support in \pkg{Stan} via the \pkg{brms} interface. Only -some \pkg{Stan} functions can be run on a GPU at this point and so -a lot of \pkg{brms} models won't benefit from OpenCL for now. -} -\details{ -For more details on OpenCL in \pkg{Stan}, check out -\url{https://mc-stan.org/docs/2_26/cmdstan-guide/parallelization.html#opencl} -as well as \url{https://mc-stan.org/docs/2_26/stan-users-guide/opencl.html}. -} -\examples{ -\dontrun{ -# this model just serves as an illustration -# OpenCL may not actually speed things up here -fit <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson(), - chains = 2, cores = 2, opencl = opencl(c(0, 0)), - backend = "cmdstanr") -summary(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/backends.R +\name{opencl} +\alias{opencl} +\title{GPU support in Stan via OpenCL} +\usage{ +opencl(ids = NULL) +} +\arguments{ +\item{ids}{(integer vector of length 2) The platform and device IDs of the +OpenCL device to use for fitting. If you don't know the IDs of your OpenCL +device, \code{c(0,0)} is most likely what you need.} +} +\value{ +A \code{brmsopencl} object which can be passed to the + \code{opencl} argument of \code{brm} and related functions. +} +\description{ +Use OpenCL for GPU support in \pkg{Stan} via the \pkg{brms} interface. Only +some \pkg{Stan} functions can be run on a GPU at this point and so +a lot of \pkg{brms} models won't benefit from OpenCL for now. +} +\details{ +For more details on OpenCL in \pkg{Stan}, check out +\url{https://mc-stan.org/docs/2_26/cmdstan-guide/parallelization.html#opencl} +as well as \url{https://mc-stan.org/docs/2_26/stan-users-guide/opencl.html}. +} +\examples{ +\dontrun{ +# this model just serves as an illustration +# OpenCL may not actually speed things up here +fit <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson(), + chains = 2, cores = 2, opencl = opencl(c(0, 0)), + backend = "cmdstanr") +summary(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/pairs.brmsfit.Rd r-cran-brms-2.17.0/man/pairs.brmsfit.Rd --- r-cran-brms-2.16.3/man/pairs.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/pairs.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,48 +1,48 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R -\name{pairs.brmsfit} -\alias{pairs.brmsfit} -\title{Create a matrix of output plots from a \code{brmsfit} object} -\usage{ -\method{pairs}{brmsfit}(x, pars = NA, variable = NULL, regex = FALSE, fixed = FALSE, ...) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}} - -\item{pars}{Deprecated alias of \code{variable}. -Names of the parameters to plot, as given by a -character vector or a regular expression.} - -\item{variable}{Names of the variables (parameters) to plot, as given by a -character vector or a regular expression (if \code{regex = TRUE}). By -default, a hopefully not too large selection of variables is plotted.} - -\item{regex}{Logical; Indicates whether \code{variable} should -be treated as regular expressions. Defaults to \code{FALSE}.} - -\item{fixed}{(Deprecated) Indicates whether parameter names -should be matched exactly (\code{TRUE}) or treated as -regular expressions (\code{FALSE}). Default is \code{FALSE} -and only works with argument \code{pars}.} - -\item{...}{Further arguments to be passed to -\code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}.} -} -\description{ -A \code{\link[graphics:pairs]{pairs}} -method that is customized for MCMC output. -} -\details{ -For a detailed description see - \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt - + (1|patient) + (1|visit), - data = epilepsy, family = "poisson") -pairs(fit, variable = variables(fit)[1:3]) -pairs(fit, variable = "^sd_", regex = TRUE) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.R +\name{pairs.brmsfit} +\alias{pairs.brmsfit} +\title{Create a matrix of output plots from a \code{brmsfit} object} +\usage{ +\method{pairs}{brmsfit}(x, pars = NA, variable = NULL, regex = FALSE, fixed = FALSE, ...) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}} + +\item{pars}{Deprecated alias of \code{variable}. +Names of the parameters to plot, as given by a +character vector or a regular expression.} + +\item{variable}{Names of the variables (parameters) to plot, as given by a +character vector or a regular expression (if \code{regex = TRUE}). By +default, a hopefully not too large selection of variables is plotted.} + +\item{regex}{Logical; Indicates whether \code{variable} should +be treated as regular expressions. Defaults to \code{FALSE}.} + +\item{fixed}{(Deprecated) Indicates whether parameter names +should be matched exactly (\code{TRUE}) or treated as +regular expressions (\code{FALSE}). Default is \code{FALSE} +and only works with argument \code{pars}.} + +\item{...}{Further arguments to be passed to +\code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}.} +} +\description{ +A \code{\link[graphics:pairs]{pairs}} +method that is customized for MCMC output. +} +\details{ +For a detailed description see + \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + + (1|patient) + (1|visit), + data = epilepsy, family = "poisson") +pairs(fit, variable = variables(fit)[1:3]) +pairs(fit, variable = "^sd_", regex = TRUE) +} + +} diff -Nru r-cran-brms-2.16.3/man/parnames.Rd r-cran-brms-2.17.0/man/parnames.Rd --- r-cran-brms-2.16.3/man/parnames.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/parnames.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,20 +1,20 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_samples.R -\name{parnames} -\alias{parnames} -\alias{parnames.brmsfit} -\title{Extract Parameter Names} -\usage{ -parnames(x, ...) -} -\arguments{ -\item{x}{An \R object} - -\item{...}{Further arguments passed to or from other methods.} -} -\value{ -A character vector containing the parameter names of the model. -} -\description{ -Extract all parameter names of a given model. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_samples.R +\name{parnames} +\alias{parnames} +\alias{parnames.brmsfit} +\title{Extract Parameter Names} +\usage{ +parnames(x, ...) +} +\arguments{ +\item{x}{An \R object} + +\item{...}{Further arguments passed to or from other methods.} +} +\value{ +A character vector containing the parameter names of the model. +} +\description{ +Extract all parameter names of a given model. +} diff -Nru r-cran-brms-2.16.3/man/plot.brmsfit.Rd r-cran-brms-2.17.0/man/plot.brmsfit.Rd --- r-cran-brms-2.16.3/man/plot.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/plot.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,86 +1,86 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R -\name{plot.brmsfit} -\alias{plot.brmsfit} -\title{Trace and Density Plots for MCMC Draws} -\usage{ -\method{plot}{brmsfit}( - x, - pars = NA, - combo = c("dens", "trace"), - N = 5, - variable = NULL, - regex = FALSE, - fixed = FALSE, - theme = NULL, - plot = TRUE, - ask = TRUE, - newpage = TRUE, - ... -) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}.} - -\item{pars}{Deprecated alias of \code{variable}. -Names of the parameters to plot, as given by a -character vector or a regular expression.} - -\item{combo}{A character vector with at least two elements. -Each element of \code{combo} corresponds to a column in the resulting -graphic and should be the name of one of the available -\code{\link[bayesplot:MCMC-overview]{MCMC}} functions -(omitting the \code{mcmc_} prefix).} - -\item{N}{The number of parameters plotted per page.} - -\item{variable}{Names of the variables (parameters) to plot, as given by a -character vector or a regular expression (if \code{regex = TRUE}). By -default, a hopefully not too large selection of variables is plotted.} - -\item{regex}{Logical; Indicates whether \code{variable} should -be treated as regular expressions. Defaults to \code{FALSE}.} - -\item{fixed}{(Deprecated) Indicates whether parameter names -should be matched exactly (\code{TRUE}) or treated as -regular expressions (\code{FALSE}). Default is \code{FALSE} -and only works with argument \code{pars}.} - -\item{theme}{A \code{\link[ggplot2:theme]{theme}} object -modifying the appearance of the plots. -For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} -and \code{\link[bayesplot:theme_default]{theme_default}}.} - -\item{plot}{Logical; indicates if plots should be -plotted directly in the active graphic device. -Defaults to \code{TRUE}.} - -\item{ask}{Logical; indicates if the user is prompted -before a new page is plotted. -Only used if \code{plot} is \code{TRUE}.} - -\item{newpage}{Logical; indicates if the first set of plots -should be plotted to a new page. -Only used if \code{plot} is \code{TRUE}.} - -\item{...}{Further arguments passed to -\code{\link[bayesplot:MCMC-combos]{mcmc_combo}}.} -} -\value{ -An invisible list of - \code{\link[gtable:gtable]{gtable}} objects. -} -\description{ -Trace and Density Plots for MCMC Draws -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt - + (1|patient) + (1|visit), - data = epilepsy, family = "poisson") -plot(fit) -## plot population-level effects only -plot(fit, variable = "^b_", regex = TRUE) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.R +\name{plot.brmsfit} +\alias{plot.brmsfit} +\title{Trace and Density Plots for MCMC Draws} +\usage{ +\method{plot}{brmsfit}( + x, + pars = NA, + combo = c("dens", "trace"), + N = 5, + variable = NULL, + regex = FALSE, + fixed = FALSE, + theme = NULL, + plot = TRUE, + ask = TRUE, + newpage = TRUE, + ... +) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}.} + +\item{pars}{Deprecated alias of \code{variable}. +Names of the parameters to plot, as given by a +character vector or a regular expression.} + +\item{combo}{A character vector with at least two elements. +Each element of \code{combo} corresponds to a column in the resulting +graphic and should be the name of one of the available +\code{\link[bayesplot:MCMC-overview]{MCMC}} functions +(omitting the \code{mcmc_} prefix).} + +\item{N}{The number of parameters plotted per page.} + +\item{variable}{Names of the variables (parameters) to plot, as given by a +character vector or a regular expression (if \code{regex = TRUE}). By +default, a hopefully not too large selection of variables is plotted.} + +\item{regex}{Logical; Indicates whether \code{variable} should +be treated as regular expressions. Defaults to \code{FALSE}.} + +\item{fixed}{(Deprecated) Indicates whether parameter names +should be matched exactly (\code{TRUE}) or treated as +regular expressions (\code{FALSE}). Default is \code{FALSE} +and only works with argument \code{pars}.} + +\item{theme}{A \code{\link[ggplot2:theme]{theme}} object +modifying the appearance of the plots. +For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} +and \code{\link[bayesplot:theme_default]{theme_default}}.} + +\item{plot}{Logical; indicates if plots should be +plotted directly in the active graphic device. +Defaults to \code{TRUE}.} + +\item{ask}{Logical; indicates if the user is prompted +before a new page is plotted. +Only used if \code{plot} is \code{TRUE}.} + +\item{newpage}{Logical; indicates if the first set of plots +should be plotted to a new page. +Only used if \code{plot} is \code{TRUE}.} + +\item{...}{Further arguments passed to +\code{\link[bayesplot:MCMC-combos]{mcmc_combo}}.} +} +\value{ +An invisible list of + \code{\link[gtable:gtable]{gtable}} objects. +} +\description{ +Trace and Density Plots for MCMC Draws +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + + (1|patient) + (1|visit), + data = epilepsy, family = "poisson") +plot(fit) +## plot population-level effects only +plot(fit, variable = "^b_", regex = TRUE) +} + +} diff -Nru r-cran-brms-2.16.3/man/posterior_average.brmsfit.Rd r-cran-brms-2.17.0/man/posterior_average.brmsfit.Rd --- r-cran-brms-2.16.3/man/posterior_average.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_average.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,98 +1,98 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model_weights.R -\name{posterior_average.brmsfit} -\alias{posterior_average.brmsfit} -\alias{posterior_average} -\title{Posterior draws of parameters averaged across models} -\usage{ -\method{posterior_average}{brmsfit}( - x, - ..., - variable = NULL, - pars = NULL, - weights = "stacking", - ndraws = NULL, - nsamples = NULL, - missing = NULL, - model_names = NULL, - control = list(), - seed = NULL -) - -posterior_average(x, ...) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{variable}{Names of variables (parameters) for which to average across -models. Only those variables can be averaged that appear in every model. -Defaults to all overlapping variables.} - -\item{pars}{Deprecated alias of \code{variable}.} - -\item{weights}{Name of the criterion to compute weights from. Should be one -of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current -default), or \code{"bma"}, \code{"pseudobma"}, For the former three -options, Akaike weights will be computed based on the information criterion -values returned by the respective methods. For \code{"stacking"} and -\code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to -obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be -used to compute Bayesian model averaging weights based on log marginal -likelihood values (make sure to specify reasonable priors in this case). -For some methods, \code{weights} may also be a numeric vector of -pre-specified weights.} - -\item{ndraws}{Total number of posterior draws to use.} - -\item{nsamples}{Deprecated alias of \code{ndraws}.} - -\item{missing}{An optional numeric value or a named list of numeric values -to use if a model does not contain a variable for which posterior draws -should be averaged. Defaults to \code{NULL}, in which case only those -variables can be averaged that are present in all of the models.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} - -\item{control}{Optional \code{list} of further arguments -passed to the function specified in \code{weights}.} - -\item{seed}{A single numeric value passed to \code{\link{set.seed}} -to make results reproducible.} -} -\value{ -A \code{data.frame} of posterior draws. -} -\description{ -Extract posterior draws of parameters averaged across models. -Weighting can be done in various ways, for instance using -Akaike weights based on information criteria or -marginal likelihoods. -} -\details{ -Weights are computed with the \code{\link{model_weights}} method. -} -\examples{ -\dontrun{ -# model with 'treat' as predictor -fit1 <- brm(rating ~ treat + period + carry, data = inhaler) -summary(fit1) - -# model without 'treat' as predictor -fit2 <- brm(rating ~ period + carry, data = inhaler) -summary(fit2) - -# compute model-averaged posteriors of overlapping parameters -posterior_average(fit1, fit2, weights = "waic") -} - -} -\seealso{ -\code{\link{model_weights}}, \code{\link{pp_average}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/model_weights.R +\name{posterior_average.brmsfit} +\alias{posterior_average.brmsfit} +\alias{posterior_average} +\title{Posterior draws of parameters averaged across models} +\usage{ +\method{posterior_average}{brmsfit}( + x, + ..., + variable = NULL, + pars = NULL, + weights = "stacking", + ndraws = NULL, + nsamples = NULL, + missing = NULL, + model_names = NULL, + control = list(), + seed = NULL +) + +posterior_average(x, ...) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{variable}{Names of variables (parameters) for which to average across +models. Only those variables can be averaged that appear in every model. +Defaults to all overlapping variables.} + +\item{pars}{Deprecated alias of \code{variable}.} + +\item{weights}{Name of the criterion to compute weights from. Should be one +of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current +default), or \code{"bma"}, \code{"pseudobma"}, For the former three +options, Akaike weights will be computed based on the information criterion +values returned by the respective methods. For \code{"stacking"} and +\code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to +obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be +used to compute Bayesian model averaging weights based on log marginal +likelihood values (make sure to specify reasonable priors in this case). +For some methods, \code{weights} may also be a numeric vector of +pre-specified weights.} + +\item{ndraws}{Total number of posterior draws to use.} + +\item{nsamples}{Deprecated alias of \code{ndraws}.} + +\item{missing}{An optional numeric value or a named list of numeric values +to use if a model does not contain a variable for which posterior draws +should be averaged. Defaults to \code{NULL}, in which case only those +variables can be averaged that are present in all of the models.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} + +\item{control}{Optional \code{list} of further arguments +passed to the function specified in \code{weights}.} + +\item{seed}{A single numeric value passed to \code{\link{set.seed}} +to make results reproducible.} +} +\value{ +A \code{data.frame} of posterior draws. +} +\description{ +Extract posterior draws of parameters averaged across models. +Weighting can be done in various ways, for instance using +Akaike weights based on information criteria or +marginal likelihoods. +} +\details{ +Weights are computed with the \code{\link{model_weights}} method. +} +\examples{ +\dontrun{ +# model with 'treat' as predictor +fit1 <- brm(rating ~ treat + period + carry, data = inhaler) +summary(fit1) + +# model without 'treat' as predictor +fit2 <- brm(rating ~ period + carry, data = inhaler) +summary(fit2) + +# compute model-averaged posteriors of overlapping parameters +posterior_average(fit1, fit2, weights = "waic") +} + +} +\seealso{ +\code{\link{model_weights}}, \code{\link{pp_average}} +} diff -Nru r-cran-brms-2.16.3/man/posterior_epred.brmsfit.Rd r-cran-brms-2.17.0/man/posterior_epred.brmsfit.Rd --- r-cran-brms-2.16.3/man/posterior_epred.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_epred.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,106 +1,106 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_epred.R -\name{posterior_epred.brmsfit} -\alias{posterior_epred.brmsfit} -\alias{pp_expect} -\alias{posterior_epred} -\title{Expected Values of the Posterior Predictive Distribution} -\usage{ -\method{posterior_epred}{brmsfit}( - object, - newdata = NULL, - re_formula = NULL, - re.form = NULL, - resp = NULL, - dpar = NULL, - nlpar = NULL, - ndraws = NULL, - draw_ids = NULL, - sort = FALSE, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{re.form}{Alias of \code{re_formula}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{dpar}{Optional name of a predicted distributional parameter. -If specified, expected predictions of this parameters are returned.} - -\item{nlpar}{Optional name of a predicted non-linear parameter. -If specified, expected predictions of this parameters are returned.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{sort}{Logical. Only relevant for time series models. -Indicating whether to return predicted values in the original -order (\code{FALSE}; default) or in the order of the -time series (\code{TRUE}).} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -An \code{array} of predicted \emph{mean} response values. For - categorical and ordinal models, the output is an S x N x C array. - Otherwise, the output is an S x N matrix, where S is the number of - posterior draws, N is the number of observations, and C is the number of - categories. In multivariate models, an additional dimension is added to the - output which indexes along the different response variables. -} -\description{ -Compute posterior draws of the expected value/mean of the posterior -predictive distribution. Can be performed for the data used to fit the model -(posterior predictive checks) or for new data. By definition, these -predictions have smaller variance than the posterior predictions performed by -the \code{\link{posterior_predict.brmsfit}} method. This is because only the -uncertainty in the mean is incorporated in the draws computed by -\code{posterior_epred} while any residual error is ignored. However, the -estimated means of both methods averaged across draws should be very -similar. -} -\details{ -\code{NA} values within factors in \code{newdata}, - are interpreted as if all dummy variables of this factor are - zero. This allows, for instance, to make predictions of the grand mean - when using sum coding. - -In multilevel models, it is possible to -allow new levels of grouping factors to be used in the predictions. -This can be controlled via argument \code{allow_new_levels}. -New levels can be sampled in multiple ways, which can be controlled -via argument \code{sample_new_levels}. Both of these arguments are -documented in \code{\link{prepare_predictions}} along with several -other useful arguments to control specific aspects of the predictions. -} -\examples{ -\dontrun{ -## fit a model -fit <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler) - -## compute expected predictions -ppe <- posterior_epred(fit) -str(ppe) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_epred.R +\name{posterior_epred.brmsfit} +\alias{posterior_epred.brmsfit} +\alias{pp_expect} +\alias{posterior_epred} +\title{Expected Values of the Posterior Predictive Distribution} +\usage{ +\method{posterior_epred}{brmsfit}( + object, + newdata = NULL, + re_formula = NULL, + re.form = NULL, + resp = NULL, + dpar = NULL, + nlpar = NULL, + ndraws = NULL, + draw_ids = NULL, + sort = FALSE, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{re.form}{Alias of \code{re_formula}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{dpar}{Optional name of a predicted distributional parameter. +If specified, expected predictions of this parameters are returned.} + +\item{nlpar}{Optional name of a predicted non-linear parameter. +If specified, expected predictions of this parameters are returned.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{sort}{Logical. Only relevant for time series models. +Indicating whether to return predicted values in the original +order (\code{FALSE}; default) or in the order of the +time series (\code{TRUE}).} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +An \code{array} of predicted \emph{mean} response values. For + categorical and ordinal models, the output is an S x N x C array. + Otherwise, the output is an S x N matrix, where S is the number of + posterior draws, N is the number of observations, and C is the number of + categories. In multivariate models, an additional dimension is added to the + output which indexes along the different response variables. +} +\description{ +Compute posterior draws of the expected value/mean of the posterior +predictive distribution. Can be performed for the data used to fit the model +(posterior predictive checks) or for new data. By definition, these +predictions have smaller variance than the posterior predictions performed by +the \code{\link{posterior_predict.brmsfit}} method. This is because only the +uncertainty in the mean is incorporated in the draws computed by +\code{posterior_epred} while any residual error is ignored. However, the +estimated means of both methods averaged across draws should be very +similar. +} +\details{ +\code{NA} values within factors in \code{newdata}, + are interpreted as if all dummy variables of this factor are + zero. This allows, for instance, to make predictions of the grand mean + when using sum coding. + +In multilevel models, it is possible to +allow new levels of grouping factors to be used in the predictions. +This can be controlled via argument \code{allow_new_levels}. +New levels can be sampled in multiple ways, which can be controlled +via argument \code{sample_new_levels}. Both of these arguments are +documented in \code{\link{prepare_predictions}} along with several +other useful arguments to control specific aspects of the predictions. +} +\examples{ +\dontrun{ +## fit a model +fit <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler) + +## compute expected predictions +ppe <- posterior_epred(fit) +str(ppe) +} + +} diff -Nru r-cran-brms-2.16.3/man/posterior_interval.brmsfit.Rd r-cran-brms-2.17.0/man/posterior_interval.brmsfit.Rd --- r-cran-brms-2.16.3/man/posterior_interval.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_interval.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,39 +1,39 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary.R -\name{posterior_interval.brmsfit} -\alias{posterior_interval.brmsfit} -\alias{posterior_interval} -\title{Compute posterior uncertainty intervals} -\usage{ -\method{posterior_interval}{brmsfit}(object, pars = NA, variable = NULL, prob = 0.95, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{pars}{Deprecated alias of \code{variable}. For reasons of backwards -compatibility, \code{pars} is interpreted as a vector of regular -expressions by default unless \code{fixed = TRUE} is specified.} - -\item{variable}{A character vector providing the variables to extract. -By default, all variables are extracted.} - -\item{prob}{A value between 0 and 1 indicating the desired probability -to be covered by the uncertainty intervals. The default is 0.95.} - -\item{...}{More arguments passed to \code{\link{as.matrix.brmsfit}}.} -} -\value{ -A \code{matrix} with lower and upper interval bounds - as columns and as many rows as selected variables. -} -\description{ -Compute posterior uncertainty intervals for \code{brmsfit} objects. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt, - data = epilepsy, family = negbinomial()) -posterior_interval(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{posterior_interval.brmsfit} +\alias{posterior_interval.brmsfit} +\alias{posterior_interval} +\title{Compute posterior uncertainty intervals} +\usage{ +\method{posterior_interval}{brmsfit}(object, pars = NA, variable = NULL, prob = 0.95, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{pars}{Deprecated alias of \code{variable}. For reasons of backwards +compatibility, \code{pars} is interpreted as a vector of regular +expressions by default unless \code{fixed = TRUE} is specified.} + +\item{variable}{A character vector providing the variables to extract. +By default, all variables are extracted.} + +\item{prob}{A value between 0 and 1 indicating the desired probability +to be covered by the uncertainty intervals. The default is 0.95.} + +\item{...}{More arguments passed to \code{\link{as.matrix.brmsfit}}.} +} +\value{ +A \code{matrix} with lower and upper interval bounds + as columns and as many rows as selected variables. +} +\description{ +Compute posterior uncertainty intervals for \code{brmsfit} objects. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt, + data = epilepsy, family = negbinomial()) +posterior_interval(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/posterior_linpred.brmsfit.Rd r-cran-brms-2.17.0/man/posterior_linpred.brmsfit.Rd --- r-cran-brms-2.16.3/man/posterior_linpred.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_linpred.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,93 +1,93 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_epred.R -\name{posterior_linpred.brmsfit} -\alias{posterior_linpred.brmsfit} -\alias{posterior_linpred} -\title{Posterior Draws of the Linear Predictor} -\usage{ -\method{posterior_linpred}{brmsfit}( - object, - transform = FALSE, - newdata = NULL, - re_formula = NULL, - re.form = NULL, - resp = NULL, - dpar = NULL, - nlpar = NULL, - incl_thres = NULL, - ndraws = NULL, - draw_ids = NULL, - sort = FALSE, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{transform}{Logical; if \code{FALSE} -(the default), draws of the linear predictor are returned. -If \code{TRUE}, draws of transformed linear predictor, -that is, after applying the link function are returned.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{re.form}{Alias of \code{re_formula}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{dpar}{Name of a predicted distributional parameter -for which draws are to be returned. By default, draws -of the main distributional parameter(s) \code{"mu"} are returned.} - -\item{nlpar}{Optional name of a predicted non-linear parameter. -If specified, expected predictions of this parameters are returned.} - -\item{incl_thres}{Logical; only relevant for ordinal models when -\code{transform} is \code{FALSE}, and ignored otherwise. Shall the -thresholds and category-specific effects be included in the linear -predictor? For backwards compatibility, the default is to not include them.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{sort}{Logical. Only relevant for time series models. -Indicating whether to return predicted values in the original -order (\code{FALSE}; default) or in the order of the -time series (\code{TRUE}).} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\description{ -Compute posterior draws of the linear predictor, that is draws before -applying any link functions or other transformations. Can be performed for -the data used to fit the model (posterior predictive checks) or for new data. -} -\examples{ -\dontrun{ -## fit a model -fit <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler) - -## extract linear predictor values -pl <- posterior_linpred(fit) -str(pl) -} - -} -\seealso{ -\code{\link{posterior_epred.brmsfit}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_epred.R +\name{posterior_linpred.brmsfit} +\alias{posterior_linpred.brmsfit} +\alias{posterior_linpred} +\title{Posterior Draws of the Linear Predictor} +\usage{ +\method{posterior_linpred}{brmsfit}( + object, + transform = FALSE, + newdata = NULL, + re_formula = NULL, + re.form = NULL, + resp = NULL, + dpar = NULL, + nlpar = NULL, + incl_thres = NULL, + ndraws = NULL, + draw_ids = NULL, + sort = FALSE, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{transform}{Logical; if \code{FALSE} +(the default), draws of the linear predictor are returned. +If \code{TRUE}, draws of transformed linear predictor, +that is, after applying the link function are returned.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{re.form}{Alias of \code{re_formula}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{dpar}{Name of a predicted distributional parameter +for which draws are to be returned. By default, draws +of the main distributional parameter(s) \code{"mu"} are returned.} + +\item{nlpar}{Optional name of a predicted non-linear parameter. +If specified, expected predictions of this parameters are returned.} + +\item{incl_thres}{Logical; only relevant for ordinal models when +\code{transform} is \code{FALSE}, and ignored otherwise. Shall the +thresholds and category-specific effects be included in the linear +predictor? For backwards compatibility, the default is to not include them.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{sort}{Logical. Only relevant for time series models. +Indicating whether to return predicted values in the original +order (\code{FALSE}; default) or in the order of the +time series (\code{TRUE}).} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\description{ +Compute posterior draws of the linear predictor, that is draws before +applying any link functions or other transformations. Can be performed for +the data used to fit the model (posterior predictive checks) or for new data. +} +\examples{ +\dontrun{ +## fit a model +fit <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler) + +## extract linear predictor values +pl <- posterior_linpred(fit) +str(pl) +} + +} +\seealso{ +\code{\link{posterior_epred.brmsfit}} +} diff -Nru r-cran-brms-2.16.3/man/posterior_predict.brmsfit.Rd r-cran-brms-2.17.0/man/posterior_predict.brmsfit.Rd --- r-cran-brms-2.16.3/man/posterior_predict.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_predict.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,139 +1,139 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_predict.R -\name{posterior_predict.brmsfit} -\alias{posterior_predict.brmsfit} -\alias{posterior_predict} -\title{Draws from the Posterior Predictive Distribution} -\usage{ -\method{posterior_predict}{brmsfit}( - object, - newdata = NULL, - re_formula = NULL, - re.form = NULL, - transform = NULL, - resp = NULL, - negative_rt = FALSE, - ndraws = NULL, - draw_ids = NULL, - sort = FALSE, - ntrys = 5, - cores = NULL, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{re.form}{Alias of \code{re_formula}.} - -\item{transform}{(Deprecated) A function or a character string naming -a function to be applied on the predicted responses -before summary statistics are computed.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{negative_rt}{Only relevant for Wiener diffusion models. -A flag indicating whether response times of responses -on the lower boundary should be returned as negative values. -This allows to distinguish responses on the upper and -lower boundary. Defaults to \code{FALSE}.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{sort}{Logical. Only relevant for time series models. -Indicating whether to return predicted values in the original -order (\code{FALSE}; default) or in the order of the -time series (\code{TRUE}).} - -\item{ntrys}{Parameter used in rejection sampling -for truncated discrete models only -(defaults to \code{5}). See Details for more information.} - -\item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, -this argument can be set globally via the \code{mc.cores} option.} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -An \code{array} of predicted response values. In univariate models, - the output is as an S x N matrix, where S is the number of posterior - draws and N is the number of observations. In multivariate models, an - additional dimension is added to the output which indexes along the - different response variables. -} -\description{ -Compute posterior draws of the posterior predictive distribution. Can be -performed for the data used to fit the model (posterior predictive checks) or -for new data. By definition, these draws have higher variance than draws -of the means of the posterior predictive distribution computed by -\code{\link{posterior_epred.brmsfit}}. This is because the residual error -is incorporated in \code{posterior_predict}. However, the estimated means of -both methods averaged across draws should be very similar. -} -\details{ -\code{NA} values within factors in \code{newdata}, - are interpreted as if all dummy variables of this factor are - zero. This allows, for instance, to make predictions of the grand mean - when using sum coding. - -In multilevel models, it is possible to -allow new levels of grouping factors to be used in the predictions. -This can be controlled via argument \code{allow_new_levels}. -New levels can be sampled in multiple ways, which can be controlled -via argument \code{sample_new_levels}. Both of these arguments are -documented in \code{\link{prepare_predictions}} along with several -other useful arguments to control specific aspects of the predictions. - -For truncated discrete models only: In the absence of any general - algorithm to sample from truncated discrete distributions, rejection - sampling is applied in this special case. This means that values are - sampled until a value lies within the defined truncation boundaries. In - practice, this procedure may be rather slow (especially in \R). Thus, we - try to do approximate rejection sampling by sampling each value - \code{ntrys} times and then select a valid value. If all values are - invalid, the closest boundary is used, instead. If there are more than a - few of these pathological cases, a warning will occur suggesting to - increase argument \code{ntrys}. -} -\examples{ -\dontrun{ -## fit a model -fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), - data = kidney, family = "exponential", inits = "0") - -## predicted responses -pp <- posterior_predict(fit) -str(pp) - -## predicted responses excluding the group-level effect of age -pp <- posterior_predict(fit, re_formula = ~ (1 | patient)) -str(pp) - -## predicted responses of patient 1 for new data -newdata <- data.frame( - sex = factor(c("male", "female")), - age = c(20, 50), - patient = c(1, 1) -) -pp <- posterior_predict(fit, newdata = newdata) -str(pp) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_predict.R +\name{posterior_predict.brmsfit} +\alias{posterior_predict.brmsfit} +\alias{posterior_predict} +\title{Draws from the Posterior Predictive Distribution} +\usage{ +\method{posterior_predict}{brmsfit}( + object, + newdata = NULL, + re_formula = NULL, + re.form = NULL, + transform = NULL, + resp = NULL, + negative_rt = FALSE, + ndraws = NULL, + draw_ids = NULL, + sort = FALSE, + ntrys = 5, + cores = NULL, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{re.form}{Alias of \code{re_formula}.} + +\item{transform}{(Deprecated) A function or a character string naming +a function to be applied on the predicted responses +before summary statistics are computed.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{negative_rt}{Only relevant for Wiener diffusion models. +A flag indicating whether response times of responses +on the lower boundary should be returned as negative values. +This allows to distinguish responses on the upper and +lower boundary. Defaults to \code{FALSE}.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{sort}{Logical. Only relevant for time series models. +Indicating whether to return predicted values in the original +order (\code{FALSE}; default) or in the order of the +time series (\code{TRUE}).} + +\item{ntrys}{Parameter used in rejection sampling +for truncated discrete models only +(defaults to \code{5}). See Details for more information.} + +\item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, +this argument can be set globally via the \code{mc.cores} option.} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +An \code{array} of predicted response values. In univariate models, + the output is as an S x N matrix, where S is the number of posterior + draws and N is the number of observations. In multivariate models, an + additional dimension is added to the output which indexes along the + different response variables. +} +\description{ +Compute posterior draws of the posterior predictive distribution. Can be +performed for the data used to fit the model (posterior predictive checks) or +for new data. By definition, these draws have higher variance than draws +of the means of the posterior predictive distribution computed by +\code{\link{posterior_epred.brmsfit}}. This is because the residual error +is incorporated in \code{posterior_predict}. However, the estimated means of +both methods averaged across draws should be very similar. +} +\details{ +\code{NA} values within factors in \code{newdata}, + are interpreted as if all dummy variables of this factor are + zero. This allows, for instance, to make predictions of the grand mean + when using sum coding. + +In multilevel models, it is possible to +allow new levels of grouping factors to be used in the predictions. +This can be controlled via argument \code{allow_new_levels}. +New levels can be sampled in multiple ways, which can be controlled +via argument \code{sample_new_levels}. Both of these arguments are +documented in \code{\link{prepare_predictions}} along with several +other useful arguments to control specific aspects of the predictions. + +For truncated discrete models only: In the absence of any general + algorithm to sample from truncated discrete distributions, rejection + sampling is applied in this special case. This means that values are + sampled until a value lies within the defined truncation boundaries. In + practice, this procedure may be rather slow (especially in \R). Thus, we + try to do approximate rejection sampling by sampling each value + \code{ntrys} times and then select a valid value. If all values are + invalid, the closest boundary is used, instead. If there are more than a + few of these pathological cases, a warning will occur suggesting to + increase argument \code{ntrys}. +} +\examples{ +\dontrun{ +## fit a model +fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), + data = kidney, family = "exponential", init = "0") + +## predicted responses +pp <- posterior_predict(fit) +str(pp) + +## predicted responses excluding the group-level effect of age +pp <- posterior_predict(fit, re_formula = ~ (1 | patient)) +str(pp) + +## predicted responses of patient 1 for new data +newdata <- data.frame( + sex = factor(c("male", "female")), + age = c(20, 50), + patient = c(1, 1) +) +pp <- posterior_predict(fit, newdata = newdata) +str(pp) +} + +} diff -Nru r-cran-brms-2.16.3/man/posterior_samples.brmsfit.Rd r-cran-brms-2.17.0/man/posterior_samples.brmsfit.Rd --- r-cran-brms-2.16.3/man/posterior_samples.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_samples.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,76 +1,76 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_samples.R -\name{posterior_samples.brmsfit} -\alias{posterior_samples.brmsfit} -\alias{posterior_samples} -\title{(Deprecated) Extract Posterior Samples} -\usage{ -\method{posterior_samples}{brmsfit}( - x, - pars = NA, - fixed = FALSE, - add_chain = FALSE, - subset = NULL, - as.matrix = FALSE, - as.array = FALSE, - ... -) - -posterior_samples(x, pars = NA, ...) -} -\arguments{ -\item{x}{An \code{R} object typically of class \code{brmsfit}} - -\item{pars}{Names of parameters for which posterior samples -should be returned, as given by a character vector or regular expressions. -By default, all posterior samples of all parameters are extracted.} - -\item{fixed}{Indicates whether parameter names -should be matched exactly (\code{TRUE}) or treated as -regular expressions (\code{FALSE}). Default is \code{FALSE}.} - -\item{add_chain}{A flag indicating if the returned \code{data.frame} -should contain two additional columns. The \code{chain} column -indicates the chain in which each sample was generated, the \code{iter} -column indicates the iteration number within each chain.} - -\item{subset}{A numeric vector indicating the rows -(i.e., posterior samples) to be returned. -If \code{NULL} (the default), all posterior samples are returned.} - -\item{as.matrix}{Should the output be a \code{matrix} -instead of a \code{data.frame}? Defaults to \code{FALSE}.} - -\item{as.array}{Should the output be an \code{array} -instead of a \code{data.frame}? Defaults to \code{FALSE}.} - -\item{...}{Arguments passed to individual methods (if applicable).} -} -\value{ -A data.frame (matrix or array) containing the posterior samples. -} -\description{ -Extract posterior samples of specified parameters. The -\code{posterior_samples} method is deprecated. We recommend using the more -modern and consistent \code{\link[brms:draws-brms]{as_draws_*}} extractor -functions of the \pkg{posterior} package instead. -} -\examples{ -\dontrun{ -fit <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = "cumulative") - -# extract posterior samples of population-level effects -samples1 <- posterior_samples(fit, pars = "^b") -head(samples1) - -# extract posterior samples of group-level standard deviations -samples2 <- posterior_samples(fit, pars = "^sd_") -head(samples2) -} - -} -\seealso{ -\code{\link[brms:draws-brms]{as_draws}}, - \code{\link[brms:as.data.frame.brmsfit]{as.data.frame}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_samples.R +\name{posterior_samples.brmsfit} +\alias{posterior_samples.brmsfit} +\alias{posterior_samples} +\title{(Deprecated) Extract Posterior Samples} +\usage{ +\method{posterior_samples}{brmsfit}( + x, + pars = NA, + fixed = FALSE, + add_chain = FALSE, + subset = NULL, + as.matrix = FALSE, + as.array = FALSE, + ... +) + +posterior_samples(x, pars = NA, ...) +} +\arguments{ +\item{x}{An \code{R} object typically of class \code{brmsfit}} + +\item{pars}{Names of parameters for which posterior samples +should be returned, as given by a character vector or regular expressions. +By default, all posterior samples of all parameters are extracted.} + +\item{fixed}{Indicates whether parameter names +should be matched exactly (\code{TRUE}) or treated as +regular expressions (\code{FALSE}). Default is \code{FALSE}.} + +\item{add_chain}{A flag indicating if the returned \code{data.frame} +should contain two additional columns. The \code{chain} column +indicates the chain in which each sample was generated, the \code{iter} +column indicates the iteration number within each chain.} + +\item{subset}{A numeric vector indicating the rows +(i.e., posterior samples) to be returned. +If \code{NULL} (the default), all posterior samples are returned.} + +\item{as.matrix}{Should the output be a \code{matrix} +instead of a \code{data.frame}? Defaults to \code{FALSE}.} + +\item{as.array}{Should the output be an \code{array} +instead of a \code{data.frame}? Defaults to \code{FALSE}.} + +\item{...}{Arguments passed to individual methods (if applicable).} +} +\value{ +A data.frame (matrix or array) containing the posterior samples. +} +\description{ +Extract posterior samples of specified parameters. The +\code{posterior_samples} method is deprecated. We recommend using the more +modern and consistent \code{\link[brms:draws-brms]{as_draws_*}} extractor +functions of the \pkg{posterior} package instead. +} +\examples{ +\dontrun{ +fit <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = "cumulative") + +# extract posterior samples of population-level effects +samples1 <- posterior_samples(fit, pars = "^b") +head(samples1) + +# extract posterior samples of group-level standard deviations +samples2 <- posterior_samples(fit, pars = "^sd_") +head(samples2) +} + +} +\seealso{ +\code{\link[brms:draws-brms]{as_draws}}, + \code{\link[brms:as.data.frame.brmsfit]{as.data.frame}} +} diff -Nru r-cran-brms-2.16.3/man/posterior_smooths.brmsfit.Rd r-cran-brms-2.17.0/man/posterior_smooths.brmsfit.Rd --- r-cran-brms-2.16.3/man/posterior_smooths.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_smooths.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,70 +1,70 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_smooths.R -\name{posterior_smooths.brmsfit} -\alias{posterior_smooths.brmsfit} -\alias{posterior_smooths} -\title{Posterior Predictions of Smooth Terms} -\usage{ -\method{posterior_smooths}{brmsfit}( - object, - smooth, - newdata = NULL, - resp = NULL, - dpar = NULL, - nlpar = NULL, - ndraws = NULL, - draw_ids = NULL, - ... -) - -posterior_smooths(object, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{smooth}{Name of a single smooth term for which predictions should -be computed.} - -\item{newdata}{An optional \code{data.frame} for which to evaluate -predictions. If \code{NULL} (default), the original data of the model is -used. Only those variables appearing in the chosen \code{smooth} term are -required.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{dpar}{Optional name of a predicted distributional parameter. -If specified, expected predictions of this parameters are returned.} - -\item{nlpar}{Optional name of a predicted non-linear parameter. -If specified, expected predictions of this parameters are returned.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{...}{Currently ignored.} -} -\value{ -An S x N matrix, where S is the number of - posterior draws and N is the number of observations. -} -\description{ -Compute posterior predictions of smooth \code{s} and \code{t2} terms of -models fitted with \pkg{brms}. -} -\examples{ -\dontrun{ -set.seed(0) -dat <- mgcv::gamSim(1, n = 200, scale = 2) -fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) -summary(fit) - -newdata <- data.frame(x2 = seq(0, 1, 10)) -str(posterior_smooths(fit, smooth = "s(x2)", newdata = newdata)) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_smooths.R +\name{posterior_smooths.brmsfit} +\alias{posterior_smooths.brmsfit} +\alias{posterior_smooths} +\title{Posterior Predictions of Smooth Terms} +\usage{ +\method{posterior_smooths}{brmsfit}( + object, + smooth, + newdata = NULL, + resp = NULL, + dpar = NULL, + nlpar = NULL, + ndraws = NULL, + draw_ids = NULL, + ... +) + +posterior_smooths(object, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{smooth}{Name of a single smooth term for which predictions should +be computed.} + +\item{newdata}{An optional \code{data.frame} for which to evaluate +predictions. If \code{NULL} (default), the original data of the model is +used. Only those variables appearing in the chosen \code{smooth} term are +required.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{dpar}{Optional name of a predicted distributional parameter. +If specified, expected predictions of this parameters are returned.} + +\item{nlpar}{Optional name of a predicted non-linear parameter. +If specified, expected predictions of this parameters are returned.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{...}{Currently ignored.} +} +\value{ +An S x N matrix, where S is the number of + posterior draws and N is the number of observations. +} +\description{ +Compute posterior predictions of smooth \code{s} and \code{t2} terms of +models fitted with \pkg{brms}. +} +\examples{ +\dontrun{ +set.seed(0) +dat <- mgcv::gamSim(1, n = 200, scale = 2) +fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) +summary(fit) + +newdata <- data.frame(x2 = seq(0, 1, 10)) +str(posterior_smooths(fit, smooth = "s(x2)", newdata = newdata)) +} + +} diff -Nru r-cran-brms-2.16.3/man/posterior_summary.Rd r-cran-brms-2.17.0/man/posterior_summary.Rd --- r-cran-brms-2.16.3/man/posterior_summary.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_summary.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,66 +1,66 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary.R -\name{posterior_summary} -\alias{posterior_summary} -\alias{posterior_summary.default} -\alias{posterior_summary.brmsfit} -\title{Summarize Posterior draws} -\usage{ -posterior_summary(x, ...) - -\method{posterior_summary}{default}(x, probs = c(0.025, 0.975), robust = FALSE, ...) - -\method{posterior_summary}{brmsfit}( - x, - pars = NA, - variable = NULL, - probs = c(0.025, 0.975), - robust = FALSE, - ... -) -} -\arguments{ -\item{x}{An \R object.} - -\item{...}{More arguments passed to or from other methods.} - -\item{probs}{The percentiles to be computed by the -\code{\link[stats:quantile]{quantile}} function.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead.} - -\item{pars}{Deprecated alias of \code{variable}. For reasons of backwards -compatibility, \code{pars} is interpreted as a vector of regular -expressions by default unless \code{fixed = TRUE} is specified.} - -\item{variable}{A character vector providing the variables to extract. -By default, all variables are extracted.} -} -\value{ -A matrix where rows indicate variables -and columns indicate the summary estimates. -} -\description{ -Summarizes posterior draws based on point estimates (mean or median), -estimation errors (SD or MAD) and quantiles. This function mainly exists to -retain backwards compatibility. It will eventually be replaced by functions -of the \pkg{posterior} package (see examples below). -} -\examples{ -\dontrun{ -fit <- brm(time ~ age * sex, data = kidney) -posterior_summary(fit) - -# recommended workflow using posterior -library(posterior) -draws <- as_draws_array(fit) -summarise_draws(draws, default_summary_measures()) -} - -} -\seealso{ -\code{\link[posterior:summarize_draws]{summarize_draws}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{posterior_summary} +\alias{posterior_summary} +\alias{posterior_summary.default} +\alias{posterior_summary.brmsfit} +\title{Summarize Posterior draws} +\usage{ +posterior_summary(x, ...) + +\method{posterior_summary}{default}(x, probs = c(0.025, 0.975), robust = FALSE, ...) + +\method{posterior_summary}{brmsfit}( + x, + pars = NA, + variable = NULL, + probs = c(0.025, 0.975), + robust = FALSE, + ... +) +} +\arguments{ +\item{x}{An \R object.} + +\item{...}{More arguments passed to or from other methods.} + +\item{probs}{The percentiles to be computed by the +\code{\link[stats:quantile]{quantile}} function.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead.} + +\item{pars}{Deprecated alias of \code{variable}. For reasons of backwards +compatibility, \code{pars} is interpreted as a vector of regular +expressions by default unless \code{fixed = TRUE} is specified.} + +\item{variable}{A character vector providing the variables to extract. +By default, all variables are extracted.} +} +\value{ +A matrix where rows indicate variables +and columns indicate the summary estimates. +} +\description{ +Summarizes posterior draws based on point estimates (mean or median), +estimation errors (SD or MAD) and quantiles. This function mainly exists to +retain backwards compatibility. It will eventually be replaced by functions +of the \pkg{posterior} package (see examples below). +} +\examples{ +\dontrun{ +fit <- brm(time ~ age * sex, data = kidney) +posterior_summary(fit) + +# recommended workflow using posterior +library(posterior) +draws <- as_draws_array(fit) +summarise_draws(draws, default_summary_measures()) +} + +} +\seealso{ +\code{\link[posterior:summarize_draws]{summarize_draws}} +} diff -Nru r-cran-brms-2.16.3/man/posterior_table.Rd r-cran-brms-2.17.0/man/posterior_table.Rd --- r-cran-brms-2.16.3/man/posterior_table.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/posterior_table.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,34 +1,34 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary.R -\name{posterior_table} -\alias{posterior_table} -\title{Table Creation for Posterior Draws} -\usage{ -posterior_table(x, levels = NULL) -} -\arguments{ -\item{x}{A matrix of posterior draws where rows -indicate draws and columns indicate parameters.} - -\item{levels}{Optional values of possible posterior values. -Defaults to all unique values in \code{x}.} -} -\value{ -A matrix where rows indicate parameters - and columns indicate the unique values of - posterior draws. -} -\description{ -Create a table for unique values of posterior draws. -This is usually only useful when summarizing predictions -of ordinal models. -} -\examples{ -\dontrun{ -fit <- brm(rating ~ period + carry + treat, - data = inhaler, family = cumulative()) -pr <- predict(fit, summary = FALSE) -posterior_table(pr) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{posterior_table} +\alias{posterior_table} +\title{Table Creation for Posterior Draws} +\usage{ +posterior_table(x, levels = NULL) +} +\arguments{ +\item{x}{A matrix of posterior draws where rows +indicate draws and columns indicate parameters.} + +\item{levels}{Optional values of possible posterior values. +Defaults to all unique values in \code{x}.} +} +\value{ +A matrix where rows indicate parameters + and columns indicate the unique values of + posterior draws. +} +\description{ +Create a table for unique values of posterior draws. +This is usually only useful when summarizing predictions +of ordinal models. +} +\examples{ +\dontrun{ +fit <- brm(rating ~ period + carry + treat, + data = inhaler, family = cumulative()) +pr <- predict(fit, summary = FALSE) +posterior_table(pr) +} + +} diff -Nru r-cran-brms-2.16.3/man/post_prob.brmsfit.Rd r-cran-brms-2.17.0/man/post_prob.brmsfit.Rd --- r-cran-brms-2.16.3/man/post_prob.brmsfit.Rd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/man/post_prob.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,84 +1,84 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/bridgesampling.R -\name{post_prob.brmsfit} -\alias{post_prob.brmsfit} -\alias{post_prob} -\title{Posterior Model Probabilities from Marginal Likelihoods} -\usage{ -\method{post_prob}{brmsfit}(x, ..., prior_prob = NULL, model_names = NULL) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{prior_prob}{Numeric vector with prior model probabilities. -If omitted, a uniform prior is used (i.e., all models are equally -likely a priori). The default \code{NULL} corresponds to equal -prior model weights.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} -} -\description{ -Compute posterior model probabilities from marginal likelihoods. -The \code{brmsfit} method is just a thin wrapper around -the corresponding method for \code{bridge} objects. -} -\details{ -Computing the marginal likelihood requires samples - of all variables defined in Stan's \code{parameters} block - to be saved. Otherwise \code{post_prob} cannot be computed. - Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, - if you are planning to apply \code{post_prob} to your models. - - The computation of model probabilities based on bridge sampling requires - a lot more posterior samples than usual. A good conservative - rule of thump is perhaps 10-fold more samples (read: the default of 4000 - samples may not be enough in many cases). If not enough posterior - samples are provided, the bridge sampling algorithm tends to be - unstable leading to considerably different results each time it is run. - We thus recommend running \code{post_prob} - multiple times to check the stability of the results. - - More details are provided under - \code{\link[bridgesampling:post_prob]{bridgesampling::post_prob}}. -} -\examples{ -\dontrun{ -# model with the treatment effect -fit1 <- brm( - count ~ zAge + zBase + Trt, - data = epilepsy, family = negbinomial(), - prior = prior(normal(0, 1), class = b), - save_all_pars = TRUE -) -summary(fit1) - -# model without the treatent effect -fit2 <- brm( - count ~ zAge + zBase, - data = epilepsy, family = negbinomial(), - prior = prior(normal(0, 1), class = b), - save_all_pars = TRUE -) -summary(fit2) - -# compute the posterior model probabilities -post_prob(fit1, fit2) - -# specify prior model probabilities -post_prob(fit1, fit2, prior_prob = c(0.8, 0.2)) -} - -} -\seealso{ -\code{ - \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, - \link[brms:bayes_factor.brmsfit]{bayes_factor} -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bridgesampling.R +\name{post_prob.brmsfit} +\alias{post_prob.brmsfit} +\alias{post_prob} +\title{Posterior Model Probabilities from Marginal Likelihoods} +\usage{ +\method{post_prob}{brmsfit}(x, ..., prior_prob = NULL, model_names = NULL) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{prior_prob}{Numeric vector with prior model probabilities. +If omitted, a uniform prior is used (i.e., all models are equally +likely a priori). The default \code{NULL} corresponds to equal +prior model weights.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} +} +\description{ +Compute posterior model probabilities from marginal likelihoods. +The \code{brmsfit} method is just a thin wrapper around +the corresponding method for \code{bridge} objects. +} +\details{ +Computing the marginal likelihood requires samples + of all variables defined in Stan's \code{parameters} block + to be saved. Otherwise \code{post_prob} cannot be computed. + Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, + if you are planning to apply \code{post_prob} to your models. + + The computation of model probabilities based on bridge sampling requires + a lot more posterior samples than usual. A good conservative + rule of thump is perhaps 10-fold more samples (read: the default of 4000 + samples may not be enough in many cases). If not enough posterior + samples are provided, the bridge sampling algorithm tends to be + unstable leading to considerably different results each time it is run. + We thus recommend running \code{post_prob} + multiple times to check the stability of the results. + + More details are provided under + \code{\link[bridgesampling:post_prob]{bridgesampling::post_prob}}. +} +\examples{ +\dontrun{ +# model with the treatment effect +fit1 <- brm( + count ~ zAge + zBase + Trt, + data = epilepsy, family = negbinomial(), + prior = prior(normal(0, 1), class = b), + save_all_pars = TRUE +) +summary(fit1) + +# model without the treatent effect +fit2 <- brm( + count ~ zAge + zBase, + data = epilepsy, family = negbinomial(), + prior = prior(normal(0, 1), class = b), + save_all_pars = TRUE +) +summary(fit2) + +# compute the posterior model probabilities +post_prob(fit1, fit2) + +# specify prior model probabilities +post_prob(fit1, fit2, prior_prob = c(0.8, 0.2)) +} + +} +\seealso{ +\code{ + \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, + \link[brms:bayes_factor.brmsfit]{bayes_factor} +} +} diff -Nru r-cran-brms-2.16.3/man/pp_average.brmsfit.Rd r-cran-brms-2.17.0/man/pp_average.brmsfit.Rd --- r-cran-brms-2.16.3/man/pp_average.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/pp_average.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,110 +1,110 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/model_weights.R -\name{pp_average.brmsfit} -\alias{pp_average.brmsfit} -\alias{pp_average} -\title{Posterior predictive draws averaged across models} -\usage{ -\method{pp_average}{brmsfit}( - x, - ..., - weights = "stacking", - method = "posterior_predict", - ndraws = NULL, - nsamples = NULL, - summary = TRUE, - probs = c(0.025, 0.975), - robust = FALSE, - model_names = NULL, - control = list(), - seed = NULL -) - -pp_average(x, ...) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{weights}{Name of the criterion to compute weights from. Should be one -of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current -default), or \code{"bma"}, \code{"pseudobma"}, For the former three -options, Akaike weights will be computed based on the information criterion -values returned by the respective methods. For \code{"stacking"} and -\code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to -obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be -used to compute Bayesian model averaging weights based on log marginal -likelihood values (make sure to specify reasonable priors in this case). -For some methods, \code{weights} may also be a numeric vector of -pre-specified weights.} - -\item{method}{Method used to obtain predictions to average over. Should be -one of \code{"posterior_predict"} (default), \code{"posterior_epred"}, -\code{"posterior_linpred"} or \code{"predictive_error"}.} - -\item{ndraws}{Total number of posterior draws to use.} - -\item{nsamples}{Deprecated alias of \code{ndraws}.} - -\item{summary}{Should summary statistics - (i.e. means, sds, and 95\% intervals) be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} - -\item{control}{Optional \code{list} of further arguments -passed to the function specified in \code{weights}.} - -\item{seed}{A single numeric value passed to \code{\link{set.seed}} -to make results reproducible.} -} -\value{ -Same as the output of the method specified - in argument \code{method}. -} -\description{ -Compute posterior predictive draws averaged across models. -Weighting can be done in various ways, for instance using -Akaike weights based on information criteria or -marginal likelihoods. -} -\details{ -Weights are computed with the \code{\link{model_weights}} method. -} -\examples{ -\dontrun{ -# model with 'treat' as predictor -fit1 <- brm(rating ~ treat + period + carry, data = inhaler) -summary(fit1) - -# model without 'treat' as predictor -fit2 <- brm(rating ~ period + carry, data = inhaler) -summary(fit2) - -# compute model-averaged predicted values -(df <- unique(inhaler[, c("treat", "period", "carry")])) -pp_average(fit1, fit2, newdata = df) - -# compute model-averaged fitted values -pp_average(fit1, fit2, method = "fitted", newdata = df) -} - -} -\seealso{ -\code{\link{model_weights}}, \code{\link{posterior_average}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/model_weights.R +\name{pp_average.brmsfit} +\alias{pp_average.brmsfit} +\alias{pp_average} +\title{Posterior predictive draws averaged across models} +\usage{ +\method{pp_average}{brmsfit}( + x, + ..., + weights = "stacking", + method = "posterior_predict", + ndraws = NULL, + nsamples = NULL, + summary = TRUE, + probs = c(0.025, 0.975), + robust = FALSE, + model_names = NULL, + control = list(), + seed = NULL +) + +pp_average(x, ...) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{weights}{Name of the criterion to compute weights from. Should be one +of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current +default), or \code{"bma"}, \code{"pseudobma"}, For the former three +options, Akaike weights will be computed based on the information criterion +values returned by the respective methods. For \code{"stacking"} and +\code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to +obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be +used to compute Bayesian model averaging weights based on log marginal +likelihood values (make sure to specify reasonable priors in this case). +For some methods, \code{weights} may also be a numeric vector of +pre-specified weights.} + +\item{method}{Method used to obtain predictions to average over. Should be +one of \code{"posterior_predict"} (default), \code{"posterior_epred"}, +\code{"posterior_linpred"} or \code{"predictive_error"}.} + +\item{ndraws}{Total number of posterior draws to use.} + +\item{nsamples}{Deprecated alias of \code{ndraws}.} + +\item{summary}{Should summary statistics + (i.e. means, sds, and 95\% intervals) be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} + +\item{control}{Optional \code{list} of further arguments +passed to the function specified in \code{weights}.} + +\item{seed}{A single numeric value passed to \code{\link{set.seed}} +to make results reproducible.} +} +\value{ +Same as the output of the method specified + in argument \code{method}. +} +\description{ +Compute posterior predictive draws averaged across models. +Weighting can be done in various ways, for instance using +Akaike weights based on information criteria or +marginal likelihoods. +} +\details{ +Weights are computed with the \code{\link{model_weights}} method. +} +\examples{ +\dontrun{ +# model with 'treat' as predictor +fit1 <- brm(rating ~ treat + period + carry, data = inhaler) +summary(fit1) + +# model without 'treat' as predictor +fit2 <- brm(rating ~ period + carry, data = inhaler) +summary(fit2) + +# compute model-averaged predicted values +(df <- unique(inhaler[, c("treat", "period", "carry")])) +pp_average(fit1, fit2, newdata = df) + +# compute model-averaged fitted values +pp_average(fit1, fit2, method = "fitted", newdata = df) +} + +} +\seealso{ +\code{\link{model_weights}}, \code{\link{posterior_average}} +} diff -Nru r-cran-brms-2.16.3/man/pp_check.brmsfit.Rd r-cran-brms-2.17.0/man/pp_check.brmsfit.Rd --- r-cran-brms-2.16.3/man/pp_check.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/pp_check.brmsfit.Rd 2022-04-08 11:57:41.000000000 +0000 @@ -1,95 +1,104 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pp_check.R -\name{pp_check.brmsfit} -\alias{pp_check.brmsfit} -\alias{pp_check} -\title{Posterior Predictive Checks for \code{brmsfit} Objects} -\usage{ -\method{pp_check}{brmsfit}( - object, - type, - ndraws = NULL, - nsamples = NULL, - group = NULL, - x = NULL, - newdata = NULL, - resp = NULL, - draw_ids = NULL, - subset = NULL, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{type}{Type of the ppc plot as given by a character string. -See \code{\link[bayesplot:PPC-overview]{PPC}} for an overview -of currently supported types. You may also use an invalid -type (e.g. \code{type = "xyz"}) to get a list of supported -types in the resulting error message.} - -\item{ndraws}{Positive integer indicating how many -posterior draws should be used. -If \code{NULL} all draws are used. If not specified, -the number of posterior draws is chosen automatically. -Ignored if \code{draw_ids} is not \code{NULL}.} - -\item{nsamples}{Deprecated alias of \code{ndraws}.} - -\item{group}{Optional name of a factor variable in the model -by which to stratify the ppc plot. This argument is required for -ppc \code{*_grouped} types and ignored otherwise.} - -\item{x}{Optional name of a variable in the model. -Only used for ppc types having an \code{x} argument -and ignored otherwise.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{subset}{Deprecated alias of \code{draw_ids}.} - -\item{...}{Further arguments passed to \code{\link{predict.brmsfit}} -as well as to the PPC function specified in \code{type}.} -} -\value{ -A ggplot object that can be further - customized using the \pkg{ggplot2} package. -} -\description{ -Perform posterior predictive checks with the help -of the \pkg{bayesplot} package. -} -\details{ -For a detailed explanation of each of the ppc functions, -see the \code{\link[bayesplot:PPC-overview]{PPC}} -documentation of the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} -package. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt - + (1|patient) + (1|obs), - data = epilepsy, family = poisson()) - -pp_check(fit) # shows dens_overlay plot by default -pp_check(fit, type = "error_hist", ndraws = 11) -pp_check(fit, type = "scatter_avg", ndraws = 100) -pp_check(fit, type = "stat_2d") -pp_check(fit, type = "rootogram") -pp_check(fit, type = "loo_pit") - -## get an overview of all valid types -pp_check(fit, type = "xyz") -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pp_check.R +\name{pp_check.brmsfit} +\alias{pp_check.brmsfit} +\alias{pp_check} +\title{Posterior Predictive Checks for \code{brmsfit} Objects} +\usage{ +\method{pp_check}{brmsfit}( + object, + type, + ndraws = NULL, + prefix = c("ppc", "ppd"), + group = NULL, + x = NULL, + newdata = NULL, + resp = NULL, + draw_ids = NULL, + nsamples = NULL, + subset = NULL, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{type}{Type of the ppc plot as given by a character string. +See \code{\link[bayesplot:PPC-overview]{PPC}} for an overview +of currently supported types. You may also use an invalid +type (e.g. \code{type = "xyz"}) to get a list of supported +types in the resulting error message.} + +\item{ndraws}{Positive integer indicating how many +posterior draws should be used. +If \code{NULL} all draws are used. If not specified, +the number of posterior draws is chosen automatically. +Ignored if \code{draw_ids} is not \code{NULL}.} + +\item{prefix}{The prefix of the \pkg{bayesplot} function to be applied. +Either `"ppc"` (posterior predictive check; the default) +or `"ppd"` (posterior predictive distribution), the latter being the same +as the former except that the observed data is not shown for `"ppd"`.} + +\item{group}{Optional name of a factor variable in the model +by which to stratify the ppc plot. This argument is required for +ppc \code{*_grouped} types and ignored otherwise.} + +\item{x}{Optional name of a variable in the model. +Only used for ppc types having an \code{x} argument +and ignored otherwise.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{nsamples}{Deprecated alias of \code{ndraws}.} + +\item{subset}{Deprecated alias of \code{draw_ids}.} + +\item{...}{Further arguments passed to \code{\link{predict.brmsfit}} +as well as to the PPC function specified in \code{type}.} +} +\value{ +A ggplot object that can be further + customized using the \pkg{ggplot2} package. +} +\description{ +Perform posterior predictive checks with the help +of the \pkg{bayesplot} package. +} +\details{ +For a detailed explanation of each of the ppc functions, +see the \code{\link[bayesplot:PPC-overview]{PPC}} +documentation of the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} +package. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + + (1|patient) + (1|obs), + data = epilepsy, family = poisson()) + +pp_check(fit) # shows dens_overlay plot by default +pp_check(fit, type = "error_hist", ndraws = 11) +pp_check(fit, type = "scatter_avg", ndraws = 100) +pp_check(fit, type = "stat_2d") +pp_check(fit, type = "rootogram") +pp_check(fit, type = "loo_pit") + +## get an overview of all valid types +pp_check(fit, type = "xyz") + +## get a plot without the observed data +pp_check(fit, prefix = "ppd") +} + +} diff -Nru r-cran-brms-2.16.3/man/pp_mixture.brmsfit.Rd r-cran-brms-2.17.0/man/pp_mixture.brmsfit.Rd --- r-cran-brms-2.16.3/man/pp_mixture.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/pp_mixture.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,121 +1,121 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pp_mixture.R -\name{pp_mixture.brmsfit} -\alias{pp_mixture.brmsfit} -\alias{pp_mixture} -\title{Posterior Probabilities of Mixture Component Memberships} -\usage{ -\method{pp_mixture}{brmsfit}( - x, - newdata = NULL, - re_formula = NULL, - resp = NULL, - ndraws = NULL, - draw_ids = NULL, - log = FALSE, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - ... -) - -pp_mixture(x, ...) -} -\arguments{ -\item{x}{An \R object usually of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{log}{Logical; Indicates whether to return -probabilities on the log-scale.} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -If \code{summary = TRUE}, an N x E x K array, -where N is the number of observations, K is the number -of mixture components, and E is equal to \code{length(probs) + 2}. -If \code{summary = FALSE}, an S x N x K array, where -S is the number of posterior draws. -} -\description{ -Compute the posterior probabilities of mixture component -memberships for each observation including uncertainty -estimates. -} -\details{ -The returned probabilities can be written as -\eqn{P(Kn = k | Yn)}, that is the posterior probability -that observation n originates from component k. -They are computed using Bayes' Theorem -\deqn{P(Kn = k | Yn) = P(Yn | Kn = k) P(Kn = k) / P(Yn),} -where \eqn{P(Yn | Kn = k)} is the (posterior) likelihood -of observation n for component k, \eqn{P(Kn = k)} is -the (posterior) mixing probability of component k -(i.e. parameter \code{theta}), and -\deqn{P(Yn) = \sum (k=1,...,K) P(Yn | Kn = k) P(Kn = k)} -is a normalizing constant. -} -\examples{ -\dontrun{ -## simulate some data -set.seed(1234) -dat <- data.frame( - y = c(rnorm(100), rnorm(50, 2)), - x = rnorm(150) -) -## fit a simple normal mixture model -mix <- mixture(gaussian, nmix = 2) -prior <- c( - prior(normal(0, 5), Intercept, nlpar = mu1), - prior(normal(0, 5), Intercept, nlpar = mu2), - prior(dirichlet(2, 2), theta) -) -fit1 <- brm(bf(y ~ x), dat, family = mix, - prior = prior, chains = 2, inits = 0) -summary(fit1) - -## compute the membership probabilities -ppm <- pp_mixture(fit1) -str(ppm) - -## extract point estimates for each observation -head(ppm[, 1, ]) - -## classify every observation according to -## the most likely component -apply(ppm[, 1, ], 1, which.max) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pp_mixture.R +\name{pp_mixture.brmsfit} +\alias{pp_mixture.brmsfit} +\alias{pp_mixture} +\title{Posterior Probabilities of Mixture Component Memberships} +\usage{ +\method{pp_mixture}{brmsfit}( + x, + newdata = NULL, + re_formula = NULL, + resp = NULL, + ndraws = NULL, + draw_ids = NULL, + log = FALSE, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + ... +) + +pp_mixture(x, ...) +} +\arguments{ +\item{x}{An \R object usually of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{log}{Logical; Indicates whether to return +probabilities on the log-scale.} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +If \code{summary = TRUE}, an N x E x K array, +where N is the number of observations, K is the number +of mixture components, and E is equal to \code{length(probs) + 2}. +If \code{summary = FALSE}, an S x N x K array, where +S is the number of posterior draws. +} +\description{ +Compute the posterior probabilities of mixture component +memberships for each observation including uncertainty +estimates. +} +\details{ +The returned probabilities can be written as +\eqn{P(Kn = k | Yn)}, that is the posterior probability +that observation n originates from component k. +They are computed using Bayes' Theorem +\deqn{P(Kn = k | Yn) = P(Yn | Kn = k) P(Kn = k) / P(Yn),} +where \eqn{P(Yn | Kn = k)} is the (posterior) likelihood +of observation n for component k, \eqn{P(Kn = k)} is +the (posterior) mixing probability of component k +(i.e. parameter \code{theta}), and +\deqn{P(Yn) = \sum (k=1,...,K) P(Yn | Kn = k) P(Kn = k)} +is a normalizing constant. +} +\examples{ +\dontrun{ +## simulate some data +set.seed(1234) +dat <- data.frame( + y = c(rnorm(100), rnorm(50, 2)), + x = rnorm(150) +) +## fit a simple normal mixture model +mix <- mixture(gaussian, nmix = 2) +prior <- c( + prior(normal(0, 5), Intercept, nlpar = mu1), + prior(normal(0, 5), Intercept, nlpar = mu2), + prior(dirichlet(2, 2), theta) +) +fit1 <- brm(bf(y ~ x), dat, family = mix, + prior = prior, chains = 2, init = 0) +summary(fit1) + +## compute the membership probabilities +ppm <- pp_mixture(fit1) +str(ppm) + +## extract point estimates for each observation +head(ppm[, 1, ]) + +## classify every observation according to +## the most likely component +apply(ppm[, 1, ], 1, which.max) +} + +} diff -Nru r-cran-brms-2.16.3/man/predict.brmsfit.Rd r-cran-brms-2.17.0/man/predict.brmsfit.Rd --- r-cran-brms-2.16.3/man/predict.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/predict.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,132 +1,132 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_predict.R -\name{predict.brmsfit} -\alias{predict.brmsfit} -\title{Draws from the Posterior Predictive Distribution} -\usage{ -\method{predict}{brmsfit}( - object, - newdata = NULL, - re_formula = NULL, - transform = NULL, - resp = NULL, - negative_rt = FALSE, - ndraws = NULL, - draw_ids = NULL, - sort = FALSE, - ntrys = 5, - cores = NULL, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{transform}{(Deprecated) A function or a character string naming -a function to be applied on the predicted responses -before summary statistics are computed.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{negative_rt}{Only relevant for Wiener diffusion models. -A flag indicating whether response times of responses -on the lower boundary should be returned as negative values. -This allows to distinguish responses on the upper and -lower boundary. Defaults to \code{FALSE}.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{sort}{Logical. Only relevant for time series models. -Indicating whether to return predicted values in the original -order (\code{FALSE}; default) or in the order of the -time series (\code{TRUE}).} - -\item{ntrys}{Parameter used in rejection sampling -for truncated discrete models only -(defaults to \code{5}). See Details for more information.} - -\item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, -this argument can be set globally via the \code{mc.cores} option.} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -An \code{array} of predicted response values. - If \code{summary = FALSE} the output resembles those of - \code{\link{posterior_predict.brmsfit}}. - - If \code{summary = TRUE} the output depends on the family: For categorical - and ordinal families, the output is an N x C matrix, where N is the number - of observations, C is the number of categories, and the values are - predicted category probabilities. For all other families, the output is a N - x E matrix where E = \code{2 + length(probs)} is the number of summary - statistics: The \code{Estimate} column contains point estimates (either - mean or median depending on argument \code{robust}), while the - \code{Est.Error} column contains uncertainty estimates (either standard - deviation or median absolute deviation depending on argument - \code{robust}). The remaining columns starting with \code{Q} contain - quantile estimates as specified via argument \code{probs}. -} -\description{ -This method is an alias of \code{\link{posterior_predict.brmsfit}} -with additional arguments for obtaining summaries of the computed draws. -} -\examples{ -\dontrun{ -## fit a model -fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), - data = kidney, family = "exponential", inits = "0") - -## predicted responses -pp <- predict(fit) -head(pp) - -## predicted responses excluding the group-level effect of age -pp <- predict(fit, re_formula = ~ (1 | patient)) -head(pp) - -## predicted responses of patient 1 for new data -newdata <- data.frame( - sex = factor(c("male", "female")), - age = c(20, 50), - patient = c(1, 1) -) -predict(fit, newdata = newdata) -} - -} -\seealso{ -\code{\link{posterior_predict.brmsfit}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_predict.R +\name{predict.brmsfit} +\alias{predict.brmsfit} +\title{Draws from the Posterior Predictive Distribution} +\usage{ +\method{predict}{brmsfit}( + object, + newdata = NULL, + re_formula = NULL, + transform = NULL, + resp = NULL, + negative_rt = FALSE, + ndraws = NULL, + draw_ids = NULL, + sort = FALSE, + ntrys = 5, + cores = NULL, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{transform}{(Deprecated) A function or a character string naming +a function to be applied on the predicted responses +before summary statistics are computed.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{negative_rt}{Only relevant for Wiener diffusion models. +A flag indicating whether response times of responses +on the lower boundary should be returned as negative values. +This allows to distinguish responses on the upper and +lower boundary. Defaults to \code{FALSE}.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{sort}{Logical. Only relevant for time series models. +Indicating whether to return predicted values in the original +order (\code{FALSE}; default) or in the order of the +time series (\code{TRUE}).} + +\item{ntrys}{Parameter used in rejection sampling +for truncated discrete models only +(defaults to \code{5}). See Details for more information.} + +\item{cores}{Number of cores (defaults to \code{1}). On non-Windows systems, +this argument can be set globally via the \code{mc.cores} option.} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +An \code{array} of predicted response values. + If \code{summary = FALSE} the output resembles those of + \code{\link{posterior_predict.brmsfit}}. + + If \code{summary = TRUE} the output depends on the family: For categorical + and ordinal families, the output is an N x C matrix, where N is the number + of observations, C is the number of categories, and the values are + predicted category probabilities. For all other families, the output is a N + x E matrix where E = \code{2 + length(probs)} is the number of summary + statistics: The \code{Estimate} column contains point estimates (either + mean or median depending on argument \code{robust}), while the + \code{Est.Error} column contains uncertainty estimates (either standard + deviation or median absolute deviation depending on argument + \code{robust}). The remaining columns starting with \code{Q} contain + quantile estimates as specified via argument \code{probs}. +} +\description{ +This method is an alias of \code{\link{posterior_predict.brmsfit}} +with additional arguments for obtaining summaries of the computed draws. +} +\examples{ +\dontrun{ +## fit a model +fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), + data = kidney, family = "exponential", init = "0") + +## predicted responses +pp <- predict(fit) +head(pp) + +## predicted responses excluding the group-level effect of age +pp <- predict(fit, re_formula = ~ (1 | patient)) +head(pp) + +## predicted responses of patient 1 for new data +newdata <- data.frame( + sex = factor(c("male", "female")), + age = c(20, 50), + patient = c(1, 1) +) +predict(fit, newdata = newdata) +} + +} +\seealso{ +\code{\link{posterior_predict.brmsfit}} +} diff -Nru r-cran-brms-2.16.3/man/predictive_error.brmsfit.Rd r-cran-brms-2.17.0/man/predictive_error.brmsfit.Rd --- r-cran-brms-2.16.3/man/predictive_error.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/predictive_error.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,73 +1,73 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/predictive_error.R -\name{predictive_error.brmsfit} -\alias{predictive_error.brmsfit} -\alias{predictive_error} -\title{Posterior Draws of Predictive Errors} -\usage{ -\method{predictive_error}{brmsfit}( - object, - newdata = NULL, - re_formula = NULL, - re.form = NULL, - resp = NULL, - ndraws = NULL, - draw_ids = NULL, - sort = FALSE, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{re.form}{Alias of \code{re_formula}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{sort}{Logical. Only relevant for time series models. -Indicating whether to return predicted values in the original -order (\code{FALSE}; default) or in the order of the -time series (\code{TRUE}).} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -An S x N \code{array} of predictive error draws, where S is the - number of posterior draws and N is the number of observations. -} -\description{ -Compute posterior draws of predictive errors, that is, observed minus -predicted responses. Can be performed for the data used to fit the model -(posterior predictive checks) or for new data. -} -\examples{ -\dontrun{ -## fit a model -fit <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler, cores = 2) - -## extract predictive errors -pe <- predictive_error(fit) -str(pe) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predictive_error.R +\name{predictive_error.brmsfit} +\alias{predictive_error.brmsfit} +\alias{predictive_error} +\title{Posterior Draws of Predictive Errors} +\usage{ +\method{predictive_error}{brmsfit}( + object, + newdata = NULL, + re_formula = NULL, + re.form = NULL, + resp = NULL, + ndraws = NULL, + draw_ids = NULL, + sort = FALSE, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{re.form}{Alias of \code{re_formula}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{sort}{Logical. Only relevant for time series models. +Indicating whether to return predicted values in the original +order (\code{FALSE}; default) or in the order of the +time series (\code{TRUE}).} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +An S x N \code{array} of predictive error draws, where S is the + number of posterior draws and N is the number of observations. +} +\description{ +Compute posterior draws of predictive errors, that is, observed minus +predicted responses. Can be performed for the data used to fit the model +(posterior predictive checks) or for new data. +} +\examples{ +\dontrun{ +## fit a model +fit <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler, cores = 2) + +## extract predictive errors +pe <- predictive_error(fit) +str(pe) +} + +} diff -Nru r-cran-brms-2.16.3/man/predictive_interval.brmsfit.Rd r-cran-brms-2.17.0/man/predictive_interval.brmsfit.Rd --- r-cran-brms-2.16.3/man/predictive_interval.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/predictive_interval.brmsfit.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,31 +1,31 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/posterior_predict.R -\name{predictive_interval.brmsfit} -\alias{predictive_interval.brmsfit} -\alias{predictive_interval} -\title{Predictive Intervals} -\usage{ -\method{predictive_interval}{brmsfit}(object, prob = 0.9, ...) -} -\arguments{ -\item{object}{An \R object of class \code{brmsfit}.} - -\item{prob}{A number p (0 < p < 1) indicating the desired probability mass to -include in the intervals. Defaults to \code{0.9}.} - -\item{...}{Further arguments passed to \code{\link{posterior_predict}}.} -} -\value{ -A matrix with 2 columns for the lower and upper bounds of the - intervals, respectively, and as many rows as observations being predicted. -} -\description{ -Compute intervals from the posterior predictive distribution. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zBase, data = epilepsy, family = poisson()) -predictive_interval(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/posterior_predict.R +\name{predictive_interval.brmsfit} +\alias{predictive_interval.brmsfit} +\alias{predictive_interval} +\title{Predictive Intervals} +\usage{ +\method{predictive_interval}{brmsfit}(object, prob = 0.9, ...) +} +\arguments{ +\item{object}{An \R object of class \code{brmsfit}.} + +\item{prob}{A number p (0 < p < 1) indicating the desired probability mass to +include in the intervals. Defaults to \code{0.9}.} + +\item{...}{Further arguments passed to \code{\link{posterior_predict}}.} +} +\value{ +A matrix with 2 columns for the lower and upper bounds of the + intervals, respectively, and as many rows as observations being predicted. +} +\description{ +Compute intervals from the posterior predictive distribution. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zBase, data = epilepsy, family = poisson()) +predictive_interval(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/prepare_predictions.Rd r-cran-brms-2.17.0/man/prepare_predictions.Rd --- r-cran-brms-2.16.3/man/prepare_predictions.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/prepare_predictions.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,123 +1,123 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prepare_predictions.R -\name{prepare_predictions.brmsfit} -\alias{prepare_predictions.brmsfit} -\alias{prepare_predictions} -\alias{extract_draws} -\title{Prepare Predictions} -\usage{ -\method{prepare_predictions}{brmsfit}( - x, - newdata = NULL, - re_formula = NULL, - allow_new_levels = FALSE, - sample_new_levels = "uncertainty", - incl_autocor = TRUE, - oos = NULL, - resp = NULL, - ndraws = NULL, - draw_ids = NULL, - nsamples = NULL, - subset = NULL, - nug = NULL, - smooths_only = FALSE, - offset = TRUE, - newdata2 = NULL, - new_objects = NULL, - point_estimate = NULL, - ... -) - -prepare_predictions(x, ...) -} -\arguments{ -\item{x}{An \R object typically of class \code{'brmsfit'}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{allow_new_levels}{A flag indicating if new levels of group-level -effects are allowed (defaults to \code{FALSE}). Only relevant if -\code{newdata} is provided.} - -\item{sample_new_levels}{Indicates how to sample new levels for grouping -factors specified in \code{re_formula}. This argument is only relevant if -\code{newdata} is provided and \code{allow_new_levels} is set to -\code{TRUE}. If \code{"uncertainty"} (default), each posterior sample for a -new level is drawn from the posterior draws of a randomly chosen existing -level. Each posterior sample for a new level may be drawn from a different -existing level such that the resulting set of new posterior draws -represents the variation across existing levels. If \code{"gaussian"}, -sample new levels from the (multivariate) normal distribution implied by the -group-level standard deviations and correlations. This options may be useful -for conducting Bayesian power analysis or predicting new levels in -situations where relatively few levels where observed in the old_data. If -\code{"old_levels"}, directly sample new levels from the existing levels, -where a new level is assigned all of the posterior draws of the same -(randomly chosen) existing level.} - -\item{incl_autocor}{A flag indicating if correlation structures originally -specified via \code{autocor} should be included in the predictions. -Defaults to \code{TRUE}.} - -\item{oos}{Optional indices of observations for which to compute -out-of-sample rather than in-sample predictions. Only required in models -that make use of response values to make predictions, that is, currently -only ARMA models.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{nsamples}{Deprecated alias of \code{ndraws}.} - -\item{subset}{Deprecated alias of \code{draw_ids}.} - -\item{nug}{Small positive number for Gaussian process terms only. For -numerical reasons, the covariance matrix of a Gaussian process might not be -positive definite. Adding a very small number to the matrix's diagonal -often solves this problem. If \code{NULL} (the default), \code{nug} is -chosen internally.} - -\item{smooths_only}{Logical; If \code{TRUE} only predictions related to the} - -\item{offset}{Logical; Indicates if offsets should be included in the -predictions. Defaults to \code{TRUE}.} - -\item{newdata2}{A named \code{list} of objects containing new data, which -cannot be passed via argument \code{newdata}. Required for some objects -used in autocorrelation structures, or \code{\link{stanvars}}.} - -\item{new_objects}{Deprecated alias of \code{newdata2}.} - -\item{point_estimate}{Shall the returned object contain only point estimates -of the parameters instead of their posterior draws? Defaults to -\code{NULL} in which case no point estimate is computed. Alternatively, may -be set to \code{"mean"} or \code{"median"}. This argument is primarily -implemented to ensure compatibility with the \code{\link{loo_subsample}} -method.} - -\item{...}{Further arguments passed to \code{\link{validate_newdata}}.} -} -\value{ -An object of class \code{'brmsprep'} or \code{'mvbrmsprep'}, - depending on whether a univariate or multivariate model is passed. -} -\description{ -This method helps in preparing \pkg{brms} models for certin post-processing -tasks most notably various forms of predictions. Unless you are a package -developer, you will rarely need to call \code{prepare_predictions} directly. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_predictions.R +\name{prepare_predictions.brmsfit} +\alias{prepare_predictions.brmsfit} +\alias{prepare_predictions} +\alias{extract_draws} +\title{Prepare Predictions} +\usage{ +\method{prepare_predictions}{brmsfit}( + x, + newdata = NULL, + re_formula = NULL, + allow_new_levels = FALSE, + sample_new_levels = "uncertainty", + incl_autocor = TRUE, + oos = NULL, + resp = NULL, + ndraws = NULL, + draw_ids = NULL, + nsamples = NULL, + subset = NULL, + nug = NULL, + smooths_only = FALSE, + offset = TRUE, + newdata2 = NULL, + new_objects = NULL, + point_estimate = NULL, + ... +) + +prepare_predictions(x, ...) +} +\arguments{ +\item{x}{An \R object typically of class \code{'brmsfit'}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{allow_new_levels}{A flag indicating if new levels of group-level +effects are allowed (defaults to \code{FALSE}). Only relevant if +\code{newdata} is provided.} + +\item{sample_new_levels}{Indicates how to sample new levels for grouping +factors specified in \code{re_formula}. This argument is only relevant if +\code{newdata} is provided and \code{allow_new_levels} is set to +\code{TRUE}. If \code{"uncertainty"} (default), each posterior sample for a +new level is drawn from the posterior draws of a randomly chosen existing +level. Each posterior sample for a new level may be drawn from a different +existing level such that the resulting set of new posterior draws +represents the variation across existing levels. If \code{"gaussian"}, +sample new levels from the (multivariate) normal distribution implied by the +group-level standard deviations and correlations. This options may be useful +for conducting Bayesian power analysis or predicting new levels in +situations where relatively few levels where observed in the old_data. If +\code{"old_levels"}, directly sample new levels from the existing levels, +where a new level is assigned all of the posterior draws of the same +(randomly chosen) existing level.} + +\item{incl_autocor}{A flag indicating if correlation structures originally +specified via \code{autocor} should be included in the predictions. +Defaults to \code{TRUE}.} + +\item{oos}{Optional indices of observations for which to compute +out-of-sample rather than in-sample predictions. Only required in models +that make use of response values to make predictions, that is, currently +only ARMA models.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{nsamples}{Deprecated alias of \code{ndraws}.} + +\item{subset}{Deprecated alias of \code{draw_ids}.} + +\item{nug}{Small positive number for Gaussian process terms only. For +numerical reasons, the covariance matrix of a Gaussian process might not be +positive definite. Adding a very small number to the matrix's diagonal +often solves this problem. If \code{NULL} (the default), \code{nug} is +chosen internally.} + +\item{smooths_only}{Logical; If \code{TRUE} only predictions related to the} + +\item{offset}{Logical; Indicates if offsets should be included in the +predictions. Defaults to \code{TRUE}.} + +\item{newdata2}{A named \code{list} of objects containing new data, which +cannot be passed via argument \code{newdata}. Required for some objects +used in autocorrelation structures, or \code{\link{stanvars}}.} + +\item{new_objects}{Deprecated alias of \code{newdata2}.} + +\item{point_estimate}{Shall the returned object contain only point estimates +of the parameters instead of their posterior draws? Defaults to +\code{NULL} in which case no point estimate is computed. Alternatively, may +be set to \code{"mean"} or \code{"median"}. This argument is primarily +implemented to ensure compatibility with the \code{\link{loo_subsample}} +method.} + +\item{...}{Further arguments passed to \code{\link{validate_newdata}}.} +} +\value{ +An object of class \code{'brmsprep'} or \code{'mvbrmsprep'}, + depending on whether a univariate or multivariate model is passed. +} +\description{ +This method helps in preparing \pkg{brms} models for certin post-processing +tasks most notably various forms of predictions. Unless you are a package +developer, you will rarely need to call \code{prepare_predictions} directly. +} diff -Nru r-cran-brms-2.16.3/man/print.brmsfit.Rd r-cran-brms-2.17.0/man/print.brmsfit.Rd --- r-cran-brms-2.16.3/man/print.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/print.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,24 +1,24 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary.R -\name{print.brmsfit} -\alias{print.brmsfit} -\alias{print.brmssummary} -\title{Print a summary for a fitted model represented by a \code{brmsfit} object} -\usage{ -\method{print}{brmsfit}(x, digits = 2, ...) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}} - -\item{digits}{The number of significant digits for printing out the summary; -defaults to 2. The effective sample size is always rounded to integers.} - -\item{...}{Additional arguments that would be passed -to method \code{summary} of \code{brmsfit}.} -} -\description{ -Print a summary for a fitted model represented by a \code{brmsfit} object -} -\seealso{ -\code{\link{summary.brmsfit}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{print.brmsfit} +\alias{print.brmsfit} +\alias{print.brmssummary} +\title{Print a summary for a fitted model represented by a \code{brmsfit} object} +\usage{ +\method{print}{brmsfit}(x, digits = 2, ...) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}} + +\item{digits}{The number of significant digits for printing out the summary; +defaults to 2. The effective sample size is always rounded to integers.} + +\item{...}{Additional arguments that would be passed +to method \code{summary} of \code{brmsfit}.} +} +\description{ +Print a summary for a fitted model represented by a \code{brmsfit} object +} +\seealso{ +\code{\link{summary.brmsfit}} +} diff -Nru r-cran-brms-2.16.3/man/print.brmsprior.Rd r-cran-brms-2.17.0/man/print.brmsprior.Rd --- r-cran-brms-2.16.3/man/print.brmsprior.Rd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/man/print.brmsprior.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,20 +1,20 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/priors.R -\name{print.brmsprior} -\alias{print.brmsprior} -\title{Print method for \code{brmsprior} objects} -\usage{ -\method{print}{brmsprior}(x, show_df = NULL, ...) -} -\arguments{ -\item{x}{An object of class \code{brmsprior}.} - -\item{show_df}{Logical; Print priors as a single -\code{data.frame} (\code{TRUE}) or as a sequence of -sampling statements (\code{FALSE})?} - -\item{...}{Currently ignored.} -} -\description{ -Print method for \code{brmsprior} objects -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/priors.R +\name{print.brmsprior} +\alias{print.brmsprior} +\title{Print method for \code{brmsprior} objects} +\usage{ +\method{print}{brmsprior}(x, show_df = NULL, ...) +} +\arguments{ +\item{x}{An object of class \code{brmsprior}.} + +\item{show_df}{Logical; Print priors as a single +\code{data.frame} (\code{TRUE}) or as a sequence of +sampling statements (\code{FALSE})?} + +\item{...}{Currently ignored.} +} +\description{ +Print method for \code{brmsprior} objects +} diff -Nru r-cran-brms-2.16.3/man/prior_draws.brmsfit.Rd r-cran-brms-2.17.0/man/prior_draws.brmsfit.Rd --- r-cran-brms-2.16.3/man/prior_draws.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/prior_draws.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,59 +1,59 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prior_draws.R -\name{prior_draws.brmsfit} -\alias{prior_draws.brmsfit} -\alias{prior_samples} -\alias{prior_draws} -\title{Extract Prior Draws} -\usage{ -\method{prior_draws}{brmsfit}(x, variable = NULL, pars = NULL, ...) - -prior_draws(x, ...) - -prior_samples(x, ...) -} -\arguments{ -\item{x}{An \code{R} object typically of class \code{brmsfit}.} - -\item{variable}{A character vector providing the variables to extract. -By default, all variables are extracted.} - -\item{pars}{Deprecated alias of \code{variable}. For reasons of backwards -compatibility, \code{pars} is interpreted as a vector of regular -expressions by default unless \code{fixed = TRUE} is specified.} - -\item{...}{Arguments passed to individual methods (if applicable).} -} -\value{ -A \code{data.frame} containing the prior draws. -} -\description{ -Extract prior draws of specified parameters -} -\details{ -To make use of this function, the model must contain draws of - prior distributions. This can be ensured by setting \code{sample_prior = - TRUE} in function \code{brm}. Priors of certain parameters cannot be saved - for technical reasons. For instance, this is the case for the - population-level intercept, which is only computed after fitting the model - by default. If you want to treat the intercept as part of all the other - regression coefficients, so that sampling from its prior becomes possible, - use \code{... ~ 0 + Intercept + ...} in the formulas. -} -\examples{ -\dontrun{ -fit <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = "cumulative", - prior = set_prior("normal(0,2)", class = "b"), - sample_prior = TRUE) - -# extract all prior draws -draws1 <- prior_draws(fit) -head(draws1) - -# extract prior draws for the coefficient of 'treat' -draws2 <- prior_draws(fit, "b_treat") -head(draws2) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prior_draws.R +\name{prior_draws.brmsfit} +\alias{prior_draws.brmsfit} +\alias{prior_samples} +\alias{prior_draws} +\title{Extract Prior Draws} +\usage{ +\method{prior_draws}{brmsfit}(x, variable = NULL, pars = NULL, ...) + +prior_draws(x, ...) + +prior_samples(x, ...) +} +\arguments{ +\item{x}{An \code{R} object typically of class \code{brmsfit}.} + +\item{variable}{A character vector providing the variables to extract. +By default, all variables are extracted.} + +\item{pars}{Deprecated alias of \code{variable}. For reasons of backwards +compatibility, \code{pars} is interpreted as a vector of regular +expressions by default unless \code{fixed = TRUE} is specified.} + +\item{...}{Arguments passed to individual methods (if applicable).} +} +\value{ +A \code{data.frame} containing the prior draws. +} +\description{ +Extract prior draws of specified parameters +} +\details{ +To make use of this function, the model must contain draws of + prior distributions. This can be ensured by setting \code{sample_prior = + TRUE} in function \code{brm}. Priors of certain parameters cannot be saved + for technical reasons. For instance, this is the case for the + population-level intercept, which is only computed after fitting the model + by default. If you want to treat the intercept as part of all the other + regression coefficients, so that sampling from its prior becomes possible, + use \code{... ~ 0 + Intercept + ...} in the formulas. +} +\examples{ +\dontrun{ +fit <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = "cumulative", + prior = set_prior("normal(0,2)", class = "b"), + sample_prior = TRUE) + +# extract all prior draws +draws1 <- prior_draws(fit) +head(draws1) + +# extract prior draws for the coefficient of 'treat' +draws2 <- prior_draws(fit, "b_treat") +head(draws2) +} + +} diff -Nru r-cran-brms-2.16.3/man/prior_summary.brmsfit.Rd r-cran-brms-2.17.0/man/prior_summary.brmsfit.Rd --- r-cran-brms-2.16.3/man/prior_summary.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/prior_summary.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,37 +1,37 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary.R -\name{prior_summary.brmsfit} -\alias{prior_summary.brmsfit} -\alias{prior_summary} -\title{Extract Priors of a Bayesian Model Fitted with \pkg{brms}} -\usage{ -\method{prior_summary}{brmsfit}(object, all = TRUE, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{all}{Logical; Show all parameters in the model which may have -priors (\code{TRUE}) or only those with proper priors (\code{FALSE})?} - -\item{...}{Further arguments passed to or from other methods.} -} -\value{ -For \code{brmsfit} objects, an object of class \code{brmsprior}. -} -\description{ -Extract Priors of a Bayesian Model Fitted with \pkg{brms} -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt - + (1|patient) + (1|obs), - data = epilepsy, family = poisson(), - prior = c(prior(student_t(5,0,10), class = b), - prior(cauchy(0,2), class = sd))) - -prior_summary(fit) -prior_summary(fit, all = FALSE) -print(prior_summary(fit, all = FALSE), show_df = FALSE) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{prior_summary.brmsfit} +\alias{prior_summary.brmsfit} +\alias{prior_summary} +\title{Extract Priors of a Bayesian Model Fitted with \pkg{brms}} +\usage{ +\method{prior_summary}{brmsfit}(object, all = TRUE, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{all}{Logical; Show all parameters in the model which may have +priors (\code{TRUE}) or only those with proper priors (\code{FALSE})?} + +\item{...}{Further arguments passed to or from other methods.} +} +\value{ +For \code{brmsfit} objects, an object of class \code{brmsprior}. +} +\description{ +Extract Priors of a Bayesian Model Fitted with \pkg{brms} +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + + (1|patient) + (1|obs), + data = epilepsy, family = poisson(), + prior = c(prior(student_t(5,0,10), class = b), + prior(cauchy(0,2), class = sd))) + +prior_summary(fit) +prior_summary(fit, all = FALSE) +print(prior_summary(fit, all = FALSE), show_df = FALSE) +} + +} diff -Nru r-cran-brms-2.16.3/man/R2D2.Rd r-cran-brms-2.17.0/man/R2D2.Rd --- r-cran-brms-2.16.3/man/R2D2.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/R2D2.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,40 +1,40 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/priors.R -\name{R2D2} -\alias{R2D2} -\title{R2-D2 Priors in \pkg{brms}} -\usage{ -R2D2(mean_R2 = 0.5, prec_R2 = 2, cons_D2 = 1, autoscale = TRUE) -} -\arguments{ -\item{mean_R2}{mean of the Beta prior on the coefficient of determination R^2.} - -\item{prec_R2}{precision of the Beta prior on the coefficient of determination R^2.} - -\item{cons_D2}{concentration vector of the Dirichlet prior on the variance -decomposition parameters.} - -\item{autoscale}{Logical; indicating whether the horseshoe -prior should be scaled using the residual standard deviation -\code{sigma} if possible and sensible (defaults to \code{TRUE}). -Autoscaling is not applied for distributional parameters or -when the model does not contain the parameter \code{sigma}.} -} -\description{ -Function used to set up R2D2 priors for population-level effects in -\pkg{brms}. The function does not evaluate its arguments -- it exists purely -to help set up the model. -} -\examples{ -set_prior(R2D2(mean_R2 = 0.8, prec_R2 = 10)) - -} -\references{ -Zhang, Y. D., Naughton, B. P., Bondell, H. D., & Reich, B. J. (2020). - Bayesian regression using a prior on the model fit: The R2-D2 shrinkage - prior. Journal of the American Statistical Association. - \url{https://arxiv.org/pdf/1609.00046.pdf} -} -\seealso{ -\code{\link{set_prior}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/priors.R +\name{R2D2} +\alias{R2D2} +\title{R2-D2 Priors in \pkg{brms}} +\usage{ +R2D2(mean_R2 = 0.5, prec_R2 = 2, cons_D2 = 1, autoscale = TRUE) +} +\arguments{ +\item{mean_R2}{mean of the Beta prior on the coefficient of determination R^2.} + +\item{prec_R2}{precision of the Beta prior on the coefficient of determination R^2.} + +\item{cons_D2}{concentration vector of the Dirichlet prior on the variance +decomposition parameters.} + +\item{autoscale}{Logical; indicating whether the horseshoe +prior should be scaled using the residual standard deviation +\code{sigma} if possible and sensible (defaults to \code{TRUE}). +Autoscaling is not applied for distributional parameters or +when the model does not contain the parameter \code{sigma}.} +} +\description{ +Function used to set up R2D2 priors for population-level effects in +\pkg{brms}. The function does not evaluate its arguments -- it exists purely +to help set up the model. +} +\examples{ +set_prior(R2D2(mean_R2 = 0.8, prec_R2 = 10)) + +} +\references{ +Zhang, Y. D., Naughton, B. P., Bondell, H. D., & Reich, B. J. (2020). + Bayesian regression using a prior on the model fit: The R2-D2 shrinkage + prior. Journal of the American Statistical Association. + \url{https://arxiv.org/pdf/1609.00046.pdf} +} +\seealso{ +\code{\link{set_prior}} +} diff -Nru r-cran-brms-2.16.3/man/ranef.brmsfit.Rd r-cran-brms-2.17.0/man/ranef.brmsfit.Rd --- r-cran-brms-2.16.3/man/ranef.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/ranef.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,63 +1,63 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{ranef.brmsfit} -\alias{ranef.brmsfit} -\alias{ranef} -\title{Extract Group-Level Estimates} -\usage{ -\method{ranef}{brmsfit}( - object, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - pars = NULL, - groups = NULL, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{pars}{Optional names of coefficients to extract. -By default, all coefficients are extracted.} - -\item{groups}{Optional names of grouping variables -for which to extract effects.} - -\item{...}{Currently ignored.} -} -\value{ -A list of 3D arrays (one per grouping factor). - If \code{summary} is \code{TRUE}, - the 1st dimension contains the factor levels, - the 2nd dimension contains the summary statistics - (see \code{\link{posterior_summary}}), and - the 3rd dimension contains the group-level effects. - If \code{summary} is \code{FALSE}, the 1st dimension contains - the posterior draws, the 2nd dimension contains the factor levels, - and the 3rd dimension contains the group-level effects. -} -\description{ -Extract the group-level ('random') effects of each level -from a \code{brmsfit} object. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), - data = epilepsy, family = gaussian(), chains = 2) -ranef(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{ranef.brmsfit} +\alias{ranef.brmsfit} +\alias{ranef} +\title{Extract Group-Level Estimates} +\usage{ +\method{ranef}{brmsfit}( + object, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + pars = NULL, + groups = NULL, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{pars}{Optional names of coefficients to extract. +By default, all coefficients are extracted.} + +\item{groups}{Optional names of grouping variables +for which to extract effects.} + +\item{...}{Currently ignored.} +} +\value{ +A list of 3D arrays (one per grouping factor). + If \code{summary} is \code{TRUE}, + the 1st dimension contains the factor levels, + the 2nd dimension contains the summary statistics + (see \code{\link{posterior_summary}}), and + the 3rd dimension contains the group-level effects. + If \code{summary} is \code{FALSE}, the 1st dimension contains + the posterior draws, the 2nd dimension contains the factor levels, + and the 3rd dimension contains the group-level effects. +} +\description{ +Extract the group-level ('random') effects of each level +from a \code{brmsfit} object. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), + data = epilepsy, family = gaussian(), chains = 2) +ranef(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/reloo.brmsfit.Rd r-cran-brms-2.17.0/man/reloo.brmsfit.Rd --- r-cran-brms-2.16.3/man/reloo.brmsfit.Rd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/man/reloo.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,86 +1,91 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/reloo.R -\name{reloo.brmsfit} -\alias{reloo.brmsfit} -\alias{reloo.loo} -\alias{reloo} -\title{Compute exact cross-validation for problematic observations} -\usage{ -\method{reloo}{brmsfit}( - x, - loo, - k_threshold = 0.7, - newdata = NULL, - resp = NULL, - check = TRUE, - ... -) - -\method{reloo}{loo}(x, fit, ...) - -reloo(x, ...) -} -\arguments{ -\item{x}{An \R object of class \code{brmsfit} or \code{loo} depending -on the method.} - -\item{loo}{An \R object of class \code{loo}.} - -\item{k_threshold}{The threshold at which Pareto \eqn{k} -estimates are treated as problematic. Defaults to \code{0.7}. -See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} -for more details.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{check}{Logical; If \code{TRUE} (the default), some checks -check are performed if the \code{loo} object was generated -from the \code{brmsfit} object passed to argument \code{fit}.} - -\item{...}{Further arguments passed to -\code{\link{update.brmsfit}} and \code{\link{log_lik.brmsfit}}.} - -\item{fit}{An \R object of class \code{brmsfit}.} -} -\value{ -An object of the class \code{loo}. -} -\description{ -Compute exact cross-validation for problematic observations for which -approximate leave-one-out cross-validation may return incorrect results. -Models for problematic observations can be run in parallel using the -\pkg{future} package. -} -\details{ -Warnings about Pareto \eqn{k} estimates indicate observations -for which the approximation to LOO is problematic (this is described in -detail in Vehtari, Gelman, and Gabry (2017) and the -\pkg{\link[loo:loo-package]{loo}} package documentation). -If there are \eqn{J} observations with \eqn{k} estimates above -\code{k_threshold}, then \code{reloo} will refit the original model -\eqn{J} times, each time leaving out one of the \eqn{J} -problematic observations. The pointwise contributions of these observations -to the total ELPD are then computed directly and substituted for the -previous estimates from these \eqn{J} observations that are stored in the -original \code{loo} object. -} -\examples{ -\dontrun{ -fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson()) -# throws warning about some pareto k estimates being too high -(loo1 <- loo(fit1)) -(reloo1 <- reloo(fit1, loo = loo1, chains = 1)) -} - -} -\seealso{ -\code{\link{loo}}, \code{\link{kfold}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/reloo.R +\name{reloo.brmsfit} +\alias{reloo.brmsfit} +\alias{reloo.loo} +\alias{reloo} +\title{Compute exact cross-validation for problematic observations} +\usage{ +\method{reloo}{brmsfit}( + x, + loo, + k_threshold = 0.7, + newdata = NULL, + resp = NULL, + check = TRUE, + future_args = list(), + ... +) + +\method{reloo}{loo}(x, fit, ...) + +reloo(x, ...) +} +\arguments{ +\item{x}{An \R object of class \code{brmsfit} or \code{loo} depending +on the method.} + +\item{loo}{An \R object of class \code{loo}.} + +\item{k_threshold}{The threshold at which Pareto \eqn{k} +estimates are treated as problematic. Defaults to \code{0.7}. +See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} +for more details.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{check}{Logical; If \code{TRUE} (the default), some checks +check are performed if the \code{loo} object was generated +from the \code{brmsfit} object passed to argument \code{fit}.} + +\item{future_args}{A list of further arguments passed to +\code{\link[future:future]{future}} for additional control over parallel +execution if activated.} + +\item{...}{Further arguments passed to +\code{\link{update.brmsfit}} and \code{\link{log_lik.brmsfit}}.} + +\item{fit}{An \R object of class \code{brmsfit}.} +} +\value{ +An object of the class \code{loo}. +} +\description{ +Compute exact cross-validation for problematic observations for which +approximate leave-one-out cross-validation may return incorrect results. +Models for problematic observations can be run in parallel using the +\pkg{future} package. +} +\details{ +Warnings about Pareto \eqn{k} estimates indicate observations +for which the approximation to LOO is problematic (this is described in +detail in Vehtari, Gelman, and Gabry (2017) and the +\pkg{\link[loo:loo-package]{loo}} package documentation). +If there are \eqn{J} observations with \eqn{k} estimates above +\code{k_threshold}, then \code{reloo} will refit the original model +\eqn{J} times, each time leaving out one of the \eqn{J} +problematic observations. The pointwise contributions of these observations +to the total ELPD are then computed directly and substituted for the +previous estimates from these \eqn{J} observations that are stored in the +original \code{loo} object. +} +\examples{ +\dontrun{ +fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson()) +# throws warning about some pareto k estimates being too high +(loo1 <- loo(fit1)) +(reloo1 <- reloo(fit1, loo = loo1, chains = 1)) +} + +} +\seealso{ +\code{\link{loo}}, \code{\link{kfold}} +} diff -Nru r-cran-brms-2.16.3/man/rename_pars.Rd r-cran-brms-2.17.0/man/rename_pars.Rd --- r-cran-brms-2.16.3/man/rename_pars.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/rename_pars.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,35 +1,35 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/rename_pars.R -\name{rename_pars} -\alias{rename_pars} -\title{Rename Parameters} -\usage{ -rename_pars(x) -} -\arguments{ -\item{x}{A brmsfit object.} -} -\value{ -A brmfit object with adjusted parameter names. -} -\description{ -Rename parameters within the \code{stanfit} object after model fitting to -ensure reasonable parameter names. This function is usually called -automatically by \code{\link{brm}} and users will rarely be required to call -it themselves. -} -\examples{ -\dontrun{ -# fit a model manually via rstan -scode <- make_stancode(count ~ Trt, data = epilepsy) -sdata <- make_standata(count ~ Trt, data = epilepsy) -stanfit <- rstan::stan(model_code = scode, data = sdata) - -# feed the Stan model back into brms -fit <- brm(count ~ Trt, data = epilepsy, empty = TRUE) -fit$fit <- stanfit -fit <- rename_pars(fit) -summary(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rename_pars.R +\name{rename_pars} +\alias{rename_pars} +\title{Rename Parameters} +\usage{ +rename_pars(x) +} +\arguments{ +\item{x}{A brmsfit object.} +} +\value{ +A brmfit object with adjusted parameter names. +} +\description{ +Rename parameters within the \code{stanfit} object after model fitting to +ensure reasonable parameter names. This function is usually called +automatically by \code{\link{brm}} and users will rarely be required to call +it themselves. +} +\examples{ +\dontrun{ +# fit a model manually via rstan +scode <- make_stancode(count ~ Trt, data = epilepsy) +sdata <- make_standata(count ~ Trt, data = epilepsy) +stanfit <- rstan::stan(model_code = scode, data = sdata) + +# feed the Stan model back into brms +fit <- brm(count ~ Trt, data = epilepsy, empty = TRUE) +fit$fit <- stanfit +fit <- rename_pars(fit) +summary(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/residuals.brmsfit.Rd r-cran-brms-2.17.0/man/residuals.brmsfit.Rd --- r-cran-brms-2.16.3/man/residuals.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/residuals.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,105 +1,105 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/predictive_error.R -\name{residuals.brmsfit} -\alias{residuals.brmsfit} -\title{Posterior Draws of Residuals/Predictive Errors} -\usage{ -\method{residuals}{brmsfit}( - object, - newdata = NULL, - re_formula = NULL, - method = "posterior_epred", - type = c("ordinary", "pearson"), - resp = NULL, - ndraws = NULL, - draw_ids = NULL, - sort = FALSE, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{method}{Method use to obtain predictions. Either -\code{"posterior_epred"} (the default) or \code{"posterior_predict"}. -Using \code{"posterior_predict"} is recommended -but \code{"posterior_epred"} is the current default for -reasons of backwards compatibility.} - -\item{type}{The type of the residuals, -either \code{"ordinary"} or \code{"pearson"}. -More information is provided under 'Details'.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{ndraws}{Positive integer indicating how many posterior draws should -be used. If \code{NULL} (the default) all draws are used. Ignored if -\code{draw_ids} is not \code{NULL}.} - -\item{draw_ids}{An integer vector specifying the posterior draws to be used. -If \code{NULL} (the default), all draws are used.} - -\item{sort}{Logical. Only relevant for time series models. -Indicating whether to return predicted values in the original -order (\code{FALSE}; default) or in the order of the -time series (\code{TRUE}).} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}..} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{...}{Further arguments passed to \code{\link{prepare_predictions}} -that control several aspects of data validation and prediction.} -} -\value{ -An \code{array} of predictive error/residual draws. If - \code{summary = FALSE} the output resembles those of - \code{\link{predictive_error.brmsfit}}. If \code{summary = TRUE} the output - is an N x E matrix, where N is the number of observations and E denotes - the summary statistics computed from the draws. -} -\description{ -This method is an alias of \code{\link{predictive_error.brmsfit}} -with additional arguments for obtaining summaries of the computed draws. -} -\details{ -Residuals of type \code{'ordinary'} are of the form \eqn{R = Y - - Yrep}, where \eqn{Y} is the observed and \eqn{Yrep} is the predicted response. - Residuals of type \code{pearson} are of the form \eqn{R = (Y - Yrep) / - SD(Yrep)}, where \eqn{SD(Yrep)} is an estimate of the standard deviation of - \eqn{Yrep}. -} -\examples{ -\dontrun{ -## fit a model -fit <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler, cores = 2) - -## extract residuals/predictive errors -res <- residuals(fit) -head(res) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/predictive_error.R +\name{residuals.brmsfit} +\alias{residuals.brmsfit} +\title{Posterior Draws of Residuals/Predictive Errors} +\usage{ +\method{residuals}{brmsfit}( + object, + newdata = NULL, + re_formula = NULL, + method = "posterior_epred", + type = c("ordinary", "pearson"), + resp = NULL, + ndraws = NULL, + draw_ids = NULL, + sort = FALSE, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{method}{Method use to obtain predictions. Either +\code{"posterior_epred"} (the default) or \code{"posterior_predict"}. +Using \code{"posterior_predict"} is recommended +but \code{"posterior_epred"} is the current default for +reasons of backwards compatibility.} + +\item{type}{The type of the residuals, +either \code{"ordinary"} or \code{"pearson"}. +More information is provided under 'Details'.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{ndraws}{Positive integer indicating how many posterior draws should +be used. If \code{NULL} (the default) all draws are used. Ignored if +\code{draw_ids} is not \code{NULL}.} + +\item{draw_ids}{An integer vector specifying the posterior draws to be used. +If \code{NULL} (the default), all draws are used.} + +\item{sort}{Logical. Only relevant for time series models. +Indicating whether to return predicted values in the original +order (\code{FALSE}; default) or in the order of the +time series (\code{TRUE}).} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}..} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{...}{Further arguments passed to \code{\link{prepare_predictions}} +that control several aspects of data validation and prediction.} +} +\value{ +An \code{array} of predictive error/residual draws. If + \code{summary = FALSE} the output resembles those of + \code{\link{predictive_error.brmsfit}}. If \code{summary = TRUE} the output + is an N x E matrix, where N is the number of observations and E denotes + the summary statistics computed from the draws. +} +\description{ +This method is an alias of \code{\link{predictive_error.brmsfit}} +with additional arguments for obtaining summaries of the computed draws. +} +\details{ +Residuals of type \code{'ordinary'} are of the form \eqn{R = Y - + Yrep}, where \eqn{Y} is the observed and \eqn{Yrep} is the predicted response. + Residuals of type \code{pearson} are of the form \eqn{R = (Y - Yrep) / + SD(Yrep)}, where \eqn{SD(Yrep)} is an estimate of the standard deviation of + \eqn{Yrep}. +} +\examples{ +\dontrun{ +## fit a model +fit <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler, cores = 2) + +## extract residuals/predictive errors +res <- residuals(fit) +head(res) +} + +} diff -Nru r-cran-brms-2.16.3/man/restructure.Rd r-cran-brms-2.17.0/man/restructure.Rd --- r-cran-brms-2.16.3/man/restructure.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/restructure.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,25 +1,25 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/restructure.R -\name{restructure} -\alias{restructure} -\title{Restructure Old \code{brmsfit} Objects} -\usage{ -restructure(x, ...) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}.} - -\item{...}{Currently ignored.} -} -\value{ -A \code{brmsfit} object compatible with the latest version - of \pkg{brms}. -} -\description{ -Restructure old \code{brmsfit} objects to work with -the latest \pkg{brms} version. This function is called -internally when applying post-processing methods. -However, in order to avoid unnecessary run time caused -by the restructuring, I recommend explicitly calling -\code{restructure} once per model after updating \pkg{brms}. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/restructure.R +\name{restructure} +\alias{restructure} +\title{Restructure Old \code{brmsfit} Objects} +\usage{ +restructure(x, ...) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}.} + +\item{...}{Currently ignored.} +} +\value{ +A \code{brmsfit} object compatible with the latest version + of \pkg{brms}. +} +\description{ +Restructure old \code{brmsfit} objects to work with +the latest \pkg{brms} version. This function is called +internally when applying post-processing methods. +However, in order to avoid unnecessary run time caused +by the restructuring, I recommend explicitly calling +\code{restructure} once per model after updating \pkg{brms}. +} diff -Nru r-cran-brms-2.16.3/man/rows2labels.Rd r-cran-brms-2.17.0/man/rows2labels.Rd --- r-cran-brms-2.16.3/man/rows2labels.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/rows2labels.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,32 +1,32 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/conditional_effects.R -\name{rows2labels} -\alias{rows2labels} -\title{Convert Rows to Labels} -\usage{ -rows2labels(x, digits = 2, sep = " & ", incl_vars = TRUE, ...) -} -\arguments{ -\item{x}{A \code{data.frame} for which to extract labels.} - -\item{digits}{Minimal number of decimal places shown in -the labels of numeric variables.} - -\item{sep}{A single character string defining the separator -between variables used in the labels.} - -\item{incl_vars}{Indicates if variable names should -be part of the labels. Defaults to \code{TRUE}.} - -\item{...}{Currently unused.} -} -\value{ -A character vector of the same length as the number - of rows of \code{x}. -} -\description{ -Convert information in rows to labels for each row. -} -\seealso{ -\code{\link{make_conditions}}, \code{\link{conditional_effects}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/conditional_effects.R +\name{rows2labels} +\alias{rows2labels} +\title{Convert Rows to Labels} +\usage{ +rows2labels(x, digits = 2, sep = " & ", incl_vars = TRUE, ...) +} +\arguments{ +\item{x}{A \code{data.frame} for which to extract labels.} + +\item{digits}{Minimal number of decimal places shown in +the labels of numeric variables.} + +\item{sep}{A single character string defining the separator +between variables used in the labels.} + +\item{incl_vars}{Indicates if variable names should +be part of the labels. Defaults to \code{TRUE}.} + +\item{...}{Currently unused.} +} +\value{ +A character vector of the same length as the number + of rows of \code{x}. +} +\description{ +Convert information in rows to labels for each row. +} +\seealso{ +\code{\link{make_conditions}}, \code{\link{conditional_effects}} +} diff -Nru r-cran-brms-2.16.3/man/sar.Rd r-cran-brms-2.17.0/man/sar.Rd --- r-cran-brms-2.16.3/man/sar.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/sar.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,58 +1,58 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-ac.R -\name{sar} -\alias{sar} -\title{Spatial simultaneous autoregressive (SAR) structures} -\usage{ -sar(M, type = "lag") -} -\arguments{ -\item{M}{An object specifying the spatial weighting matrix. -Can be either the spatial weight matrix itself or an -object of class \code{listw} or \code{nb}, from which -the spatial weighting matrix can be computed.} - -\item{type}{Type of the SAR structure. Either \code{"lag"} -(for SAR of the response values) or \code{"error"} -(for SAR of the residuals). More information is -provided in the 'Details' section.} -} -\value{ -An object of class \code{'sar_term'}, which is a list - of arguments to be interpreted by the formula - parsing functions of \pkg{brms}. -} -\description{ -Set up an spatial simultaneous autoregressive (SAR) term in \pkg{brms}. The -function does not evaluate its arguments -- it exists purely to help set up a -model with SAR terms. -} -\details{ -The \code{lagsar} structure implements SAR of the response values: - \deqn{y = \rho W y + \eta + e} - The \code{errorsar} structure implements SAR of the residuals: - \deqn{y = \eta + u, u = \rho W u + e} - In the above equations, \eqn{\eta} is the predictor term and \eqn{e} are - independent normally or t-distributed residuals. Currently, only families - \code{gaussian} and \code{student} support SAR structures. -} -\examples{ -\dontrun{ -data(oldcol, package = "spdep") -fit1 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "lag"), - data = COL.OLD, data2 = list(COL.nb = COL.nb), - chains = 2, cores = 2) -summary(fit1) -plot(fit1) - -fit2 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "error"), - data = COL.OLD, data2 = list(COL.nb = COL.nb), - chains = 2, cores = 2) -summary(fit2) -plot(fit2) -} - -} -\seealso{ -\code{\link{autocor-terms}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-ac.R +\name{sar} +\alias{sar} +\title{Spatial simultaneous autoregressive (SAR) structures} +\usage{ +sar(M, type = "lag") +} +\arguments{ +\item{M}{An object specifying the spatial weighting matrix. +Can be either the spatial weight matrix itself or an +object of class \code{listw} or \code{nb}, from which +the spatial weighting matrix can be computed.} + +\item{type}{Type of the SAR structure. Either \code{"lag"} +(for SAR of the response values) or \code{"error"} +(for SAR of the residuals). More information is +provided in the 'Details' section.} +} +\value{ +An object of class \code{'sar_term'}, which is a list + of arguments to be interpreted by the formula + parsing functions of \pkg{brms}. +} +\description{ +Set up an spatial simultaneous autoregressive (SAR) term in \pkg{brms}. The +function does not evaluate its arguments -- it exists purely to help set up a +model with SAR terms. +} +\details{ +The \code{lagsar} structure implements SAR of the response values: + \deqn{y = \rho W y + \eta + e} + The \code{errorsar} structure implements SAR of the residuals: + \deqn{y = \eta + u, u = \rho W u + e} + In the above equations, \eqn{\eta} is the predictor term and \eqn{e} are + independent normally or t-distributed residuals. Currently, only families + \code{gaussian} and \code{student} support SAR structures. +} +\examples{ +\dontrun{ +data(oldcol, package = "spdep") +fit1 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "lag"), + data = COL.OLD, data2 = list(COL.nb = COL.nb), + chains = 2, cores = 2) +summary(fit1) +plot(fit1) + +fit2 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "error"), + data = COL.OLD, data2 = list(COL.nb = COL.nb), + chains = 2, cores = 2) +summary(fit2) +plot(fit2) +} + +} +\seealso{ +\code{\link{autocor-terms}} +} diff -Nru r-cran-brms-2.16.3/man/save_pars.Rd r-cran-brms-2.17.0/man/save_pars.Rd --- r-cran-brms-2.16.3/man/save_pars.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/save_pars.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,51 +1,51 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/exclude_pars.R -\name{save_pars} -\alias{save_pars} -\title{Control Saving of Parameter Draws} -\usage{ -save_pars(group = TRUE, latent = FALSE, all = FALSE, manual = NULL) -} -\arguments{ -\item{group}{A flag to indicate if group-level coefficients for -each level of the grouping factors should be saved (default is -\code{TRUE}). Set to \code{FALSE} to save memory. Alternatively, -\code{group} may also be a character vector naming the grouping factors -for which to save draws of coefficients.} - -\item{latent}{A flag to indicate if draws of latent variables obtained by -using \code{me} and \code{mi} terms should be saved (default is -\code{FALSE}). Saving these draws allows to better use methods such as -\code{posterior_predict} with the latent variables but leads to very large -\R objects even for models of moderate size and complexity. Alternatively, -\code{latent} may also be a character vector naming the latent variables -for which to save draws.} - -\item{all}{A flag to indicate if draws of all variables defined in Stan's -\code{parameters} block should be saved (default is \code{FALSE}). Saving -these draws is required in order to apply the certain methods such as -\code{bridge_sampler} and \code{bayes_factor}.} - -\item{manual}{A character vector naming Stan variable names which should be -saved. These names should match the variable names inside the Stan code -before renaming. This feature is meant for power users only and will rarely -be useful outside of very special cases.} -} -\value{ -A list of class \code{"save_pars"}. -} -\description{ -Control which (draws of) parameters should be saved in a \pkg{brms} -model. The output of this function is ment for usage in the -\code{save_pars} argument of \code{\link{brm}}. -} -\examples{ -\dontrun{ -# don't store group-level coefficients -fit <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson(), - save_pars = save_pars(group = FALSE)) -variables(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/exclude_pars.R +\name{save_pars} +\alias{save_pars} +\title{Control Saving of Parameter Draws} +\usage{ +save_pars(group = TRUE, latent = FALSE, all = FALSE, manual = NULL) +} +\arguments{ +\item{group}{A flag to indicate if group-level coefficients for +each level of the grouping factors should be saved (default is +\code{TRUE}). Set to \code{FALSE} to save memory. Alternatively, +\code{group} may also be a character vector naming the grouping factors +for which to save draws of coefficients.} + +\item{latent}{A flag to indicate if draws of latent variables obtained by +using \code{me} and \code{mi} terms should be saved (default is +\code{FALSE}). Saving these draws allows to better use methods such as +\code{posterior_predict} with the latent variables but leads to very large +\R objects even for models of moderate size and complexity. Alternatively, +\code{latent} may also be a character vector naming the latent variables +for which to save draws.} + +\item{all}{A flag to indicate if draws of all variables defined in Stan's +\code{parameters} block should be saved (default is \code{FALSE}). Saving +these draws is required in order to apply the certain methods such as +\code{bridge_sampler} and \code{bayes_factor}.} + +\item{manual}{A character vector naming Stan variable names which should be +saved. These names should match the variable names inside the Stan code +before renaming. This feature is meant for power users only and will rarely +be useful outside of very special cases.} +} +\value{ +A list of class \code{"save_pars"}. +} +\description{ +Control which (draws of) parameters should be saved in a \pkg{brms} +model. The output of this function is ment for usage in the +\code{save_pars} argument of \code{\link{brm}}. +} +\examples{ +\dontrun{ +# don't store group-level coefficients +fit <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson(), + save_pars = save_pars(group = FALSE)) +variables(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/set_prior.Rd r-cran-brms-2.17.0/man/set_prior.Rd --- r-cran-brms-2.16.3/man/set_prior.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/set_prior.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,394 +1,394 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/priors.R -\name{set_prior} -\alias{set_prior} -\alias{brmsprior} -\alias{brmsprior-class} -\alias{prior} -\alias{prior_} -\alias{prior_string} -\alias{empty_prior} -\title{Prior Definitions for \pkg{brms} Models} -\usage{ -set_prior( - prior, - class = "b", - coef = "", - group = "", - resp = "", - dpar = "", - nlpar = "", - lb = NA, - ub = NA, - check = TRUE -) - -prior(prior, ...) - -prior_(prior, ...) - -prior_string(prior, ...) - -empty_prior() -} -\arguments{ -\item{prior}{A character string defining a distribution in \pkg{Stan} language} - -\item{class}{The parameter class. Defaults to \code{"b"} -(i.e. population-level effects). -See 'Details' for other valid parameter classes.} - -\item{coef}{Name of the coefficient within the parameter class.} - -\item{group}{Grouping factor for group-level parameters.} - -\item{resp}{Name of the response variable. -Only used in multivariate models.} - -\item{dpar}{Name of a distributional parameter. -Only used in distributional models.} - -\item{nlpar}{Name of a non-linear parameter. -Only used in non-linear models.} - -\item{lb}{Lower bound for parameter restriction. Currently only allowed -for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction.} - -\item{ub}{Upper bound for parameter restriction. Currently only allowed -for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction.} - -\item{check}{Logical; Indicates whether priors -should be checked for validity (as far as possible). -Defaults to \code{TRUE}. If \code{FALSE}, \code{prior} is passed -to the Stan code as is, and all other arguments are ignored.} - -\item{...}{Arguments passed to \code{set_prior}.} -} -\value{ -An object of class \code{brmsprior} to be used in the \code{prior} - argument of \code{\link{brm}}. -} -\description{ -Define priors for specific parameters or classes of parameters. -} -\details{ -\code{set_prior} is used to define prior distributions for parameters - in \pkg{brms} models. The functions \code{prior}, \code{prior_}, and - \code{prior_string} are aliases of \code{set_prior} each allowing - for a different kind of argument specification. - \code{prior} allows specifying arguments as expression without - quotation marks using non-standard evaluation. - \code{prior_} allows specifying arguments as one-sided formulas - or wrapped in \code{quote}. - \code{prior_string} allows specifying arguments as strings just - as \code{set_prior} itself. - - Below, we explain its usage and list some common - prior distributions for parameters. - A complete overview on possible prior distributions is given - in the Stan Reference Manual available at \url{https://mc-stan.org/}. - - To combine multiple priors, use \code{c(...)} or the \code{+} operator - (see 'Examples'). \pkg{brms} does not check if the priors are written - in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their - syntactical correctness when the model is parsed to \code{C++} and - returns an error if they are not. - This, however, does not imply that priors are always meaningful if they are - accepted by \pkg{Stan}. Although \pkg{brms} trys to find common problems - (e.g., setting bounded priors on unbounded parameters), there is no guarantee - that the defined priors are reasonable for the model. - Below, we list the types of parameters in \pkg{brms} models, - for which the user can specify prior distributions. - - 1. Population-level ('fixed') effects - - Every Population-level effect has its own regression parameter - represents the name of the corresponding population-level effect. - Suppose, for instance, that \code{y} is predicted by \code{x1} and \code{x2} - (i.e., \code{y ~ x1 + x2} in formula syntax). - Then, \code{x1} and \code{x2} have regression parameters - \code{b_x1} and \code{b_x2} respectively. - The default prior for population-level effects (including monotonic and - category specific effects) is an improper flat prior over the reals. - Other common options are normal priors or student-t priors. - If we want to have a normal prior with mean 0 and - standard deviation 5 for \code{x1}, and a unit student-t prior with 10 - degrees of freedom for \code{x2}, we can specify this via - \code{set_prior("normal(0,5)", class = "b", coef = "x1")} and \cr - \code{set_prior("student_t(10, 0, 1)", class = "b", coef = "x2")}. - To put the same prior on all population-level effects at once, - we may write as a shortcut \code{set_prior("", class = "b")}. - This also leads to faster sampling, because priors can be vectorized in this case. - Both ways of defining priors can be combined using for instance - \code{set_prior("normal(0, 2)", class = "b")} and \cr - \code{set_prior("normal(0, 10)", class = "b", coef = "x1")} - at the same time. This will set a \code{normal(0, 10)} prior on - the effect of \code{x1} and a \code{normal(0, 2)} prior - on all other population-level effects. - However, this will break vectorization and - may slow down the sampling procedure a bit. - - In case of the default intercept parameterization - (discussed in the 'Details' section of \code{\link{brmsformula}}), - general priors on class \code{"b"} will \emph{not} affect - the intercept. Instead, the intercept has its own parameter class - named \code{"Intercept"} and priors can thus be - specified via \code{set_prior("", class = "Intercept")}. - Setting a prior on the intercept will not break vectorization - of the other population-level effects. - Note that technically, this prior is set on an intercept that - results when internally centering all population-level predictors - around zero to improve sampling efficiency. On this centered - intercept, specifying a prior is actually much easier and - intuitive than on the original intercept, since the former - represents the expected response value when all predictors - are at their means. To treat the intercept as an ordinary - population-level effect and avoid the centering parameterization, - use \code{0 + Intercept} on the right-hand side of the model formula. - - A special shrinkage prior to be applied on population-level effects is the - (regularized) horseshoe prior and related priors. See - \code{\link{horseshoe}} for details. Another shrinkage prior is the - so-called lasso prior. See \code{\link{lasso}} for details. - - In non-linear models, population-level effects are defined separately - for each non-linear parameter. Accordingly, it is necessary to specify - the non-linear parameter in \code{set_prior} so that priors - we can be assigned correctly. - If, for instance, \code{alpha} is the parameter and \code{x} the predictor - for which we want to define the prior, we can write - \code{set_prior("", coef = "x", nlpar = "alpha")}. - As a shortcut we can use \code{set_prior("", nlpar = "alpha")} - to set the same prior on all population-level effects of \code{alpha} at once. - - If desired, population-level effects can be restricted to fall only - within a certain interval using the \code{lb} and \code{ub} arguments - of \code{set_prior}. This is often required when defining priors - that are not defined everywhere on the real line, such as uniform - or gamma priors. When defining a \code{uniform(2,4)} prior, - you should write \code{set_prior("uniform(2,4)", lb = 2, ub = 4)}. - When using a prior that is defined on the positive reals only - (such as a gamma prior) set \code{lb = 0}. - In most situations, it is not useful to restrict population-level - parameters through bounded priors - (non-linear models are an important exception), - but if you really want to this is the way to go. - - 2. Standard deviations of group-level ('random') effects - - Each group-level effect of each grouping factor has a standard deviation named - \code{sd__}. Consider, for instance, the formula - \code{y ~ x1 + x2 + (1 + x1 | g)}. - We see that the intercept as well as \code{x1} are group-level effects - nested in the grouping factor \code{g}. - The corresponding standard deviation parameters are named as - \code{sd_g_Intercept} and \code{sd_g_x1} respectively. - These parameters are restricted to be non-negative and, by default, - have a half student-t prior with 3 degrees of freedom and a - scale parameter that depends on the standard deviation of the response - after applying the link function. Minimally, the scale parameter is 2.5. - This prior is used (a) to be only weakly informative in order to influence - results as few as possible, while (b) providing at least some regularization - to considerably improve convergence and sampling efficiency. - To define a prior distribution only for standard deviations - of a specific grouping factor, - use \cr \code{set_prior("", class = "sd", group = "")}. - To define a prior distribution only for a specific standard deviation - of a specific grouping factor, you may write \cr - \code{set_prior("", class = "sd", group = "", coef = "")}. - Recommendations on useful prior distributions for - standard deviations are given in Gelman (2006), but note that he - is no longer recommending uniform priors, anymore. \cr - - When defining priors on group-level parameters in non-linear models, - please make sure to specify the corresponding non-linear parameter - through the \code{nlpar} argument in the same way as - for population-level effects. - - 3. Correlations of group-level ('random') effects - - If there is more than one group-level effect per grouping factor, - the correlations between those effects have to be estimated. - The prior \code{lkj_corr_cholesky(eta)} or in short - \code{lkj(eta)} with \code{eta > 0} - is essentially the only prior for (Cholesky factors) of correlation matrices. - If \code{eta = 1} (the default) all correlations matrices - are equally likely a priori. If \code{eta > 1}, extreme correlations - become less likely, whereas \code{0 < eta < 1} results in - higher probabilities for extreme correlations. - Correlation matrix parameters in \code{brms} models are named as - \code{cor_}, (e.g., \code{cor_g} if \code{g} is the grouping factor). - To set the same prior on every correlation matrix, - use for instance \code{set_prior("lkj(2)", class = "cor")}. - Internally, the priors are transformed to be put on the Cholesky factors - of the correlation matrices to improve efficiency and numerical stability. - The corresponding parameter class of the Cholesky factors is \code{L}, - but it is not recommended to specify priors for this parameter class directly. - - 4. Splines - - Splines are implemented in \pkg{brms} using the 'random effects' - formulation as explained in \code{\link[mgcv:gamm]{gamm}}). - Thus, each spline has its corresponding standard deviations - modeling the variability within this term. In \pkg{brms}, this - parameter class is called \code{sds} and priors can - be specified via \code{set_prior("", class = "sds", - coef = "")}. The default prior is the same as - for standard deviations of group-level effects. - - 5. Gaussian processes - - Gaussian processes as currently implemented in \pkg{brms} have - two parameters, the standard deviation parameter \code{sdgp}, - and characteristic length-scale parameter \code{lscale} - (see \code{\link{gp}} for more details). The default prior - of \code{sdgp} is the same as for standard deviations of - group-level effects. The default prior of \code{lscale} - is an informative inverse-gamma prior specifically tuned - to the covariates of the Gaussian process (for more details see - \url{https://betanalpha.github.io/assets/case_studies/gp_part3/part3.html}). - This tuned prior may be overly informative in some cases, so please - consider other priors as well to make sure inference is - robust to the prior specification. If tuning fails, a half-normal prior - is used instead. - - 6. Autocorrelation parameters - - The autocorrelation parameters currently implemented are named - \code{ar} (autoregression), \code{ma} (moving average), - \code{arr} (autoregression of the response), \code{car} - (spatial conditional autoregression), as well as \code{lagsar} - and \code{errorsar} (Spatial simultaneous autoregression). - - Priors can be defined by \code{set_prior("", class = "ar")} - for \code{ar} and similar for other autocorrelation parameters. - By default, \code{ar} and \code{ma} are bounded between \code{-1} - and \code{1}, \code{car}, \code{lagsar}, and \code{errorsar} are - bounded between \code{0}, and \code{1}, and \code{arr} is unbounded - (you may change this by using the arguments \code{lb} and \code{ub}). - The default prior is flat over the definition area. - - 7. Distance parameters of monotonic effects - - As explained in the details section of \code{\link{brm}}, - monotonic effects make use of a special parameter vector to - estimate the 'normalized distances' between consecutive predictor - categories. This is realized in \pkg{Stan} using the \code{simplex} - parameter type. This class is named \code{"simo"} (short for - simplex monotonic) in \pkg{brms}. - The only valid prior for simplex parameters is the - dirichlet prior, which accepts a vector of length \code{K - 1} - (K = number of predictor categories) as input defining the - 'concentration' of the distribution. Explaining the dirichlet prior - is beyond the scope of this documentation, but we want to describe - how to define this prior syntactically correct. - If a predictor \code{x} with \code{K} categories is modeled as monotonic, - we can define a prior on its corresponding simplex via \cr - \code{prior(dirichlet(), class = simo, coef = mox1)}. - The \code{1} in the end of \code{coef} indicates that this is the first - simplex in this term. If interactions between multiple monotonic - variables are modeled, multiple simplexes per term are required. - For \code{}, we can put in any \code{R} expression - defining a vector of length \code{K - 1}. The default is a uniform - prior (i.e. \code{ = rep(1, K-1)}) over all simplexes - of the respective dimension. - - 8. Parameters for specific families - - Some families need additional parameters to be estimated. - Families \code{gaussian}, \code{student}, \code{skew_normal}, - \code{lognormal}, and \code{gen_extreme_value} need the parameter - \code{sigma} to account for the residual standard deviation. - By default, \code{sigma} has a half student-t prior that scales - in the same way as the group-level standard deviations. - Further, family \code{student} needs the parameter - \code{nu} representing the degrees of freedom of students-t distribution. - By default, \code{nu} has prior \code{gamma(2, 0.1)} - and a fixed lower bound of \code{1}. - Families \code{gamma}, \code{weibull}, \code{inverse.gaussian}, and - \code{negbinomial} need a \code{shape} parameter that has a - \code{gamma(0.01, 0.01)} prior by default. - For families \code{cumulative}, \code{cratio}, \code{sratio}, - and \code{acat}, and only if \code{threshold = "equidistant"}, - the parameter \code{delta} is used to model the distance between - two adjacent thresholds. - By default, \code{delta} has an improper flat prior over the reals. - The \code{von_mises} family needs the parameter \code{kappa}, representing - the concentration parameter. By default, \code{kappa} has prior - \code{gamma(2, 0.01)}. \cr - Every family specific parameter has its own prior class, so that - \code{set_prior("", class = "")} is the right way to go. - All of these priors are chosen to be weakly informative, - having only minimal influence on the estimations, - while improving convergence and sampling efficiency. - - Fixing parameters to constants is possible by using the \code{constant} - function, for example, \code{constant(1)} to fix a parameter to 1. - Broadcasting to vectors and matrices is done automatically. - - Often, it may not be immediately clear, which parameters are present in the - model. To get a full list of parameters and parameter classes for which - priors can be specified (depending on the model) use function - \code{\link{get_prior}}. -} -\section{Functions}{ -\itemize{ -\item \code{prior}: Alias of \code{set_prior} allowing to -specify arguments as expressions without quotation marks. - -\item \code{prior_}: Alias of \code{set_prior} allowing to specify -arguments as as one-sided formulas or wrapped in \code{quote}. - -\item \code{prior_string}: Alias of \code{set_prior} allowing to -specify arguments as strings. - -\item \code{empty_prior}: Create an empty \code{brmsprior} object. -}} - -\examples{ -## use alias functions -(prior1 <- prior(cauchy(0, 1), class = sd)) -(prior2 <- prior_(~cauchy(0, 1), class = ~sd)) -(prior3 <- prior_string("cauchy(0, 1)", class = "sd")) -identical(prior1, prior2) -identical(prior1, prior3) - -# check which parameters can have priors -get_prior(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = cumulative()) - -# define some priors -bprior <- c(prior_string("normal(0,10)", class = "b"), - prior(normal(1,2), class = b, coef = treat), - prior_(~cauchy(0,2), class = ~sd, - group = ~subject, coef = ~Intercept)) - -# verify that the priors indeed found their way into Stan's model code -make_stancode(rating ~ treat + period + carry + (1|subject), - data = inhaler, family = cumulative(), - prior = bprior) - -# use the horseshoe prior to model sparsity in regression coefficients -make_stancode(count ~ zAge + zBase * Trt, - data = epilepsy, family = poisson(), - prior = set_prior("horseshoe(3)")) - -# fix certain priors to constants -bprior <- prior(constant(1), class = "b") + - prior(constant(2), class = "b", coef = "zBase") + - prior(constant(0.5), class = "sd") -make_stancode(count ~ zAge + zBase + (1 | patient), - data = epilepsy, prior = bprior) - -# pass priors to Stan without checking -prior <- prior_string("target += normal_lpdf(b[1] | 0, 1)", check = FALSE) -make_stancode(count ~ Trt, data = epilepsy, prior = prior) - -} -\references{ -Gelman A. (2006). Prior distributions for variance parameters in hierarchical models. - Bayesian analysis, 1(3), 515 -- 534. -} -\seealso{ -\code{\link{get_prior}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/priors.R +\name{set_prior} +\alias{set_prior} +\alias{brmsprior} +\alias{brmsprior-class} +\alias{prior} +\alias{prior_} +\alias{prior_string} +\alias{empty_prior} +\title{Prior Definitions for \pkg{brms} Models} +\usage{ +set_prior( + prior, + class = "b", + coef = "", + group = "", + resp = "", + dpar = "", + nlpar = "", + lb = NA, + ub = NA, + check = TRUE +) + +prior(prior, ...) + +prior_(prior, ...) + +prior_string(prior, ...) + +empty_prior() +} +\arguments{ +\item{prior}{A character string defining a distribution in \pkg{Stan} language} + +\item{class}{The parameter class. Defaults to \code{"b"} +(i.e. population-level effects). +See 'Details' for other valid parameter classes.} + +\item{coef}{Name of the coefficient within the parameter class.} + +\item{group}{Grouping factor for group-level parameters.} + +\item{resp}{Name of the response variable. +Only used in multivariate models.} + +\item{dpar}{Name of a distributional parameter. +Only used in distributional models.} + +\item{nlpar}{Name of a non-linear parameter. +Only used in non-linear models.} + +\item{lb}{Lower bound for parameter restriction. Currently only allowed +for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction.} + +\item{ub}{Upper bound for parameter restriction. Currently only allowed +for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction.} + +\item{check}{Logical; Indicates whether priors +should be checked for validity (as far as possible). +Defaults to \code{TRUE}. If \code{FALSE}, \code{prior} is passed +to the Stan code as is, and all other arguments are ignored.} + +\item{...}{Arguments passed to \code{set_prior}.} +} +\value{ +An object of class \code{brmsprior} to be used in the \code{prior} + argument of \code{\link{brm}}. +} +\description{ +Define priors for specific parameters or classes of parameters. +} +\details{ +\code{set_prior} is used to define prior distributions for parameters + in \pkg{brms} models. The functions \code{prior}, \code{prior_}, and + \code{prior_string} are aliases of \code{set_prior} each allowing + for a different kind of argument specification. + \code{prior} allows specifying arguments as expression without + quotation marks using non-standard evaluation. + \code{prior_} allows specifying arguments as one-sided formulas + or wrapped in \code{quote}. + \code{prior_string} allows specifying arguments as strings just + as \code{set_prior} itself. + + Below, we explain its usage and list some common + prior distributions for parameters. + A complete overview on possible prior distributions is given + in the Stan Reference Manual available at \url{https://mc-stan.org/}. + + To combine multiple priors, use \code{c(...)} or the \code{+} operator + (see 'Examples'). \pkg{brms} does not check if the priors are written + in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their + syntactical correctness when the model is parsed to \code{C++} and + returns an error if they are not. + This, however, does not imply that priors are always meaningful if they are + accepted by \pkg{Stan}. Although \pkg{brms} trys to find common problems + (e.g., setting bounded priors on unbounded parameters), there is no guarantee + that the defined priors are reasonable for the model. + Below, we list the types of parameters in \pkg{brms} models, + for which the user can specify prior distributions. + + 1. Population-level ('fixed') effects + + Every Population-level effect has its own regression parameter + represents the name of the corresponding population-level effect. + Suppose, for instance, that \code{y} is predicted by \code{x1} and \code{x2} + (i.e., \code{y ~ x1 + x2} in formula syntax). + Then, \code{x1} and \code{x2} have regression parameters + \code{b_x1} and \code{b_x2} respectively. + The default prior for population-level effects (including monotonic and + category specific effects) is an improper flat prior over the reals. + Other common options are normal priors or student-t priors. + If we want to have a normal prior with mean 0 and + standard deviation 5 for \code{x1}, and a unit student-t prior with 10 + degrees of freedom for \code{x2}, we can specify this via + \code{set_prior("normal(0,5)", class = "b", coef = "x1")} and \cr + \code{set_prior("student_t(10, 0, 1)", class = "b", coef = "x2")}. + To put the same prior on all population-level effects at once, + we may write as a shortcut \code{set_prior("", class = "b")}. + This also leads to faster sampling, because priors can be vectorized in this case. + Both ways of defining priors can be combined using for instance + \code{set_prior("normal(0, 2)", class = "b")} and \cr + \code{set_prior("normal(0, 10)", class = "b", coef = "x1")} + at the same time. This will set a \code{normal(0, 10)} prior on + the effect of \code{x1} and a \code{normal(0, 2)} prior + on all other population-level effects. + However, this will break vectorization and + may slow down the sampling procedure a bit. + + In case of the default intercept parameterization + (discussed in the 'Details' section of \code{\link{brmsformula}}), + general priors on class \code{"b"} will \emph{not} affect + the intercept. Instead, the intercept has its own parameter class + named \code{"Intercept"} and priors can thus be + specified via \code{set_prior("", class = "Intercept")}. + Setting a prior on the intercept will not break vectorization + of the other population-level effects. + Note that technically, this prior is set on an intercept that + results when internally centering all population-level predictors + around zero to improve sampling efficiency. On this centered + intercept, specifying a prior is actually much easier and + intuitive than on the original intercept, since the former + represents the expected response value when all predictors + are at their means. To treat the intercept as an ordinary + population-level effect and avoid the centering parameterization, + use \code{0 + Intercept} on the right-hand side of the model formula. + + A special shrinkage prior to be applied on population-level effects is the + (regularized) horseshoe prior and related priors. See + \code{\link{horseshoe}} for details. Another shrinkage prior is the + so-called lasso prior. See \code{\link{lasso}} for details. + + In non-linear models, population-level effects are defined separately + for each non-linear parameter. Accordingly, it is necessary to specify + the non-linear parameter in \code{set_prior} so that priors + we can be assigned correctly. + If, for instance, \code{alpha} is the parameter and \code{x} the predictor + for which we want to define the prior, we can write + \code{set_prior("", coef = "x", nlpar = "alpha")}. + As a shortcut we can use \code{set_prior("", nlpar = "alpha")} + to set the same prior on all population-level effects of \code{alpha} at once. + + If desired, population-level effects can be restricted to fall only + within a certain interval using the \code{lb} and \code{ub} arguments + of \code{set_prior}. This is often required when defining priors + that are not defined everywhere on the real line, such as uniform + or gamma priors. When defining a \code{uniform(2,4)} prior, + you should write \code{set_prior("uniform(2,4)", lb = 2, ub = 4)}. + When using a prior that is defined on the positive reals only + (such as a gamma prior) set \code{lb = 0}. + In most situations, it is not useful to restrict population-level + parameters through bounded priors + (non-linear models are an important exception), + but if you really want to this is the way to go. + + 2. Standard deviations of group-level ('random') effects + + Each group-level effect of each grouping factor has a standard deviation named + \code{sd__}. Consider, for instance, the formula + \code{y ~ x1 + x2 + (1 + x1 | g)}. + We see that the intercept as well as \code{x1} are group-level effects + nested in the grouping factor \code{g}. + The corresponding standard deviation parameters are named as + \code{sd_g_Intercept} and \code{sd_g_x1} respectively. + These parameters are restricted to be non-negative and, by default, + have a half student-t prior with 3 degrees of freedom and a + scale parameter that depends on the standard deviation of the response + after applying the link function. Minimally, the scale parameter is 2.5. + This prior is used (a) to be only weakly informative in order to influence + results as few as possible, while (b) providing at least some regularization + to considerably improve convergence and sampling efficiency. + To define a prior distribution only for standard deviations + of a specific grouping factor, + use \cr \code{set_prior("", class = "sd", group = "")}. + To define a prior distribution only for a specific standard deviation + of a specific grouping factor, you may write \cr + \code{set_prior("", class = "sd", group = "", coef = "")}. + Recommendations on useful prior distributions for + standard deviations are given in Gelman (2006), but note that he + is no longer recommending uniform priors, anymore. \cr + + When defining priors on group-level parameters in non-linear models, + please make sure to specify the corresponding non-linear parameter + through the \code{nlpar} argument in the same way as + for population-level effects. + + 3. Correlations of group-level ('random') effects + + If there is more than one group-level effect per grouping factor, + the correlations between those effects have to be estimated. + The prior \code{lkj_corr_cholesky(eta)} or in short + \code{lkj(eta)} with \code{eta > 0} + is essentially the only prior for (Cholesky factors) of correlation matrices. + If \code{eta = 1} (the default) all correlations matrices + are equally likely a priori. If \code{eta > 1}, extreme correlations + become less likely, whereas \code{0 < eta < 1} results in + higher probabilities for extreme correlations. + Correlation matrix parameters in \code{brms} models are named as + \code{cor_}, (e.g., \code{cor_g} if \code{g} is the grouping factor). + To set the same prior on every correlation matrix, + use for instance \code{set_prior("lkj(2)", class = "cor")}. + Internally, the priors are transformed to be put on the Cholesky factors + of the correlation matrices to improve efficiency and numerical stability. + The corresponding parameter class of the Cholesky factors is \code{L}, + but it is not recommended to specify priors for this parameter class directly. + + 4. Splines + + Splines are implemented in \pkg{brms} using the 'random effects' + formulation as explained in \code{\link[mgcv:gamm]{gamm}}). + Thus, each spline has its corresponding standard deviations + modeling the variability within this term. In \pkg{brms}, this + parameter class is called \code{sds} and priors can + be specified via \code{set_prior("", class = "sds", + coef = "")}. The default prior is the same as + for standard deviations of group-level effects. + + 5. Gaussian processes + + Gaussian processes as currently implemented in \pkg{brms} have + two parameters, the standard deviation parameter \code{sdgp}, + and characteristic length-scale parameter \code{lscale} + (see \code{\link{gp}} for more details). The default prior + of \code{sdgp} is the same as for standard deviations of + group-level effects. The default prior of \code{lscale} + is an informative inverse-gamma prior specifically tuned + to the covariates of the Gaussian process (for more details see + \url{https://betanalpha.github.io/assets/case_studies/gp_part3/part3.html}). + This tuned prior may be overly informative in some cases, so please + consider other priors as well to make sure inference is + robust to the prior specification. If tuning fails, a half-normal prior + is used instead. + + 6. Autocorrelation parameters + + The autocorrelation parameters currently implemented are named \code{ar} + (autoregression), \code{ma} (moving average), \code{sderr} (standard + deviation of latent residuals in latent ARMA models), \code{cosy} (compound + symmetry correlation), \code{car} (spatial conditional autoregression), as + well as \code{lagsar} and \code{errorsar} (spatial simultaneous + autoregression). + + Priors can be defined by \code{set_prior("", class = "ar")} for + \code{ar} and similar for other autocorrelation parameters. By default, + \code{ar} and \code{ma} are bounded between \code{-1} and \code{1}; + \code{cosy}, \code{car}, \code{lagsar}, and \code{errorsar} are bounded + between \code{0} and \code{1}. The default priors are flat over the + respective definition areas. + + 7. Distance parameters of monotonic effects + + As explained in the details section of \code{\link{brm}}, + monotonic effects make use of a special parameter vector to + estimate the 'normalized distances' between consecutive predictor + categories. This is realized in \pkg{Stan} using the \code{simplex} + parameter type. This class is named \code{"simo"} (short for + simplex monotonic) in \pkg{brms}. + The only valid prior for simplex parameters is the + dirichlet prior, which accepts a vector of length \code{K - 1} + (K = number of predictor categories) as input defining the + 'concentration' of the distribution. Explaining the dirichlet prior + is beyond the scope of this documentation, but we want to describe + how to define this prior syntactically correct. + If a predictor \code{x} with \code{K} categories is modeled as monotonic, + we can define a prior on its corresponding simplex via \cr + \code{prior(dirichlet(), class = simo, coef = mox1)}. + The \code{1} in the end of \code{coef} indicates that this is the first + simplex in this term. If interactions between multiple monotonic + variables are modeled, multiple simplexes per term are required. + For \code{}, we can put in any \code{R} expression + defining a vector of length \code{K - 1}. The default is a uniform + prior (i.e. \code{ = rep(1, K-1)}) over all simplexes + of the respective dimension. + + 8. Parameters for specific families + + Some families need additional parameters to be estimated. + Families \code{gaussian}, \code{student}, \code{skew_normal}, + \code{lognormal}, and \code{gen_extreme_value} need the parameter + \code{sigma} to account for the residual standard deviation. + By default, \code{sigma} has a half student-t prior that scales + in the same way as the group-level standard deviations. + Further, family \code{student} needs the parameter + \code{nu} representing the degrees of freedom of students-t distribution. + By default, \code{nu} has prior \code{gamma(2, 0.1)} + and a fixed lower bound of \code{1}. + Families \code{gamma}, \code{weibull}, \code{inverse.gaussian}, and + \code{negbinomial} need a \code{shape} parameter that has a + \code{gamma(0.01, 0.01)} prior by default. + For families \code{cumulative}, \code{cratio}, \code{sratio}, + and \code{acat}, and only if \code{threshold = "equidistant"}, + the parameter \code{delta} is used to model the distance between + two adjacent thresholds. + By default, \code{delta} has an improper flat prior over the reals. + The \code{von_mises} family needs the parameter \code{kappa}, representing + the concentration parameter. By default, \code{kappa} has prior + \code{gamma(2, 0.01)}. \cr + Every family specific parameter has its own prior class, so that + \code{set_prior("", class = "")} is the right way to go. + All of these priors are chosen to be weakly informative, + having only minimal influence on the estimations, + while improving convergence and sampling efficiency. + + Fixing parameters to constants is possible by using the \code{constant} + function, for example, \code{constant(1)} to fix a parameter to 1. + Broadcasting to vectors and matrices is done automatically. + + Often, it may not be immediately clear, which parameters are present in the + model. To get a full list of parameters and parameter classes for which + priors can be specified (depending on the model) use function + \code{\link{get_prior}}. +} +\section{Functions}{ +\itemize{ +\item \code{prior}: Alias of \code{set_prior} allowing to +specify arguments as expressions without quotation marks. + +\item \code{prior_}: Alias of \code{set_prior} allowing to specify +arguments as as one-sided formulas or wrapped in \code{quote}. + +\item \code{prior_string}: Alias of \code{set_prior} allowing to +specify arguments as strings. + +\item \code{empty_prior}: Create an empty \code{brmsprior} object. +}} + +\examples{ +## use alias functions +(prior1 <- prior(cauchy(0, 1), class = sd)) +(prior2 <- prior_(~cauchy(0, 1), class = ~sd)) +(prior3 <- prior_string("cauchy(0, 1)", class = "sd")) +identical(prior1, prior2) +identical(prior1, prior3) + +# check which parameters can have priors +get_prior(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = cumulative()) + +# define some priors +bprior <- c(prior_string("normal(0,10)", class = "b"), + prior(normal(1,2), class = b, coef = treat), + prior_(~cauchy(0,2), class = ~sd, + group = ~subject, coef = ~Intercept)) + +# verify that the priors indeed found their way into Stan's model code +make_stancode(rating ~ treat + period + carry + (1|subject), + data = inhaler, family = cumulative(), + prior = bprior) + +# use the horseshoe prior to model sparsity in regression coefficients +make_stancode(count ~ zAge + zBase * Trt, + data = epilepsy, family = poisson(), + prior = set_prior("horseshoe(3)")) + +# fix certain priors to constants +bprior <- prior(constant(1), class = "b") + + prior(constant(2), class = "b", coef = "zBase") + + prior(constant(0.5), class = "sd") +make_stancode(count ~ zAge + zBase + (1 | patient), + data = epilepsy, prior = bprior) + +# pass priors to Stan without checking +prior <- prior_string("target += normal_lpdf(b[1] | 0, 1)", check = FALSE) +make_stancode(count ~ Trt, data = epilepsy, prior = prior) + +} +\references{ +Gelman A. (2006). Prior distributions for variance parameters in hierarchical models. + Bayesian analysis, 1(3), 515 -- 534. +} +\seealso{ +\code{\link{get_prior}} +} diff -Nru r-cran-brms-2.16.3/man/Shifted_Lognormal.Rd r-cran-brms-2.17.0/man/Shifted_Lognormal.Rd --- r-cran-brms-2.16.3/man/Shifted_Lognormal.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/Shifted_Lognormal.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,61 +1,61 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{Shifted_Lognormal} -\alias{Shifted_Lognormal} -\alias{dshifted_lnorm} -\alias{pshifted_lnorm} -\alias{qshifted_lnorm} -\alias{rshifted_lnorm} -\title{The Shifted Log Normal Distribution} -\usage{ -dshifted_lnorm(x, meanlog = 0, sdlog = 1, shift = 0, log = FALSE) - -pshifted_lnorm( - q, - meanlog = 0, - sdlog = 1, - shift = 0, - lower.tail = TRUE, - log.p = FALSE -) - -qshifted_lnorm( - p, - meanlog = 0, - sdlog = 1, - shift = 0, - lower.tail = TRUE, - log.p = FALSE -) - -rshifted_lnorm(n, meanlog = 0, sdlog = 1, shift = 0) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{meanlog}{Vector of means.} - -\item{sdlog}{Vector of standard deviations.} - -\item{shift}{Vector of shifts.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{p}{Vector of probabilities.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, quantile function and random generation -for the shifted log normal distribution with mean \code{meanlog}, -standard deviation \code{sdlog}, and shift parameter \code{shift}. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{Shifted_Lognormal} +\alias{Shifted_Lognormal} +\alias{dshifted_lnorm} +\alias{pshifted_lnorm} +\alias{qshifted_lnorm} +\alias{rshifted_lnorm} +\title{The Shifted Log Normal Distribution} +\usage{ +dshifted_lnorm(x, meanlog = 0, sdlog = 1, shift = 0, log = FALSE) + +pshifted_lnorm( + q, + meanlog = 0, + sdlog = 1, + shift = 0, + lower.tail = TRUE, + log.p = FALSE +) + +qshifted_lnorm( + p, + meanlog = 0, + sdlog = 1, + shift = 0, + lower.tail = TRUE, + log.p = FALSE +) + +rshifted_lnorm(n, meanlog = 0, sdlog = 1, shift = 0) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{meanlog}{Vector of means.} + +\item{sdlog}{Vector of standard deviations.} + +\item{shift}{Vector of shifts.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{p}{Vector of probabilities.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, quantile function and random generation +for the shifted log normal distribution with mean \code{meanlog}, +standard deviation \code{sdlog}, and shift parameter \code{shift}. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} diff -Nru r-cran-brms-2.16.3/man/SkewNormal.Rd r-cran-brms-2.17.0/man/SkewNormal.Rd --- r-cran-brms-2.16.3/man/SkewNormal.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/SkewNormal.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,83 +1,83 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{SkewNormal} -\alias{SkewNormal} -\alias{dskew_normal} -\alias{pskew_normal} -\alias{qskew_normal} -\alias{rskew_normal} -\title{The Skew-Normal Distribution} -\usage{ -dskew_normal( - x, - mu = 0, - sigma = 1, - alpha = 0, - xi = NULL, - omega = NULL, - log = FALSE -) - -pskew_normal( - q, - mu = 0, - sigma = 1, - alpha = 0, - xi = NULL, - omega = NULL, - lower.tail = TRUE, - log.p = FALSE -) - -qskew_normal( - p, - mu = 0, - sigma = 1, - alpha = 0, - xi = NULL, - omega = NULL, - lower.tail = TRUE, - log.p = FALSE, - tol = 1e-08 -) - -rskew_normal(n, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{mu}{Vector of mean values.} - -\item{sigma}{Vector of standard deviation values.} - -\item{alpha}{Vector of skewness values.} - -\item{xi}{Optional vector of location values. -If \code{NULL} (the default), will be computed internally.} - -\item{omega}{Optional vector of scale values. -If \code{NULL} (the default), will be computed internally.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{p}{Vector of probabilities.} - -\item{tol}{Tolerance of the approximation used in the -computation of quantiles.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, and random generation for the -skew-normal distribution with mean \code{mu}, -standard deviation \code{sigma}, and skewness \code{alpha}. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{SkewNormal} +\alias{SkewNormal} +\alias{dskew_normal} +\alias{pskew_normal} +\alias{qskew_normal} +\alias{rskew_normal} +\title{The Skew-Normal Distribution} +\usage{ +dskew_normal( + x, + mu = 0, + sigma = 1, + alpha = 0, + xi = NULL, + omega = NULL, + log = FALSE +) + +pskew_normal( + q, + mu = 0, + sigma = 1, + alpha = 0, + xi = NULL, + omega = NULL, + lower.tail = TRUE, + log.p = FALSE +) + +qskew_normal( + p, + mu = 0, + sigma = 1, + alpha = 0, + xi = NULL, + omega = NULL, + lower.tail = TRUE, + log.p = FALSE, + tol = 1e-08 +) + +rskew_normal(n, mu = 0, sigma = 1, alpha = 0, xi = NULL, omega = NULL) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{mu}{Vector of mean values.} + +\item{sigma}{Vector of standard deviation values.} + +\item{alpha}{Vector of skewness values.} + +\item{xi}{Optional vector of location values. +If \code{NULL} (the default), will be computed internally.} + +\item{omega}{Optional vector of scale values. +If \code{NULL} (the default), will be computed internally.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{p}{Vector of probabilities.} + +\item{tol}{Tolerance of the approximation used in the +computation of quantiles.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, and random generation for the +skew-normal distribution with mean \code{mu}, +standard deviation \code{sigma}, and skewness \code{alpha}. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} diff -Nru r-cran-brms-2.16.3/man/s.Rd r-cran-brms-2.17.0/man/s.Rd --- r-cran-brms-2.16.3/man/s.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/s.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,47 +1,47 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/formula-sm.R -\name{s} -\alias{s} -\alias{t2} -\title{Defining smooths in \pkg{brms} formulas} -\usage{ -s(...) - -t2(...) -} -\arguments{ -\item{...}{Arguments passed to \code{\link[mgcv:s]{mgcv::s}} or -\code{\link[mgcv:t2]{mgcv::t2}}.} -} -\description{ -Functions used in definition of smooth terms within a model formulas. -The function does not evaluate a (spline) smooth - it exists purely -to help set up a model using spline based smooths. -} -\details{ -The function defined here are just simple wrappers - of the respective functions of the \pkg{mgcv} package. -} -\examples{ -\dontrun{ -# simulate some data -dat <- mgcv::gamSim(1, n = 200, scale = 2) - -# fit univariate smooths for all predictors -fit1 <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), - data = dat, chains = 2) -summary(fit1) -plot(conditional_smooths(fit1), ask = FALSE) - -# fit a more complicated smooth model -fit2 <- brm(y ~ t2(x0, x1) + s(x2, by = x3), - data = dat, chains = 2) -summary(fit2) -plot(conditional_smooths(fit2), ask = FALSE) -} - -} -\seealso{ -\code{\link{brmsformula}}, - \code{\link[mgcv:s]{mgcv::s}}, \code{\link[mgcv:t2]{mgcv::t2}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/formula-sm.R +\name{s} +\alias{s} +\alias{t2} +\title{Defining smooths in \pkg{brms} formulas} +\usage{ +s(...) + +t2(...) +} +\arguments{ +\item{...}{Arguments passed to \code{\link[mgcv:s]{mgcv::s}} or +\code{\link[mgcv:t2]{mgcv::t2}}.} +} +\description{ +Functions used in definition of smooth terms within a model formulas. +The function does not evaluate a (spline) smooth - it exists purely +to help set up a model using spline based smooths. +} +\details{ +The function defined here are just simple wrappers + of the respective functions of the \pkg{mgcv} package. +} +\examples{ +\dontrun{ +# simulate some data +dat <- mgcv::gamSim(1, n = 200, scale = 2) + +# fit univariate smooths for all predictors +fit1 <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), + data = dat, chains = 2) +summary(fit1) +plot(conditional_smooths(fit1), ask = FALSE) + +# fit a more complicated smooth model +fit2 <- brm(y ~ t2(x0, x1) + s(x2, by = x3), + data = dat, chains = 2) +summary(fit2) +plot(conditional_smooths(fit2), ask = FALSE) +} + +} +\seealso{ +\code{\link{brmsformula}}, + \code{\link[mgcv:s]{mgcv::s}}, \code{\link[mgcv:t2]{mgcv::t2}} +} diff -Nru r-cran-brms-2.16.3/man/stancode.brmsfit.Rd r-cran-brms-2.17.0/man/stancode.brmsfit.Rd --- r-cran-brms-2.16.3/man/stancode.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/stancode.brmsfit.Rd 2022-04-08 11:57:41.000000000 +0000 @@ -1,35 +1,44 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/make_stancode.R -\name{stancode.brmsfit} -\alias{stancode.brmsfit} -\alias{stancode} -\title{Extract Stan model code} -\usage{ -\method{stancode}{brmsfit}(object, version = TRUE, regenerate = NULL, threads = NULL, ...) - -stancode(object, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{version}{Logical; indicates if the first line containing -the \pkg{brms} version number should be included. -Defaults to \code{TRUE}.} - -\item{regenerate}{Logical; indicates if the Stan code should -be regenerated with the current \pkg{brms} version. -By default, \code{regenerate} will be \code{FALSE} unless required -to be \code{TRUE} by other arguments.} - -\item{threads}{Controls whether the Stan code should be threaded. -See \code{\link{threading}} for details.} - -\item{...}{Further arguments passed to \code{\link{make_stancode}} if the -Stan code is regenerated.} -} -\value{ -Stan model code for further processing. -} -\description{ -Extract Stan code that was used to specify the model. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/make_stancode.R +\name{stancode.brmsfit} +\alias{stancode.brmsfit} +\alias{stancode} +\title{Extract Stan model code} +\usage{ +\method{stancode}{brmsfit}( + object, + version = TRUE, + regenerate = NULL, + threads = NULL, + backend = NULL, + ... +) + +stancode(object, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{version}{Logical; indicates if the first line containing +the \pkg{brms} version number should be included. +Defaults to \code{TRUE}.} + +\item{regenerate}{Logical; indicates if the Stan code should +be regenerated with the current \pkg{brms} version. +By default, \code{regenerate} will be \code{FALSE} unless required +to be \code{TRUE} by other arguments.} + +\item{threads}{Controls whether the Stan code should be threaded. +See \code{\link{threading}} for details.} + +\item{backend}{Controls the Stan backend. See \code{\link{brm}} for details.} + +\item{...}{Further arguments passed to \code{\link{make_stancode}} if the +Stan code is regenerated.} +} +\value{ +Stan model code for further processing. +} +\description{ +Extract Stan code that was used to specify the model. +} diff -Nru r-cran-brms-2.16.3/man/standata.brmsfit.Rd r-cran-brms-2.17.0/man/standata.brmsfit.Rd --- r-cran-brms-2.16.3/man/standata.brmsfit.Rd 2020-07-08 07:08:40.000000000 +0000 +++ r-cran-brms-2.17.0/man/standata.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,51 +1,51 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/make_standata.R -\name{standata.brmsfit} -\alias{standata.brmsfit} -\alias{standata} -\title{Extract data passed to Stan} -\usage{ -\method{standata}{brmsfit}( - object, - newdata = NULL, - re_formula = NULL, - newdata2 = NULL, - new_objects = NULL, - incl_autocor = TRUE, - ... -) - -standata(object, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{newdata}{An optional data.frame for which to evaluate predictions. If -\code{NULL} (default), the original data of the model is used. -\code{NA} values within factors are interpreted as if all dummy -variables of this factor are zero. This allows, for instance, to make -predictions of the grand mean when using sum coding.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{newdata2}{A named \code{list} of objects containing new data, which -cannot be passed via argument \code{newdata}. Required for some objects -used in autocorrelation structures, or \code{\link{stanvars}}.} - -\item{new_objects}{Deprecated alias of \code{newdata2}.} - -\item{incl_autocor}{A flag indicating if correlation structures originally -specified via \code{autocor} should be included in the predictions. -Defaults to \code{TRUE}.} - -\item{...}{More arguments passed to \code{\link{make_standata}} -and \code{\link{validate_newdata}}.} -} -\value{ -A named list containing the data originally passed to Stan. -} -\description{ -Extract all data that was used by Stan to fit the model. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/make_standata.R +\name{standata.brmsfit} +\alias{standata.brmsfit} +\alias{standata} +\title{Extract data passed to Stan} +\usage{ +\method{standata}{brmsfit}( + object, + newdata = NULL, + re_formula = NULL, + newdata2 = NULL, + new_objects = NULL, + incl_autocor = TRUE, + ... +) + +standata(object, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{newdata}{An optional data.frame for which to evaluate predictions. If +\code{NULL} (default), the original data of the model is used. +\code{NA} values within factors are interpreted as if all dummy +variables of this factor are zero. This allows, for instance, to make +predictions of the grand mean when using sum coding.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{newdata2}{A named \code{list} of objects containing new data, which +cannot be passed via argument \code{newdata}. Required for some objects +used in autocorrelation structures, or \code{\link{stanvars}}.} + +\item{new_objects}{Deprecated alias of \code{newdata2}.} + +\item{incl_autocor}{A flag indicating if correlation structures originally +specified via \code{autocor} should be included in the predictions. +Defaults to \code{TRUE}.} + +\item{...}{More arguments passed to \code{\link{make_standata}} +and \code{\link{validate_newdata}}.} +} +\value{ +A named list containing the data originally passed to Stan. +} +\description{ +Extract all data that was used by Stan to fit the model. +} diff -Nru r-cran-brms-2.16.3/man/stanvar.Rd r-cran-brms-2.17.0/man/stanvar.Rd --- r-cran-brms-2.16.3/man/stanvar.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/stanvar.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,82 +1,82 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/stanvars.R -\name{stanvar} -\alias{stanvar} -\alias{stanvars} -\title{User-defined variables passed to Stan} -\usage{ -stanvar( - x = NULL, - name = NULL, - scode = NULL, - block = "data", - position = "start", - pll_args = NULL -) -} -\arguments{ -\item{x}{An \R object containing data to be passed to Stan. -Only required if \code{block = 'data'} and ignored otherwise.} - -\item{name}{Optional character string providing the desired variable -name of the object in \code{x}. If \code{NULL} (the default) -the variable name is directly inferred from \code{x}.} - -\item{scode}{Line of Stan code to define the variable -in Stan language. If \code{block = 'data'}, the -Stan code is inferred based on the class of \code{x} by default.} - -\item{block}{Name of one of Stan's program blocks in -which the variable should be defined. Can be \code{'data'}, -\code{'tdata'} (transformed data), \code{'parameters'}, -\code{'tparameters'} (transformed parameters), \code{'model'}, -\code{'likelihood'} (part of the model block where the likelihood is given), -\code{'genquant'} (generated quantities) or \code{'functions'}.} - -\item{position}{Name of the position within the block where the -Stan code should be placed. Currently allowed are \code{'start'} -(the default) and \code{'end'} of the block.} - -\item{pll_args}{Optional Stan code to be put into the header -of \code{partial_log_lik} functions. This ensures that the variables -specified in \code{scode} can be used in the likelihood even when -within-chain parallelization is activated via \code{\link{threading}}.} -} -\value{ -An object of class \code{stanvars}. -} -\description{ -Prepare user-defined variables to be passed to one of Stan's -program blocks. This is primarily useful for defining more complex -priors, for refitting models without recompilation despite -changing priors, or for defining custom Stan functions. -} -\examples{ -bprior <- prior(normal(mean_intercept, 10), class = "Intercept") -stanvars <- stanvar(5, name = "mean_intercept") -make_stancode(count ~ Trt, epilepsy, prior = bprior, - stanvars = stanvars) - -# define a multi-normal prior with known covariance matrix -bprior <- prior(multi_normal(M, V), class = "b") -stanvars <- stanvar(rep(0, 2), "M", scode = " vector[K] M;") + - stanvar(diag(2), "V", scode = " matrix[K, K] V;") -make_stancode(count ~ Trt + zBase, epilepsy, - prior = bprior, stanvars = stanvars) - -# define a hierachical prior on the regression coefficients -bprior <- set_prior("normal(0, tau)", class = "b") + - set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) -stanvars <- stanvar(scode = "real tau;", - block = "parameters") -make_stancode(count ~ Trt + zBase, epilepsy, - prior = bprior, stanvars = stanvars) - -# ensure that 'tau' is passed to the likelihood of a threaded model -# not necessary for this example but may be necessary in other cases -stanvars <- stanvar(scode = "real tau;", - block = "parameters", pll_args = "real tau") -make_stancode(count ~ Trt + zBase, epilepsy, - stanvars = stanvars, threads = threading(2)) - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stanvars.R +\name{stanvar} +\alias{stanvar} +\alias{stanvars} +\title{User-defined variables passed to Stan} +\usage{ +stanvar( + x = NULL, + name = NULL, + scode = NULL, + block = "data", + position = "start", + pll_args = NULL +) +} +\arguments{ +\item{x}{An \R object containing data to be passed to Stan. +Only required if \code{block = 'data'} and ignored otherwise.} + +\item{name}{Optional character string providing the desired variable +name of the object in \code{x}. If \code{NULL} (the default) +the variable name is directly inferred from \code{x}.} + +\item{scode}{Line of Stan code to define the variable +in Stan language. If \code{block = 'data'}, the +Stan code is inferred based on the class of \code{x} by default.} + +\item{block}{Name of one of Stan's program blocks in +which the variable should be defined. Can be \code{'data'}, +\code{'tdata'} (transformed data), \code{'parameters'}, +\code{'tparameters'} (transformed parameters), \code{'model'}, +\code{'likelihood'} (part of the model block where the likelihood is given), +\code{'genquant'} (generated quantities) or \code{'functions'}.} + +\item{position}{Name of the position within the block where the +Stan code should be placed. Currently allowed are \code{'start'} +(the default) and \code{'end'} of the block.} + +\item{pll_args}{Optional Stan code to be put into the header +of \code{partial_log_lik} functions. This ensures that the variables +specified in \code{scode} can be used in the likelihood even when +within-chain parallelization is activated via \code{\link{threading}}.} +} +\value{ +An object of class \code{stanvars}. +} +\description{ +Prepare user-defined variables to be passed to one of Stan's +program blocks. This is primarily useful for defining more complex +priors, for refitting models without recompilation despite +changing priors, or for defining custom Stan functions. +} +\examples{ +bprior <- prior(normal(mean_intercept, 10), class = "Intercept") +stanvars <- stanvar(5, name = "mean_intercept") +make_stancode(count ~ Trt, epilepsy, prior = bprior, + stanvars = stanvars) + +# define a multi-normal prior with known covariance matrix +bprior <- prior(multi_normal(M, V), class = "b") +stanvars <- stanvar(rep(0, 2), "M", scode = " vector[K] M;") + + stanvar(diag(2), "V", scode = " matrix[K, K] V;") +make_stancode(count ~ Trt + zBase, epilepsy, + prior = bprior, stanvars = stanvars) + +# define a hierachical prior on the regression coefficients +bprior <- set_prior("normal(0, tau)", class = "b") + + set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) +stanvars <- stanvar(scode = "real tau;", + block = "parameters") +make_stancode(count ~ Trt + zBase, epilepsy, + prior = bprior, stanvars = stanvars) + +# ensure that 'tau' is passed to the likelihood of a threaded model +# not necessary for this example but may be necessary in other cases +stanvars <- stanvar(scode = "real tau;", + block = "parameters", pll_args = "real tau") +make_stancode(count ~ Trt + zBase, epilepsy, + stanvars = stanvars, threads = threading(2)) + +} diff -Nru r-cran-brms-2.16.3/man/StudentT.Rd r-cran-brms-2.17.0/man/StudentT.Rd --- r-cran-brms-2.16.3/man/StudentT.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/StudentT.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,48 +1,48 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{StudentT} -\alias{StudentT} -\alias{dstudent_t} -\alias{pstudent_t} -\alias{qstudent_t} -\alias{rstudent_t} -\title{The Student-t Distribution} -\usage{ -dstudent_t(x, df, mu = 0, sigma = 1, log = FALSE) - -pstudent_t(q, df, mu = 0, sigma = 1, lower.tail = TRUE, log.p = FALSE) - -qstudent_t(p, df, mu = 0, sigma = 1) - -rstudent_t(n, df, mu = 0, sigma = 1) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{df}{Vector of degrees of freedom.} - -\item{mu}{Vector of location values.} - -\item{sigma}{Vector of scale values.} - -\item{log, log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{p}{Vector of probabilities.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, quantile function and random generation -for the Student-t distribution with location \code{mu}, scale \code{sigma}, -and degrees of freedom \code{df}. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} -\seealso{ -\code{\link[stats:TDist]{TDist}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{StudentT} +\alias{StudentT} +\alias{dstudent_t} +\alias{pstudent_t} +\alias{qstudent_t} +\alias{rstudent_t} +\title{The Student-t Distribution} +\usage{ +dstudent_t(x, df, mu = 0, sigma = 1, log = FALSE) + +pstudent_t(q, df, mu = 0, sigma = 1, lower.tail = TRUE, log.p = FALSE) + +qstudent_t(p, df, mu = 0, sigma = 1) + +rstudent_t(n, df, mu = 0, sigma = 1) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{df}{Vector of degrees of freedom.} + +\item{mu}{Vector of location values.} + +\item{sigma}{Vector of scale values.} + +\item{log, log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{p}{Vector of probabilities.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, quantile function and random generation +for the Student-t distribution with location \code{mu}, scale \code{sigma}, +and degrees of freedom \code{df}. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} +\seealso{ +\code{\link[stats:TDist]{TDist}} +} diff -Nru r-cran-brms-2.16.3/man/summary.brmsfit.Rd r-cran-brms-2.17.0/man/summary.brmsfit.Rd --- r-cran-brms-2.16.3/man/summary.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/summary.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,48 +1,48 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/summary.R -\name{summary.brmsfit} -\alias{summary.brmsfit} -\title{Create a summary of a fitted model represented by a \code{brmsfit} object} -\usage{ -\method{summary}{brmsfit}( - object, - priors = FALSE, - prob = 0.95, - robust = FALSE, - mc_se = FALSE, - ... -) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{priors}{Logical; Indicating if priors should be included -in the summary. Default is \code{FALSE}.} - -\item{prob}{A value between 0 and 1 indicating the desired probability -to be covered by the uncertainty intervals. The default is 0.95.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead.} - -\item{mc_se}{Logical; Indicating if the uncertainty in \code{Estimate} -caused by the MCMC sampling should be shown in the summary. Defaults to -\code{FALSE}.} - -\item{...}{Other potential arguments} -} -\description{ -Create a summary of a fitted model represented by a \code{brmsfit} object -} -\details{ -The convergence diagnostics \code{Rhat}, \code{Bulk_ESS}, and -\code{Tail_ESS} are described in detail in Vehtari et al. (2020). -} -\references{ -Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and -Paul-Christian Bürkner (2020). Rank-normalization, folding, and -localization: An improved R-hat for assessing convergence of -MCMC. *Bayesian Analysis*. 1–28. dpi:10.1214/20-BA1221 -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/summary.R +\name{summary.brmsfit} +\alias{summary.brmsfit} +\title{Create a summary of a fitted model represented by a \code{brmsfit} object} +\usage{ +\method{summary}{brmsfit}( + object, + priors = FALSE, + prob = 0.95, + robust = FALSE, + mc_se = FALSE, + ... +) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{priors}{Logical; Indicating if priors should be included +in the summary. Default is \code{FALSE}.} + +\item{prob}{A value between 0 and 1 indicating the desired probability +to be covered by the uncertainty intervals. The default is 0.95.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead.} + +\item{mc_se}{Logical; Indicating if the uncertainty in \code{Estimate} +caused by the MCMC sampling should be shown in the summary. Defaults to +\code{FALSE}.} + +\item{...}{Other potential arguments} +} +\description{ +Create a summary of a fitted model represented by a \code{brmsfit} object +} +\details{ +The convergence diagnostics \code{Rhat}, \code{Bulk_ESS}, and +\code{Tail_ESS} are described in detail in Vehtari et al. (2020). +} +\references{ +Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and +Paul-Christian Bürkner (2020). Rank-normalization, folding, and +localization: An improved R-hat for assessing convergence of +MCMC. *Bayesian Analysis*. 1–28. dpi:10.1214/20-BA1221 +} diff -Nru r-cran-brms-2.16.3/man/theme_black.Rd r-cran-brms-2.17.0/man/theme_black.Rd --- r-cran-brms-2.16.3/man/theme_black.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/theme_black.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,45 +1,45 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ggplot-themes.R -\name{theme_black} -\alias{theme_black} -\title{(Deprecated) Black Theme for \pkg{ggplot2} Graphics} -\usage{ -theme_black(base_size = 12, base_family = "") -} -\arguments{ -\item{base_size}{base font size} - -\item{base_family}{base font family} -} -\value{ -A \code{theme} object used in \pkg{ggplot2} graphics. -} -\description{ -A black theme for ggplot graphics inspired by a blog post of Jon Lefcheck -(\url{https://jonlefcheck.net/2013/03/11/black-theme-for-ggplot2-2/}). -} -\details{ -When using \code{theme_black} in plots powered by the -\pkg{bayesplot} package such as \code{pp_check} or \code{stanplot}, -I recommend using the \code{"viridisC"} color scheme (see examples). -} -\examples{ -\dontrun{ -# change default ggplot theme -ggplot2::theme_set(theme_black()) - -# change default bayesplot color scheme -bayesplot::color_scheme_set("viridisC") - -# fit a simple model -fit <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson(), chains = 2) -summary(fit) - -# create various plots -plot(marginal_effects(fit), ask = FALSE) -pp_check(fit) -mcmc_plot(fit, type = "hex", variable = c("b_Intercept", "b_Trt1")) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ggplot-themes.R +\name{theme_black} +\alias{theme_black} +\title{(Deprecated) Black Theme for \pkg{ggplot2} Graphics} +\usage{ +theme_black(base_size = 12, base_family = "") +} +\arguments{ +\item{base_size}{base font size} + +\item{base_family}{base font family} +} +\value{ +A \code{theme} object used in \pkg{ggplot2} graphics. +} +\description{ +A black theme for ggplot graphics inspired by a blog post of Jon Lefcheck +(\url{https://jonlefcheck.net/2013/03/11/black-theme-for-ggplot2-2/}). +} +\details{ +When using \code{theme_black} in plots powered by the +\pkg{bayesplot} package such as \code{pp_check} or \code{stanplot}, +I recommend using the \code{"viridisC"} color scheme (see examples). +} +\examples{ +\dontrun{ +# change default ggplot theme +ggplot2::theme_set(theme_black()) + +# change default bayesplot color scheme +bayesplot::color_scheme_set("viridisC") + +# fit a simple model +fit <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson(), chains = 2) +summary(fit) + +# create various plots +plot(marginal_effects(fit), ask = FALSE) +pp_check(fit) +mcmc_plot(fit, type = "hex", variable = c("b_Intercept", "b_Trt1")) +} + +} diff -Nru r-cran-brms-2.16.3/man/theme_default.Rd r-cran-brms-2.17.0/man/theme_default.Rd --- r-cran-brms-2.16.3/man/theme_default.Rd 2020-08-05 10:25:46.000000000 +0000 +++ r-cran-brms-2.17.0/man/theme_default.Rd 2021-12-20 13:50:54.000000000 +0000 @@ -1,18 +1,18 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.R -\name{theme_default} -\alias{theme_default} -\title{Default \pkg{bayesplot} Theme for \pkg{ggplot2} Graphics} -\arguments{ -\item{base_size}{base font size} - -\item{base_family}{base font family} -} -\value{ -A \code{theme} object used in \pkg{ggplot2} graphics. -} -\description{ -This theme is imported from the \pkg{bayesplot} package. -See \code{\link[bayesplot:theme_default]{theme_default}} -for a complete documentation. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.R +\name{theme_default} +\alias{theme_default} +\title{Default \pkg{bayesplot} Theme for \pkg{ggplot2} Graphics} +\arguments{ +\item{base_size}{base font size} + +\item{base_family}{base font family} +} +\value{ +A \code{theme} object used in \pkg{ggplot2} graphics. +} +\description{ +This theme is imported from the \pkg{bayesplot} package. +See \code{\link[bayesplot:theme_default]{theme_default}} +for a complete documentation. +} diff -Nru r-cran-brms-2.16.3/man/threading.Rd r-cran-brms-2.17.0/man/threading.Rd --- r-cran-brms-2.16.3/man/threading.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/threading.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,57 +1,57 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/backends.R -\name{threading} -\alias{threading} -\title{Threading in Stan} -\usage{ -threading(threads = NULL, grainsize = NULL, static = FALSE) -} -\arguments{ -\item{threads}{Number of threads to use in within-chain parallelization.} - -\item{grainsize}{Number of observations evaluated together in one chunk on -one of the CPUs used for threading. If \code{NULL} (the default), -\code{grainsize} is currently chosen as \code{max(100, N / (2 * -threads))}, where \code{N} is the number of observations in the data. This -default is experimental and may change in the future without prior notice.} - -\item{static}{Logical. Apply the static (non-adaptive) version of -\code{reduce_sum}? Defaults to \code{FALSE}. Setting it to \code{TRUE} -is required to achieve exact reproducibility of the model results -(if the random seed is set as well).} -} -\value{ -A \code{brmsthreads} object which can be passed to the - \code{threads} argument of \code{brm} and related functions. -} -\description{ -Use threads for within-chain parallelization in \pkg{Stan} via the \pkg{brms} -interface. Within-chain parallelization is experimental! We recommend its use -only if you are experienced with Stan's \code{reduce_sum} function and have a -slow running model that cannot be sped up by any other means. -} -\details{ -The adaptive scheduling procedure used by \code{reduce_sum} will - prevent the results to be exactly reproducible even if you set the random - seed. If you need exact reproducibility, you have to set argument - \code{static = TRUE} which may reduce efficiency a bit. - - To ensure that chunks (whose size is defined by \code{grainsize}) require - roughly the same amount of computing time, we recommend storing - observations in random order in the data. At least, please avoid sorting - observations after the response values. This is because the latter often - cause variations in the computing time of the pointwise log-likelihood, - which makes up a big part of the parallelized code. -} -\examples{ -\dontrun{ -# this model just serves as an illustration -# threading may not actually speed things up here -fit <- brm(count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = negbinomial(), - chains = 1, threads = threading(2, grainsize = 100), - backend = "cmdstanr") -summary(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/backends.R +\name{threading} +\alias{threading} +\title{Threading in Stan} +\usage{ +threading(threads = NULL, grainsize = NULL, static = FALSE) +} +\arguments{ +\item{threads}{Number of threads to use in within-chain parallelization.} + +\item{grainsize}{Number of observations evaluated together in one chunk on +one of the CPUs used for threading. If \code{NULL} (the default), +\code{grainsize} is currently chosen as \code{max(100, N / (2 * +threads))}, where \code{N} is the number of observations in the data. This +default is experimental and may change in the future without prior notice.} + +\item{static}{Logical. Apply the static (non-adaptive) version of +\code{reduce_sum}? Defaults to \code{FALSE}. Setting it to \code{TRUE} +is required to achieve exact reproducibility of the model results +(if the random seed is set as well).} +} +\value{ +A \code{brmsthreads} object which can be passed to the + \code{threads} argument of \code{brm} and related functions. +} +\description{ +Use threads for within-chain parallelization in \pkg{Stan} via the \pkg{brms} +interface. Within-chain parallelization is experimental! We recommend its use +only if you are experienced with Stan's \code{reduce_sum} function and have a +slow running model that cannot be sped up by any other means. +} +\details{ +The adaptive scheduling procedure used by \code{reduce_sum} will + prevent the results to be exactly reproducible even if you set the random + seed. If you need exact reproducibility, you have to set argument + \code{static = TRUE} which may reduce efficiency a bit. + + To ensure that chunks (whose size is defined by \code{grainsize}) require + roughly the same amount of computing time, we recommend storing + observations in random order in the data. At least, please avoid sorting + observations after the response values. This is because the latter often + cause variations in the computing time of the pointwise log-likelihood, + which makes up a big part of the parallelized code. +} +\examples{ +\dontrun{ +# this model just serves as an illustration +# threading may not actually speed things up here +fit <- brm(count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = negbinomial(), + chains = 1, threads = threading(2, grainsize = 100), + backend = "cmdstanr") +summary(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/update.brmsfit_multiple.Rd r-cran-brms-2.17.0/man/update.brmsfit_multiple.Rd --- r-cran-brms-2.16.3/man/update.brmsfit_multiple.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/update.brmsfit_multiple.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,38 +1,38 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/update.R -\name{update.brmsfit_multiple} -\alias{update.brmsfit_multiple} -\title{Update \pkg{brms} models based on multiple data sets} -\usage{ -\method{update}{brmsfit_multiple}(object, formula., newdata = NULL, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit_multiple}.} - -\item{formula.}{Changes to the formula; for details see -\code{\link{update.formula}} and \code{\link{brmsformula}}.} - -\item{newdata}{List of \code{data.frames} to update the model with new data. -Currently required even if the original data should be used.} - -\item{...}{Other arguments passed to \code{\link{update.brmsfit}} -and \code{\link{brm_multiple}}.} -} -\description{ -This method allows to update an existing \code{brmsfit_multiple} object. -} -\examples{ -\dontrun{ -library(mice) -imp <- mice(nhanes2) - -# initially fit the model -fit_imp1 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) -summary(fit_imp1) - -# update the model using fewer predictors -fit_imp2 <- update(fit_imp1, formula. = . ~ hyp + chl, newdata = imp) -summary(fit_imp2) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/update.R +\name{update.brmsfit_multiple} +\alias{update.brmsfit_multiple} +\title{Update \pkg{brms} models based on multiple data sets} +\usage{ +\method{update}{brmsfit_multiple}(object, formula., newdata = NULL, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit_multiple}.} + +\item{formula.}{Changes to the formula; for details see +\code{\link{update.formula}} and \code{\link{brmsformula}}.} + +\item{newdata}{List of \code{data.frames} to update the model with new data. +Currently required even if the original data should be used.} + +\item{...}{Other arguments passed to \code{\link{update.brmsfit}} +and \code{\link{brm_multiple}}.} +} +\description{ +This method allows to update an existing \code{brmsfit_multiple} object. +} +\examples{ +\dontrun{ +library(mice) +imp <- mice(nhanes2) + +# initially fit the model +fit_imp1 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) +summary(fit_imp1) + +# update the model using fewer predictors +fit_imp2 <- update(fit_imp1, formula. = . ~ hyp + chl, newdata = imp) +summary(fit_imp2) +} + +} diff -Nru r-cran-brms-2.16.3/man/update.brmsfit.Rd r-cran-brms-2.17.0/man/update.brmsfit.Rd --- r-cran-brms-2.16.3/man/update.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/update.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,51 +1,51 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/update.R -\name{update.brmsfit} -\alias{update.brmsfit} -\title{Update \pkg{brms} models} -\usage{ -\method{update}{brmsfit}(object, formula., newdata = NULL, recompile = NULL, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{formula.}{Changes to the formula; for details see -\code{\link{update.formula}} and \code{\link{brmsformula}}.} - -\item{newdata}{Optional \code{data.frame} to update the model with new data. -Data-dependent default priors will not be updated automatically.} - -\item{recompile}{Logical, indicating whether the Stan model should -be recompiled. If \code{NULL} (the default), \code{update} tries -to figure out internally, if recompilation is necessary. -Setting it to \code{FALSE} will cause all Stan code changing -arguments to be ignored.} - -\item{...}{Other arguments passed to \code{\link{brm}}.} -} -\description{ -This method allows to update an existing \code{brmsfit} object. -} -\examples{ -\dontrun{ -fit1 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), - data = kidney, family = gaussian("log")) -summary(fit1) - -## remove effects of 'disease' -fit2 <- update(fit1, formula. = ~ . - disease) -summary(fit2) - -## remove the group specific term of 'patient' and -## change the data (just take a subset in this example) -fit3 <- update(fit1, formula. = ~ . - (1|patient), - newdata = kidney[1:38, ]) -summary(fit3) - -## use another family and add population-level priors -fit4 <- update(fit1, family = weibull(), inits = "0", - prior = set_prior("normal(0,5)")) -summary(fit4) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/update.R +\name{update.brmsfit} +\alias{update.brmsfit} +\title{Update \pkg{brms} models} +\usage{ +\method{update}{brmsfit}(object, formula., newdata = NULL, recompile = NULL, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{formula.}{Changes to the formula; for details see +\code{\link{update.formula}} and \code{\link{brmsformula}}.} + +\item{newdata}{Optional \code{data.frame} to update the model with new data. +Data-dependent default priors will not be updated automatically.} + +\item{recompile}{Logical, indicating whether the Stan model should +be recompiled. If \code{NULL} (the default), \code{update} tries +to figure out internally, if recompilation is necessary. +Setting it to \code{FALSE} will cause all Stan code changing +arguments to be ignored.} + +\item{...}{Other arguments passed to \code{\link{brm}}.} +} +\description{ +This method allows to update an existing \code{brmsfit} object. +} +\examples{ +\dontrun{ +fit1 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), + data = kidney, family = gaussian("log")) +summary(fit1) + +## remove effects of 'disease' +fit2 <- update(fit1, formula. = ~ . - disease) +summary(fit2) + +## remove the group specific term of 'patient' and +## change the data (just take a subset in this example) +fit3 <- update(fit1, formula. = ~ . - (1|patient), + newdata = kidney[1:38, ]) +summary(fit3) + +## use another family and add population-level priors +fit4 <- update(fit1, family = weibull(), init = "0", + prior = set_prior("normal(0,5)")) +summary(fit4) +} + +} diff -Nru r-cran-brms-2.16.3/man/validate_newdata.Rd r-cran-brms-2.17.0/man/validate_newdata.Rd --- r-cran-brms-2.16.3/man/validate_newdata.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/validate_newdata.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,64 +1,64 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data-helpers.R -\name{validate_newdata} -\alias{validate_newdata} -\title{Validate New Data} -\usage{ -validate_newdata( - newdata, - object, - re_formula = NULL, - allow_new_levels = FALSE, - newdata2 = NULL, - resp = NULL, - check_response = TRUE, - incl_autocor = TRUE, - group_vars = NULL, - req_vars = NULL, - ... -) -} -\arguments{ -\item{newdata}{A \code{data.frame} containing new data to be validated.} - -\item{object}{A \code{brmsfit} object.} - -\item{re_formula}{formula containing group-level effects to be considered in -the prediction. If \code{NULL} (default), include all group-level effects; -if \code{NA}, include no group-level effects.} - -\item{allow_new_levels}{A flag indicating if new levels of group-level -effects are allowed (defaults to \code{FALSE}). Only relevant if -\code{newdata} is provided.} - -\item{newdata2}{A named \code{list} of objects containing new data, which -cannot be passed via argument \code{newdata}. Required for some objects -used in autocorrelation structures, or \code{\link{stanvars}}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{check_response}{Logical; Indicates if response variables should -be checked as well. Defaults to \code{TRUE}.} - -\item{incl_autocor}{A flag indicating if correlation structures originally -specified via \code{autocor} should be included in the predictions. -Defaults to \code{TRUE}.} - -\item{group_vars}{Optional names of grouping variables to be validated. -Defaults to all grouping variables in the model.} - -\item{req_vars}{Optional names of variables required in \code{newdata}. -If \code{NULL} (the default), all variables in the original data -are required (unless ignored for some other reason).} - -\item{...}{Currently ignored.} -} -\value{ -A validated \code{'data.frame'} based on \code{newdata}. -} -\description{ -Validate new data passed to post-processing methods of \pkg{brms}. Unless you -are a package developer, you will rarely need to call \code{validate_newdata} -directly. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data-helpers.R +\name{validate_newdata} +\alias{validate_newdata} +\title{Validate New Data} +\usage{ +validate_newdata( + newdata, + object, + re_formula = NULL, + allow_new_levels = FALSE, + newdata2 = NULL, + resp = NULL, + check_response = TRUE, + incl_autocor = TRUE, + group_vars = NULL, + req_vars = NULL, + ... +) +} +\arguments{ +\item{newdata}{A \code{data.frame} containing new data to be validated.} + +\item{object}{A \code{brmsfit} object.} + +\item{re_formula}{formula containing group-level effects to be considered in +the prediction. If \code{NULL} (default), include all group-level effects; +if \code{NA}, include no group-level effects.} + +\item{allow_new_levels}{A flag indicating if new levels of group-level +effects are allowed (defaults to \code{FALSE}). Only relevant if +\code{newdata} is provided.} + +\item{newdata2}{A named \code{list} of objects containing new data, which +cannot be passed via argument \code{newdata}. Required for some objects +used in autocorrelation structures, or \code{\link{stanvars}}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{check_response}{Logical; Indicates if response variables should +be checked as well. Defaults to \code{TRUE}.} + +\item{incl_autocor}{A flag indicating if correlation structures originally +specified via \code{autocor} should be included in the predictions. +Defaults to \code{TRUE}.} + +\item{group_vars}{Optional names of grouping variables to be validated. +Defaults to all grouping variables in the model.} + +\item{req_vars}{Optional names of variables required in \code{newdata}. +If \code{NULL} (the default), all variables in the original data +are required (unless ignored for some other reason).} + +\item{...}{Currently ignored.} +} +\value{ +A validated \code{'data.frame'} based on \code{newdata}. +} +\description{ +Validate new data passed to post-processing methods of \pkg{brms}. Unless you +are a package developer, you will rarely need to call \code{validate_newdata} +directly. +} diff -Nru r-cran-brms-2.16.3/man/validate_prior.Rd r-cran-brms-2.17.0/man/validate_prior.Rd --- r-cran-brms-2.16.3/man/validate_prior.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/validate_prior.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,83 +1,83 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/priors.R -\name{validate_prior} -\alias{validate_prior} -\title{Validate Prior for \pkg{brms} Models} -\usage{ -validate_prior( - prior, - formula, - data, - family = gaussian(), - sample_prior = "no", - data2 = NULL, - knots = NULL, - ... -) -} -\arguments{ -\item{prior}{One or more \code{brmsprior} objects created by -\code{\link{set_prior}} or related functions and combined using the -\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} -for more help.} - -\item{formula}{An object of class \code{\link[stats:formula]{formula}}, -\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can -be coerced to that classes): A symbolic description of the model to be -fitted. The details of model specification are explained in -\code{\link{brmsformula}}.} - -\item{data}{An object of class \code{data.frame} (or one that can be coerced -to that class) containing data of all variables used in the model.} - -\item{family}{A description of the response distribution and link function to -be used in the model. This can be a family function, a call to a family -function or a character string naming the family. Every family function has -a \code{link} argument allowing to specify the link function to be applied -on the response variable. If not specified, default links are used. For -details of supported families see \code{\link{brmsfamily}}. By default, a -linear \code{gaussian} model is applied. In multivariate models, -\code{family} might also be a list of families.} - -\item{sample_prior}{Indicate if draws from priors should be drawn -additionally to the posterior draws. Options are \code{"no"} (the -default), \code{"yes"}, and \code{"only"}. Among others, these draws can -be used to calculate Bayes factors for point hypotheses via -\code{\link{hypothesis}}. Please note that improper priors are not sampled, -including the default improper priors used by \code{brm}. See -\code{\link{set_prior}} on how to set (proper) priors. Please also note -that prior draws for the overall intercept are not obtained by default -for technical reasons. See \code{\link{brmsformula}} how to obtain prior -draws for the intercept. If \code{sample_prior} is set to \code{"only"}, -draws are drawn solely from the priors ignoring the likelihood, which -allows among others to generate draws from the prior predictive -distribution. In this case, all parameters must have proper priors.} - -\item{data2}{A named \code{list} of objects containing data, which -cannot be passed via argument \code{data}. Required for some objects -used in autocorrelation structures to specify dependency structures -as well as for within-group covariance matrices.} - -\item{knots}{Optional list containing user specified knot values to be used -for basis construction of smoothing terms. See -\code{\link[mgcv:gamm]{gamm}} for more details.} - -\item{...}{Other arguments for internal usage only.} -} -\value{ -An object of class \code{brmsprior}. -} -\description{ -Validate priors supplied by the user. Return a complete -set of priors for the given model, including default priors. -} -\examples{ -prior1 <- prior(normal(0,10), class = b) + - prior(cauchy(0,2), class = sd) -validate_prior(prior1, count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson()) - -} -\seealso{ -\code{\link{get_prior}}, \code{\link{set_prior}}. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/priors.R +\name{validate_prior} +\alias{validate_prior} +\title{Validate Prior for \pkg{brms} Models} +\usage{ +validate_prior( + prior, + formula, + data, + family = gaussian(), + sample_prior = "no", + data2 = NULL, + knots = NULL, + ... +) +} +\arguments{ +\item{prior}{One or more \code{brmsprior} objects created by +\code{\link{set_prior}} or related functions and combined using the +\code{c} method or the \code{+} operator. See also \code{\link{get_prior}} +for more help.} + +\item{formula}{An object of class \code{\link[stats:formula]{formula}}, +\code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can +be coerced to that classes): A symbolic description of the model to be +fitted. The details of model specification are explained in +\code{\link{brmsformula}}.} + +\item{data}{An object of class \code{data.frame} (or one that can be coerced +to that class) containing data of all variables used in the model.} + +\item{family}{A description of the response distribution and link function to +be used in the model. This can be a family function, a call to a family +function or a character string naming the family. Every family function has +a \code{link} argument allowing to specify the link function to be applied +on the response variable. If not specified, default links are used. For +details of supported families see \code{\link{brmsfamily}}. By default, a +linear \code{gaussian} model is applied. In multivariate models, +\code{family} might also be a list of families.} + +\item{sample_prior}{Indicate if draws from priors should be drawn +additionally to the posterior draws. Options are \code{"no"} (the +default), \code{"yes"}, and \code{"only"}. Among others, these draws can +be used to calculate Bayes factors for point hypotheses via +\code{\link{hypothesis}}. Please note that improper priors are not sampled, +including the default improper priors used by \code{brm}. See +\code{\link{set_prior}} on how to set (proper) priors. Please also note +that prior draws for the overall intercept are not obtained by default +for technical reasons. See \code{\link{brmsformula}} how to obtain prior +draws for the intercept. If \code{sample_prior} is set to \code{"only"}, +draws are drawn solely from the priors ignoring the likelihood, which +allows among others to generate draws from the prior predictive +distribution. In this case, all parameters must have proper priors.} + +\item{data2}{A named \code{list} of objects containing data, which +cannot be passed via argument \code{data}. Required for some objects +used in autocorrelation structures to specify dependency structures +as well as for within-group covariance matrices.} + +\item{knots}{Optional list containing user specified knot values to be used +for basis construction of smoothing terms. See +\code{\link[mgcv:gamm]{gamm}} for more details.} + +\item{...}{Other arguments for internal usage only.} +} +\value{ +An object of class \code{brmsprior}. +} +\description{ +Validate priors supplied by the user. Return a complete +set of priors for the given model, including default priors. +} +\examples{ +prior1 <- prior(normal(0,10), class = b) + + prior(cauchy(0,2), class = sd) +validate_prior(prior1, count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson()) + +} +\seealso{ +\code{\link{get_prior}}, \code{\link{set_prior}}. +} diff -Nru r-cran-brms-2.16.3/man/VarCorr.brmsfit.Rd r-cran-brms-2.17.0/man/VarCorr.brmsfit.Rd --- r-cran-brms-2.16.3/man/VarCorr.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/VarCorr.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,57 +1,57 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{VarCorr.brmsfit} -\alias{VarCorr.brmsfit} -\alias{VarCorr} -\title{Extract Variance and Correlation Components} -\usage{ -\method{VarCorr}{brmsfit}( - x, - sigma = 1, - summary = TRUE, - robust = FALSE, - probs = c(0.025, 0.975), - ... -) -} -\arguments{ -\item{x}{An object of class \code{brmsfit}.} - -\item{sigma}{Ignored (included for compatibility with -\code{\link[nlme:VarCorr]{VarCorr}}).} - -\item{summary}{Should summary statistics be returned -instead of the raw values? Default is \code{TRUE}.} - -\item{robust}{If \code{FALSE} (the default) the mean is used as -the measure of central tendency and the standard deviation as -the measure of variability. If \code{TRUE}, the median and the -median absolute deviation (MAD) are applied instead. -Only used if \code{summary} is \code{TRUE}.} - -\item{probs}{The percentiles to be computed by the \code{quantile} -function. Only used if \code{summary} is \code{TRUE}.} - -\item{...}{Currently ignored.} -} -\value{ -A list of lists (one per grouping factor), each with -three elements: a matrix containing the standard deviations, -an array containing the correlation matrix, and an array -containing the covariance matrix with variances on the diagonal. -} -\description{ -This function calculates the estimated standard deviations, -correlations and covariances of the group-level terms -in a multilevel model of class \code{brmsfit}. -For linear models, the residual standard deviations, -correlations and covariances are also returned. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), - data = epilepsy, family = gaussian(), chains = 2) -VarCorr(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{VarCorr.brmsfit} +\alias{VarCorr.brmsfit} +\alias{VarCorr} +\title{Extract Variance and Correlation Components} +\usage{ +\method{VarCorr}{brmsfit}( + x, + sigma = 1, + summary = TRUE, + robust = FALSE, + probs = c(0.025, 0.975), + ... +) +} +\arguments{ +\item{x}{An object of class \code{brmsfit}.} + +\item{sigma}{Ignored (included for compatibility with +\code{\link[nlme:VarCorr]{VarCorr}}).} + +\item{summary}{Should summary statistics be returned +instead of the raw values? Default is \code{TRUE}.} + +\item{robust}{If \code{FALSE} (the default) the mean is used as +the measure of central tendency and the standard deviation as +the measure of variability. If \code{TRUE}, the median and the +median absolute deviation (MAD) are applied instead. +Only used if \code{summary} is \code{TRUE}.} + +\item{probs}{The percentiles to be computed by the \code{quantile} +function. Only used if \code{summary} is \code{TRUE}.} + +\item{...}{Currently ignored.} +} +\value{ +A list of lists (one per grouping factor), each with +three elements: a matrix containing the standard deviations, +an array containing the correlation matrix, and an array +containing the covariance matrix with variances on the diagonal. +} +\description{ +This function calculates the estimated standard deviations, +correlations and covariances of the group-level terms +in a multilevel model of class \code{brmsfit}. +For linear models, the residual standard deviations, +correlations and covariances are also returned. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), + data = epilepsy, family = gaussian(), chains = 2) +VarCorr(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/vcov.brmsfit.Rd r-cran-brms-2.17.0/man/vcov.brmsfit.Rd --- r-cran-brms-2.16.3/man/vcov.brmsfit.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/vcov.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,38 +1,38 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/brmsfit-methods.R -\name{vcov.brmsfit} -\alias{vcov.brmsfit} -\title{Covariance and Correlation Matrix of Population-Level Effects} -\usage{ -\method{vcov}{brmsfit}(object, correlation = FALSE, pars = NULL, ...) -} -\arguments{ -\item{object}{An object of class \code{brmsfit}.} - -\item{correlation}{Logical; if \code{FALSE} (the default), compute -the covariance matrix, if \code{TRUE}, compute the correlation matrix.} - -\item{pars}{Optional names of coefficients to extract. -By default, all coefficients are extracted.} - -\item{...}{Currently ignored.} -} -\value{ -covariance or correlation matrix of population-level parameters -} -\description{ -Get a point estimate of the covariance or -correlation matrix of population-level parameters -} -\details{ -Estimates are obtained by calculating the maximum likelihood - covariances (correlations) of the posterior draws. -} -\examples{ -\dontrun{ -fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), - data = epilepsy, family = gaussian(), chains = 2) -vcov(fit) -} - -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brmsfit-methods.R +\name{vcov.brmsfit} +\alias{vcov.brmsfit} +\title{Covariance and Correlation Matrix of Population-Level Effects} +\usage{ +\method{vcov}{brmsfit}(object, correlation = FALSE, pars = NULL, ...) +} +\arguments{ +\item{object}{An object of class \code{brmsfit}.} + +\item{correlation}{Logical; if \code{FALSE} (the default), compute +the covariance matrix, if \code{TRUE}, compute the correlation matrix.} + +\item{pars}{Optional names of coefficients to extract. +By default, all coefficients are extracted.} + +\item{...}{Currently ignored.} +} +\value{ +covariance or correlation matrix of population-level parameters +} +\description{ +Get a point estimate of the covariance or +correlation matrix of population-level parameters +} +\details{ +Estimates are obtained by calculating the maximum likelihood + covariances (correlations) of the posterior draws. +} +\examples{ +\dontrun{ +fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), + data = epilepsy, family = gaussian(), chains = 2) +vcov(fit) +} + +} diff -Nru r-cran-brms-2.16.3/man/VonMises.Rd r-cran-brms-2.17.0/man/VonMises.Rd --- r-cran-brms-2.16.3/man/VonMises.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/VonMises.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,41 +1,41 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{VonMises} -\alias{VonMises} -\alias{dvon_mises} -\alias{pvon_mises} -\alias{rvon_mises} -\title{The von Mises Distribution} -\usage{ -dvon_mises(x, mu, kappa, log = FALSE) - -pvon_mises(q, mu, kappa, lower.tail = TRUE, log.p = FALSE, acc = 1e-20) - -rvon_mises(n, mu, kappa) -} -\arguments{ -\item{x, q}{Vector of quantiles.} - -\item{mu}{Vector of location values.} - -\item{kappa}{Vector of precision values.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{acc}{Accuracy of numerical approximations.} - -\item{n}{Number of draws to sample from the distribution.} -} -\description{ -Density, distribution function, and random generation for the -von Mises distribution with location \code{mu}, and precision \code{kappa}. -} -\details{ -See \code{vignette("brms_families")} for details -on the parameterization. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{VonMises} +\alias{VonMises} +\alias{dvon_mises} +\alias{pvon_mises} +\alias{rvon_mises} +\title{The von Mises Distribution} +\usage{ +dvon_mises(x, mu, kappa, log = FALSE) + +pvon_mises(q, mu, kappa, lower.tail = TRUE, log.p = FALSE, acc = 1e-20) + +rvon_mises(n, mu, kappa) +} +\arguments{ +\item{x, q}{Vector of quantiles.} + +\item{mu}{Vector of location values.} + +\item{kappa}{Vector of precision values.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{acc}{Accuracy of numerical approximations.} + +\item{n}{Number of draws to sample from the distribution.} +} +\description{ +Density, distribution function, and random generation for the +von Mises distribution with location \code{mu}, and precision \code{kappa}. +} +\details{ +See \code{vignette("brms_families")} for details +on the parameterization. +} diff -Nru r-cran-brms-2.16.3/man/waic.brmsfit.Rd r-cran-brms-2.17.0/man/waic.brmsfit.Rd --- r-cran-brms-2.16.3/man/waic.brmsfit.Rd 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/man/waic.brmsfit.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,88 +1,88 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/loo.R -\name{waic.brmsfit} -\alias{waic.brmsfit} -\alias{waic} -\alias{WAIC} -\alias{WAIC.brmsfit} -\title{Widely Applicable Information Criterion (WAIC)} -\usage{ -\method{waic}{brmsfit}( - x, - ..., - compare = TRUE, - resp = NULL, - pointwise = FALSE, - model_names = NULL -) -} -\arguments{ -\item{x}{A \code{brmsfit} object.} - -\item{...}{More \code{brmsfit} objects or further arguments -passed to the underlying post-processing functions. -In particular, see \code{\link{prepare_predictions}} for further -supported arguments.} - -\item{compare}{A flag indicating if the information criteria -of the models should be compared to each other -via \code{\link{loo_compare}}.} - -\item{resp}{Optional names of response variables. If specified, predictions -are performed only for the specified response variables.} - -\item{pointwise}{A flag indicating whether to compute the full -log-likelihood matrix at once or separately for each observation. -The latter approach is usually considerably slower but -requires much less working memory. Accordingly, if one runs -into memory issues, \code{pointwise = TRUE} is the way to go.} - -\item{model_names}{If \code{NULL} (the default) will use model names -derived from deparsing the call. Otherwise will use the passed -values as model names.} -} -\value{ -If just one object is provided, an object of class \code{loo}. - If multiple objects are provided, an object of class \code{loolist}. -} -\description{ -Compute the widely applicable information criterion (WAIC) -based on the posterior likelihood using the \pkg{loo} package. -For more details see \code{\link[loo:waic]{waic}}. -} -\details{ -See \code{\link{loo_compare}} for details on model comparisons. - For \code{brmsfit} objects, \code{WAIC} is an alias of \code{waic}. - Use method \code{\link[brms:add_criterion]{add_criterion}} to store - information criteria in the fitted model object for later usage. -} -\examples{ -\dontrun{ -# model with population-level effects only -fit1 <- brm(rating ~ treat + period + carry, - data = inhaler) -(waic1 <- waic(fit1)) - -# model with an additional varying intercept for subjects -fit2 <- brm(rating ~ treat + period + carry + (1|subject), - data = inhaler) -(waic2 <- waic(fit2)) - -# compare both models -loo_compare(waic1, waic2) -} - -} -\references{ -Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model -evaluation using leave-one-out cross-validation and WAIC. In Statistics -and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. - -Gelman, A., Hwang, J., & Vehtari, A. (2014). -Understanding predictive information criteria for Bayesian models. -Statistics and Computing, 24, 997-1016. - -Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation -and widely applicable information criterion in singular learning theory. -The Journal of Machine Learning Research, 11, 3571-3594. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/loo.R +\name{waic.brmsfit} +\alias{waic.brmsfit} +\alias{waic} +\alias{WAIC} +\alias{WAIC.brmsfit} +\title{Widely Applicable Information Criterion (WAIC)} +\usage{ +\method{waic}{brmsfit}( + x, + ..., + compare = TRUE, + resp = NULL, + pointwise = FALSE, + model_names = NULL +) +} +\arguments{ +\item{x}{A \code{brmsfit} object.} + +\item{...}{More \code{brmsfit} objects or further arguments +passed to the underlying post-processing functions. +In particular, see \code{\link{prepare_predictions}} for further +supported arguments.} + +\item{compare}{A flag indicating if the information criteria +of the models should be compared to each other +via \code{\link{loo_compare}}.} + +\item{resp}{Optional names of response variables. If specified, predictions +are performed only for the specified response variables.} + +\item{pointwise}{A flag indicating whether to compute the full +log-likelihood matrix at once or separately for each observation. +The latter approach is usually considerably slower but +requires much less working memory. Accordingly, if one runs +into memory issues, \code{pointwise = TRUE} is the way to go.} + +\item{model_names}{If \code{NULL} (the default) will use model names +derived from deparsing the call. Otherwise will use the passed +values as model names.} +} +\value{ +If just one object is provided, an object of class \code{loo}. + If multiple objects are provided, an object of class \code{loolist}. +} +\description{ +Compute the widely applicable information criterion (WAIC) +based on the posterior likelihood using the \pkg{loo} package. +For more details see \code{\link[loo:waic]{waic}}. +} +\details{ +See \code{\link{loo_compare}} for details on model comparisons. + For \code{brmsfit} objects, \code{WAIC} is an alias of \code{waic}. + Use method \code{\link[brms:add_criterion]{add_criterion}} to store + information criteria in the fitted model object for later usage. +} +\examples{ +\dontrun{ +# model with population-level effects only +fit1 <- brm(rating ~ treat + period + carry, + data = inhaler) +(waic1 <- waic(fit1)) + +# model with an additional varying intercept for subjects +fit2 <- brm(rating ~ treat + period + carry + (1|subject), + data = inhaler) +(waic2 <- waic(fit2)) + +# compare both models +loo_compare(waic1, waic2) +} + +} +\references{ +Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model +evaluation using leave-one-out cross-validation and WAIC. In Statistics +and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. + +Gelman, A., Hwang, J., & Vehtari, A. (2014). +Understanding predictive information criteria for Bayesian models. +Statistics and Computing, 24, 997-1016. + +Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation +and widely applicable information criterion in singular learning theory. +The Journal of Machine Learning Research, 11, 3571-3594. +} diff -Nru r-cran-brms-2.16.3/man/Wiener.Rd r-cran-brms-2.17.0/man/Wiener.Rd --- r-cran-brms-2.16.3/man/Wiener.Rd 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/Wiener.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,74 +1,74 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{Wiener} -\alias{Wiener} -\alias{dwiener} -\alias{rwiener} -\title{The Wiener Diffusion Model Distribution} -\usage{ -dwiener( - x, - alpha, - tau, - beta, - delta, - resp = 1, - log = FALSE, - backend = getOption("wiener_backend", "Rwiener") -) - -rwiener( - n, - alpha, - tau, - beta, - delta, - types = c("q", "resp"), - backend = getOption("wiener_backend", "Rwiener") -) -} -\arguments{ -\item{x}{Vector of quantiles.} - -\item{alpha}{Boundary separation parameter.} - -\item{tau}{Non-decision time parameter.} - -\item{beta}{Bias parameter.} - -\item{delta}{Drift rate parameter.} - -\item{resp}{Response: \code{"upper"} or \code{"lower"}. -If no character vector, it is coerced to logical -where \code{TRUE} indicates \code{"upper"} and -\code{FALSE} indicates \code{"lower"}.} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{backend}{Name of the package to use as backend for the computations. -Either \code{"Rwiener"} (the default) or \code{"rtdists"}. -Can be set globally for the current \R session via the -\code{"wiener_backend"} option (see \code{\link{options}}).} - -\item{n}{Number of draws to sample from the distribution.} - -\item{types}{Which types of responses to return? By default, -return both the response times \code{"q"} and the dichotomous -responses \code{"resp"}. If either \code{"q"} or \code{"resp"}, -return only one of the two types.} -} -\description{ -Density function and random generation for the Wiener -diffusion model distribution with boundary separation \code{alpha}, -non-decision time \code{tau}, bias \code{beta} and -drift rate \code{delta}. -} -\details{ -These are wrappers around functions of the \pkg{RWiener} or \pkg{rtdists} -package (depending on the chosen \code{backend}). See -\code{vignette("brms_families")} for details on the parameterization. -} -\seealso{ -\code{\link[RWiener:wienerdist]{wienerdist}}, - \code{\link[rtdists:Diffusion]{Diffusion}} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{Wiener} +\alias{Wiener} +\alias{dwiener} +\alias{rwiener} +\title{The Wiener Diffusion Model Distribution} +\usage{ +dwiener( + x, + alpha, + tau, + beta, + delta, + resp = 1, + log = FALSE, + backend = getOption("wiener_backend", "Rwiener") +) + +rwiener( + n, + alpha, + tau, + beta, + delta, + types = c("q", "resp"), + backend = getOption("wiener_backend", "Rwiener") +) +} +\arguments{ +\item{x}{Vector of quantiles.} + +\item{alpha}{Boundary separation parameter.} + +\item{tau}{Non-decision time parameter.} + +\item{beta}{Bias parameter.} + +\item{delta}{Drift rate parameter.} + +\item{resp}{Response: \code{"upper"} or \code{"lower"}. +If no character vector, it is coerced to logical +where \code{TRUE} indicates \code{"upper"} and +\code{FALSE} indicates \code{"lower"}.} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{backend}{Name of the package to use as backend for the computations. +Either \code{"Rwiener"} (the default) or \code{"rtdists"}. +Can be set globally for the current \R session via the +\code{"wiener_backend"} option (see \code{\link{options}}).} + +\item{n}{Number of draws to sample from the distribution.} + +\item{types}{Which types of responses to return? By default, +return both the response times \code{"q"} and the dichotomous +responses \code{"resp"}. If either \code{"q"} or \code{"resp"}, +return only one of the two types.} +} +\description{ +Density function and random generation for the Wiener +diffusion model distribution with boundary separation \code{alpha}, +non-decision time \code{tau}, bias \code{beta} and +drift rate \code{delta}. +} +\details{ +These are wrappers around functions of the \pkg{RWiener} or \pkg{rtdists} +package (depending on the chosen \code{backend}). See +\code{vignette("brms_families")} for details on the parameterization. +} +\seealso{ +\code{\link[RWiener:wienerdist]{wienerdist}}, + \code{\link[rtdists:Diffusion]{Diffusion}} +} diff -Nru r-cran-brms-2.16.3/man/ZeroInflated.Rd r-cran-brms-2.17.0/man/ZeroInflated.Rd --- r-cran-brms-2.16.3/man/ZeroInflated.Rd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/man/ZeroInflated.Rd 2022-03-13 16:10:29.000000000 +0000 @@ -1,61 +1,77 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/distributions.R -\name{ZeroInflated} -\alias{ZeroInflated} -\alias{dzero_inflated_poisson} -\alias{pzero_inflated_poisson} -\alias{dzero_inflated_negbinomial} -\alias{pzero_inflated_negbinomial} -\alias{dzero_inflated_binomial} -\alias{pzero_inflated_binomial} -\alias{dzero_inflated_beta} -\alias{pzero_inflated_beta} -\title{Zero-Inflated Distributions} -\usage{ -dzero_inflated_poisson(x, lambda, zi, log = FALSE) - -pzero_inflated_poisson(q, lambda, zi, lower.tail = TRUE, log.p = FALSE) - -dzero_inflated_negbinomial(x, mu, shape, zi, log = FALSE) - -pzero_inflated_negbinomial(q, mu, shape, zi, lower.tail = TRUE, log.p = FALSE) - -dzero_inflated_binomial(x, size, prob, zi, log = FALSE) - -pzero_inflated_binomial(q, size, prob, zi, lower.tail = TRUE, log.p = FALSE) - -dzero_inflated_beta(x, shape1, shape2, zi, log = FALSE) - -pzero_inflated_beta(q, shape1, shape2, zi, lower.tail = TRUE, log.p = FALSE) -} -\arguments{ -\item{x}{Vector of quantiles.} - -\item{zi}{zero-inflation probability} - -\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{q}{Vector of quantiles.} - -\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). -Else, return P(X > x) .} - -\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} - -\item{mu, lambda}{location parameter} - -\item{shape, shape1, shape2}{shape parameter} - -\item{size}{number of trials} - -\item{prob}{probability of success on each trial} -} -\description{ -Density and distribution functions for zero-inflated distributions. -} -\details{ -The density of a zero-inflated distribution can be specified as follows. -If \eqn{x = 0} set \eqn{f(x) = \theta + (1 - \theta) * g(0)}. -Else set \eqn{f(x) = (1 - \theta) * g(x)}, -where \eqn{g(x)} is the density of the non-zero-inflated part. -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/distributions.R +\name{ZeroInflated} +\alias{ZeroInflated} +\alias{dzero_inflated_poisson} +\alias{pzero_inflated_poisson} +\alias{dzero_inflated_negbinomial} +\alias{pzero_inflated_negbinomial} +\alias{dzero_inflated_binomial} +\alias{pzero_inflated_binomial} +\alias{dzero_inflated_beta_binomial} +\alias{pzero_inflated_beta_binomial} +\alias{dzero_inflated_beta} +\alias{pzero_inflated_beta} +\title{Zero-Inflated Distributions} +\usage{ +dzero_inflated_poisson(x, lambda, zi, log = FALSE) + +pzero_inflated_poisson(q, lambda, zi, lower.tail = TRUE, log.p = FALSE) + +dzero_inflated_negbinomial(x, mu, shape, zi, log = FALSE) + +pzero_inflated_negbinomial(q, mu, shape, zi, lower.tail = TRUE, log.p = FALSE) + +dzero_inflated_binomial(x, size, prob, zi, log = FALSE) + +pzero_inflated_binomial(q, size, prob, zi, lower.tail = TRUE, log.p = FALSE) + +dzero_inflated_beta_binomial(x, size, mu, phi, zi, log = FALSE) + +pzero_inflated_beta_binomial( + q, + size, + mu, + phi, + zi, + lower.tail = TRUE, + log.p = FALSE +) + +dzero_inflated_beta(x, shape1, shape2, zi, log = FALSE) + +pzero_inflated_beta(q, shape1, shape2, zi, lower.tail = TRUE, log.p = FALSE) +} +\arguments{ +\item{x}{Vector of quantiles.} + +\item{zi}{zero-inflation probability} + +\item{log}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{q}{Vector of quantiles.} + +\item{lower.tail}{Logical; If \code{TRUE} (default), return P(X <= x). +Else, return P(X > x) .} + +\item{log.p}{Logical; If \code{TRUE}, values are returned on the log scale.} + +\item{mu, lambda}{location parameter} + +\item{shape, shape1, shape2}{shape parameter} + +\item{size}{number of trials} + +\item{prob}{probability of success on each trial} + +\item{phi}{precision parameter} +} +\description{ +Density and distribution functions for zero-inflated distributions. +} +\details{ +The density of a zero-inflated distribution can be specified as follows. +If \eqn{x = 0} set \eqn{f(x) = \theta + (1 - \theta) * g(0)}. +Else set \eqn{f(x) = (1 - \theta) * g(x)}, +where \eqn{g(x)} is the density of the non-zero-inflated part. +} diff -Nru r-cran-brms-2.16.3/MD5 r-cran-brms-2.17.0/MD5 --- r-cran-brms-2.16.3/MD5 2021-11-22 19:50:03.000000000 +0000 +++ r-cran-brms-2.17.0/MD5 2022-04-13 14:22:30.000000000 +0000 @@ -1,390 +1,395 @@ -5c969426af9875ee475bc96c2887a586 *DESCRIPTION -4709d1b79105885f84d149ff841cdcdf *NAMESPACE -922748973edfac4d7ab212effe2ab25c *NEWS.md -8af5e09967f0cf14e129c54ef1137ffc *R/autocor.R -c1a4725c588857aa00de4614829a02e6 *R/backends.R -fe2835e8d799bd1a51acc794cda44eb8 *R/bayes_R2.R -887700e231273b32d73c20cd21525caa *R/bridgesampling.R -df20072e168e8ad07a436a8a0caff72b *R/brm.R -d25b63ab0fe1f9b34638c9333f2c8882 *R/brm_multiple.R -443af9129305de0abc18c66f7f2c3f1f *R/brms-package.R -1cd0eff10441ed72df42fa3d14a8b7a4 *R/brmsfit-class.R -d994b0b30bb91337de442c257aba9ebf *R/brmsfit-helpers.R -3d6f40ac34151ea66d3617c751c5bb33 *R/brmsfit-methods.R -15e091ee4ff4e61bddc719442fa94df8 *R/brmsformula.R -3844d3e49b702f7ba77cb2f96c709875 *R/brmsterms.R -56392048b072f9fe0dd2d9edb62d5dca *R/conditional_effects.R -dc7c9083b52f28739f24e1dfbb253921 *R/conditional_smooths.R -45eed8c948e4386c62599a212b9107d3 *R/data-helpers.R -38eaf45b65b06f720827f2e841190df4 *R/data-predictor.R -93049af0ef65cc6df0f8712faf61f4f5 *R/data-response.R -04040252b1f71fc2cd3d8909331fb8fd *R/datasets.R -bbfb5baa937e6916bf8cf82be845d936 *R/diagnostics.R -afd673de00a896fbca4210661d616f39 *R/distributions.R -7e2c859de2fb889755f69e8f2cc3d626 *R/emmeans.R -6c9a03b6ba571e97a00cf77ff81f5962 *R/exclude_pars.R -67b0efaf0e48fc8c40018e823fc03961 *R/exclude_terms.R -0ef268e21b98082fd1a2ac2b9d37d293 *R/families.R -95ba5aa8269b657d0bdaf70d74fdec3f *R/family-lists.R -981b978ffe0509ee04e7f5a7f21201f9 *R/formula-ac.R -ff9de2b88d52af63d7856713db638fd5 *R/formula-ad.R -bd1e7040e058ce10e3d7a502c7203806 *R/formula-cs.R -4d545c4e4f5375dff2ddb5a8715b0269 *R/formula-gp.R -0e809dfaa53ec872e4af2fef49c99b36 *R/formula-re.R -467070f2e384be47b60ad19b26ed68cf *R/formula-sm.R -859b86dd1993cd1824fa608eb547db78 *R/formula-sp.R -02956f98bd3683709f2324fd8d01398e *R/ggplot-themes.R -d9ac9900f47749aad22d7ef477e3e6bf *R/hypothesis.R -af0214db1d18ca24b9334746b0194567 *R/kfold.R -153863d26650a38b0d559144a4a5324b *R/launch_shinystan.R -d804a22bf8778c9c67b2c5bbaf8190d7 *R/log_lik.R -753a609b7b77523063ae0c7ca874ac3a *R/loo.R -2b4fbf14a35b94bf4468206f1754298e *R/loo_moment_match.R -0d7bcb1ca865e2e6801e2ba082d30092 *R/loo_predict.R -25320fc4efc4008cd76ef74e416b3a6b *R/loo_subsample.R -8945944acd49625df84706c36d74a846 *R/lsp.R -d4da3068f030d7280d148c3abac6b2df *R/make_stancode.R -be0a6c7dc80bfe2ba4d880aa4cf7c935 *R/make_standata.R -4b2c0dad0377adb197b7ae9af96ceec0 *R/misc.R -f80b3e799f356088092433edb15dcdf1 *R/model_weights.R -ed20b05ccd8bc2147053501d2aba781c *R/numeric-helpers.R -de9c5c1da682f72989398d15c412548b *R/plot.R -e16db33e5777be44ad40b12baff947eb *R/posterior.R -ffb8dd70704280747bdb20dd4aa569d0 *R/posterior_epred.R -0660e8a54c79add74d07c04851783b5a *R/posterior_predict.R -a7b3dc917dbe38cf28f1795fbfcf7543 *R/posterior_samples.R -4f42087dd88fd6a1ef05beec6e50cca6 *R/posterior_smooths.R -c3815284b5f7b543241963dc5382ed1d *R/pp_check.R -d8728e6fddbc38b7b70e63b8947998de *R/pp_mixture.R -34b1d3584c09d0dde449b5c0924022d3 *R/predictive_error.R -bcedc5ad9c57658cdc11a325436d0d93 *R/predictor.R -4f5f18cdff59095157dca16697028bfe *R/prepare_predictions.R -0635ab5e2d6ab26d5565d7281eeb28b6 *R/prior_draws.R -ca5f0307036c96ecb2ef154a3014013b *R/priors.R -ac45961c52b312ebaa6557cfa538e5c1 *R/projpred.R -d2c16068bc19ced0d8ed7ff9a3d6d76b *R/reloo.R -356ed74a0d24d6aef1e9fa232a1848f1 *R/rename_pars.R -f441583e81088c5922530b20294ed159 *R/restructure.R -e2660f0dd08c0d60a7385285273bdaac *R/stan-helpers.R -9c1ceb793ced5310110705719d08e52f *R/stan-likelihood.R -291eb5219f4c0d6d3e3d23bf2c093df9 *R/stan-predictor.R -58e14a2a071b96cdcbb56dabeb4510c1 *R/stan-prior.R -3f54060f452bb3981d96cf7197f2f7c2 *R/stan-response.R -bac24b8db1a16cdb3a37c5548124f55b *R/stanvars.R -6e1b6a618dbe79f04b5baf2fb3666f69 *R/summary.R +21fcba48436087ca7042df1d1f9f17d4 *DESCRIPTION +235602ca3f860316cea5d20bd300cafe *NAMESPACE +18896c8a578f1ba3f7151e57892785d1 *NEWS.md +d08ca9e5ded75a36fe87628d1266583e *R/autocor.R +239644b08c3751490c2522473791d822 *R/backends.R +a62648c0b2b854f598e93e5b0d7f54a1 *R/bayes_R2.R +d72c7cfb0d4061565113ee5422695161 *R/bridgesampling.R +7b0af7b036614e4c68083ed945292a49 *R/brm.R +e919c05585992a4b445bf25f665bfc00 *R/brm_multiple.R +4e51574efdc48fd8c1573048d8cb18b2 *R/brms-package.R +5d8b73fc5380f0899f0394696d14fecc *R/brmsfit-class.R +d2bd03bcdd068ab5cd74a3ef64df12b3 *R/brmsfit-helpers.R +23de75d1908d7f3c4f7ed08f5cc00c6f *R/brmsfit-methods.R +f8e581d63ccb9016cef3732f0745b081 *R/brmsformula.R +66c1edd9567ab7c18b95bec269d08ec2 *R/brmsterms.R +9cc4e94cf7f395e394ca5bc5f842dfe0 *R/conditional_effects.R +191afe28bfbaea0d95c8173b08aa5247 *R/conditional_smooths.R +75c2aa77a87fc12eeeff26f918dcd235 *R/data-helpers.R +6d0c4f528533e6f0be131c483cb03c9d *R/data-predictor.R +38f218193cb302db1f71dbdf20f9cfa2 *R/data-response.R +d79f47e77c3b11477953f636c7605647 *R/datasets.R +3a489ec351aab173a511b57fb84ebff5 *R/diagnostics.R +f86f34e50babce5da67ee53352e0af01 *R/distributions.R +44409fa6302bf02bca2d3fa33eccb30d *R/emmeans.R +9d4aa62152cb06f06a771fd2c9718e6f *R/exclude_pars.R +a8ef78dc95fc0a1275a3086c59dbe18a *R/exclude_terms.R +59189a581a0ed031ce17090e335bfea7 *R/families.R +7ac311402003a9b5aadeac0f93bd1d9b *R/family-lists.R +fbee7a3c80d9cda742a35cee3793dfe0 *R/formula-ac.R +136ffaa17ae16be2e4c67f09e529c4f0 *R/formula-ad.R +b9d10079aad0858ab9e5271763b22eac *R/formula-cs.R +1effb6fce2d910d5de9c9745c078cb83 *R/formula-gp.R +a4a6ea3ca14f86ac99f725dba656756f *R/formula-re.R +b2b56d7dfd937f8c88664e15e40bb268 *R/formula-sm.R +134a0d207aca944d4ebf6b8b03bc1dba *R/formula-sp.R +aefb99178ab21e8064b69728118f3ae8 *R/ggplot-themes.R +9c4c29901a5ee66974f9a70db2e58bf9 *R/hypothesis.R +95fca3961f729334b92f9fc9125c7123 *R/kfold.R +919680283ce369f76420b4888ca19f35 *R/launch_shinystan.R +2149bd05f772a69633c3842ec54da6c6 *R/log_lik.R +e0ecdd1c3db683a5eb88d1dcaa761f3a *R/loo.R +43ca39c0d4ffc8bb42a52c8c7bb81f9c *R/loo_moment_match.R +101ef84e65d885b4d43d3cbd2a75d9b5 *R/loo_predict.R +24a2aef03aa8af0815e352d452fe3228 *R/loo_subsample.R +1edbea17f83d0f074ab154a34d04d6d9 *R/lsp.R +5da85f0591bfa22653309522eb4ec62a *R/make_stancode.R +d86250f08eda9ba72f0f8504efbf2e3c *R/make_standata.R +55b31e372bdc2b23d7d552259b22d359 *R/misc.R +4b1b8ea8e0b0fef4c5e6c4de29ed93e5 *R/model_weights.R +9c0fd71ed616725cbf57b56b6053039c *R/numeric-helpers.R +f72f85360466ad39cc5a18dfa04f8f5c *R/plot.R +97742adeebaa219cd89fddb6539a73cf *R/posterior.R +037b96efd03389ffbd5ea075ae05d8d3 *R/posterior_epred.R +f02949ebbd41b9e0d1f4354a7fc82ba0 *R/posterior_predict.R +d440bca90ad433492cabc870135ea8cc *R/posterior_samples.R +3346bb6b9b80c3240ebb1539ada8b95c *R/posterior_smooths.R +b127515afdc1cefdf577738d8f8d12f1 *R/pp_check.R +472ea36ce557193d1c997ef4a1eba150 *R/pp_mixture.R +ae44ffe821934a85d8bd06e71b591fc7 *R/predictive_error.R +928b330deec496998bef615852f8118e *R/predictor.R +d85e67715919380807814f47c794aab2 *R/prepare_predictions.R +5aa300349b0a542bce1aff6d55f9929c *R/prior_draws.R +913cf98bb40e4c8790cc88c972c32e9c *R/priors.R +56688c1c7cb2312a03595557e329da74 *R/projpred.R +524126ea3979e781095c06473c76a9a3 *R/reloo.R +ab5284fc79d61f53b48c60e3211a7553 *R/rename_pars.R +272500ed9b39c9f1f77cc80e844ae450 *R/restructure.R +3d011764ae3eb4331b6d17fbf18342f5 *R/stan-helpers.R +658b8c42c47a679d026174d23b060379 *R/stan-likelihood.R +fe9821766cd6a6302434ce3b2bf3c335 *R/stan-predictor.R +c776ed79c3a4c1eec0425b476e651f42 *R/stan-prior.R +381c64403c791f4e72ae9a2d6dbb332b *R/stan-response.R +a7c59641c0ba0194003e8056202e577d *R/stanvars.R +fbf6014de5d2334d5bfd5c96a3b89993 *R/summary.R 420ccccb64e75da22aef6b0b737f3b77 *R/sysdata.rda -ad5de9a92ddf98afa31840b83235f8df *R/update.R +7b2e247106c7ad82b2c2fa7d3ef27d1c *R/update.R 72b4fff3d0529ec33b90921c73c8ba4c *R/zzz.R -462a82e116481b0c60abeae875d07b00 *README.md -a2d6d7d671d82883c552b8d07a2debd6 *build/vignette.rds +81403d76a31e2e5582ccc3e437be87f4 *README.md +2aa3c746dd085f228803a451f73f9aea *build/vignette.rds 29545093bb6edb0416e8ca2725949829 *data/epilepsy.rda d3e1729f040540ec7d640ce9d9e1c7c4 *data/inhaler.rda b491f9e27065b6a30dfaa06835d4058f *data/kidney.rda 1012588a05c5b7e59dfb16bc57adcf85 *data/loss.rda -fb8d31f81acfe1fe17f4b1f58461c77b *inst/CITATION -a98064209d48d927ff8881552f449293 *inst/chunks/fun_asym_laplace.stan -a6d4286c602fa7c20fa9839153baa5d4 *inst/chunks/fun_cauchit.stan -cbde5d7aa82e8f54878e21345d41ed2d *inst/chunks/fun_cholesky_cor_ar1.stan -9b3afe0f8326b9630d14fa5bd738e024 *inst/chunks/fun_cholesky_cor_arma1.stan -4a1dfc8a30ac7db990381493f7d07e48 *inst/chunks/fun_cholesky_cor_cosy.stan -9235311a924a41a116c2b694f780dd1c *inst/chunks/fun_cholesky_cor_ma1.stan -63a090be16d81d49a84a508c92f9a6cf *inst/chunks/fun_cloglog.stan -f2649108c1c6e6f03cca829b885fd324 *inst/chunks/fun_com_poisson.stan -45fdfa66aabc3094a505d1e5489c0662 *inst/chunks/fun_cox.stan -4a34f3da7fc169ae7734f345be75b3b5 *inst/chunks/fun_dirichlet_logit.stan -ba8f1f8abeb08b6835af41427f66a2e4 *inst/chunks/fun_discrete_weibull.stan -edb318ed3e2e42fa3571dc9573c6ede5 *inst/chunks/fun_gaussian_process.stan -724df15202c238ff3399ebb746803589 *inst/chunks/fun_gaussian_process_approx.stan -5caee0b5d6ceea372fd0b1c88755ef15 *inst/chunks/fun_gen_extreme_value.stan -d497b9a6f52344c1740e7f935b088b43 *inst/chunks/fun_horseshoe.stan -e8ca4770184d9834b264efe4f6d05558 *inst/chunks/fun_hurdle_gamma.stan -a15d564f825cf56a1cd705479df440c2 *inst/chunks/fun_hurdle_lognormal.stan -bf86eb93141cd8ced1e5f6d6a0a299d5 *inst/chunks/fun_hurdle_negbinomial.stan -3323605321012af39364d3ebc2e627b8 *inst/chunks/fun_hurdle_poisson.stan -410331b0ff5335b7122ce94e82bffaa2 *inst/chunks/fun_inv_gaussian.stan -fb9e84df9cbe026e3e3b3e6d106d09dd *inst/chunks/fun_logm1.stan -a2f8c721f77b3bb06e00d692830428c6 *inst/chunks/fun_monotonic.stan -b2ba2403a480200aabb229f38e7ccfeb *inst/chunks/fun_multinomial_logit.stan -b568981b75f509ccf32174fb0397ac0d *inst/chunks/fun_normal_errorsar.stan -cab255115314672cfb18dac3dcfa0c69 *inst/chunks/fun_normal_fcor.stan -b71db1f08c41b1275af65f0206d2bd1b *inst/chunks/fun_normal_lagsar.stan -4db656e838f57bb02f4b154dcf65b5d8 *inst/chunks/fun_normal_time.stan -e9141f8f3e7798b949bd19cbb1eaf886 *inst/chunks/fun_r2d2.stan -0cfe72ce347d58328ac8391f94490200 *inst/chunks/fun_scale_r_cor.stan -c08ea259483ece76b4b961d0c638fb81 *inst/chunks/fun_scale_r_cor_by.stan -d99c8984423de9c89877f8dbb45dcec7 *inst/chunks/fun_scale_r_cor_by_cov.stan -9e0d32d5f353ff615247f36f23a58dfd *inst/chunks/fun_scale_r_cor_cov.stan -b65877f1450a1d4266c303568189c0d6 *inst/chunks/fun_scale_time_err.stan -8092f198b21aaa36f63b6f603f411fe3 *inst/chunks/fun_scale_xi.stan -81adee40c17436420879e1a48465d863 *inst/chunks/fun_sequence.stan -a68c834d3a8bf2bb1b505e9539f1e4ad *inst/chunks/fun_softplus.stan -0dd10f85ea66787ff49092ac4c0d6507 *inst/chunks/fun_sparse_car_lpdf.stan -6d69314af266429e46007a636896d8a1 *inst/chunks/fun_sparse_icar_lpdf.stan -848167122601e075f21ffb03ac34cbc8 *inst/chunks/fun_squareplus.stan -d8b7685f83c599c957909837939ede60 *inst/chunks/fun_student_t_errorsar.stan -8e62e4d6ef29142a37407d35e152561a *inst/chunks/fun_student_t_fcor.stan -4de7706d06b43c637cfa10a17a96b02a *inst/chunks/fun_student_t_lagsar.stan -c7d278e8ae6529f39ed2d786d4fc78ec *inst/chunks/fun_student_t_time.stan -15e7bba16664915bcb682a58b012d5d4 *inst/chunks/fun_tan_half.stan -2396fcafffb41122f71465f7306a8cd0 *inst/chunks/fun_von_mises.stan -8f0e2fd17a82e2489aff8195b924e156 *inst/chunks/fun_which_range.stan -28240b527b6638f5f7f1c52a03c45dcd *inst/chunks/fun_wiener_diffusion.stan -bcacbeab70fc5141db21c788cc424629 *inst/chunks/fun_zero_inflated_asym_laplace.stan -9ea0b8a6d1a6bf5cb00f8835fa4b14ad *inst/chunks/fun_zero_inflated_beta.stan -fc249bf75c51cd2f9525ef1943189104 *inst/chunks/fun_zero_inflated_binomial.stan -221508c5adb43ccb0bdb95db0e68c5ea *inst/chunks/fun_zero_inflated_negbinomial.stan -515585bed72e8196eff714ed5270b9b8 *inst/chunks/fun_zero_inflated_poisson.stan -0642c30fcb52c745abeaba0c8767ac74 *inst/chunks/fun_zero_one_inflated_beta.stan -779220fdc3753a6a18eb5639d71f61bf *inst/doc/brms_customfamilies.R -4d677b7dd6922df9e3e0399af379efb2 *inst/doc/brms_customfamilies.Rmd -983d76b7cc32aef240f121438c84f699 *inst/doc/brms_customfamilies.html -eed4bcadd0394d075bacb37295c4ebe0 *inst/doc/brms_distreg.R -8c3bfb376c70c42e179053f9c1e9c565 *inst/doc/brms_distreg.Rmd -8f32f4b704ec166e37037740cdf558bf *inst/doc/brms_distreg.html -24d2a0c1b21e81268a3fe22c085d5da1 *inst/doc/brms_families.Rmd -d405822faf7eb1ecb67702de3aefa91d *inst/doc/brms_families.html -7628123a2cc4c1b2ca73f628a26ca77a *inst/doc/brms_missings.R -0cab824b02268ac6e3f5deabba37f5e5 *inst/doc/brms_missings.Rmd -a6a0221056824539f92655f71b762182 *inst/doc/brms_missings.html -7d0b64f17e6b692926122c5460c490cf *inst/doc/brms_monotonic.R -3df4781dcaace7113283264da54ffee1 *inst/doc/brms_monotonic.Rmd -c65d11b4bd896301cf27cd2b5995c77a *inst/doc/brms_monotonic.html -936e753dc84aadef50c46ba07f417011 *inst/doc/brms_multilevel.ltx -7dee615777073a6c39a997e3b26d8bff *inst/doc/brms_multilevel.pdf -35abd548882af0b4fdd703dc4a8b4f71 *inst/doc/brms_multivariate.R -87e35e5a77cc5e5c27ded17031c52b51 *inst/doc/brms_multivariate.Rmd -bb21604ae8428eb675cf32fa2e2f13df *inst/doc/brms_multivariate.html -b30140a0fa20028ac2cee2688e6a0879 *inst/doc/brms_nonlinear.R -22819f4acf34913fb947beb0e8799f8b *inst/doc/brms_nonlinear.Rmd -0d1ffdde8625ee9f5486cc5a2560486b *inst/doc/brms_nonlinear.html -0f61eb8dc9644314ad28512597696f8d *inst/doc/brms_overview.ltx -13030fd8b37c8a63829b29102ffa8c9c *inst/doc/brms_overview.pdf -4c7c66726a89ed9a459865813f529644 *inst/doc/brms_phylogenetics.R -f2f5d8f580423d498e25dc5dfcb19c26 *inst/doc/brms_phylogenetics.Rmd -f36983c24160672e4386bf94328a33ab *inst/doc/brms_phylogenetics.html -f0e2a1f3865b29f13ca1c5ba3f27876f *inst/doc/brms_threading.R -feed5725c51eb4429b5b556eda4461ac *inst/doc/brms_threading.Rmd -43e2dd9df7f4c780c7bd64f08b1b9b79 *inst/doc/brms_threading.html -4a3de0051a14f5f69e19dada8405b0f7 *man/AsymLaplace.Rd -7b242d7d3cce6d6cbd46950408fcbadc *man/Dirichlet.Rd -121353956d2df4b5f9d25361633c7190 *man/ExGaussian.Rd -36719474a53f764f94fd68b4e9ed0b52 *man/Frechet.Rd -79fe34f3bb3ae49f7f53e0785eb97827 *man/GenExtremeValue.Rd -05e149444009fbc46f54ad56fd5b6b99 *man/Hurdle.Rd -767641821e1bbb405cc53324b9911f51 *man/InvGaussian.Rd -533ab218661f21ea11d0e0c70217bf98 *man/MultiNormal.Rd -4fc00d787af2c694636394ed0919beb1 *man/MultiStudentT.Rd -bb3b5e65380032f0652038da09ac5f0a *man/R2D2.Rd -d211519a613d023bb0c2151ad2c5ed67 *man/Shifted_Lognormal.Rd -1b23d60c6bd2f5d277ee6d1e62076c2d *man/SkewNormal.Rd -d8dacbc59a716219a5dcc30053770e19 *man/StudentT.Rd -088c579de00b1050488bad974a1e7b73 *man/VarCorr.brmsfit.Rd -2cbe623bd331e6c97cb2c7b28255bc90 *man/VonMises.Rd -9a699aeb450133c5e1521c5a086a9009 *man/Wiener.Rd -ed8c35c02f5b87d827d37f01f012faec *man/ZeroInflated.Rd -218920f5f075b30d394c68eed106995b *man/add_criterion.Rd -31fe0fc7b7f834611058e3408c3a098c *man/add_ic.Rd -0ea163e1aef3085d0b180d556bd76f9a *man/add_rstan_model.Rd -fc3dbb35478fed3ff4170add64a93c14 *man/addition-terms.Rd -6fe15df008f29b223b16001c9424fabf *man/ar.Rd -7027516bd6d8f25fb0c954f6abe2ae19 *man/arma.Rd -1c18b8f665f31dae8dd554dbb7caa0cb *man/as.data.frame.brmsfit.Rd -6e6563cabe857e465b1ad20657fc71b5 *man/as.mcmc.brmsfit.Rd -4bc01134553482f3ac35f88335d9aa6b *man/autocor-terms.Rd -c0ea56b4c8ae8db9362e666ba1f9804d *man/autocor.brmsfit.Rd -02e78c08c2d00248f1f3f0fa8ba9b645 *man/bayes_R2.brmsfit.Rd -79ed99cf0a1d4ab95be5e7d00ce178c0 *man/bayes_factor.brmsfit.Rd -6728cdb5f4bf8ffa5b2defcbe7f48fe3 *man/bridge_sampler.brmsfit.Rd -dccf8706a59211512677655c79053215 *man/brm.Rd -b4f65c7279610c5737107d7b965640d7 *man/brm_multiple.Rd -4969bda8630e12faa0f114850f7b8916 *man/brms-package.Rd -0da70dabc2dc49f9d89fef595408c5a5 *man/brmsfamily.Rd -7d1904f46951d357ad9da065b5029c01 *man/brmsfit-class.Rd -4d13dcfe58aa0f5f664214210bc28a1c *man/brmsfit_needs_refit.Rd -d70e3a8bd58f14f1764a4320f0765390 *man/brmsformula-helpers.Rd -747930f869d7ff7b95015f7345642c9c *man/brmsformula.Rd -b01a01790db33ac14c5ff3f928d7d77c *man/brmshypothesis.Rd -6c1b52813e2f6258fba2d029731d748e *man/brmsterms.Rd -ab71ad4238d22d820f5c933b83631643 *man/car.Rd -2da899352b093ca01c88f062862e85c1 *man/coef.brmsfit.Rd -14455c636110902592e2656ff880e6c9 *man/combine_models.Rd -536475ee3189c2b8c98a0b7f700df36a *man/compare_ic.Rd -b62051df80a1e1795ef8cf3d5ed615bc *man/conditional_effects.brmsfit.Rd -aaaeaa11cbe3b491e6fc2cfb81971574 *man/conditional_smooths.brmsfit.Rd -8b9ba946bd8ab62f623a359a358e2dcc *man/control_params.Rd -880c203a381108beade110e0ffb81334 *man/cor_ar.Rd -d6cc2c55c8b8b48283fb1192af853c23 *man/cor_arma.Rd -caa14430a3471aedf961ff6d1b8998ee *man/cor_arr.Rd -ff54b0010b804d14a524cf09fbecbd6b *man/cor_brms.Rd -dc75585b61a68ce01134e261dd71237a *man/cor_bsts.Rd -c4d870ef90f10d22ff2fec44a2c99e17 *man/cor_car.Rd -2434a8432103e4e4e8961e603f292a2b *man/cor_cosy.Rd -b4c36f5603dc02f95cdf5ef86f2776f1 *man/cor_fixed.Rd -a3380ce7925c2f16b205a45026b6706e *man/cor_ma.Rd -c98f6396cdbf60f9785f5064d91ed197 *man/cor_sar.Rd -e47db19e7cb6f87d747baa6bae399ce7 *man/cosy.Rd -a6f0fe02a8f0382eb7a2dc4775a4310e *man/cs.Rd -41955bdfbfd4a04054383ce54442d933 *man/custom_family.Rd -81be337f5ddeccc02a7fb4aefd143a2d *man/data_predictor.Rd -5e686d854680185c1635bc68f8471ab8 *man/data_response.Rd -7942584b6937f1af1f6b9afa276a6b9a *man/density_ratio.Rd -94e3a313300ecce5790bc2e2432c1ad6 *man/diagnostic-quantities.Rd -9b09daff808d0683d07b5fddb5346af8 *man/do_call.Rd -b8a2223a54ca9db2a3e4580c8b04ff04 *man/draws-brms.Rd -451242e3949307bb05e1260d467a82c0 *man/draws-index-brms.Rd -4dba716fde6dbe88540f5854ee1a5eeb *man/emmeans-brms-helpers.Rd -260cac52df95e5768cce2f2ecfe34574 *man/epilepsy.Rd -a3fe80bdbe805b8e2ddbc50749bd83ac *man/expose_functions.brmsfit.Rd -b39f81a07a666c3c2e6e5f65091dbef1 *man/expp1.Rd -e43a00bc97ecaa16b25b0832b1ef6327 *man/family.brmsfit.Rd -cdacff18293c3ba78788f0d9dede7d0a *man/fcor.Rd +2024133c73ebe6ad6887ac0f58235b4d *inst/CITATION +ea378d56df10b3d9272d2dca8262e8fb *inst/chunks/fun_asym_laplace.stan +6d86df2bc6f7544a4563725778b0b16b *inst/chunks/fun_cauchit.stan +fd90371e171982b87e128fcf8113266e *inst/chunks/fun_cholesky_cor_ar1.stan +b8cdce7d7bdad258e873ab5cc8cc24d4 *inst/chunks/fun_cholesky_cor_arma1.stan +356998171806c24364357c7fa83bc4f3 *inst/chunks/fun_cholesky_cor_cosy.stan +1a86c51d5048b4cb4f280f041e28c7c6 *inst/chunks/fun_cholesky_cor_ma1.stan +ad44c1673324f37cb17322e071a97911 *inst/chunks/fun_cloglog.stan +deb4338fee0c1d931b368cee1250e9c4 *inst/chunks/fun_com_poisson.stan +9cb57f90a4bb61d8ee746f518e2ae9ef *inst/chunks/fun_cox.stan +d7f5ae53cc6aac2bcd8747f56692daae *inst/chunks/fun_dirichlet_logit.stan +77bad66bf658c6d78b16f3b74284a9c7 *inst/chunks/fun_discrete_weibull.stan +737cf8920b1cc73a6e3f5e1784a4c719 *inst/chunks/fun_gaussian_process.stan +b9906a838d8cc37dad6482a8d92222e9 *inst/chunks/fun_gaussian_process_approx.stan +90bf3da8c32ea57699d7bd87ed025da8 *inst/chunks/fun_gen_extreme_value.stan +2c721f9639433aeb355311c009d02f90 *inst/chunks/fun_horseshoe.stan +6f382f8dd397b8a4a0aae8085753ffbc *inst/chunks/fun_hurdle_gamma.stan +32a82f3e36792d38d9f3b6aa58b14dbd *inst/chunks/fun_hurdle_lognormal.stan +22cb3b99c9a7aa3b39756cd2575635fb *inst/chunks/fun_hurdle_negbinomial.stan +a753bb5e1ed481d31dfb5a72a27c937d *inst/chunks/fun_hurdle_poisson.stan +6fc37af292edf6efcdf13f5686dc1e18 *inst/chunks/fun_inv_gaussian.stan +00aa1a161641dc9210d78322c8d900ef *inst/chunks/fun_logistic_normal.stan +ab1336026af95aef7a954f19d518357f *inst/chunks/fun_logm1.stan +0baa69b90616ca4194776ddb600a6b83 *inst/chunks/fun_monotonic.stan +4b3a37209ccaf984ee6eb865babe87b1 *inst/chunks/fun_multinomial_logit.stan +6a4e61936b11e2d17d4c2b1a1fcd3502 *inst/chunks/fun_normal_errorsar.stan +7da89af6f64975a537de8f5c77d307e2 *inst/chunks/fun_normal_fcor.stan +abd3602bbdca2185ec2f338d4c284ae0 *inst/chunks/fun_normal_lagsar.stan +50286ef04e8d1ed9ee9a59be7805a3ae *inst/chunks/fun_normal_time.stan +141b84cf9c78fb7b2dd7e90194e34c63 *inst/chunks/fun_r2d2.stan +0bc8ab0d7b8523aa844e1afbb8e9259f *inst/chunks/fun_scale_r_cor.stan +cc66d6548107091c43cbcb28584b087a *inst/chunks/fun_scale_r_cor_by.stan +b9d27e19e58c764fd2a996f8eebb1e72 *inst/chunks/fun_scale_r_cor_by_cov.stan +73c259890366f5d8ae4268c41114a80a *inst/chunks/fun_scale_r_cor_cov.stan +31726bc33b561165ef111c93cfac4b0d *inst/chunks/fun_scale_time_err.stan +3984fbf915968ea965adda307f313964 *inst/chunks/fun_scale_xi.stan +8c304e9437926d788d226588b68e2b3a *inst/chunks/fun_sequence.stan +7ad0c17d3752675f9a8e2dbc5613d23c *inst/chunks/fun_softit.stan +5497d6e377507243d681f79209f3bb8e *inst/chunks/fun_softplus.stan +dcdf6b009a117d4b65f8c0c231decbe9 *inst/chunks/fun_sparse_car_lpdf.stan +b3c1b668aafb089e95b105c4825406f2 *inst/chunks/fun_sparse_icar_lpdf.stan +e45d628c78ed6363a5d9f88076869811 *inst/chunks/fun_squareplus.stan +21f75d7dcbc7ec643344bde03b071057 *inst/chunks/fun_student_t_errorsar.stan +7ecdcc3ef15aac75059696c3092159b9 *inst/chunks/fun_student_t_fcor.stan +17be1585e0d2a3da3db0f5b186dd0e57 *inst/chunks/fun_student_t_lagsar.stan +3878523f15e5be22d146538d285ca34f *inst/chunks/fun_student_t_time.stan +a803ff115a9080dc03636ce110049b37 *inst/chunks/fun_tan_half.stan +59b5e7f52ac92c6cf06de27f9d09b0c5 *inst/chunks/fun_von_mises.stan +8746e223df0f3278b8db9c116e9f20db *inst/chunks/fun_which_range.stan +6e5b83378b4701b2c6fb3efd326f95ee *inst/chunks/fun_wiener_diffusion.stan +6a85f96ae29a539743865b155c8393ea *inst/chunks/fun_zero_inflated_asym_laplace.stan +e76db5963e8b6358822005b7b3ffe57e *inst/chunks/fun_zero_inflated_beta.stan +701b8376108cde636fd66906f9ce6f17 *inst/chunks/fun_zero_inflated_beta_binomial.stan +007ca9d21e1e8ace60ac061af77ed100 *inst/chunks/fun_zero_inflated_binomial.stan +6f99414a24b70e038b595f3affc7584f *inst/chunks/fun_zero_inflated_negbinomial.stan +078cb83d3122b01e310aa6c7272e1db3 *inst/chunks/fun_zero_inflated_poisson.stan +c2055bf9157eb32470ead3264ba79d91 *inst/chunks/fun_zero_one_inflated_beta.stan +73b796f222b65966a41e50d6e08c5483 *inst/doc/brms_customfamilies.R +b044a924fbded90c6ca9da8bc01f85cd *inst/doc/brms_customfamilies.Rmd +5b9f58174d0f68ebe6af1b3ba4ed4449 *inst/doc/brms_customfamilies.html +05e53c1b4763120cd27f208a820aa457 *inst/doc/brms_distreg.R +3a1e89b91c2b94282c6df6607f405a89 *inst/doc/brms_distreg.Rmd +8f2f5347a55051b80a29507650ac23d9 *inst/doc/brms_distreg.html +5ee02c9103d3b08f08c87597328e1fc1 *inst/doc/brms_families.Rmd +c3db978ea8f10a823be6d67ec63c5bba *inst/doc/brms_families.html +7bc766f8f78ca7a4b1206fc52b796a03 *inst/doc/brms_missings.R +cdf2b42e1cf561cdf4f1f1f7c06d8148 *inst/doc/brms_missings.Rmd +bbd2e60e78a3d8970c3e1d41dac0fc89 *inst/doc/brms_missings.html +975fbf30dc344a58912d2ba55fb31dd7 *inst/doc/brms_monotonic.R +ee62fe59cf57cd22be35969e4c27dc7b *inst/doc/brms_monotonic.Rmd +3e1d502462e70344dfbf714cc32e2f65 *inst/doc/brms_monotonic.html +f7cece21fca8fbaaa53a106038349d0c *inst/doc/brms_multilevel.ltx +de37e48a913291aec1d171d4aa7265ab *inst/doc/brms_multilevel.pdf +a7e2942d137e03618604f6815207a6c0 *inst/doc/brms_multivariate.R +7567746ed5926d36df405b3a22f01eef *inst/doc/brms_multivariate.Rmd +1e293d05cb3a032c3ab0a0007bdda470 *inst/doc/brms_multivariate.html +3ac17800c6a2f929f1c8689434b57234 *inst/doc/brms_nonlinear.R +1d4ca841f24e6d41d803ea56afbdbbae *inst/doc/brms_nonlinear.Rmd +6a1cbc5790fab8c2bc926123ca2a27e4 *inst/doc/brms_nonlinear.html +5ae728c35b6cd8d27e69cf0a119e646f *inst/doc/brms_overview.ltx +5dfdfadad022b7c3edf05112031baac9 *inst/doc/brms_overview.pdf +8e540a5fba57119659a394690dcdf749 *inst/doc/brms_phylogenetics.R +85bd37fc5196318ee06e034c67a50c9a *inst/doc/brms_phylogenetics.Rmd +fce201589b7bdef0157b3111e2070f92 *inst/doc/brms_phylogenetics.html +98f7d2fc500f2a560229526401197465 *inst/doc/brms_threading.R +7566e5c0fa0e7d54fa16e0c0f6938e12 *inst/doc/brms_threading.Rmd +8bcdf261ba4de8b41398ac1719fef4c5 *inst/doc/brms_threading.html +f819a4d09188807bbb5fdda05405e6e1 *man/AsymLaplace.Rd +5213ddb4c75aedec7603e2fdea1af660 *man/BetaBinomial.Rd +14c9f1fc298dcbd26f807f24e07550db *man/Dirichlet.Rd +97e447e090056a382da7393a794dc68d *man/ExGaussian.Rd +348c7a3e4b2acf7822be61a7b9ace214 *man/Frechet.Rd +ac3b2201f7c3c3d160c5f64346f8e990 *man/GenExtremeValue.Rd +35c9075a7ca69042980395bfd9e02bc5 *man/Hurdle.Rd +7b4a4ebd29218e15291e36d3f5c46f9b *man/InvGaussian.Rd +3e30acb0a73351ea6c1b985e94028f42 *man/LogisticNormal.Rd +1ffc2bc2c24125e8d7e481fb9a6007b0 *man/MultiNormal.Rd +add9404002291d1d5f16391e65941d1d *man/MultiStudentT.Rd +44696405af68137488d394b0196133ec *man/R2D2.Rd +8bf7659c384cabee6cdd45e0616995db *man/Shifted_Lognormal.Rd +8ae449627b649dddccafb402636dd9d6 *man/SkewNormal.Rd +912a01faa1e7c1c44a7241d09a8e5d43 *man/StudentT.Rd +6685626d29ded45092d866eab6dbc9c7 *man/VarCorr.brmsfit.Rd +b3629fa3b04924241d79932524cc55e4 *man/VonMises.Rd +930e9213115e835e1ecb1321258c4308 *man/Wiener.Rd +2f1fdd6851666b81b68f2896f15c3c0b *man/ZeroInflated.Rd +950b24967deccd1d87d011cbdaba50fd *man/add_criterion.Rd +2551b940b4b7637a537f26bed7718db8 *man/add_ic.Rd +8ead7876a361cce15b28222a5dc69629 *man/add_rstan_model.Rd +59513769914d436d6fddbd9556593e5f *man/addition-terms.Rd +d1694011ffb4be502a30de3bfa1d5709 *man/ar.Rd +e48c1cebb35608b8aa990d9aaedcefab *man/arma.Rd +1a5ec35ec370b88d90d312f2ee2894b9 *man/as.data.frame.brmsfit.Rd +0bebf3936e927a156ffba64b82863f98 *man/as.mcmc.brmsfit.Rd +d668eaee60cdeaeadfcb6c942357c7c4 *man/autocor-terms.Rd +8b6e6789c093ecd1badcf2b7db00459a *man/autocor.brmsfit.Rd +7d69950d7307c6406ee93d57d49df47d *man/bayes_R2.brmsfit.Rd +c3e6672f4201e9b6b20308c48225c31d *man/bayes_factor.brmsfit.Rd +46ec77f8278dcc430f9d542ded6a08c5 *man/bridge_sampler.brmsfit.Rd +646e57da7448374d26ddb294ddf23a32 *man/brm.Rd +4dbd3d95fe7c44d893ad9576a914cbab *man/brm_multiple.Rd +1b54ac4c4eef3d7603ab2000c1659b09 *man/brms-package.Rd +07a51b789ca2f7a6b36484eb42ceb4fd *man/brmsfamily.Rd +78983f84cdb12a0567096938e9db455a *man/brmsfit-class.Rd +3c66fbab1383d6b1a65ea8962a626220 *man/brmsfit_needs_refit.Rd +1036924e7dc17991d0a52a31458486e4 *man/brmsformula-helpers.Rd +2dd107cf8156a01b487f0dc8b1c53e48 *man/brmsformula.Rd +93957b9d8e53a7f24bb2c216c86a9ebf *man/brmshypothesis.Rd +c2b51e956debe84df87304a1d8ddccaa *man/brmsterms.Rd +fe96ed9e31d6050d2d5fc3ce16a1a1cc *man/car.Rd +ebcaf612c03c7e8e49795504239101b6 *man/coef.brmsfit.Rd +585718ec6123ceb262c5a46f5c2033b3 *man/combine_models.Rd +2d4529ffb04ae9b7b2cf32688d65667a *man/compare_ic.Rd +c177bec8ec370433d449f13d5a5175fd *man/conditional_effects.brmsfit.Rd +94137c497cb22d22b30812e31fb1f343 *man/conditional_smooths.brmsfit.Rd +75d9f30b935f0e99a41d01e4bf0f9b4e *man/control_params.Rd +4aa53d8353dffc501c9bf55b85e0432f *man/cor_ar.Rd +cecad3804f335aea8259e3dc4303647b *man/cor_arma.Rd +7f439f409b1aa8e77f01687959e46393 *man/cor_arr.Rd +8f8b4ff277782a5cce802a93a0099784 *man/cor_brms.Rd +46dc58cfcc1ebebd9bc1b972cfeb4352 *man/cor_bsts.Rd +ab427b3414aefcf08e9ab1bb23e9092c *man/cor_car.Rd +c0de434e09365e73bc60be48b9020269 *man/cor_cosy.Rd +0c8390364d274f1240881f8db6bf4efe *man/cor_fixed.Rd +b830c26475a2c54fbdeaa1db9e14b98b *man/cor_ma.Rd +713028020db23317a00dcbd763eeef6c *man/cor_sar.Rd +9d3a1304f56bd940335c3a2ff440f684 *man/cosy.Rd +285a185d228d276351aa993c5d518dee *man/cs.Rd +95ee9e173941ae06fbdf66b1cb820bce *man/custom_family.Rd +7d03bee9e6784550dd14c86517f88048 *man/data_predictor.Rd +ce7eda06e9eefc17ea320ef7f1448c2a *man/data_response.Rd +04b4aae9b081455668a9ecbe6ff7b8a1 *man/density_ratio.Rd +dc166e916716038846bf9daf7496e438 *man/diagnostic-quantities.Rd +e589de81ddbec620fa58e1501bc887c0 *man/do_call.Rd +0acbb82e6f9b540146069d2cf844713a *man/draws-brms.Rd +675ee1a3277bd1a7367047e66a21846c *man/draws-index-brms.Rd +a2e43eb498f1431b0e98d83ae3427a2e *man/emmeans-brms-helpers.Rd +640e1713fbc56c4761a3fc9ed1a40d57 *man/epilepsy.Rd +0474edf753d3dc04367b0fce35b851e5 *man/expose_functions.brmsfit.Rd +ef2c51106154f8ec1eed261051f21a63 *man/expp1.Rd +ebbceb3446d178098f9cb6d582ae65b5 *man/family.brmsfit.Rd +e80efced805aedd25858d661a85b4959 *man/fcor.Rd 8939fce14ae807a154ff4ab5f714fea5 *man/figures/README-conditional_effects-1.png 3f784b7850206ac837f1e618890f285e *man/figures/README-plot-1.png 5a143f562f85cfa3980dbfc8a1187fa3 *man/figures/brms.png 5fad10a5cc62c59ea429a5ce90191e2e *man/figures/stanlogo.png -dc2fae5a86aa597d0ae8c72e294ada89 *man/fitted.brmsfit.Rd -018ec8aa5d191411d6f9ddf4134507fc *man/fixef.brmsfit.Rd -366deef67bb007692950ec06f763015d *man/get_dpar.Rd -cfe6b43c52168bc38288038ceda682f9 *man/get_prior.Rd -f00714ffd523d51420c9b14da69d7c1e *man/get_refmodel.brmsfit.Rd -50888fb89fefc612cc8abd3f70e3b3bb *man/get_y.Rd -812c9803ee5f7a9823a5d999e6e2430a *man/gp.Rd -6a7032b9ae8389b29467b608c0c1eb2a *man/gr.Rd -db02bdd57db9c1a3ae91667c03ed44b0 *man/horseshoe.Rd -0ebac0c6b66c6d6eb33e70a91ea65f27 *man/hypothesis.brmsfit.Rd -de24adad365b036d52b47d3c1b2eb92a *man/inhaler.Rd +d0a1a12ff0c499035d2fadc665e38a5d *man/fitted.brmsfit.Rd +655490ff4efde340116660f0781d9350 *man/fixef.brmsfit.Rd +cbb1a56c5f50bc677ef49e3b4efca504 *man/get_dpar.Rd +a0621ed1247d028201f787557932e9b0 *man/get_prior.Rd +f718db86394e05baf182d5ef3fb4af9e *man/get_refmodel.brmsfit.Rd +d76887acafebd4415eb1afb776d84224 *man/get_y.Rd +63de21a08fc9ce3e6320a0b54d1d1230 *man/gp.Rd +551a0a9608e2da325d7bfb528c185475 *man/gr.Rd +b2f5ffed1c409c2e43984e24c1bb2725 *man/horseshoe.Rd +17a509e86162fd0eee2b79098c44a3bf *man/hypothesis.brmsfit.Rd +b35515077061d0109567561d704fe0e0 *man/inhaler.Rd 91bc090feda4bd1d3905237cb210afc0 *man/inv_logit_scaled.Rd -b415b243f7778b800ab56569baa3044b *man/is.brmsfit.Rd -a26dcbb0bfe6a152171450ca5de77fbc *man/is.brmsfit_multiple.Rd -837292b068f84e6ee06a2b0e2fbfcefe *man/is.brmsformula.Rd -15ff1c006fba2a58b1025d39bbde6362 *man/is.brmsprior.Rd -cb6a884428dcb9a410dddb78d10d089e *man/is.brmsterms.Rd -c4a2c5a027c141ffb46a5ed4748b15ef *man/is.cor_brms.Rd -4a381927c9781360cb7195b44acc15d2 *man/is.mvbrmsformula.Rd -4febd60005469f36a36c289a09846012 *man/is.mvbrmsterms.Rd -aa38b096fe5437b4bd7fd99538c02af0 *man/kfold.brmsfit.Rd -e856ad22ddf57c7f3f0f2f3723833d49 *man/kfold_predict.Rd -82e4963735217e608c0ddb15f8fb604e *man/kidney.Rd -82c676486e6ad3c7863ed663c86d9696 *man/lasso.Rd -56928865274d3060603d5824d5317bb3 *man/launch_shinystan.brmsfit.Rd -3a5b8ff06599d70e3b79b8556d155d84 *man/log_lik.brmsfit.Rd -eb7887eb9acb7e80778fcdf9af5da719 *man/logit_scaled.Rd -51678017231f5c106b401e074ba5a193 *man/logm1.Rd -d64f2389dffd8fcc4e6872a16829d974 *man/loo.brmsfit.Rd -23871e6a7d1d406eefa37fff2abc24bf *man/loo_R2.brmsfit.Rd -d0d4babf60634c59a4c3d8640d7fa885 *man/loo_compare.brmsfit.Rd -1239953226f2c0592844778d7300ccaa *man/loo_model_weights.brmsfit.Rd -96f0d385c72d7a0e2a3075a63d5dd2f8 *man/loo_moment_match.brmsfit.Rd -76be9b908e2d55264faa60911ec46a02 *man/loo_predict.brmsfit.Rd -d23a7ced444c3818e6e23b29a55c17e9 *man/loo_subsample.brmsfit.Rd -8ec836de39a59363e0119f35bd341595 *man/loss.Rd -71cc49ced14a40d70f962b51ff9944f9 *man/ma.Rd -8a9b655c43bc0a74f9e765c1017a2a5d *man/make_conditions.Rd -4f8919e26fd4c7a810f0000a4ec2f0b2 *man/make_stancode.Rd -ee3c10058dde48d3bdfb20d5f6348859 *man/make_standata.Rd -850bb658c7596783c14411c7c9c5ee11 *man/mcmc_plot.brmsfit.Rd -b4bf1080b3cdc7eb695c4e4b887cabc1 *man/me.Rd -e4027c05a4b0bf191d092b3f4a0d4abf *man/mi.Rd -886ffd80fe4941576f384f684cfe963c *man/mixture.Rd -606c37c63a40a14c1e27b50b3951c4fc *man/mm.Rd -9c3e263487793e900df3cc059e7c6781 *man/mmc.Rd -267c77b9f6e81d542a2dd47f101206da *man/mo.Rd -d1a95180c86b8c393c0f559c2dcba2e0 *man/model_weights.brmsfit.Rd +d3887f794ca279d6e91f78d359488413 *man/is.brmsfit.Rd +4bfcffa8ee62d0ba281e00ac75c44c62 *man/is.brmsfit_multiple.Rd +d345caf2b9ad7295e3c8b3c7550099b9 *man/is.brmsformula.Rd +2495abf33e51dd1c7b777be17639e83b *man/is.brmsprior.Rd +b4e9ae0fe2f7e053481f5baec6c169f8 *man/is.brmsterms.Rd +719230daa3fa48becfd07b2abd132270 *man/is.cor_brms.Rd +a8d15115fddf4462460bee22230c7aa1 *man/is.mvbrmsformula.Rd +9a9129afc0fa575f47184739243bb79d *man/is.mvbrmsterms.Rd +d6f562710dc0e5ea4882aa2bb280a7bb *man/kfold.brmsfit.Rd +68aebab51d29b7c6a28025d602665656 *man/kfold_predict.Rd +3da1d29a87963c216a1c6e7a03062f41 *man/kidney.Rd +d1c180abc561dd4ed0184b8861e51e10 *man/lasso.Rd +ccfb164d7b2242b8b6a77747e9f8c04a *man/launch_shinystan.brmsfit.Rd +62e6869c08bf324141f3f5ce86fc496f *man/log_lik.brmsfit.Rd +900ea73d5b892e4fb1436ca014dfcb16 *man/logit_scaled.Rd +1e4ddd51ad3a4561cb500f85ad5f2e0a *man/logm1.Rd +d7688327753660acb96bdad83f973985 *man/loo.brmsfit.Rd +7d6aeee8042b66b5eccb0d67d4231394 *man/loo_R2.brmsfit.Rd +57a07a3eaada9ab2c256a44d27ffec5d *man/loo_compare.brmsfit.Rd +f29597640d7d655a681115ab42f02789 *man/loo_model_weights.brmsfit.Rd +a13ef9f993f1520b3f789d54c2ec6506 *man/loo_moment_match.brmsfit.Rd +3e9d22039f442d0f207b03cf1372c4b6 *man/loo_predict.brmsfit.Rd +e0d53fb404be8407bf1a5ec23410af8d *man/loo_subsample.brmsfit.Rd +7fa05a35f23a32ff377f16d4376fee7a *man/loss.Rd +9ae67551d15eb035058fe01f8fd551f4 *man/ma.Rd +67442f213bfd5a21dc2d7ef560ff618e *man/make_conditions.Rd +cf06e9f770acbbdafff7fca25072c9e5 *man/make_stancode.Rd +7ae6520b7c6f4030cc59eec83cbac797 *man/make_standata.Rd +699f7d9796dc61fcb6ba5a7fcfe8f03b *man/mcmc_plot.brmsfit.Rd +8a4b6431285accd9445532bc466b216f *man/me.Rd +059d1149efd9185938a5da4f54af27c9 *man/mi.Rd +1870ea75d4b13e11c6d60aea1d554382 *man/mixture.Rd +35ea0579c8e2ce93aba57e7d33085bed *man/mm.Rd +c8f23b1448b4d3fddc30f12c3c6747af *man/mmc.Rd +67fdada3b82bf0de3502920ff501f251 *man/mo.Rd +bc4a98eb125d89c537ba607c0831f921 *man/model_weights.brmsfit.Rd 41d271b33d265ac55dce75c385d429ca *man/mvbind.Rd -bd746d483683608f2bebcd60aabfc81d *man/mvbrmsformula.Rd -1583894f185a4696a33136eb6fc53933 *man/ngrps.brmsfit.Rd -b7a41a067626f4f61a9a71e0e88e59ce *man/nsamples.brmsfit.Rd -1cc9d19228c25f480dffa71d284667c0 *man/opencl.Rd -16736f0a0586f135f9d51619faabdb94 *man/pairs.brmsfit.Rd -42d330926da9cc7674ec17cf4c9bb2a2 *man/parnames.Rd -d88af5b63e6a517482d6e60169a26e48 *man/plot.brmsfit.Rd -7f5ccb3bfbfac60babf3cf1bf51c5886 *man/post_prob.brmsfit.Rd -7c50b075b1e569f433f183868a051eb6 *man/posterior_average.brmsfit.Rd -7d0e0e8203d5759275312d1e0a4ebd9b *man/posterior_epred.brmsfit.Rd -deb75862fb990c7135e3259e86030180 *man/posterior_interval.brmsfit.Rd -452e05eb1528662890627740ebfb0cd4 *man/posterior_linpred.brmsfit.Rd -4159287ae87cf65f7982f3d9393a76b5 *man/posterior_predict.brmsfit.Rd -7800cfc79113307cfd5cc22cd8c739e0 *man/posterior_samples.brmsfit.Rd -efe0e5738561c35822887e859df64b2d *man/posterior_smooths.brmsfit.Rd -022ca488c128b992c7fc76d479fe9073 *man/posterior_summary.Rd -2ee832b41159af33d03890fa5b7c6cf4 *man/posterior_table.Rd -1b68e9cda8816d4b1aa38d4cd2104e02 *man/pp_average.brmsfit.Rd -c9dadec75846594d42aca55844181ea7 *man/pp_check.brmsfit.Rd -b88bb2ebfa834eae1383a5679036d153 *man/pp_mixture.brmsfit.Rd -7b69307e3df329a311d55b54b7c69249 *man/predict.brmsfit.Rd -5ada0695547e6fb4af63b4377e04570f *man/predictive_error.brmsfit.Rd -bcfe80237350dc8b6135cb250675a098 *man/predictive_interval.brmsfit.Rd -05611f229f1c415d31ba54b25f1b52a6 *man/prepare_predictions.Rd -f7528522dcbe19c7c6c3e7e81e5b62f9 *man/print.brmsfit.Rd -4695332de883a74adb3b6eeb4643ea0f *man/print.brmsprior.Rd -856389bd392df08e848205b6b1aa6838 *man/prior_draws.brmsfit.Rd -36b7a42f879f2f7441f8d756982b6c70 *man/prior_summary.brmsfit.Rd -32b4b5eaff00acdc78309962af225c23 *man/ranef.brmsfit.Rd +d9faea0f79c1ed4b2107cedef3c2aea5 *man/mvbrmsformula.Rd +c12860b45008dfc4a57a27111003d8f5 *man/ngrps.brmsfit.Rd +f736c567c641266af3de81ac00769748 *man/nsamples.brmsfit.Rd +5eadb0ff319ed12d02d1d8af4d2ad78e *man/opencl.Rd +ab92f50152366dab3e9dfd8f9f65e2a4 *man/pairs.brmsfit.Rd +3c30943f7c3617d6b30253272079cecf *man/parnames.Rd +818eaed07ea2ce3cba5a9144c745bdb5 *man/plot.brmsfit.Rd +fdf888004fff752c2772e53d818a7d3d *man/post_prob.brmsfit.Rd +6979e03753e7fa14c452ee4b075c5d5d *man/posterior_average.brmsfit.Rd +aadfe47629ba36cd38e810c2a0d0b9f8 *man/posterior_epred.brmsfit.Rd +19a86630a8ccb9f149f796922bb4fb84 *man/posterior_interval.brmsfit.Rd +529dc82fac364e2b85e9aae5f5651305 *man/posterior_linpred.brmsfit.Rd +8dad928db6fac74e150407031aaa0549 *man/posterior_predict.brmsfit.Rd +1a2ada66c95792eb04d29443968a4d00 *man/posterior_samples.brmsfit.Rd +cde301543987b3569dce77d3691b128c *man/posterior_smooths.brmsfit.Rd +8b15c4487188671d4819d06f1acdc827 *man/posterior_summary.Rd +95c2007d202944bdb2946fef3b64f14f *man/posterior_table.Rd +8b07cf4bbf3eaecdec266f5a200ebb4a *man/pp_average.brmsfit.Rd +ad3cea79773407539a101427046c48ed *man/pp_check.brmsfit.Rd +b80fe2c679ba40e666af3da4cd22e3d1 *man/pp_mixture.brmsfit.Rd +cad0a460283bd612dde7d923d8d859c0 *man/predict.brmsfit.Rd +f1f80bdea5d6ae738986c80ecfc47935 *man/predictive_error.brmsfit.Rd +9fb4d1382e914f9ff5a306f783091c4b *man/predictive_interval.brmsfit.Rd +5b16317032f95e11c8341e0eb8d9c7be *man/prepare_predictions.Rd +6a101409630ca8947aeba54e0dd89551 *man/print.brmsfit.Rd +e8009c6186fb93c8d89682c4dd34c1cb *man/print.brmsprior.Rd +924af1c1af0be14eaf84860a048b3a8c *man/prior_draws.brmsfit.Rd +49d839532a1d0da147db7b992946a854 *man/prior_summary.brmsfit.Rd +f24e2e8f9ac0bac9fb6e51bd2dd66a55 *man/ranef.brmsfit.Rd 2d049bf19ee1db3b1e00b044c41f3e3d *man/recompile_model.Rd -55d374187b74c685fed3c66896b857eb *man/reloo.brmsfit.Rd -b86737ad5ddcba0ec6cfb583aed0fe0d *man/rename_pars.Rd -010a73449fb09ec51a3f87beddb1fb3b *man/residuals.brmsfit.Rd -de90a86da8cba2eda87b5a85c2e89ae2 *man/restructure.Rd -d35464624f86fe2ea5104984d086a00b *man/rows2labels.Rd -796cfda792081bd0bc1103f5369f86f9 *man/s.Rd -b38f0ff9d48fcfedba9b27c63e9ce208 *man/sar.Rd -3cf345c1e14b4f73434fbf9da0fb065d *man/save_pars.Rd -343680160a44641cd39f9c85b18dce01 *man/set_prior.Rd -b40a9ca551e3d4fe1576ef70192cea72 *man/stancode.brmsfit.Rd -13983425ed88a94741eaf4d7dbf5c0e4 *man/standata.brmsfit.Rd -282dc8e772911a4c7f3b35cc33dacfb5 *man/stanvar.Rd -15f9e57d2d16f5cdeaa11efc82f3a6b3 *man/summary.brmsfit.Rd -62e4e69322483d22e6b0a9d0cab134d9 *man/theme_black.Rd -3fdb7c7e7f37555d794f238b234f1bad *man/theme_default.Rd -66f01dc325acb775d6908a67eeea0361 *man/threading.Rd -36d9a1069e4f39dc8d8bf0757cfa2c73 *man/update.brmsfit.Rd -862d7f27b7c04a6ffbb31b00481de092 *man/update.brmsfit_multiple.Rd +fa85615af6b651e645f4ac09b46ad6b2 *man/reloo.brmsfit.Rd +2910fe3cbb1060d7a0c29e14cd6eae6b *man/rename_pars.Rd +e42b9ef07bfb347df256b6e63fa247a1 *man/residuals.brmsfit.Rd +fd18518e39d8b72eb2da941a5c9e2264 *man/restructure.Rd +4f7f207825b3f9a5f951f9cc02d9bc65 *man/rows2labels.Rd +85352419f17ffa36797db25447795e41 *man/s.Rd +36766e1568e020be0eedcd04c795f0c9 *man/sar.Rd +0b346b3c24439642182b8c92dbbf7d8d *man/save_pars.Rd +f3d72834e6d77b7eb1907218bb1e4455 *man/set_prior.Rd +5b9bc103dd04679d89fe9a3a7ea017c4 *man/stancode.brmsfit.Rd +a6bc6ed748ddf011083b3656f87f8844 *man/standata.brmsfit.Rd +26937c4d73ee327c30d5131a161140e0 *man/stanvar.Rd +609139f5fa9d220f297ec9aac9675a05 *man/summary.brmsfit.Rd +6ef704004a7c7719b0806d1cd47f3736 *man/theme_black.Rd +6f15836eefa722613d11ae2a26d498b2 *man/theme_default.Rd +9ccc493e1ffc4cb8233711028629ef7a *man/threading.Rd +e7aa1e144a1f605c523a75943ca731a7 *man/update.brmsfit.Rd +3776192391910c4f222a6ff404067a83 *man/update.brmsfit_multiple.Rd d4329014c6586f1d939c80df9105286d *man/update_adterms.Rd -70e25beb0ce7b0519f5a0d3f5817ed43 *man/validate_newdata.Rd -9cd8a6ec5bb3c5e1a6dca4bbf49cabb6 *man/validate_prior.Rd -3054742849165aa4111da1cb17c19890 *man/vcov.brmsfit.Rd -70564348d5313cd557d61f42d0fd20f1 *man/waic.brmsfit.Rd -2b545ab36b38afc18e158956ff3071a7 *tests/testthat.R -9803edc3d25a061c517d81f2328f8e92 *tests/testthat/helpers/insert_refcat_ch.R -b78e4255c898e45171bd384dd27b411f *tests/testthat/helpers/inv_link_categorical_ch.R -6bd67088a605e026b11dabfa30056c85 *tests/testthat/helpers/inv_link_ordinal_ch.R -7dbd7900503f0241de4530b72d0d509e *tests/testthat/helpers/link_categorical_ch.R -576c93f792337e0412b236036236450f *tests/testthat/helpers/link_ordinal_ch.R -c84470b942721db6758db28cd98c88cf *tests/testthat/helpers/simopts_catlike.R -a68beb7b3fffcd6d0b06ee28ddae203a *tests/testthat/helpers/simopts_catlike_oneobs.R -d5b5fa484306406e3d79209c8e88ade2 *tests/testthat/tests.brm.R -cf177191d175048df8f28e993f221684 *tests/testthat/tests.brmsfit-helpers.R -26f7d5c0b64418aa905ae5e25b23c1d5 *tests/testthat/tests.brmsfit-methods.R -6619c7458c57e3bfd6102dac65b79a8f *tests/testthat/tests.brmsformula.R -5dfbad44314e36823894ee6bc8932ac5 *tests/testthat/tests.brmsterms.R -e859d58ccbd22effe1e5a8907694d607 *tests/testthat/tests.data-helpers.R -8609d28ca2c927f1d22c3dbd2a5ef6ee *tests/testthat/tests.distributions.R -cbfef132f01754f96d43dd9e370113ac *tests/testthat/tests.emmeans.R -b20e3dcd3d97d64acc0c36daea982b70 *tests/testthat/tests.exclude_pars.R -469e1b181b2bef194a6c9feef7675c15 *tests/testthat/tests.families.R -e8f00b5c1fd92182c1472d71aa5130ec *tests/testthat/tests.log_lik.R -1fa7eae9c9ca7d64b3294228b9142f7c *tests/testthat/tests.make_stancode.R -c99c6fde8ad4ac47c6d703106aae1350 *tests/testthat/tests.make_standata.R -01549ac202dd07e8a3c51e2f8ff2eefc *tests/testthat/tests.misc.R -bbb1bacf702e516f9bb02fbf1e3ff295 *tests/testthat/tests.posterior_epred.R -65b2c02a257a2c2117569a4aa80ea5a7 *tests/testthat/tests.posterior_predict.R -871c468b74f1f908b8a07f714da4bbdf *tests/testthat/tests.priors.R -0722edbe0eb05a3ceb7abbb42d80be04 *tests/testthat/tests.rename_pars.R -741f832512f242551c4b9807adbebe79 *tests/testthat/tests.restructure.R -0c91c32577cbc8c185fe001848becbe1 *tests/testthat/tests.stan_functions.R -4d677b7dd6922df9e3e0399af379efb2 *vignettes/brms_customfamilies.Rmd -8c3bfb376c70c42e179053f9c1e9c565 *vignettes/brms_distreg.Rmd -24d2a0c1b21e81268a3fe22c085d5da1 *vignettes/brms_families.Rmd -0cab824b02268ac6e3f5deabba37f5e5 *vignettes/brms_missings.Rmd -3df4781dcaace7113283264da54ffee1 *vignettes/brms_monotonic.Rmd -936e753dc84aadef50c46ba07f417011 *vignettes/brms_multilevel.ltx -87e35e5a77cc5e5c27ded17031c52b51 *vignettes/brms_multivariate.Rmd -22819f4acf34913fb947beb0e8799f8b *vignettes/brms_nonlinear.Rmd -0f61eb8dc9644314ad28512597696f8d *vignettes/brms_overview.ltx -f2f5d8f580423d498e25dc5dfcb19c26 *vignettes/brms_phylogenetics.Rmd -feed5725c51eb4429b5b556eda4461ac *vignettes/brms_threading.Rmd -d03511b5b5f0034e974205b90a81e499 *vignettes/citations_multilevel.bib -07ac5ec3d888046289de19638ab18a45 *vignettes/citations_overview.bib +4b51313d63442b5f22ae5df5dd65c902 *man/validate_newdata.Rd +7319bd0394eb784fd80bdef84a73d5c6 *man/validate_prior.Rd +1174c012f645c3dc8f70ef58fe542671 *man/vcov.brmsfit.Rd +dee69387c0a4ef07a8953e4980649c80 *man/waic.brmsfit.Rd +eb94c0cef2e4c20ce9610bd1cc3661b6 *tests/testthat.R +7d17ab2ab674f8c2c73fe7183a2a47e4 *tests/testthat/helpers/insert_refcat_ch.R +3cee71d2f8577174607c3840426b1d8a *tests/testthat/helpers/inv_link_categorical_ch.R +919d639446d3c2ab168cbdcf3bb4336d *tests/testthat/helpers/inv_link_ordinal_ch.R +771dcf586afefa69ae5c82a1c867e845 *tests/testthat/helpers/link_categorical_ch.R +55eff9dc736befdf5b7569a5b0bdf9f1 *tests/testthat/helpers/link_ordinal_ch.R +34a79884fed445b69b7fcd9e4166e531 *tests/testthat/helpers/simopts_catlike.R +83cf80ac0b464e6217fabba119a182c5 *tests/testthat/helpers/simopts_catlike_oneobs.R +984b086239e1ec078f2d326b50d75ff4 *tests/testthat/tests.brm.R +9ca8a7841717c461c28f247391e8af7e *tests/testthat/tests.brmsfit-helpers.R +7e01cc94ac2999ab87694143192326f6 *tests/testthat/tests.brmsfit-methods.R +218087f1991e81f0f9696364227e3dd6 *tests/testthat/tests.brmsformula.R +147d519778a7cd17bdbe0d365c9ea20a *tests/testthat/tests.brmsterms.R +0701b29bcf35b3dc573c0e48e87762fe *tests/testthat/tests.data-helpers.R +dc2a2b5494b4e0f9eb37de285543b66a *tests/testthat/tests.distributions.R +ed2a592a2a4d6cfaf359b86ddde34252 *tests/testthat/tests.emmeans.R +65451b49b0aeda03d07d49ebba424295 *tests/testthat/tests.exclude_pars.R +a66a59e5c60433bb8974b2bfde6ff703 *tests/testthat/tests.families.R +fa12020b362a92da929e4c552bbe24d0 *tests/testthat/tests.log_lik.R +5433870dae8e47ffd42bb43762578da9 *tests/testthat/tests.make_stancode.R +11597dd50c4b14c469b92f6a6c27693a *tests/testthat/tests.make_standata.R +9e74f38ff67944eae6927f0147973509 *tests/testthat/tests.misc.R +27c988453cf1194e268c9d7b5e00f0e0 *tests/testthat/tests.posterior_epred.R +ab17e267459f1d9c759fb99ec9576c54 *tests/testthat/tests.posterior_predict.R +50d4ce0a9700eab22e2fa06ab98bc341 *tests/testthat/tests.priors.R +217e1ec6d85a8964e69621bcac0369c8 *tests/testthat/tests.rename_pars.R +38418ca0c150cb822d4014ecb2ccf4a8 *tests/testthat/tests.restructure.R +65f6180b5a6026b675b6ac1065e49713 *tests/testthat/tests.stan_functions.R +b044a924fbded90c6ca9da8bc01f85cd *vignettes/brms_customfamilies.Rmd +3a1e89b91c2b94282c6df6607f405a89 *vignettes/brms_distreg.Rmd +5ee02c9103d3b08f08c87597328e1fc1 *vignettes/brms_families.Rmd +cdf2b42e1cf561cdf4f1f1f7c06d8148 *vignettes/brms_missings.Rmd +ee62fe59cf57cd22be35969e4c27dc7b *vignettes/brms_monotonic.Rmd +f7cece21fca8fbaaa53a106038349d0c *vignettes/brms_multilevel.ltx +7567746ed5926d36df405b3a22f01eef *vignettes/brms_multivariate.Rmd +1d4ca841f24e6d41d803ea56afbdbbae *vignettes/brms_nonlinear.Rmd +5ae728c35b6cd8d27e69cf0a119e646f *vignettes/brms_overview.ltx +85bd37fc5196318ee06e034c67a50c9a *vignettes/brms_phylogenetics.Rmd +7566e5c0fa0e7d54fa16e0c0f6938e12 *vignettes/brms_threading.Rmd +8e122a174183d81956fefd5f7d9a2b9b *vignettes/citations_multilevel.bib +6ba1d5ec8ecc1031d8845d82dcef11da *vignettes/citations_overview.bib 1e02697a37e36908b7d8954bfaea2e92 *vignettes/flowchart.pdf 598082534ce6cb51d34c01a69dda5088 *vignettes/inhaler_plot.pdf d7d237f55a6850eba15ad5ceeaf821f6 *vignettes/kidney_conditional_effects.pdf diff -Nru r-cran-brms-2.16.3/NAMESPACE r-cran-brms-2.17.0/NAMESPACE --- r-cran-brms-2.16.3/NAMESPACE 2021-11-22 15:27:01.000000000 +0000 +++ r-cran-brms-2.17.0/NAMESPACE 2022-04-11 07:10:19.000000000 +0000 @@ -1,647 +1,661 @@ -# Generated by roxygen2: do not edit by hand - -S3method("+",bform) -S3method("+",brmsprior) -S3method("+",stanvars) -S3method(.compute_point_estimate,brmsprep) -S3method(.compute_point_estimate,mvbrmsprep) -S3method(.extract_par_terms,brmsfit) -S3method(.extract_par_terms,brmsterms) -S3method(.extract_par_terms,mvbrmsterms) -S3method(.ndraws,brmsprep) -S3method(.ndraws,mvbrmsprep) -S3method(.thin_draws,brmsprep) -S3method(.thin_draws,mvbrmsprep) -S3method(.tidy_index,brmsterms) -S3method(.tidy_index,mvbrmsterms) -S3method(LOO,brmsfit) -S3method(VarCorr,brmsfit) -S3method(WAIC,brmsfit) -S3method(add_criterion,brmsfit) -S3method(add_ic,brmsfit) -S3method(as.array,brmsfit) -S3method(as.data.frame,brmsfit) -S3method(as.matrix,brmsfit) -S3method(as.mcmc,brmsfit) -S3method(as_draws,brmsfit) -S3method(as_draws_array,brmsfit) -S3method(as_draws_df,brmsfit) -S3method(as_draws_list,brmsfit) -S3method(as_draws_matrix,brmsfit) -S3method(as_draws_rvars,brmsfit) -S3method(autocor,brmsfit) -S3method(bayes_R2,brmsfit) -S3method(bayes_factor,brmsfit) -S3method(bridge_sampler,brmsfit) -S3method(brmsterms,brmsformula) -S3method(brmsterms,default) -S3method(brmsterms,mvbrmsformula) -S3method(c,brmsprior) -S3method(c,stanvars) -S3method(change_effects,brmsterms) -S3method(change_effects,btl) -S3method(change_effects,default) -S3method(change_effects,mvbrmsterms) -S3method(coef,brmsfit) -S3method(compute_xi,brmsfit) -S3method(compute_xi,brmsprep) -S3method(compute_xi,mvbrmsprep) -S3method(conditional_effects,brmsfit) -S3method(conditional_effects,brmsterms) -S3method(conditional_effects,mvbrmsterms) -S3method(conditional_smooths,brmsfit) -S3method(conditional_smooths,brmsterms) -S3method(conditional_smooths,btl) -S3method(conditional_smooths,default) -S3method(conditional_smooths,mvbrmsterms) -S3method(control_params,brmsfit) -S3method(data_predictor,brmsterms) -S3method(data_predictor,btl) -S3method(data_predictor,btnl) -S3method(data_predictor,mvbrmsterms) -S3method(data_response,brmsterms) -S3method(data_response,mvbrmsterms) -S3method(def_scale_prior,brmsterms) -S3method(def_scale_prior,mvbrmsterms) -S3method(dpar_family,default) -S3method(dpar_family,mixfamily) -S3method(duplicated,brmsprior) -S3method(exclude_pars,brmsfit) -S3method(exclude_pars,brmsterms) -S3method(exclude_pars,btl) -S3method(exclude_pars,default) -S3method(exclude_pars,mvbrmsterms) -S3method(exclude_terms,brmsfit) -S3method(exclude_terms,brmsformula) -S3method(exclude_terms,mvbrmsformula) -S3method(expose_functions,brmsfit) -S3method(family,brmsfit) -S3method(family_bounds,brmsterms) -S3method(family_bounds,mvbrmsterms) -S3method(family_info,brmsfamily) -S3method(family_info,brmsfit) -S3method(family_info,brmsformula) -S3method(family_info,brmsterms) -S3method(family_info,btl) -S3method(family_info,btnl) -S3method(family_info,default) -S3method(family_info,family) -S3method(family_info,list) -S3method(family_info,mixfamily) -S3method(family_info,mvbrmsformula) -S3method(family_info,mvbrmsterms) -S3method(fitted,brmsfit) -S3method(fixef,brmsfit) -S3method(formula,brmsfit) -S3method(getCall,brmsfit) -S3method(get_ad_vars,brmsterms) -S3method(get_ad_vars,mvbrmsterms) -S3method(get_all_effects,brmsterms) -S3method(get_all_effects,btl) -S3method(get_all_effects,btnl) -S3method(get_all_effects,default) -S3method(get_all_effects,mvbrmsterms) -S3method(get_data2_autocor,brmsformula) -S3method(get_data2_autocor,mvbrmsformula) -S3method(get_effect,brmsfit) -S3method(get_effect,brmsformula) -S3method(get_effect,brmsterms) -S3method(get_effect,btl) -S3method(get_effect,btnl) -S3method(get_effect,default) -S3method(get_effect,mvbrmsformula) -S3method(get_effect,mvbrmsterms) -S3method(get_element,default) -S3method(get_element,mvbrmsformula) -S3method(get_element,mvbrmsterms) -S3method(get_group_vars,brmsfit) -S3method(get_group_vars,brmsterms) -S3method(get_group_vars,default) -S3method(get_group_vars,mvbrmsterms) -S3method(get_int_vars,brmsterms) -S3method(get_int_vars,mvbrmsterms) -S3method(get_re,brmsterms) -S3method(get_re,btl) -S3method(get_re,default) -S3method(get_re,mvbrmsterms) -S3method(hypothesis,brmsfit) -S3method(hypothesis,default) -S3method(kfold,brmsfit) -S3method(launch_shinystan,brmsfit) -S3method(logLik,brmsfit) -S3method(log_lik,brmsfit) -S3method(log_lik,brmsprep) -S3method(log_lik,mvbrmsprep) -S3method(log_posterior,brmsfit) -S3method(loo,brmsfit) -S3method(loo_R2,brmsfit) -S3method(loo_compare,brmsfit) -S3method(loo_linpred,brmsfit) -S3method(loo_model_weights,brmsfit) -S3method(loo_moment_match,brmsfit) -S3method(loo_predict,brmsfit) -S3method(loo_predictive_interval,brmsfit) -S3method(loo_subsample,brmsfit) -S3method(marginal_effects,brmsfit) -S3method(marginal_smooths,brmsfit) -S3method(mcmc_plot,brmsfit) -S3method(model.frame,brmsfit) -S3method(model_weights,brmsfit) -S3method(nchains,brmsfit) -S3method(ndraws,brmsfit) -S3method(neff_ratio,brmsfit) -S3method(ngrps,brmsfit) -S3method(niterations,brmsfit) -S3method(nobs,brmsfit) -S3method(nsamples,brmsfit) -S3method(nuts_params,brmsfit) -S3method(nvariables,brmsfit) -S3method(pairs,brmsfit) -S3method(parnames,brmsfit) -S3method(parnames,default) -S3method(plot,brmsMarginalEffects) -S3method(plot,brms_conditional_effects) -S3method(plot,brmsfit) -S3method(plot,brmshypothesis) -S3method(post_prob,brmsfit) -S3method(posterior_average,brmsfit) -S3method(posterior_epred,brmsfit) -S3method(posterior_epred,brmsprep) -S3method(posterior_epred,mvbrmsprep) -S3method(posterior_interval,brmsfit) -S3method(posterior_linpred,brmsfit) -S3method(posterior_predict,brmsfit) -S3method(posterior_predict,brmsprep) -S3method(posterior_predict,mvbrmsprep) -S3method(posterior_samples,brmsfit) -S3method(posterior_samples,default) -S3method(posterior_smooths,brmsfit) -S3method(posterior_smooths,btl) -S3method(posterior_smooths,btnl) -S3method(posterior_summary,brmsfit) -S3method(posterior_summary,default) -S3method(pp_average,brmsfit) -S3method(pp_check,brmsfit) -S3method(pp_mixture,brmsfit) -S3method(predict,brmsfit) -S3method(predictive_error,brmsfit) -S3method(predictive_interval,brmsfit) -S3method(predictor,bprepl) -S3method(predictor,bprepnl) -S3method(prepare_predictions,brmsfit) -S3method(prepare_predictions,brmsterms) -S3method(prepare_predictions,btl) -S3method(prepare_predictions,btnl) -S3method(prepare_predictions,default) -S3method(print,brmsMarginalEffects) -S3method(print,brms_conditional_effects) -S3method(print,brmsfamily) -S3method(print,brmsfit) -S3method(print,brmsformula) -S3method(print,brmshypothesis) -S3method(print,brmsmodel) -S3method(print,brmsprior) -S3method(print,brmssummary) -S3method(print,cor_arma) -S3method(print,cor_brms_formula) -S3method(print,cor_car) -S3method(print,cor_cosy) -S3method(print,cor_empty) -S3method(print,cor_fixed) -S3method(print,cor_sar) -S3method(print,cov_fixed) -S3method(print,customfamily) -S3method(print,iclist) -S3method(print,loolist) -S3method(print,mixfamily) -S3method(print,mvbrmsformula) -S3method(prior_draws,brmsfit) -S3method(prior_draws,default) -S3method(prior_predictor,btl) -S3method(prior_predictor,btnl) -S3method(prior_predictor,default) -S3method(prior_summary,brmsfit) -S3method(r_eff_log_lik,"function") -S3method(r_eff_log_lik,matrix) -S3method(ranef,brmsfit) -S3method(reloo,brmsfit) -S3method(reloo,loo) -S3method(rescale_old_mo,brmsfit) -S3method(rescale_old_mo,brmsterms) -S3method(rescale_old_mo,btl) -S3method(rescale_old_mo,btnl) -S3method(rescale_old_mo,mvbrmsterms) -S3method(residuals,brmsfit) -S3method(rhat,brmsfit) -S3method(stan_log_lik,brmsterms) -S3method(stan_log_lik,family) -S3method(stan_log_lik,mixfamily) -S3method(stan_log_lik,mvbrmsterms) -S3method(stan_predictor,brmsterms) -S3method(stan_predictor,btl) -S3method(stan_predictor,btnl) -S3method(stan_predictor,mvbrmsterms) -S3method(stancode,brmsfit) -S3method(standata,brmsfit) -S3method(standata_basis,brmsterms) -S3method(standata_basis,btl) -S3method(standata_basis,btnl) -S3method(standata_basis,default) -S3method(standata_basis,mvbrmsterms) -S3method(stanplot,brmsfit) -S3method(summarise_families,brmsformula) -S3method(summarise_families,mvbrmsformula) -S3method(summarise_links,brmsformula) -S3method(summarise_links,mvbrmsformula) -S3method(summary,brmsfit) -S3method(summary,customfamily) -S3method(summary,family) -S3method(summary,mixfamily) -S3method(tidy_acef,"NULL") -S3method(tidy_acef,acef) -S3method(tidy_acef,brmsterms) -S3method(tidy_acef,btl) -S3method(tidy_acef,btnl) -S3method(tidy_acef,default) -S3method(tidy_acef,mvbrmsterms) -S3method(unclass_draws,default) -S3method(unclass_draws,draws_df) -S3method(update,brmsfit) -S3method(update,brmsfit_multiple) -S3method(update,brmsformula) -S3method(update,mvbrmsformula) -S3method(update_old_family,brmsfamily) -S3method(update_old_family,brmsformula) -S3method(update_old_family,customfamily) -S3method(update_old_family,default) -S3method(update_old_family,mixfamily) -S3method(update_old_family,mvbrmsformula) -S3method(update_re_terms,brmsformula) -S3method(update_re_terms,formula) -S3method(update_re_terms,mvbrmsformula) -S3method(valid_dpars,brmsfit) -S3method(valid_dpars,brmsformula) -S3method(valid_dpars,brmsterms) -S3method(valid_dpars,default) -S3method(valid_dpars,mixfamily) -S3method(valid_dpars,mvbrmsformula) -S3method(valid_dpars,mvbrmsterms) -S3method(validate_formula,brmsformula) -S3method(validate_formula,default) -S3method(validate_formula,mvbrmsformula) -S3method(validate_prior_special,brmsprior) -S3method(validate_prior_special,brmsterms) -S3method(validate_prior_special,btl) -S3method(validate_prior_special,btnl) -S3method(validate_prior_special,default) -S3method(validate_prior_special,mvbrmsterms) -S3method(variables,brmsfit) -S3method(vars_keep_na,brmsterms) -S3method(vars_keep_na,mvbrmsterms) -S3method(vcov,brmsfit) -S3method(waic,brmsfit) -export("add_ic<-") -export(Beta) -export(LOO) -export(R2D2) -export(VarCorr) -export(WAIC) -export(acat) -export(acformula) -export(add_criterion) -export(add_ic) -export(add_loo) -export(add_rstan_model) -export(add_waic) -export(ar) -export(arma) -export(as.mcmc) -export(as_draws) -export(as_draws_array) -export(as_draws_df) -export(as_draws_list) -export(as_draws_matrix) -export(as_draws_rvars) -export(asym_laplace) -export(autocor) -export(bayes_R2) -export(bayes_factor) -export(bernoulli) -export(bf) -export(bridge_sampler) -export(brm) -export(brm_multiple) -export(brmsfamily) -export(brmsfit_needs_refit) -export(brmsformula) -export(brmsterms) -export(car) -export(categorical) -export(combine_models) -export(compare_ic) -export(conditional_effects) -export(conditional_smooths) -export(control_params) -export(cor_ar) -export(cor_arma) -export(cor_arr) -export(cor_bsts) -export(cor_car) -export(cor_cosy) -export(cor_errorsar) -export(cor_fixed) -export(cor_icar) -export(cor_lagsar) -export(cor_ma) -export(cor_sar) -export(cosy) -export(cox) -export(cratio) -export(cs) -export(cse) -export(cumulative) -export(custom_family) -export(dasym_laplace) -export(data_predictor) -export(data_response) -export(ddirichlet) -export(density_ratio) -export(dexgaussian) -export(dfrechet) -export(dgen_extreme_value) -export(dhurdle_gamma) -export(dhurdle_lognormal) -export(dhurdle_negbinomial) -export(dhurdle_poisson) -export(dinv_gaussian) -export(dirichlet) -export(dmulti_normal) -export(dmulti_student_t) -export(do_call) -export(dshifted_lnorm) -export(dskew_normal) -export(dstudent_t) -export(dvon_mises) -export(dwiener) -export(dzero_inflated_beta) -export(dzero_inflated_binomial) -export(dzero_inflated_negbinomial) -export(dzero_inflated_poisson) -export(empty_prior) -export(exgaussian) -export(exponential) -export(expose_functions) -export(expp1) -export(extract_draws) -export(fcor) -export(fixef) -export(frechet) -export(gen_extreme_value) -export(geometric) -export(get_dpar) -export(get_prior) -export(get_y) -export(gp) -export(gr) -export(horseshoe) -export(hurdle_gamma) -export(hurdle_lognormal) -export(hurdle_negbinomial) -export(hurdle_poisson) -export(hypothesis) -export(inv_logit_scaled) -export(is.brmsfit) -export(is.brmsfit_multiple) -export(is.brmsformula) -export(is.brmsprior) -export(is.brmsterms) -export(is.cor_arma) -export(is.cor_brms) -export(is.cor_car) -export(is.cor_cosy) -export(is.cor_fixed) -export(is.cor_sar) -export(is.mvbrmsformula) -export(is.mvbrmsterms) -export(kfold) -export(kfold_predict) -export(lasso) -export(launch_shinystan) -export(lf) -export(log_lik) -export(log_posterior) -export(logit_scaled) -export(logm1) -export(lognormal) -export(loo) -export(loo_R2) -export(loo_compare) -export(loo_linpred) -export(loo_model_weights) -export(loo_moment_match) -export(loo_predict) -export(loo_predictive_interval) -export(loo_subsample) -export(ma) -export(make_conditions) -export(make_stancode) -export(make_standata) -export(marginal_effects) -export(marginal_smooths) -export(mcmc_plot) -export(me) -export(mi) -export(mixture) -export(mm) -export(mmc) -export(mo) -export(model_weights) -export(multinomial) -export(mvbf) -export(mvbind) -export(mvbrmsformula) -export(nchains) -export(ndraws) -export(neff_ratio) -export(negbinomial) -export(ngrps) -export(niterations) -export(nlf) -export(nsamples) -export(nuts_params) -export(nvariables) -export(opencl) -export(parnames) -export(parse_bf) -export(pasym_laplace) -export(pexgaussian) -export(pfrechet) -export(pgen_extreme_value) -export(phurdle_gamma) -export(phurdle_lognormal) -export(phurdle_negbinomial) -export(phurdle_poisson) -export(pinv_gaussian) -export(post_prob) -export(posterior_average) -export(posterior_epred) -export(posterior_interval) -export(posterior_linpred) -export(posterior_predict) -export(posterior_samples) -export(posterior_smooths) -export(posterior_summary) -export(posterior_table) -export(pp_average) -export(pp_check) -export(pp_expect) -export(pp_mixture) -export(predictive_error) -export(predictive_interval) -export(prepare_predictions) -export(prior) -export(prior_) -export(prior_draws) -export(prior_samples) -export(prior_string) -export(prior_summary) -export(pshifted_lnorm) -export(pskew_normal) -export(pstudent_t) -export(pvon_mises) -export(pzero_inflated_beta) -export(pzero_inflated_binomial) -export(pzero_inflated_negbinomial) -export(pzero_inflated_poisson) -export(qasym_laplace) -export(qfrechet) -export(qshifted_lnorm) -export(qskew_normal) -export(qstudent_t) -export(ranef) -export(rasym_laplace) -export(rdirichlet) -export(recompile_model) -export(reloo) -export(rename_pars) -export(resp_cat) -export(resp_cens) -export(resp_dec) -export(resp_index) -export(resp_mi) -export(resp_rate) -export(resp_se) -export(resp_subset) -export(resp_thres) -export(resp_trials) -export(resp_trunc) -export(resp_vint) -export(resp_vreal) -export(resp_weights) -export(restructure) -export(rexgaussian) -export(rfrechet) -export(rgen_extreme_value) -export(rhat) -export(rinv_gaussian) -export(rmulti_normal) -export(rmulti_student_t) -export(rows2labels) -export(rshifted_lnorm) -export(rskew_normal) -export(rstudent_t) -export(rvon_mises) -export(rwiener) -export(s) -export(sar) -export(save_pars) -export(set_mecor) -export(set_nl) -export(set_prior) -export(set_rescor) -export(shifted_lognormal) -export(skew_normal) -export(sratio) -export(stancode) -export(standata) -export(stanplot) -export(stanvar) -export(student) -export(t2) -export(theme_black) -export(theme_default) -export(threading) -export(update_adterms) -export(validate_newdata) -export(validate_prior) -export(variables) -export(von_mises) -export(waic) -export(weibull) -export(wiener) -export(zero_inflated_beta) -export(zero_inflated_binomial) -export(zero_inflated_negbinomial) -export(zero_inflated_poisson) -export(zero_one_inflated_beta) -import(Rcpp) -import(abind) -import(ggplot2) -import(methods) -import(parallel) -import(stats) -importFrom(bayesplot,log_posterior) -importFrom(bayesplot,neff_ratio) -importFrom(bayesplot,nuts_params) -importFrom(bayesplot,pp_check) -importFrom(bayesplot,rhat) -importFrom(bayesplot,theme_default) -importFrom(bridgesampling,bayes_factor) -importFrom(bridgesampling,bridge_sampler) -importFrom(bridgesampling,post_prob) -importFrom(coda,as.mcmc) -importFrom(grDevices,devAskNewPage) -importFrom(graphics,plot) -importFrom(loo,.compute_point_estimate) -importFrom(loo,.ndraws) -importFrom(loo,.thin_draws) -importFrom(loo,is.loo) -importFrom(loo,kfold) -importFrom(loo,loo) -importFrom(loo,loo_compare) -importFrom(loo,loo_model_weights) -importFrom(loo,loo_moment_match) -importFrom(loo,loo_subsample) -importFrom(loo,waic) -importFrom(nlme,VarCorr) -importFrom(nlme,fixef) -importFrom(nlme,ranef) -importFrom(posterior,as_draws) -importFrom(posterior,as_draws_array) -importFrom(posterior,as_draws_df) -importFrom(posterior,as_draws_list) -importFrom(posterior,as_draws_matrix) -importFrom(posterior,as_draws_rvars) -importFrom(posterior,nchains) -importFrom(posterior,ndraws) -importFrom(posterior,niterations) -importFrom(posterior,nvariables) -importFrom(posterior,subset_draws) -importFrom(posterior,summarize_draws) -importFrom(posterior,variables) -importFrom(rstantools,bayes_R2) -importFrom(rstantools,log_lik) -importFrom(rstantools,loo_R2) -importFrom(rstantools,loo_linpred) -importFrom(rstantools,loo_predict) -importFrom(rstantools,loo_predictive_interval) -importFrom(rstantools,nsamples) -importFrom(rstantools,posterior_epred) -importFrom(rstantools,posterior_interval) -importFrom(rstantools,posterior_linpred) -importFrom(rstantools,posterior_predict) -importFrom(rstantools,predictive_error) -importFrom(rstantools,predictive_interval) -importFrom(rstantools,prior_summary) -importFrom(shinystan,launch_shinystan) -importMethodsFrom(rstan,summary) +# Generated by roxygen2: do not edit by hand + +S3method("+",bform) +S3method("+",brmsprior) +S3method("+",stanvars) +S3method(.compute_point_estimate,brmsprep) +S3method(.compute_point_estimate,mvbrmsprep) +S3method(.extract_par_terms,brmsfit) +S3method(.extract_par_terms,brmsterms) +S3method(.extract_par_terms,mvbrmsterms) +S3method(.ndraws,brmsprep) +S3method(.ndraws,mvbrmsprep) +S3method(.thin_draws,brmsprep) +S3method(.thin_draws,mvbrmsprep) +S3method(.tidy_index,brmsterms) +S3method(.tidy_index,mvbrmsterms) +S3method(LOO,brmsfit) +S3method(VarCorr,brmsfit) +S3method(WAIC,brmsfit) +S3method(add_criterion,brmsfit) +S3method(add_ic,brmsfit) +S3method(as.array,brmsfit) +S3method(as.data.frame,brmsfit) +S3method(as.matrix,brmsfit) +S3method(as.mcmc,brmsfit) +S3method(as_draws,brmsfit) +S3method(as_draws_array,brmsfit) +S3method(as_draws_df,brmsfit) +S3method(as_draws_list,brmsfit) +S3method(as_draws_matrix,brmsfit) +S3method(as_draws_rvars,brmsfit) +S3method(autocor,brmsfit) +S3method(bayes_R2,brmsfit) +S3method(bayes_factor,brmsfit) +S3method(bridge_sampler,brmsfit) +S3method(brmsterms,brmsformula) +S3method(brmsterms,default) +S3method(brmsterms,mvbrmsformula) +S3method(c,brmsprior) +S3method(c,stanvars) +S3method(change_effects,brmsterms) +S3method(change_effects,btl) +S3method(change_effects,default) +S3method(change_effects,mvbrmsterms) +S3method(coef,brmsfit) +S3method(compute_xi,brmsfit) +S3method(compute_xi,brmsprep) +S3method(compute_xi,mvbrmsprep) +S3method(conditional_effects,brmsfit) +S3method(conditional_effects,brmsterms) +S3method(conditional_effects,mvbrmsterms) +S3method(conditional_smooths,brmsfit) +S3method(conditional_smooths,brmsterms) +S3method(conditional_smooths,btl) +S3method(conditional_smooths,default) +S3method(conditional_smooths,mvbrmsterms) +S3method(control_params,brmsfit) +S3method(data_predictor,brmsterms) +S3method(data_predictor,btl) +S3method(data_predictor,btnl) +S3method(data_predictor,mvbrmsterms) +S3method(data_response,brmsterms) +S3method(data_response,mvbrmsterms) +S3method(def_scale_prior,brmsterms) +S3method(def_scale_prior,mvbrmsterms) +S3method(dpar_family,default) +S3method(dpar_family,mixfamily) +S3method(duplicated,brmsprior) +S3method(exclude_pars,brmsfit) +S3method(exclude_pars,brmsterms) +S3method(exclude_pars,btl) +S3method(exclude_pars,default) +S3method(exclude_pars,mvbrmsterms) +S3method(exclude_terms,brmsfit) +S3method(exclude_terms,brmsformula) +S3method(exclude_terms,mvbrmsformula) +S3method(expose_functions,brmsfit) +S3method(family,brmsfit) +S3method(family_bounds,brmsterms) +S3method(family_bounds,mvbrmsterms) +S3method(family_info,brmsfamily) +S3method(family_info,brmsfit) +S3method(family_info,brmsformula) +S3method(family_info,brmsterms) +S3method(family_info,btl) +S3method(family_info,btnl) +S3method(family_info,default) +S3method(family_info,family) +S3method(family_info,list) +S3method(family_info,mixfamily) +S3method(family_info,mvbrmsformula) +S3method(family_info,mvbrmsterms) +S3method(fitted,brmsfit) +S3method(fixef,brmsfit) +S3method(formula,brmsfit) +S3method(getCall,brmsfit) +S3method(get_ad_vars,brmsterms) +S3method(get_ad_vars,mvbrmsterms) +S3method(get_all_effects,brmsterms) +S3method(get_all_effects,btl) +S3method(get_all_effects,btnl) +S3method(get_all_effects,default) +S3method(get_all_effects,mvbrmsterms) +S3method(get_data2_autocor,brmsformula) +S3method(get_data2_autocor,mvbrmsformula) +S3method(get_effect,brmsfit) +S3method(get_effect,brmsformula) +S3method(get_effect,brmsterms) +S3method(get_effect,btl) +S3method(get_effect,btnl) +S3method(get_effect,default) +S3method(get_effect,mvbrmsformula) +S3method(get_effect,mvbrmsterms) +S3method(get_element,default) +S3method(get_element,mvbrmsformula) +S3method(get_element,mvbrmsterms) +S3method(get_group_vars,brmsfit) +S3method(get_group_vars,brmsterms) +S3method(get_group_vars,default) +S3method(get_group_vars,mvbrmsterms) +S3method(get_int_vars,brmsterms) +S3method(get_int_vars,mvbrmsterms) +S3method(get_re,brmsterms) +S3method(get_re,btl) +S3method(get_re,default) +S3method(get_re,mvbrmsterms) +S3method(get_unused_arg_vars,brmsformula) +S3method(get_unused_arg_vars,brmsterms) +S3method(get_unused_arg_vars,mvbrmsformula) +S3method(get_unused_arg_vars,mvbrmsterms) +S3method(hypothesis,brmsfit) +S3method(hypothesis,default) +S3method(kfold,brmsfit) +S3method(launch_shinystan,brmsfit) +S3method(logLik,brmsfit) +S3method(log_lik,brmsfit) +S3method(log_lik,brmsprep) +S3method(log_lik,mvbrmsprep) +S3method(log_posterior,brmsfit) +S3method(loo,brmsfit) +S3method(loo_R2,brmsfit) +S3method(loo_compare,brmsfit) +S3method(loo_linpred,brmsfit) +S3method(loo_model_weights,brmsfit) +S3method(loo_moment_match,brmsfit) +S3method(loo_predict,brmsfit) +S3method(loo_predictive_interval,brmsfit) +S3method(loo_subsample,brmsfit) +S3method(marginal_effects,brmsfit) +S3method(marginal_smooths,brmsfit) +S3method(mcmc_plot,brmsfit) +S3method(model.frame,brmsfit) +S3method(model_weights,brmsfit) +S3method(nchains,brmsfit) +S3method(ndraws,brmsfit) +S3method(neff_ratio,brmsfit) +S3method(ngrps,brmsfit) +S3method(niterations,brmsfit) +S3method(nobs,brmsfit) +S3method(nsamples,brmsfit) +S3method(nuts_params,brmsfit) +S3method(nvariables,brmsfit) +S3method(pairs,brmsfit) +S3method(parnames,brmsfit) +S3method(parnames,default) +S3method(plot,brmsMarginalEffects) +S3method(plot,brms_conditional_effects) +S3method(plot,brmsfit) +S3method(plot,brmshypothesis) +S3method(post_prob,brmsfit) +S3method(posterior_average,brmsfit) +S3method(posterior_epred,brmsfit) +S3method(posterior_epred,brmsprep) +S3method(posterior_epred,mvbrmsprep) +S3method(posterior_interval,brmsfit) +S3method(posterior_linpred,brmsfit) +S3method(posterior_predict,brmsfit) +S3method(posterior_predict,brmsprep) +S3method(posterior_predict,mvbrmsprep) +S3method(posterior_samples,brmsfit) +S3method(posterior_samples,default) +S3method(posterior_smooths,brmsfit) +S3method(posterior_smooths,btl) +S3method(posterior_smooths,btnl) +S3method(posterior_summary,brmsfit) +S3method(posterior_summary,default) +S3method(pp_average,brmsfit) +S3method(pp_check,brmsfit) +S3method(pp_mixture,brmsfit) +S3method(predict,brmsfit) +S3method(predictive_error,brmsfit) +S3method(predictive_interval,brmsfit) +S3method(predictor,bprepl) +S3method(predictor,bprepnl) +S3method(prepare_predictions,brmsfit) +S3method(prepare_predictions,brmsterms) +S3method(prepare_predictions,btl) +S3method(prepare_predictions,btnl) +S3method(prepare_predictions,default) +S3method(print,brmsMarginalEffects) +S3method(print,brms_conditional_effects) +S3method(print,brmsfamily) +S3method(print,brmsfit) +S3method(print,brmsformula) +S3method(print,brmshypothesis) +S3method(print,brmsmodel) +S3method(print,brmsprior) +S3method(print,brmssummary) +S3method(print,cor_arma) +S3method(print,cor_brms_formula) +S3method(print,cor_car) +S3method(print,cor_cosy) +S3method(print,cor_empty) +S3method(print,cor_fixed) +S3method(print,cor_sar) +S3method(print,cov_fixed) +S3method(print,customfamily) +S3method(print,iclist) +S3method(print,loolist) +S3method(print,mixfamily) +S3method(print,mvbrmsformula) +S3method(prior_draws,brmsfit) +S3method(prior_draws,default) +S3method(prior_predictor,btl) +S3method(prior_predictor,btnl) +S3method(prior_predictor,default) +S3method(prior_summary,brmsfit) +S3method(r_eff_log_lik,"function") +S3method(r_eff_log_lik,matrix) +S3method(ranef,brmsfit) +S3method(reloo,brmsfit) +S3method(reloo,loo) +S3method(rescale_old_mo,brmsfit) +S3method(rescale_old_mo,brmsterms) +S3method(rescale_old_mo,btl) +S3method(rescale_old_mo,btnl) +S3method(rescale_old_mo,mvbrmsterms) +S3method(residuals,brmsfit) +S3method(rhat,brmsfit) +S3method(stan_log_lik,brmsterms) +S3method(stan_log_lik,family) +S3method(stan_log_lik,mixfamily) +S3method(stan_log_lik,mvbrmsterms) +S3method(stan_predictor,brmsterms) +S3method(stan_predictor,btl) +S3method(stan_predictor,btnl) +S3method(stan_predictor,mvbrmsterms) +S3method(stancode,brmsfit) +S3method(standata,brmsfit) +S3method(standata_basis,brmsterms) +S3method(standata_basis,btl) +S3method(standata_basis,btnl) +S3method(standata_basis,default) +S3method(standata_basis,mvbrmsterms) +S3method(stanplot,brmsfit) +S3method(summarise_families,brmsformula) +S3method(summarise_families,mvbrmsformula) +S3method(summarise_links,brmsformula) +S3method(summarise_links,mvbrmsformula) +S3method(summary,brmsfit) +S3method(summary,customfamily) +S3method(summary,family) +S3method(summary,mixfamily) +S3method(tidy_acef,"NULL") +S3method(tidy_acef,acef) +S3method(tidy_acef,brmsterms) +S3method(tidy_acef,btl) +S3method(tidy_acef,btnl) +S3method(tidy_acef,default) +S3method(tidy_acef,mvbrmsterms) +S3method(unclass_draws,default) +S3method(unclass_draws,draws_df) +S3method(update,brmsfit) +S3method(update,brmsfit_multiple) +S3method(update,brmsformula) +S3method(update,mvbrmsformula) +S3method(update_old_family,brmsfamily) +S3method(update_old_family,brmsformula) +S3method(update_old_family,customfamily) +S3method(update_old_family,default) +S3method(update_old_family,mixfamily) +S3method(update_old_family,mvbrmsformula) +S3method(update_re_terms,brmsformula) +S3method(update_re_terms,formula) +S3method(update_re_terms,mvbrmsformula) +S3method(valid_dpars,brmsfit) +S3method(valid_dpars,brmsformula) +S3method(valid_dpars,brmsterms) +S3method(valid_dpars,default) +S3method(valid_dpars,mixfamily) +S3method(valid_dpars,mvbrmsformula) +S3method(valid_dpars,mvbrmsterms) +S3method(validate_formula,brmsformula) +S3method(validate_formula,default) +S3method(validate_formula,mvbrmsformula) +S3method(validate_prior_special,brmsprior) +S3method(validate_prior_special,brmsterms) +S3method(validate_prior_special,btl) +S3method(validate_prior_special,btnl) +S3method(validate_prior_special,default) +S3method(validate_prior_special,mvbrmsterms) +S3method(variables,brmsfit) +S3method(vars_keep_na,brmsterms) +S3method(vars_keep_na,mvbrmsterms) +S3method(vcov,brmsfit) +S3method(waic,brmsfit) +export("add_ic<-") +export(Beta) +export(LOO) +export(R2D2) +export(VarCorr) +export(WAIC) +export(acat) +export(acformula) +export(add_criterion) +export(add_ic) +export(add_loo) +export(add_rstan_model) +export(add_waic) +export(ar) +export(arma) +export(as.mcmc) +export(as_draws) +export(as_draws_array) +export(as_draws_df) +export(as_draws_list) +export(as_draws_matrix) +export(as_draws_rvars) +export(asym_laplace) +export(autocor) +export(bayes_R2) +export(bayes_factor) +export(bernoulli) +export(beta_binomial) +export(bf) +export(bridge_sampler) +export(brm) +export(brm_multiple) +export(brmsfamily) +export(brmsfit_needs_refit) +export(brmsformula) +export(brmsterms) +export(car) +export(categorical) +export(combine_models) +export(compare_ic) +export(conditional_effects) +export(conditional_smooths) +export(control_params) +export(cor_ar) +export(cor_arma) +export(cor_arr) +export(cor_bsts) +export(cor_car) +export(cor_cosy) +export(cor_errorsar) +export(cor_fixed) +export(cor_icar) +export(cor_lagsar) +export(cor_ma) +export(cor_sar) +export(cosy) +export(cox) +export(cratio) +export(cs) +export(cse) +export(cumulative) +export(custom_family) +export(dasym_laplace) +export(data_predictor) +export(data_response) +export(dbeta_binomial) +export(ddirichlet) +export(density_ratio) +export(dexgaussian) +export(dfrechet) +export(dgen_extreme_value) +export(dhurdle_gamma) +export(dhurdle_lognormal) +export(dhurdle_negbinomial) +export(dhurdle_poisson) +export(dinv_gaussian) +export(dirichlet) +export(dlogistic_normal) +export(dmulti_normal) +export(dmulti_student_t) +export(do_call) +export(dshifted_lnorm) +export(dskew_normal) +export(dstudent_t) +export(dvon_mises) +export(dwiener) +export(dzero_inflated_beta) +export(dzero_inflated_beta_binomial) +export(dzero_inflated_binomial) +export(dzero_inflated_negbinomial) +export(dzero_inflated_poisson) +export(empty_prior) +export(exgaussian) +export(exponential) +export(expose_functions) +export(expp1) +export(extract_draws) +export(fcor) +export(fixef) +export(frechet) +export(gen_extreme_value) +export(geometric) +export(get_dpar) +export(get_prior) +export(get_y) +export(gp) +export(gr) +export(horseshoe) +export(hurdle_gamma) +export(hurdle_lognormal) +export(hurdle_negbinomial) +export(hurdle_poisson) +export(hypothesis) +export(inv_logit_scaled) +export(is.brmsfit) +export(is.brmsfit_multiple) +export(is.brmsformula) +export(is.brmsprior) +export(is.brmsterms) +export(is.cor_arma) +export(is.cor_brms) +export(is.cor_car) +export(is.cor_cosy) +export(is.cor_fixed) +export(is.cor_sar) +export(is.mvbrmsformula) +export(is.mvbrmsterms) +export(kfold) +export(kfold_predict) +export(lasso) +export(launch_shinystan) +export(lf) +export(log_lik) +export(log_posterior) +export(logistic_normal) +export(logit_scaled) +export(logm1) +export(lognormal) +export(loo) +export(loo_R2) +export(loo_compare) +export(loo_linpred) +export(loo_model_weights) +export(loo_moment_match) +export(loo_predict) +export(loo_predictive_interval) +export(loo_subsample) +export(ma) +export(make_conditions) +export(make_stancode) +export(make_standata) +export(marginal_effects) +export(marginal_smooths) +export(mcmc_plot) +export(me) +export(mi) +export(mixture) +export(mm) +export(mmc) +export(mo) +export(model_weights) +export(multinomial) +export(mvbf) +export(mvbind) +export(mvbrmsformula) +export(nchains) +export(ndraws) +export(neff_ratio) +export(negbinomial) +export(ngrps) +export(niterations) +export(nlf) +export(nsamples) +export(nuts_params) +export(nvariables) +export(opencl) +export(parnames) +export(parse_bf) +export(pasym_laplace) +export(pbeta_binomial) +export(pexgaussian) +export(pfrechet) +export(pgen_extreme_value) +export(phurdle_gamma) +export(phurdle_lognormal) +export(phurdle_negbinomial) +export(phurdle_poisson) +export(pinv_gaussian) +export(post_prob) +export(posterior_average) +export(posterior_epred) +export(posterior_interval) +export(posterior_linpred) +export(posterior_predict) +export(posterior_samples) +export(posterior_smooths) +export(posterior_summary) +export(posterior_table) +export(pp_average) +export(pp_check) +export(pp_expect) +export(pp_mixture) +export(predictive_error) +export(predictive_interval) +export(prepare_predictions) +export(prior) +export(prior_) +export(prior_draws) +export(prior_samples) +export(prior_string) +export(prior_summary) +export(pshifted_lnorm) +export(pskew_normal) +export(pstudent_t) +export(pvon_mises) +export(pzero_inflated_beta) +export(pzero_inflated_beta_binomial) +export(pzero_inflated_binomial) +export(pzero_inflated_negbinomial) +export(pzero_inflated_poisson) +export(qasym_laplace) +export(qfrechet) +export(qshifted_lnorm) +export(qskew_normal) +export(qstudent_t) +export(ranef) +export(rasym_laplace) +export(rbeta_binomial) +export(rdirichlet) +export(recompile_model) +export(reloo) +export(rename_pars) +export(resp_cat) +export(resp_cens) +export(resp_dec) +export(resp_index) +export(resp_mi) +export(resp_rate) +export(resp_se) +export(resp_subset) +export(resp_thres) +export(resp_trials) +export(resp_trunc) +export(resp_vint) +export(resp_vreal) +export(resp_weights) +export(restructure) +export(rexgaussian) +export(rfrechet) +export(rgen_extreme_value) +export(rhat) +export(rinv_gaussian) +export(rlogistic_normal) +export(rmulti_normal) +export(rmulti_student_t) +export(rows2labels) +export(rshifted_lnorm) +export(rskew_normal) +export(rstudent_t) +export(rvon_mises) +export(rwiener) +export(s) +export(sar) +export(save_pars) +export(set_mecor) +export(set_nl) +export(set_prior) +export(set_rescor) +export(shifted_lognormal) +export(skew_normal) +export(sratio) +export(stancode) +export(standata) +export(stanplot) +export(stanvar) +export(student) +export(t2) +export(theme_black) +export(theme_default) +export(threading) +export(update_adterms) +export(validate_newdata) +export(validate_prior) +export(variables) +export(von_mises) +export(waic) +export(weibull) +export(wiener) +export(zero_inflated_beta) +export(zero_inflated_beta_binomial) +export(zero_inflated_binomial) +export(zero_inflated_negbinomial) +export(zero_inflated_poisson) +export(zero_one_inflated_beta) +import(Rcpp) +import(abind) +import(ggplot2) +import(methods) +import(parallel) +import(stats) +importFrom(bayesplot,log_posterior) +importFrom(bayesplot,neff_ratio) +importFrom(bayesplot,nuts_params) +importFrom(bayesplot,pp_check) +importFrom(bayesplot,rhat) +importFrom(bayesplot,theme_default) +importFrom(bridgesampling,bayes_factor) +importFrom(bridgesampling,bridge_sampler) +importFrom(bridgesampling,post_prob) +importFrom(coda,as.mcmc) +importFrom(grDevices,devAskNewPage) +importFrom(graphics,plot) +importFrom(loo,.compute_point_estimate) +importFrom(loo,.ndraws) +importFrom(loo,.thin_draws) +importFrom(loo,is.loo) +importFrom(loo,kfold) +importFrom(loo,loo) +importFrom(loo,loo_compare) +importFrom(loo,loo_model_weights) +importFrom(loo,loo_moment_match) +importFrom(loo,loo_subsample) +importFrom(loo,waic) +importFrom(nlme,VarCorr) +importFrom(nlme,fixef) +importFrom(nlme,ranef) +importFrom(posterior,as_draws) +importFrom(posterior,as_draws_array) +importFrom(posterior,as_draws_df) +importFrom(posterior,as_draws_list) +importFrom(posterior,as_draws_matrix) +importFrom(posterior,as_draws_rvars) +importFrom(posterior,nchains) +importFrom(posterior,ndraws) +importFrom(posterior,niterations) +importFrom(posterior,nvariables) +importFrom(posterior,subset_draws) +importFrom(posterior,summarize_draws) +importFrom(posterior,variables) +importFrom(rstantools,bayes_R2) +importFrom(rstantools,log_lik) +importFrom(rstantools,loo_R2) +importFrom(rstantools,loo_linpred) +importFrom(rstantools,loo_predict) +importFrom(rstantools,loo_predictive_interval) +importFrom(rstantools,nsamples) +importFrom(rstantools,posterior_epred) +importFrom(rstantools,posterior_interval) +importFrom(rstantools,posterior_linpred) +importFrom(rstantools,posterior_predict) +importFrom(rstantools,predictive_error) +importFrom(rstantools,predictive_interval) +importFrom(rstantools,prior_summary) +importFrom(shinystan,launch_shinystan) +importMethodsFrom(rstan,summary) diff -Nru r-cran-brms-2.16.3/NEWS.md r-cran-brms-2.17.0/NEWS.md --- r-cran-brms-2.16.3/NEWS.md 2021-11-22 15:39:33.000000000 +0000 +++ r-cran-brms-2.17.0/NEWS.md 2022-04-08 12:23:23.000000000 +0000 @@ -1,3 +1,44 @@ +# brms 2.17.0 + +### New Features + +* Add full user control for boundaries of most parameters via the `lb` and +`ub` arguments of `set_prior` and related functions. (#878, #1094) +* Add family `logistic_normal` for simplex responses. (#1274) +* Add argument `future_args` to `kfold` and `reloo` for additional +control over parallel execution via futures. +* Add families `beta_binomial` & `zero_inflated_beta_binomial` for potentially +over-dispersed and zero-inflated binomial response models thanks to Hayden +Rabel. (#1319 & #1311) +* Display `ppd_*` plots in `pp_check` via argument `prefix`. (#1313) +* Support the `log` link in binomial and beta type families. (#1316) + +### Other changes + +* Argument `brms_seed` has been added to `get_refmodel.brmsfit()`. (#1287) +* Deprecate argument `inits` in favor of `init` for consistency +with the Stan backends. +* Improve speed of the `summary` method for high-dimensional models. (#1330) + +### Bug Fixes + +* Fix Stan code of threaded multivariate models +thanks to Anirban Mukherjee. (#1277) +* Fix usage of `int_conditions` in `conditional_smooths` +thanks to Urs Kalbitzer. (#1280) +* Fix an error sometimes occurring for multilevel (reference) models in +`projpred`'s K-fold CV. (#1286) +* Fix response values in `make_standata` for `bernoulli` families +when only 1s are present thanks to Facundo Munoz. (#1298) +* Fix `pp_check` for censored responses to work for all plot types +thanks to Hayden Rabel. (#1327) +* Ensure that argument `overwrite` in `add_criterion` works as expected +for all criteria thanks to Andrew Milne. (#1323) +* Fix a problem in `launch_shinystan` occurring when warmup draws +were saved thanks to Frank Weber. (#1257, #1329) +* Fix numerical stability problems in `log_lik` for ordinal models. (#1192) + + # brms 2.16.3 ### Other changes @@ -30,37 +71,37 @@ ### New Features * Support several methods of the `posterior` package. (#1204) -* Substantially extend compatibility of `brms` models +* Substantially extend compatibility of `brms` models with `emmeans` thanks to Mattan S. Ben-Shachar. (#907, #1134) * Combine missing value (`mi`) terms with `subset` addition terms. (#1063) -* Expose function `get_dpar` for use in the post-processing +* Expose function `get_dpar` for use in the post-processing of custom families thank to Martin Modrak. (#1131) * Support the `squareplus` link function in all families and distributional parameters that also allow for the `log` link function. * Add argument `incl_thres` to `posterior_linpred.brmsfit()` allowing to subtract the threshold-excluding linear predictor from the thresholds in case of an ordinal family. (#1137) -* Add a `"mock"` backend option to facilitate testing +* Add a `"mock"` backend option to facilitate testing thanks to Martin Modrak. (#1116) * Add option `file_refit = "always"` to always overwrite models stored via the `file` argument. (#1151) * Initial GPU support via OpenCL thanks to the help Rok Češnovar. (#1166) * Support argument `robust` in method `hypothesis`. (#1170) -* Vectorize the Stan code of custom likelihoods via +* Vectorize the Stan code of custom likelihoods via argument `loop` of `custom_family`. (#1084) * Experimentally allow category specific effects for ordinal `cumulative` models. (#1060) * Regenerate Stan code of an existing model via argument `regenerate` of method `stancode`. -* Support `expose_functions` for models fitted with the +* Support `expose_functions` for models fitted with the `cmdstanr` backend thanks to Sebastian Weber. (#1176) -* Support `log_prob` and related functionality in models fitted +* Support `log_prob` and related functionality in models fitted with the `cmdstanr` backend via function `add_rstan_model`. (#1184) ### Other Changes -* Remove use of `cbind` to express multivariate models after +* Remove use of `cbind` to express multivariate models after over two years of deprecation (please use `mvbind` instead). * Method `posterior_linpred(transform = TRUE)` is now equal to `posterior_epred(dpar = "mu")` and no longer deprecated. @@ -80,11 +121,11 @@ * Fix an issue with default baseline hazard knots in `cox` models thanks to Malcolm Gillies. (#1143) * Fix a bug in non-linear models caused by accidental -merging of operators in the non-linear formula +merging of operators in the non-linear formula thanks to Fernando Miguez. (#1142) * Correctly trigger a refit for `file_refit = "on_change"` if factor level names have changed thanks to Martin Modrak. (#1128) -* Validate factors in `validate_newdata` even when they are simultaneously +* Validate factors in `validate_newdata` even when they are simultaneously used as predictors and grouping variables thanks to Martin Modrak. (#1141) * Fix a bug in the Stan code generation of threaded mixture models with predicted mixture probabilities thanks to Riccardo Fusaroli. (#1150) @@ -94,7 +135,7 @@ parameters thanks to Sebastian Weber. * Fix an issue in the Stan code of threaded non-looped non-linear models thanks to Sebastian Weber. (#1175) -* Fix problems in the post-processing of multivariate meta-analytic +* Fix problems in the post-processing of multivariate meta-analytic models that could lead to incorrect handling of known standard errors. @@ -111,7 +152,7 @@ * Apply the R2-D2 shrinkage prior to population-level coefficients via function `R2D2` to be used in `set_prior`. * Extend support for `arma` correlation structures in non-normal families. -* Extend scope of variables passed via `data2` for use in the +* Extend scope of variables passed via `data2` for use in the evaluation of most model terms. * Refit models previously stored on disc only when necessary thanks to Martin Modrak. The behavior can be controlled via `file_refit`. (#1058) @@ -122,12 +163,12 @@ ### Other Changes -* Improve numerical stability of ordinal sequential models +* Improve numerical stability of ordinal sequential models (families `sratio` and `cratio`) thanks to Andrew Johnson. (#1087) ### Bug Fixes -* Allow fitting `multinomial` models with the +* Allow fitting `multinomial` models with the `cmdstanr` backend thanks to Andrew Johnson. (#1033) * Allow user-defined Stan functions in threaded models. (#1034) * Allow usage of the `:` operator in autocorrelation terms. @@ -143,7 +184,7 @@ `by` variables thanks to Reece Willoughby. (#1081) * Fix a bug in the threaded Stan code when using QR decomposition thanks to Steve Bronder. (#1086) -* Include offsets in `emmeans` related methods thanks to +* Include offsets in `emmeans` related methods thanks to Russell V. Lenth. (#1096) @@ -163,7 +204,7 @@ * Allow `se` addition terms in threaded models. * Allow `categorical` families in threaded models. * Fix updating of parameters in `loo_moment_match`. -* Fix facet labels in `conditional_effects` thanks +* Fix facet labels in `conditional_effects` thanks to Isaac Petersen. (#1014) @@ -179,27 +220,27 @@ * Combine `by` variables and within-group correlation matrices in group-level terms. (#674) * Add argument `robust` to the `summary` method. (#976) -* Parallelize evaluation of the `posterior_predict` and `log_lik` +* Parallelize evaluation of the `posterior_predict` and `log_lik` methods via argument `cores`. (#819) * Compute effective number of parameters in `kfold`. -* Show prior sources and vectorization in the `print` output +* Show prior sources and vectorization in the `print` output of `brmsprior` objects. (#761) -* Store unused variables in the model's data frame via +* Store unused variables in the model's data frame via argument `unused` of function `brmsformula`. -* Support posterior mean predictions in `emmeans` via +* Support posterior mean predictions in `emmeans` via `dpar = "mean"` thanks to Russell V. Lenth. (#993) -* Improve control of which parameters should be saved via +* Improve control of which parameters should be saved via function `save_pars` and corresponding argument in `brm`. (#746) * Add method `posterior_smooths` to computing predictions of individual smooth terms. (#738) -* Allow to display grouping variables in `conditional_effects` +* Allow to display grouping variables in `conditional_effects` using the `effects` argument. (#1012) ### Other Changes * Improve sampling efficiency for a lot of models by using Stan's GLM-primitives even in non-GLM cases. (#984) -* Improve sampling efficiency of multilevel models with +* Improve sampling efficiency of multilevel models with within-group covariances thanks to David Westergaard. (#977) * Deprecate argument `probs` in the `conditional_effects` method in favor of argument `prob`. @@ -216,15 +257,15 @@ ### New Features -* Support the Cox proportional hazards model for +* Support the Cox proportional hazards model for time-to-event data via family `cox`. (#230, #962) * Support method `loo_moment_match`, which can be used to update a `loo` object when Pareto k estimates are large. ### Other Changes -* Improve the prediction behavior in post-processing methods -when sampling new levels of grouping factors via +* Improve the prediction behavior in post-processing methods +when sampling new levels of grouping factors via `sample_new_levels = "uncertainty"`. (#956) ### Bug Fixes @@ -267,22 +308,22 @@ Marta Kołczyńska. * Support `posterior_linpred` as method in `conditional_effects`. * Use `std_normal` in the Stan code for improved efficiency. -* Add arguments `cor`, `id`, and `cov` to the functions `gr` and +* Add arguments `cor`, `id`, and `cov` to the functions `gr` and `mm` for easy specification of group-level correlation structures. * Improve workflow to feed back brms-created models which were fitted somewhere else back into brms. (#745) * Improve argument `int_conditions` in `conditional_effects` to work for all predictors not just interactions. -* Support multiple imputation of data passed via `data2` in +* Support multiple imputation of data passed via `data2` in `brm_multiple`. (#886) -* Fully support the `emmeans` package thanks to the help +* Fully support the `emmeans` package thanks to the help of Russell V. Lenth. (#418) -* Control the within-block position of Stan code added via +* Control the within-block position of Stan code added via `stanvar` using the `position` argument. ### Bug Fixes -* Fix issue in Stan code of models with multiple `me` terms +* Fix issue in Stan code of models with multiple `me` terms thanks to Chris Chatham. (#855, #856) * Fix scaling problems in the estimation of ordinal models with multiple threshold vectors thanks to Marta Kołczyńska and @@ -290,18 +331,18 @@ * Allow usage of `std_normal` in `set_prior` thanks to Ben Goodrich. (#867) * Fix Stan code of distributional models with `weibull`, `frechet`, or `inverse.gaussian` families thanks to Brian Huey and Jack Caster. (#879) -* Fix Stan code of models which are truncated and weighted at the +* Fix Stan code of models which are truncated and weighted at the same time thanks to Michael Thompson. (#884) * Fix Stan code of multivariate models with custom families and data variables passed to the likelihood thanks to Raoul Wolf. (#906) - + ### Other Changes * Reduce minimal scale of several default priors from 10 to 2.5. The resulting priors should remain weakly informative. * Automatically group observations in `gp` for increased efficiency. * Rename `parse_bf` to `brmsterms` and deprecate the former function. -* Rename `extract_draws` to `prepare_predictions` and deprecate +* Rename `extract_draws` to `prepare_predictions` and deprecate the former function. * Deprecate using a model-dependent `rescor` default. * Deprecate argument `cov_ranef` in `brm` and related functions. @@ -335,7 +376,7 @@ thanks to Ivan Ukhov. * Fix selection of group-level terms via `re_formula` in multivariate models thanks to Maxime Dahirel. (#834) -* Enforce correct ordering of terms in `re_formula` +* Enforce correct ordering of terms in `re_formula` thanks to @ferberkl. (#844) * Fix post-processing of multivariate multilevel models when multiple IDs are used for the same grouping factor @@ -344,14 +385,14 @@ output of `posterior_predict` again thanks to Mattew Kay. (#838) * Handle `NA` values more consistently in `posterior_table` thanks to Anna Hake. (#845) -* Fix a bug in the Stan code of models with multiple monotonic +* Fix a bug in the Stan code of models with multiple monotonic varying effects across different groups thanks to Julian Quandt. ### Other Changes * Rename `offset` variables to `offsets` in the generated Stan code as the former will be reserved in the new stanc3 compiler. - + # brms 2.11.1 @@ -359,18 +400,18 @@ * Fix version requirement of the `loo` package. * Fix effective sample size note in the `summary` output. (#824) -* Fix an edge case in the handling of covariates in +* Fix an edge case in the handling of covariates in special terms thanks to Andrew Milne. (#823) * Allow restructuring objects multiple times with different brms versions thanks to Jonathan A. Nations. (#828) -* Fix validation of ordered factors in `newdata` +* Fix validation of ordered factors in `newdata` thanks to Andrew Milne. (#830) # brms 2.11.0 ### New Features -* Support grouped ordinal threshold vectors via addition +* Support grouped ordinal threshold vectors via addition argument `resp_thres`. (#675) * Support method `loo_subsample` for performing approximate leave-one-out cross-validation for large data. @@ -378,7 +419,7 @@ ### Bug Fixes -* Fix prediction uncertainties of new group levels for +* Fix prediction uncertainties of new group levels for `sample_new_levels = "uncertainty"` thanks to Dominic Magirr. (#779) * Fix problems when using `pp_check` on censored models thanks to Andrew Milne. (#744) @@ -389,9 +430,9 @@ * Fix out-of-sample predictions of AR models when predicting more than one step ahead. * Fix problems when using `reloo` or `kfold` with CAR models. -* Fix problems when using `fitted(..., scale = "linear")` with +* Fix problems when using `fitted(..., scale = "linear")` with multinomial models thanks to Santiago Olivella. (#770) -* Fix problems in the `as.mcmc` method for thinned models +* Fix problems in the `as.mcmc` method for thinned models thanks to @hoxo-m. (#811) * Fix problems in parsing covariates of special effects terms thanks to Riccardo Fusaroli (#813) @@ -402,7 +443,7 @@ `marginal_smooths` to `conditional_smooths`. (#735) * Rename `stanplot` to `mcmc_plot`. * Add method `pp_expect` as an alias of `fitted`. (#644) -* Model fit criteria computed via `add_criterion` are now +* Model fit criteria computed via `add_criterion` are now stored in the `brmsfit$criteria` slot. * Deprecate `resp_cat` in favor of `resp_thres`. * Deprecate specifying global priors on regression coefficients @@ -422,11 +463,11 @@ * Pass real and integer data vectors to custom families via the addition arguments `vreal` and `vint`. (#707) * Model compound symmetry correlations via `cor_cosy`. (#403) -* Predict `sigma` in combination with several +* Predict `sigma` in combination with several autocorrelation structures. (#403) * Use addition term `rate` to conveniently handle denominators of rate responses in log-linear models. -* Fit BYM2 CAR models via `cor_car` thanks to the case study +* Fit BYM2 CAR models via `cor_car` thanks to the case study and help of Mitzi Morris. ### Other Changes @@ -435,10 +476,10 @@ thanks to the GitHub user aslez. (#680) * No longer allow changing the boundaries of autocorrelation parameters. -* Set the number of trials to 1 by default in +* Set the number of trials to 1 by default in `marginal_effects` if not specified otherwise. (#718) * Use non-standard evaluation for addition terms. -* Name temporary intercept parameters more consistently +* Name temporary intercept parameters more consistently in the Stan code. ### Bug Fixes @@ -455,8 +496,8 @@ of categorical responses thanks to Emmanuel Charpentier. (#672) * Fix Stan code of multivariate models with multi-membership terms thanks to the Stan discourse user Pia. -* Improve checks for non-standard variable names -thanks to Ryan Holbrook. (#721) +* Improve checks for non-standard variable names +thanks to Ryan Holbrook. (#721) * Fix problems when plotting facetted spaghetti plots via `marginal_smooths` thanks to Gavin Simpson. (#740) @@ -468,7 +509,7 @@ * Specify non-linear ordinal models. (#623) * Allow to fix thresholds in ordinal mixture models (#626) * Use the `softplus` link function in various families. (#622) -* Use QR decomposition of design matrices via argument +* Use QR decomposition of design matrices via argument `decomp` of `brmsformula` thanks to the help of Ben Goodrich. (#640) * Define argument `sparse` separately for each model formula. * Allow using `bayes_R2` and `loo_R2` with ordinal models. (#639) @@ -476,9 +517,9 @@ ### Other Changes -* Change the parameterization of monotonic effects to +* Change the parameterization of monotonic effects to improve their interpretability. (#578) -* No longer support the `cor_arr` and `cor_bsts` correlation +* No longer support the `cor_arr` and `cor_bsts` correlation structures after a year of deprecation. * Refactor internal evaluation of special predictor terms. * Improve penalty of splines thanks to Ben Goodrich @@ -488,13 +529,13 @@ * Fix a problem when applying `marginal_effects` to measurement error models thanks to Jonathan A. Nations. (#636) -* Fix computation of log-likelihood values for weighted +* Fix computation of log-likelihood values for weighted mixture models. -* Fix computation of fitted values for truncated lognormal +* Fix computation of fitted values for truncated lognormal and weibull models. * Fix checking of response boundaries for models with missing values thanks to Lucas Deschamps. -* Fix Stan code of multivariate models with both residual +* Fix Stan code of multivariate models with both residual correlations and missing value terms thanks to Solomon Kurz. * Fix problems with interactions of special terms when extracting variable names in `marginal_effects`. @@ -510,7 +551,7 @@ * Fit Dirichlet models via family `dirichlet`. (#463) * Fit conditional logistic models using the `categorical` and `multinomial` families together with non-linear formula syntax. (#560) -* Choose the reference category of `categorical` and related +* Choose the reference category of `categorical` and related families via argument `refcat` of the corresponding family functions. * Use different subsets of the data in different univariate parts of a multivariate model via addition argument `subset`. (#360) @@ -524,9 +565,9 @@ * Deprecate `compare_ic` and instead recommend `loo_compare` for the comparison of `loo` objects to ensure consistency between packages. (#414) * Use the **glue** package in the Stan code generation. (#549) -* Introduce `mvbind` to eventually replace `cbind` +* Introduce `mvbind` to eventually replace `cbind` in the formula syntax of multivariate models. -* Validate several sampling-related arguments in +* Validate several sampling-related arguments in `brm` before compiling the Stan model. (#576) * Show evaluated vignettes on CRAN again. (#591) * Export function `get_y` which is used to extract response @@ -534,17 +575,17 @@ ### Bug fixes -* Fix an error when trying to change argument `re_formula` +* Fix an error when trying to change argument `re_formula` in `bayes_R2` thanks to the GitHub user emieldl. (#592) * Fix occasional problems when running chains in parallel via the **future** package thanks to Jared Knowles. (#579) * Ensure correct ordering of response categories in ordinal models thanks to Jonas Kristoffer Lindelov. (#580) -* Ignore argument `resp` of `marginal_effects` in +* Ignore argument `resp` of `marginal_effects` in univariate models thanks to Vassilis Kehayas. (#589) * Correctly disable cell-mean coding in varying effects. * Allow to fix parameter `ndt` in drift diffusion models. -* Fix Stan code for t-distributed varying effects +* Fix Stan code for t-distributed varying effects thanks to Ozgur Asar. * Fix an error in the post-processing of monotonic effects occurring for multivariate models thanks to James Rae. (#598) @@ -560,11 +601,11 @@ ### New features * Fit approximate and non-isotropic Gaussian processes via `gp`. (#540) -* Enable parallelization of model fitting in `brm_multiple` +* Enable parallelization of model fitting in `brm_multiple` via the future package. (#364) -* Perform posterior predictions based on k-fold cross-validation +* Perform posterior predictions based on k-fold cross-validation via `kfold_predict`. (#468) -* Indicate observations for out-of-sample predictions in +* Indicate observations for out-of-sample predictions in ARMA models via argument `oos` of `extract_draws`. (#539) ### Other changes @@ -578,13 +619,13 @@ ### Bug fixes -* Fix an issue that could result in a substantial efficiency +* Fix an issue that could result in a substantial efficiency drop of various post-processing methods for larger models. * Fix an issue when that resulted in an error when using `fitted(..., scale = "linear")` with ordinal models thanks to Andrew Milne. (#557) * Allow setting priors on the overall intercept in sparse models. -* Allow sampling from models with only a single observation +* Allow sampling from models with only a single observation that also contain an offset thanks to Antonio Vargas. (#545) * Fix an error when sampling from priors in mixture models thanks to Jacki Buros Novik. (#542) @@ -592,9 +633,9 @@ parameter transformations. * Allow using `marginal_smooths` with ordinal models thanks to Andrew Milne. (#570) -* Fix an error in the post-processing of `me` +* Fix an error in the post-processing of `me` terms thanks to the GitHub user hlluik. (#571) -* Correctly update `warmup` samples when using +* Correctly update `warmup` samples when using `update.brmsfit`. @@ -606,8 +647,8 @@ * Specify separate priors for thresholds in ordinal models. (#524) * Pass additional arguments to `rstan::stan_model` via argument `stan_model_args` in `brm`. (#525) -* Save model objects via argument `file` in `add_ic` -after adding model fit criteria. (#478) +* Save model objects via argument `file` in `add_ic` +after adding model fit criteria. (#478) * Compute density ratios based on MCMC samples via `density_ratio`. * Ignore offsets in various post-processing methods via argument `offset`. @@ -630,20 +671,20 @@ ### New features -* Improve `marginal_effects` to better display ordinal and +* Improve `marginal_effects` to better display ordinal and categorical models via argument `categorical`. (#491, #497) * Improve method `kfold` to offer more options for specifying omitted subsets. (#510) * Compute estimated values of non-linear parameters via argument `nlpar` in method `fitted`. -* Disable automatic cell-mean coding in model formulas without -an intercept via argument `cmc` of `brmsformula` and related +* Disable automatic cell-mean coding in model formulas without +an intercept via argument `cmc` of `brmsformula` and related functions thanks to Marie Beisemann. -* Allow using the `bridge_sampler` method even if +* Allow using the `bridge_sampler` method even if prior samples are drawn within the model. (#485) -* Specify post-processing functions of custom families +* Specify post-processing functions of custom families directly in `custom_family`. -* Select a subset of coefficients in `fixef`, `ranef`, +* Select a subset of coefficients in `fixef`, `ranef`, and `coef` via argument `pars`. (#520) * Allow to `overwrite` already stored fit indices when using `add_ic`. @@ -655,19 +696,19 @@ * Deprecate argument `ordinal` of `marginal_effects`. (#491) * Deprecate argument `exact_loo` of `kfold`. (#510) * Deprecate usage of `binomial` families without specifying `trials`. -* No longer sample from priors of population-level intercepts +* No longer sample from priors of population-level intercepts when using the default intercept parameterization. ### Bug fixes -* Correctly sample from LKJ correlation priors +* Correctly sample from LKJ correlation priors thanks to Donald Williams. -* Remove stored fit indices when calling `update` on +* Remove stored fit indices when calling `update` on brmsfit objects thanks to Emmanuel Charpentier. (#490) -* Fix problems when predicting a single data point using +* Fix problems when predicting a single data point using spline models thanks to Emmanuel Charpentier. (#494) -* Set `Post.Prob = 1` if `Evid.Ratio = Inf` in -method `hypothesis` thanks to Andrew Milne. (#509) +* Set `Post.Prob = 1` if `Evid.Ratio = Inf` in +method `hypothesis` thanks to Andrew Milne. (#509) * Ensure correct handling of argument `file` in `brm_multiple`. @@ -677,17 +718,17 @@ * Define custom variables in all of Stan's program blocks via function `stanvar`. (#459) -* Change the scope of non-linear parameters to be global +* Change the scope of non-linear parameters to be global within univariate models. (#390) -* Allow to automatically group predictor values in Gaussian +* Allow to automatically group predictor values in Gaussian processes specified via `gp`. This may lead to a considerable increase in sampling efficiency. (#300) * Compute LOO-adjusted R-squared using method `loo_R2`. -* Compute non-linear predictors outside of a loop over +* Compute non-linear predictors outside of a loop over observations by means of argument `loop` in `brmsformula`. * Fit non-linear mixture models. (#456) * Fit censored or truncated mixture models. (#469) -* Allow `horseshoe` and `lasso` priors to be set on special +* Allow `horseshoe` and `lasso` priors to be set on special population-level effects. * Allow vectors of length greater one to be passed to `set_prior`. * Conveniently save and load fitted model objects in `brm` @@ -705,11 +746,11 @@ * Allow custom families in mixture models thanks to Noam Ross. (#453) * Ensure compatibility with **mice** version 3.0. (#455) -* Fix naming of correlation parameters of group-level terms -with multiple subgroups thanks to Kristoffer Magnusson. (#457) +* Fix naming of correlation parameters of group-level terms +with multiple subgroups thanks to Kristoffer Magnusson. (#457) * Improve scaling of default priors in `lognormal` models (#460). * Fix multiple problems in the post-processing of categorical models. -* Fix validation of nested grouping factors in post-processing +* Fix validation of nested grouping factors in post-processing methods when passing new data thanks to Liam Kendall. @@ -718,11 +759,11 @@ ### New features * Allow censoring and truncation in zero-inflated and hurdle models. (#430) -* Export zero-inflated and hurdle distribution functions. +* Export zero-inflated and hurdle distribution functions. ### Other changes -* Improve sampling efficiency of the ordinal families +* Improve sampling efficiency of the ordinal families `cumulative`, `sratio`, and `cratio`. (#433) * Allow to specify a single k-fold subset in method `kfold`. (#441) @@ -741,11 +782,11 @@ difference formulation thanks to the case study of Mitzi Morris. * Compute `loo` and related methods for non-factorizable normal models. -### Other changes +### Other changes * Rename quantile columns in `posterior_summary`. This affects the output of `predict` and related methods if `summary = TRUE`. (#425) -* Use hashes to check if models have the same response values +* Use hashes to check if models have the same response values when performing model comparisons. (#414) * No longer set `pointwise` dynamically in `loo` and related methods. (#416) * No longer show information criteria in the summary output. @@ -753,7 +794,7 @@ ### Bug fixes -* Allow `cor_car` in multivariate models with residual correlations +* Allow `cor_car` in multivariate models with residual correlations thanks to Quentin Read. (#427) * Fix a problem in the Stan code generation of distributional `beta` models thanks to Hans van Calster. (#404) @@ -825,7 +866,7 @@ # brms 2.1.0 ### Features - + * Fit models on multiple imputed datasets via `brm_multiple` thanks to Ruben Arslan. (#27) * Combine multiple `brmsfit` objects via function `combine_models`. @@ -842,7 +883,7 @@ ### Bug fixes - + * Correctly recover noise-free coefficients through `me` terms thanks to Ruben Arslan. As a side effect, it is no longer possible to define priors on noise-free `Xme` variables directly, but only on their hyper-parameters `meanme` @@ -862,13 +903,13 @@ # brms 2.0.1 ### Features - + * Export the helper functions `posterior_summary` and `posterior_table` both being used to summarize posterior samples and predictions. ### Bug fixes - + * Fix incorrect computation of intercepts in `acat` and `cratio` models thanks to Peter Phalen. (#302) * Fix `pointwise` computation of `LOO` and `WAIC` in multivariate models with @@ -889,9 +930,9 @@ in the future. In addition, most deprecated functionality and arguments have been removed to provide a clean new start for the package. Models fitted with `brms` 1.0 or higher should remain fully compatible with `brms` 2.0. - + ### Features - + * Add support for generalized multivariate models, where each of the univariate models may have a different family and autocorrelation structure. Residual correlations can be estimated for multivariate `gaussian` and `student` models. @@ -907,7 +948,7 @@ ### Other changes - + * Refactor many parts of the package to make it more consistent and easier to extend. * Show the link functions of all distributional parameters in the `summary` @@ -928,7 +969,7 @@ ### Bug fixes - + * Store `stan_funs` in `brmsfit` objects to allow using `update` on models with user-defined Stan functions thanks to Tom Wallis. (#288) * Fix problems in various post-processing methods when applied to models with @@ -944,7 +985,7 @@ # brms 1.10.2 ### Features - + * Allow setting priors on noise-free variables specified via function `me`. * Add arguments `Ksub`, `exact_loo` and `group` to method `kfold` for defining omitted subsets according to a grouping variable or factor. @@ -952,7 +993,7 @@ ### Bug fixes - + * Ensure correct behavior of horseshoe and lasso priors in multivariate models thanks to Donald Williams. * Allow using `identity` links on all parameters of the `wiener` family thanks @@ -968,7 +1009,7 @@ # brms 1.10.0 ### Features - + * Rebuild monotonic effects from scratch to allow specifying interactions with other variables. (#239) * Introduce methods `posterior_linpred` and `posterior_interval` for consistency @@ -984,7 +1025,7 @@ ### Other changes - + * Use the same noise-free variables for all model parts in measurement error models. (#257) * Make names of local-level terms used in the `cor_bsts` structure more @@ -1000,7 +1041,7 @@ ### Bug fixes - + * Do not silence the `Stan` parser when calling `brm` to get informative error messages about invalid priors. * Fix problems with spaces in priors passed to `set_prior`. @@ -1013,7 +1054,7 @@ # brms 1.9.0 ### Features - + * Perform model comparisons based on marginal likelihoods using the methods `bridge_sampler`, `bayes_factor`, and `post_prob` all powered by the `bridgesampling` package. @@ -1027,7 +1068,7 @@ ### Other changes - + * Refactor parts of the package to prepare for the implementation of more flexible multivariate models in future updates. * Keep all constants in the log-posterior in order for `bridge_sampler` to be @@ -1042,7 +1083,7 @@ ### Bug fixes - + * Fix problems when calling `fitted` with `hurdle_lognormal` models thanks to Meghna Krishnadas. * Fix problems when predicting `sigma` in `asym_laplace` models thanks to Anna @@ -1053,7 +1094,7 @@ # brms 1.8.0 ### Features - + * Fit conditional autoregressive (CAR) models via function `cor_car` thanks to the case study of Max Joseph. * Fit spatial autoregressive (SAR) models via function `cor_sar`. Currently @@ -1071,7 +1112,7 @@ ### Other changes - + * Improve efficiency and stability of ARMA models. * Throw an error when the intercept is removed in an ordinal model instead of silently adding it back again. @@ -1084,7 +1125,7 @@ ### Bug fixes - + * Fix problems in `pp_check` when the variable specified in argument `x` has attributes thanks to Paul Galpern. * Fix problems when computing fitted values for truncated discrete models based @@ -1100,7 +1141,7 @@ # brms 1.7.0 ### Features - + * Fit latent Gaussian processes of one or more covariates via function `gp` specified in the model formula (#221). * Rework methods `fixef`, `ranef`, `coef`, and `VarCorr` to be more flexible and @@ -1116,7 +1157,7 @@ ### Other changes - + * Show output of \R code in HTML vignettes thanks to Ben Goodrich (#158). * Resolve citations in PDF vignettes thanks to Thomas Kluth (#223). * Improve sampling efficiency for `exgaussian` models thanks to Alex Forrence @@ -1126,7 +1167,7 @@ ### Bug fixes - + * Fix an unexpected error in `marginal_effects` occurring for some models with autocorrelation terms thanks to Markus Gesmann. * Fix multiple problems occurring for models with the `cor_bsts` structure @@ -1137,19 +1178,19 @@ # brms 1.6.1 ### Features - + * Implement zero-one-inflated beta models via family `zero_one_inflated_beta`. * Allow for more link functions in zero-inflated and hurdle models. ### Other changes - + * Ensure full compatibility with `bayesplot` version 1.2.0. * Deprecate addition argument `disp`. ### Bug fixes - + * Fix problems when setting priors on coefficients of auxiliary parameters when also setting priors on the corresponding coefficients of the mean parameter. Thanks to Matti Vuorre for reporting this bug. @@ -1161,7 +1202,7 @@ # brms 1.6.0 ### Features - + * Fit finite mixture models using family function `mixture`. * Introduce method `pp_mixture` to compute posterior probabilities of mixture component memberships thanks to a discussion with Stephen Martin. @@ -1186,7 +1227,7 @@ ### Other changes - + * Improve the `update` method to only recompile models when the `Stan` code changes. * Warn about divergent transitions when calling `summary` or `print` on @@ -1198,7 +1239,7 @@ ### Bug fixes - + * Fix problems with the inclusion of offsets occurring for more complicated formulas thanks to Christian Stock. * Fix a bug that led to invalid Stan code when sampling from priors in intercept @@ -1218,20 +1259,20 @@ # brms 1.5.1 ### Features - + * Allow `horseshoe` and `lasso` priors to be applied on population-level effects of non-linear and auxiliary parameters. * Force recompiling `Stan` models in `update.brmsfit` via argument `recompile`. ### Other changes - + * Avoid indexing of matrices in non-linear models to slightly improve sampling speed. ### Bug fixes - + * Fix a severe problem (introduced in version 1.5.0), when predicting `Beta` models thanks to Vivian Lam. * Fix problems when summarizing some models fitted with older version of `brms` @@ -1244,7 +1285,7 @@ # brms 1.5.0 ### Features - + * Implement the generalized extreme value distribution via family `gen_extreme_value`. * Improve flexibility of the `horseshoe` prior thanks to Juho Piironen. @@ -1257,7 +1298,7 @@ ### Other changes - + * Refactor various parts of the package to ease implementation of mixture and multivariate models in future updates. This should not have any user visible effects. @@ -1265,7 +1306,7 @@ ### Bug fixes - + * Fix a rare error when predicting `von_mises` models thanks to John Kirwan. @@ -1273,7 +1314,7 @@ # brms 1.4.0 ### Features - + * Fit quantile regression models via family `asym_laplace` (asymmetric Laplace distribution). * Specify non-linear models in a (hopefully) more intuitive way using @@ -1293,7 +1334,7 @@ ### Other changes - + * Change structure of `brmsformula` objects to be more reliable and easier to extend. * Make sure that parameter `nu` never falls below `1` to reduce convergence @@ -1313,7 +1354,7 @@ ### Bug fixes - + * Fix problems when fitting smoothing terms with factors as `by` variables thanks to Milani Chaloupka. * Fix a bug that could cause some monotonic effects to be ignored in the `Stan` @@ -1335,7 +1376,7 @@ # brms 1.3.1 ### Features - + * Introduce the auxiliary parameter `disc` ('discrimination') to be used in ordinal models. By default it is not estimated but fixed to one. * Create `marginal_effects` plots of two-way interactions of variables that were @@ -1343,14 +1384,14 @@ ### Other changes - + * Move `rstan` to 'Imports' and `Rcpp` to 'Depends' in order to avoid loading `rstan` into the global environment automatically. ### Bug fixes - -* Fix a bug leading to unexpected errors in some S3 methods when + +* Fix a bug leading to unexpected errors in some S3 methods when applied to ordinal models. @@ -1359,7 +1400,7 @@ # brms 1.3.0 ### Features - + * Fit error-in-variables models using function `me` in the model formulae. * Fit multi-membership models using function `mm` in grouping terms. * Add families `exgaussian` (exponentially modified Gaussian distribution) and @@ -1377,7 +1418,7 @@ ### Other changes - + * Require argument `data` to be explicitely specified in all user facing functions. * Refactor the `stanplot` method to use `bayesplot` on the backend. @@ -1397,7 +1438,7 @@ # brms 1.2.0 ### Features - + * Add the new family `hurdle_lognormal` specifically suited for zero-inflated continuous responses. * Introduce the `pp_check` method to perform various posterior predictive checks @@ -1421,7 +1462,7 @@ ### Other changes - + * Improve computation of Bayes factors in the `hypothesis` method to be less influenced by MCMC error. * Improve documentation of default priors. @@ -1431,7 +1472,7 @@ ### Bug fixes - + * Better mimic `mgcv` when parsing smooth terms to make sure all arguments are correctly handled. * Avoid an error occurring during the prediction of new data when grouping @@ -1449,7 +1490,7 @@ # brms 1.1.0 ### Features - + * Estimate monotonic group-level effects. * Estimate category specific group-level effects. * Allow `t2` smooth terms based on multiple covariates. @@ -1460,7 +1501,7 @@ ### Other changes - + * Use the prefix `bcs` in parameter names of category specific effects and the prefix `bm` in parameter names of monotonic effects (instead of the prefix `b`) to simplify their identification. @@ -1468,7 +1509,7 @@ ### Bug fixes - + * Fix a bug that could result in incorrect threshold estimates for `cumulative` and `sratio` models thanks to Peter Congdon. * Fix a bug that sometimes kept distributional `gamma` models from being @@ -1488,7 +1529,7 @@ # brms 1.0.1 \subsection{MINOR CHANGES - + * Center design matrices inside the Stan code instead of inside `make_standata`. * Get rid of several warning messages occurring on CRAN. @@ -1502,9 +1543,9 @@ removed from the package as it was confusing for users, required much special case coding, and was hard to maintain. See `help(brmsformula)` for details of the formula syntax applied in `brms`. - + ### Features - + * Allow estimating correlations between group-level effects defined across multiple formulae (e.g., in non-linear models) by specifying IDs in each grouping term via an extended `lme4` syntax. @@ -1523,7 +1564,7 @@ ### Other changes - + * Remove the `cauchy` family after several months of deprecation. * Make sure that group-level parameter names are unambiguous by adding double underscores thanks to the idea of the GitHub user schmettow. @@ -1538,7 +1579,7 @@ ### Bug fixes - + * Fix a bug that could occur when predicting factorial response variables for new data. Only affects categorical and ordinal models. * Fix a bug that could lead to duplicated variable names in the Stan code when @@ -1553,7 +1594,7 @@ # brms 0.10.0 ### Features - + * Add support for generalized additive mixed models (GAMMs). Smoothing terms can be specified using the `s` and `t2` functions in the model formula. * Introduce `as.data.frame` and `as.matrix` methods for `brmsfit` objects. @@ -1567,7 +1608,7 @@ ### Bug fixes - + * The `ngrps` method should now always return the correct result for non-linear models. * Fix problems in `marginal_effects` for models using the reserved variable @@ -1582,7 +1623,7 @@ # brms 0.9.1 ### Features - + * Allow the '/' symbol in group-level terms in the `formula` argument to indicate nested grouping structures. * Allow to compute `WAIC` and `LOO` based on the pointwise log-likelihood using @@ -1590,12 +1631,12 @@ ### Other changes - + * Add horizontal lines to the errorbars in `marginal_effects` plots for factors. ### Bug fixes - + * Fix a bug that could lead to a cryptic error message when changing some parts of the model `formula` using the `update` method. * Fix a bug that could lead to an error when calling `marginal_effects` for @@ -1612,7 +1653,7 @@ # brms 0.9.0 ### Features - + * Add support for `monotonic` effects allowing to use ordinal predictors without assuming their categories to be equidistant. * Apply multivariate formula syntax in categorical models to considerably @@ -1635,7 +1676,7 @@ ### Other changes - + * Refactor `Stan` code and data generating functions to be more consistent and easier to extent. * Improve checks of user-define prior specifications. @@ -1647,7 +1688,7 @@ ### Bug fixes - + * Fix problems in the generated `Stan` code when using very long non-linear model formulas thanks to Emmanuel Charpentier. * Fix a bug that prohibited to change priors on single standard deviation @@ -1663,7 +1704,7 @@ # brms 0.8.0 ### Features - + * Implement generalized non-linear models, which can be specified with the help of the `nonlinear` argument in `brm`. * Compute and plot marginal effects using the `marginal_effects` method thanks @@ -1678,7 +1719,7 @@ ### Other changes - + * Make sure that `brms` is fully compatible with `loo` version 0.1.5. * Optionally define the intercept as an ordinary fixed effect to avoid the reparametrization via centering of the fixed effects design matrix. @@ -1699,7 +1740,7 @@ ### Bug fixes - + * Fix problems when predicting with `newdata` for zero-inflated and hurdle models thanks to Ruben Arslan. * Fix problems when predicting with `newdata` if it is a subset of the data @@ -1720,7 +1761,7 @@ # brms 0.7.0 ### Features - + * Use variational inference algorithms as alternative to the NUTS sampler by specifying argument `algorithm` in the `brm` function. * Implement beta regression models through family `Beta`. @@ -1743,7 +1784,7 @@ ### Other changes - + * Improve evaluation of the response part of the `formula` argument to reliably allow terms with more than one variable (e.g., `y/x ~ 1`). * Improve sampling efficiency of models containing many fixed effects through @@ -1766,7 +1807,7 @@ ### Bug fixes - + * Fix a bug in the `hypothesis` method that could cause valid model parameters to be falsely reported as invalid. * Fix a bug in the `prior_samples` method that could cause prior samples of @@ -1783,7 +1824,7 @@ # brms 0.6.0 ### Features - + * Add support for zero-inflated and hurdle models thanks to the idea of Scott Baldwin. * Implement inverse gaussian models through family `inverse.gaussian`. @@ -1806,7 +1847,7 @@ ### Other changes - + * Separate the fixed effects Intercept from other fixed effects in the `Stan` code to slightly improve sampling efficiency. * Move autoregressive (AR) effects of the response from the `cor_ar` to the @@ -1842,7 +1883,7 @@ # brms 0.5.0 ### Features - + * Compute the Watanabe-Akaike information criterion (WAIC) and leave-one-out cross-validation (LOO) using the `loo` package. * Provide an interface to `shinystan` with S3 method `launch_shiny`. @@ -1857,7 +1898,7 @@ ### Other changes - + * Arguments `WAIC` and `predict` are removed from the `brm` function, as they are no longer necessary. * New argument `cluster_type` in function `brm` allowing to choose the cluster @@ -1870,7 +1911,7 @@ ### Bug fixes - + * Fix a bug in S3 method `hypothesis` related to the calculation of Bayes-factors for point hypotheses. * User-defined covariance matrices that are not strictly positive definite for @@ -1884,12 +1925,12 @@ # brms 0.4.1 ### Features - + * Allow for sampling from all specified proper priors in the model. * Compute Bayes-factors for point hypotheses in S3 method `hypothesis`. ### Bug fixes - + * Fix a bug that could cause an error for models with multiple grouping factors thanks to Jonathan Williams. * Fix a bug that could cause an error for weighted poisson and exponential @@ -1899,7 +1940,7 @@ # brms 0.4.0 ### Features - + * Implement the Watanabe-Akaike Information Criterion (WAIC). * Implement the `||`-syntax for random effects allowing for the estimation of random effects standard deviations without the estimation of correlations. @@ -1915,7 +1956,7 @@ ### Other changes - + * Slightly change the internal structure of brms to reflect that `rstan` is finally on CRAN. * Thoroughly check validity of the response variable before the data is passed @@ -1932,7 +1973,7 @@ ### Bug fixes - + * Fix a bug in S3 method `hypothesis` leading to an error when numbers with decimal places were used in the formulation of the hypotheses. * Fix a bug in S3 method `ranef` that caused an error for grouping factors with @@ -1945,7 +1986,7 @@ # brms 0.3.0 ### Features - + * Introduce new methods `parnames` and `posterior_samples` for class 'brmsfit' to extract parameter names and posterior samples for given parameters, respectively. @@ -1968,15 +2009,15 @@ ### Other changes - + * Amend parametrization of random effects to increase efficiency of the sampling -algorithms. +algorithms. * Improve vectorization of sampling statements. ### Bug fixes - -* Fix a bug that could cause an error when fitting poisson models while + +* Fix a bug that could cause an error when fitting poisson models while `predict = TRUE`. * Fix a bug that caused an error when sampling only one chain while `silent = TRUE`. @@ -1985,7 +2026,7 @@ # brms 0.2.0 ### Features - + * New S3 class `brmsfit` to be returned by the `brm` function. * New methods for class `brmsfit`: `summary`, `print`, `plot`, `predict`, `fixef`, `ranef`, `VarCorr`, `nobs`, `ngrps`, and `formula`. @@ -1996,14 +2037,14 @@ ### Other changes - + * Amend warning and error messages to make them more informative. * Correct examples in the documentation. * Extend the README file. ### Bug fixes - + * Fix a bug that caused problems when formulas contained more complicated function calls. * Fix a bug that caused an error when posterior predictives were sampled for @@ -2013,7 +2054,7 @@ # brms 0.1.0 - + * Initial release version diff -Nru r-cran-brms-2.16.3/R/autocor.R r-cran-brms-2.17.0/R/autocor.R --- r-cran-brms-2.16.3/R/autocor.R 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/R/autocor.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,634 +1,634 @@ -# All functions in this file belong to the deprecated 'cor_brms' class -# for specifying autocorrelation structures. They will be removed in brms 3. - -#' (Deprecated) Correlation structure classes for the \pkg{brms} package -#' -#' Classes of correlation structures available in the \pkg{brms} package. -#' \code{cor_brms} is not a correlation structure itself, -#' but the class common to all correlation structures implemented in \pkg{brms}. -#' -#' @name cor_brms -#' @aliases cor_brms-class -#' -#' @section Available correlation structures: -#' \describe{ -#' \item{cor_arma}{autoregressive-moving average (ARMA) structure, -#' with arbitrary orders for the autoregressive and moving -#' average components} -#' \item{cor_ar}{autoregressive (AR) structure of arbitrary order} -#' \item{cor_ma}{moving average (MA) structure of arbitrary order} -#' \item{cor_car}{Spatial conditional autoregressive (CAR) structure} -#' \item{cor_sar}{Spatial simultaneous autoregressive (SAR) structure} -#' \item{cor_fixed}{fixed user-defined covariance structure} -#' } -#' -#' @seealso -#' \code{\link{cor_arma}, \link{cor_ar}, \link{cor_ma}, -#' \link{cor_car}, \link{cor_sar}, \link{cor_fixed}} -#' -NULL - -#' (Deprecated) ARMA(p,q) correlation structure -#' -#' This function is deprecated. Please see \code{\link{arma}} for the new syntax. -#' This functions is a constructor for the \code{cor_arma} class, representing -#' an autoregression-moving average correlation structure of order (p, q). -#' -#' @aliases cor_arma-class -#' -#' @param formula A one sided formula of the form \code{~ t}, or \code{~ t | g}, -#' specifying a time covariate \code{t} and, optionally, a grouping factor -#' \code{g}. A covariate for this correlation structure must be integer -#' valued. When a grouping factor is present in \code{formula}, the -#' correlation structure is assumed to apply only to observations within the -#' same grouping level; observations with different grouping levels are -#' assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to -#' using the order of the observations in the data as a covariate, and no -#' groups. -#' @param p A non-negative integer specifying the autoregressive (AR) -#' order of the ARMA structure. Default is 0. -#' @param q A non-negative integer specifying the moving average (MA) -#' order of the ARMA structure. Default is 0. -#' @param r No longer supported. -#' @param cov A flag indicating whether ARMA effects should be estimated by -#' means of residual covariance matrices. This is currently only possible for -#' stationary ARMA effects of order 1. If the model family does not have -#' natural residuals, latent residuals are added automatically. If -#' \code{FALSE} (the default) a regression formulation is used that is -#' considerably faster and allows for ARMA effects of order higher than 1 but -#' is only available for \code{gaussian} models and some of its -#' generalizations. -#' -#' @return An object of class \code{cor_arma}, representing an -#' autoregression-moving-average correlation structure. -#' -#' @seealso \code{\link{cor_ar}}, \code{\link{cor_ma}} -#' -#' @examples -#' cor_arma(~ visit | patient, p = 2, q = 2) -#' -#' @export -cor_arma <- function(formula = ~1, p = 0, q = 0, r = 0, cov = FALSE) { - formula <- as.formula(formula) - p <- as_one_numeric(p) - q <- as_one_numeric(q) - cov <- as_one_logical(cov) - if ("r" %in% names(match.call())) { - warning2("The ARR structure is no longer supported and ignored.") - } - if (!(p >= 0 && p == round(p))) { - stop2("Autoregressive order must be a non-negative integer.") - } - if (!(q >= 0 && q == round(q))) { - stop2("Moving-average order must be a non-negative integer.") - } - if (!sum(p, q)) { - stop2("At least one of 'p' and 'q' should be greater zero.") - } - if (cov && (p > 1 || q > 1)) { - stop2("Covariance formulation of ARMA structures is ", - "only possible for effects of maximal order one.") - } - x <- nlist(formula, p, q, cov) - class(x) <- c("cor_arma", "cor_brms") - x -} - -#' (Deprecated) AR(p) correlation structure -#' -#' This function is deprecated. Please see \code{\link{ar}} for the new syntax. -#' This function is a constructor for the \code{cor_arma} class, -#' allowing for autoregression terms only. -#' -#' @inheritParams cor_arma -#' @param p A non-negative integer specifying the autoregressive (AR) -#' order of the ARMA structure. Default is 1. -#' -#' @return An object of class \code{cor_arma} containing solely autoregression terms. -#' -#' @details AR refers to autoregressive effects of residuals, which -#' is what is typically understood as autoregressive effects. -#' However, one may also model autoregressive effects of the response -#' variable, which is called ARR in \pkg{brms}. -#' -#' @seealso \code{\link{cor_arma}} -#' -#' @examples -#' cor_ar(~visit|patient, p = 2) -#' -#' @export -cor_ar <- function(formula = ~1, p = 1, cov = FALSE) { - cor_arma(formula = formula, p = p, q = 0, cov = cov) -} - -#' (Deprecated) MA(q) correlation structure -#' -#' This function is deprecated. Please see \code{\link{ma}} for the new syntax. -#' This function is a constructor for the \code{cor_arma} class, -#' allowing for moving average terms only. -#' -#' @inheritParams cor_arma -#' @param q A non-negative integer specifying the moving average (MA) -#' order of the ARMA structure. Default is 1. -#' -#' @return An object of class \code{cor_arma} containing solely moving -#' average terms. -#' -#' @seealso \code{\link{cor_arma}} -#' -#' @examples -#' cor_ma(~visit|patient, q = 2) -#' -#' @export -cor_ma <- function(formula = ~1, q = 1, cov = FALSE) { - cor_arma(formula = formula, p = 0, q = q, cov = cov) -} - -#' (Defunct) ARR correlation structure -#' -#' The ARR correlation structure is no longer supported. -#' -#' @inheritParams cor_arma -#' -#' @keywords internal -#' @export -cor_arr <- function(formula = ~1, r = 1) { - cor_arma(formula = formula, p = 0, q = 0, r = r) -} - -#' (Deprecated) Compound Symmetry (COSY) Correlation Structure -#' -#' This function is deprecated. Please see \code{\link{cosy}} for the new syntax. -#' This functions is a constructor for the \code{cor_cosy} class, representing -#' a compound symmetry structure corresponding to uniform correlation. -#' -#' @aliases cor_cosy-class -#' -#' @inheritParams cor_arma -#' -#' @return An object of class \code{cor_cosy}, representing a compound symmetry -#' correlation structure. -#' -#' @examples -#' cor_cosy(~ visit | patient) -#' -#' @export -cor_cosy <- function(formula = ~1) { - formula <- as.formula(formula) - x <- nlist(formula) - class(x) <- c("cor_cosy", "cor_brms") - x -} - -#' (Deprecated) Spatial simultaneous autoregressive (SAR) structures -#' -#' Thse functions are deprecated. Please see \code{\link{sar}} for the new -#' syntax. These functions are constructors for the \code{cor_sar} class -#' implementing spatial simultaneous autoregressive structures. -#' The \code{lagsar} structure implements SAR of the response values: -#' \deqn{y = \rho W y + \eta + e} -#' The \code{errorsar} structure implements SAR of the residuals: -#' \deqn{y = \eta + u, u = \rho W u + e} -#' In the above equations, \eqn{\eta} is the predictor term and -#' \eqn{e} are independent normally or t-distributed residuals. -#' -#' @param W An object specifying the spatial weighting matrix. -#' Can be either the spatial weight matrix itself or an -#' object of class \code{listw} or \code{nb}, from which -#' the spatial weighting matrix can be computed. -#' @param type Type of the SAR structure. Either \code{"lag"} -#' (for SAR of the response values) or \code{"error"} -#' (for SAR of the residuals). -#' -#' @details Currently, only families \code{gaussian} and \code{student} -#' support SAR structures. -#' -#' @return An object of class \code{cor_sar} to be used in calls to -#' \code{\link{brm}}. -#' -#' @examples -#' \dontrun{ -#' data(oldcol, package = "spdep") -#' fit1 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, -#' autocor = cor_lagsar(COL.nb), -#' chains = 2, cores = 2) -#' summary(fit1) -#' plot(fit1) -#' -#' fit2 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, -#' autocor = cor_errorsar(COL.nb), -#' chains = 2, cores = 2) -#' summary(fit2) -#' plot(fit2) -#' } -#' -#' @export -cor_sar <- function(W, type = c("lag", "error")) { - type <- match.arg(type) - W_name <- deparse(substitute(W)) - W <- validate_sar_matrix(W) - structure( - nlist(W, W_name, type), - class = c("cor_sar", "cor_brms") - ) -} - -#' @rdname cor_sar -#' @export -cor_lagsar <- function(W) { - out <- cor_sar(W, type = "lag") - out$W_name <- deparse(substitute(W)) - out -} - -#' @rdname cor_sar -#' @export -cor_errorsar <- function(W) { - out <- cor_sar(W, type = "error") - out$W_name <- deparse(substitute(W)) - out -} - -#' (Deprecated) Spatial conditional autoregressive (CAR) structures -#' -#' These function are deprecated. Please see \code{\link{car}} for the new -#' syntax. These functions are constructors for the \code{cor_car} class -#' implementing spatial conditional autoregressive structures. -#' -#' @param W Adjacency matrix of locations. -#' All non-zero entries are treated as if the two locations -#' are adjacent. If \code{formula} contains a grouping factor, -#' the row names of \code{W} have to match the levels -#' of the grouping factor. -#' @param formula An optional one-sided formula of the form -#' \code{~ 1 | g}, where \code{g} is a grouping factor mapping -#' observations to spatial locations. If not specified, -#' each observation is treated as a separate location. -#' It is recommended to always specify a grouping factor -#' to allow for handling of new data in post-processing methods. -#' @param type Type of the CAR structure. Currently implemented -#' are \code{"escar"} (exact sparse CAR), \code{"esicar"} -#' (exact sparse intrinsic CAR), \code{"icar"} (intrinsic CAR), -#' and \code{"bym2"}. More information is provided in the 'Details' section. -#' -#' @details The \code{escar} and \code{esicar} types are -#' implemented based on the case study of Max Joseph -#' (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and -#' \code{bym2} type is implemented based on the case study of Mitzi Morris -#' (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). -#' -#' @examples -#' \dontrun{ -#' # generate some spatial data -#' east <- north <- 1:10 -#' Grid <- expand.grid(east, north) -#' K <- nrow(Grid) -#' -#' # set up distance and neighbourhood matrices -#' distance <- as.matrix(dist(Grid)) -#' W <- array(0, c(K, K)) -#' W[distance == 1] <- 1 -#' -#' # generate the covariates and response data -#' x1 <- rnorm(K) -#' x2 <- rnorm(K) -#' theta <- rnorm(K, sd = 0.05) -#' phi <- rmulti_normal( -#' 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) -#' ) -#' eta <- x1 + x2 + phi -#' prob <- exp(eta) / (1 + exp(eta)) -#' size <- rep(50, K) -#' y <- rbinom(n = K, size = size, prob = prob) -#' dat <- data.frame(y, size, x1, x2) -#' -#' # fit a CAR model -#' fit <- brm(y | trials(size) ~ x1 + x2, data = dat, -#' family = binomial(), autocor = cor_car(W)) -#' summary(fit) -#' } -#' -#' @export -cor_car <- function(W, formula = ~1, type = "escar") { - options <- c("escar", "esicar", "icar", "bym2") - type <- match.arg(type, options) - W_name <- deparse(substitute(W)) - W <- validate_car_matrix(W) - formula <- as.formula(formula) - if (!is.null(lhs(formula))) { - stop2("'formula' should be a one-sided formula.") - } - if (length(attr(terms(formula), "term.labels")) > 1L) { - stop2("'formula' should not contain more than one term.") - } - structure( - nlist(W, W_name, formula, type), - class = c("cor_car", "cor_brms") - ) -} - -#' @rdname cor_car -#' @export -cor_icar <- function(W, formula = ~1) { - out <- cor_car(W, formula, type = "icar") - out$W_name <- deparse(substitute(W)) - out -} - -#' (Deprecated) Fixed user-defined covariance matrices -#' -#' This function is deprecated. Please see \code{\link{fcor}} for the new -#' syntax. Define a fixed covariance matrix of the response variable for -#' instance to model multivariate effect sizes in meta-analysis. -#' -#' @aliases cov_fixed -#' -#' @param V Known covariance matrix of the response variable. -#' If a vector is passed, it will be used as diagonal entries -#' (variances) and covariances will be set to zero. -#' -#' @return An object of class \code{cor_fixed}. -#' -#' @examples -#' \dontrun{ -#' dat <- data.frame(y = rnorm(3)) -#' V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) -#' fit <- brm(y~1, data = dat, autocor = cor_fixed(V)) -#' } -#' -#' @export -cor_fixed <- function(V) { - V_name <- deparse(substitute(V)) - if (is.vector(V)) { - V <- diag(V) - } else { - V <- as.matrix(V) - } - if (!isSymmetric(unname(V))) { - stop2("'V' must be symmetric") - } - structure(nlist(V, V_name), class = c("cor_fixed", "cor_brms")) -} - -#' (Defunct) Basic Bayesian Structural Time Series -#' -#' The BSTS correlation structure is no longer supported. -#' -#' @inheritParams cor_arma -#' -#' @keywords internal -#' @export -cor_bsts <- function(formula = ~1) { - stop2("The BSTS structure is no longer supported.") -} - -#' Check if argument is a correlation structure -#' -#' Check if argument is one of the correlation structures -#' used in \pkg{brms}. -#' -#' @param x An \R object. -#' -#' @export -is.cor_brms <- function(x) { - inherits(x, "cor_brms") -} - -#' @rdname is.cor_brms -#' @export -is.cor_arma <- function(x) { - inherits(x, "cor_arma") -} - -#' @rdname is.cor_brms -#' @export -is.cor_cosy <- function(x) { - inherits(x, "cor_cosy") -} - -#' @rdname is.cor_brms -#' @export -is.cor_sar <- function(x) { - inherits(x, "cor_sar") -} - -#' @rdname is.cor_brms -#' @export -is.cor_car <- function(x) { - inherits(x, "cor_car") -} - -#' @rdname is.cor_brms -#' @export -is.cor_fixed <- function(x) { - inherits(x, "cor_fixed") -} - -#' @export -print.cor_empty <- function(x, ...) { - cat("empty()\n") -} - -#' @export -print.cor_arma <- function(x, ...) { - cat(paste0("arma(", formula2str(x$formula), ", ", x$p, ", ", x$q, ")\n")) - invisible(x) -} - -#' @export -print.cor_cosy <- function(x, ...) { - cat(paste0("cosy(", formula2str(x$formula), ")\n")) - invisible(x) -} - -#' @export -print.cor_sar <- function(x, ...) { - cat(paste0("sar(", x$W_name, ", '", x$type, "')\n")) - invisible(x) -} - -#' @export -print.cor_car <- function(x, ...) { - form <- formula2str(x$formula) - cat(paste0("car(", x$W_name, ", ", form, ", '", x$type, "')\n")) - invisible(x) -} - -#' @export -print.cor_fixed <- function(x, ...) { - cat("Fixed covariance matrix: \n") - print(x$V) - invisible(x) -} - -#' @export -print.cov_fixed <- function(x, ...) { - class(x) <- "cor_fixed" - print.cor_fixed(x) -} - -stop_not_cor_brms <- function(x) { - if (!(is.null(x) || is.cor_brms(x))) { - stop2("Argument 'autocor' must be of class 'cor_brms'.") - } - TRUE -} - -# empty 'cor_brms' object -cor_empty <- function() { - structure(list(), class = c("cor_empty", "cor_brms")) -} - -is.cor_empty <- function(x) { - inherits(x, "cor_empty") -} - -#' (Deprecated) Extract Autocorrelation Objects -#' -#' @inheritParams posterior_predict.brmsfit -#' @param ... Currently unused. -#' -#' @return A \code{cor_brms} object or a list of such objects for multivariate -#' models. Not supported for models fitted with brms 2.11.1 or higher. -#' -#' @export -autocor.brmsfit <- function(object, resp = NULL, ...) { - warning2("Method 'autocor' is deprecated and will be removed in the future.") - object <- restructure(object) - resp <- validate_resp(resp, object) - if (!is.null(resp)) { - # multivariate model - autocor <- object$autocor[resp] - if (length(resp) == 1L) { - autocor <- autocor[[1]] - } - } else { - # univariate model - autocor <- object$autocor - } - autocor -} - -#' @rdname autocor.brmsfit -#' @export -autocor <- function(object, ...) { - UseMethod("autocor") -} - -# extract variables for autocorrelation structures -# @param autocor object of class 'cor_brms' -# @return a list with elements 'time', and 'group' -terms_autocor <- function(autocor) { - out <- list() - formula <- autocor$formula - if (is.null(formula)) { - formula <- ~1 - } - if (!is.null(lhs(formula))) { - stop2("Autocorrelation formulas must be one-sided.") - } - formula <- formula2str(formula) - time <- as.formula(paste("~", gsub("~|\\|[[:print:]]*", "", formula))) - time_vars <- all_vars(time) - if (is.cor_car(autocor) && length(time_vars) > 0L) { - stop2("The CAR structure should not contain a 'time' variable.") - } - if (length(time_vars) > 1L) { - stop2("Autocorrelation structures may only contain 1 time variable.") - } - if (length(time_vars)) { - out$time <- time_vars - } else { - out$time <- NA - } - group <- sub("^\\|*", "", sub("~[^\\|]*", "", formula)) - stopif_illegal_group(group) - group_vars <- all_vars(group) - if (length(group_vars)) { - out$group <- paste0(group_vars, collapse = ":") - } else { - out$group <- NA - } - out -} - -# transform a 'cor_brms' object into a formula -# this ensure compatibility with brms <= 2.11 -as_formula_cor_brms <- function(x) { - stop_not_cor_brms(x) - if (is.cor_empty(x)) { - return(NULL) - } - args <- data2 <- list() - pac <- terms_autocor(x) - if (is.cor_arma(x)) { - fun <- "arma" - args$time <- pac$time - args$gr <- pac$group - args$p <- x$p - args$q <- x$q - args$cov <- x$cov - out <- paste0(names(args), " = ", args, collapse = ", ") - out <- paste0("arma(", out, ")") - } else if (is.cor_cosy(x)) { - fun <- "cosy" - args$time <- pac$time - args$gr <- pac$group - } else if (is.cor_sar(x)) { - fun <- "sar" - args$M <- make_M_names(x$W_name) - args$type <- paste0("'", x$type, "'") - data2[[args$M]] <- x$W - } else if (is.cor_car(x)) { - fun <- "car" - args$M <- make_M_names(x$W_name) - args$gr <- pac$group - args$type <- paste0("'", x$type, "'") - data2[[args$M]] <- x$W - } else if (is.cor_fixed(x)) { - fun <- "fcor" - args$M <- make_M_names(x$V_name) - data2[[args$M]] <- x$V - } - out <- paste0(names(args), " = ", args, collapse = ", ") - out <- paste0(fun, "(", out, ")") - out <- str2formula(out) - attr(out, "data2") <- data2 - class(out) <- c("cor_brms_formula", "formula") - out -} - -# ensures covariance matrix inputs are named reasonably -make_M_names <- function(x) { - out <- make.names(x) - if (!length(out)) { - # likely unique random name for the matrix argument - out <- paste0("M", collapse(sample(0:9, 5, TRUE))) - } - out -} - -# get data objects from 'autocor' for use in 'data2' -# for backwards compatibility with brms <= 2.11 -get_data2_autocor <- function(x, ...) { - UseMethod("get_data2_autocor") -} - -#' @export -get_data2_autocor.brmsformula <- function(x, ...) { - attr(attr(x$formula, "autocor"), "data2") -} - -#' @export -get_data2_autocor.mvbrmsformula <- function(x, ...) { - ulapply(x$forms, get_data2_autocor, recursive = FALSE) -} - -#' @export -print.cor_brms_formula <- function(x, ...) { - y <- x - attr(y, "data2") <- NULL - class(y) <- "formula" - print(y) - invisible(x) -} +# All functions in this file belong to the deprecated 'cor_brms' class +# for specifying autocorrelation structures. They will be removed in brms 3. + +#' (Deprecated) Correlation structure classes for the \pkg{brms} package +#' +#' Classes of correlation structures available in the \pkg{brms} package. +#' \code{cor_brms} is not a correlation structure itself, +#' but the class common to all correlation structures implemented in \pkg{brms}. +#' +#' @name cor_brms +#' @aliases cor_brms-class +#' +#' @section Available correlation structures: +#' \describe{ +#' \item{cor_arma}{autoregressive-moving average (ARMA) structure, +#' with arbitrary orders for the autoregressive and moving +#' average components} +#' \item{cor_ar}{autoregressive (AR) structure of arbitrary order} +#' \item{cor_ma}{moving average (MA) structure of arbitrary order} +#' \item{cor_car}{Spatial conditional autoregressive (CAR) structure} +#' \item{cor_sar}{Spatial simultaneous autoregressive (SAR) structure} +#' \item{cor_fixed}{fixed user-defined covariance structure} +#' } +#' +#' @seealso +#' \code{\link{cor_arma}, \link{cor_ar}, \link{cor_ma}, +#' \link{cor_car}, \link{cor_sar}, \link{cor_fixed}} +#' +NULL + +#' (Deprecated) ARMA(p,q) correlation structure +#' +#' This function is deprecated. Please see \code{\link{arma}} for the new syntax. +#' This functions is a constructor for the \code{cor_arma} class, representing +#' an autoregression-moving average correlation structure of order (p, q). +#' +#' @aliases cor_arma-class +#' +#' @param formula A one sided formula of the form \code{~ t}, or \code{~ t | g}, +#' specifying a time covariate \code{t} and, optionally, a grouping factor +#' \code{g}. A covariate for this correlation structure must be integer +#' valued. When a grouping factor is present in \code{formula}, the +#' correlation structure is assumed to apply only to observations within the +#' same grouping level; observations with different grouping levels are +#' assumed to be uncorrelated. Defaults to \code{~ 1}, which corresponds to +#' using the order of the observations in the data as a covariate, and no +#' groups. +#' @param p A non-negative integer specifying the autoregressive (AR) +#' order of the ARMA structure. Default is 0. +#' @param q A non-negative integer specifying the moving average (MA) +#' order of the ARMA structure. Default is 0. +#' @param r No longer supported. +#' @param cov A flag indicating whether ARMA effects should be estimated by +#' means of residual covariance matrices. This is currently only possible for +#' stationary ARMA effects of order 1. If the model family does not have +#' natural residuals, latent residuals are added automatically. If +#' \code{FALSE} (the default) a regression formulation is used that is +#' considerably faster and allows for ARMA effects of order higher than 1 but +#' is only available for \code{gaussian} models and some of its +#' generalizations. +#' +#' @return An object of class \code{cor_arma}, representing an +#' autoregression-moving-average correlation structure. +#' +#' @seealso \code{\link{cor_ar}}, \code{\link{cor_ma}} +#' +#' @examples +#' cor_arma(~ visit | patient, p = 2, q = 2) +#' +#' @export +cor_arma <- function(formula = ~1, p = 0, q = 0, r = 0, cov = FALSE) { + formula <- as.formula(formula) + p <- as_one_numeric(p) + q <- as_one_numeric(q) + cov <- as_one_logical(cov) + if ("r" %in% names(match.call())) { + warning2("The ARR structure is no longer supported and ignored.") + } + if (!(p >= 0 && p == round(p))) { + stop2("Autoregressive order must be a non-negative integer.") + } + if (!(q >= 0 && q == round(q))) { + stop2("Moving-average order must be a non-negative integer.") + } + if (!sum(p, q)) { + stop2("At least one of 'p' and 'q' should be greater zero.") + } + if (cov && (p > 1 || q > 1)) { + stop2("Covariance formulation of ARMA structures is ", + "only possible for effects of maximal order one.") + } + x <- nlist(formula, p, q, cov) + class(x) <- c("cor_arma", "cor_brms") + x +} + +#' (Deprecated) AR(p) correlation structure +#' +#' This function is deprecated. Please see \code{\link{ar}} for the new syntax. +#' This function is a constructor for the \code{cor_arma} class, +#' allowing for autoregression terms only. +#' +#' @inheritParams cor_arma +#' @param p A non-negative integer specifying the autoregressive (AR) +#' order of the ARMA structure. Default is 1. +#' +#' @return An object of class \code{cor_arma} containing solely autoregression terms. +#' +#' @details AR refers to autoregressive effects of residuals, which +#' is what is typically understood as autoregressive effects. +#' However, one may also model autoregressive effects of the response +#' variable, which is called ARR in \pkg{brms}. +#' +#' @seealso \code{\link{cor_arma}} +#' +#' @examples +#' cor_ar(~visit|patient, p = 2) +#' +#' @export +cor_ar <- function(formula = ~1, p = 1, cov = FALSE) { + cor_arma(formula = formula, p = p, q = 0, cov = cov) +} + +#' (Deprecated) MA(q) correlation structure +#' +#' This function is deprecated. Please see \code{\link{ma}} for the new syntax. +#' This function is a constructor for the \code{cor_arma} class, +#' allowing for moving average terms only. +#' +#' @inheritParams cor_arma +#' @param q A non-negative integer specifying the moving average (MA) +#' order of the ARMA structure. Default is 1. +#' +#' @return An object of class \code{cor_arma} containing solely moving +#' average terms. +#' +#' @seealso \code{\link{cor_arma}} +#' +#' @examples +#' cor_ma(~visit|patient, q = 2) +#' +#' @export +cor_ma <- function(formula = ~1, q = 1, cov = FALSE) { + cor_arma(formula = formula, p = 0, q = q, cov = cov) +} + +#' (Defunct) ARR correlation structure +#' +#' The ARR correlation structure is no longer supported. +#' +#' @inheritParams cor_arma +#' +#' @keywords internal +#' @export +cor_arr <- function(formula = ~1, r = 1) { + cor_arma(formula = formula, p = 0, q = 0, r = r) +} + +#' (Deprecated) Compound Symmetry (COSY) Correlation Structure +#' +#' This function is deprecated. Please see \code{\link{cosy}} for the new syntax. +#' This functions is a constructor for the \code{cor_cosy} class, representing +#' a compound symmetry structure corresponding to uniform correlation. +#' +#' @aliases cor_cosy-class +#' +#' @inheritParams cor_arma +#' +#' @return An object of class \code{cor_cosy}, representing a compound symmetry +#' correlation structure. +#' +#' @examples +#' cor_cosy(~ visit | patient) +#' +#' @export +cor_cosy <- function(formula = ~1) { + formula <- as.formula(formula) + x <- nlist(formula) + class(x) <- c("cor_cosy", "cor_brms") + x +} + +#' (Deprecated) Spatial simultaneous autoregressive (SAR) structures +#' +#' Thse functions are deprecated. Please see \code{\link{sar}} for the new +#' syntax. These functions are constructors for the \code{cor_sar} class +#' implementing spatial simultaneous autoregressive structures. +#' The \code{lagsar} structure implements SAR of the response values: +#' \deqn{y = \rho W y + \eta + e} +#' The \code{errorsar} structure implements SAR of the residuals: +#' \deqn{y = \eta + u, u = \rho W u + e} +#' In the above equations, \eqn{\eta} is the predictor term and +#' \eqn{e} are independent normally or t-distributed residuals. +#' +#' @param W An object specifying the spatial weighting matrix. +#' Can be either the spatial weight matrix itself or an +#' object of class \code{listw} or \code{nb}, from which +#' the spatial weighting matrix can be computed. +#' @param type Type of the SAR structure. Either \code{"lag"} +#' (for SAR of the response values) or \code{"error"} +#' (for SAR of the residuals). +#' +#' @details Currently, only families \code{gaussian} and \code{student} +#' support SAR structures. +#' +#' @return An object of class \code{cor_sar} to be used in calls to +#' \code{\link{brm}}. +#' +#' @examples +#' \dontrun{ +#' data(oldcol, package = "spdep") +#' fit1 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, +#' autocor = cor_lagsar(COL.nb), +#' chains = 2, cores = 2) +#' summary(fit1) +#' plot(fit1) +#' +#' fit2 <- brm(CRIME ~ INC + HOVAL, data = COL.OLD, +#' autocor = cor_errorsar(COL.nb), +#' chains = 2, cores = 2) +#' summary(fit2) +#' plot(fit2) +#' } +#' +#' @export +cor_sar <- function(W, type = c("lag", "error")) { + type <- match.arg(type) + W_name <- deparse(substitute(W)) + W <- validate_sar_matrix(W) + structure( + nlist(W, W_name, type), + class = c("cor_sar", "cor_brms") + ) +} + +#' @rdname cor_sar +#' @export +cor_lagsar <- function(W) { + out <- cor_sar(W, type = "lag") + out$W_name <- deparse(substitute(W)) + out +} + +#' @rdname cor_sar +#' @export +cor_errorsar <- function(W) { + out <- cor_sar(W, type = "error") + out$W_name <- deparse(substitute(W)) + out +} + +#' (Deprecated) Spatial conditional autoregressive (CAR) structures +#' +#' These function are deprecated. Please see \code{\link{car}} for the new +#' syntax. These functions are constructors for the \code{cor_car} class +#' implementing spatial conditional autoregressive structures. +#' +#' @param W Adjacency matrix of locations. +#' All non-zero entries are treated as if the two locations +#' are adjacent. If \code{formula} contains a grouping factor, +#' the row names of \code{W} have to match the levels +#' of the grouping factor. +#' @param formula An optional one-sided formula of the form +#' \code{~ 1 | g}, where \code{g} is a grouping factor mapping +#' observations to spatial locations. If not specified, +#' each observation is treated as a separate location. +#' It is recommended to always specify a grouping factor +#' to allow for handling of new data in post-processing methods. +#' @param type Type of the CAR structure. Currently implemented +#' are \code{"escar"} (exact sparse CAR), \code{"esicar"} +#' (exact sparse intrinsic CAR), \code{"icar"} (intrinsic CAR), +#' and \code{"bym2"}. More information is provided in the 'Details' section. +#' +#' @details The \code{escar} and \code{esicar} types are +#' implemented based on the case study of Max Joseph +#' (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and +#' \code{bym2} type is implemented based on the case study of Mitzi Morris +#' (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). +#' +#' @examples +#' \dontrun{ +#' # generate some spatial data +#' east <- north <- 1:10 +#' Grid <- expand.grid(east, north) +#' K <- nrow(Grid) +#' +#' # set up distance and neighbourhood matrices +#' distance <- as.matrix(dist(Grid)) +#' W <- array(0, c(K, K)) +#' W[distance == 1] <- 1 +#' +#' # generate the covariates and response data +#' x1 <- rnorm(K) +#' x2 <- rnorm(K) +#' theta <- rnorm(K, sd = 0.05) +#' phi <- rmulti_normal( +#' 1, mu = rep(0, K), Sigma = 0.4 * exp(-0.1 * distance) +#' ) +#' eta <- x1 + x2 + phi +#' prob <- exp(eta) / (1 + exp(eta)) +#' size <- rep(50, K) +#' y <- rbinom(n = K, size = size, prob = prob) +#' dat <- data.frame(y, size, x1, x2) +#' +#' # fit a CAR model +#' fit <- brm(y | trials(size) ~ x1 + x2, data = dat, +#' family = binomial(), autocor = cor_car(W)) +#' summary(fit) +#' } +#' +#' @export +cor_car <- function(W, formula = ~1, type = "escar") { + options <- c("escar", "esicar", "icar", "bym2") + type <- match.arg(type, options) + W_name <- deparse(substitute(W)) + W <- validate_car_matrix(W) + formula <- as.formula(formula) + if (!is.null(lhs(formula))) { + stop2("'formula' should be a one-sided formula.") + } + if (length(attr(terms(formula), "term.labels")) > 1L) { + stop2("'formula' should not contain more than one term.") + } + structure( + nlist(W, W_name, formula, type), + class = c("cor_car", "cor_brms") + ) +} + +#' @rdname cor_car +#' @export +cor_icar <- function(W, formula = ~1) { + out <- cor_car(W, formula, type = "icar") + out$W_name <- deparse(substitute(W)) + out +} + +#' (Deprecated) Fixed user-defined covariance matrices +#' +#' This function is deprecated. Please see \code{\link{fcor}} for the new +#' syntax. Define a fixed covariance matrix of the response variable for +#' instance to model multivariate effect sizes in meta-analysis. +#' +#' @aliases cov_fixed +#' +#' @param V Known covariance matrix of the response variable. +#' If a vector is passed, it will be used as diagonal entries +#' (variances) and covariances will be set to zero. +#' +#' @return An object of class \code{cor_fixed}. +#' +#' @examples +#' \dontrun{ +#' dat <- data.frame(y = rnorm(3)) +#' V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) +#' fit <- brm(y~1, data = dat, autocor = cor_fixed(V)) +#' } +#' +#' @export +cor_fixed <- function(V) { + V_name <- deparse(substitute(V)) + if (is.vector(V)) { + V <- diag(V) + } else { + V <- as.matrix(V) + } + if (!isSymmetric(unname(V))) { + stop2("'V' must be symmetric") + } + structure(nlist(V, V_name), class = c("cor_fixed", "cor_brms")) +} + +#' (Defunct) Basic Bayesian Structural Time Series +#' +#' The BSTS correlation structure is no longer supported. +#' +#' @inheritParams cor_arma +#' +#' @keywords internal +#' @export +cor_bsts <- function(formula = ~1) { + stop2("The BSTS structure is no longer supported.") +} + +#' Check if argument is a correlation structure +#' +#' Check if argument is one of the correlation structures +#' used in \pkg{brms}. +#' +#' @param x An \R object. +#' +#' @export +is.cor_brms <- function(x) { + inherits(x, "cor_brms") +} + +#' @rdname is.cor_brms +#' @export +is.cor_arma <- function(x) { + inherits(x, "cor_arma") +} + +#' @rdname is.cor_brms +#' @export +is.cor_cosy <- function(x) { + inherits(x, "cor_cosy") +} + +#' @rdname is.cor_brms +#' @export +is.cor_sar <- function(x) { + inherits(x, "cor_sar") +} + +#' @rdname is.cor_brms +#' @export +is.cor_car <- function(x) { + inherits(x, "cor_car") +} + +#' @rdname is.cor_brms +#' @export +is.cor_fixed <- function(x) { + inherits(x, "cor_fixed") +} + +#' @export +print.cor_empty <- function(x, ...) { + cat("empty()\n") +} + +#' @export +print.cor_arma <- function(x, ...) { + cat(paste0("arma(", formula2str(x$formula), ", ", x$p, ", ", x$q, ")\n")) + invisible(x) +} + +#' @export +print.cor_cosy <- function(x, ...) { + cat(paste0("cosy(", formula2str(x$formula), ")\n")) + invisible(x) +} + +#' @export +print.cor_sar <- function(x, ...) { + cat(paste0("sar(", x$W_name, ", '", x$type, "')\n")) + invisible(x) +} + +#' @export +print.cor_car <- function(x, ...) { + form <- formula2str(x$formula) + cat(paste0("car(", x$W_name, ", ", form, ", '", x$type, "')\n")) + invisible(x) +} + +#' @export +print.cor_fixed <- function(x, ...) { + cat("Fixed covariance matrix: \n") + print(x$V) + invisible(x) +} + +#' @export +print.cov_fixed <- function(x, ...) { + class(x) <- "cor_fixed" + print.cor_fixed(x) +} + +stop_not_cor_brms <- function(x) { + if (!(is.null(x) || is.cor_brms(x))) { + stop2("Argument 'autocor' must be of class 'cor_brms'.") + } + TRUE +} + +# empty 'cor_brms' object +cor_empty <- function() { + structure(list(), class = c("cor_empty", "cor_brms")) +} + +is.cor_empty <- function(x) { + inherits(x, "cor_empty") +} + +#' (Deprecated) Extract Autocorrelation Objects +#' +#' @inheritParams posterior_predict.brmsfit +#' @param ... Currently unused. +#' +#' @return A \code{cor_brms} object or a list of such objects for multivariate +#' models. Not supported for models fitted with brms 2.11.1 or higher. +#' +#' @export +autocor.brmsfit <- function(object, resp = NULL, ...) { + warning2("Method 'autocor' is deprecated and will be removed in the future.") + object <- restructure(object) + resp <- validate_resp(resp, object) + if (!is.null(resp)) { + # multivariate model + autocor <- object$autocor[resp] + if (length(resp) == 1L) { + autocor <- autocor[[1]] + } + } else { + # univariate model + autocor <- object$autocor + } + autocor +} + +#' @rdname autocor.brmsfit +#' @export +autocor <- function(object, ...) { + UseMethod("autocor") +} + +# extract variables for autocorrelation structures +# @param autocor object of class 'cor_brms' +# @return a list with elements 'time', and 'group' +terms_autocor <- function(autocor) { + out <- list() + formula <- autocor$formula + if (is.null(formula)) { + formula <- ~1 + } + if (!is.null(lhs(formula))) { + stop2("Autocorrelation formulas must be one-sided.") + } + formula <- formula2str(formula) + time <- as.formula(paste("~", gsub("~|\\|[[:print:]]*", "", formula))) + time_vars <- all_vars(time) + if (is.cor_car(autocor) && length(time_vars) > 0L) { + stop2("The CAR structure should not contain a 'time' variable.") + } + if (length(time_vars) > 1L) { + stop2("Autocorrelation structures may only contain 1 time variable.") + } + if (length(time_vars)) { + out$time <- time_vars + } else { + out$time <- NA + } + group <- sub("^\\|*", "", sub("~[^\\|]*", "", formula)) + stopif_illegal_group(group) + group_vars <- all_vars(group) + if (length(group_vars)) { + out$group <- paste0(group_vars, collapse = ":") + } else { + out$group <- NA + } + out +} + +# transform a 'cor_brms' object into a formula +# this ensure compatibility with brms <= 2.11 +as_formula_cor_brms <- function(x) { + stop_not_cor_brms(x) + if (is.cor_empty(x)) { + return(NULL) + } + args <- data2 <- list() + pac <- terms_autocor(x) + if (is.cor_arma(x)) { + fun <- "arma" + args$time <- pac$time + args$gr <- pac$group + args$p <- x$p + args$q <- x$q + args$cov <- x$cov + out <- paste0(names(args), " = ", args, collapse = ", ") + out <- paste0("arma(", out, ")") + } else if (is.cor_cosy(x)) { + fun <- "cosy" + args$time <- pac$time + args$gr <- pac$group + } else if (is.cor_sar(x)) { + fun <- "sar" + args$M <- make_M_names(x$W_name) + args$type <- paste0("'", x$type, "'") + data2[[args$M]] <- x$W + } else if (is.cor_car(x)) { + fun <- "car" + args$M <- make_M_names(x$W_name) + args$gr <- pac$group + args$type <- paste0("'", x$type, "'") + data2[[args$M]] <- x$W + } else if (is.cor_fixed(x)) { + fun <- "fcor" + args$M <- make_M_names(x$V_name) + data2[[args$M]] <- x$V + } + out <- paste0(names(args), " = ", args, collapse = ", ") + out <- paste0(fun, "(", out, ")") + out <- str2formula(out) + attr(out, "data2") <- data2 + class(out) <- c("cor_brms_formula", "formula") + out +} + +# ensures covariance matrix inputs are named reasonably +make_M_names <- function(x) { + out <- make.names(x) + if (!length(out)) { + # likely unique random name for the matrix argument + out <- paste0("M", collapse(sample(0:9, 5, TRUE))) + } + out +} + +# get data objects from 'autocor' for use in 'data2' +# for backwards compatibility with brms <= 2.11 +get_data2_autocor <- function(x, ...) { + UseMethod("get_data2_autocor") +} + +#' @export +get_data2_autocor.brmsformula <- function(x, ...) { + attr(attr(x$formula, "autocor"), "data2") +} + +#' @export +get_data2_autocor.mvbrmsformula <- function(x, ...) { + ulapply(x$forms, get_data2_autocor, recursive = FALSE) +} + +#' @export +print.cor_brms_formula <- function(x, ...) { + y <- x + attr(y, "data2") <- NULL + class(y) <- "formula" + print(y) + invisible(x) +} diff -Nru r-cran-brms-2.16.3/R/backends.R r-cran-brms-2.17.0/R/backends.R --- r-cran-brms-2.16.3/R/backends.R 2021-10-28 18:31:46.000000000 +0000 +++ r-cran-brms-2.17.0/R/backends.R 2022-04-08 12:30:03.000000000 +0000 @@ -24,6 +24,9 @@ .parse_model_cmdstanr <- function(model, silent = 1, ...) { require_package("cmdstanr") temp_file <- cmdstanr::write_stan_file(model) + if (cmdstanr::cmdstan_version() >= "2.29.0") { + .canonicalize_stan_model(temp_file, overwrite_file = TRUE) + } out <- eval_silent( cmdstanr::cmdstan_model(temp_file, compile = FALSE, ...), type = "message", try = TRUE, silent = silent @@ -94,6 +97,9 @@ require_package("cmdstanr") args <- list(...) args$stan_file <- cmdstanr::write_stan_file(model) + if (cmdstanr::cmdstan_version() >= "2.29.0") { + .canonicalize_stan_model(args$stan_file, overwrite_file = TRUE) + } if (use_threading(threads)) { args$cpp_options$stan_threads <- TRUE } @@ -136,10 +142,10 @@ # @param model a compiled Stan model # @param sdata named list to be passed to Stan as data # @return a fitted Stan model -.fit_model_rstan <- function(model, sdata, algorithm, iter, warmup, thin, - chains, cores, threads, opencl, inits, exclude, +.fit_model_rstan <- function(model, sdata, algorithm, iter, warmup, thin, + chains, cores, threads, opencl, init, exclude, seed, control, silent, future, ...) { - + # some input checks and housekeeping if (use_threading(threads)) { if (utils::packageVersion("rstan") >= 2.26) { @@ -155,19 +161,21 @@ stop2("OpenCL is not supported by backend 'rstan' version ", utils::packageVersion("rstan"), ".") } - if (is.character(inits) && !inits %in% c("random", "0")) { - inits <- get(inits, mode = "function", envir = parent.frame()) + if (is.null(init)) { + init <- "random" + } else if (is.character(init) && !init %in% c("random", "0")) { + init <- get(init, mode = "function", envir = parent.frame()) } args <- nlist( - object = model, data = sdata, iter, seed, - init = inits, pars = exclude, include = FALSE + object = model, data = sdata, iter, seed, + init = init, pars = exclude, include = FALSE ) dots <- list(...) args[names(dots)] <- dots - + # do the actual sampling if (silent < 2) { - message("Start sampling") + message("Start sampling") } if (algorithm %in% c("sampling", "fixed_param")) { c(args) <- nlist(warmup, thin, control, show_messages = !silent) @@ -182,23 +190,23 @@ futures <- fits <- vector("list", chains) for (i in seq_len(chains)) { args$chain_id <- i - if (is.list(inits)) { - args$init <- inits[i] + if (is.list(init)) { + args$init <- init[i] } futures[[i]] <- future::future( - brms::do_call(rstan::sampling, args), + brms::do_call(rstan::sampling, args), packages = "rstan", seed = TRUE ) } for (i in seq_len(chains)) { - fits[[i]] <- future::value(futures[[i]]) + fits[[i]] <- future::value(futures[[i]]) } out <- rstan::sflist2stanfit(fits) rm(futures, fits) } else { c(args) <- nlist(chains, cores) - out <- do_call(rstan::sampling, args) + out <- do_call(rstan::sampling, args) } } else if (algorithm %in% c("fullrank", "meanfield")) { # vb does not support parallel execution @@ -215,27 +223,31 @@ # @param model a compiled Stan model # @param sdata named list to be passed to Stan as data # @return a fitted Stan model -.fit_model_cmdstanr <- function(model, sdata, algorithm, iter, warmup, thin, - chains, cores, threads, opencl, inits, exclude, +.fit_model_cmdstanr <- function(model, sdata, algorithm, iter, warmup, thin, + chains, cores, threads, opencl, init, exclude, seed, control, silent, future, ...) { - + require_package("cmdstanr") # some input checks and housekeeping class(sdata) <- "list" if (isNA(seed)) { seed <- NULL } - if (is_equal(inits, "random")) { - inits <- NULL - } else if (is_equal(inits, "0")) { - inits <- 0 + if (is_equal(init, "random")) { + init <- NULL + } else if (is_equal(init, "0")) { + init <- 0 } if (future) { stop2("Argument 'future' is not supported by backend 'cmdstanr'.") } - args <- nlist(data = sdata, seed, init = inits) + args <- nlist(data = sdata, seed, init) if (use_threading(threads)) { - args$threads_per_chain <- threads$threads + if (algorithm %in% c("sampling", "fixed_param")) { + args$threads_per_chain <- threads$threads + } else if (algorithm %in% c("fullrank", "meanfield")) { + args$threads <- threads$threads + } } if (use_opencl(opencl)) { args$opencl_ids <- opencl$ids @@ -244,7 +256,7 @@ dots <- list(...) args[names(dots)] <- dots args[names(control)] <- control - + chains <- as_one_numeric(chains) empty_model <- chains <= 0 if (empty_model) { @@ -256,16 +268,16 @@ thin <- 1 cores <- 1 } - + # do the actual sampling if (silent < 2) { - message("Start sampling") + message("Start sampling") } if (algorithm %in% c("sampling", "fixed_param")) { c(args) <- nlist( iter_sampling = iter - warmup, - iter_warmup = warmup, - chains, thin, + iter_warmup = warmup, + chains, thin, parallel_chains = cores, show_messages = !silent, fixed_param = algorithm == "fixed_param" @@ -296,8 +308,8 @@ } # fit model with a mock backend for testing -.fit_model_mock <- function(model, sdata, algorithm, iter, warmup, thin, - chains, cores, threads, opencl, inits, exclude, +.fit_model_mock <- function(model, sdata, algorithm, iter, warmup, thin, + chains, cores, threads, opencl, init, exclude, seed, control, silent, future, mock_fit, ...) { if (is.function(mock_fit)) { out <- mock_fit() @@ -331,7 +343,7 @@ out <- FALSE } else if (backend == "cmdstanr") { exe_file <- attributes(x$fit)$CmdStanModel$exe_file() - out <- !is.character(exe_file) || !exists(exe_file) + out <- !is.character(exe_file) || !file.exists(exe_file) } else if (backend == "mock") { out <- FALSE } @@ -339,20 +351,20 @@ } #' Recompile Stan models in \code{brmsfit} objects -#' +#' #' Recompile the Stan model inside a \code{brmsfit} object, if necessary. #' This does not change the model, it simply recreates the executable -#' so that sampling is possible again. -#' +#' so that sampling is possible again. +#' #' @param x An object of class \code{brmsfit}. #' @param recompile Logical, indicating whether the Stan model should be #' recompiled. If \code{NULL} (the default), \code{recompile_model} tries #' to figure out internally, if recompilation is necessary. Setting it to #' \code{FALSE} will cause \code{recompile_model} to always return the #' \code{brmsfit} object unchanged. -#' +#' #' @return A (possibly updated) \code{brmsfit} object. -#' +#' #' @export recompile_model <- function(x, recompile = NULL) { stopifnot(is.brmsfit(x)) @@ -366,7 +378,7 @@ message("Recompiling the Stan model") backend <- x$backend %||% "rstan" new_model <- compile_model( - stancode(x), backend = backend, threads = x$threads, + stancode(x), backend = backend, threads = x$threads, opencl = x$opencl, silent = 2 ) if (backend == "rstan") { @@ -392,7 +404,7 @@ sampling = out[, "sample"] ) out$total <- out$warmup + out$sampling - rownames(out) <- NULL + rownames(out) <- NULL } else if (backend == "cmdstanr") { out <- attributes(x$fit)$metadata$time$chains } else if (backend == "mock") { @@ -422,12 +434,12 @@ } #' Threading in Stan -#' +#' #' Use threads for within-chain parallelization in \pkg{Stan} via the \pkg{brms} #' interface. Within-chain parallelization is experimental! We recommend its use #' only if you are experienced with Stan's \code{reduce_sum} function and have a #' slow running model that cannot be sped up by any other means. -#' +#' #' @param threads Number of threads to use in within-chain parallelization. #' @param grainsize Number of observations evaluated together in one chunk on #' one of the CPUs used for threading. If \code{NULL} (the default), @@ -438,7 +450,7 @@ #' \code{reduce_sum}? Defaults to \code{FALSE}. Setting it to \code{TRUE} #' is required to achieve exact reproducibility of the model results #' (if the random seed is set as well). -#' +#' #' @return A \code{brmsthreads} object which can be passed to the #' \code{threads} argument of \code{brm} and related functions. #' @@ -451,10 +463,10 @@ #' roughly the same amount of computing time, we recommend storing #' observations in random order in the data. At least, please avoid sorting #' observations after the response values. This is because the latter often -#' cause variations in the computing time of the pointwise log-likelihood, +#' cause variations in the computing time of the pointwise log-likelihood, #' which makes up a big part of the parallelized code. -#' -#' @examples +#' +#' @examples #' \dontrun{ #' # this model just serves as an illustration #' # threading may not actually speed things up here @@ -464,7 +476,7 @@ #' backend = "cmdstanr") #' summary(fit) #' } -#' +#' #' @export threading <- function(threads = NULL, grainsize = NULL, static = FALSE) { out <- list(threads = NULL, grainsize = NULL) @@ -499,7 +511,7 @@ threads <- as_one_numeric(threads) threads <- threading(threads) } else if (!is.brmsthreads(threads)) { - stop2("Argument 'threads' needs to be numeric or ", + stop2("Argument 'threads' needs to be numeric or ", "specified via the 'threading' function.") } threads @@ -511,23 +523,23 @@ } #' GPU support in Stan via OpenCL -#' -#' Use OpenCL for GPU support in \pkg{Stan} via the \pkg{brms} interface. Only +#' +#' Use OpenCL for GPU support in \pkg{Stan} via the \pkg{brms} interface. Only #' some \pkg{Stan} functions can be run on a GPU at this point and so #' a lot of \pkg{brms} models won't benefit from OpenCL for now. -#' +#' #' @param ids (integer vector of length 2) The platform and device IDs of the #' OpenCL device to use for fitting. If you don't know the IDs of your OpenCL #' device, \code{c(0,0)} is most likely what you need. -#' +#' #' @return A \code{brmsopencl} object which can be passed to the #' \code{opencl} argument of \code{brm} and related functions. -#' +#' #' @details For more details on OpenCL in \pkg{Stan}, check out #' \url{https://mc-stan.org/docs/2_26/cmdstan-guide/parallelization.html#opencl} #' as well as \url{https://mc-stan.org/docs/2_26/stan-users-guide/opencl.html}. -#' -#' @examples +#' +#' @examples #' \dontrun{ #' # this model just serves as an illustration #' # OpenCL may not actually speed things up here @@ -537,7 +549,7 @@ #' backend = "cmdstanr") #' summary(fit) #' } -#' +#' #' @export opencl <- function(ids = NULL) { out <- list(ids = NULL) @@ -563,7 +575,7 @@ } else if (is.numeric(opencl)) { opencl <- opencl(opencl) } else if (!is.brmsopencl(opencl)) { - stop2("Argument 'opencl' needs to an integer vector or ", + stop2("Argument 'opencl' needs to an integer vector or ", "specified via the 'opencl' function.") } opencl @@ -606,3 +618,34 @@ file_refit_options <- function() { c("never", "always", "on_change") } + +.canonicalize_stan_model <- function(stan_file, overwrite_file = TRUE) { + if (os_is_windows()) { + stanc_cmd <- "bin/stanc.exe" + } else { + stanc_cmd <- "bin/stanc" + } + stanc_flags <- c( + "--auto-format", + "--canonicalize=deprecations,braces,parentheses" + ) + if (cmdstanr::cmdstan_version() >= "2.29.0") { + require_package("processx") + res <- processx::run( + command = stanc_cmd, + args = c(stan_file, stanc_flags), + wd = cmdstanr::cmdstan_path(), + echo = FALSE, + echo_cmd = FALSE, + spinner = FALSE, + stderr_callback = function(x, p) { + message(x) + }, + error_on_status = TRUE + ) + if (overwrite_file) { + cat(res$stdout, file = stan_file, sep = "\n") + } + } + res$stdout +} diff -Nru r-cran-brms-2.16.3/R/bayes_R2.R r-cran-brms-2.17.0/R/bayes_R2.R --- r-cran-brms-2.16.3/R/bayes_R2.R 2021-08-26 17:47:33.000000000 +0000 +++ r-cran-brms-2.17.0/R/bayes_R2.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,94 +1,94 @@ -#' Compute a Bayesian version of R-squared for regression models -#' -#' @aliases bayes_R2 -#' -#' @inheritParams predict.brmsfit -#' @param ... Further arguments passed to -#' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}, -#' which is used in the computation of the R-squared values. -#' -#' @return If \code{summary = TRUE}, an M x C matrix is returned -#' (M = number of response variables and c = \code{length(probs) + 2}) -#' containing summary statistics of the Bayesian R-squared values. -#' If \code{summary = FALSE}, the posterior draws of the Bayesian -#' R-squared values are returned in an S x M matrix (S is the number of draws). -#' -#' @details For an introduction to the approach, see Gelman et al. (2018) -#' and \url{https://github.com/jgabry/bayes_R2/}. -#' -#' @references Andrew Gelman, Ben Goodrich, Jonah Gabry & Aki Vehtari. (2018). -#' R-squared for Bayesian regression models, \emph{The American Statistician}. -#' \code{10.1080/00031305.2018.1549100} (Preprint available at -#' \url{https://stat.columbia.edu/~gelman/research/published/bayes_R2_v3.pdf}) -#' -#' @examples -#' \dontrun{ -#' fit <- brm(mpg ~ wt + cyl, data = mtcars) -#' summary(fit) -#' bayes_R2(fit) -#' -#' # compute R2 with new data -#' nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) -#' bayes_R2(fit, newdata = nd) -#' } -#' -#' @method bayes_R2 brmsfit -#' @importFrom rstantools bayes_R2 -#' @export bayes_R2 -#' @export -bayes_R2.brmsfit <- function(object, resp = NULL, summary = TRUE, - robust = FALSE, probs = c(0.025, 0.975), ...) { - contains_draws(object) - object <- restructure(object) - resp <- validate_resp(resp, object) - summary <- as_one_logical(summary) - # check for precomputed values - R2 <- get_criterion(object, "bayes_R2") - if (is.matrix(R2)) { - # assumes unsummarized 'R2' as ensured by 'add_criterion' - take <- colnames(R2) %in% paste0("R2", resp) - R2 <- R2[, take, drop = FALSE] - if (summary) { - R2 <- posterior_summary(R2, probs = probs, robust = robust) - } - return(R2) - } - family <- family(object, resp = resp) - if (conv_cats_dpars(family)) { - stop2("'bayes_R2' is not defined for unordered categorical models.") - } - if (is_ordinal(family)) { - warning2( - "Predictions are treated as continuous variables in ", - "'bayes_R2' which is likely invalid for ordinal families." - ) - } - args_y <- list(object, warn = TRUE, ...) - args_ypred <- list(object, sort = TRUE, ...) - R2 <- named_list(paste0("R2", resp)) - for (i in seq_along(R2)) { - # assumes expectations of different responses to be independent - args_ypred$resp <- args_y$resp <- resp[i] - y <- do_call(get_y, args_y) - ypred <- do_call(posterior_epred, args_ypred) - if (is_ordinal(family(object, resp = resp[i]))) { - ypred <- ordinal_probs_continuous(ypred) - } - R2[[i]] <- .bayes_R2(y, ypred) - } - R2 <- do_call(cbind, R2) - colnames(R2) <- paste0("R2", resp) - if (summary) { - R2 <- posterior_summary(R2, probs = probs, robust = robust) - } - R2 -} - -# internal function of bayes_R2.brmsfit -# see https://github.com/jgabry/bayes_R2/blob/master/bayes_R2.pdf -.bayes_R2 <- function(y, ypred, ...) { - e <- -1 * sweep(ypred, 2, y) - var_ypred <- matrixStats::rowVars(ypred) - var_e <- matrixStats::rowVars(e) - as.matrix(var_ypred / (var_ypred + var_e)) -} +#' Compute a Bayesian version of R-squared for regression models +#' +#' @aliases bayes_R2 +#' +#' @inheritParams predict.brmsfit +#' @param ... Further arguments passed to +#' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}, +#' which is used in the computation of the R-squared values. +#' +#' @return If \code{summary = TRUE}, an M x C matrix is returned +#' (M = number of response variables and c = \code{length(probs) + 2}) +#' containing summary statistics of the Bayesian R-squared values. +#' If \code{summary = FALSE}, the posterior draws of the Bayesian +#' R-squared values are returned in an S x M matrix (S is the number of draws). +#' +#' @details For an introduction to the approach, see Gelman et al. (2018) +#' and \url{https://github.com/jgabry/bayes_R2/}. +#' +#' @references Andrew Gelman, Ben Goodrich, Jonah Gabry & Aki Vehtari. (2018). +#' R-squared for Bayesian regression models, \emph{The American Statistician}. +#' \code{10.1080/00031305.2018.1549100} (Preprint available at +#' \url{https://stat.columbia.edu/~gelman/research/published/bayes_R2_v3.pdf}) +#' +#' @examples +#' \dontrun{ +#' fit <- brm(mpg ~ wt + cyl, data = mtcars) +#' summary(fit) +#' bayes_R2(fit) +#' +#' # compute R2 with new data +#' nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) +#' bayes_R2(fit, newdata = nd) +#' } +#' +#' @method bayes_R2 brmsfit +#' @importFrom rstantools bayes_R2 +#' @export bayes_R2 +#' @export +bayes_R2.brmsfit <- function(object, resp = NULL, summary = TRUE, + robust = FALSE, probs = c(0.025, 0.975), ...) { + contains_draws(object) + object <- restructure(object) + resp <- validate_resp(resp, object) + summary <- as_one_logical(summary) + # check for precomputed values + R2 <- get_criterion(object, "bayes_R2") + if (is.matrix(R2)) { + # assumes unsummarized 'R2' as ensured by 'add_criterion' + take <- colnames(R2) %in% paste0("R2", resp) + R2 <- R2[, take, drop = FALSE] + if (summary) { + R2 <- posterior_summary(R2, probs = probs, robust = robust) + } + return(R2) + } + family <- family(object, resp = resp) + if (conv_cats_dpars(family)) { + stop2("'bayes_R2' is not defined for unordered categorical models.") + } + if (is_ordinal(family)) { + warning2( + "Predictions are treated as continuous variables in ", + "'bayes_R2' which is likely invalid for ordinal families." + ) + } + args_y <- list(object, warn = TRUE, ...) + args_ypred <- list(object, sort = TRUE, ...) + R2 <- named_list(paste0("R2", resp)) + for (i in seq_along(R2)) { + # assumes expectations of different responses to be independent + args_ypred$resp <- args_y$resp <- resp[i] + y <- do_call(get_y, args_y) + ypred <- do_call(posterior_epred, args_ypred) + if (is_ordinal(family(object, resp = resp[i]))) { + ypred <- ordinal_probs_continuous(ypred) + } + R2[[i]] <- .bayes_R2(y, ypred) + } + R2 <- do_call(cbind, R2) + colnames(R2) <- paste0("R2", resp) + if (summary) { + R2 <- posterior_summary(R2, probs = probs, robust = robust) + } + R2 +} + +# internal function of bayes_R2.brmsfit +# see https://github.com/jgabry/bayes_R2/blob/master/bayes_R2.pdf +.bayes_R2 <- function(y, ypred, ...) { + e <- -1 * sweep(ypred, 2, y) + var_ypred <- matrixStats::rowVars(ypred) + var_e <- matrixStats::rowVars(e) + as.matrix(var_ypred / (var_ypred + var_e)) +} diff -Nru r-cran-brms-2.16.3/R/bridgesampling.R r-cran-brms-2.17.0/R/bridgesampling.R --- r-cran-brms-2.16.3/R/bridgesampling.R 2021-08-26 17:47:33.000000000 +0000 +++ r-cran-brms-2.17.0/R/bridgesampling.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,248 +1,248 @@ -#' Log Marginal Likelihood via Bridge Sampling -#' -#' Computes log marginal likelihood via bridge sampling, -#' which can be used in the computation of bayes factors -#' and posterior model probabilities. -#' The \code{brmsfit} method is just a thin wrapper around -#' the corresponding method for \code{stanfit} objects. -#' -#' @aliases bridge_sampler -#' -#' @param samples A \code{brmsfit} object. -#' @param ... Additional arguments passed to -#' \code{\link[bridgesampling:bridge_sampler]{bridge_sampler.stanfit}}. -#' -#' @details Computing the marginal likelihood requires samples of all variables -#' defined in Stan's \code{parameters} block to be saved. Otherwise -#' \code{bridge_sampler} cannot be computed. Thus, please set \code{save_pars -#' = save_pars(all = TRUE)} in the call to \code{brm}, if you are planning to -#' apply \code{bridge_sampler} to your models. -#' -#' The computation of marginal likelihoods based on bridge sampling requires -#' a lot more posterior draws than usual. A good conservative -#' rule of thump is perhaps 10-fold more draws (read: the default of 4000 -#' draws may not be enough in many cases). If not enough posterior -#' draws are provided, the bridge sampling algorithm tends to be -#' unstable leading to considerably different results each time it is run. -#' We thus recommend running \code{bridge_sampler} -#' multiple times to check the stability of the results. -#' -#' More details are provided under -#' \code{\link[bridgesampling:bridge_sampler]{bridgesampling::bridge_sampler}}. -#' -#' @seealso \code{ -#' \link[brms:bayes_factor.brmsfit]{bayes_factor}, -#' \link[brms:post_prob.brmsfit]{post_prob} -#' } -#' -#' @examples -#' \dontrun{ -#' # model with the treatment effect -#' fit1 <- brm( -#' count ~ zAge + zBase + Trt, -#' data = epilepsy, family = negbinomial(), -#' prior = prior(normal(0, 1), class = b), -#' save_pars = save_pars(all = TRUE) -#' ) -#' summary(fit1) -#' bridge_sampler(fit1) -#' -#' # model without the treatment effect -#' fit2 <- brm( -#' count ~ zAge + zBase, -#' data = epilepsy, family = negbinomial(), -#' prior = prior(normal(0, 1), class = b), -#' save_pars = save_pars(all = TRUE) -#' ) -#' summary(fit2) -#' bridge_sampler(fit2) -#' } -#' -#' @method bridge_sampler brmsfit -#' @importFrom bridgesampling bridge_sampler -#' @export bridge_sampler -#' @export -bridge_sampler.brmsfit <- function(samples, ...) { - out <- get_criterion(samples, "marglik") - if (inherits(out, "bridge") && !is.na(out$logml)) { - # return precomputed criterion - return(out) - } - samples <- restructure(samples) - if (samples$version$brms <= "1.8.0") { - stop2( - "Models fitted with brms 1.8.0 or lower are not ", - "usable in method 'bridge_sampler'." - ) - } - if (!is_normalized(samples$model)) { - stop2( - "The Stan model has to be normalized to be ", - "usable in method 'bridge_sampler'." - ) - } - # otherwise bridge_sampler might not work in a new R session - samples <- update_misc_env(samples) - out <- try(bridge_sampler(samples$fit, ...)) - if (is(out, "try-error")) { - stop2( - "Bridgesampling failed. Perhaps you did not set ", - "'save_pars = save_pars(all = TRUE)' when fitting your model?" - ) - } - out -} - -#' Bayes Factors from Marginal Likelihoods -#' -#' Compute Bayes factors from marginal likelihoods. -#' -#' @aliases bayes_factor -#' -#' @param x1 A \code{brmsfit} object -#' @param x2 Another \code{brmsfit} object based on the same responses. -#' @param log Report Bayes factors on the log-scale? -#' @param ... Additional arguments passed to -#' \code{\link[brms:bridge_sampler.brmsfit]{bridge_sampler}}. -#' -#' @details Computing the marginal likelihood requires samples -#' of all variables defined in Stan's \code{parameters} block -#' to be saved. Otherwise \code{bayes_factor} cannot be computed. -#' Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, -#' if you are planning to apply \code{bayes_factor} to your models. -#' -#' The computation of Bayes factors based on bridge sampling requires -#' a lot more posterior samples than usual. A good conservative -#' rule of thumb is perhaps 10-fold more samples (read: the default of 4000 -#' samples may not be enough in many cases). If not enough posterior -#' samples are provided, the bridge sampling algorithm tends to be unstable, -#' leading to considerably different results each time it is run. -#' We thus recommend running \code{bayes_factor} -#' multiple times to check the stability of the results. -#' -#' More details are provided under -#' \code{\link[bridgesampling:bf]{bridgesampling::bayes_factor}}. -#' -#' @seealso \code{ -#' \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, -#' \link[brms:post_prob.brmsfit]{post_prob} -#' } -#' -#' @examples -#' \dontrun{ -#' # model with the treatment effect -#' fit1 <- brm( -#' count ~ zAge + zBase + Trt, -#' data = epilepsy, family = negbinomial(), -#' prior = prior(normal(0, 1), class = b), -#' save_all_pars = TRUE -#' ) -#' summary(fit1) -#' -#' # model without the treatment effect -#' fit2 <- brm( -#' count ~ zAge + zBase, -#' data = epilepsy, family = negbinomial(), -#' prior = prior(normal(0, 1), class = b), -#' save_all_pars = TRUE -#' ) -#' summary(fit2) -#' -#' # compute the bayes factor -#' bayes_factor(fit1, fit2) -#' } -#' -#' @method bayes_factor brmsfit -#' @importFrom bridgesampling bayes_factor -#' @export bayes_factor -#' @export -bayes_factor.brmsfit <- function(x1, x2, log = FALSE, ...) { - model_name_1 <- deparse_combine(substitute(x1)) - model_name_2 <- deparse_combine(substitute(x2)) - match_response(list(x1, x2)) - bridge1 <- bridge_sampler(x1, ...) - bridge2 <- bridge_sampler(x2, ...) - out <- bayes_factor(bridge1, bridge2, log = log) - attr(out, "model_names") <- c(model_name_1, model_name_2) - out -} - -#' Posterior Model Probabilities from Marginal Likelihoods -#' -#' Compute posterior model probabilities from marginal likelihoods. -#' The \code{brmsfit} method is just a thin wrapper around -#' the corresponding method for \code{bridge} objects. -#' -#' @aliases post_prob -#' -#' @inheritParams loo.brmsfit -#' @param prior_prob Numeric vector with prior model probabilities. -#' If omitted, a uniform prior is used (i.e., all models are equally -#' likely a priori). The default \code{NULL} corresponds to equal -#' prior model weights. -#' -#' @details Computing the marginal likelihood requires samples -#' of all variables defined in Stan's \code{parameters} block -#' to be saved. Otherwise \code{post_prob} cannot be computed. -#' Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, -#' if you are planning to apply \code{post_prob} to your models. -#' -#' The computation of model probabilities based on bridge sampling requires -#' a lot more posterior samples than usual. A good conservative -#' rule of thump is perhaps 10-fold more samples (read: the default of 4000 -#' samples may not be enough in many cases). If not enough posterior -#' samples are provided, the bridge sampling algorithm tends to be -#' unstable leading to considerably different results each time it is run. -#' We thus recommend running \code{post_prob} -#' multiple times to check the stability of the results. -#' -#' More details are provided under -#' \code{\link[bridgesampling:post_prob]{bridgesampling::post_prob}}. -#' -#' @seealso \code{ -#' \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, -#' \link[brms:bayes_factor.brmsfit]{bayes_factor} -#' } -#' -#' @examples -#' \dontrun{ -#' # model with the treatment effect -#' fit1 <- brm( -#' count ~ zAge + zBase + Trt, -#' data = epilepsy, family = negbinomial(), -#' prior = prior(normal(0, 1), class = b), -#' save_all_pars = TRUE -#' ) -#' summary(fit1) -#' -#' # model without the treatent effect -#' fit2 <- brm( -#' count ~ zAge + zBase, -#' data = epilepsy, family = negbinomial(), -#' prior = prior(normal(0, 1), class = b), -#' save_all_pars = TRUE -#' ) -#' summary(fit2) -#' -#' # compute the posterior model probabilities -#' post_prob(fit1, fit2) -#' -#' # specify prior model probabilities -#' post_prob(fit1, fit2, prior_prob = c(0.8, 0.2)) -#' } -#' -#' @method post_prob brmsfit -#' @importFrom bridgesampling post_prob -#' @export post_prob -#' @export -post_prob.brmsfit <- function(x, ..., prior_prob = NULL, model_names = NULL) { - args <- split_dots(x, ..., model_names = model_names) - models <- args$models - args$models <- NULL - bs <- vector("list", length(models)) - for (i in seq_along(models)) { - bs[[i]] <- do_call(bridge_sampler, c(list(models[[i]]), args)) - } - model_names <- names(models) - do_call(post_prob, c(bs, nlist(prior_prob, model_names))) -} +#' Log Marginal Likelihood via Bridge Sampling +#' +#' Computes log marginal likelihood via bridge sampling, +#' which can be used in the computation of bayes factors +#' and posterior model probabilities. +#' The \code{brmsfit} method is just a thin wrapper around +#' the corresponding method for \code{stanfit} objects. +#' +#' @aliases bridge_sampler +#' +#' @param samples A \code{brmsfit} object. +#' @param ... Additional arguments passed to +#' \code{\link[bridgesampling:bridge_sampler]{bridge_sampler.stanfit}}. +#' +#' @details Computing the marginal likelihood requires samples of all variables +#' defined in Stan's \code{parameters} block to be saved. Otherwise +#' \code{bridge_sampler} cannot be computed. Thus, please set \code{save_pars +#' = save_pars(all = TRUE)} in the call to \code{brm}, if you are planning to +#' apply \code{bridge_sampler} to your models. +#' +#' The computation of marginal likelihoods based on bridge sampling requires +#' a lot more posterior draws than usual. A good conservative +#' rule of thump is perhaps 10-fold more draws (read: the default of 4000 +#' draws may not be enough in many cases). If not enough posterior +#' draws are provided, the bridge sampling algorithm tends to be +#' unstable leading to considerably different results each time it is run. +#' We thus recommend running \code{bridge_sampler} +#' multiple times to check the stability of the results. +#' +#' More details are provided under +#' \code{\link[bridgesampling:bridge_sampler]{bridgesampling::bridge_sampler}}. +#' +#' @seealso \code{ +#' \link[brms:bayes_factor.brmsfit]{bayes_factor}, +#' \link[brms:post_prob.brmsfit]{post_prob} +#' } +#' +#' @examples +#' \dontrun{ +#' # model with the treatment effect +#' fit1 <- brm( +#' count ~ zAge + zBase + Trt, +#' data = epilepsy, family = negbinomial(), +#' prior = prior(normal(0, 1), class = b), +#' save_pars = save_pars(all = TRUE) +#' ) +#' summary(fit1) +#' bridge_sampler(fit1) +#' +#' # model without the treatment effect +#' fit2 <- brm( +#' count ~ zAge + zBase, +#' data = epilepsy, family = negbinomial(), +#' prior = prior(normal(0, 1), class = b), +#' save_pars = save_pars(all = TRUE) +#' ) +#' summary(fit2) +#' bridge_sampler(fit2) +#' } +#' +#' @method bridge_sampler brmsfit +#' @importFrom bridgesampling bridge_sampler +#' @export bridge_sampler +#' @export +bridge_sampler.brmsfit <- function(samples, ...) { + out <- get_criterion(samples, "marglik") + if (inherits(out, "bridge") && !is.na(out$logml)) { + # return precomputed criterion + return(out) + } + samples <- restructure(samples) + if (samples$version$brms <= "1.8.0") { + stop2( + "Models fitted with brms 1.8.0 or lower are not ", + "usable in method 'bridge_sampler'." + ) + } + if (!is_normalized(samples$model)) { + stop2( + "The Stan model has to be normalized to be ", + "usable in method 'bridge_sampler'." + ) + } + # otherwise bridge_sampler might not work in a new R session + samples <- update_misc_env(samples) + out <- try(bridge_sampler(samples$fit, ...)) + if (is(out, "try-error")) { + stop2( + "Bridgesampling failed. Perhaps you did not set ", + "'save_pars = save_pars(all = TRUE)' when fitting your model?" + ) + } + out +} + +#' Bayes Factors from Marginal Likelihoods +#' +#' Compute Bayes factors from marginal likelihoods. +#' +#' @aliases bayes_factor +#' +#' @param x1 A \code{brmsfit} object +#' @param x2 Another \code{brmsfit} object based on the same responses. +#' @param log Report Bayes factors on the log-scale? +#' @param ... Additional arguments passed to +#' \code{\link[brms:bridge_sampler.brmsfit]{bridge_sampler}}. +#' +#' @details Computing the marginal likelihood requires samples +#' of all variables defined in Stan's \code{parameters} block +#' to be saved. Otherwise \code{bayes_factor} cannot be computed. +#' Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, +#' if you are planning to apply \code{bayes_factor} to your models. +#' +#' The computation of Bayes factors based on bridge sampling requires +#' a lot more posterior samples than usual. A good conservative +#' rule of thumb is perhaps 10-fold more samples (read: the default of 4000 +#' samples may not be enough in many cases). If not enough posterior +#' samples are provided, the bridge sampling algorithm tends to be unstable, +#' leading to considerably different results each time it is run. +#' We thus recommend running \code{bayes_factor} +#' multiple times to check the stability of the results. +#' +#' More details are provided under +#' \code{\link[bridgesampling:bf]{bridgesampling::bayes_factor}}. +#' +#' @seealso \code{ +#' \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, +#' \link[brms:post_prob.brmsfit]{post_prob} +#' } +#' +#' @examples +#' \dontrun{ +#' # model with the treatment effect +#' fit1 <- brm( +#' count ~ zAge + zBase + Trt, +#' data = epilepsy, family = negbinomial(), +#' prior = prior(normal(0, 1), class = b), +#' save_all_pars = TRUE +#' ) +#' summary(fit1) +#' +#' # model without the treatment effect +#' fit2 <- brm( +#' count ~ zAge + zBase, +#' data = epilepsy, family = negbinomial(), +#' prior = prior(normal(0, 1), class = b), +#' save_all_pars = TRUE +#' ) +#' summary(fit2) +#' +#' # compute the bayes factor +#' bayes_factor(fit1, fit2) +#' } +#' +#' @method bayes_factor brmsfit +#' @importFrom bridgesampling bayes_factor +#' @export bayes_factor +#' @export +bayes_factor.brmsfit <- function(x1, x2, log = FALSE, ...) { + model_name_1 <- deparse_combine(substitute(x1)) + model_name_2 <- deparse_combine(substitute(x2)) + match_response(list(x1, x2)) + bridge1 <- bridge_sampler(x1, ...) + bridge2 <- bridge_sampler(x2, ...) + out <- bayes_factor(bridge1, bridge2, log = log) + attr(out, "model_names") <- c(model_name_1, model_name_2) + out +} + +#' Posterior Model Probabilities from Marginal Likelihoods +#' +#' Compute posterior model probabilities from marginal likelihoods. +#' The \code{brmsfit} method is just a thin wrapper around +#' the corresponding method for \code{bridge} objects. +#' +#' @aliases post_prob +#' +#' @inheritParams loo.brmsfit +#' @param prior_prob Numeric vector with prior model probabilities. +#' If omitted, a uniform prior is used (i.e., all models are equally +#' likely a priori). The default \code{NULL} corresponds to equal +#' prior model weights. +#' +#' @details Computing the marginal likelihood requires samples +#' of all variables defined in Stan's \code{parameters} block +#' to be saved. Otherwise \code{post_prob} cannot be computed. +#' Thus, please set \code{save_all_pars = TRUE} in the call to \code{brm}, +#' if you are planning to apply \code{post_prob} to your models. +#' +#' The computation of model probabilities based on bridge sampling requires +#' a lot more posterior samples than usual. A good conservative +#' rule of thump is perhaps 10-fold more samples (read: the default of 4000 +#' samples may not be enough in many cases). If not enough posterior +#' samples are provided, the bridge sampling algorithm tends to be +#' unstable leading to considerably different results each time it is run. +#' We thus recommend running \code{post_prob} +#' multiple times to check the stability of the results. +#' +#' More details are provided under +#' \code{\link[bridgesampling:post_prob]{bridgesampling::post_prob}}. +#' +#' @seealso \code{ +#' \link[brms:bridge_sampler.brmsfit]{bridge_sampler}, +#' \link[brms:bayes_factor.brmsfit]{bayes_factor} +#' } +#' +#' @examples +#' \dontrun{ +#' # model with the treatment effect +#' fit1 <- brm( +#' count ~ zAge + zBase + Trt, +#' data = epilepsy, family = negbinomial(), +#' prior = prior(normal(0, 1), class = b), +#' save_all_pars = TRUE +#' ) +#' summary(fit1) +#' +#' # model without the treatent effect +#' fit2 <- brm( +#' count ~ zAge + zBase, +#' data = epilepsy, family = negbinomial(), +#' prior = prior(normal(0, 1), class = b), +#' save_all_pars = TRUE +#' ) +#' summary(fit2) +#' +#' # compute the posterior model probabilities +#' post_prob(fit1, fit2) +#' +#' # specify prior model probabilities +#' post_prob(fit1, fit2, prior_prob = c(0.8, 0.2)) +#' } +#' +#' @method post_prob brmsfit +#' @importFrom bridgesampling post_prob +#' @export post_prob +#' @export +post_prob.brmsfit <- function(x, ..., prior_prob = NULL, model_names = NULL) { + args <- split_dots(x, ..., model_names = model_names) + models <- args$models + args$models <- NULL + bs <- vector("list", length(models)) + for (i in seq_along(models)) { + bs[[i]] <- do_call(bridge_sampler, c(list(models[[i]]), args)) + } + model_names <- names(models) + do_call(post_prob, c(bs, nlist(prior_prob, model_names))) +} diff -Nru r-cran-brms-2.16.3/R/brm_multiple.R r-cran-brms-2.17.0/R/brm_multiple.R --- r-cran-brms-2.16.3/R/brm_multiple.R 2021-10-04 06:14:17.000000000 +0000 +++ r-cran-brms-2.17.0/R/brm_multiple.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,11 +1,11 @@ #' Run the same \pkg{brms} model on multiple datasets -#' +#' #' Run the same \pkg{brms} model on multiple datasets and then combine the #' results into one fitted model object. This is useful in particular for #' multiple missing value imputation, where the same model is fitted on multiple #' imputed data sets. Models can be run in parallel using the \pkg{future} #' package. -#' +#' #' @inheritParams brm #' @param data A \emph{list} of data.frames each of which will be used to fit a #' separate model. Alternatively, a \code{mids} object from the \pkg{mice} @@ -30,52 +30,52 @@ #' ignored. It is not recommended to use this argument directly, but to call #' the \code{\link[brms:update.brmsfit_multiple]{update}} method, instead. #' @param ... Further arguments passed to \code{\link{brm}}. -#' +#' #' @details The combined model may issue false positive convergence warnings, as #' the MCMC chains corresponding to different datasets may not necessarily #' overlap, even if each of the original models did converge. To find out #' whether each of the original models converged, investigate #' \code{fit$rhats}, where \code{fit} denotes the output of #' \code{brm_multiple}. -#' +#' #' @return If \code{combine = TRUE} a \code{brmsfit_multiple} object, which #' inherits from class \code{brmsfit} and behaves essentially the same. If #' \code{combine = FALSE} a list of \code{brmsfit} objects. -#' +#' #' @author Paul-Christian Buerkner \email{paul.buerkner@@gmail.com} -#' +#' #' @examples #' \dontrun{ #' library(mice) #' imp <- mice(nhanes2) -#' +#' #' # fit the model using mice and lm #' fit_imp1 <- with(lm(bmi ~ age + hyp + chl), data = imp) #' summary(pool(fit_imp1)) -#' +#' #' # fit the model using brms #' fit_imp2 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) #' summary(fit_imp2) #' plot(fit_imp2, pars = "^b_") #' # investigate convergence of the original models #' fit_imp2$rhats -#' +#' #' # use the future package for parallelization #' library(future) #' plan(multiprocess) #' fit_imp3 <- brm_multiple(bmi~age+hyp+chl, data = imp, chains = 1) #' summary(fit_imp3) #' } -#' +#' #' @export -brm_multiple <- function(formula, data, family = gaussian(), prior = NULL, - data2 = NULL, autocor = NULL, cov_ranef = NULL, - sample_prior = c("no", "yes", "only"), +brm_multiple <- function(formula, data, family = gaussian(), prior = NULL, + data2 = NULL, autocor = NULL, cov_ranef = NULL, + sample_prior = c("no", "yes", "only"), sparse = NULL, knots = NULL, stanvars = NULL, stan_funs = NULL, silent = 1, recompile = FALSE, - combine = TRUE, fit = NA, seed = NA, + combine = TRUE, fit = NA, seed = NA, file = NULL, file_refit = "never", ...) { - + combine <- as_one_logical(combine) file_refit <- match.arg(file_refit, file_refit_options()) if (!is.null(file)) { @@ -90,10 +90,10 @@ fits <- read_brmsfit(file) if (!is.null(fits)) { return(fits) - } + } } } - + silent <- validate_silent(silent) recompile <- as_one_logical(recompile) data_name <- substitute_name(data) @@ -111,14 +111,14 @@ stop2("'data2' must have the same length as 'data'.") } } - + if (is.brmsfit(fit)) { # avoid complications when updating the model class(fit) <- setdiff(class(fit), "brmsfit_multiple") } else { args <- nlist( - formula, data = data[[1]], family, prior, data2 = data2[[1]], - autocor, cov_ranef, sample_prior, sparse, knots, stanvars, + formula, data = data[[1]], family, prior, data2 = data2[[1]], + autocor, cov_ranef, sample_prior, sparse, knots, stanvars, stan_funs, silent, seed, ... ) args$chains <- 0 @@ -127,14 +127,14 @@ } fit <- suppressMessages(do_call(brm, args)) } - + dots <- list(...) # allow compiling the model without sampling (#671) if (isTRUE(dots$chains == 0) || isTRUE(dots$iter == 0)) { class(fit) <- c("brmsfit_multiple", class(fit)) return(fit) } - + fits <- futures <- rhats <- vector("list", length(data)) for (i in seq_along(data)) { futures[[i]] <- future::future( @@ -145,9 +145,9 @@ } for (i in seq_along(data)) { if (silent < 2) { - message("Fitting imputed model ", i) + message("Fitting imputed model ", i) } - fits[[i]] <- future::value(futures[[i]]) + fits[[i]] <- future::value(futures[[i]]) rhats[[i]] <- data.frame(as.list(rhat(fits[[i]]))) if (any(rhats[[i]] > 1.1, na.rm = TRUE)) { warning2("Imputed model ", i, " did not converge.") @@ -166,23 +166,23 @@ } #' Combine Models fitted with \pkg{brms} -#' +#' #' Combine multiple \code{brmsfit} objects, which fitted the same model. #' This is usefully for instance when having manually run models in parallel. -#' +#' #' @param ... One or more \code{brmsfit} objects. #' @param mlist Optional list of one or more \code{brmsfit} objects. #' @param check_data Logical; indicates if the data should be checked #' for being the same across models (defaults to \code{TRUE}). #' Setting it to \code{FALSE} may be useful for instance #' when combining models fitted on multiple imputed data sets. -#' -#' @details This function just takes the first model and replaces -#' its \code{stanfit} object (slot \code{fit}) by the combined +#' +#' @details This function just takes the first model and replaces +#' its \code{stanfit} object (slot \code{fit}) by the combined #' \code{stanfit} objects of all models. -#' +#' #' @return A \code{brmsfit} object. -#' +#' #' @export combine_models <- function(..., mlist = NULL, check_data = TRUE) { models <- c(list(...), mlist) @@ -198,7 +198,7 @@ } ref_formula <- formula(models[[1]]) ref_pars <- variables(models[[1]]) - ref_mf <- model.frame(models[[1]]) + ref_mf <- model.frame(models[[1]]) for (i in seq_along(models)[-1]) { if (!is_equal(formula(models[[i]]), ref_formula)) { stop2("Models 1 and ", i, " have different formulas.") @@ -208,7 +208,7 @@ } if (check_data && !is_equal(model.frame(models[[i]]), ref_mf)) { stop2( - "Models 1 and ", i, " have different data. ", + "Models 1 and ", i, " have different data. ", "Set 'check_data' to FALSE to turn off checking of the data." ) } @@ -231,7 +231,7 @@ warn_brmsfit_multiple <- function(x, newdata = NULL) { if (is.brmsfit_multiple(x) && is.null(newdata)) { warning2( - "Using only the first imputed data set. Please interpret the results ", + "Using only the first imputed data set. Please interpret the results ", "with caution until a more principled approach has been implemented." ) } diff -Nru r-cran-brms-2.16.3/R/brm.R r-cran-brms-2.17.0/R/brm.R --- r-cran-brms-2.16.3/R/brm.R 2021-10-28 18:31:28.000000000 +0000 +++ r-cran-brms-2.17.0/R/brm.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,19 +1,19 @@ #' Fit Bayesian Generalized (Non-)Linear Multivariate Multilevel Models -#' -#' Fit Bayesian generalized (non-)linear multivariate multilevel models -#' using Stan for full Bayesian inference. A wide range of distributions -#' and link functions are supported, allowing users to fit -- among others -- -#' linear, robust linear, count data, survival, response times, ordinal, -#' zero-inflated, hurdle, and even self-defined mixture models all in a -#' multilevel context. Further modeling options include non-linear and -#' smooth terms, auto-correlation structures, censored data, meta-analytic -#' standard errors, and quite a few more. In addition, all parameters of the -#' response distributions can be predicted in order to perform distributional -#' regression. Prior specifications are flexible and explicitly encourage +#' +#' Fit Bayesian generalized (non-)linear multivariate multilevel models +#' using Stan for full Bayesian inference. A wide range of distributions +#' and link functions are supported, allowing users to fit -- among others -- +#' linear, robust linear, count data, survival, response times, ordinal, +#' zero-inflated, hurdle, and even self-defined mixture models all in a +#' multilevel context. Further modeling options include non-linear and +#' smooth terms, auto-correlation structures, censored data, meta-analytic +#' standard errors, and quite a few more. In addition, all parameters of the +#' response distributions can be predicted in order to perform distributional +#' regression. Prior specifications are flexible and explicitly encourage #' users to apply prior distributions that actually reflect their beliefs. #' In addition, model fit can easily be assessed and compared with #' posterior predictive checks and leave-one-out cross-validation. -#' +#' #' @param formula An object of class \code{\link[stats:formula]{formula}}, #' \code{\link{brmsformula}}, or \code{\link{mvbrmsformula}} (or one that can #' be coerced to that classes): A symbolic description of the model to be @@ -34,7 +34,7 @@ #' \code{c} method or the \code{+} operator. See also \code{\link{get_prior}} #' for more help. #' @param data2 A named \code{list} of objects containing data, which -#' cannot be passed via argument \code{data}. Required for some objects +#' cannot be passed via argument \code{data}. Required for some objects #' used in autocorrelation structures to specify dependency structures #' as well as for within-group covariance matrices. #' @param autocor (Deprecated) An optional \code{\link{cor_brms}} object @@ -56,7 +56,7 @@ #' matrices should correspond to columns in \code{data} that are used as #' grouping factors. All levels of the grouping factor should appear as #' rownames of the corresponding matrix. This argument can be used, among -#' others to model pedigrees and phylogenetic effects. +#' others to model pedigrees and phylogenetic effects. #' It is now recommended to specify those matrices in the formula #' interface using the \code{\link{gr}} and related functions. See #' \code{vignette("brms_phylogenetics")} for more details. @@ -106,20 +106,21 @@ #' arguments modifying the model code or data are ignored. It is not #' recommended to use this argument directly, but to call the #' \code{\link[brms:update.brmsfit]{update}} method, instead. -#' @param inits Either \code{"random"} or \code{"0"}. If inits is -#' \code{"random"} (the default), Stan will randomly generate initial values -#' for parameters. If it is \code{"0"}, all parameters are initialized to -#' zero. This option is sometimes useful for certain families, as it happens -#' that default (\code{"random"}) inits cause draws to be essentially -#' constant. Generally, setting \code{inits = "0"} is worth a try, if chains -#' do not behave well. Alternatively, \code{inits} can be a list of lists -#' containing the initial values, or a function (or function name) generating -#' initial values. The latter options are mainly implemented for internal -#' testing but are available to users if necessary. If specifying initial -#' values using a list or a function then currently the parameter names must -#' correspond to the names used in the generated Stan code (not the names -#' used in \R). For more details on specifying initial values you can consult -#' the documentation of the selected \code{backend}. +#' @param init Initial values for the sampler. If \code{NULL} (the default) or +#' \code{"random"}, Stan will randomly generate initial values for parameters +#' in a reasonable range. If \code{0}, all parameters are initialized to zero +#' on the unconstrained space. This option is sometimes useful for certain +#' families, as it happens that default random initial values cause draws to +#' be essentially constant. Generally, setting \code{init = 0} is worth a try, +#' if chains do not initialize or behave well. Alternatively, \code{init} can +#' be a list of lists containing the initial values, or a function (or +#' function name) generating initial values. The latter options are mainly +#' implemented for internal testing but are available to users if necessary. +#' If specifying initial values using a list or a function then currently the +#' parameter names must correspond to the names used in the generated Stan +#' code (not the names used in \R). For more details on specifying initial +#' values you can consult the documentation of the selected \code{backend}. +#' @param inits (Deprecated) Alias of \code{init}. #' @param chains Number of Markov chains (defaults to 4). #' @param iter Number of total iterations per chain (including warmup; defaults #' to 2000). @@ -140,16 +141,19 @@ #' \code{brmsthreads} object created by \code{\link{threading}}. Within-chain #' parallelization is experimental! We recommend its use only if you are #' experienced with Stan's \code{reduce_sum} function and have a slow running -#' model that cannot be sped up by any other means. +#' model that cannot be sped up by any other means. Can be set globally for +#' the current \R session via the \code{"brms.threads"} option (see +#' \code{\link{options}}). #' @param opencl The platform and device IDs of the OpenCL device to use for -#' fitting using GPU support. If you don't know the IDs of your OpenCL -#' device, \code{c(0,0)} is most likely what you need. For more details, see -#' \code{\link{opencl}}. +#' fitting using GPU support. If you don't know the IDs of your OpenCL device, +#' \code{c(0,0)} is most likely what you need. For more details, see +#' \code{\link{opencl}}. Can be set globally for the current \R session via +#' the \code{"brms.opencl"} option #' @param normalize Logical. Indicates whether normalization constants should #' be included in the Stan code (defaults to \code{TRUE}). Setting it #' to \code{FALSE} requires Stan version >= 2.25 to work. If \code{FALSE}, #' sampling efficiency may be increased but some post processing functions -#' such as \code{\link{bridge_sampler}} will not be available. Can be +#' such as \code{\link{bridge_sampler}} will not be available. Can be #' controlled globally for the current \R session via the `brms.normalize` #' option. #' @param algorithm Character string naming the estimation approach to use. @@ -166,7 +170,7 @@ #' \pkg{rstan} and \pkg{cmdstanr} packages are available at #' \url{https://mc-stan.org/rstan/} and \url{https://mc-stan.org/cmdstanr/}, #' respectively. Additionally a \code{"mock"} backend is available to make -#' testing \pkg{brms} and packages that depend on it easier. +#' testing \pkg{brms} and packages that depend on it easier. #' The \code{"mock"} backend does not actually do any fitting, it only checks #' the generated Stan code for correctness and then returns whatever is passed #' in an additional \code{mock_fit} argument as the result of the fit. @@ -197,14 +201,14 @@ #' fitted model object is saved via \code{\link{saveRDS}} in a file named #' after the string supplied in \code{file}. The \code{.rds} extension is #' added automatically. If the file already exists, \code{brm} will load and -#' return the saved model object instead of refitting the model. +#' return the saved model object instead of refitting the model. #' Unless you specify the \code{file_refit} argument as well, the existing #' files won't be overwritten, you have to manually remove the file in order #' to refit and save the model under an existing file name. The file name #' is stored in the \code{brmsfit} object for later usage. #' @param file_refit Modifies when the fit stored via the \code{file} parameter #' is re-used. Can be set globally for the current \R session via the -#' \code{"brms.file_refit"} option (see \code{\link{options}}). +#' \code{"brms.file_refit"} option (see \code{\link{options}}). #' For \code{"never"} (default) the fit is always loaded if it #' exists and fitting is skipped. For \code{"always"} the model is always #' refitted. If set to \code{"on_change"}, brms will @@ -221,19 +225,19 @@ #' and compiled and the corresponding \code{'fit'} slot of the \code{brmsfit} #' object will be empty. This is useful if you have estimated a brms-created #' Stan model outside of \pkg{brms} and want to feed it back into the package. -#' @param rename For internal use only. +#' @param rename For internal use only. #' @param stan_model_args A \code{list} of further arguments passed to #' \code{\link[rstan:stan_model]{stan_model}}. -#' @param ... Further arguments passed to Stan. +#' @param ... Further arguments passed to Stan. #' For \code{backend = "rstan"} the arguments are passed to #' \code{\link[rstan]{sampling}} or \code{\link[rstan]{vb}}. #' For \code{backend = "cmdstanr"} the arguments are passed to the #' \code{cmdstanr::sample} or \code{cmdstanr::variational} method. -#' +#' #' @return An object of class \code{brmsfit}, which contains the posterior #' draws along with many other useful information about the model. Use #' \code{methods(class = "brmsfit")} for an overview on available methods. -#' +#' #' @author Paul-Christian Buerkner \email{paul.buerkner@@gmail.com} #' #' @details Fit a generalized (non-)linear multivariate multilevel model via @@ -290,13 +294,13 @@ #' usually be larger than the current default of \code{10}. For more details #' on the \code{control} argument see \code{\link[rstan:stan]{stan}}. #' -#' @references -#' Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel -#' Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. +#' @references +#' Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel +#' Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. #' \code{doi:10.18637/jss.v080.i01} -#' -#' Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling -#' with the R Package brms. \emph{The R Journal}. 10(1), 395–411. +#' +#' Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling +#' with the R Package brms. \emph{The R Journal}. 10(1), 395–411. #' \code{doi:10.32614/RJ-2018-017} #' #' @seealso \code{\link{brms}}, \code{\link{brmsformula}}, @@ -361,7 +365,7 @@ #' # Non-linear Gaussian model #' fit5 <- brm( #' bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), -#' ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, +#' ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, #' nl = TRUE), #' data = loss, family = gaussian(), #' prior = c( @@ -402,8 +406,8 @@ #' library(future) #' plan(multiprocess) #' fit7 <- update(fit7, future = TRUE) -#' -#' +#' +#' #' # fit a model manually via rstan #' scode <- make_stancode(count ~ Trt, data = epilepsy) #' sdata <- make_standata(count ~ Trt, data = epilepsy) @@ -420,25 +424,26 @@ #' @import stats #' @import Rcpp #' @export -brm <- function(formula, data, family = gaussian(), prior = NULL, - autocor = NULL, data2 = NULL, cov_ranef = NULL, +brm <- function(formula, data, family = gaussian(), prior = NULL, + autocor = NULL, data2 = NULL, cov_ranef = NULL, sample_prior = "no", sparse = NULL, knots = NULL, - stanvars = NULL, stan_funs = NULL, fit = NA, - save_pars = NULL, save_ranef = NULL, - save_mevars = NULL, save_all_pars = NULL, - inits = "random", chains = 4, iter = 2000, + stanvars = NULL, stan_funs = NULL, fit = NA, + save_pars = NULL, save_ranef = NULL, + save_mevars = NULL, save_all_pars = NULL, + init = NULL, inits = NULL, chains = 4, iter = 2000, warmup = floor(iter / 2), thin = 1, - cores = getOption("mc.cores", 1), - threads = NULL, opencl = NULL, + cores = getOption("mc.cores", 1), + threads = getOption("brms.threads", NULL), + opencl = getOption("brms.opencl", NULL), normalize = getOption("brms.normalize", TRUE), - control = NULL, + control = NULL, algorithm = getOption("brms.algorithm", "sampling"), backend = getOption("brms.backend", "rstan"), - future = getOption("future", FALSE), silent = 1, + future = getOption("future", FALSE), silent = 1, seed = NA, save_model = NULL, stan_model_args = list(), - file = NULL, file_refit = getOption("brms.file_refit", "never"), + file = NULL, file_refit = getOption("brms.file_refit", "never"), empty = FALSE, rename = TRUE, ...) { - + # optionally load brmsfit from file # Loading here only when we should directly load the file. # The "on_change" option needs sdata and scode to be built @@ -449,7 +454,7 @@ return(x) } } - + # validate arguments later passed to Stan algorithm <- match.arg(algorithm, algorithm_choices()) backend <- match.arg(backend, backend_choices()) @@ -460,13 +465,14 @@ thin <- as_one_numeric(thin) chains <- as_one_numeric(chains) cores <- as_one_numeric(cores) + init <- use_alias(init, inits) threads <- validate_threads(threads) opencl <- validate_opencl(opencl) future <- as_one_logical(future) && chains > 0L seed <- as_one_numeric(seed, allow_na = TRUE) empty <- as_one_logical(empty) rename <- as_one_logical(rename) - + # initialize brmsfit object if (is.brmsfit(fit)) { # re-use existing model @@ -488,23 +494,23 @@ backend <- x$backend model <- compiled_model(x) exclude <- exclude_pars(x) - } else { + } else { # build new model formula <- validate_formula( - formula, data = data, family = family, + formula, data = data, family = family, autocor = autocor, sparse = sparse, cov_ranef = cov_ranef ) family <- get_element(formula, "family") bterms <- brmsterms(formula) data2 <- validate_data2( - data2, bterms = bterms, + data2, bterms = bterms, get_data2_autocor(formula), get_data2_cov_ranef(formula) ) data_name <- substitute_name(data) data <- validate_data( - data, bterms = bterms, + data, bterms = bterms, data2 = data2, knots = knots ) attr(data, "data_name") <- data_name @@ -514,23 +520,23 @@ ) stanvars <- validate_stanvars(stanvars, stan_funs = stan_funs) save_pars <- validate_save_pars( - save_pars, save_ranef = save_ranef, + save_pars, save_ranef = save_ranef, save_mevars = save_mevars, save_all_pars = save_all_pars ) ranef <- tidy_ranef(bterms, data = data) # generate Stan code model <- .make_stancode( - bterms, data = data, prior = prior, + bterms, data = data, prior = prior, stanvars = stanvars, save_model = save_model, backend = backend, threads = threads, opencl = opencl, normalize = normalize ) - + # initialize S3 object x <- brmsfit( - formula = formula, data = data, data2 = data2, prior = prior, - stanvars = stanvars, model = model, algorithm = algorithm, + formula = formula, data = data, data2 = data2, prior = prior, + stanvars = stanvars, model = model, algorithm = algorithm, backend = backend, threads = threads, opencl = opencl, save_pars = save_pars, ranef = ranef, family = family ) @@ -538,15 +544,15 @@ # generate Stan data before compiling the model to avoid # unnecessary compilations in case of invalid data sdata <- .make_standata( - bterms, data = data, prior = prior, data2 = data2, + bterms, data = data, prior = prior, data2 = data2, stanvars = stanvars, threads = threads ) - + if (empty) { # return the brmsfit object with an empty 'fit' slot return(x) } - + if (!is.null(file) && file_refit == "on_change") { x_from_file <- read_brmsfit(file) if (!is.null(x_from_file)) { @@ -559,7 +565,7 @@ } } } - + # compile the Stan model compile_args <- stan_model_args compile_args$model <- model @@ -569,17 +575,17 @@ compile_args$silent <- silent model <- do_call(compile_model, compile_args) } - + # fit the Stan model fit_args <- nlist( model, sdata, algorithm, backend, iter, warmup, thin, chains, cores, - threads, opencl, inits, exclude, control, future, seed, silent, ... + threads, opencl, init, exclude, control, future, seed, silent, ... ) x$fit <- do_call(fit_model, fit_args) # rename parameters to have human readable names if (rename) { - x <- rename_pars(x) + x <- rename_pars(x) } if (!is.null(file)) { x <- write_brmsfit(x, file) diff -Nru r-cran-brms-2.16.3/R/brmsfit-class.R r-cran-brms-2.17.0/R/brmsfit-class.R --- r-cran-brms-2.16.3/R/brmsfit-class.R 2021-08-26 17:47:33.000000000 +0000 +++ r-cran-brms-2.17.0/R/brmsfit-class.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,102 +1,102 @@ -#' Class \code{brmsfit} of models fitted with the \pkg{brms} package -#' -#' Models fitted with the \code{\link[brms:brms-package]{brms}} package are -#' represented as a \code{brmsfit} object, which contains the posterior -#' draws (samples), model formula, Stan code, relevant data, and other information. -#' -#' @name brmsfit-class -#' @aliases brmsfit -#' @docType class -#' -#' @details -#' See \code{methods(class = "brmsfit")} for an overview of available methods. -#' -#' @slot formula A \code{\link{brmsformula}} object. -#' @slot data A \code{data.frame} containing all variables used in the model. -#' @slot data2 A \code{list} of data objects which cannot be passed -#' via \code{data}. -#' @slot prior A \code{\link{brmsprior}} object containing -#' information on the priors used in the model. -#' @slot stanvars A \code{\link{stanvars}} object. -#' @slot model The model code in \pkg{Stan} language. -#' @slot ranef A \code{data.frame} containing the group-level structure. -#' @slot exclude The names of the parameters for which draws are not saved. -#' @slot algorithm The name of the algorithm used to fit the model. -#' @slot backend The name of the backend used to fit the model. -#' @slot threads An object of class `brmsthreads` created by -#' \code{\link{threading}}. -#' @slot opencl An object of class `brmsopencl` created by \code{\link{opencl}}. -#' @slot fit An object of class \code{\link[rstan:stanfit-class]{stanfit}} -#' among others containing the posterior draws. -#' @slot criteria An empty \code{list} for adding model fit criteria -#' after estimation of the model. -#' @slot file Optional name of a file in which the model object was stored in -#' or loaded from. -#' @slot version The versions of \pkg{brms} and \pkg{rstan} with -#' which the model was fitted. -#' @slot family (Deprecated) A \code{\link{brmsfamily}} object. -#' @slot autocor (Deprecated) An \code{\link{cor_brms}} object containing -#' the autocorrelation structure if specified. -#' @slot cov_ranef (Deprecated) A \code{list} of customized group-level -#' covariance matrices. -#' @slot stan_funs (Deprecated) A character string of length one or \code{NULL}. -#' @slot data.name (Deprecated) The name of \code{data} as specified by the user. -#' -#' @seealso -#' \code{\link{brms}}, -#' \code{\link{brm}}, -#' \code{\link{brmsformula}}, -#' \code{\link{brmsfamily}} -#' -NULL - -# brmsfit class -brmsfit <- function(formula = NULL, data = data.frame(), prior = empty_prior(), - data2 = list(), stanvars = NULL, model = "", - ranef = empty_ranef(), save_pars = NULL, - algorithm = "sampling", backend = "rstan", - threads = threading(), opencl = opencl(), - fit = NULL, criteria = list(), - file = NULL, family = NULL, autocor = NULL, - cov_ranef = NULL, stan_funs = NULL, data.name = "") { - version <- list( - brms = utils::packageVersion("brms"), - rstan = utils::packageVersion("rstan"), - stanHeaders = utils::packageVersion("StanHeaders") - ) - if (backend == "cmdstanr") { - require_package("cmdstanr") - version$cmdstanr <- utils::packageVersion("cmdstanr") - version$cmdstan <- as.package_version(cmdstanr::cmdstan_version()) - } - x <- nlist( - formula, data, prior, data2, stanvars, model, ranef, - save_pars, algorithm, backend, threads, opencl, fit, criteria, file, - version, family, autocor, cov_ranef, stan_funs, data.name - ) - class(x) <- "brmsfit" - x -} - -#' Checks if argument is a \code{brmsfit} object -#' -#' @param x An \R object -#' -#' @export -is.brmsfit <- function(x) { - inherits(x, "brmsfit") -} - -#' Checks if argument is a \code{brmsfit_multiple} object -#' -#' @param x An \R object -#' -#' @export -is.brmsfit_multiple <- function(x) { - inherits(x, "brmsfit_multiple") -} - -is.stanfit <- function(x) { - inherits(x, "stanfit") -} - +#' Class \code{brmsfit} of models fitted with the \pkg{brms} package +#' +#' Models fitted with the \code{\link[brms:brms-package]{brms}} package are +#' represented as a \code{brmsfit} object, which contains the posterior +#' draws (samples), model formula, Stan code, relevant data, and other information. +#' +#' @name brmsfit-class +#' @aliases brmsfit +#' @docType class +#' +#' @details +#' See \code{methods(class = "brmsfit")} for an overview of available methods. +#' +#' @slot formula A \code{\link{brmsformula}} object. +#' @slot data A \code{data.frame} containing all variables used in the model. +#' @slot data2 A \code{list} of data objects which cannot be passed +#' via \code{data}. +#' @slot prior A \code{\link{brmsprior}} object containing +#' information on the priors used in the model. +#' @slot stanvars A \code{\link{stanvars}} object. +#' @slot model The model code in \pkg{Stan} language. +#' @slot ranef A \code{data.frame} containing the group-level structure. +#' @slot exclude The names of the parameters for which draws are not saved. +#' @slot algorithm The name of the algorithm used to fit the model. +#' @slot backend The name of the backend used to fit the model. +#' @slot threads An object of class `brmsthreads` created by +#' \code{\link{threading}}. +#' @slot opencl An object of class `brmsopencl` created by \code{\link{opencl}}. +#' @slot fit An object of class \code{\link[rstan:stanfit-class]{stanfit}} +#' among others containing the posterior draws. +#' @slot criteria An empty \code{list} for adding model fit criteria +#' after estimation of the model. +#' @slot file Optional name of a file in which the model object was stored in +#' or loaded from. +#' @slot version The versions of \pkg{brms} and \pkg{rstan} with +#' which the model was fitted. +#' @slot family (Deprecated) A \code{\link{brmsfamily}} object. +#' @slot autocor (Deprecated) An \code{\link{cor_brms}} object containing +#' the autocorrelation structure if specified. +#' @slot cov_ranef (Deprecated) A \code{list} of customized group-level +#' covariance matrices. +#' @slot stan_funs (Deprecated) A character string of length one or \code{NULL}. +#' @slot data.name (Deprecated) The name of \code{data} as specified by the user. +#' +#' @seealso +#' \code{\link{brms}}, +#' \code{\link{brm}}, +#' \code{\link{brmsformula}}, +#' \code{\link{brmsfamily}} +#' +NULL + +# brmsfit class +brmsfit <- function(formula = NULL, data = data.frame(), prior = empty_prior(), + data2 = list(), stanvars = NULL, model = "", + ranef = empty_ranef(), save_pars = NULL, + algorithm = "sampling", backend = "rstan", + threads = threading(), opencl = opencl(), + fit = NULL, criteria = list(), + file = NULL, family = NULL, autocor = NULL, + cov_ranef = NULL, stan_funs = NULL, data.name = "") { + version <- list( + brms = utils::packageVersion("brms"), + rstan = utils::packageVersion("rstan"), + stanHeaders = utils::packageVersion("StanHeaders") + ) + if (backend == "cmdstanr") { + require_package("cmdstanr") + version$cmdstanr <- utils::packageVersion("cmdstanr") + version$cmdstan <- as.package_version(cmdstanr::cmdstan_version()) + } + x <- nlist( + formula, data, prior, data2, stanvars, model, ranef, + save_pars, algorithm, backend, threads, opencl, fit, criteria, file, + version, family, autocor, cov_ranef, stan_funs, data.name + ) + class(x) <- "brmsfit" + x +} + +#' Checks if argument is a \code{brmsfit} object +#' +#' @param x An \R object +#' +#' @export +is.brmsfit <- function(x) { + inherits(x, "brmsfit") +} + +#' Checks if argument is a \code{brmsfit_multiple} object +#' +#' @param x An \R object +#' +#' @export +is.brmsfit_multiple <- function(x) { + inherits(x, "brmsfit_multiple") +} + +is.stanfit <- function(x) { + inherits(x, "stanfit") +} + diff -Nru r-cran-brms-2.16.3/R/brmsfit-helpers.R r-cran-brms-2.17.0/R/brmsfit-helpers.R --- r-cran-brms-2.16.3/R/brmsfit-helpers.R 2021-10-28 18:08:12.000000000 +0000 +++ r-cran-brms-2.17.0/R/brmsfit-helpers.R 2022-04-08 11:57:41.000000000 +0000 @@ -12,57 +12,89 @@ stopifnot_resp <- function(x, resp = NULL) { if (is_mv(x) && length(resp) != 1L) { - stop2("Argument 'resp' must be a single variable name ", + stop2("Argument 'resp' must be a single variable name ", "when applying this method to a multivariate model.") } invisible(NULL) } -# apply a link function +# apply a link function # @param x an array of arbitrary dimension # @param link character string defining the link link <- function(x, link) { - switch(link, - "identity" = x, - "log" = log(x), - "logm1" = logm1(x), - "log1p" = log1p(x), - "inverse" = 1 / x, - "sqrt" = sqrt(x), - "1/mu^2" = 1 / x^2, - "tan_half" = tan(x / 2), - "logit" = logit(x), - "probit" = qnorm(x), - "cauchit" = qcauchy(x), - "cloglog" = cloglog(x), - "probit_approx" = qnorm(x), - "softplus" = log_expm1(x), - "squareplus" = (x^2 - 1) / x, - stop2("Link '", link, "' not supported.") + switch(link, + identity = x, + log = log(x), + logm1 = logm1(x), + log1p = log1p(x), + inverse = 1 / x, + sqrt = sqrt(x), + "1/mu^2" = 1 / x^2, + tan_half = tan(x / 2), + logit = logit(x), + probit = qnorm(x), + cauchit = qcauchy(x), + cloglog = cloglog(x), + probit_approx = qnorm(x), + softplus = log_expm1(x), + squareplus = (x^2 - 1) / x, + softit = softit(x), + stop2("Link '", link, "' is not supported.") ) } # apply an inverse link function # @param x an array of arbitrary dimension # @param link a character string defining the link -ilink <- function(x, link) { - switch(link, - "identity" = x, - "log" = exp(x), - "logm1" = expp1(x), - "log1p" = expm1(x), - "inverse" = 1 / x, - "sqrt" = x^2, - "1/mu^2" = 1 / sqrt(x), - "tan_half" = 2 * atan(x), - "logit" = inv_logit(x), - "probit" = pnorm(x), - "cauchit" = pcauchy(x), - "cloglog" = inv_cloglog(x), - "probit_approx" = pnorm(x), - "softplus" = log1p_exp(x), - "squareplus" = (x + sqrt(x^2 + 4)) / 2, - stop2("Link '", link, "' not supported.") +inv_link <- function(x, link) { + switch(link, + identity = x, + log = exp(x), + logm1 = expp1(x), + log1p = expm1(x), + inverse = 1 / x, + sqrt = x^2, + "1/mu^2" = 1 / sqrt(x), + tan_half = 2 * atan(x), + logit = inv_logit(x), + probit = pnorm(x), + cauchit = pcauchy(x), + cloglog = inv_cloglog(x), + probit_approx = pnorm(x), + softplus = log1p_exp(x), + squareplus = (x + sqrt(x^2 + 4)) / 2, + softit = inv_softit(x), + stop2("Link '", link, "' is not supported.") + ) +} + +# log CDF for unit interval link functions +# @param x an array of arbitrary dimension +# @param link a character string defining the link +log_cdf <- function(x, link) { + switch(link, + logit = log_inv_logit(x), + probit = pnorm(x, log.p = TRUE), + cauchit = pcauchy(x, log.p = TRUE), + cloglog = log1m_exp(-exp(x)), + probit_approx = pnorm(x, log.p = TRUE), + softit = log_inv_softit(x), + stop2("Link '", link, "' is not supported.") + ) +} + +# log CCDF for unit interval link functions +# @param x an array of arbitrary dimension +# @param link a character string defining the link +log_ccdf <- function(x, link) { + switch(link, + logit = log1m_inv_logit(x), + probit = pnorm(x, log.p = TRUE, lower.tail = FALSE), + cauchit = pcauchy(x, log.p = TRUE, lower.tail = FALSE), + cloglog = -exp(x), + probit_approx = pnorm(x, log.p = TRUE, lower.tail = FALSE), + softit = log1m_inv_softit(x), + stop2("Link '", link, "' is not supported.") ) } @@ -83,9 +115,9 @@ } # get correlation names as combinations of variable names -# @param names the variable names +# @param names the variable names # @param type character string to be put in front of the returned strings -# @param brackets should the correlation names contain brackets +# @param brackets should the correlation names contain brackets # or underscores as seperators? # @param sep character string to separate names; only used if !brackets # @return a vector of character strings @@ -126,7 +158,7 @@ size <- ncol(sd) out <- array(diag(1, size), dim = c(size, size, ndraws)) out <- aperm(out, perm = c(3, 1, 2)) - for (i in seq_len(size)) { + for (i in seq_len(size)) { out[, i, i] <- sd[, i]^2 } if (length(cor)) { @@ -134,7 +166,7 @@ stopifnot(nrow(sd) == nrow(cor)) stopifnot(min(cor) >= -1, max(cor) <= 1) stopifnot(ncol(cor) == size * (size - 1) / 2) - k <- 0 + k <- 0 for (i in seq_len(size)[-1]) { for (j in seq_len(i - 1)) { k = k + 1 @@ -156,7 +188,7 @@ cor <- as.matrix(cor) size <- -1 / 2 + sqrt(1 / 4 + 2 * ncol(cor)) + 1 ndraws <- nrow(cor) - } + } size <- as_one_numeric(size) ndraws <- as_one_numeric(ndraws) stopifnot(is_wholenumber(size) && size > 0) @@ -164,7 +196,7 @@ out <- array(diag(1, size), dim = c(size, size, ndraws)) out <- aperm(out, perm = c(3, 1, 2)) if (length(cor)) { - k <- 0 + k <- 0 for (i in seq_len(size)[-1]) { for (j in seq_len(i - 1)) { k = k + 1 @@ -181,7 +213,7 @@ # @param latent compute covariance matrix for latent residuals? get_cov_matrix_ac <- function(prep, obs = NULL, latent = FALSE) { if (is.null(obs)) { - obs <- seq_len(prep$nobs) + obs <- seq_len(prep$nobs) } nobs <- length(obs) ndraws <- prep$ndraws @@ -246,11 +278,11 @@ for (i in seq_len(nobs)) { pow_ar[[i + 1]] <- ar^i out[, i, i] <- fac - for (j in seq_len(i - 1)) { + for (j in seq_len(i - 1)) { out[, i, j] <- fac * pow_ar[[i - j + 1]] out[, j, i] <- out[, i, j] - } - } + } + } out } @@ -261,7 +293,7 @@ get_cor_matrix_ma1 <- function(ma, nobs) { out <- array(0, dim = c(NROW(ma), nobs, nobs)) gamma0 <- 1 + ma^2 - for (i in seq_len(nobs)) { + for (i in seq_len(nobs)) { out[, i, i] <- gamma0 if (i > 1) { out[, i, i - 1] <- ma @@ -269,8 +301,8 @@ if (i < nobs) { out[, i, i + 1] <- ma } - } - out + } + out } # compute ARMA1 correlation matrices @@ -287,12 +319,12 @@ for (i in seq_len(nobs)) { out[, i, i] <- fac * gamma0 gamma[[i]] <- gamma[[1]] * ar^(i - 1) - for (j in seq_len(i - 1)) { + for (j in seq_len(i - 1)) { out[, i, j] <- fac * gamma[[i - j]] out[, j, i] <- out[, i, j] - } - } - out + } + } + out } # compute compound symmetry correlation matrices @@ -303,11 +335,11 @@ out <- array(0, dim = c(NROW(cosy), nobs, nobs)) for (i in seq_len(nobs)) { out[, i, i] <- 1 - for (j in seq_len(i - 1)) { + for (j in seq_len(i - 1)) { out[, i, j] <- cosy out[, j, i] <- out[, i, j] - } - } + } + } out } @@ -333,32 +365,32 @@ } #' Draws of a Distributional Parameter -#' -#' Get draws of a distributional parameter from a \code{brmsprep} or +#' +#' Get draws of a distributional parameter from a \code{brmsprep} or #' \code{mvbrmsprep} object. This function is primarily useful when developing -#' custom families or packages depending on \pkg{brms}. +#' custom families or packages depending on \pkg{brms}. #' This function lets callers easily handle both the case when the #' distributional parameter is predicted directly, via a (non-)linear #' predictor or fixed to a constant. See the vignette #' \code{vignette("brms_customfamilies")} for an example use case. -#' +#' #' @param prep A 'brmsprep' or 'mvbrmsprep' object created by #' \code{\link[brms:prepare_predictions.brmsfit]{prepare_predictions}}. #' @param dpar Name of the distributional parameter. #' @param i The observation numbers for which predictions shall be extracted. #' If \code{NULL} (the default), all observation will be extracted. #' Ignored if \code{dpar} is not predicted. -#' @param ilink Should the inverse link function be applied? +#' @param inv_link Should the inverse link function be applied? #' If \code{NULL} (the default), the value is chosen internally. -#' In particular, \code{ilink} is \code{TRUE} by default for custom +#' In particular, \code{inv_link} is \code{TRUE} by default for custom #' families. -#' @return +#' @return #' If the parameter is predicted and \code{i} is \code{NULL} or #' \code{length(i) > 1}, an \code{S x N} matrix. If the parameter it not #' predicted or \code{length(i) == 1}, a vector of length \code{S}. Here #' \code{S} is the number of draws and \code{N} is the number of #' observations or length of \code{i} if specified. -#' +#' #' @examples #' \dontrun{ #' posterior_predict_my_dist <- function(i, prep, ...) { @@ -366,10 +398,10 @@ #' mypar <- brms::get_dpar(prep, "mypar", i = i) #' my_rng(mu, mypar) #' } -#' } -#' +#' } +#' #' @export -get_dpar <- function(prep, dpar, i = NULL, ilink = NULL) { +get_dpar <- function(prep, dpar, i = NULL, inv_link = NULL) { stopifnot(is.brmsprep(prep) || is.mvbrmsprep(prep)) dpar <- as_one_character(dpar) x <- prep$dpars[[dpar]] @@ -377,13 +409,13 @@ if (is.list(x)) { # compute draws of a predicted parameter out <- predictor(x, i = i, fprep = prep) - if (is.null(ilink)) { - ilink <- apply_dpar_ilink(dpar, family = prep$family) + if (is.null(inv_link)) { + inv_link <- apply_dpar_inv_link(dpar, family = prep$family) } else { - ilink <- as_one_logical(ilink) + inv_link <- as_one_logical(inv_link) } - if (ilink) { - out <- ilink(out, x$family$link) + if (inv_link) { + out <- inv_link(out, x$family$link) } if (length(i) == 1L) { out <- slice_col(out, 1) @@ -449,62 +481,92 @@ # get posterior draws of multivariate mean vectors # only used in multivariate models with 'rescor' +# and in univariate models with multiple 'mu' pars such as logistic_normal get_Mu <- function(prep, i = NULL) { - stopifnot(is.mvbrmsprep(prep)) - Mu <- prep$mvpars$Mu - if (is.null(Mu)) { - Mu <- lapply(prep$resps, get_dpar, "mu", i = i) - if (length(i) == 1L) { - Mu <- do_call(cbind, Mu) - } else { - # keep correct dimension even if data has only 1 row - Mu <- lapply(Mu, as.matrix) - Mu <- abind::abind(Mu, along = 3) - } + is_mv <- is.mvbrmsprep(prep) + if (is_mv) { + Mu <- prep$mvpars$Mu } else { + stopifnot(is.brmsprep(prep)) + Mu <- prep$dpars$Mu + } + if (!is.null(Mu)) { stopifnot(!is.null(i)) Mu <- slice_col(Mu, i) + return(Mu) + } + if (is_mv) { + Mu <- lapply(prep$resps, get_dpar, "mu", i = i) + } else { + mu_dpars <- str_subset(names(prep$dpars), "^mu") + Mu <- lapply(mu_dpars, get_dpar, prep = prep, i = i) + } + if (length(i) == 1L) { + Mu <- do_call(cbind, Mu) + } else { + # keep correct dimension even if data has only 1 row + Mu <- lapply(Mu, as.matrix) + Mu <- abind::abind(Mu, along = 3) } Mu } # get posterior draws of residual covariance matrices # only used in multivariate models with 'rescor' -get_Sigma <- function(prep, i = NULL) { - stopifnot(is.mvbrmsprep(prep)) - Sigma <- prep$mvpars$Sigma - if (is.null(Sigma)) { - stopifnot(!is.null(prep$mvpars$rescor)) +# and in univariate models with multiple 'mu' pars such as logistic_normal +get_Sigma <- function(prep, i = NULL, cor_name = NULL) { + is_mv <- is.mvbrmsprep(prep) + if (is_mv) { + cor_name <- "rescor" + Sigma <- prep$mvpars$Sigma + } else { + stopifnot(is.brmsprep(prep)) + cor_name <- as_one_character(cor_name) + Sigma <- prep$dpars$Sigma + } + if (!is.null(Sigma)) { + # already computed before + stopifnot(!is.null(i)) + ldim <- length(dim(Sigma)) + stopifnot(ldim %in% 3:4) + if (ldim == 4L) { + Sigma <- slice_col(Sigma, i) + } + return(Sigma) + } + if (is_mv) { + cors <- prep$mvpars[[cor_name]] sigma <- named_list(names(prep$resps)) for (j in seq_along(sigma)) { sigma[[j]] <- get_dpar(prep$resps[[j]], "sigma", i = i) sigma[[j]] <- add_sigma_se(sigma[[j]], prep$resps[[j]], i = i) } - is_matrix <- ulapply(sigma, is.matrix) - if (!any(is_matrix)) { - # happens if length(i) == 1 or if no sigma was predicted - sigma <- do_call(cbind, sigma) - Sigma <- get_cov_matrix(sigma, prep$mvpars$rescor) - } else { - for (j in seq_along(sigma)) { - # bring all sigmas to the same dimension - if (!is_matrix[j]) { - sigma[[j]] <- array(sigma[[j]], dim = dim_mu(prep)) - } - } - nsigma <- length(sigma) - sigma <- abind(sigma, along = 3) - Sigma <- array(dim = c(dim_mu(prep), nsigma, nsigma)) - for (n in seq_len(ncol(Sigma))) { - Sigma[, n, , ] <- get_cov_matrix(sigma[, n, ], prep$mvpars$rescor) - } + } else { + cors <- prep$dpars[[cor_name]] + sigma_names <- str_subset(names(prep$dpars), "^sigma") + sigma <- named_list(sigma_names) + for (j in seq_along(sigma)) { + sigma[[j]] <- get_dpar(prep, sigma_names[j], i = i) + sigma[[j]] <- add_sigma_se(sigma[[j]], prep, i = i) } + } + is_matrix <- ulapply(sigma, is.matrix) + if (!any(is_matrix)) { + # happens if length(i) == 1 or if no sigma was predicted + sigma <- do_call(cbind, sigma) + Sigma <- get_cov_matrix(sigma, cors) } else { - stopifnot(!is.null(i)) - ldim <- length(dim(Sigma)) - stopifnot(ldim %in% 3:4) - if (ldim == 4L) { - Sigma <- slice_col(Sigma, i) + for (j in seq_along(sigma)) { + # bring all sigmas to the same dimension + if (!is_matrix[j]) { + sigma[[j]] <- array(sigma[[j]], dim = dim_mu(prep)) + } + } + nsigma <- length(sigma) + sigma <- abind(sigma, along = 3) + Sigma <- array(dim = c(dim_mu(prep), nsigma, nsigma)) + for (n in seq_len(ncol(Sigma))) { + Sigma[, n, , ] <- get_cov_matrix(sigma[, n, ], cors) } } Sigma @@ -534,7 +596,7 @@ if ("se" %in% names(prep$data)) { se <- get_se(prep, i = i) sigma <- sqrt(se^2 + sigma^2) - } + } sigma } @@ -579,35 +641,21 @@ } # helper function of 'get_dpar' to decide if -# the link function should be applied direclty -apply_dpar_ilink <- function(dpar, family) { +# the link function should be applied directly +apply_dpar_inv_link <- function(dpar, family) { !(has_joint_link(family) && dpar_class(dpar, family) == "mu") } # insert zeros for the predictor term of the reference category # in categorical-like models using the softmax response function -insert_refcat <- function(eta, family) { - stopifnot(is.array(eta), is.brmsfamily(family)) - if (!conv_cats_dpars(family) || isNA(family$refcat)) { - return(eta) - } +insert_refcat <- function(eta, refcat = 1) { + stopifnot(is.array(eta)) + refcat <- as_one_integer(refcat) # need to add zeros for the reference category ndim <- length(dim(eta)) dim_noncat <- dim(eta)[-ndim] zeros_arr <- array(0, dim = c(dim_noncat, 1)) - if (is.null(family$refcat) || is.null(family$cats)) { - # no information on the categories provided: - # use the first category as the reference - return(abind::abind(zeros_arr, eta)) - } - ncat <- length(family$cats) - stopifnot(identical(dim(eta)[ndim], ncat - 1L)) - if (is.null(dimnames(eta)[[ndim]])) { - dimnames(eta)[[ndim]] <- paste0("mu", setdiff(family$cats, family$refcat)) - } - dimnames(zeros_arr)[[ndim]] <- paste0("mu", family$refcat) - iref <- match(family$refcat, family$cats) - before <- seq_len(iref - 1) + before <- seq_len(refcat - 1) after <- setdiff(seq_dim(eta, ndim), before) abind::abind( slice(eta, ndim, before, drop = FALSE), @@ -646,15 +694,15 @@ } # split '...' into a list of model objects and other arguments -# takes its argument names from parent.frame() +# takes its argument names from parent.frame() # @param .... objects to split into model and non-model objects # @param x object treated in the same way as '...'. Adding it is -# necessary for substitute() to catch the name of the first +# necessary for substitute() to catch the name of the first # argument passed to S3 methods. -# @param model_names optional names of the model objects +# @param model_names optional names of the model objects # @param other: allow non-model arguments in '...'? # @return -# A list of arguments. All brmsfit objects are stored +# A list of arguments. All brmsfit objects are stored # as a list in element 'models' unless 'other' is FALSE. # In the latter case just returns a list of models split_dots <- function(x, ..., model_names = NULL, other = TRUE) { @@ -686,7 +734,7 @@ } # reorder observations to be in the initial user-defined order -# currently only relevant for autocorrelation models +# currently only relevant for autocorrelation models # @param eta 'ndraws' x 'nobs' matrix or array # @param old_order optional vector to retrieve the initial data order # @param sort keep the new order as defined by the time-series? @@ -714,25 +762,25 @@ # TODO: find a more efficient way to update .MISC old_backend <- x$backend x$backend <- "rstan" - x$fit@.MISC <- suppressMessages(brm(fit = x, chains = 0))$fit@.MISC + x$fit@.MISC <- suppressMessages(brm(fit = x, chains = 0))$fit@.MISC x$backend <- old_backend } x } #' Add compiled \pkg{rstan} models to \code{brmsfit} objects -#' +#' #' Compile a \code{\link[rstan:stanmodel-class]{stanmodel}} and add #' it to a \code{brmsfit} object. This enables some advanced functionality #' of \pkg{rstan}, most notably \code{\link[rstan:log_prob]{log_prob}} #' and friends, to be used with brms models fitted with other Stan backends. -#' +#' #' @param x A \code{brmsfit} object to be updated. -#' @param overwrite Logical. If \code{TRUE}, overwrite any existing +#' @param overwrite Logical. If \code{TRUE}, overwrite any existing #' \code{\link[rstan:stanmodel-class]{stanmodel}}. Defaults to \code{FALSE}. -#' +#' #' @return A (possibly updated) \code{brmsfit} object. -#' +#' #' @export add_rstan_model <- function(x, overwrite = FALSE) { stopifnot(is.brmsfit(x)) @@ -741,7 +789,7 @@ message("Recompiling the model with 'rstan'") # threading is not yet supported by rstan and needs to be deactivated stanfit <- suppressMessages(rstan::stan( - model_code = stancode(x, threads = threading()), + model_code = stancode(x, threads = threading(), backend = "rstan"), data = standata(x), chains = 0 )) x$fit@stanmodel <- stanfit@stanmodel @@ -751,7 +799,7 @@ x } -# does the model have a non-empty rstan 'stanmodel' +# does the model have a non-empty rstan 'stanmodel' # that can be used for 'log_prob' and friends? has_rstan_model <- function(x) { stopifnot(is.brmsfit(x)) @@ -779,7 +827,7 @@ # in post-processing functions as discussed in #1129 cores <- 1L } else { - cores <- getOption("mc.cores", 1L) + cores <- getOption("mc.cores", 1L) } } cores <- as_one_integer(cores) @@ -790,13 +838,13 @@ } #' Check if cached fit can be used. -#' -#' Checks whether a given cached fit can be used without refitting when +#' +#' Checks whether a given cached fit can be used without refitting when #' \code{file_refit = "on_change"} is used. -#' This function is internal and exposed only to facilitate debugging problems +#' This function is internal and exposed only to facilitate debugging problems #' with cached fits. The function may change or be removed in future versions #' and scripts should not use it. -#' +#' #' @param fit Old \code{brmsfit} object (e.g., loaded from file). #' @param sdata New Stan data (result of a call to \code{\link{make_standata}}). #' Pass \code{NULL} to avoid this data check. @@ -806,18 +854,18 @@ #' Pass \code{NULL} to avoid this data check. #' @param algorithm New algorithm. Pass \code{NULL} to avoid algorithm check. #' @param silent Logical. If \code{TRUE}, no messages will be given. -#' @param verbose Logical. If \code{TRUE} detailed report of the differences +#' @param verbose Logical. If \code{TRUE} detailed report of the differences #' is printed to the console. #' @return A boolean indicating whether a refit is needed. -#' -#' @details +#' +#' @details #' Use with \code{verbose = TRUE} to get additional info on how the stored #' fit differs from the given data and code. -#' +#' #' @export #' @keywords internal brmsfit_needs_refit <- function(fit, sdata = NULL, scode = NULL, data = NULL, - algorithm = NULL, silent = FALSE, + algorithm = NULL, silent = FALSE, verbose = FALSE) { stopifnot(is.brmsfit(fit)) silent <- as_one_logical(silent) @@ -838,7 +886,7 @@ algorithm <- as_one_character(algorithm) stopifnot(!is.null(fit$algorithm)) } - + refit <- FALSE if (!is.null(scode)) { if (normalize_stancode(scode) != normalize_stancode(cached_scode)) { @@ -865,7 +913,7 @@ } } if (!is.null(data)) { - # check consistency of factor names + # check consistency of factor names # as they are only stored as attributes in sdata (#1128) factor_level_message <- FALSE for (var in names(cached_data)) { @@ -878,7 +926,7 @@ if (verbose) { cat(paste0( "Names of factor levels have changed for variable '", var, "' ", - "with cached levels (", collapse_comma(cached_levels), ") ", + "with cached levels (", collapse_comma(cached_levels), ") ", "but new levels (", collapse_comma(new_levels), ").\n" )) } @@ -898,7 +946,7 @@ if (!is.null(algorithm)) { if (algorithm != fit$algorithm) { if (!silent) { - message("Algorithm has changed from '", fit$algorithm, + message("Algorithm has changed from '", fit$algorithm, "' to '", algorithm, "'.\n") } refit <- TRUE @@ -954,7 +1002,7 @@ } # check if a function requires an old default setting -# only used to ensure backwards compatibility +# only used to ensure backwards compatibility # @param version brms version in which the change to the default was made # @return TRUE or FALSE require_old_default <- function(version) { @@ -975,10 +1023,10 @@ stopifnot(identical(dim, numeric(0))) newpar <- as_one_character(newpar) for (i in seq_along(x$fit@sim$samples)) { - x$fit@sim$samples[[i]][[newpar]] <- + x$fit@sim$samples[[i]][[newpar]] <- do_call(paste0("r", dist), list(x$fit@sim$iter, ...)) } - x$fit@sim$fnames_oi <- c(x$fit@sim$fnames_oi, newpar) + x$fit@sim$fnames_oi <- c(x$fit@sim$fnames_oi, newpar) x$fit@sim$dims_oi[[newpar]] <- dim x$fit@sim$pars_oi <- names(x$fit@sim$dims_oi) x diff -Nru r-cran-brms-2.16.3/R/brmsfit-methods.R r-cran-brms-2.17.0/R/brmsfit-methods.R --- r-cran-brms-2.16.3/R/brmsfit-methods.R 2021-08-26 17:47:33.000000000 +0000 +++ r-cran-brms-2.17.0/R/brmsfit-methods.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,564 +1,564 @@ -# This file contains several extractor methods for brmsfit objects. -# A lot of other brmsfit methods have their own dedicated files. - -#' Extract Population-Level Estimates -#' -#' Extract the population-level ('fixed') effects -#' from a \code{brmsfit} object. -#' -#' @aliases fixef -#' -#' @inheritParams predict.brmsfit -#' @param pars Optional names of coefficients to extract. -#' By default, all coefficients are extracted. -#' @param ... Currently ignored. -#' -#' @return If \code{summary} is \code{TRUE}, a matrix returned -#' by \code{\link{posterior_summary}} for the population-level effects. -#' If \code{summary} is \code{FALSE}, a matrix with one row per -#' posterior draw and one column per population-level effect. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(time | cens(censored) ~ age + sex + disease, -#' data = kidney, family = "exponential") -#' fixef(fit) -#' # extract only some coefficients -#' fixef(fit, pars = c("age", "sex")) -#' } -#' -#' @method fixef brmsfit -#' @export -#' @export fixef -#' @importFrom nlme fixef -fixef.brmsfit <- function(object, summary = TRUE, robust = FALSE, - probs = c(0.025, 0.975), pars = NULL, ...) { - contains_draws(object) - all_pars <- variables(object) - fpars <- all_pars[grepl(fixef_pars(), all_pars)] - if (!is.null(pars)) { - pars <- as.character(pars) - fpars <- fpars[sub("^[^_]+_", "", fpars) %in% pars] - } - if (!length(fpars)) { - return(NULL) - } - out <- as.matrix(object, variable = fpars) - colnames(out) <- gsub(fixef_pars(), "", fpars) - if (summary) { - out <- posterior_summary(out, probs, robust) - } - out -} - -#' Covariance and Correlation Matrix of Population-Level Effects -#' -#' Get a point estimate of the covariance or -#' correlation matrix of population-level parameters -#' -#' @inheritParams fixef.brmsfit -#' @param correlation Logical; if \code{FALSE} (the default), compute -#' the covariance matrix, if \code{TRUE}, compute the correlation matrix. -#' -#' @return covariance or correlation matrix of population-level parameters -#' -#' @details Estimates are obtained by calculating the maximum likelihood -#' covariances (correlations) of the posterior draws. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), -#' data = epilepsy, family = gaussian(), chains = 2) -#' vcov(fit) -#' } -#' -#' @export -vcov.brmsfit <- function(object, correlation = FALSE, pars = NULL, ...) { - contains_draws(object) - all_pars <- variables(object) - fpars <- all_pars[grepl(fixef_pars(), all_pars)] - if (!is.null(pars)) { - pars <- as.character(pars) - fpars <- intersect(fpars, paste0("b_", pars)) - } - if (!length(fpars)) { - return(NULL) - } - draws <- as.data.frame(object, variable = fpars) - names(draws) <- sub(fixef_pars(), "", names(draws)) - if (correlation) { - out <- cor(draws) - } else { - out <- cov(draws) - } - out -} - -#' Extract Group-Level Estimates -#' -#' Extract the group-level ('random') effects of each level -#' from a \code{brmsfit} object. -#' -#' @aliases ranef -#' -#' @inheritParams fixef.brmsfit -#' @param groups Optional names of grouping variables -#' for which to extract effects. -#' @param ... Currently ignored. -#' -#' @return A list of 3D arrays (one per grouping factor). -#' If \code{summary} is \code{TRUE}, -#' the 1st dimension contains the factor levels, -#' the 2nd dimension contains the summary statistics -#' (see \code{\link{posterior_summary}}), and -#' the 3rd dimension contains the group-level effects. -#' If \code{summary} is \code{FALSE}, the 1st dimension contains -#' the posterior draws, the 2nd dimension contains the factor levels, -#' and the 3rd dimension contains the group-level effects. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), -#' data = epilepsy, family = gaussian(), chains = 2) -#' ranef(fit) -#' } -#' -#' @method ranef brmsfit -#' @export -#' @export ranef -#' @importFrom nlme ranef -ranef.brmsfit <- function(object, summary = TRUE, robust = FALSE, - probs = c(0.025, 0.975), pars = NULL, - groups = NULL, ...) { - contains_draws(object) - object <- restructure(object) - if (!nrow(object$ranef)) { - stop2("The model does not contain group-level effects.") - } - all_pars <- variables(object) - if (!is.null(pars)) { - pars <- as.character(pars) - } - ranef <- object$ranef - all_groups <- unique(ranef$group) - if (!is.null(groups)) { - groups <- as.character(groups) - all_groups <- intersect(all_groups, groups) - } - out <- named_list(all_groups) - for (g in all_groups) { - r <- subset2(ranef, group = g) - coefs <- paste0(usc(combine_prefix(r), "suffix"), r$coef) - rpars <- all_pars[grepl(paste0("^r_", g, "(__.+\\[|\\[)"), all_pars)] - if (!is.null(pars)) { - coefs <- coefs[r$coef %in% pars] - if (!length(coefs)) { - next - } - regex <- paste0("(", escape_all(coefs), ")", collapse = "|") - regex <- paste0(",", regex, "\\]$") - rpars <- rpars[grepl(regex, rpars)] - } - out[[g]] <- as.matrix(object, variable = rpars) - levels <- attr(ranef, "levels")[[g]] - dim(out[[g]]) <- c(nrow(out[[g]]), length(levels), length(coefs)) - dimnames(out[[g]])[2:3] <- list(levels, coefs) - if (summary) { - out[[g]] <- posterior_summary(out[[g]], probs, robust) - } - } - rmNULL(out, recursive = FALSE) -} - -#' Extract Model Coefficients -#' -#' Extract model coefficients, which are the sum of population-level -#' effects and corresponding group-level effects -#' -#' @inheritParams ranef.brmsfit -#' @param ... Further arguments passed to \code{\link{fixef.brmsfit}} -#' and \code{\link{ranef.brmsfit}}. -#' -#' @return A list of 3D arrays (one per grouping factor). -#' If \code{summary} is \code{TRUE}, -#' the 1st dimension contains the factor levels, -#' the 2nd dimension contains the summary statistics -#' (see \code{\link{posterior_summary}}), and -#' the 3rd dimension contains the group-level effects. -#' If \code{summary} is \code{FALSE}, the 1st dimension contains -#' the posterior draws, the 2nd dimension contains the factor levels, -#' and the 3rd dimension contains the group-level effects. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), -#' data = epilepsy, family = gaussian(), chains = 2) -#' ## extract population and group-level coefficients separately -#' fixef(fit) -#' ranef(fit) -#' ## extract combined coefficients -#' coef(fit) -#' } -#' -#' @export -coef.brmsfit <- function(object, summary = TRUE, robust = FALSE, - probs = c(0.025, 0.975), ...) { - contains_draws(object) - object <- restructure(object) - if (!nrow(object$ranef)) { - stop2("No group-level effects detected. Call method ", - "'fixef' to access population-level effects.") - } - fixef <- fixef(object, summary = FALSE, ...) - coef <- ranef(object, summary = FALSE, ...) - # add missing coefficients to fixef - all_ranef_names <- unique(ulapply(coef, function(x) dimnames(x)[[3]])) - fixef_names <- colnames(fixef) - fixef_no_digits <- get_matches("^[^\\[]+", fixef_names) - miss_fixef <- setdiff(all_ranef_names, fixef_names) - miss_fixef_no_digits <- get_matches("^[^\\[]+", miss_fixef) - new_fixef <- named_list(miss_fixef) - for (k in seq_along(miss_fixef)) { - # digits occur in ordinal models with category specific effects - match_fixef <- match(miss_fixef_no_digits[k], fixef_names) - if (!is.na(match_fixef)) { - new_fixef[[k]] <- fixef[, match_fixef] - } else if (!miss_fixef[k] %in% fixef_no_digits) { - new_fixef[[k]] <- 0 - } - } - rm_fixef <- fixef_names %in% miss_fixef_no_digits - fixef <- fixef[, !rm_fixef, drop = FALSE] - fixef <- do_call(cbind, c(list(fixef), rmNULL(new_fixef))) - - for (g in names(coef)) { - # add missing coefficients to ranef - ranef_names <- dimnames(coef[[g]])[[3]] - ranef_no_digits <- get_matches("^[^\\[]+", ranef_names) - miss_ranef <- setdiff(fixef_names, ranef_names) - miss_ranef_no_digits <- get_matches("^[^\\[]+", miss_ranef) - new_ranef <- named_list(miss_ranef) - for (k in seq_along(miss_ranef)) { - # digits occur in ordinal models with category specific effects - match_ranef <- match(miss_ranef_no_digits[k], ranef_names) - if (!is.na(match_ranef)) { - new_ranef[[k]] <- coef[[g]][, , match_ranef] - } else if (!miss_ranef[k] %in% ranef_no_digits) { - new_ranef[[k]] <- array(0, dim = dim(coef[[g]])[1:2]) - } - } - rm_ranef <- ranef_names %in% miss_ranef_no_digits - coef[[g]] <- coef[[g]][, , !rm_ranef, drop = FALSE] - coef[[g]] <- abind(c(list(coef[[g]]), rmNULL(new_ranef))) - for (nm in dimnames(coef[[g]])[[3]]) { - is_ord_intercept <- grepl("(^|_)Intercept\\[[[:digit:]]+\\]$", nm) - if (is_ord_intercept) { - # correct the sign of thresholds in ordinal models - resp <- if (is_mv(object)) get_matches("^[^_]+", nm) - family <- family(object, resp = resp)$family - if (has_thres_minus_eta(family)) { - coef[[g]][, , nm] <- fixef[, nm] - coef[[g]][, , nm] - } else if (has_eta_minus_thres(family)) { - coef[[g]][, , nm] <- coef[[g]][, , nm] - fixef[, nm] - } else { - coef[[g]][, , nm] <- fixef[, nm] + coef[[g]][, , nm] - } - } else { - coef[[g]][, , nm] <- fixef[, nm] + coef[[g]][, , nm] - } - } - if (summary) { - coef[[g]] <- posterior_summary(coef[[g]], probs, robust) - } - } - coef -} - -#' Extract Variance and Correlation Components -#' -#' This function calculates the estimated standard deviations, -#' correlations and covariances of the group-level terms -#' in a multilevel model of class \code{brmsfit}. -#' For linear models, the residual standard deviations, -#' correlations and covariances are also returned. -#' -#' @aliases VarCorr -#' -#' @param x An object of class \code{brmsfit}. -#' @inheritParams fixef.brmsfit -#' @param sigma Ignored (included for compatibility with -#' \code{\link[nlme:VarCorr]{VarCorr}}). -#' @param ... Currently ignored. -#' -#' @return A list of lists (one per grouping factor), each with -#' three elements: a matrix containing the standard deviations, -#' an array containing the correlation matrix, and an array -#' containing the covariance matrix with variances on the diagonal. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), -#' data = epilepsy, family = gaussian(), chains = 2) -#' VarCorr(fit) -#' } -#' -#' @method VarCorr brmsfit -#' @import abind abind -#' @importFrom nlme VarCorr -#' @export VarCorr -#' @export -VarCorr.brmsfit <- function(x, sigma = 1, summary = TRUE, robust = FALSE, - probs = c(0.025, 0.975), ...) { - contains_draws(x) - x <- restructure(x) - if (!(nrow(x$ranef) || any(grepl("^sigma($|_)", variables(x))))) { - stop2("The model does not contain covariance matrices.") - } - .VarCorr <- function(y) { - # extract draws for sd, cor and cov - out <- list(sd = as.matrix(x, variable = y$sd_pars)) - colnames(out$sd) <- y$rnames - # compute correlation and covariance matrices - found_cor_pars <- intersect(y$cor_pars, variables(x)) - if (length(found_cor_pars)) { - cor <- as.matrix(x, variable = found_cor_pars) - if (length(found_cor_pars) < length(y$cor_pars)) { - # some correlations are missing and will be replaced by 0 - cor_all <- matrix(0, nrow = nrow(cor), ncol = length(y$cor_pars)) - names(cor_all) <- y$cor_pars - for (i in seq_len(ncol(cor_all))) { - found <- match(names(cor_all)[i], colnames(cor)) - if (!is.na(found)) { - cor_all[, i] <- cor[, found] - } - } - cor <- cor_all - } - out$cor <- get_cor_matrix(cor = cor) - out$cov <- get_cov_matrix(sd = out$sd, cor = cor) - dimnames(out$cor)[2:3] <- list(y$rnames, y$rnames) - dimnames(out$cov)[2:3] <- list(y$rnames, y$rnames) - if (summary) { - out$cor <- posterior_summary(out$cor, probs, robust) - out$cov <- posterior_summary(out$cov, probs, robust) - } - } - if (summary) { - out$sd <- posterior_summary(out$sd, probs, robust) - } - return(out) - } - - if (nrow(x$ranef)) { - get_names <- function(group) { - # get names of group-level parameters - r <- subset2(x$ranef, group = group) - rnames <- as.vector(get_rnames(r)) - cor_type <- paste0("cor_", group) - sd_pars <- paste0("sd_", group, "__", rnames) - cor_pars <- get_cornames(rnames, cor_type, brackets = FALSE) - nlist(rnames, sd_pars, cor_pars) - } - group <- unique(x$ranef$group) - tmp <- lapply(group, get_names) - names(tmp) <- group - } else { - tmp <- list() - } - # include residual variances in the output as well - bterms <- brmsterms(x$formula) - if (is.brmsterms(bterms)) { - if (simple_sigma(bterms) && !is.mixfamily(x$family)) { - tmp_resid <- list(rnames = bterms$resp, sd_pars = "sigma") - tmp <- c(tmp, residual__ = list(tmp_resid)) - } - } else if (is.mvbrmsterms(bterms)) { - simple_sigma <- ulapply(bterms$terms, simple_sigma) - pred_sigma <- ulapply(bterms$terms, pred_sigma) - is_mix <- ulapply(x$family, is.mixfamily) - if (any(simple_sigma) && !any(pred_sigma) && !any(is_mix)) { - resps <- bterms$responses[simple_sigma] - sd_pars <- paste0("sigma_", resps) - if (bterms$rescor) { - cor_pars <- get_cornames(resps, type = "rescor", brackets = FALSE) - } else { - cor_pars <- character(0) - } - tmp_resid <- nlist(rnames = resps, sd_pars, cor_pars) - tmp <- c(tmp, residual__ = list(tmp_resid)) - } - } - lapply(tmp, .VarCorr) -} - -#' @export -model.frame.brmsfit <- function(formula, ...) { - formula$data -} - -#' (Deprecated) Number of Posterior Samples -#' -#' Extract the number of posterior samples (draws) stored in a fitted Bayesian -#' model. Method \code{nsamples} is deprecated. Please use \code{ndraws} -#' instead. -#' -#' @aliases nsamples -#' -#' @param object An object of class \code{brmsfit}. -#' @param subset An optional integer vector defining a subset of samples -#' to be considered. -#' @param incl_warmup A flag indicating whether to also count warmup / burn-in -#' samples. -#' @param ... Currently ignored. -#' -#' @method nsamples brmsfit -#' @export -#' @export nsamples -#' @importFrom rstantools nsamples -nsamples.brmsfit <- function(object, subset = NULL, - incl_warmup = FALSE, ...) { - warning2("'nsamples.brmsfit' is deprecated. Please use 'ndraws' instead.") - if (!is(object$fit, "stanfit") || !length(object$fit@sim)) { - out <- 0 - } else { - ntsamples <- object$fit@sim$n_save[1] - if (!incl_warmup) { - ntsamples <- ntsamples - object$fit@sim$warmup2[1] - } - ntsamples <- ntsamples * object$fit@sim$chains - if (length(subset)) { - out <- length(subset) - if (out > ntsamples || max(subset) > ntsamples) { - stop2("Argument 'subset' is invalid.") - } - } else { - out <- ntsamples - } - } - out -} - -#' @export -nobs.brmsfit <- function(object, resp = NULL, ...) { - if (is_mv(object) && length(resp)) { - resp <- validate_resp(resp, object, multiple = FALSE) - bterms <- brmsterms(object$formula$forms[[resp]]) - out <- nrow(subset_data(model.frame(object), bterms)) - } else { - out <- nrow(model.frame(object)) - } - out -} - -#' Number of Grouping Factor Levels -#' -#' Extract the number of levels of one or more grouping factors. -#' -#' @aliases ngrps.brmsfit -#' -#' @param object An \R object. -#' @param ... Currently ignored. -#' -#' @return A named list containing the number of levels per -#' grouping factor. -#' -#' @export -ngrps.brmsfit <- function(object, ...) { - object <- restructure(object) - if (nrow(object$ranef)) { - out <- lapply(attr(object$ranef, "levels"), length) - } else { - out <- NULL - } - out -} - -#' @rdname ngrps.brmsfit -#' @export -ngrps <- function(object, ...) { - UseMethod("ngrps") -} - -#' @export -formula.brmsfit <- function(x, ...) { - x$formula -} - -#' @export -getCall.brmsfit <- function(x, ...) { - x$formula -} - -#' Extract Model Family Objects -#' -#' @inheritParams posterior_predict.brmsfit -#' @param ... Currently unused. -#' -#' @return A \code{brmsfamily} object -#' or a list of such objects for multivariate models. -#' -#' @export -family.brmsfit <- function(object, resp = NULL, ...) { - resp <- validate_resp(resp, object) - if (!is.null(resp)) { - # multivariate model - family <- lapply(object$formula$forms[resp], "[[", "family") - if (length(resp) == 1L) { - family <- family[[1]] - } - } else { - # univariate model - family <- object$formula$family - if (is.null(family)) { - family <- object$family - } - } - family -} - -#' Expose user-defined \pkg{Stan} functions -#' -#' Export user-defined \pkg{Stan} function and -#' optionally vectorize them. For more details see -#' \code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. -#' -#' @param x An object of class \code{brmsfit}. -#' @param vectorize Logical; Indicates if the exposed functions -#' should be vectorized via \code{\link{Vectorize}}. -#' Defaults to \code{FALSE}. -#' @param env Environment where the functions should be made -#' available. Defaults to the global environment. -#' @param ... Further arguments passed to -#' \code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. -#' -#' @export -expose_functions.brmsfit <- function(x, vectorize = FALSE, - env = globalenv(), ...) { - vectorize <- as_one_logical(vectorize) - if (x$backend == "cmdstanr") { - # cmdstanr does not yet support 'expose_stan_functions' itself (#1176) - scode <- strsplit(stancode(x), "\n")[[1]] - data_line <- grep("^data[ ]+\\{$", scode) - scode <- paste0(c(scode[seq_len(data_line - 1)], "\n"), collapse = "\n") - stanmodel <- tempfile(fileext = ".stan") - cat(scode, file = stanmodel) - } else { - stanmodel <- x$fit - } - if (vectorize) { - funs <- rstan::expose_stan_functions(stanmodel, env = environment(), ...) - for (i in seq_along(funs)) { - FUN <- Vectorize(get(funs[i], mode = "function")) - assign(funs[i], FUN, pos = env) - } - } else { - funs <- rstan::expose_stan_functions(stanmodel, env = env, ...) - } - invisible(funs) -} - -#' @rdname expose_functions.brmsfit -#' @export -expose_functions <- function(x, ...) { - UseMethod("expose_functions") -} +# This file contains several extractor methods for brmsfit objects. +# A lot of other brmsfit methods have their own dedicated files. + +#' Extract Population-Level Estimates +#' +#' Extract the population-level ('fixed') effects +#' from a \code{brmsfit} object. +#' +#' @aliases fixef +#' +#' @inheritParams predict.brmsfit +#' @param pars Optional names of coefficients to extract. +#' By default, all coefficients are extracted. +#' @param ... Currently ignored. +#' +#' @return If \code{summary} is \code{TRUE}, a matrix returned +#' by \code{\link{posterior_summary}} for the population-level effects. +#' If \code{summary} is \code{FALSE}, a matrix with one row per +#' posterior draw and one column per population-level effect. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(time | cens(censored) ~ age + sex + disease, +#' data = kidney, family = "exponential") +#' fixef(fit) +#' # extract only some coefficients +#' fixef(fit, pars = c("age", "sex")) +#' } +#' +#' @method fixef brmsfit +#' @export +#' @export fixef +#' @importFrom nlme fixef +fixef.brmsfit <- function(object, summary = TRUE, robust = FALSE, + probs = c(0.025, 0.975), pars = NULL, ...) { + contains_draws(object) + all_pars <- variables(object) + fpars <- all_pars[grepl(fixef_pars(), all_pars)] + if (!is.null(pars)) { + pars <- as.character(pars) + fpars <- fpars[sub("^[^_]+_", "", fpars) %in% pars] + } + if (!length(fpars)) { + return(NULL) + } + out <- as.matrix(object, variable = fpars) + colnames(out) <- gsub(fixef_pars(), "", fpars) + if (summary) { + out <- posterior_summary(out, probs, robust) + } + out +} + +#' Covariance and Correlation Matrix of Population-Level Effects +#' +#' Get a point estimate of the covariance or +#' correlation matrix of population-level parameters +#' +#' @inheritParams fixef.brmsfit +#' @param correlation Logical; if \code{FALSE} (the default), compute +#' the covariance matrix, if \code{TRUE}, compute the correlation matrix. +#' +#' @return covariance or correlation matrix of population-level parameters +#' +#' @details Estimates are obtained by calculating the maximum likelihood +#' covariances (correlations) of the posterior draws. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), +#' data = epilepsy, family = gaussian(), chains = 2) +#' vcov(fit) +#' } +#' +#' @export +vcov.brmsfit <- function(object, correlation = FALSE, pars = NULL, ...) { + contains_draws(object) + all_pars <- variables(object) + fpars <- all_pars[grepl(fixef_pars(), all_pars)] + if (!is.null(pars)) { + pars <- as.character(pars) + fpars <- intersect(fpars, paste0("b_", pars)) + } + if (!length(fpars)) { + return(NULL) + } + draws <- as.data.frame(object, variable = fpars) + names(draws) <- sub(fixef_pars(), "", names(draws)) + if (correlation) { + out <- cor(draws) + } else { + out <- cov(draws) + } + out +} + +#' Extract Group-Level Estimates +#' +#' Extract the group-level ('random') effects of each level +#' from a \code{brmsfit} object. +#' +#' @aliases ranef +#' +#' @inheritParams fixef.brmsfit +#' @param groups Optional names of grouping variables +#' for which to extract effects. +#' @param ... Currently ignored. +#' +#' @return A list of 3D arrays (one per grouping factor). +#' If \code{summary} is \code{TRUE}, +#' the 1st dimension contains the factor levels, +#' the 2nd dimension contains the summary statistics +#' (see \code{\link{posterior_summary}}), and +#' the 3rd dimension contains the group-level effects. +#' If \code{summary} is \code{FALSE}, the 1st dimension contains +#' the posterior draws, the 2nd dimension contains the factor levels, +#' and the 3rd dimension contains the group-level effects. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), +#' data = epilepsy, family = gaussian(), chains = 2) +#' ranef(fit) +#' } +#' +#' @method ranef brmsfit +#' @export +#' @export ranef +#' @importFrom nlme ranef +ranef.brmsfit <- function(object, summary = TRUE, robust = FALSE, + probs = c(0.025, 0.975), pars = NULL, + groups = NULL, ...) { + contains_draws(object) + object <- restructure(object) + if (!nrow(object$ranef)) { + stop2("The model does not contain group-level effects.") + } + all_pars <- variables(object) + if (!is.null(pars)) { + pars <- as.character(pars) + } + ranef <- object$ranef + all_groups <- unique(ranef$group) + if (!is.null(groups)) { + groups <- as.character(groups) + all_groups <- intersect(all_groups, groups) + } + out <- named_list(all_groups) + for (g in all_groups) { + r <- subset2(ranef, group = g) + coefs <- paste0(usc(combine_prefix(r), "suffix"), r$coef) + rpars <- all_pars[grepl(paste0("^r_", g, "(__.+\\[|\\[)"), all_pars)] + if (!is.null(pars)) { + coefs <- coefs[r$coef %in% pars] + if (!length(coefs)) { + next + } + regex <- paste0("(", escape_all(coefs), ")", collapse = "|") + regex <- paste0(",", regex, "\\]$") + rpars <- rpars[grepl(regex, rpars)] + } + out[[g]] <- as.matrix(object, variable = rpars) + levels <- attr(ranef, "levels")[[g]] + dim(out[[g]]) <- c(nrow(out[[g]]), length(levels), length(coefs)) + dimnames(out[[g]])[2:3] <- list(levels, coefs) + if (summary) { + out[[g]] <- posterior_summary(out[[g]], probs, robust) + } + } + rmNULL(out, recursive = FALSE) +} + +#' Extract Model Coefficients +#' +#' Extract model coefficients, which are the sum of population-level +#' effects and corresponding group-level effects +#' +#' @inheritParams ranef.brmsfit +#' @param ... Further arguments passed to \code{\link{fixef.brmsfit}} +#' and \code{\link{ranef.brmsfit}}. +#' +#' @return A list of 3D arrays (one per grouping factor). +#' If \code{summary} is \code{TRUE}, +#' the 1st dimension contains the factor levels, +#' the 2nd dimension contains the summary statistics +#' (see \code{\link{posterior_summary}}), and +#' the 3rd dimension contains the group-level effects. +#' If \code{summary} is \code{FALSE}, the 1st dimension contains +#' the posterior draws, the 2nd dimension contains the factor levels, +#' and the 3rd dimension contains the group-level effects. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), +#' data = epilepsy, family = gaussian(), chains = 2) +#' ## extract population and group-level coefficients separately +#' fixef(fit) +#' ranef(fit) +#' ## extract combined coefficients +#' coef(fit) +#' } +#' +#' @export +coef.brmsfit <- function(object, summary = TRUE, robust = FALSE, + probs = c(0.025, 0.975), ...) { + contains_draws(object) + object <- restructure(object) + if (!nrow(object$ranef)) { + stop2("No group-level effects detected. Call method ", + "'fixef' to access population-level effects.") + } + fixef <- fixef(object, summary = FALSE, ...) + coef <- ranef(object, summary = FALSE, ...) + # add missing coefficients to fixef + all_ranef_names <- unique(ulapply(coef, function(x) dimnames(x)[[3]])) + fixef_names <- colnames(fixef) + fixef_no_digits <- get_matches("^[^\\[]+", fixef_names) + miss_fixef <- setdiff(all_ranef_names, fixef_names) + miss_fixef_no_digits <- get_matches("^[^\\[]+", miss_fixef) + new_fixef <- named_list(miss_fixef) + for (k in seq_along(miss_fixef)) { + # digits occur in ordinal models with category specific effects + match_fixef <- match(miss_fixef_no_digits[k], fixef_names) + if (!is.na(match_fixef)) { + new_fixef[[k]] <- fixef[, match_fixef] + } else if (!miss_fixef[k] %in% fixef_no_digits) { + new_fixef[[k]] <- 0 + } + } + rm_fixef <- fixef_names %in% miss_fixef_no_digits + fixef <- fixef[, !rm_fixef, drop = FALSE] + fixef <- do_call(cbind, c(list(fixef), rmNULL(new_fixef))) + + for (g in names(coef)) { + # add missing coefficients to ranef + ranef_names <- dimnames(coef[[g]])[[3]] + ranef_no_digits <- get_matches("^[^\\[]+", ranef_names) + miss_ranef <- setdiff(fixef_names, ranef_names) + miss_ranef_no_digits <- get_matches("^[^\\[]+", miss_ranef) + new_ranef <- named_list(miss_ranef) + for (k in seq_along(miss_ranef)) { + # digits occur in ordinal models with category specific effects + match_ranef <- match(miss_ranef_no_digits[k], ranef_names) + if (!is.na(match_ranef)) { + new_ranef[[k]] <- coef[[g]][, , match_ranef] + } else if (!miss_ranef[k] %in% ranef_no_digits) { + new_ranef[[k]] <- array(0, dim = dim(coef[[g]])[1:2]) + } + } + rm_ranef <- ranef_names %in% miss_ranef_no_digits + coef[[g]] <- coef[[g]][, , !rm_ranef, drop = FALSE] + coef[[g]] <- abind(c(list(coef[[g]]), rmNULL(new_ranef))) + for (nm in dimnames(coef[[g]])[[3]]) { + is_ord_intercept <- grepl("(^|_)Intercept\\[[[:digit:]]+\\]$", nm) + if (is_ord_intercept) { + # correct the sign of thresholds in ordinal models + resp <- if (is_mv(object)) get_matches("^[^_]+", nm) + family <- family(object, resp = resp)$family + if (has_thres_minus_eta(family)) { + coef[[g]][, , nm] <- fixef[, nm] - coef[[g]][, , nm] + } else if (has_eta_minus_thres(family)) { + coef[[g]][, , nm] <- coef[[g]][, , nm] - fixef[, nm] + } else { + coef[[g]][, , nm] <- fixef[, nm] + coef[[g]][, , nm] + } + } else { + coef[[g]][, , nm] <- fixef[, nm] + coef[[g]][, , nm] + } + } + if (summary) { + coef[[g]] <- posterior_summary(coef[[g]], probs, robust) + } + } + coef +} + +#' Extract Variance and Correlation Components +#' +#' This function calculates the estimated standard deviations, +#' correlations and covariances of the group-level terms +#' in a multilevel model of class \code{brmsfit}. +#' For linear models, the residual standard deviations, +#' correlations and covariances are also returned. +#' +#' @aliases VarCorr +#' +#' @param x An object of class \code{brmsfit}. +#' @inheritParams fixef.brmsfit +#' @param sigma Ignored (included for compatibility with +#' \code{\link[nlme:VarCorr]{VarCorr}}). +#' @param ... Currently ignored. +#' +#' @return A list of lists (one per grouping factor), each with +#' three elements: a matrix containing the standard deviations, +#' an array containing the correlation matrix, and an array +#' containing the covariance matrix with variances on the diagonal. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt + (1+Trt|visit), +#' data = epilepsy, family = gaussian(), chains = 2) +#' VarCorr(fit) +#' } +#' +#' @method VarCorr brmsfit +#' @import abind abind +#' @importFrom nlme VarCorr +#' @export VarCorr +#' @export +VarCorr.brmsfit <- function(x, sigma = 1, summary = TRUE, robust = FALSE, + probs = c(0.025, 0.975), ...) { + contains_draws(x) + x <- restructure(x) + if (!(nrow(x$ranef) || any(grepl("^sigma($|_)", variables(x))))) { + stop2("The model does not contain covariance matrices.") + } + .VarCorr <- function(y) { + # extract draws for sd, cor and cov + out <- list(sd = as.matrix(x, variable = y$sd_pars)) + colnames(out$sd) <- y$rnames + # compute correlation and covariance matrices + found_cor_pars <- intersect(y$cor_pars, variables(x)) + if (length(found_cor_pars)) { + cor <- as.matrix(x, variable = found_cor_pars) + if (length(found_cor_pars) < length(y$cor_pars)) { + # some correlations are missing and will be replaced by 0 + cor_all <- matrix(0, nrow = nrow(cor), ncol = length(y$cor_pars)) + names(cor_all) <- y$cor_pars + for (i in seq_len(ncol(cor_all))) { + found <- match(names(cor_all)[i], colnames(cor)) + if (!is.na(found)) { + cor_all[, i] <- cor[, found] + } + } + cor <- cor_all + } + out$cor <- get_cor_matrix(cor = cor) + out$cov <- get_cov_matrix(sd = out$sd, cor = cor) + dimnames(out$cor)[2:3] <- list(y$rnames, y$rnames) + dimnames(out$cov)[2:3] <- list(y$rnames, y$rnames) + if (summary) { + out$cor <- posterior_summary(out$cor, probs, robust) + out$cov <- posterior_summary(out$cov, probs, robust) + } + } + if (summary) { + out$sd <- posterior_summary(out$sd, probs, robust) + } + return(out) + } + + if (nrow(x$ranef)) { + get_names <- function(group) { + # get names of group-level parameters + r <- subset2(x$ranef, group = group) + rnames <- as.vector(get_rnames(r)) + cor_type <- paste0("cor_", group) + sd_pars <- paste0("sd_", group, "__", rnames) + cor_pars <- get_cornames(rnames, cor_type, brackets = FALSE) + nlist(rnames, sd_pars, cor_pars) + } + group <- unique(x$ranef$group) + tmp <- lapply(group, get_names) + names(tmp) <- group + } else { + tmp <- list() + } + # include residual variances in the output as well + bterms <- brmsterms(x$formula) + if (is.brmsterms(bterms)) { + if (simple_sigma(bterms) && !is.mixfamily(x$family)) { + tmp_resid <- list(rnames = bterms$resp, sd_pars = "sigma") + tmp <- c(tmp, residual__ = list(tmp_resid)) + } + } else if (is.mvbrmsterms(bterms)) { + simple_sigma <- ulapply(bterms$terms, simple_sigma) + pred_sigma <- ulapply(bterms$terms, pred_sigma) + is_mix <- ulapply(x$family, is.mixfamily) + if (any(simple_sigma) && !any(pred_sigma) && !any(is_mix)) { + resps <- bterms$responses[simple_sigma] + sd_pars <- paste0("sigma_", resps) + if (bterms$rescor) { + cor_pars <- get_cornames(resps, type = "rescor", brackets = FALSE) + } else { + cor_pars <- character(0) + } + tmp_resid <- nlist(rnames = resps, sd_pars, cor_pars) + tmp <- c(tmp, residual__ = list(tmp_resid)) + } + } + lapply(tmp, .VarCorr) +} + +#' @export +model.frame.brmsfit <- function(formula, ...) { + formula$data +} + +#' (Deprecated) Number of Posterior Samples +#' +#' Extract the number of posterior samples (draws) stored in a fitted Bayesian +#' model. Method \code{nsamples} is deprecated. Please use \code{ndraws} +#' instead. +#' +#' @aliases nsamples +#' +#' @param object An object of class \code{brmsfit}. +#' @param subset An optional integer vector defining a subset of samples +#' to be considered. +#' @param incl_warmup A flag indicating whether to also count warmup / burn-in +#' samples. +#' @param ... Currently ignored. +#' +#' @method nsamples brmsfit +#' @export +#' @export nsamples +#' @importFrom rstantools nsamples +nsamples.brmsfit <- function(object, subset = NULL, + incl_warmup = FALSE, ...) { + warning2("'nsamples.brmsfit' is deprecated. Please use 'ndraws' instead.") + if (!is(object$fit, "stanfit") || !length(object$fit@sim)) { + out <- 0 + } else { + ntsamples <- object$fit@sim$n_save[1] + if (!incl_warmup) { + ntsamples <- ntsamples - object$fit@sim$warmup2[1] + } + ntsamples <- ntsamples * object$fit@sim$chains + if (length(subset)) { + out <- length(subset) + if (out > ntsamples || max(subset) > ntsamples) { + stop2("Argument 'subset' is invalid.") + } + } else { + out <- ntsamples + } + } + out +} + +#' @export +nobs.brmsfit <- function(object, resp = NULL, ...) { + if (is_mv(object) && length(resp)) { + resp <- validate_resp(resp, object, multiple = FALSE) + bterms <- brmsterms(object$formula$forms[[resp]]) + out <- nrow(subset_data(model.frame(object), bterms)) + } else { + out <- nrow(model.frame(object)) + } + out +} + +#' Number of Grouping Factor Levels +#' +#' Extract the number of levels of one or more grouping factors. +#' +#' @aliases ngrps.brmsfit +#' +#' @param object An \R object. +#' @param ... Currently ignored. +#' +#' @return A named list containing the number of levels per +#' grouping factor. +#' +#' @export +ngrps.brmsfit <- function(object, ...) { + object <- restructure(object) + if (nrow(object$ranef)) { + out <- lapply(attr(object$ranef, "levels"), length) + } else { + out <- NULL + } + out +} + +#' @rdname ngrps.brmsfit +#' @export +ngrps <- function(object, ...) { + UseMethod("ngrps") +} + +#' @export +formula.brmsfit <- function(x, ...) { + x$formula +} + +#' @export +getCall.brmsfit <- function(x, ...) { + x$formula +} + +#' Extract Model Family Objects +#' +#' @inheritParams posterior_predict.brmsfit +#' @param ... Currently unused. +#' +#' @return A \code{brmsfamily} object +#' or a list of such objects for multivariate models. +#' +#' @export +family.brmsfit <- function(object, resp = NULL, ...) { + resp <- validate_resp(resp, object) + if (!is.null(resp)) { + # multivariate model + family <- lapply(object$formula$forms[resp], "[[", "family") + if (length(resp) == 1L) { + family <- family[[1]] + } + } else { + # univariate model + family <- object$formula$family + if (is.null(family)) { + family <- object$family + } + } + family +} + +#' Expose user-defined \pkg{Stan} functions +#' +#' Export user-defined \pkg{Stan} function and +#' optionally vectorize them. For more details see +#' \code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. +#' +#' @param x An object of class \code{brmsfit}. +#' @param vectorize Logical; Indicates if the exposed functions +#' should be vectorized via \code{\link{Vectorize}}. +#' Defaults to \code{FALSE}. +#' @param env Environment where the functions should be made +#' available. Defaults to the global environment. +#' @param ... Further arguments passed to +#' \code{\link[rstan:expose_stan_functions]{expose_stan_functions}}. +#' +#' @export +expose_functions.brmsfit <- function(x, vectorize = FALSE, + env = globalenv(), ...) { + vectorize <- as_one_logical(vectorize) + if (x$backend == "cmdstanr") { + # cmdstanr does not yet support 'expose_stan_functions' itself (#1176) + scode <- strsplit(stancode(x), "\n")[[1]] + data_line <- grep("^data[ ]+\\{$", scode) + scode <- paste0(c(scode[seq_len(data_line - 1)], "\n"), collapse = "\n") + stanmodel <- tempfile(fileext = ".stan") + cat(scode, file = stanmodel) + } else { + stanmodel <- x$fit + } + if (vectorize) { + funs <- rstan::expose_stan_functions(stanmodel, env = environment(), ...) + for (i in seq_along(funs)) { + FUN <- Vectorize(get(funs[i], mode = "function")) + assign(funs[i], FUN, pos = env) + } + } else { + funs <- rstan::expose_stan_functions(stanmodel, env = env, ...) + } + invisible(funs) +} + +#' @rdname expose_functions.brmsfit +#' @export +expose_functions <- function(x, ...) { + UseMethod("expose_functions") +} diff -Nru r-cran-brms-2.16.3/R/brmsformula.R r-cran-brms-2.17.0/R/brmsformula.R --- r-cran-brms-2.16.3/R/brmsformula.R 2021-08-26 17:47:33.000000000 +0000 +++ r-cran-brms-2.17.0/R/brmsformula.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,1701 +1,1705 @@ -#' Set up a model formula for use in \pkg{brms} -#' -#' Set up a model formula for use in the \pkg{brms} package -#' allowing to define (potentially non-linear) additive multilevel -#' models for all parameters of the assumed response distribution. -#' -#' @aliases bf -#' -#' @param formula An object of class \code{formula} -#' (or one that can be coerced to that class): -#' a symbolic description of the model to be fitted. -#' The details of model specification are given in 'Details'. -#' @param ... Additional \code{formula} objects to specify predictors of -#' non-linear and distributional parameters. Formulas can either be named -#' directly or contain names on their left-hand side. Alternatively, -#' it is possible to fix parameters to certain values by passing -#' numbers or character strings in which case arguments have to be named -#' to provide the parameter names. See 'Details' for more information. -#' @param flist Optional list of formulas, which are treated in the -#' same way as formulas passed via the \code{...} argument. -#' @param nl Logical; Indicates whether \code{formula} should be -#' treated as specifying a non-linear model. By default, \code{formula} -#' is treated as an ordinary linear model formula. -#' @param loop Logical; Only used in non-linear models. -#' Indicates if the computation of the non-linear formula should be -#' done inside (\code{TRUE}) or outside (\code{FALSE}) a loop -#' over observations. Defaults to \code{TRUE}. -#' @param center Logical; Indicates if the population-level design -#' matrix should be centered, which usually increases sampling efficiency. -#' See the 'Details' section for more information. -#' Defaults to \code{TRUE} for distributional parameters -#' and to \code{FALSE} for non-linear parameters. -#' @param cmc Logical; Indicates whether automatic cell-mean coding -#' should be enabled when removing the intercept by adding \code{0} -#' to the right-hand of model formulas. Defaults to \code{TRUE} to -#' mirror the behavior of standard \R formula parsing. -#' @param sparse Logical; indicates whether the population-level design matrices -#' should be treated as sparse (defaults to \code{FALSE}). For design matrices -#' with many zeros, this can considerably reduce required memory. Sampling -#' speed is currently not improved or even slightly decreased. -#' @param decomp Optional name of the decomposition used for the -#' population-level design matrix. Defaults to \code{NULL} that is -#' no decomposition. Other options currently available are -#' \code{"QR"} for the QR decomposition that helps in fitting models -#' with highly correlated predictors. -#' @param family Same argument as in \code{\link{brm}}. -#' If \code{family} is specified in \code{brmsformula}, it will -#' overwrite the value specified in other functions. -#' @param autocor An optional \code{formula} which contains -#' autocorrelation terms as described in \code{\link{autocor-terms}} -#' or alternatively a \code{\link{cor_brms}} object (deprecated). -#' If \code{autocor} is specified in \code{brmsformula}, it will -#' overwrite the value specified in other functions. -#' @param unused An optional \code{formula} which contains variables -#' that are unused in the model but should still be stored in the -#' model's data frame. This can be useful, for example, -#' if those variables are required for post-processing the model. -#' -#' @return An object of class \code{brmsformula}, which -#' is essentially a \code{list} containing all model -#' formulas as well as some additional information. -#' -#' @seealso \code{\link{mvbrmsformula}}, \code{\link{brmsformula-helpers}} -#' -#' @details -#' -#' \bold{General formula structure} -#' -#' The \code{formula} argument accepts formulas of the following syntax: -#' -#' \code{response | aterms ~ pterms + (gterms | group)} -#' -#' The \code{pterms} part contains effects that are assumed to be the same -#' across observations. We call them 'population-level' or 'overall' effects, -#' or (adopting frequentist vocabulary) 'fixed' effects. The optional -#' \code{gterms} part may contain effects that are assumed to vary across -#' grouping variables specified in \code{group}. We call them 'group-level' or -#' 'varying' effects, or (adopting frequentist vocabulary) 'random' effects, -#' although the latter name is misleading in a Bayesian context. For more -#' details type \code{vignette("brms_overview")} and -#' \code{vignette("brms_multilevel")}. -#' -#' \bold{Group-level terms} -#' -#' Multiple grouping factors each with multiple group-level effects are -#' possible. (Of course we can also run models without any group-level -#' effects.) Instead of \code{|} you may use \code{||} in grouping terms to -#' prevent correlations from being modeled. Equivalently, the \code{cor} -#' argument of the \code{\link{gr}} function can be used for this purpose, -#' for example, \code{(1 + x || g)} is equivalent to -#' \code{(1 + x | gr(g, cor = FALSE))}. -#' -#' It is also possible to model different group-level terms of the same -#' grouping factor as correlated (even across different formulas, e.g., in -#' non-linear models) by using \code{||} instead of \code{|}. All -#' group-level terms sharing the same ID will be modeled as correlated. If, -#' for instance, one specifies the terms \code{(1+x|i|g)} and \code{(1+z|i|g)} -#' somewhere in the formulas passed to \code{brmsformula}, correlations -#' between the corresponding group-level effects will be estimated. In the -#' above example, \code{i} is not a variable in the data but just a symbol to -#' indicate correlations between multiple group-level terms. Equivalently, the -#' \code{id} argument of the \code{\link{gr}} function can be used as well, -#' for example, \code{(1 + x | gr(g, id = "i"))}. -#' -#' If levels of the grouping factor belong to different sub-populations, -#' it may be reasonable to assume a different covariance matrix for each -#' of the sub-populations. For instance, the variation within the -#' treatment group and within the control group in a randomized control -#' trial might differ. Suppose that \code{y} is the outcome, and -#' \code{x} is the factor indicating the treatment and control group. -#' Then, we could estimate different hyper-parameters of the varying -#' effects (in this case a varying intercept) for treatment and control -#' group via \code{y ~ x + (1 | gr(subject, by = x))}. -#' -#' You can specify multi-membership terms using the \code{\link{mm}} -#' function. For instance, a multi-membership term with two members -#' could be \code{(1 | mm(g1, g2))}, where \code{g1} and \code{g2} -#' specify the first and second member, respectively. Moreover, -#' if a covariate \code{x} varies across the levels of the grouping-factors -#' \code{g1} and \code{g2}, we can save the respective covariate values -#' in the variables \code{x1} and \code{x2} and then model the varying -#' effect as \code{(1 + mmc(x1, x2) | mm(g1, g2))}. -#' -#' \bold{Special predictor terms} -#' -#' Flexible non-linear smooth terms can modeled using the \code{\link{s}} -#' and \code{\link{t2}} functions in the \code{pterms} part -#' of the model formula. This allows to fit generalized additive mixed -#' models (GAMMs) with \pkg{brms}. The implementation is similar to that -#' used in the \pkg{gamm4} package. For more details on this model class -#' see \code{\link[mgcv:gam]{gam}} and \code{\link[mgcv:gamm]{gamm}}. -#' -#' Gaussian process terms can be fitted using the \code{\link{gp}} -#' function in the \code{pterms} part of the model formula. Similar to -#' smooth terms, Gaussian processes can be used to model complex non-linear -#' relationships, for instance temporal or spatial autocorrelation. -#' However, they are computationally demanding and are thus not recommended -#' for very large datasets or approximations need to be used. -#' -#' The \code{pterms} and \code{gterms} parts may contain four non-standard -#' effect types namely monotonic, measurement error, missing value, and -#' category specific effects, which can be specified using terms of the -#' form \code{mo(predictor)}, \code{me(predictor, sd_predictor)}, -#' \code{mi(predictor)}, and \code{cs()}, respectively. -#' Category specific effects can only be estimated in -#' ordinal models and are explained in more detail in the package's -#' main vignette (type \code{vignette("brms_overview")}). -#' The other three effect types are explained in the following. -#' -#' A monotonic predictor must either be integer valued or an ordered factor, -#' which is the first difference to an ordinary continuous predictor. -#' More importantly, predictor categories (or integers) are not assumed to be -#' equidistant with respect to their effect on the response variable. -#' Instead, the distance between adjacent predictor categories (or integers) -#' is estimated from the data and may vary across categories. -#' This is realized by parameterizing as follows: -#' One parameter takes care of the direction and size of the effect similar -#' to an ordinary regression parameter, while an additional parameter vector -#' estimates the normalized distances between consecutive predictor categories. -#' A main application of monotonic effects are ordinal predictors that -#' can this way be modeled without (falsely) treating them as continuous -#' or as unordered categorical predictors. For more details and examples -#' see \code{vignette("brms_monotonic")}. -#' -#' Quite often, predictors are measured and as such naturally contain -#' measurement error. Although most researchers are well aware of this problem, -#' measurement error in predictors is ignored in most -#' regression analyses, possibly because only few packages allow -#' for modeling it. Notably, measurement error can be handled in -#' structural equation models, but many more general regression models -#' (such as those featured by \pkg{brms}) cannot be transferred -#' to the SEM framework. In \pkg{brms}, effects of noise-free predictors -#' can be modeled using the \code{me} (for 'measurement error') function. -#' If, say, \code{y} is the response variable and -#' \code{x} is a measured predictor with known measurement error -#' \code{sdx}, we can simply include it on the right-hand side of the -#' model formula via \code{y ~ me(x, sdx)}. -#' This can easily be extended to more general formulas. -#' If \code{x2} is another measured predictor with corresponding error -#' \code{sdx2} and \code{z} is a predictor without error -#' (e.g., an experimental setting), we can model all main effects -#' and interactions of the three predictors in the well known manner: -#' \code{y ~ me(x, sdx) * me(x2, sdx2) * z}. -#' The \code{me} function is soft deprecated in favor of the more flexible -#' and consistent \code{mi} function (see below). -#' -#' When a variable contains missing values, the corresponding rows will -#' be excluded from the data by default (row-wise exclusion). However, -#' quite often we want to keep these rows and instead estimate the missing values. -#' There are two approaches for this: (a) Impute missing values before -#' the model fitting for instance via multiple imputation (see -#' \code{\link{brm_multiple}} for a way to handle multiple imputed datasets). -#' (b) Impute missing values on the fly during model fitting. The latter -#' approach is explained in the following. Using a variable with missing -#' values as predictors requires two things, First, we need to specify that -#' the predictor contains missings that should to be imputed. -#' If, say, \code{y} is the primary response, \code{x} is a -#' predictor with missings and \code{z} is a predictor without missings, -#' we go for \code{y ~ mi(x) + z}. Second, we need to model \code{x} -#' as an additional response with corresponding predictors and the -#' addition term \code{mi()}. In our example, we could write -#' \code{x | mi() ~ z}. Measurement error may be included via -#' the \code{sdy} argument, say, \code{x | mi(sdy = se) ~ z}. -#' See \code{\link{mi}} for examples with real data. -#' -#' -#' \bold{Autocorrelation terms} -#' -#' Autocorrelation terms can be directly specified inside the \code{pterms} -#' part as well. Details can be found in \code{\link{autocor-terms}}. -#' -#' \bold{Additional response information} -#' -#' Another special of the \pkg{brms} formula syntax is the optional -#' \code{aterms} part, which may contain multiple terms of the form -#' \code{fun()} separated by \code{+} each providing special -#' information on the response variable. \code{fun} can be replaced with -#' either \code{se}, \code{weights}, \code{subset}, \code{cens}, \code{trunc}, -#' \code{trials}, \code{cat}, \code{dec}, \code{rate}, \code{vreal}, or -#' \code{vint}. Their meanings are explained below. -#' (see also \code{\link{addition-terms}}). -#' -#' For families \code{gaussian}, \code{student} and \code{skew_normal}, it is -#' possible to specify standard errors of the observations, thus allowing -#' to perform meta-analysis. Suppose that the variable \code{yi} contains -#' the effect sizes from the studies and \code{sei} the corresponding -#' standard errors. Then, fixed and random effects meta-analyses can -#' be conducted using the formulas \code{yi | se(sei) ~ 1} and -#' \code{yi | se(sei) ~ 1 + (1|study)}, respectively, where -#' \code{study} is a variable uniquely identifying every study. -#' If desired, meta-regression can be performed via -#' \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1|study)} -#' or \cr \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1 + mod1 + mod2|study)}, -#' where \code{mod1} and \code{mod2} represent moderator variables. -#' By default, the standard errors replace the parameter \code{sigma}. -#' To model \code{sigma} in addition to the known standard errors, -#' set argument \code{sigma} in function \code{se} to \code{TRUE}, -#' for instance, \code{yi | se(sei, sigma = TRUE) ~ 1}. -#' -#' For all families, weighted regression may be performed using -#' \code{weights} in the \code{aterms} part. Internally, this is -#' implemented by multiplying the log-posterior values of each -#' observation by their corresponding weights. -#' Suppose that variable \code{wei} contains the weights -#' and that \code{yi} is the response variable. -#' Then, formula \code{yi | weights(wei) ~ predictors} -#' implements a weighted regression. -#' -#' For multivariate models, \code{subset} may be used in the \code{aterms} -#' part, to use different subsets of the data in different univariate -#' models. For instance, if \code{sub} is a logical variable and -#' \code{y} is the response of one of the univariate models, we may -#' write \code{y | subset(sub) ~ predictors} so that \code{y} is -#' predicted only for those observations for which \code{sub} evaluates -#' to \code{TRUE}. -#' -#' For log-linear models such as poisson models, \code{rate} may be used -#' in the \code{aterms} part to specify the denominator of a response that -#' is expressed as a rate. The numerator is given by the actual response -#' variable and has a distribution according to the family as usual. Using -#' \code{rate(denom)} is equivalent to adding \code{offset(log(denom))} to -#' the linear predictor of the main parameter but the former is arguably -#' more convenient and explicit. -#' -#' With the exception of categorical and ordinal families, -#' left, right, and interval censoring can be modeled through -#' \code{y | cens(censored) ~ predictors}. The censoring variable -#' (named \code{censored} in this example) should contain the values -#' \code{'left'}, \code{'none'}, \code{'right'}, and \code{'interval'} -#' (or equivalently \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate that -#' the corresponding observation is left censored, not censored, right censored, -#' or interval censored. For interval censored data, a second variable -#' (let's call it \code{y2}) has to be passed to \code{cens}. In this case, -#' the formula has the structure \code{y | cens(censored, y2) ~ predictors}. -#' While the lower bounds are given in \code{y}, the upper bounds are given -#' in \code{y2} for interval censored data. Intervals are assumed to be open -#' on the left and closed on the right: \code{(y, y2]}. -#' -#' With the exception of categorical and ordinal families, -#' the response distribution can be truncated using the \code{trunc} -#' function in the addition part. If the response variable is truncated -#' between, say, 0 and 100, we can specify this via -#' \code{yi | trunc(lb = 0, ub = 100) ~ predictors}. -#' Instead of numbers, variables in the data set can also be passed allowing -#' for varying truncation points across observations. Defining only one of -#' the two arguments in \code{trunc} leads to one-sided truncation. -#' -#' For all continuous families, missing values in the responses can be imputed -#' within Stan by using the addition term \code{mi}. This is mostly -#' useful in combination with \code{mi} predictor terms as explained -#' above under 'Special predictor terms'. -#' -#' For families \code{binomial} and \code{zero_inflated_binomial}, -#' addition should contain a variable indicating the number of trials -#' underlying each observation. In \code{lme4} syntax, we may write for instance -#' \code{cbind(success, n - success)}, which is equivalent -#' to \code{success | trials(n)} in \pkg{brms} syntax. If the number of trials -#' is constant across all observations, say \code{10}, -#' we may also write \code{success | trials(10)}. -#' \bold{Please note that the \code{cbind()} syntax will not work -#' in \pkg{brms} in the expected way because this syntax is reserved -#' for other purposes.} -#' -#' For all ordinal families, \code{aterms} may contain a term -#' \code{thres(number)} to specify the number thresholds (e.g, -#' \code{thres(6)}), which should be equal to the total number of response -#' categories - 1. If not given, the number of thresholds is calculated from -#' the data. If different threshold vectors should be used for different -#' subsets of the data, the \code{gr} argument can be used to provide the -#' grouping variable (e.g, \code{thres(6, gr = item)}, if \code{item} is the -#' grouping variable). In this case, the number of thresholds can also be a -#' variable in the data with different values per group. -#' -#' A deprecated quasi alias of \code{thres()} is \code{cat()} with which the -#' total number of response categories (i.e., number of thresholds + 1) can be -#' specified. -#' -#' In Wiener diffusion models (family \code{wiener}) the addition term -#' \code{dec} is mandatory to specify the (vector of) binary decisions -#' corresponding to the reaction times. Non-zero values will be treated -#' as a response on the upper boundary of the diffusion process and zeros -#' will be treated as a response on the lower boundary. Alternatively, -#' the variable passed to \code{dec} might also be a character vector -#' consisting of \code{'lower'} and \code{'upper'}. -#' -#' All families support the \code{index} addition term to uniquely identify -#' each observation of the corresponding response variable. Currently, -#' \code{index} is primarily useful in combination with the \code{subset} -#' addition and \code{\link{mi}} terms. -#' -#' For custom families, it is possible to pass an arbitrary number of real and -#' integer vectors via the addition terms \code{vreal} and \code{vint}, -#' respectively. An example is provided in -#' \code{vignette('brms_customfamilies')}. To pass multiple vectors of the -#' same data type, provide them separated by commas inside a single -#' \code{vreal} or \code{vint} statement. -#' -#' Multiple addition terms of different types may be specified at the same -#' time using the \code{+} operator. For example, the formula -#' \code{formula = yi | se(sei) + cens(censored) ~ 1} implies a censored -#' meta-analytic model. -#' -#' The addition argument \code{disp} (short for dispersion) -#' has been removed in version 2.0. You may instead use the -#' distributional regression approach by specifying -#' \code{sigma ~ 1 + offset(log(xdisp))} or -#' \code{shape ~ 1 + offset(log(xdisp))}, where \code{xdisp} is -#' the variable being previously passed to \code{disp}. -#' -#' \bold{Parameterization of the population-level intercept} -#' -#' By default, the population-level intercept (if incorporated) is estimated -#' separately and not as part of population-level parameter vector \code{b} As -#' a result, priors on the intercept also have to be specified separately. -#' Furthermore, to increase sampling efficiency, the population-level design -#' matrix \code{X} is centered around its column means \code{X_means} if the -#' intercept is incorporated. This leads to a temporary bias in the intercept -#' equal to \code{}, where \code{<,>} is the scalar product. The -#' bias is corrected after fitting the model, but be aware that you are -#' effectively defining a prior on the intercept of the centered design matrix -#' not on the real intercept. You can turn off this special handling of the -#' intercept by setting argument \code{center} to \code{FALSE}. For more -#' details on setting priors on population-level intercepts, see -#' \code{\link{set_prior}}. -#' -#' This behavior can be avoided by using the reserved -#' (and internally generated) variable \code{Intercept}. -#' Instead of \code{y ~ x}, you may write -#' \code{y ~ 0 + Intercept + x}. This way, priors can be -#' defined on the real intercept, directly. In addition, -#' the intercept is just treated as an ordinary population-level effect -#' and thus priors defined on \code{b} will also apply to it. -#' Note that this parameterization may be less efficient -#' than the default parameterization discussed above. -#' -#' \bold{Formula syntax for non-linear models} -#' -#' In \pkg{brms}, it is possible to specify non-linear models -#' of arbitrary complexity. -#' The non-linear model can just be specified within the \code{formula} -#' argument. Suppose, that we want to predict the response \code{y} -#' through the predictor \code{x}, where \code{x} is linked to \code{y} -#' through \code{y = alpha - beta * lambda^x}, with parameters -#' \code{alpha}, \code{beta}, and \code{lambda}. This is certainly a -#' non-linear model being defined via -#' \code{formula = y ~ alpha - beta * lambda^x} (addition arguments -#' can be added in the same way as for ordinary formulas). -#' To tell \pkg{brms} that this is a non-linear model, -#' we set argument \code{nl} to \code{TRUE}. -#' Now we have to specify a model for each of the non-linear parameters. -#' Let's say we just want to estimate those three parameters -#' with no further covariates or random effects. Then we can pass -#' \code{alpha + beta + lambda ~ 1} or equivalently -#' (and more flexible) \code{alpha ~ 1, beta ~ 1, lambda ~ 1} -#' to the \code{...} argument. -#' This can, of course, be extended. If we have another predictor \code{z} and -#' observations nested within the grouping factor \code{g}, we may write for -#' instance \code{alpha ~ 1, beta ~ 1 + z + (1|g), lambda ~ 1}. -#' The formula syntax described above applies here as well. -#' In this example, we are using \code{z} and \code{g} only for the -#' prediction of \code{beta}, but we might also use them for the other -#' non-linear parameters (provided that the resulting model is still -#' scientifically reasonable). -#' -#' By default, non-linear covariates are treated as real vectors in Stan. -#' However, if the data of the covariates is of type `integer` in \R (which -#' can be enforced by the `as.integer` function), the Stan type will be -#' changed to an integer array. That way, covariates can also be used -#' for indexing purposes in Stan. -#' -#' Non-linear models may not be uniquely identified and / or show bad convergence. -#' For this reason it is mandatory to specify priors on the non-linear parameters. -#' For instructions on how to do that, see \code{\link{set_prior}}. -#' For some examples of non-linear models, see \code{vignette("brms_nonlinear")}. -#' -#' \bold{Formula syntax for predicting distributional parameters} -#' -#' It is also possible to predict parameters of the response distribution such -#' as the residual standard deviation \code{sigma} in gaussian models or the -#' hurdle probability \code{hu} in hurdle models. The syntax closely resembles -#' that of a non-linear parameter, for instance \code{sigma ~ x + s(z) + -#' (1+x|g)}. For some examples of distributional models, see -#' \code{vignette("brms_distreg")}. -#' -#' Parameter \code{mu} exists for every family and can be used as an -#' alternative to specifying terms in \code{formula}. If both \code{mu} and -#' \code{formula} are given, the right-hand side of \code{formula} is ignored. -#' Accordingly, specifying terms on the right-hand side of both \code{formula} -#' and \code{mu} at the same time is deprecated. In future versions, -#' \code{formula} might be updated by \code{mu}. -#' -#' The following are -#' distributional parameters of specific families (all other parameters are -#' treated as non-linear parameters): \code{sigma} (residual standard -#' deviation or scale of the \code{gaussian}, \code{student}, -#' \code{skew_normal}, \code{lognormal} \code{exgaussian}, and -#' \code{asym_laplace} families); \code{shape} (shape parameter of the -#' \code{Gamma}, \code{weibull}, \code{negbinomial}, and related zero-inflated -#' / hurdle families); \code{nu} (degrees of freedom parameter of the -#' \code{student} and \code{frechet} families); \code{phi} (precision -#' parameter of the \code{beta} and \code{zero_inflated_beta} families); -#' \code{kappa} (precision parameter of the \code{von_mises} family); -#' \code{beta} (mean parameter of the exponential component of the -#' \code{exgaussian} family); \code{quantile} (quantile parameter of the -#' \code{asym_laplace} family); \code{zi} (zero-inflation probability); -#' \code{hu} (hurdle probability); \code{zoi} (zero-one-inflation -#' probability); \code{coi} (conditional one-inflation probability); -#' \code{disc} (discrimination) for ordinal models; \code{bs}, \code{ndt}, and -#' \code{bias} (boundary separation, non-decision time, and initial bias of -#' the \code{wiener} diffusion model). By default, distributional parameters -#' are modeled on the log scale if they can be positive only or on the logit -#' scale if the can only be within the unit interval. -#' -#' Alternatively, one may fix distributional parameters to certain values. -#' However, this is mainly useful when models become too -#' complicated and otherwise have convergence issues. -#' We thus suggest to be generally careful when making use of this option. -#' The \code{quantile} parameter of the \code{asym_laplace} distribution -#' is a good example where it is useful. By fixing \code{quantile}, -#' one can perform quantile regression for the specified quantile. -#' For instance, \code{quantile = 0.25} allows predicting the 25\%-quantile. -#' Furthermore, the \code{bias} parameter in drift-diffusion models, -#' is assumed to be \code{0.5} (i.e. no bias) in many applications. -#' To achieve this, simply write \code{bias = 0.5}. -#' Other possible applications are the Cauchy distribution as a -#' special case of the Student-t distribution with -#' \code{nu = 1}, or the geometric distribution as a special case of -#' the negative binomial distribution with \code{shape = 1}. -#' Furthermore, the parameter \code{disc} ('discrimination') in ordinal -#' models is fixed to \code{1} by default and not estimated, -#' but may be modeled as any other distributional parameter if desired -#' (see examples). For reasons of identification, \code{'disc'} -#' can only be positive, which is achieved by applying the log-link. -#' -#' In categorical models, distributional parameters do not have -#' fixed names. Instead, they are named after the response categories -#' (excluding the first one, which serves as the reference category), -#' with the prefix \code{'mu'}. If, for instance, categories are named -#' \code{cat1}, \code{cat2}, and \code{cat3}, the distributional parameters -#' will be named \code{mucat2} and \code{mucat3}. -#' -#' Some distributional parameters currently supported by \code{brmsformula} -#' have to be positive (a negative standard deviation or precision parameter -#' does not make any sense) or are bounded between 0 and 1 (for zero-inflated / -#' hurdle probabilities, quantiles, or the initial bias parameter of -#' drift-diffusion models). -#' However, linear predictors can be positive or negative, and thus the log link -#' (for positive parameters) or logit link (for probability parameters) are used -#' by default to ensure that distributional parameters are within their valid intervals. -#' This implies that, by default, effects for such distributional parameters are -#' estimated on the log / logit scale and one has to apply the inverse link -#' function to get to the effects on the original scale. -#' Alternatively, it is possible to use the identity link to predict parameters -#' on their original scale, directly. However, this is much more likely to lead -#' to problems in the model fitting, if the parameter actually has a restricted range. -#' -#' See also \code{\link{brmsfamily}} for an overview of valid link functions. -#' -#' \bold{Formula syntax for mixture models} -#' -#' The specification of mixture models closely resembles that -#' of non-mixture models. If not specified otherwise (see below), -#' all mean parameters of the mixture components are predicted -#' using the right-hand side of \code{formula}. All types of predictor -#' terms allowed in non-mixture models are allowed in mixture models -#' as well. -#' -#' Distributional parameters of mixture distributions have the same -#' name as those of the corresponding ordinary distributions, but with -#' a number at the end to indicate the mixture component. For instance, if -#' you use family \code{mixture(gaussian, gaussian)}, the distributional -#' parameters are \code{sigma1} and \code{sigma2}. -#' Distributional parameters of the same class can be fixed to the same value. -#' For the above example, we could write \code{sigma2 = "sigma1"} to make -#' sure that both components have the same residual standard deviation, -#' which is in turn estimated from the data. -#' -#' In addition, there are two types of special distributional parameters. -#' The first are named \code{mu}, that allow for modeling different -#' predictors for the mean parameters of different mixture components. -#' For instance, if you want to predict the mean of the first component -#' using predictor \code{x} and the mean of the second component using -#' predictor \code{z}, you can write \code{mu1 ~ x} as well as \code{mu2 ~ z}. -#' The second are named \code{theta}, which constitute the mixing -#' proportions. If the mixing proportions are fixed to certain values, -#' they are internally normalized to form a probability vector. -#' If one seeks to predict the mixing proportions, all but -#' one of the them has to be predicted, while the remaining one is used -#' as the reference category to identify the model. The \code{softmax} -#' function is applied on the linear predictor terms to form a -#' probability vector. -#' -#' For more information on mixture models, see -#' the documentation of \code{\link{mixture}}. -#' -#' \bold{Formula syntax for multivariate models} -#' -#' Multivariate models may be specified using \code{mvbind} notation -#' or with help of the \code{\link{mvbf}} function. -#' Suppose that \code{y1} and \code{y2} are response variables -#' and \code{x} is a predictor. Then \code{mvbind(y1, y2) ~ x} -#' specifies a multivariate model. -#' The effects of all terms specified at the RHS of the formula -#' are assumed to vary across response variables. -#' For instance, two parameters will be estimated for \code{x}, -#' one for the effect on \code{y1} and another for the effect on \code{y2}. -#' This is also true for group-level effects. When writing, for instance, -#' \code{mvbind(y1, y2) ~ x + (1+x|g)}, group-level effects will be -#' estimated separately for each response. To model these effects -#' as correlated across responses, use the ID syntax (see above). -#' For the present example, this would look as follows: -#' \code{mvbind(y1, y2) ~ x + (1+x|2|g)}. Of course, you could also use -#' any value other than \code{2} as ID. -#' -#' It is also possible to specify different formulas for different responses. -#' If, for instance, \code{y1} should be predicted by \code{x} and \code{y2} -#' should be predicted by \code{z}, we could write \code{mvbf(y1 ~ x, y2 ~ z)}. -#' Alternatively, multiple \code{brmsformula} objects can be added to -#' specify a joint multivariate model (see 'Examples'). -#' -#' @examples -#' # multilevel model with smoothing terms -#' brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2)) -#' -#' # additionally predict 'sigma' -#' brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2), -#' sigma ~ x1 + (1|g2)) -#' -#' # use the shorter alias 'bf' -#' (formula1 <- brmsformula(y ~ x + (x|g))) -#' (formula2 <- bf(y ~ x + (x|g))) -#' # will be TRUE -#' identical(formula1, formula2) -#' -#' # incorporate censoring -#' bf(y | cens(censor_variable) ~ predictors) -#' -#' # define a simple non-linear model -#' bf(y ~ a1 - a2^x, a1 + a2 ~ 1, nl = TRUE) -#' -#' # predict a1 and a2 differently -#' bf(y ~ a1 - a2^x, a1 ~ 1, a2 ~ x + (x|g), nl = TRUE) -#' -#' # correlated group-level effects across parameters -#' bf(y ~ a1 - a2^x, a1 ~ 1 + (1 |2| g), a2 ~ x + (x |2| g), nl = TRUE) -#' # alternative but equivalent way to specify the above model -#' bf(y ~ a1 - a2^x, a1 ~ 1 + (1 | gr(g, id = 2)), -#' a2 ~ x + (x | gr(g, id = 2)), nl = TRUE) -#' -#' # define a multivariate model -#' bf(mvbind(y1, y2) ~ x * z + (1|g)) -#' -#' # define a zero-inflated model -#' # also predicting the zero-inflation part -#' bf(y ~ x * z + (1+x|ID1|g), zi ~ x + (1|ID1|g)) -#' -#' # specify a predictor as monotonic -#' bf(y ~ mo(x) + more_predictors) -#' -#' # for ordinal models only -#' # specify a predictor as category specific -#' bf(y ~ cs(x) + more_predictors) -#' # add a category specific group-level intercept -#' bf(y ~ cs(x) + (cs(1)|g)) -#' # specify parameter 'disc' -#' bf(y ~ person + item, disc ~ item) -#' -#' # specify variables containing measurement error -#' bf(y ~ me(x, sdx)) -#' -#' # specify predictors on all parameters of the wiener diffusion model -#' # the main formula models the drift rate 'delta' -#' bf(rt | dec(decision) ~ x, bs ~ x, ndt ~ x, bias ~ x) -#' -#' # fix the bias parameter to 0.5 -#' bf(rt | dec(decision) ~ x, bias = 0.5) -#' -#' # specify different predictors for different mixture components -#' mix <- mixture(gaussian, gaussian) -#' bf(y ~ 1, mu1 ~ x, mu2 ~ z, family = mix) -#' -#' # fix both residual standard deviations to the same value -#' bf(y ~ x, sigma2 = "sigma1", family = mix) -#' -#' # use the '+' operator to specify models -#' bf(y ~ 1) + -#' nlf(sigma ~ a * exp(b * x), a ~ x) + -#' lf(b ~ z + (1|g), dpar = "sigma") + -#' gaussian() -#' -#' # specify a multivariate model using the '+' operator -#' bf(y1 ~ x + (1|g)) + -#' gaussian() + cor_ar(~1|g) + -#' bf(y2 ~ z) + poisson() -#' -#' # specify correlated residuals of a gaussian and a poisson model -#' form1 <- bf(y1 ~ 1 + x + (1|c|obs), sigma = 1) + gaussian() -#' form2 <- bf(y2 ~ 1 + x + (1|c|obs)) + poisson() -#' -#' # model missing values in predictors -#' bf(bmi ~ age * mi(chl)) + -#' bf(chl | mi() ~ age) + -#' set_rescor(FALSE) -#' -#' # model sigma as a function of the mean -#' bf(y ~ eta, nl = TRUE) + -#' lf(eta ~ 1 + x) + -#' nlf(sigma ~ tau * sqrt(eta)) + -#' lf(tau ~ 1) -#' -#' @export -brmsformula <- function(formula, ..., flist = NULL, family = NULL, - autocor = NULL, nl = NULL, loop = NULL, - center = NULL, cmc = NULL, sparse = NULL, - decomp = NULL, unused = NULL) { - if (is.brmsformula(formula)) { - out <- formula - } else { - out <- list(formula = as_formula(formula)) - class(out) <- "brmsformula" - } - # parse and validate dots arguments - dots <- c(out$pforms, out$pfix, list(...), flist) - dots <- lapply(dots, function(x) if (is.list(x)) x else list(x)) - dots <- unlist(dots, recursive = FALSE) - forms <- list() - for (i in seq_along(dots)) { - c(forms) <- validate_par_formula(dots[[i]], par = names(dots)[i]) - } - is_dupl_pars <- duplicated(names(forms), fromLast = TRUE) - if (any(is_dupl_pars)) { - dupl_pars <- collapse_comma(names(forms)[is_dupl_pars]) - message("Replacing initial definitions of parameters ", dupl_pars) - forms[is_dupl_pars] <- NULL - } - not_form <- ulapply(forms, function(x) !is.formula(x)) - fix <- forms[not_form] - forms[names(fix)] <- NULL - out$pforms <- forms - # validate fixed distributional parameters - fix_theta <- fix[dpar_class(names(fix)) %in% "theta"] - if (length(fix_theta)) { - # normalize mixing proportions - sum_theta <- sum(unlist(fix_theta)) - fix_theta <- lapply(fix_theta, "/", sum_theta) - fix[names(fix_theta)] <- fix_theta - } - out$pfix <- fix - for (dp in names(out$pfix)) { - if (is.character(out$pfix[[dp]])) { - if (identical(dp, out$pfix[[dp]])) { - stop2("Equating '", dp, "' with itself is not meaningful.") - } - ap_class <- dpar_class(dp) - if (ap_class == "mu") { - stop2("Equating parameters of class 'mu' is not allowed.") - } - if (!identical(ap_class, dpar_class(out$pfix[[dp]]))) { - stop2("Can only equate parameters of the same class.") - } - if (out$pfix[[dp]] %in% names(out$pfix)) { - stop2("Cannot use fixed parameters on ", - "the right-hand side of an equation.") - } - if (out$pfix[[dp]] %in% names(out$pforms)) { - stop2("Cannot use predicted parameters on ", - "the right-hand side of an equation.") - } - } - } - if (!is.null(nl)) { - attr(out$formula, "nl") <- as_one_logical(nl) - } else if (!is.null(out[["nl"]])) { - # for backwards compatibility with brms <= 1.8.0 - attr(out$formula, "nl") <- out[["nl"]] - out[["nl"]] <- NULL - } - if (is.null(attr(out$formula, "nl"))) { - attr(out$formula, "nl") <- FALSE - } - if (!is.null(loop)) { - attr(out$formula, "loop") <- as_one_logical(loop) - } - if (is.null(attr(out$formula, "loop"))) { - attr(out$formula, "loop") <- TRUE - } - if (!is.null(center)) { - attr(out$formula, "center") <- as_one_logical(center) - } - if (!is.null(cmc)) { - attr(out$formula, "cmc") <- as_one_logical(cmc) - } - if (!is.null(sparse)) { - attr(out$formula, "sparse") <- as_one_logical(sparse) - } - if (!is.null(decomp)) { - attr(out$formula, "decomp") <- match.arg(decomp, decomp_opts()) - } - if (!is.null(unused)) { - attr(out$formula, "unused") <- as.formula(unused) - } - if (!is.null(autocor)) { - attr(out$formula, "autocor") <- validate_autocor(autocor) - } else if (!is.null(out$autocor)) { - # for backwards compatibility with brms <= 2.11.0 - attr(out$formula, "autocor") <- validate_autocor(out$autocor) - out$autocor <- NULL - } - if (!is.null(family)) { - out$family <- validate_family(family) - } - if (!is.null(lhs(formula))) { - out$resp <- terms_resp(formula) - } - # add default values for unspecified elements - defs <- list(pforms = list(), pfix = list(), family = NULL, resp = NULL) - defs <- defs[setdiff(names(defs), names(rmNULL(out, FALSE)))] - out[names(defs)] <- defs - class(out) <- c("brmsformula", "bform") - split_bf(out) -} - -# alias of brmsformula -#' @export -bf <- function(formula, ..., flist = NULL, family = NULL, autocor = NULL, - nl = NULL, loop = NULL, center = NULL, cmc = NULL, - sparse = NULL, decomp = NULL) { - brmsformula( - formula, ..., flist = flist, family = family, autocor = autocor, - nl = nl, loop = loop, center = center, cmc = cmc, sparse = sparse, - decomp = decomp - ) -} - -#' Linear and Non-linear formulas in \pkg{brms} -#' -#' Helper functions to specify linear and non-linear -#' formulas for use with \code{\link[brms:brmsformula]{brmsformula}}. -#' -#' @name brmsformula-helpers -#' @aliases bf-helpers nlf lf set_nl set_rescor -#' -#' @param formula Non-linear formula for a distributional parameter. -#' The name of the distributional parameter can either be specified -#' on the left-hand side of \code{formula} or via argument \code{dpar}. -#' @param dpar Optional character string specifying the distributional -#' parameter to which the formulas passed via \code{...} and -#' \code{flist} belong. -#' @param resp Optional character string specifying the response -#' variable to which the formulas passed via \code{...} and -#' \code{flist} belong. Only relevant in multivariate models. -#' @param autocor A one sided formula containing autocorrelation -#' terms. All none autocorrelation terms in \code{autocor} will -#' be silently ignored. -#' @param rescor Logical; Indicates if residual correlation between -#' the response variables should be modeled. Currently this is only -#' possible in multivariate \code{gaussian} and \code{student} models. -#' Only relevant in multivariate models. -#' @param mecor Logical; Indicates if correlations between latent variables -#' defined by \code{\link{me}} terms should be modeled. Defaults to \code{TRUE}. -#' @inheritParams brmsformula -#' -#' @return For \code{lf} and \code{nlf} a \code{list} that can be -#' passed to \code{\link[brms:brmsformula]{brmsformula}} or added -#' to an existing \code{brmsformula} or \code{mvbrmsformula} object. -#' For \code{set_nl} and \code{set_rescor} a logical value that can be -#' added to an existing \code{brmsformula} or \code{mvbrmsformula} object. -#' -#' @seealso \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} -#' -#' @examples -#' # add more formulas to the model -#' bf(y ~ 1) + -#' nlf(sigma ~ a * exp(b * x)) + -#' lf(a ~ x, b ~ z + (1|g)) + -#' gaussian() -#' -#' # specify 'nl' later on -#' bf(y ~ a * inv_logit(x * b)) + -#' lf(a + b ~ z) + -#' set_nl(TRUE) -#' -#' # specify a multivariate model -#' bf(y1 ~ x + (1|g)) + -#' bf(y2 ~ z) + -#' set_rescor(TRUE) -#' -#' # add autocorrelation terms -#' bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(W)) -NULL - -#' @rdname brmsformula-helpers -#' @export -nlf <- function(formula, ..., flist = NULL, dpar = NULL, - resp = NULL, loop = NULL) { - formula <- as_formula(formula) - if (is.null(lhs(formula))) { - stop2("Argument 'formula' must be two-sided.") - } - if (length(c(list(...), flist))) { - warning2( - "Arguments '...' and 'flist' in nlf() will be reworked ", - "at some point. Please avoid using them if possible." - ) - } - warn_dpar(dpar) - if (!is.null(resp)) { - resp <- as_one_character(resp) - } - if (!is.null(loop)) { - attr(formula, "loop") <- as_one_logical(loop) - } - if (is.null(attr(formula, "loop"))) { - attr(formula, "loop") <- TRUE - } - out <- c( - list(structure(formula, nl = TRUE)), - lf(..., flist = flist) - ) - structure(out, resp = resp) -} - -#' @rdname brmsformula-helpers -#' @export -lf <- function(..., flist = NULL, dpar = NULL, resp = NULL, - center = NULL, cmc = NULL, sparse = NULL, - decomp = NULL) { - out <- c(list(...), flist) - warn_dpar(dpar) - if (!is.null(resp)) { - resp <- as_one_character(resp) - } - cmc <- if (!is.null(cmc)) as_one_logical(cmc) - center <- if (!is.null(center)) as_one_logical(center) - decomp <- if (!is.null(decomp)) match.arg(decomp, decomp_opts()) - for (i in seq_along(out)) { - if (!is.null(cmc)) { - attr(out[[i]], "cmc") <- cmc - } - if (!is.null(center)) { - attr(out[[i]], "center") <- center - } - if (!is.null(sparse)) { - attr(out[[i]], "sparse") <- sparse - } - if (!is.null(decomp)) { - attr(out[[i]], "decomp") <- decomp - } - } - structure(out, resp = resp) -} - -#' @rdname brmsformula-helpers -#' @export -acformula <- function(autocor, resp = NULL) { - autocor <- terms_ac(as.formula(autocor)) - if (!is.formula(autocor)) { - stop2("'autocor' must contain at least one autocorrelation term.") - } - if (!is.null(resp)) { - resp <- as_one_character(resp) - } - structure(autocor, resp = resp, class = c("acformula", "formula")) -} - -#' @rdname brmsformula-helpers -#' @export -set_nl <- function(nl = TRUE, dpar = NULL, resp = NULL) { - nl <- as_one_logical(nl) - if (!is.null(dpar)) { - dpar <- as_one_character(dpar) - } - if (!is.null(resp)) { - resp <- as_one_character(resp) - } - structure(nl, dpar = dpar, resp = resp, class = "setnl") -} - -#' Set up a multivariate model formula for use in \pkg{brms} -#' -#' Set up a multivariate model formula for use in the \pkg{brms} package -#' allowing to define (potentially non-linear) additive multilevel -#' models for all parameters of the assumed response distributions. -#' -#' @aliases mvbf -#' -#' @param ... Objects of class \code{formula} or \code{brmsformula}, -#' each specifying a univariate model. See \code{\link{brmsformula}} -#' for details on how to specify univariate models. -#' @param flist Optional list of formulas, which are treated in the -#' same way as formulas passed via the \code{...} argument. -#' @param rescor Logical; Indicates if residual correlation between -#' the response variables should be modeled. Currently, this is only -#' possible in multivariate \code{gaussian} and \code{student} models. -#' If \code{NULL} (the default), \code{rescor} is internally set to -#' \code{TRUE} when possible. -#' -#' @return An object of class \code{mvbrmsformula}, which -#' is essentially a \code{list} containing all model formulas -#' as well as some additional information for multivariate models. -#' -#' @details See \code{vignette("brms_multivariate")} for a case study. -#' -#' @seealso \code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} -#' -#' @examples -#' bf1 <- bf(y1 ~ x + (1|g)) -#' bf2 <- bf(y2 ~ s(z)) -#' mvbf(bf1, bf2) -#' -#' @export -mvbrmsformula <- function(..., flist = NULL, rescor = NULL) { - dots <- c(list(...), flist) - if (!length(dots)) { - stop2("No objects passed to 'mvbrmsformula'.") - } - forms <- list() - for (i in seq_along(dots)) { - if (is.mvbrmsformula(dots[[i]])) { - forms <- c(forms, dots[[i]]$forms) - if (is.null(rescor)) { - rescor <- dots[[i]]$rescor - } - } else { - forms <- c(forms, list(bf(dots[[i]]))) - } - } - if (!is.null(rescor)) { - rescor <- as_one_logical(rescor) - } - responses <- ulapply(forms, "[[", "resp") - if (any(duplicated(responses))) { - stop2("Cannot use the same response variable twice in the same model.") - } - names(forms) <- responses - structure( - nlist(forms, responses, rescor), - class = c("mvbrmsformula", "bform") - ) -} - -#' @export -mvbf <- function(..., flist = NULL, rescor = NULL) { - mvbrmsformula(..., flist = flist, rescor = rescor) -} - -# build a mvbrmsformula object based on a brmsformula object -# which uses mvbind on the left-hand side to specify MV models -split_bf <- function(x) { - stopifnot(is.brmsformula(x)) - resp <- terms_resp(x$formula, check_names = FALSE) - str_adform <- formula2str(x$formula) - str_adform <- get_matches("\\|[^~]*(?=~)", str_adform, perl = TRUE) - if (length(resp) > 1L) { - # mvbind syntax used to specify MV model - flist <- named_list(resp) - for (i in seq_along(resp)) { - flist[[i]] <- x - str_lhs <- paste0(resp[[i]], str_adform) - flist[[i]]$formula[[2]] <- parse(text = str_lhs)[[1]] - flist[[i]]$resp <- resp[[i]] - } - x <- mvbf(flist = flist) - } - x -} - -#' Bind response variables in multivariate models -#' -#' Can be used to specify a multivariate \pkg{brms} model within a single -#' formula. Outside of \code{\link{brmsformula}}, it just behaves like -#' \code{\link{cbind}}. -#' -#' @param ... Same as in \code{\link{cbind}} -#' -#' @seealso \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} -#' -#' @examples -#' bf(mvbind(y1, y2) ~ x) -#' -#' @export -mvbind <- function(...) { - cbind(...) -} - -#' @rdname brmsformula-helpers -#' @export -set_rescor <- function(rescor = TRUE) { - structure(as_one_logical(rescor), class = "setrescor") -} - -allow_rescor <- function(x) { - # indicate if estimating 'rescor' is allowed for this model - if (!(is.mvbrmsformula(x) || is.mvbrmsterms(x))) { - return(FALSE) - } - parts <- if (is.mvbrmsformula(x)) x$forms else x$terms - families <- lapply(parts, "[[", "family") - has_rescor <- ulapply(families, has_rescor) - is_mixture <- ulapply(families, is.mixfamily) - family_names <- ulapply(families, "[[", "family") - all(has_rescor) && !any(is_mixture) && - length(unique(family_names)) == 1L -} - -#' @rdname brmsformula-helpers -#' @export -set_mecor <- function(mecor = TRUE) { - structure(as_one_logical(mecor), class = "setmecor") -} - -#' @export -"+.bform" <- function(e1, e2) { - if (is.brmsformula(e1)) { - out <- plus_brmsformula(e1, e2) - } else if (is.mvbrmsformula(e1)) { - out <- plus_mvbrmsformula(e1, e2) - } else { - stop2("Method '+.bform' not implemented for ", class(e1), " objects.") - } - out -} - -# internal helper function of '+.bform' -plus_brmsformula <- function(e1, e2) { - if (is.function(e2)) { - e2 <- try(e2(), silent = TRUE) - if (!is.family(e2)) { - stop2("Don't know how to handle non-family functions.") - } - } - if (is.family(e2)) { - e1 <- bf(e1, family = e2) - } else if (is.cor_brms(e2) || inherits(e2, "acformula")) { - e1 <- bf(e1, autocor = e2) - } else if (inherits(e2, "setnl")) { - dpar <- attr(e2, "dpar") - if (is.null(dpar)) { - e1 <- bf(e1, nl = e2) - } else { - if (is.null(e1$pforms[[dpar]])) { - stop2("Parameter '", dpar, "' has no formula.") - } - attr(e1$pforms[[dpar]], "nl") <- e2 - e1 <- bf(e1) - } - } else if (inherits(e2, "setmecor")) { - e1$mecor <- e2[1] - } else if (is.brmsformula(e2)) { - e1 <- mvbf(e1, e2) - } else if (inherits(e2, "setrescor")) { - stop2("Setting 'rescor' is only possible in multivariate models.") - } else if (is.ac_term(e2)) { - stop2("Autocorrelation terms can only be specified on the right-hand ", - "side of a formula, not added to a 'brmsformula' object.") - } else if (!is.null(e2)) { - e1 <- bf(e1, e2) - } - e1 -} - -# internal helper function of '+.bform' -plus_mvbrmsformula <- function(e1, e2) { - if (is.function(e2)) { - e2 <- try(e2(), silent = TRUE) - if (!is.family(e2)) { - stop2("Don't know how to handle non-family functions.") - } - } - if (is.family(e2) || is.cor_brms(e2)) { - e1$forms <- lapply(e1$forms, "+", e2) - } else if (inherits(e2, "setrescor")) { - e1$rescor <- e2[1] - } else if (inherits(e2, "setmecor")) { - e1$mecor <- e2[1] - } else if (is.brmsformula(e2)) { - e1 <- mvbf(e1, e2) - } else if (is.ac_term(e2)) { - stop2("Autocorrelation terms can only be specified on the right-hand ", - "side of a formula, not added to a 'mvbrmsformula' object.") - } else if (!is.null(e2)) { - resp <- attr(e2, "resp", TRUE) - if (is.null(resp)) { - stop2( - "Don't know how to add a ", class(e2), " object ", - "without the response variable name. ", - "See help('brmsformula-helpers') for more details." - ) - } - if (!isTRUE(resp %in% e1$responses)) { - stop2("'resp' should be one of ", collapse_comma(e1$responses), ".") - } - e1$forms[[resp]] <- e1$forms[[resp]] + e2 - } - e1 -} - -# extract the 'nl' attribute from a brmsformula object -# @param x object to extract 'nl' from -# @param dpar optional name of a distributional parameter -# for which 'nl' should be extracted -# @param resp: optional name of a response variable -# for which 'nl' should be extracted -# @param aol: (as one logical) apply isTRUE to the result? -get_nl <- function(x, dpar = NULL, resp = NULL, aol = TRUE) { - if (is.mvbrmsformula(x)) { - resp <- as_one_character(resp) - x <- x$forms[[resp]] - } - if (is.brmsformula(x)) { - if (is.null(dpar)) { - x <- x$formula - } else { - dpar <- as_one_character(dpar) - x <- x$pforms[[dpar]] - } - } - nl <- attr(x, "nl", TRUE) - if (aol) { - nl <- isTRUE(nl) - } - nl -} - -# available options for the 'decomp' argument -decomp_opts <- function() { - c("none", "QR") -} - -# validate a formula of an additional parameter -# @param formula an formula object -# @param par optional name of the parameter; if not specified -# the parameter name will be inferred from the formula -# @param rsv_pars optional character vector of reserved parameter names -# @return a named list of length one containing the formula -validate_par_formula <- function(formula, par = NULL, rsv_pars = NULL) { - stopifnot(length(par) <= 1L) - try_formula <- try(as_formula(formula), silent = TRUE) - if (is(try_formula, "try-error")) { - if (length(formula) != 1L) { - stop2("Expecting a single value when fixing parameter '", par, "'.") - } - scalar <- SW(as.numeric(formula)) - if (!is.na(scalar)) { - formula <- scalar - } else { - formula <- as.character(formula) - } - out <- named_list(par, formula) - } else { - formula <- try_formula - if (!is.null(lhs(formula))) { - resp_pars <- all.vars(formula[[2]]) - out <- named_list(resp_pars, list(formula)) - for (i in seq_along(out)) { - out[[i]][[2]] <- eval2(paste("quote(", resp_pars[i], ")")) - } - } else { - if (!isTRUE(nzchar(par))) { - stop2("Additional formulas must be named.") - } - formula <- formula(paste(par, formula2str(formula))) - out <- named_list(par, list(formula)) - } - } - pars <- names(out) - if (any(grepl("\\.|_", pars))) { - stop2("Parameter names should not contain dots or underscores.") - } - inv_pars <- intersect(pars, rsv_pars) - if (length(inv_pars)) { - stop2("The following parameter names are reserved", - "for this model:\n", collapse_comma(inv_pars)) - } - out -} - -# validate formulas dedicated to response variables -# @param x coerced to a formula object -# @param empty_ok is an empty left-hand-side ok? -# @return a formula of the form ~ 1 -validate_resp_formula <- function(x, empty_ok = TRUE) { - out <- lhs(as_formula(x)) - if (is.null(out)) { - if (empty_ok) { - out <- ~ 1 - } else { - str_x <- formula2str(x, space = "trim") - stop2("Response variable is missing in formula ", str_x) - } - } - out <- gsub("\\|+[^~]*~", "~", formula2str(out)) - out <- try(formula(out), silent = TRUE) - if (is(out, "try-error")) { - str_x <- formula2str(x, space = "trim") - stop2("Incorrect use of '|' on the left-hand side of ", str_x) - } - environment(out) <- environment(x) - out -} - -# incorporate additional arguments into the model formula -validate_formula <- function(formula, ...) { - UseMethod("validate_formula") -} - -#' @export -validate_formula.default <- function(formula, ...) { - validate_formula(bf(formula), ...) -} - -# incorporate additional arguments into the model formula -# @param formula object of class 'formula' of 'brmsformula' -# @param data optional data.frame to validate data related arguments -# @param family optional 'family' object -# @param autocor (deprecated) optional 'cor_brms' object -# @param threshold (deprecated) threshold type for ordinal models -# @param cov_ranef (deprecated) named list of group covariance matrices -# @return a brmsformula object compatible with the current version of brms -#' @export -validate_formula.brmsformula <- function( - formula, family = gaussian(), autocor = NULL, - data = NULL, threshold = NULL, sparse = NULL, - cov_ranef = NULL, ... -) { - out <- bf(formula) - if (is.null(out$family) && !is.null(family)) { - out$family <- validate_family(family) - } - # allow the '.' symbol in the formulas - out$formula <- expand_dot_formula(out$formula, data) - for (i in seq_along(out$pforms)) { - out$pforms[[i]] <- expand_dot_formula(out$pforms[[i]], data) - } - # allow 'me' terms to be correlated - out$mecor <- default_mecor(out$mecor) - if (has_cat(out) && !is.null(data)) { - # for easy access of response categories - # allow to update 'cats' with new data - out$family$cats <- extract_cat_names(out, data) - } - if (is_ordinal(out$family)) { - # thresholds and category names are data dependent - try_terms <- try(stats::terms(out$formula), silent = TRUE) - intercept <- attr(try_terms, "intercept", TRUE) - if (!is(try_terms, "try-error") && isTRUE(intercept == 0)) { - stop2("Cannot remove the intercept in an ordinal model.") - } - if (!is.null(data)) { - # for easy access of thresholds and response categories (#838) - # allow to update 'cats' and 'thres' with new data - out$family$thres <- extract_thres_names(out, data) - out$family$cats <- extract_cat_names(out, data) - } - if (is.mixfamily(out$family)) { - # every mixture family needs to know about response categories - for (i in seq_along(out$family$mix)) { - out$family$mix[[i]]$thres <- out$family$thres - } - } - } - conv_cats_dpars <- conv_cats_dpars(out$family) - if (conv_cats_dpars && !is.null(data)) { - # allow to update 'dpars' with new data - # define distributional parameters based on response categories - if (length(out$family$cats) < 2L) { - stop2("At least 2 response categories are required.") - } - if (is.null(out$family$refcat)) { - # the first level serves as the reference category - out$family$refcat <- out$family$cats[1] - } - if (isNA(out$family$refcat)) { - # implies predicting all categories - predcats <- out$family$cats - } else { - if (!out$family$refcat %in% out$family$cats) { - stop2("The reference response category must be one of ", - collapse_comma(out$family$cats), ".") - } - predcats <- setdiff(out$family$cats, out$family$refcat) - } - mu_dpars <- make_stan_names(paste0("mu", predcats)) - if (any(duplicated(mu_dpars))) { - stop2("Invalid response category names. Please avoid ", - "using any special characters in the names.") - } - old_mu_dpars <- str_subset(out$family$dpars, "^mu") - out$family$dpars <- setdiff(out$family$dpars, old_mu_dpars) - out$family$dpars <- union(mu_dpars, out$family$dpars) - } - - # incorporate deprecated arguments - require_threshold <- is_ordinal(out$family) && is.null(out$family$threshold) - if (require_threshold && !is.null(threshold)) { - # slot 'threshold' is deprecated as of brms 1.7.0 - out$family <- validate_family(out$family, threshold = threshold) - } - if (!is.null(sparse)) { - # a global 'sparse' argument is deprecated as of brms 2.8.3 - warning2( - "Argument 'sparse' should be specified within the ", - "'formula' argument. See ?brmsformula for help." - ) - sparse <- as_one_logical(sparse) - if (is.null(attr(out$formula, "sparse"))) { - attr(out$formula, "sparse") <- sparse - } - for (i in seq_along(out$pforms)) { - if (is.null(attr(out$pforms[[i]], "sparse"))) { - attr(out$pforms[[i]], "sparse") <- sparse - } - } - } - if (is.null(attr(out$formula, "autocor")) && !is.null(autocor)) { - # 'autocor' interface has been changed in brms 2.11.1 - warning2( - "Argument 'autocor' should be specified within the ", - "'formula' argument. See ?brmsformula for help." - ) - # store 'autocor' as an attribute to carry it around more easily - attr(out$formula, "autocor") <- validate_autocor(autocor) - } - if (!is.null(cov_ranef)) { - # 'cov_ranef' is deprecated as of brms 2.12.5 - out$cov_ranef <- validate_cov_ranef(cov_ranef) - } - bf(out) -} - -# incorporate additional arguments into MV model formulas -# allow passing lists of families or autocors -#' @export -validate_formula.mvbrmsformula <- function( - formula, family = NULL, autocor = NULL, cov_ranef = NULL, ... -) { - nresp <- length(formula$forms) - if (!is(family, "list")) { - family <- replicate(nresp, family, simplify = FALSE) - } else if (length(family) != nresp) { - stop2("If 'family' is a list, it has to be of the same ", - "length as the number of response variables.") - } - if (!is(autocor, "list")) { - autocor <- replicate(nresp, autocor, simplify = FALSE) - } else if (length(autocor) != nresp) { - stop2("If 'autocor' is a list, it has to be of the same ", - "length as the number of response variables.") - } - for (i in seq_len(nresp)) { - formula$forms[[i]] <- validate_formula( - formula$forms[[i]], family = family[[i]], - autocor = autocor[[i]], ... - ) - } - if (length(formula$forms) < 2L) { - stop2("Multivariate models require at least two responses.") - } - allow_rescor <- allow_rescor(formula) - if (is.null(formula$rescor)) { - # with 'mi' terms we usually don't want rescor to be estimated - miforms <- ulapply(formula$forms, function(f) - terms_ad(f$formula, f$family, FALSE)[["mi"]] - ) - formula$rescor <- allow_rescor && !length(miforms) - message("Setting 'rescor' to ", formula$rescor, " by default for this model") - if (formula$rescor) { - warning2( - "In the future, 'rescor' will be set to FALSE by default for ", - "all models. It is thus recommended to explicitely set ", - "'rescor' via 'set_rescor' instead of using the default." - ) - } - } - formula$rescor <- as_one_logical(formula$rescor) - if (formula$rescor) { - if (!allow_rescor) { - stop2("Currently, estimating 'rescor' is only possible ", - "in multivariate gaussian or student models.") - } - } - # handle default of correlations between 'me' terms - formula$mecor <- default_mecor(formula$mecor) - for (i in seq_along(formula$forms)) { - formula$forms[[i]]$mecor <- formula$mecor - } - # incorporate deprecated arguments - if (!is.null(cov_ranef)) { - # 'cov_ranef' is deprecated as of brms 2.12.5 - formula$cov_ranef <- validate_cov_ranef(cov_ranef) - } - formula -} - -# update a brmsformula and / or its attributes -# @param brmsformula object -# @param formula.: formula to update 'object' -# @param mode supports the following options: -# "update": apply update.formula -# "replace": replace old formula -# "keep": keep old formula -# attributes are always updated -# @param ... currently unused -# @return a brmsformula object -#' @export -update.brmsformula <- function(object, formula., - mode = c("update", "replace", "keep"), - ...) { - mode <- match.arg(mode) - object <- bf(object) - up_nl <- get_nl(formula., aol = FALSE) - if (is.null(up_nl)) { - up_nl <- get_nl(object) - } - # already use up_nl here to avoid ordinary parsing of NL formulas - formula. <- bf(formula., nl = up_nl) - up_family <- formula.[["family"]] - if (is.null(up_family)) { - up_family <- object[["family"]] - } - up_autocor <- attr(formula.$formula, "autocor") - if (is.null(up_autocor)) { - up_autocor <- attr(object$formula, "autocor") - } - old_form <- object$formula - up_form <- formula.$formula - if (mode == "update") { - new_form <- update(old_form, up_form, ...) - } else if (mode == "replace") { - new_form <- up_form - } else if (mode == "keep") { - new_form <- old_form - } - flist <- c(object$pforms, object$pfix, formula.$pforms, formula.$pfix) - bf(new_form, flist = flist, family = up_family, - autocor = up_autocor, nl = up_nl) -} - -#' @export -update.mvbrmsformula <- function(object, formula., ...) { - # temporary until proper updating is implemented - if (!missing(formula.)) { - stop2("Updating formulas of multivariate models is not yet possible.") - } - object -} - -#' Update Formula Addition Terms -#' -#' Update additions terms used in formulas of \pkg{brms}. See -#' \code{\link{addition-terms}} for details. -#' -#' @param formula Two-sided formula to be updated. -#' @param adform One-sided formula containing addition terms to update -#' \code{formula} with. -#' @param action Indicates what should happen to the existing addition terms in -#' \code{formula}. If \code{"update"} (the default), old addition terms that -#' have no corresponding term in \code{adform} will be kept. If -#' \code{"replace"}, all old addition terms will be removed. -#' -#' @return An object of class \code{formula}. -#' -#' @examples -#' form <- y | trials(size) ~ x -#' update_adterms(form, ~ trials(10)) -#' update_adterms(form, ~ weights(w)) -#' update_adterms(form, ~ weights(w), action = "replace") -#' update_adterms(y ~ x, ~ trials(10)) -#' -#' @export -update_adterms <- function(formula, adform, action = c("update", "replace")) { - formula <- as_formula(formula) - adform <- as_formula(adform) - action <- match.arg(action) - if (is.null(lhs(formula))) { - stop2("Can't update a ond-sided formula.") - } - str_formula <- formula2str(formula) - old_ad <- get_matches("(?<=\\|)[^~]*(?=~)", str_formula, perl = TRUE) - new_ad_terms <- attr(terms(adform), "term.labels") - if (action == "update" && length(old_ad)) { - # extract adterms from the original formula - old_ad <- formula(paste("~", old_ad)) - old_ad_terms <- attr(terms(old_ad), "term.labels") - old_adnames <- get_matches("^[^\\(]+", old_ad_terms) - old_adnames <- sub("^resp_", "", old_adnames) - new_adnames <- get_matches("^[^\\(]+", new_ad_terms) - new_adnames <- sub("^resp_", "", new_adnames) - # keep unmatched adterms of the original formula - keep <- !old_adnames %in% new_adnames - new_ad_terms <- c(old_ad_terms[keep], new_ad_terms) - } - if (length(new_ad_terms)) { - new_ad_terms <- paste(new_ad_terms, collapse = "+") - new_ad_terms <- paste("|", new_ad_terms) - } - resp <- gsub("\\|.+", "", deparse_combine(formula[[2]])) - out <- formula(paste(resp, new_ad_terms, "~1")) - out[[3]] <- formula[[3]] - attributes(out) <- attributes(formula) - out -} - -#' @export -print.brmsformula <- function(x, wsp = 0, digits = 2, ...) { - cat(formula2str(x$formula, space = "trim"), "\n") - str_wsp <- collapse(rep(" ", wsp)) - autocor <- attr(x$formula, "autocor") - if (!is.null(autocor)) { - autocor <- formula2str(autocor, rm = 1, space = "trim") - cat(paste0(str_wsp, "autocor ~ ", autocor, "\n")) - } - pforms <- x$pforms - if (length(pforms)) { - pforms <- ulapply(pforms, formula2str, space = "trim") - cat(collapse(str_wsp, pforms, "\n")) - } - pfix <- x$pfix - if (length(pfix)) { - pfix <- lapply(pfix, function(x) - ifelse(is.numeric(x), round(x, digits), x) - ) - pfix <- paste0(names(pfix), " = ", unlist(pfix)) - cat(collapse(str_wsp, pfix, "\n")) - } - invisible(x) -} - -#' @export -print.mvbrmsformula <- function(x, wsp = 0, ...) { - for (i in seq_along(x$forms)) { - if (i > 1) cat(collapse(rep(" ", wsp))) - print(x$forms[[i]], wsp = wsp, ...) - } - invisible(x) -} - -#' Checks if argument is a \code{brmsformula} object -#' -#' @param x An \R object -#' -#' @export -is.brmsformula <- function(x) { - inherits(x, "brmsformula") -} - -#' Checks if argument is a \code{mvbrmsformula} object -#' -#' @param x An \R object -#' -#' @export -is.mvbrmsformula <- function(x) { - inherits(x, "mvbrmsformula") -} - -is_nonlinear <- function(x) { - stopifnot(is.brmsfit(x)) - get_nl(bf(x$formula)) -} - -warn_dpar <- function(dpar) { - # argument 'dpar' in formula helper functions is deprecated as of 2.3.7 - if (!is.null(dpar)) { - warning2("Argument 'dpar' is no longer necessary and ignored.") - } - NULL -} - -# return the right-hand side of a formula -rhs <- function(x) { - attri <- attributes(x) - x <- as.formula(x) - x <- if (length(x) == 3) x[-2] else x - do_call(structure, c(list(x), attri)) -} - -# return the left-hand side of a formula -lhs <- function(x) { - x <- as.formula(x) - if (length(x) == 3L) update(x, . ~ 1) else NULL -} - -# convert a string to a formula -# @param x vector of strings to be converted -# @param ... passed to formula() -str2formula <- function(x, ..., collapse = "+") { - has_chars <- nzchar(x) - if (length(x) && any(has_chars)) { - out <- paste(x[has_chars], collapse = collapse) - } else { - out <- "1" - } - out <- formula(paste("~", out), ...) - environment(out) <- parent.frame() - out -} - -# convert a formula to a character string -# @param formula a model formula -# @param rm a vector of to elements indicating how many characters -# should be removed at the beginning and end of the string respectively -# @param space how should whitespaces be treated? -# option 'rm' is dangerous as it may combine different operators (#1142) -# @return a single character string or NULL -formula2str <- function(formula, rm = c(0, 0), space = c("trim", "rm")) { - if (is.null(formula)) { - return(NULL) - } - formula <- as.formula(formula) - space <- match.arg(space) - if (anyNA(rm[2])) rm[2] <- 0 - x <- Reduce(paste, deparse(formula)) - x <- gsub("[\t\r\n]+", " ", x, perl = TRUE) - if (space == "trim") { - x <- trim_wsp(x) - } else { - x <- rm_wsp(x) - } - substr(x, 1 + rm[1], nchar(x) - rm[2]) -} - -# right-hand side of a formula as a character string -str_rhs <- function(x) { - formula2str(rhs(x), rm = c(1, 0)) -} - -# left-hand side of a formula as a character string -str_lhs <- function(x) { - formula2str(lhs(x), rm = c(0, 2)) -} - -is.formula <- function(x) { - inherits(x, "formula") -} - -# wrapper around as.formula with additional checks -as_formula <- function(x) { - x <- as.formula(x) - # fixes issue #749 - rhs <- rhs(x)[[2]] - if (isTRUE(is.call(rhs) && rhs[[1]] == "~")) { - stop2("Nested formulas are not allowed. Did you use '~~' somewhere?") - } - x -} - -# expand the '.' variable in formula using stats::terms -expand_dot_formula <- function(formula, data = NULL) { - if (isTRUE("." %in% all.vars(formula))) { - att <- attributes(formula) - try_terms <- try( - stats::terms(formula, data = data), - silent = TRUE - ) - if (!is(try_terms, "try-error")) { - formula <- formula(try_terms) - } - attributes(formula) <- att - } - formula -} +#' Set up a model formula for use in \pkg{brms} +#' +#' Set up a model formula for use in the \pkg{brms} package +#' allowing to define (potentially non-linear) additive multilevel +#' models for all parameters of the assumed response distribution. +#' +#' @aliases bf +#' +#' @param formula An object of class \code{formula} +#' (or one that can be coerced to that class): +#' a symbolic description of the model to be fitted. +#' The details of model specification are given in 'Details'. +#' @param ... Additional \code{formula} objects to specify predictors of +#' non-linear and distributional parameters. Formulas can either be named +#' directly or contain names on their left-hand side. Alternatively, +#' it is possible to fix parameters to certain values by passing +#' numbers or character strings in which case arguments have to be named +#' to provide the parameter names. See 'Details' for more information. +#' @param flist Optional list of formulas, which are treated in the +#' same way as formulas passed via the \code{...} argument. +#' @param nl Logical; Indicates whether \code{formula} should be +#' treated as specifying a non-linear model. By default, \code{formula} +#' is treated as an ordinary linear model formula. +#' @param loop Logical; Only used in non-linear models. +#' Indicates if the computation of the non-linear formula should be +#' done inside (\code{TRUE}) or outside (\code{FALSE}) a loop +#' over observations. Defaults to \code{TRUE}. +#' @param center Logical; Indicates if the population-level design +#' matrix should be centered, which usually increases sampling efficiency. +#' See the 'Details' section for more information. +#' Defaults to \code{TRUE} for distributional parameters +#' and to \code{FALSE} for non-linear parameters. +#' @param cmc Logical; Indicates whether automatic cell-mean coding +#' should be enabled when removing the intercept by adding \code{0} +#' to the right-hand of model formulas. Defaults to \code{TRUE} to +#' mirror the behavior of standard \R formula parsing. +#' @param sparse Logical; indicates whether the population-level design matrices +#' should be treated as sparse (defaults to \code{FALSE}). For design matrices +#' with many zeros, this can considerably reduce required memory. Sampling +#' speed is currently not improved or even slightly decreased. +#' @param decomp Optional name of the decomposition used for the +#' population-level design matrix. Defaults to \code{NULL} that is +#' no decomposition. Other options currently available are +#' \code{"QR"} for the QR decomposition that helps in fitting models +#' with highly correlated predictors. +#' @param family Same argument as in \code{\link{brm}}. +#' If \code{family} is specified in \code{brmsformula}, it will +#' overwrite the value specified in other functions. +#' @param autocor An optional \code{formula} which contains +#' autocorrelation terms as described in \code{\link{autocor-terms}} +#' or alternatively a \code{\link{cor_brms}} object (deprecated). +#' If \code{autocor} is specified in \code{brmsformula}, it will +#' overwrite the value specified in other functions. +#' @param unused An optional \code{formula} which contains variables +#' that are unused in the model but should still be stored in the +#' model's data frame. This can be useful, for example, +#' if those variables are required for post-processing the model. +#' +#' @return An object of class \code{brmsformula}, which +#' is essentially a \code{list} containing all model +#' formulas as well as some additional information. +#' +#' @seealso \code{\link{mvbrmsformula}}, \code{\link{brmsformula-helpers}} +#' +#' @details +#' +#' \bold{General formula structure} +#' +#' The \code{formula} argument accepts formulas of the following syntax: +#' +#' \code{response | aterms ~ pterms + (gterms | group)} +#' +#' The \code{pterms} part contains effects that are assumed to be the same +#' across observations. We call them 'population-level' or 'overall' effects, +#' or (adopting frequentist vocabulary) 'fixed' effects. The optional +#' \code{gterms} part may contain effects that are assumed to vary across +#' grouping variables specified in \code{group}. We call them 'group-level' or +#' 'varying' effects, or (adopting frequentist vocabulary) 'random' effects, +#' although the latter name is misleading in a Bayesian context. For more +#' details type \code{vignette("brms_overview")} and +#' \code{vignette("brms_multilevel")}. +#' +#' \bold{Group-level terms} +#' +#' Multiple grouping factors each with multiple group-level effects are +#' possible. (Of course we can also run models without any group-level +#' effects.) Instead of \code{|} you may use \code{||} in grouping terms to +#' prevent correlations from being modeled. Equivalently, the \code{cor} +#' argument of the \code{\link{gr}} function can be used for this purpose, +#' for example, \code{(1 + x || g)} is equivalent to +#' \code{(1 + x | gr(g, cor = FALSE))}. +#' +#' It is also possible to model different group-level terms of the same +#' grouping factor as correlated (even across different formulas, e.g., in +#' non-linear models) by using \code{||} instead of \code{|}. All +#' group-level terms sharing the same ID will be modeled as correlated. If, +#' for instance, one specifies the terms \code{(1+x|i|g)} and \code{(1+z|i|g)} +#' somewhere in the formulas passed to \code{brmsformula}, correlations +#' between the corresponding group-level effects will be estimated. In the +#' above example, \code{i} is not a variable in the data but just a symbol to +#' indicate correlations between multiple group-level terms. Equivalently, the +#' \code{id} argument of the \code{\link{gr}} function can be used as well, +#' for example, \code{(1 + x | gr(g, id = "i"))}. +#' +#' If levels of the grouping factor belong to different sub-populations, +#' it may be reasonable to assume a different covariance matrix for each +#' of the sub-populations. For instance, the variation within the +#' treatment group and within the control group in a randomized control +#' trial might differ. Suppose that \code{y} is the outcome, and +#' \code{x} is the factor indicating the treatment and control group. +#' Then, we could estimate different hyper-parameters of the varying +#' effects (in this case a varying intercept) for treatment and control +#' group via \code{y ~ x + (1 | gr(subject, by = x))}. +#' +#' You can specify multi-membership terms using the \code{\link{mm}} +#' function. For instance, a multi-membership term with two members +#' could be \code{(1 | mm(g1, g2))}, where \code{g1} and \code{g2} +#' specify the first and second member, respectively. Moreover, +#' if a covariate \code{x} varies across the levels of the grouping-factors +#' \code{g1} and \code{g2}, we can save the respective covariate values +#' in the variables \code{x1} and \code{x2} and then model the varying +#' effect as \code{(1 + mmc(x1, x2) | mm(g1, g2))}. +#' +#' \bold{Special predictor terms} +#' +#' Flexible non-linear smooth terms can modeled using the \code{\link{s}} +#' and \code{\link{t2}} functions in the \code{pterms} part +#' of the model formula. This allows to fit generalized additive mixed +#' models (GAMMs) with \pkg{brms}. The implementation is similar to that +#' used in the \pkg{gamm4} package. For more details on this model class +#' see \code{\link[mgcv:gam]{gam}} and \code{\link[mgcv:gamm]{gamm}}. +#' +#' Gaussian process terms can be fitted using the \code{\link{gp}} +#' function in the \code{pterms} part of the model formula. Similar to +#' smooth terms, Gaussian processes can be used to model complex non-linear +#' relationships, for instance temporal or spatial autocorrelation. +#' However, they are computationally demanding and are thus not recommended +#' for very large datasets or approximations need to be used. +#' +#' The \code{pterms} and \code{gterms} parts may contain four non-standard +#' effect types namely monotonic, measurement error, missing value, and +#' category specific effects, which can be specified using terms of the +#' form \code{mo(predictor)}, \code{me(predictor, sd_predictor)}, +#' \code{mi(predictor)}, and \code{cs()}, respectively. +#' Category specific effects can only be estimated in +#' ordinal models and are explained in more detail in the package's +#' main vignette (type \code{vignette("brms_overview")}). +#' The other three effect types are explained in the following. +#' +#' A monotonic predictor must either be integer valued or an ordered factor, +#' which is the first difference to an ordinary continuous predictor. +#' More importantly, predictor categories (or integers) are not assumed to be +#' equidistant with respect to their effect on the response variable. +#' Instead, the distance between adjacent predictor categories (or integers) +#' is estimated from the data and may vary across categories. +#' This is realized by parameterizing as follows: +#' One parameter takes care of the direction and size of the effect similar +#' to an ordinary regression parameter, while an additional parameter vector +#' estimates the normalized distances between consecutive predictor categories. +#' A main application of monotonic effects are ordinal predictors that +#' can this way be modeled without (falsely) treating them as continuous +#' or as unordered categorical predictors. For more details and examples +#' see \code{vignette("brms_monotonic")}. +#' +#' Quite often, predictors are measured and as such naturally contain +#' measurement error. Although most researchers are well aware of this problem, +#' measurement error in predictors is ignored in most +#' regression analyses, possibly because only few packages allow +#' for modeling it. Notably, measurement error can be handled in +#' structural equation models, but many more general regression models +#' (such as those featured by \pkg{brms}) cannot be transferred +#' to the SEM framework. In \pkg{brms}, effects of noise-free predictors +#' can be modeled using the \code{me} (for 'measurement error') function. +#' If, say, \code{y} is the response variable and +#' \code{x} is a measured predictor with known measurement error +#' \code{sdx}, we can simply include it on the right-hand side of the +#' model formula via \code{y ~ me(x, sdx)}. +#' This can easily be extended to more general formulas. +#' If \code{x2} is another measured predictor with corresponding error +#' \code{sdx2} and \code{z} is a predictor without error +#' (e.g., an experimental setting), we can model all main effects +#' and interactions of the three predictors in the well known manner: +#' \code{y ~ me(x, sdx) * me(x2, sdx2) * z}. +#' The \code{me} function is soft deprecated in favor of the more flexible +#' and consistent \code{mi} function (see below). +#' +#' When a variable contains missing values, the corresponding rows will +#' be excluded from the data by default (row-wise exclusion). However, +#' quite often we want to keep these rows and instead estimate the missing values. +#' There are two approaches for this: (a) Impute missing values before +#' the model fitting for instance via multiple imputation (see +#' \code{\link{brm_multiple}} for a way to handle multiple imputed datasets). +#' (b) Impute missing values on the fly during model fitting. The latter +#' approach is explained in the following. Using a variable with missing +#' values as predictors requires two things, First, we need to specify that +#' the predictor contains missings that should to be imputed. +#' If, say, \code{y} is the primary response, \code{x} is a +#' predictor with missings and \code{z} is a predictor without missings, +#' we go for \code{y ~ mi(x) + z}. Second, we need to model \code{x} +#' as an additional response with corresponding predictors and the +#' addition term \code{mi()}. In our example, we could write +#' \code{x | mi() ~ z}. Measurement error may be included via +#' the \code{sdy} argument, say, \code{x | mi(sdy = se) ~ z}. +#' See \code{\link{mi}} for examples with real data. +#' +#' +#' \bold{Autocorrelation terms} +#' +#' Autocorrelation terms can be directly specified inside the \code{pterms} +#' part as well. Details can be found in \code{\link{autocor-terms}}. +#' +#' \bold{Additional response information} +#' +#' Another special of the \pkg{brms} formula syntax is the optional +#' \code{aterms} part, which may contain multiple terms of the form +#' \code{fun()} separated by \code{+} each providing special +#' information on the response variable. \code{fun} can be replaced with +#' either \code{se}, \code{weights}, \code{subset}, \code{cens}, \code{trunc}, +#' \code{trials}, \code{cat}, \code{dec}, \code{rate}, \code{vreal}, or +#' \code{vint}. Their meanings are explained below +#' (see also \code{\link{addition-terms}}). +#' +#' For families \code{gaussian}, \code{student} and \code{skew_normal}, it is +#' possible to specify standard errors of the observations, thus allowing +#' to perform meta-analysis. Suppose that the variable \code{yi} contains +#' the effect sizes from the studies and \code{sei} the corresponding +#' standard errors. Then, fixed and random effects meta-analyses can +#' be conducted using the formulas \code{yi | se(sei) ~ 1} and +#' \code{yi | se(sei) ~ 1 + (1|study)}, respectively, where +#' \code{study} is a variable uniquely identifying every study. +#' If desired, meta-regression can be performed via +#' \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1|study)} +#' or \cr \code{yi | se(sei) ~ 1 + mod1 + mod2 + (1 + mod1 + mod2|study)}, +#' where \code{mod1} and \code{mod2} represent moderator variables. +#' By default, the standard errors replace the parameter \code{sigma}. +#' To model \code{sigma} in addition to the known standard errors, +#' set argument \code{sigma} in function \code{se} to \code{TRUE}, +#' for instance, \code{yi | se(sei, sigma = TRUE) ~ 1}. +#' +#' For all families, weighted regression may be performed using +#' \code{weights} in the \code{aterms} part. Internally, this is +#' implemented by multiplying the log-posterior values of each +#' observation by their corresponding weights. +#' Suppose that variable \code{wei} contains the weights +#' and that \code{yi} is the response variable. +#' Then, formula \code{yi | weights(wei) ~ predictors} +#' implements a weighted regression. +#' +#' For multivariate models, \code{subset} may be used in the \code{aterms} +#' part, to use different subsets of the data in different univariate +#' models. For instance, if \code{sub} is a logical variable and +#' \code{y} is the response of one of the univariate models, we may +#' write \code{y | subset(sub) ~ predictors} so that \code{y} is +#' predicted only for those observations for which \code{sub} evaluates +#' to \code{TRUE}. +#' +#' For log-linear models such as poisson models, \code{rate} may be used +#' in the \code{aterms} part to specify the denominator of a response that +#' is expressed as a rate. The numerator is given by the actual response +#' variable and has a distribution according to the family as usual. Using +#' \code{rate(denom)} is equivalent to adding \code{offset(log(denom))} to +#' the linear predictor of the main parameter but the former is arguably +#' more convenient and explicit. +#' +#' With the exception of categorical and ordinal families, +#' left, right, and interval censoring can be modeled through +#' \code{y | cens(censored) ~ predictors}. The censoring variable +#' (named \code{censored} in this example) should contain the values +#' \code{'left'}, \code{'none'}, \code{'right'}, and \code{'interval'} +#' (or equivalently \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate that +#' the corresponding observation is left censored, not censored, right censored, +#' or interval censored. For interval censored data, a second variable +#' (let's call it \code{y2}) has to be passed to \code{cens}. In this case, +#' the formula has the structure \code{y | cens(censored, y2) ~ predictors}. +#' While the lower bounds are given in \code{y}, the upper bounds are given +#' in \code{y2} for interval censored data. Intervals are assumed to be open +#' on the left and closed on the right: \code{(y, y2]}. +#' +#' With the exception of categorical and ordinal families, +#' the response distribution can be truncated using the \code{trunc} +#' function in the addition part. If the response variable is truncated +#' between, say, 0 and 100, we can specify this via +#' \code{yi | trunc(lb = 0, ub = 100) ~ predictors}. +#' Instead of numbers, variables in the data set can also be passed allowing +#' for varying truncation points across observations. Defining only one of +#' the two arguments in \code{trunc} leads to one-sided truncation. +#' +#' For all continuous families, missing values in the responses can be imputed +#' within Stan by using the addition term \code{mi}. This is mostly +#' useful in combination with \code{mi} predictor terms as explained +#' above under 'Special predictor terms'. +#' +#' For families \code{binomial} and \code{zero_inflated_binomial}, +#' addition should contain a variable indicating the number of trials +#' underlying each observation. In \code{lme4} syntax, we may write for instance +#' \code{cbind(success, n - success)}, which is equivalent +#' to \code{success | trials(n)} in \pkg{brms} syntax. If the number of trials +#' is constant across all observations, say \code{10}, +#' we may also write \code{success | trials(10)}. +#' \bold{Please note that the \code{cbind()} syntax will not work +#' in \pkg{brms} in the expected way because this syntax is reserved +#' for other purposes.} +#' +#' For all ordinal families, \code{aterms} may contain a term +#' \code{thres(number)} to specify the number thresholds (e.g, +#' \code{thres(6)}), which should be equal to the total number of response +#' categories - 1. If not given, the number of thresholds is calculated from +#' the data. If different threshold vectors should be used for different +#' subsets of the data, the \code{gr} argument can be used to provide the +#' grouping variable (e.g, \code{thres(6, gr = item)}, if \code{item} is the +#' grouping variable). In this case, the number of thresholds can also be a +#' variable in the data with different values per group. +#' +#' A deprecated quasi alias of \code{thres()} is \code{cat()} with which the +#' total number of response categories (i.e., number of thresholds + 1) can be +#' specified. +#' +#' In Wiener diffusion models (family \code{wiener}) the addition term +#' \code{dec} is mandatory to specify the (vector of) binary decisions +#' corresponding to the reaction times. Non-zero values will be treated +#' as a response on the upper boundary of the diffusion process and zeros +#' will be treated as a response on the lower boundary. Alternatively, +#' the variable passed to \code{dec} might also be a character vector +#' consisting of \code{'lower'} and \code{'upper'}. +#' +#' All families support the \code{index} addition term to uniquely identify +#' each observation of the corresponding response variable. Currently, +#' \code{index} is primarily useful in combination with the \code{subset} +#' addition and \code{\link{mi}} terms. +#' +#' For custom families, it is possible to pass an arbitrary number of real and +#' integer vectors via the addition terms \code{vreal} and \code{vint}, +#' respectively. An example is provided in +#' \code{vignette('brms_customfamilies')}. To pass multiple vectors of the +#' same data type, provide them separated by commas inside a single +#' \code{vreal} or \code{vint} statement. +#' +#' Multiple addition terms of different types may be specified at the same +#' time using the \code{+} operator. For example, the formula +#' \code{formula = yi | se(sei) + cens(censored) ~ 1} implies a censored +#' meta-analytic model. +#' +#' The addition argument \code{disp} (short for dispersion) +#' has been removed in version 2.0. You may instead use the +#' distributional regression approach by specifying +#' \code{sigma ~ 1 + offset(log(xdisp))} or +#' \code{shape ~ 1 + offset(log(xdisp))}, where \code{xdisp} is +#' the variable being previously passed to \code{disp}. +#' +#' \bold{Parameterization of the population-level intercept} +#' +#' By default, the population-level intercept (if incorporated) is estimated +#' separately and not as part of population-level parameter vector \code{b} As +#' a result, priors on the intercept also have to be specified separately. +#' Furthermore, to increase sampling efficiency, the population-level design +#' matrix \code{X} is centered around its column means \code{X_means} if the +#' intercept is incorporated. This leads to a temporary bias in the intercept +#' equal to \code{}, where \code{<,>} is the scalar product. The +#' bias is corrected after fitting the model, but be aware that you are +#' effectively defining a prior on the intercept of the centered design matrix +#' not on the real intercept. You can turn off this special handling of the +#' intercept by setting argument \code{center} to \code{FALSE}. For more +#' details on setting priors on population-level intercepts, see +#' \code{\link{set_prior}}. +#' +#' This behavior can be avoided by using the reserved +#' (and internally generated) variable \code{Intercept}. +#' Instead of \code{y ~ x}, you may write +#' \code{y ~ 0 + Intercept + x}. This way, priors can be +#' defined on the real intercept, directly. In addition, +#' the intercept is just treated as an ordinary population-level effect +#' and thus priors defined on \code{b} will also apply to it. +#' Note that this parameterization may be less efficient +#' than the default parameterization discussed above. +#' +#' \bold{Formula syntax for non-linear models} +#' +#' In \pkg{brms}, it is possible to specify non-linear models +#' of arbitrary complexity. +#' The non-linear model can just be specified within the \code{formula} +#' argument. Suppose, that we want to predict the response \code{y} +#' through the predictor \code{x}, where \code{x} is linked to \code{y} +#' through \code{y = alpha - beta * lambda^x}, with parameters +#' \code{alpha}, \code{beta}, and \code{lambda}. This is certainly a +#' non-linear model being defined via +#' \code{formula = y ~ alpha - beta * lambda^x} (addition arguments +#' can be added in the same way as for ordinary formulas). +#' To tell \pkg{brms} that this is a non-linear model, +#' we set argument \code{nl} to \code{TRUE}. +#' Now we have to specify a model for each of the non-linear parameters. +#' Let's say we just want to estimate those three parameters +#' with no further covariates or random effects. Then we can pass +#' \code{alpha + beta + lambda ~ 1} or equivalently +#' (and more flexible) \code{alpha ~ 1, beta ~ 1, lambda ~ 1} +#' to the \code{...} argument. +#' This can, of course, be extended. If we have another predictor \code{z} and +#' observations nested within the grouping factor \code{g}, we may write for +#' instance \code{alpha ~ 1, beta ~ 1 + z + (1|g), lambda ~ 1}. +#' The formula syntax described above applies here as well. +#' In this example, we are using \code{z} and \code{g} only for the +#' prediction of \code{beta}, but we might also use them for the other +#' non-linear parameters (provided that the resulting model is still +#' scientifically reasonable). +#' +#' By default, non-linear covariates are treated as real vectors in Stan. +#' However, if the data of the covariates is of type `integer` in \R (which +#' can be enforced by the `as.integer` function), the Stan type will be +#' changed to an integer array. That way, covariates can also be used +#' for indexing purposes in Stan. +#' +#' Non-linear models may not be uniquely identified and / or show bad convergence. +#' For this reason it is mandatory to specify priors on the non-linear parameters. +#' For instructions on how to do that, see \code{\link{set_prior}}. +#' For some examples of non-linear models, see \code{vignette("brms_nonlinear")}. +#' +#' \bold{Formula syntax for predicting distributional parameters} +#' +#' It is also possible to predict parameters of the response distribution such +#' as the residual standard deviation \code{sigma} in gaussian models or the +#' hurdle probability \code{hu} in hurdle models. The syntax closely resembles +#' that of a non-linear parameter, for instance \code{sigma ~ x + s(z) + +#' (1+x|g)}. For some examples of distributional models, see +#' \code{vignette("brms_distreg")}. +#' +#' Parameter \code{mu} exists for every family and can be used as an +#' alternative to specifying terms in \code{formula}. If both \code{mu} and +#' \code{formula} are given, the right-hand side of \code{formula} is ignored. +#' Accordingly, specifying terms on the right-hand side of both \code{formula} +#' and \code{mu} at the same time is deprecated. In future versions, +#' \code{formula} might be updated by \code{mu}. +#' +#' The following are +#' distributional parameters of specific families (all other parameters are +#' treated as non-linear parameters): \code{sigma} (residual standard +#' deviation or scale of the \code{gaussian}, \code{student}, +#' \code{skew_normal}, \code{lognormal} \code{exgaussian}, and +#' \code{asym_laplace} families); \code{shape} (shape parameter of the +#' \code{Gamma}, \code{weibull}, \code{negbinomial}, and related zero-inflated +#' / hurdle families); \code{nu} (degrees of freedom parameter of the +#' \code{student} and \code{frechet} families); \code{phi} (precision +#' parameter of the \code{beta} and \code{zero_inflated_beta} families); +#' \code{kappa} (precision parameter of the \code{von_mises} family); +#' \code{beta} (mean parameter of the exponential component of the +#' \code{exgaussian} family); \code{quantile} (quantile parameter of the +#' \code{asym_laplace} family); \code{zi} (zero-inflation probability); +#' \code{hu} (hurdle probability); \code{zoi} (zero-one-inflation +#' probability); \code{coi} (conditional one-inflation probability); +#' \code{disc} (discrimination) for ordinal models; \code{bs}, \code{ndt}, and +#' \code{bias} (boundary separation, non-decision time, and initial bias of +#' the \code{wiener} diffusion model). By default, distributional parameters +#' are modeled on the log scale if they can be positive only or on the logit +#' scale if the can only be within the unit interval. +#' +#' Alternatively, one may fix distributional parameters to certain values. +#' However, this is mainly useful when models become too +#' complicated and otherwise have convergence issues. +#' We thus suggest to be generally careful when making use of this option. +#' The \code{quantile} parameter of the \code{asym_laplace} distribution +#' is a good example where it is useful. By fixing \code{quantile}, +#' one can perform quantile regression for the specified quantile. +#' For instance, \code{quantile = 0.25} allows predicting the 25\%-quantile. +#' Furthermore, the \code{bias} parameter in drift-diffusion models, +#' is assumed to be \code{0.5} (i.e. no bias) in many applications. +#' To achieve this, simply write \code{bias = 0.5}. +#' Other possible applications are the Cauchy distribution as a +#' special case of the Student-t distribution with +#' \code{nu = 1}, or the geometric distribution as a special case of +#' the negative binomial distribution with \code{shape = 1}. +#' Furthermore, the parameter \code{disc} ('discrimination') in ordinal +#' models is fixed to \code{1} by default and not estimated, +#' but may be modeled as any other distributional parameter if desired +#' (see examples). For reasons of identification, \code{'disc'} +#' can only be positive, which is achieved by applying the log-link. +#' +#' In categorical models, distributional parameters do not have +#' fixed names. Instead, they are named after the response categories +#' (excluding the first one, which serves as the reference category), +#' with the prefix \code{'mu'}. If, for instance, categories are named +#' \code{cat1}, \code{cat2}, and \code{cat3}, the distributional parameters +#' will be named \code{mucat2} and \code{mucat3}. +#' +#' Some distributional parameters currently supported by \code{brmsformula} +#' have to be positive (a negative standard deviation or precision parameter +#' does not make any sense) or are bounded between 0 and 1 (for zero-inflated / +#' hurdle probabilities, quantiles, or the initial bias parameter of +#' drift-diffusion models). +#' However, linear predictors can be positive or negative, and thus the log link +#' (for positive parameters) or logit link (for probability parameters) are used +#' by default to ensure that distributional parameters are within their valid intervals. +#' This implies that, by default, effects for such distributional parameters are +#' estimated on the log / logit scale and one has to apply the inverse link +#' function to get to the effects on the original scale. +#' Alternatively, it is possible to use the identity link to predict parameters +#' on their original scale, directly. However, this is much more likely to lead +#' to problems in the model fitting, if the parameter actually has a restricted range. +#' +#' See also \code{\link{brmsfamily}} for an overview of valid link functions. +#' +#' \bold{Formula syntax for mixture models} +#' +#' The specification of mixture models closely resembles that +#' of non-mixture models. If not specified otherwise (see below), +#' all mean parameters of the mixture components are predicted +#' using the right-hand side of \code{formula}. All types of predictor +#' terms allowed in non-mixture models are allowed in mixture models +#' as well. +#' +#' Distributional parameters of mixture distributions have the same +#' name as those of the corresponding ordinary distributions, but with +#' a number at the end to indicate the mixture component. For instance, if +#' you use family \code{mixture(gaussian, gaussian)}, the distributional +#' parameters are \code{sigma1} and \code{sigma2}. +#' Distributional parameters of the same class can be fixed to the same value. +#' For the above example, we could write \code{sigma2 = "sigma1"} to make +#' sure that both components have the same residual standard deviation, +#' which is in turn estimated from the data. +#' +#' In addition, there are two types of special distributional parameters. +#' The first are named \code{mu}, that allow for modeling different +#' predictors for the mean parameters of different mixture components. +#' For instance, if you want to predict the mean of the first component +#' using predictor \code{x} and the mean of the second component using +#' predictor \code{z}, you can write \code{mu1 ~ x} as well as \code{mu2 ~ z}. +#' The second are named \code{theta}, which constitute the mixing +#' proportions. If the mixing proportions are fixed to certain values, +#' they are internally normalized to form a probability vector. +#' If one seeks to predict the mixing proportions, all but +#' one of the them has to be predicted, while the remaining one is used +#' as the reference category to identify the model. The \code{softmax} +#' function is applied on the linear predictor terms to form a +#' probability vector. +#' +#' For more information on mixture models, see +#' the documentation of \code{\link{mixture}}. +#' +#' \bold{Formula syntax for multivariate models} +#' +#' Multivariate models may be specified using \code{mvbind} notation +#' or with help of the \code{\link{mvbf}} function. +#' Suppose that \code{y1} and \code{y2} are response variables +#' and \code{x} is a predictor. Then \code{mvbind(y1, y2) ~ x} +#' specifies a multivariate model. +#' The effects of all terms specified at the RHS of the formula +#' are assumed to vary across response variables. +#' For instance, two parameters will be estimated for \code{x}, +#' one for the effect on \code{y1} and another for the effect on \code{y2}. +#' This is also true for group-level effects. When writing, for instance, +#' \code{mvbind(y1, y2) ~ x + (1+x|g)}, group-level effects will be +#' estimated separately for each response. To model these effects +#' as correlated across responses, use the ID syntax (see above). +#' For the present example, this would look as follows: +#' \code{mvbind(y1, y2) ~ x + (1+x|2|g)}. Of course, you could also use +#' any value other than \code{2} as ID. +#' +#' It is also possible to specify different formulas for different responses. +#' If, for instance, \code{y1} should be predicted by \code{x} and \code{y2} +#' should be predicted by \code{z}, we could write \code{mvbf(y1 ~ x, y2 ~ z)}. +#' Alternatively, multiple \code{brmsformula} objects can be added to +#' specify a joint multivariate model (see 'Examples'). +#' +#' @examples +#' # multilevel model with smoothing terms +#' brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2)) +#' +#' # additionally predict 'sigma' +#' brmsformula(y ~ x1*x2 + s(z) + (1+x1|1) + (1|g2), +#' sigma ~ x1 + (1|g2)) +#' +#' # use the shorter alias 'bf' +#' (formula1 <- brmsformula(y ~ x + (x|g))) +#' (formula2 <- bf(y ~ x + (x|g))) +#' # will be TRUE +#' identical(formula1, formula2) +#' +#' # incorporate censoring +#' bf(y | cens(censor_variable) ~ predictors) +#' +#' # define a simple non-linear model +#' bf(y ~ a1 - a2^x, a1 + a2 ~ 1, nl = TRUE) +#' +#' # predict a1 and a2 differently +#' bf(y ~ a1 - a2^x, a1 ~ 1, a2 ~ x + (x|g), nl = TRUE) +#' +#' # correlated group-level effects across parameters +#' bf(y ~ a1 - a2^x, a1 ~ 1 + (1 |2| g), a2 ~ x + (x |2| g), nl = TRUE) +#' # alternative but equivalent way to specify the above model +#' bf(y ~ a1 - a2^x, a1 ~ 1 + (1 | gr(g, id = 2)), +#' a2 ~ x + (x | gr(g, id = 2)), nl = TRUE) +#' +#' # define a multivariate model +#' bf(mvbind(y1, y2) ~ x * z + (1|g)) +#' +#' # define a zero-inflated model +#' # also predicting the zero-inflation part +#' bf(y ~ x * z + (1+x|ID1|g), zi ~ x + (1|ID1|g)) +#' +#' # specify a predictor as monotonic +#' bf(y ~ mo(x) + more_predictors) +#' +#' # for ordinal models only +#' # specify a predictor as category specific +#' bf(y ~ cs(x) + more_predictors) +#' # add a category specific group-level intercept +#' bf(y ~ cs(x) + (cs(1)|g)) +#' # specify parameter 'disc' +#' bf(y ~ person + item, disc ~ item) +#' +#' # specify variables containing measurement error +#' bf(y ~ me(x, sdx)) +#' +#' # specify predictors on all parameters of the wiener diffusion model +#' # the main formula models the drift rate 'delta' +#' bf(rt | dec(decision) ~ x, bs ~ x, ndt ~ x, bias ~ x) +#' +#' # fix the bias parameter to 0.5 +#' bf(rt | dec(decision) ~ x, bias = 0.5) +#' +#' # specify different predictors for different mixture components +#' mix <- mixture(gaussian, gaussian) +#' bf(y ~ 1, mu1 ~ x, mu2 ~ z, family = mix) +#' +#' # fix both residual standard deviations to the same value +#' bf(y ~ x, sigma2 = "sigma1", family = mix) +#' +#' # use the '+' operator to specify models +#' bf(y ~ 1) + +#' nlf(sigma ~ a * exp(b * x), a ~ x) + +#' lf(b ~ z + (1|g), dpar = "sigma") + +#' gaussian() +#' +#' # specify a multivariate model using the '+' operator +#' bf(y1 ~ x + (1|g)) + +#' gaussian() + cor_ar(~1|g) + +#' bf(y2 ~ z) + poisson() +#' +#' # specify correlated residuals of a gaussian and a poisson model +#' form1 <- bf(y1 ~ 1 + x + (1|c|obs), sigma = 1) + gaussian() +#' form2 <- bf(y2 ~ 1 + x + (1|c|obs)) + poisson() +#' +#' # model missing values in predictors +#' bf(bmi ~ age * mi(chl)) + +#' bf(chl | mi() ~ age) + +#' set_rescor(FALSE) +#' +#' # model sigma as a function of the mean +#' bf(y ~ eta, nl = TRUE) + +#' lf(eta ~ 1 + x) + +#' nlf(sigma ~ tau * sqrt(eta)) + +#' lf(tau ~ 1) +#' +#' @export +brmsformula <- function(formula, ..., flist = NULL, family = NULL, + autocor = NULL, nl = NULL, loop = NULL, + center = NULL, cmc = NULL, sparse = NULL, + decomp = NULL, unused = NULL) { + if (is.brmsformula(formula)) { + out <- formula + } else { + out <- list(formula = as_formula(formula)) + class(out) <- "brmsformula" + } + # parse and validate dots arguments + dots <- c(out$pforms, out$pfix, list(...), flist) + dots <- lapply(dots, function(x) if (is.list(x)) x else list(x)) + dots <- unlist(dots, recursive = FALSE) + forms <- list() + for (i in seq_along(dots)) { + c(forms) <- validate_par_formula(dots[[i]], par = names(dots)[i]) + } + is_dupl_pars <- duplicated(names(forms), fromLast = TRUE) + if (any(is_dupl_pars)) { + dupl_pars <- collapse_comma(names(forms)[is_dupl_pars]) + message("Replacing initial definitions of parameters ", dupl_pars) + forms[is_dupl_pars] <- NULL + } + not_form <- ulapply(forms, function(x) !is.formula(x)) + fix <- forms[not_form] + forms[names(fix)] <- NULL + out$pforms <- forms + # validate fixed distributional parameters + fix_theta <- fix[dpar_class(names(fix)) %in% "theta"] + if (length(fix_theta)) { + # normalize mixing proportions + sum_theta <- sum(unlist(fix_theta)) + fix_theta <- lapply(fix_theta, "/", sum_theta) + fix[names(fix_theta)] <- fix_theta + } + out$pfix <- fix + for (dp in names(out$pfix)) { + if (is.character(out$pfix[[dp]])) { + if (identical(dp, out$pfix[[dp]])) { + stop2("Equating '", dp, "' with itself is not meaningful.") + } + ap_class <- dpar_class(dp) + if (ap_class == "mu") { + stop2("Equating parameters of class 'mu' is not allowed.") + } + if (!identical(ap_class, dpar_class(out$pfix[[dp]]))) { + stop2("Can only equate parameters of the same class.") + } + if (out$pfix[[dp]] %in% names(out$pfix)) { + stop2("Cannot use fixed parameters on ", + "the right-hand side of an equation.") + } + if (out$pfix[[dp]] %in% names(out$pforms)) { + stop2("Cannot use predicted parameters on ", + "the right-hand side of an equation.") + } + } + } + if (!is.null(nl)) { + attr(out$formula, "nl") <- as_one_logical(nl) + } else if (!is.null(out[["nl"]])) { + # for backwards compatibility with brms <= 1.8.0 + attr(out$formula, "nl") <- out[["nl"]] + out[["nl"]] <- NULL + } + if (is.null(attr(out$formula, "nl"))) { + attr(out$formula, "nl") <- FALSE + } + if (!is.null(loop)) { + attr(out$formula, "loop") <- as_one_logical(loop) + } + if (is.null(attr(out$formula, "loop"))) { + attr(out$formula, "loop") <- TRUE + } + if (!is.null(center)) { + attr(out$formula, "center") <- as_one_logical(center) + } + if (!is.null(cmc)) { + attr(out$formula, "cmc") <- as_one_logical(cmc) + } + if (!is.null(sparse)) { + attr(out$formula, "sparse") <- as_one_logical(sparse) + } + if (!is.null(decomp)) { + attr(out$formula, "decomp") <- match.arg(decomp, decomp_opts()) + } + if (!is.null(unused)) { + attr(out$formula, "unused") <- as.formula(unused) + } + if (!is.null(autocor)) { + attr(out$formula, "autocor") <- validate_autocor(autocor) + } else if (!is.null(out$autocor)) { + # for backwards compatibility with brms <= 2.11.0 + attr(out$formula, "autocor") <- validate_autocor(out$autocor) + out$autocor <- NULL + } + if (!is.null(family)) { + out$family <- validate_family(family) + } + if (!is.null(lhs(formula))) { + out$resp <- terms_resp(formula) + } + # add default values for unspecified elements + defs <- list(pforms = list(), pfix = list(), family = NULL, resp = NULL) + defs <- defs[setdiff(names(defs), names(rmNULL(out, FALSE)))] + out[names(defs)] <- defs + class(out) <- c("brmsformula", "bform") + split_bf(out) +} + +# alias of brmsformula +#' @export +bf <- function(formula, ..., flist = NULL, family = NULL, autocor = NULL, + nl = NULL, loop = NULL, center = NULL, cmc = NULL, + sparse = NULL, decomp = NULL) { + brmsformula( + formula, ..., flist = flist, family = family, autocor = autocor, + nl = nl, loop = loop, center = center, cmc = cmc, sparse = sparse, + decomp = decomp + ) +} + +#' Linear and Non-linear formulas in \pkg{brms} +#' +#' Helper functions to specify linear and non-linear +#' formulas for use with \code{\link[brms:brmsformula]{brmsformula}}. +#' +#' @name brmsformula-helpers +#' @aliases bf-helpers nlf lf set_nl set_rescor +#' +#' @param formula Non-linear formula for a distributional parameter. +#' The name of the distributional parameter can either be specified +#' on the left-hand side of \code{formula} or via argument \code{dpar}. +#' @param dpar Optional character string specifying the distributional +#' parameter to which the formulas passed via \code{...} and +#' \code{flist} belong. +#' @param resp Optional character string specifying the response +#' variable to which the formulas passed via \code{...} and +#' \code{flist} belong. Only relevant in multivariate models. +#' @param autocor A one sided formula containing autocorrelation +#' terms. All none autocorrelation terms in \code{autocor} will +#' be silently ignored. +#' @param rescor Logical; Indicates if residual correlation between +#' the response variables should be modeled. Currently this is only +#' possible in multivariate \code{gaussian} and \code{student} models. +#' Only relevant in multivariate models. +#' @param mecor Logical; Indicates if correlations between latent variables +#' defined by \code{\link{me}} terms should be modeled. Defaults to \code{TRUE}. +#' @inheritParams brmsformula +#' +#' @return For \code{lf} and \code{nlf} a \code{list} that can be +#' passed to \code{\link[brms:brmsformula]{brmsformula}} or added +#' to an existing \code{brmsformula} or \code{mvbrmsformula} object. +#' For \code{set_nl} and \code{set_rescor} a logical value that can be +#' added to an existing \code{brmsformula} or \code{mvbrmsformula} object. +#' +#' @seealso \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} +#' +#' @examples +#' # add more formulas to the model +#' bf(y ~ 1) + +#' nlf(sigma ~ a * exp(b * x)) + +#' lf(a ~ x, b ~ z + (1|g)) + +#' gaussian() +#' +#' # specify 'nl' later on +#' bf(y ~ a * inv_logit(x * b)) + +#' lf(a + b ~ z) + +#' set_nl(TRUE) +#' +#' # specify a multivariate model +#' bf(y1 ~ x + (1|g)) + +#' bf(y2 ~ z) + +#' set_rescor(TRUE) +#' +#' # add autocorrelation terms +#' bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(W)) +NULL + +#' @rdname brmsformula-helpers +#' @export +nlf <- function(formula, ..., flist = NULL, dpar = NULL, + resp = NULL, loop = NULL) { + formula <- as_formula(formula) + if (is.null(lhs(formula))) { + stop2("Argument 'formula' must be two-sided.") + } + if (length(c(list(...), flist))) { + warning2( + "Arguments '...' and 'flist' in nlf() will be reworked ", + "at some point. Please avoid using them if possible." + ) + } + warn_dpar(dpar) + if (!is.null(resp)) { + resp <- as_one_character(resp) + } + if (!is.null(loop)) { + attr(formula, "loop") <- as_one_logical(loop) + } + if (is.null(attr(formula, "loop"))) { + attr(formula, "loop") <- TRUE + } + out <- c( + list(structure(formula, nl = TRUE)), + lf(..., flist = flist) + ) + structure(out, resp = resp) +} + +#' @rdname brmsformula-helpers +#' @export +lf <- function(..., flist = NULL, dpar = NULL, resp = NULL, + center = NULL, cmc = NULL, sparse = NULL, + decomp = NULL) { + out <- c(list(...), flist) + warn_dpar(dpar) + if (!is.null(resp)) { + resp <- as_one_character(resp) + } + cmc <- if (!is.null(cmc)) as_one_logical(cmc) + center <- if (!is.null(center)) as_one_logical(center) + decomp <- if (!is.null(decomp)) match.arg(decomp, decomp_opts()) + for (i in seq_along(out)) { + if (!is.null(cmc)) { + attr(out[[i]], "cmc") <- cmc + } + if (!is.null(center)) { + attr(out[[i]], "center") <- center + } + if (!is.null(sparse)) { + attr(out[[i]], "sparse") <- sparse + } + if (!is.null(decomp)) { + attr(out[[i]], "decomp") <- decomp + } + } + structure(out, resp = resp) +} + +#' @rdname brmsformula-helpers +#' @export +acformula <- function(autocor, resp = NULL) { + autocor <- terms_ac(as.formula(autocor)) + if (!is.formula(autocor)) { + stop2("'autocor' must contain at least one autocorrelation term.") + } + if (!is.null(resp)) { + resp <- as_one_character(resp) + } + structure(autocor, resp = resp, class = c("acformula", "formula")) +} + +#' @rdname brmsformula-helpers +#' @export +set_nl <- function(nl = TRUE, dpar = NULL, resp = NULL) { + nl <- as_one_logical(nl) + if (!is.null(dpar)) { + dpar <- as_one_character(dpar) + } + if (!is.null(resp)) { + resp <- as_one_character(resp) + } + structure(nl, dpar = dpar, resp = resp, class = "setnl") +} + +#' Set up a multivariate model formula for use in \pkg{brms} +#' +#' Set up a multivariate model formula for use in the \pkg{brms} package +#' allowing to define (potentially non-linear) additive multilevel +#' models for all parameters of the assumed response distributions. +#' +#' @aliases mvbf +#' +#' @param ... Objects of class \code{formula} or \code{brmsformula}, +#' each specifying a univariate model. See \code{\link{brmsformula}} +#' for details on how to specify univariate models. +#' @param flist Optional list of formulas, which are treated in the +#' same way as formulas passed via the \code{...} argument. +#' @param rescor Logical; Indicates if residual correlation between +#' the response variables should be modeled. Currently, this is only +#' possible in multivariate \code{gaussian} and \code{student} models. +#' If \code{NULL} (the default), \code{rescor} is internally set to +#' \code{TRUE} when possible. +#' +#' @return An object of class \code{mvbrmsformula}, which +#' is essentially a \code{list} containing all model formulas +#' as well as some additional information for multivariate models. +#' +#' @details See \code{vignette("brms_multivariate")} for a case study. +#' +#' @seealso \code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} +#' +#' @examples +#' bf1 <- bf(y1 ~ x + (1|g)) +#' bf2 <- bf(y2 ~ s(z)) +#' mvbf(bf1, bf2) +#' +#' @export +mvbrmsformula <- function(..., flist = NULL, rescor = NULL) { + dots <- c(list(...), flist) + if (!length(dots)) { + stop2("No objects passed to 'mvbrmsformula'.") + } + forms <- list() + for (i in seq_along(dots)) { + if (is.mvbrmsformula(dots[[i]])) { + forms <- c(forms, dots[[i]]$forms) + if (is.null(rescor)) { + rescor <- dots[[i]]$rescor + } + } else { + forms <- c(forms, list(bf(dots[[i]]))) + } + } + if (!is.null(rescor)) { + rescor <- as_one_logical(rescor) + } + responses <- ulapply(forms, "[[", "resp") + if (any(duplicated(responses))) { + stop2("Cannot use the same response variable twice in the same model.") + } + names(forms) <- responses + structure( + nlist(forms, responses, rescor), + class = c("mvbrmsformula", "bform") + ) +} + +#' @export +mvbf <- function(..., flist = NULL, rescor = NULL) { + mvbrmsformula(..., flist = flist, rescor = rescor) +} + +# build a mvbrmsformula object based on a brmsformula object +# which uses mvbind on the left-hand side to specify MV models +split_bf <- function(x) { + stopifnot(is.brmsformula(x)) + resp <- terms_resp(x$formula, check_names = FALSE) + str_adform <- formula2str(x$formula) + str_adform <- get_matches("\\|[^~]*(?=~)", str_adform, perl = TRUE) + if (length(resp) > 1L) { + # mvbind syntax used to specify MV model + flist <- named_list(resp) + for (i in seq_along(resp)) { + flist[[i]] <- x + str_lhs <- paste0(resp[[i]], str_adform) + flist[[i]]$formula[[2]] <- parse(text = str_lhs)[[1]] + flist[[i]]$resp <- resp[[i]] + } + x <- mvbf(flist = flist) + } + x +} + +#' Bind response variables in multivariate models +#' +#' Can be used to specify a multivariate \pkg{brms} model within a single +#' formula. Outside of \code{\link{brmsformula}}, it just behaves like +#' \code{\link{cbind}}. +#' +#' @param ... Same as in \code{\link{cbind}} +#' +#' @seealso \code{\link{brmsformula}}, \code{\link{mvbrmsformula}} +#' +#' @examples +#' bf(mvbind(y1, y2) ~ x) +#' +#' @export +mvbind <- function(...) { + cbind(...) +} + +#' @rdname brmsformula-helpers +#' @export +set_rescor <- function(rescor = TRUE) { + structure(as_one_logical(rescor), class = "setrescor") +} + +allow_rescor <- function(x) { + # indicate if estimating 'rescor' is allowed for this model + if (!(is.mvbrmsformula(x) || is.mvbrmsterms(x))) { + return(FALSE) + } + parts <- if (is.mvbrmsformula(x)) x$forms else x$terms + families <- lapply(parts, "[[", "family") + has_rescor <- ulapply(families, has_rescor) + is_mixture <- ulapply(families, is.mixfamily) + family_names <- ulapply(families, "[[", "family") + all(has_rescor) && !any(is_mixture) && + length(unique(family_names)) == 1L +} + +#' @rdname brmsformula-helpers +#' @export +set_mecor <- function(mecor = TRUE) { + structure(as_one_logical(mecor), class = "setmecor") +} + +#' @export +"+.bform" <- function(e1, e2) { + if (is.brmsformula(e1)) { + out <- plus_brmsformula(e1, e2) + } else if (is.mvbrmsformula(e1)) { + out <- plus_mvbrmsformula(e1, e2) + } else { + stop2("Method '+.bform' not implemented for ", class(e1), " objects.") + } + out +} + +# internal helper function of '+.bform' +plus_brmsformula <- function(e1, e2) { + if (is.function(e2)) { + e2 <- try(e2(), silent = TRUE) + if (!is.family(e2)) { + stop2("Don't know how to handle non-family functions.") + } + } + if (is.family(e2)) { + e1 <- bf(e1, family = e2) + } else if (is.cor_brms(e2) || inherits(e2, "acformula")) { + e1 <- bf(e1, autocor = e2) + } else if (inherits(e2, "setnl")) { + dpar <- attr(e2, "dpar") + if (is.null(dpar)) { + e1 <- bf(e1, nl = e2) + } else { + if (is.null(e1$pforms[[dpar]])) { + stop2("Parameter '", dpar, "' has no formula.") + } + attr(e1$pforms[[dpar]], "nl") <- e2 + e1 <- bf(e1) + } + } else if (inherits(e2, "setmecor")) { + e1$mecor <- e2[1] + } else if (is.brmsformula(e2)) { + e1 <- mvbf(e1, e2) + } else if (inherits(e2, "setrescor")) { + stop2("Setting 'rescor' is only possible in multivariate models.") + } else if (is.ac_term(e2)) { + stop2("Autocorrelation terms can only be specified on the right-hand ", + "side of a formula, not added to a 'brmsformula' object.") + } else if (!is.null(e2)) { + e1 <- bf(e1, e2) + } + e1 +} + +# internal helper function of '+.bform' +plus_mvbrmsformula <- function(e1, e2) { + if (is.function(e2)) { + e2 <- try(e2(), silent = TRUE) + if (!is.family(e2)) { + stop2("Don't know how to handle non-family functions.") + } + } + if (is.family(e2) || is.cor_brms(e2)) { + e1$forms <- lapply(e1$forms, "+", e2) + } else if (inherits(e2, "setrescor")) { + e1$rescor <- e2[1] + } else if (inherits(e2, "setmecor")) { + e1$mecor <- e2[1] + } else if (is.brmsformula(e2)) { + e1 <- mvbf(e1, e2) + } else if (is.ac_term(e2)) { + stop2("Autocorrelation terms can only be specified on the right-hand ", + "side of a formula, not added to a 'mvbrmsformula' object.") + } else if (!is.null(e2)) { + resp <- attr(e2, "resp", TRUE) + if (is.null(resp)) { + stop2( + "Don't know how to add a ", class(e2), " object ", + "without the response variable name. ", + "See help('brmsformula-helpers') for more details." + ) + } + if (!isTRUE(resp %in% e1$responses)) { + stop2("'resp' should be one of ", collapse_comma(e1$responses), ".") + } + e1$forms[[resp]] <- e1$forms[[resp]] + e2 + } + e1 +} + +# extract the 'nl' attribute from a brmsformula object +# @param x object to extract 'nl' from +# @param dpar optional name of a distributional parameter +# for which 'nl' should be extracted +# @param resp: optional name of a response variable +# for which 'nl' should be extracted +# @param aol: (as one logical) apply isTRUE to the result? +get_nl <- function(x, dpar = NULL, resp = NULL, aol = TRUE) { + if (is.mvbrmsformula(x)) { + resp <- as_one_character(resp) + x <- x$forms[[resp]] + } + if (is.brmsformula(x)) { + if (is.null(dpar)) { + x <- x$formula + } else { + dpar <- as_one_character(dpar) + x <- x$pforms[[dpar]] + } + } + nl <- attr(x, "nl", TRUE) + if (aol) { + nl <- isTRUE(nl) + } + nl +} + +# available options for the 'decomp' argument +decomp_opts <- function() { + c("none", "QR") +} + +# validate a formula of an additional parameter +# @param formula an formula object +# @param par optional name of the parameter; if not specified +# the parameter name will be inferred from the formula +# @param rsv_pars optional character vector of reserved parameter names +# @return a named list of length one containing the formula +validate_par_formula <- function(formula, par = NULL, rsv_pars = NULL) { + stopifnot(length(par) <= 1L) + try_formula <- try(as_formula(formula), silent = TRUE) + if (is(try_formula, "try-error")) { + if (length(formula) != 1L) { + stop2("Expecting a single value when fixing parameter '", par, "'.") + } + scalar <- SW(as.numeric(formula)) + if (!is.na(scalar)) { + formula <- scalar + } else { + formula <- as.character(formula) + } + out <- named_list(par, formula) + } else { + formula <- try_formula + if (!is.null(lhs(formula))) { + resp_pars <- all.vars(formula[[2]]) + out <- named_list(resp_pars, list(formula)) + for (i in seq_along(out)) { + out[[i]][[2]] <- eval2(paste("quote(", resp_pars[i], ")")) + } + } else { + if (!isTRUE(nzchar(par))) { + stop2("Additional formulas must be named.") + } + formula <- formula(paste(par, formula2str(formula))) + out <- named_list(par, list(formula)) + } + } + pars <- names(out) + if (any(grepl("\\.|_", pars))) { + stop2("Parameter names should not contain dots or underscores.") + } + inv_pars <- intersect(pars, rsv_pars) + if (length(inv_pars)) { + stop2("The following parameter names are reserved", + "for this model:\n", collapse_comma(inv_pars)) + } + out +} + +# validate formulas dedicated to response variables +# @param x coerced to a formula object +# @param empty_ok is an empty left-hand-side ok? +# @return a formula of the form ~ 1 +validate_resp_formula <- function(x, empty_ok = TRUE) { + out <- lhs(as_formula(x)) + if (is.null(out)) { + if (empty_ok) { + out <- ~ 1 + } else { + str_x <- formula2str(x, space = "trim") + stop2("Response variable is missing in formula ", str_x) + } + } + out <- gsub("\\|+[^~]*~", "~", formula2str(out)) + out <- try(formula(out), silent = TRUE) + if (is(out, "try-error")) { + str_x <- formula2str(x, space = "trim") + stop2("Incorrect use of '|' on the left-hand side of ", str_x) + } + environment(out) <- environment(x) + out +} + +# incorporate additional arguments into the model formula +validate_formula <- function(formula, ...) { + UseMethod("validate_formula") +} + +#' @export +validate_formula.default <- function(formula, ...) { + validate_formula(bf(formula), ...) +} + +# incorporate additional arguments into the model formula +# @param formula object of class 'formula' of 'brmsformula' +# @param data optional data.frame to validate data related arguments +# @param family optional 'family' object +# @param autocor (deprecated) optional 'cor_brms' object +# @param threshold (deprecated) threshold type for ordinal models +# @param cov_ranef (deprecated) named list of group covariance matrices +# @return a brmsformula object compatible with the current version of brms +#' @export +validate_formula.brmsformula <- function( + formula, family = gaussian(), autocor = NULL, + data = NULL, threshold = NULL, sparse = NULL, + cov_ranef = NULL, ... +) { + out <- bf(formula) + if (is.null(out$family) && !is.null(family)) { + out$family <- validate_family(family) + } + # allow the '.' symbol in the formulas + out$formula <- expand_dot_formula(out$formula, data) + for (i in seq_along(out$pforms)) { + out$pforms[[i]] <- expand_dot_formula(out$pforms[[i]], data) + } + # allow 'me' terms to be correlated + out$mecor <- default_mecor(out$mecor) + if (has_cat(out) && !is.null(data)) { + # for easy access of response categories + # allow to update 'cats' with new data + out$family$cats <- extract_cat_names(out, data) + } + if (is_ordinal(out$family)) { + # thresholds and category names are data dependent + try_terms <- try(stats::terms(out$formula), silent = TRUE) + intercept <- attr(try_terms, "intercept", TRUE) + if (!is(try_terms, "try-error") && isTRUE(intercept == 0)) { + stop2("Cannot remove the intercept in an ordinal model.") + } + if (!is.null(data)) { + # for easy access of thresholds and response categories (#838) + # allow to update 'cats' and 'thres' with new data + out$family$thres <- extract_thres_names(out, data) + out$family$cats <- extract_cat_names(out, data) + } + if (is.mixfamily(out$family)) { + # every mixture family needs to know about response categories + for (i in seq_along(out$family$mix)) { + out$family$mix[[i]]$thres <- out$family$thres + } + } + } + conv_cats_dpars <- conv_cats_dpars(out$family) + if (conv_cats_dpars && !is.null(data)) { + # allow to update 'dpars' with new data + # define distributional parameters based on response categories + if (length(out$family$cats) < 2L) { + stop2("At least 2 response categories are required.") + } + if (is.null(out$family$refcat)) { + # the first level serves as the reference category + out$family$refcat <- out$family$cats[1] + } + if (isNA(out$family$refcat)) { + # implies predicting all categories + predcats <- out$family$cats + } else { + if (!out$family$refcat %in% out$family$cats) { + stop2("The reference response category must be one of ", + collapse_comma(out$family$cats), ".") + } + predcats <- setdiff(out$family$cats, out$family$refcat) + } + multi_dpars <- valid_dpars(out$family, type = "multi") + # 'rev' so that mu comes last but appears first in the end + for (dp in rev(multi_dpars)) { + dp_dpars <- make_stan_names(paste0(dp, predcats)) + if (any(duplicated(dp_dpars))) { + stop2("Invalid response category names. Please avoid ", + "using any special characters in the names.") + } + old_dp_dpars <- str_subset(out$family$dpars, paste0("^", dp)) + out$family$dpars <- setdiff(out$family$dpars, old_dp_dpars) + out$family$dpars <- union(dp_dpars, out$family$dpars) + } + } + + # incorporate deprecated arguments + require_threshold <- is_ordinal(out$family) && is.null(out$family$threshold) + if (require_threshold && !is.null(threshold)) { + # slot 'threshold' is deprecated as of brms 1.7.0 + out$family <- validate_family(out$family, threshold = threshold) + } + if (!is.null(sparse)) { + # a global 'sparse' argument is deprecated as of brms 2.8.3 + warning2( + "Argument 'sparse' should be specified within the ", + "'formula' argument. See ?brmsformula for help." + ) + sparse <- as_one_logical(sparse) + if (is.null(attr(out$formula, "sparse"))) { + attr(out$formula, "sparse") <- sparse + } + for (i in seq_along(out$pforms)) { + if (is.null(attr(out$pforms[[i]], "sparse"))) { + attr(out$pforms[[i]], "sparse") <- sparse + } + } + } + if (is.null(attr(out$formula, "autocor")) && !is.null(autocor)) { + # 'autocor' interface has been changed in brms 2.11.1 + warning2( + "Argument 'autocor' should be specified within the ", + "'formula' argument. See ?brmsformula for help." + ) + # store 'autocor' as an attribute to carry it around more easily + attr(out$formula, "autocor") <- validate_autocor(autocor) + } + if (!is.null(cov_ranef)) { + # 'cov_ranef' is deprecated as of brms 2.12.5 + out$cov_ranef <- validate_cov_ranef(cov_ranef) + } + bf(out) +} + +# incorporate additional arguments into MV model formulas +# allow passing lists of families or autocors +#' @export +validate_formula.mvbrmsformula <- function( + formula, family = NULL, autocor = NULL, cov_ranef = NULL, ... +) { + nresp <- length(formula$forms) + if (!is(family, "list")) { + family <- replicate(nresp, family, simplify = FALSE) + } else if (length(family) != nresp) { + stop2("If 'family' is a list, it has to be of the same ", + "length as the number of response variables.") + } + if (!is(autocor, "list")) { + autocor <- replicate(nresp, autocor, simplify = FALSE) + } else if (length(autocor) != nresp) { + stop2("If 'autocor' is a list, it has to be of the same ", + "length as the number of response variables.") + } + for (i in seq_len(nresp)) { + formula$forms[[i]] <- validate_formula( + formula$forms[[i]], family = family[[i]], + autocor = autocor[[i]], ... + ) + } + if (length(formula$forms) < 2L) { + stop2("Multivariate models require at least two responses.") + } + allow_rescor <- allow_rescor(formula) + if (is.null(formula$rescor)) { + # with 'mi' terms we usually don't want rescor to be estimated + miforms <- ulapply(formula$forms, function(f) + terms_ad(f$formula, f$family, FALSE)[["mi"]] + ) + formula$rescor <- allow_rescor && !length(miforms) + message("Setting 'rescor' to ", formula$rescor, " by default for this model") + if (formula$rescor) { + warning2( + "In the future, 'rescor' will be set to FALSE by default for ", + "all models. It is thus recommended to explicitely set ", + "'rescor' via 'set_rescor' instead of using the default." + ) + } + } + formula$rescor <- as_one_logical(formula$rescor) + if (formula$rescor) { + if (!allow_rescor) { + stop2("Currently, estimating 'rescor' is only possible ", + "in multivariate gaussian or student models.") + } + } + # handle default of correlations between 'me' terms + formula$mecor <- default_mecor(formula$mecor) + for (i in seq_along(formula$forms)) { + formula$forms[[i]]$mecor <- formula$mecor + } + # incorporate deprecated arguments + if (!is.null(cov_ranef)) { + # 'cov_ranef' is deprecated as of brms 2.12.5 + formula$cov_ranef <- validate_cov_ranef(cov_ranef) + } + formula +} + +# update a brmsformula and / or its attributes +# @param brmsformula object +# @param formula.: formula to update 'object' +# @param mode supports the following options: +# "update": apply update.formula +# "replace": replace old formula +# "keep": keep old formula +# attributes are always updated +# @param ... currently unused +# @return a brmsformula object +#' @export +update.brmsformula <- function(object, formula., + mode = c("update", "replace", "keep"), + ...) { + mode <- match.arg(mode) + object <- bf(object) + up_nl <- get_nl(formula., aol = FALSE) + if (is.null(up_nl)) { + up_nl <- get_nl(object) + } + # already use up_nl here to avoid ordinary parsing of NL formulas + formula. <- bf(formula., nl = up_nl) + up_family <- formula.[["family"]] + if (is.null(up_family)) { + up_family <- object[["family"]] + } + up_autocor <- attr(formula.$formula, "autocor") + if (is.null(up_autocor)) { + up_autocor <- attr(object$formula, "autocor") + } + old_form <- object$formula + up_form <- formula.$formula + if (mode == "update") { + new_form <- update(old_form, up_form, ...) + } else if (mode == "replace") { + new_form <- up_form + } else if (mode == "keep") { + new_form <- old_form + } + flist <- c(object$pforms, object$pfix, formula.$pforms, formula.$pfix) + bf(new_form, flist = flist, family = up_family, + autocor = up_autocor, nl = up_nl) +} + +#' @export +update.mvbrmsformula <- function(object, formula., ...) { + # temporary until proper updating is implemented + if (!missing(formula.)) { + stop2("Updating formulas of multivariate models is not yet possible.") + } + object +} + +#' Update Formula Addition Terms +#' +#' Update additions terms used in formulas of \pkg{brms}. See +#' \code{\link{addition-terms}} for details. +#' +#' @param formula Two-sided formula to be updated. +#' @param adform One-sided formula containing addition terms to update +#' \code{formula} with. +#' @param action Indicates what should happen to the existing addition terms in +#' \code{formula}. If \code{"update"} (the default), old addition terms that +#' have no corresponding term in \code{adform} will be kept. If +#' \code{"replace"}, all old addition terms will be removed. +#' +#' @return An object of class \code{formula}. +#' +#' @examples +#' form <- y | trials(size) ~ x +#' update_adterms(form, ~ trials(10)) +#' update_adterms(form, ~ weights(w)) +#' update_adterms(form, ~ weights(w), action = "replace") +#' update_adterms(y ~ x, ~ trials(10)) +#' +#' @export +update_adterms <- function(formula, adform, action = c("update", "replace")) { + formula <- as_formula(formula) + adform <- as_formula(adform) + action <- match.arg(action) + if (is.null(lhs(formula))) { + stop2("Can't update a ond-sided formula.") + } + str_formula <- formula2str(formula) + old_ad <- get_matches("(?<=\\|)[^~]*(?=~)", str_formula, perl = TRUE) + new_ad_terms <- attr(terms(adform), "term.labels") + if (action == "update" && length(old_ad)) { + # extract adterms from the original formula + old_ad <- formula(paste("~", old_ad)) + old_ad_terms <- attr(terms(old_ad), "term.labels") + old_adnames <- get_matches("^[^\\(]+", old_ad_terms) + old_adnames <- sub("^resp_", "", old_adnames) + new_adnames <- get_matches("^[^\\(]+", new_ad_terms) + new_adnames <- sub("^resp_", "", new_adnames) + # keep unmatched adterms of the original formula + keep <- !old_adnames %in% new_adnames + new_ad_terms <- c(old_ad_terms[keep], new_ad_terms) + } + if (length(new_ad_terms)) { + new_ad_terms <- paste(new_ad_terms, collapse = "+") + new_ad_terms <- paste("|", new_ad_terms) + } + resp <- gsub("\\|.+", "", deparse_combine(formula[[2]])) + out <- formula(paste(resp, new_ad_terms, "~1")) + out[[3]] <- formula[[3]] + attributes(out) <- attributes(formula) + out +} + +#' @export +print.brmsformula <- function(x, wsp = 0, digits = 2, ...) { + cat(formula2str(x$formula, space = "trim"), "\n") + str_wsp <- collapse(rep(" ", wsp)) + autocor <- attr(x$formula, "autocor") + if (!is.null(autocor)) { + autocor <- formula2str(autocor, rm = 1, space = "trim") + cat(paste0(str_wsp, "autocor ~ ", autocor, "\n")) + } + pforms <- x$pforms + if (length(pforms)) { + pforms <- ulapply(pforms, formula2str, space = "trim") + cat(collapse(str_wsp, pforms, "\n")) + } + pfix <- x$pfix + if (length(pfix)) { + pfix <- lapply(pfix, function(x) + ifelse(is.numeric(x), round(x, digits), x) + ) + pfix <- paste0(names(pfix), " = ", unlist(pfix)) + cat(collapse(str_wsp, pfix, "\n")) + } + invisible(x) +} + +#' @export +print.mvbrmsformula <- function(x, wsp = 0, ...) { + for (i in seq_along(x$forms)) { + if (i > 1) cat(collapse(rep(" ", wsp))) + print(x$forms[[i]], wsp = wsp, ...) + } + invisible(x) +} + +#' Checks if argument is a \code{brmsformula} object +#' +#' @param x An \R object +#' +#' @export +is.brmsformula <- function(x) { + inherits(x, "brmsformula") +} + +#' Checks if argument is a \code{mvbrmsformula} object +#' +#' @param x An \R object +#' +#' @export +is.mvbrmsformula <- function(x) { + inherits(x, "mvbrmsformula") +} + +is_nonlinear <- function(x) { + stopifnot(is.brmsfit(x)) + get_nl(bf(x$formula)) +} + +warn_dpar <- function(dpar) { + # argument 'dpar' in formula helper functions is deprecated as of 2.3.7 + if (!is.null(dpar)) { + warning2("Argument 'dpar' is no longer necessary and ignored.") + } + NULL +} + +# return the right-hand side of a formula +rhs <- function(x) { + attri <- attributes(x) + x <- as.formula(x) + x <- if (length(x) == 3) x[-2] else x + do_call(structure, c(list(x), attri)) +} + +# return the left-hand side of a formula +lhs <- function(x) { + x <- as.formula(x) + if (length(x) == 3L) update(x, . ~ 1) else NULL +} + +# convert a string to a formula +# @param x vector of strings to be converted +# @param ... passed to formula() +str2formula <- function(x, ..., collapse = "+") { + has_chars <- nzchar(x) + if (length(x) && any(has_chars)) { + out <- paste(x[has_chars], collapse = collapse) + } else { + out <- "1" + } + out <- formula(paste("~", out), ...) + environment(out) <- parent.frame() + out +} + +# convert a formula to a character string +# @param formula a model formula +# @param rm a vector of to elements indicating how many characters +# should be removed at the beginning and end of the string respectively +# @param space how should whitespaces be treated? +# option 'rm' is dangerous as it may combine different operators (#1142) +# @return a single character string or NULL +formula2str <- function(formula, rm = c(0, 0), space = c("trim", "rm")) { + if (is.null(formula)) { + return(NULL) + } + formula <- as.formula(formula) + space <- match.arg(space) + if (anyNA(rm[2])) rm[2] <- 0 + x <- Reduce(paste, deparse(formula)) + x <- gsub("[\t\r\n]+", " ", x, perl = TRUE) + if (space == "trim") { + x <- trim_wsp(x) + } else { + x <- rm_wsp(x) + } + substr(x, 1 + rm[1], nchar(x) - rm[2]) +} + +# right-hand side of a formula as a character string +str_rhs <- function(x) { + formula2str(rhs(x), rm = c(1, 0)) +} + +# left-hand side of a formula as a character string +str_lhs <- function(x) { + formula2str(lhs(x), rm = c(0, 2)) +} + +is.formula <- function(x) { + inherits(x, "formula") +} + +# wrapper around as.formula with additional checks +as_formula <- function(x) { + x <- as.formula(x) + # fixes issue #749 + rhs <- rhs(x)[[2]] + if (isTRUE(is.call(rhs) && rhs[[1]] == "~")) { + stop2("Nested formulas are not allowed. Did you use '~~' somewhere?") + } + x +} + +# expand the '.' variable in formula using stats::terms +expand_dot_formula <- function(formula, data = NULL) { + if (isTRUE("." %in% all.vars(formula))) { + att <- attributes(formula) + try_terms <- try( + stats::terms(formula, data = data), + silent = TRUE + ) + if (!is(try_terms, "try-error")) { + formula <- formula(try_terms) + } + attributes(formula) <- att + } + formula +} diff -Nru r-cran-brms-2.16.3/R/brms-package.R r-cran-brms-2.17.0/R/brms-package.R --- r-cran-brms-2.16.3/R/brms-package.R 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/R/brms-package.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,84 +1,84 @@ -#' Bayesian Regression Models using 'Stan' -#' -#' @docType package -#' @name brms-package -#' @aliases brms -#' -#' @description -#' \if{html}{ -#' \figure{stanlogo.png}{options: width="50px" alt="https://mc-stan.org/about/logo/"} -#' \emph{Stan Development Team} -#' } -#' -#' The \pkg{brms} package provides an interface to fit Bayesian generalized -#' multivariate (non-)linear multilevel models using \pkg{Stan}, which is a C++ -#' package for obtaining full Bayesian inference (see -#' \url{https://mc-stan.org/}). The formula syntax is an extended version of the -#' syntax applied in the \pkg{lme4} package to provide a familiar and simple -#' interface for performing regression analyses. -#' -#' @details -#' The main function of \pkg{brms} is \code{\link{brm}}, which uses -#' formula syntax to specify a wide range of complex Bayesian models -#' (see \code{\link{brmsformula}} for details). Based on the supplied -#' formulas, data, and additional information, it writes the Stan code -#' on the fly via \code{\link{make_stancode}}, prepares the data via -#' \code{\link{make_standata}}, and fits the model using -#' \pkg{\link[rstan:rstan]{Stan}}. -#' -#' Subsequently, a large number of post-processing methods can be applied: -#' To get an overview on the estimated parameters, -#' \code{\link[brms:summary.brmsfit]{summary}} or -#' \code{\link[brms:conditional_effects.brmsfit]{conditional_effects}} -#' are perfectly suited. Detailed visual analyses can be performed by applying -#' the \code{\link{pp_check}} and \code{\link{stanplot}} methods, which both -#' rely on the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} package. -#' Model comparisons can be done via \code{\link{loo}} and \code{\link{waic}}, -#' which make use of the \pkg{\link[loo:loo-package]{loo}} package as well as -#' via \code{\link{bayes_factor}} which relies on the \pkg{bridgesampling} package. -#' For a full list of methods to apply, type \code{methods(class = "brmsfit")}. -#' -#' Because \pkg{brms} is based on \pkg{Stan}, a C++ compiler is required. The -#' program Rtools (available on -#' \url{https://cran.r-project.org/bin/windows/Rtools/}) comes with a C++ -#' compiler for Windows. On Mac, you should use Xcode. For further instructions -#' on how to get the compilers running, see the prerequisites section at the -#' \href{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}{RStan-Getting-Started} -#' page. -#' -#' When comparing other packages fitting multilevel models to \pkg{brms}, keep -#' in mind that the latter needs to compile models before actually fitting them, -#' which will require between 20 and 40 seconds depending on your machine, -#' operating system and overall model complexity. -#' -#' Thus, fitting smaller models may be relatively slow as compilation time makes -#' up the majority of the whole running time. For larger / more complex -#' models however, fitting my take several minutes or even hours, so that the -#' compilation time won't make much of a difference for these models. -#' -#' See \code{vignette("brms_overview")} and \code{vignette("brms_multilevel")} -#' for a general introduction and overview of \pkg{brms}. For a full list of -#' available vignettes, type \code{vignette(package = "brms")}. -#' -#' @references -#' Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel -#' Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. -#' \code{doi:10.18637/jss.v080.i01} -#' -#' Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling -#' with the R Package brms. \emph{The R Journal}. 10(1), 395–411. -#' \code{doi:10.32614/RJ-2018-017} -#' -#' The Stan Development Team. \emph{Stan Modeling Language User's Guide and -#' Reference Manual}. \url{https://mc-stan.org/users/documentation/}. -#' -#' Stan Development Team (2020). RStan: the R interface to Stan. R package -#' version 2.21.2. \url{https://mc-stan.org/} -#' -#' @seealso -#' \code{\link{brm}}, -#' \code{\link{brmsformula}}, -#' \code{\link{brmsfamily}}, -#' \code{\link{brmsfit}} -#' -NULL +#' Bayesian Regression Models using 'Stan' +#' +#' @docType package +#' @name brms-package +#' @aliases brms +#' +#' @description +#' \if{html}{ +#' \figure{stanlogo.png}{options: width="50" alt="https://mc-stan.org/about/logo/"} +#' \emph{Stan Development Team} +#' } +#' +#' The \pkg{brms} package provides an interface to fit Bayesian generalized +#' multivariate (non-)linear multilevel models using \pkg{Stan}, which is a C++ +#' package for obtaining full Bayesian inference (see +#' \url{https://mc-stan.org/}). The formula syntax is an extended version of the +#' syntax applied in the \pkg{lme4} package to provide a familiar and simple +#' interface for performing regression analyses. +#' +#' @details +#' The main function of \pkg{brms} is \code{\link{brm}}, which uses +#' formula syntax to specify a wide range of complex Bayesian models +#' (see \code{\link{brmsformula}} for details). Based on the supplied +#' formulas, data, and additional information, it writes the Stan code +#' on the fly via \code{\link{make_stancode}}, prepares the data via +#' \code{\link{make_standata}}, and fits the model using +#' \pkg{\link[rstan:rstan]{Stan}}. +#' +#' Subsequently, a large number of post-processing methods can be applied: +#' To get an overview on the estimated parameters, +#' \code{\link[brms:summary.brmsfit]{summary}} or +#' \code{\link[brms:conditional_effects.brmsfit]{conditional_effects}} +#' are perfectly suited. Detailed visual analyses can be performed by applying +#' the \code{\link{pp_check}} and \code{\link{stanplot}} methods, which both +#' rely on the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} package. +#' Model comparisons can be done via \code{\link{loo}} and \code{\link{waic}}, +#' which make use of the \pkg{\link[loo:loo-package]{loo}} package as well as +#' via \code{\link{bayes_factor}} which relies on the \pkg{bridgesampling} package. +#' For a full list of methods to apply, type \code{methods(class = "brmsfit")}. +#' +#' Because \pkg{brms} is based on \pkg{Stan}, a C++ compiler is required. The +#' program Rtools (available on +#' \url{https://cran.r-project.org/bin/windows/Rtools/}) comes with a C++ +#' compiler for Windows. On Mac, you should use Xcode. For further instructions +#' on how to get the compilers running, see the prerequisites section at the +#' \href{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}{RStan-Getting-Started} +#' page. +#' +#' When comparing other packages fitting multilevel models to \pkg{brms}, keep +#' in mind that the latter needs to compile models before actually fitting them, +#' which will require between 20 and 40 seconds depending on your machine, +#' operating system and overall model complexity. +#' +#' Thus, fitting smaller models may be relatively slow as compilation time makes +#' up the majority of the whole running time. For larger / more complex +#' models however, fitting my take several minutes or even hours, so that the +#' compilation time won't make much of a difference for these models. +#' +#' See \code{vignette("brms_overview")} and \code{vignette("brms_multilevel")} +#' for a general introduction and overview of \pkg{brms}. For a full list of +#' available vignettes, type \code{vignette(package = "brms")}. +#' +#' @references +#' Paul-Christian Buerkner (2017). brms: An R Package for Bayesian Multilevel +#' Models Using Stan. \emph{Journal of Statistical Software}, 80(1), 1-28. +#' \code{doi:10.18637/jss.v080.i01} +#' +#' Paul-Christian Buerkner (2018). Advanced Bayesian Multilevel Modeling +#' with the R Package brms. \emph{The R Journal}. 10(1), 395–411. +#' \code{doi:10.32614/RJ-2018-017} +#' +#' The Stan Development Team. \emph{Stan Modeling Language User's Guide and +#' Reference Manual}. \url{https://mc-stan.org/users/documentation/}. +#' +#' Stan Development Team (2020). RStan: the R interface to Stan. R package +#' version 2.21.2. \url{https://mc-stan.org/} +#' +#' @seealso +#' \code{\link{brm}}, +#' \code{\link{brmsformula}}, +#' \code{\link{brmsfamily}}, +#' \code{\link{brmsfit}} +#' +NULL diff -Nru r-cran-brms-2.16.3/R/brmsterms.R r-cran-brms-2.17.0/R/brmsterms.R --- r-cran-brms-2.16.3/R/brmsterms.R 2021-08-26 17:47:33.000000000 +0000 +++ r-cran-brms-2.17.0/R/brmsterms.R 2022-03-21 10:24:08.000000000 +0000 @@ -1,1131 +1,1156 @@ -#' Parse Formulas of \pkg{brms} Models -#' -#' Parse formulas objects for use in \pkg{brms}. -#' -#' @aliases parse_bf -#' -#' @inheritParams brm -#' @param check_response Logical; Indicates whether the left-hand side -#' of \code{formula} (i.e. response variables and addition arguments) -#' should be parsed. If \code{FALSE}, \code{formula} may also be one-sided. -#' @param resp_rhs_all Logical; Indicates whether to also include response -#' variables on the right-hand side of formula \code{.$allvars}, -#' where \code{.} represents the output of \code{brmsterms}. -#' @param ... Further arguments passed to or from other methods. -#' -#' @return An object of class \code{brmsterms} or \code{mvbrmsterms} -#' (for multivariate models), which is a \code{list} containing all -#' required information initially stored in \code{formula} -#' in an easier to use format, basically a list of formulas -#' (not an abstract syntax tree). -#' -#' @details This is the main formula parsing function of \pkg{brms}. -#' It should usually not be called directly, but is exported to allow -#' package developers making use of the formula syntax implemented -#' in \pkg{brms}. As long as no other packages depend on this functions, -#' it may be changed without deprecation warnings, when new features make -#' this necessary. -#' -#' @seealso -#' \code{\link{brm}}, -#' \code{\link{brmsformula}}, -#' \code{\link{mvbrmsformula}} -#' -#' @export -brmsterms <- function(formula, ...) { - UseMethod("brmsterms") -} - -# the name 'parse_bf' is deprecated as of brms 2.12.4 -# remove it eventually in brms 3.0 -#' @export -parse_bf <- function(x, ...) { - warning2("Method 'parse_bf' is deprecated. Please use 'brmsterms' instead.") - UseMethod("brmsterms") -} - -#' @rdname brmsterms -#' @export -brmsterms.default <- function(formula, ...) { - brmsterms(validate_formula(formula), ...) -} - -#' @rdname brmsterms -#' @export -brmsterms.brmsformula <- function(formula, check_response = TRUE, - resp_rhs_all = TRUE, ...) { - x <- validate_formula(formula) - mv <- isTRUE(x$mv) - rescor <- mv && isTRUE(x$rescor) - mecor <- isTRUE(x$mecor) - formula <- x$formula - family <- x$family - y <- nlist(formula, family, mv, rescor, mecor) - y$cov_ranef <- x$cov_ranef - class(y) <- "brmsterms" - - if (check_response) { - # extract response variables - y$respform <- validate_resp_formula(formula, empty_ok = FALSE) - if (mv) { - y$resp <- terms_resp(y$respform) - } else { - y$resp <- "" - } - } - - # extract addition arguments - adforms <- terms_ad(formula, family, check_response) - advars <- str2formula(ulapply(adforms, all_vars)) - y$adforms[names(adforms)] <- adforms - - # centering would lead to incorrect results for grouped threshold vectors - # as each threshold vector only affects a subset of observations - if (!is.null(get_ad_expr(y, "thres", "gr"))) { - attr(formula, "center") <- FALSE - dp_classes <- dpar_class(names(x$pforms)) - mu_names <- names(x$pforms)[dp_classes == "mu"] - for (dp in mu_names) { - attr(x$pforms[[dp]], "center") <- FALSE - } - } - - # combine the main formula with formulas for the 'mu' parameters - if (is.mixfamily(family)) { - mu_dpars <- paste0("mu", seq_along(family$mix)) - for (dp in mu_dpars) { - x$pforms[[dp]] <- combine_formulas(formula, x$pforms[[dp]], dp) - } - x$pforms <- move2start(x$pforms, mu_dpars) - } else if (conv_cats_dpars(x$family)) { - mu_dpars <- str_subset(x$family$dpars, "^mu") - for (dp in mu_dpars) { - x$pforms[[dp]] <- combine_formulas(formula, x$pforms[[dp]], dp) - } - x$pforms <- move2start(x$pforms, mu_dpars) - } else { - x$pforms[["mu"]] <- combine_formulas(formula, x$pforms[["mu"]], "mu") - x$pforms <- move2start(x$pforms, "mu") - } - - # predicted distributional parameters - resp <- ifelse(mv && !is.null(y$resp), y$resp, "") - dpars <- intersect(names(x$pforms), valid_dpars(family)) - dpar_forms <- x$pforms[dpars] - nlpars <- setdiff(names(x$pforms), dpars) - - y$dpars <- named_list(dpars) - for (dp in dpars) { - if (get_nl(dpar_forms[[dp]])) { - y$dpars[[dp]] <- terms_nlf(dpar_forms[[dp]], nlpars, resp) - } else { - y$dpars[[dp]] <- terms_lf(dpar_forms[[dp]]) - } - y$dpars[[dp]]$family <- dpar_family(family, dp) - y$dpars[[dp]]$dpar <- dp - y$dpars[[dp]]$resp <- resp - if (dpar_class(dp) == "mu") { - y$dpars[[dp]]$respform <- y$respform - y$dpars[[dp]]$adforms <- y$adforms - } - check_cs(y$dpars[[dp]]) - } - - y$nlpars <- named_list(nlpars) - if (length(nlpars)) { - nlpar_forms <- x$pforms[nlpars] - for (nlp in nlpars) { - if (is.null(attr(nlpar_forms[[nlp]], "center"))) { - # design matrices of non-linear parameters will not be - # centered by default to make prior specification easier - attr(nlpar_forms[[nlp]], "center") <- FALSE - } - if (get_nl(nlpar_forms[[nlp]])) { - y$nlpars[[nlp]] <- terms_nlf(nlpar_forms[[nlp]], nlpars, resp) - } else { - y$nlpars[[nlp]] <- terms_lf(nlpar_forms[[nlp]]) - } - y$nlpars[[nlp]]$nlpar <- nlp - y$nlpars[[nlp]]$resp <- resp - check_cs(y$nlpars[[nlp]]) - } - used_nlpars <- ulapply(c(y$dpars, y$nlpars), "[[", "used_nlpars") - unused_nlpars <- setdiff(nlpars, used_nlpars) - if (length(unused_nlpars)) { - stop2( - "The parameter '", unused_nlpars[1], "' is not a ", - "valid distributional or non-linear parameter. ", - "Did you forget to set 'nl = TRUE'?" - ) - } - # sort non-linear parameters after dependency - used_nlpars <- lapply(y$nlpars, "[[", "used_nlpars") - sorted_nlpars <- sort_dependencies(used_nlpars) - y$nlpars <- y$nlpars[sorted_nlpars] - } - - # fixed distributional parameters - valid_dpars <- valid_dpars(y) - inv_fixed_dpars <- setdiff(names(x$pfix), valid_dpars) - if (length(inv_fixed_dpars)) { - stop2("Invalid fixed parameters: ", collapse_comma(inv_fixed_dpars)) - } - if ("sigma" %in% valid_dpars && no_sigma(y)) { - # some models require setting sigma to 0 - if ("sigma" %in% c(names(x$pforms), names(x$pfix))) { - stop2("Cannot predict or fix 'sigma' in this model.") - } - x$pfix$sigma <- 0 - } - if ("nu" %in% valid_dpars && no_nu(y)) { - if ("nu" %in% c(names(x$pforms), names(x$pfix))) { - stop2("Cannot predict or fix 'nu' in this model.") - } - x$pfix$nu <- 1 - } - disc_pars <- valid_dpars[dpar_class(valid_dpars) %in% "disc"] - for (dp in disc_pars) { - # 'disc' is set to 1 and not estimated by default - if (!dp %in% c(names(x$pforms), names(x$pfix))) { - x$pfix[[dp]] <- 1 - } - } - for (dp in names(x$pfix)) { - y$fdpars[[dp]] <- list(value = x$pfix[[dp]], dpar = dp) - } - check_fdpars(y$fdpars) - - # make a formula containing all required variables - unused_vars <- all_vars(attr(x$formula, "unused")) - lhsvars <- if (resp_rhs_all) all_vars(y$respform) - y$allvars <- allvars_formula( - lhsvars, advars, lapply(y$dpars, get_allvars), - lapply(y$nlpars, get_allvars), y$time$allvars, - unused_vars - ) - if (check_response) { - # add y$respform to the left-hand side of y$allvars - # avoid using update.formula as it is inefficient for longer formulas - formula_allvars <- y$respform - formula_allvars[[3]] <- y$allvars[[2]] - y$allvars <- formula_allvars - } - environment(y$allvars) <- environment(formula) - y -} - -#' @rdname brmsterms -#' @export -brmsterms.mvbrmsformula <- function(formula, ...) { - x <- validate_formula(formula) - x$rescor <- isTRUE(x$rescor) - x$mecor <- isTRUE(x$mecor) - out <- structure(list(), class = "mvbrmsterms") - out$terms <- named_list(names(x$forms)) - for (i in seq_along(out$terms)) { - x$forms[[i]]$rescor <- x$rescor - x$forms[[i]]$mecor <- x$mecor - x$forms[[i]]$mv <- TRUE - out$terms[[i]] <- brmsterms(x$forms[[i]], ...) - } - out$allvars <- allvars_formula(lapply(out$terms, get_allvars)) - # required to find variables used solely in the response part - lhs_resp <- function(x) deparse_combine(lhs(x$respform)[[2]]) - out$respform <- paste0(ulapply(out$terms, lhs_resp), collapse = ",") - out$respform <- formula(paste0("mvbind(", out$respform, ") ~ 1")) - out$responses <- ulapply(out$terms, "[[", "resp") - out$rescor <- x$rescor - out$mecor <- x$mecor - out$cov_ranef <- x$cov_ranef - out -} - -# parse linear/additive formulas -# @param formula an ordinary model formula -# @return a 'btl' object -terms_lf <- function(formula) { - formula <- rhs(as.formula(formula)) - y <- nlist(formula) - formula <- terms(formula) - check_accidental_helper_functions(formula) - types <- setdiff(all_term_types(), excluded_term_types(formula)) - for (t in types) { - tmp <- do_call(paste0("terms_", t), list(formula)) - if (is.data.frame(tmp) || is.formula(tmp)) { - y[[t]] <- tmp - } - } - y$allvars <- allvars_formula( - get_allvars(y$fe), get_allvars(y$re), - get_allvars(y$cs), get_allvars(y$sp), - get_allvars(y$sm), get_allvars(y$gp), - get_allvars(y$ac), get_allvars(y$offset) - ) - environment(y$allvars) <- environment(formula) - structure(y, class = "btl") -} - -# parse non-linear formulas -# @param formula non-linear model formula -# @param nlpars names of all non-linear parameters -# @param resp optional name of a response variable -# @return a 'btnl' object -terms_nlf <- function(formula, nlpars, resp = "") { - if (!length(nlpars)) { - stop2("No non-linear parameters specified.") - } - loop <- !isFALSE(attr(formula, "loop")) - formula <- rhs(as.formula(formula)) - y <- nlist(formula) - all_vars <- all_vars(formula) - y$used_nlpars <- intersect(all_vars, nlpars) - covars <- setdiff(all_vars, nlpars) - y$covars <- structure(str2formula(covars), int = FALSE) - if (!"ac" %in% excluded_term_types(formula)) { - y$ac <- terms_ac(attr(formula, "autocor")) - } - y$allvars <- allvars_formula(covars, get_allvars(y$ac)) - environment(y$allvars) <- environment(formula) - y$loop <- loop - structure(y, class = "btnl") -} - -# extract addition arguments out of formula -# @return a list of formulas each containg a single addition term -terms_ad <- function(formula, family = NULL, check_response = TRUE) { - x <- list() - ad_funs <- lsp("brms", what = "exports", pattern = "^resp_") - ad_funs <- sub("^resp_", "", ad_funs) - families <- family_names(family) - if (is.family(family) && any(nzchar(families))) { - str_formula <- formula2str(formula) - ad <- get_matches("(?<=\\|)[^~]*(?=~)", str_formula, perl = TRUE) - valid_ads <- family_info(family, "ad") - if (length(ad)) { - ad_terms <- terms(str2formula(ad)) - if (length(attr(ad_terms, "offset"))) { - stop2("Offsets are not allowed in addition terms.") - } - ad_terms <- attr(ad_terms, "term.labels") - for (a in ad_funs) { - matches <- grep(paste0("^(resp_)?", a, "\\(.*\\)$"), ad_terms) - if (length(matches) == 1L) { - x[[a]] <- ad_terms[matches] - if (!grepl("^resp_", x[[a]])) { - x[[a]] <- paste0("resp_", x[[a]]) - } - ad_terms <- ad_terms[-matches] - if (!is.na(x[[a]]) && a %in% valid_ads) { - x[[a]] <- str2formula(x[[a]]) - } else { - stop2("Argument '", a, "' is not supported for ", - "family '", summary(family), "'.") - } - } else if (length(matches) > 1L) { - stop2("Each addition argument may only be defined once.") - } - } - if (length(ad_terms)) { - stop2("The following addition terms are invalid:\n", - collapse_comma(ad_terms)) - } - } - if (check_response && "wiener" %in% families && !is.formula(x$dec)) { - stop2("Addition argument 'dec' is required for family 'wiener'.") - } - if (is.formula(x$cat)) { - # 'cat' was replaced by 'thres' in brms 2.10.5 - x$thres <- x$cat - } - } - x -} - -# extract fixed effects terms -terms_fe <- function(formula) { - if (!is.terms(formula)) { - formula <- terms(formula) - } - all_terms <- all_terms(formula) - sp_terms <- find_terms(all_terms, "all", complete = FALSE) - re_terms <- all_terms[grepl("\\|", all_terms)] - int_term <- attr(formula, "intercept") - fe_terms <- setdiff(all_terms, c(sp_terms, re_terms)) - out <- paste(c(int_term, fe_terms), collapse = "+") - out <- str2formula(out) - attr(out, "allvars") <- allvars_formula(out) - attr(out, "decomp") <- get_decomp(formula) - if (has_rsv_intercept(out, has_intercept(formula))) { - attr(out, "int") <- FALSE - } - if (no_cmc(formula)) { - attr(out, "cmc") <- FALSE - } - if (no_center(formula)) { - attr(out, "center") <- FALSE - } - if (is_sparse(formula)) { - attr(out, "sparse") <- TRUE - } - out -} - -# gather information of group-level terms -# @return a data.frame with one row per group-level term -terms_re <- function(formula) { - re_terms <- get_re_terms(formula, brackets = FALSE) - if (!length(re_terms)) { - return(NULL) - } - re_terms <- split_re_terms(re_terms) - re_parts <- re_parts(re_terms) - out <- allvars <- vector("list", length(re_terms)) - type <- attr(re_terms, "type") - for (i in seq_along(re_terms)) { - gcall <- eval2(re_parts$rhs[i]) - form <- str2formula(re_parts$lhs[i]) - group <- paste0(gcall$type, collapse(gcall$groups)) - out[[i]] <- data.frame( - group = group, gtype = gcall$type, gn = i, - id = gcall$id, type = type[i], cor = gcall$cor, - stringsAsFactors = FALSE - ) - out[[i]]$gcall <- list(gcall) - out[[i]]$form <- list(form) - # gather all variables used in the group-level term - # at this point 'cs' terms are no longer recognized as such - ftype <- str_if(type[i] %in% "cs", "", type[i]) - re_allvars <- get_allvars(form, type = ftype) - allvars[[i]] <- allvars_formula(re_allvars, gcall$allvars) - } - out <- do_call(rbind, out) - out <- out[order(out$group), ] - attr(out, "allvars") <- allvars_formula(allvars) - if (no_cmc(formula)) { - # disabling cell-mean coding in all group-level terms - # has to come last to avoid removal of attributes - for (i in seq_rows(out)) { - attr(out$form[[i]], "cmc") <- FALSE - } - } - out -} - -# extract category specific terms for ordinal models -terms_cs <- function(formula) { - out <- find_terms(formula, "cs") - if (!length(out)) { - return(NULL) - } - out <- ulapply(out, eval2, envir = environment()) - out <- str2formula(out) - attr(out, "allvars") <- allvars_formula(out) - # do not test whether variables were supplied to 'cs' - # to allow category specific group-level intercepts - attr(out, "int") <- FALSE - out -} - -# extract special effects terms -terms_sp <- function(formula) { - types <- c("mo", "me", "mi") - out <- find_terms(formula, types, complete = FALSE) - if (!length(out)) { - return(NULL) - } - uni_mo <- trim_wsp(get_matches_expr(regex_sp("mo"), out)) - uni_me <- trim_wsp(get_matches_expr(regex_sp("me"), out)) - uni_mi <- trim_wsp(get_matches_expr(regex_sp("mi"), out)) - # remove the intercept as it is handled separately - out <- str2formula(c("0", out)) - attr(out, "int") <- FALSE - attr(out, "uni_mo") <- uni_mo - attr(out, "uni_me") <- uni_me - attr(out, "uni_mi") <- uni_mi - attr(out, "allvars") <- str2formula(all_vars(out)) - # TODO: do we need sp_fake_formula at all? - # attr(out, "allvars") <- sp_fake_formula(uni_mo, uni_me, uni_mi) - out -} - -# extract spline terms -terms_sm <- function(formula) { - out <- find_terms(formula, "sm") - if (!length(out)) { - return(NULL) - } - if (any(grepl("^(te|ti)\\(", out))) { - stop2("Tensor product smooths 'te' and 'ti' are not yet ", - "implemented in brms. Consider using 't2' instead.") - } - out <- str2formula(out) - attr(out, "allvars") <- mgcv::interpret.gam(out)$fake.formula - out -} - -# extract gaussian process terms -terms_gp <- function(formula) { - out <- find_terms(formula, "gp") - if (!length(out)) { - return(NULL) - } - eterms <- lapply(out, eval2, envir = environment()) - covars <- lapply(eterms, "[[", "term") - byvars <- lapply(eterms, "[[", "by") - allvars <- str2formula(unlist(c(covars, byvars))) - allvars <- str2formula(all_vars(allvars)) - if (!length(all_vars(allvars))) { - stop2("No variable supplied to function 'gp'.") - } - out <- str2formula(out) - attr(out, "allvars") <- allvars - out -} - -# extract autocorrelation terms -terms_ac <- function(formula) { - autocor <- attr(formula, "autocor") - out <- c(find_terms(formula, "ac"), find_terms(autocor, "ac")) - if (!length(out)) { - return(NULL) - } - eterms <- lapply(out, eval2, envir = environment()) - allvars <- unlist(c( - lapply(eterms, "[[", "time"), - lapply(eterms, "[[", "gr") - )) - allvars <- str2formula(all_vars(allvars)) - out <- str2formula(out) - attr(out, "allvars") <- allvars - out -} - -# extract offset terms -terms_offset <- function(formula) { - if (!is.terms(formula)) { - formula <- terms(as.formula(formula)) - } - pos <- attr(formula, "offset") - if (is.null(pos)) { - return(NULL) - } - vars <- attr(formula, "variables") - out <- ulapply(pos, function(i) deparse(vars[[i + 1]])) - out <- str2formula(out) - attr(out, "allvars") <- str2formula(all_vars(out)) - out -} - -# extract multiple covariates in multi-membership terms -terms_mmc <- function(formula) { - out <- find_terms(formula, "mmc") - if (!length(out)) { - return(NULL) - } - # remove the intercept as it is handled separately - out <- str2formula(c("0", out)) - attr(out, "allvars") <- allvars_formula(out) - attr(out, "int") <- FALSE - out -} - -# extract response variable names -# assumes multiple response variables to be combined via mvbind -terms_resp <- function(formula, check_names = TRUE) { - formula <- lhs(as.formula(formula)) - if (is.null(formula)) { - return(NULL) - } - expr <- validate_resp_formula(formula)[[2]] - if (length(expr) <= 1L) { - out <- deparse_no_string(expr) - } else { - str_fun <- deparse_no_string(expr[[1]]) - used_mvbind <- grepl("^(brms:::?)?mvbind$", str_fun) - if (used_mvbind) { - out <- ulapply(expr[-1], deparse_no_string) - } else { - out <- deparse_no_string(expr) - } - } - if (check_names) { - out <- make_stan_names(out) - } - out -} - -#' Checks if argument is a \code{brmsterms} object -#' -#' @param x An \R object -#' -#' @seealso \code{\link[brms:brmsterms]{brmsterms}} -#' -#' @export -is.brmsterms <- function(x) { - inherits(x, "brmsterms") -} - -#' Checks if argument is a \code{mvbrmsterms} object -#' -#' @param x An \R object -#' -#' @seealso \code{\link[brms:brmsterms]{brmsterms}} -#' -#' @export -is.mvbrmsterms <- function(x) { - inherits(x, "mvbrmsterms") -} - -is.btl <- function(x) { - inherits(x, "btl") -} - -is.btnl <- function(x) { - inherits(x, "btnl") -} - -# transform mvbrmsterms objects for use in stan_llh.brmsterms -as.brmsterms <- function(x) { - stopifnot(is.mvbrmsterms(x), x$rescor) - families <- ulapply(x$terms, function(y) y$family$family) - stopifnot(all(families == families[1])) - out <- structure(list(), class = "brmsterms") - out$family <- structure( - list(family = paste0(families[1], "_mv"), link = "identity"), - class = c("brmsfamily", "family") - ) - info <- get(paste0(".family_", families[1]))() - out$family[names(info)] <- info - out$sigma_pred <- any(ulapply(x$terms, - function(x) "sigma" %in% names(x$dpar) || is.formula(x$adforms$se) - )) - weight_forms <- rmNULL(lapply(x$terms, function(x) x$adforms$weights)) - if (length(weight_forms)) { - str_wf <- unique(ulapply(weight_forms, formula2str)) - if (length(str_wf) > 1L) { - stop2("All responses should use the same", - "weights if 'rescor' is estimated.") - } - out$adforms$weights <- weight_forms[[1]] - } - miforms <- rmNULL(lapply(x$terms, function(x) x$adforms$mi)) - if (length(miforms)) { - out$adforms$mi <- miforms[[1]] - } - out -} - -# names of supported term types -all_term_types <- function() { - c("fe", "re", "sp", "cs", "sm", "gp", "ac", "offset") -} - -# avoid ambiguous parameter names -# @param names names to check for ambiguity -# @param bterms a brmsterms object -avoid_dpars <- function(names, bterms) { - dpars <- c(names(bterms$dpars), "sp", "cs") - if (length(dpars)) { - dpars_prefix <- paste0("^", dpars, "_") - invalid <- any(ulapply(dpars_prefix, grepl, names)) - if (invalid) { - dpars <- paste0("'", dpars, "_'", collapse = ", ") - stop2("Variable names starting with ", dpars, - " are not allowed for this model.") - } - } - invisible(NULL) -} - -vars_prefix <- function() { - c("dpar", "resp", "nlpar") -} - -# check and tidy parameter prefixes -check_prefix <- function(x, keep_mu = FALSE) { - vpx <- vars_prefix() - if (is.data.frame(x) && nrow(x) == 0) { - # avoids a bug in data.frames with zero rows - x <- list() - } - x[setdiff(vpx, names(x))] <- "" - x <- x[vpx] - for (i in seq_along(x)) { - x[[i]] <- as.character(x[[i]]) - if (!length(x[[i]])) { - x[[i]] <- "" - } - x[[i]] <- ifelse( - !keep_mu & names(x)[i] == "dpar" & x[[i]] %in% "mu", - yes = "", no = x[[i]] - ) - x[[i]] <- ifelse( - keep_mu & names(x)[i] == "dpar" & x[[i]] %in% "", - yes = "mu", no = x[[i]] - ) - } - x -} - -# combined parameter prefixes -# @param prefix object from which to extract prefixes -# @param keep_mu keep the 'mu' prefix if available or remove it? -# @param nlp include the 'nlp' prefix for non-linear parameters? -combine_prefix <- function(prefix, keep_mu = FALSE, nlp = FALSE) { - prefix <- check_prefix(prefix, keep_mu = keep_mu) - if (is_nlpar(prefix) && nlp) { - prefix$dpar <- "nlp" - } - prefix <- lapply(prefix, usc) - sub("^_", "", do_call(paste0, prefix)) -} - -# check validity of fixed distributional parameters -check_fdpars <- function(x) { - stopifnot(is.null(x) || is.list(x)) - pos_pars <- c( - "sigma", "shape", "nu", "phi", "kappa", - "beta", "disc", "bs", "ndt", "theta" - ) - prob_pars <- c("zi", "hu", "bias", "quantile") - for (dp in names(x)) { - apc <- dpar_class(dp) - value <- x[[dp]]$value - if (apc %in% pos_pars && value < 0) { - stop2("Parameter '", dp, "' must be positive.") - } - if (apc %in% prob_pars && (value < 0 || value > 1)) { - stop2("Parameter '", dp, "' must be between 0 and 1.") - } - } - invisible(TRUE) -} - -# combine all variables in one formuula -# @param x (list of) formulas or character strings -# @return a formula with all variables on the right-hand side -allvars_formula <- function(...) { - out <- rmNULL(c(...)) - out <- collapse(ulapply(out, plus_rhs)) - all_vars <- all_vars(out) - invalid_vars <- setdiff(all_vars, make.names(all_vars)) - if (length(invalid_vars)) { - stop2("The following variable names are invalid: ", - collapse_comma(invalid_vars)) - } - str2formula(c(out, all_vars)) -} - -# conveniently extract a formula of all relevant variables -# @param x any object from which to extract 'allvars' -# @param type predictor type; requires a 'parse_' function -# @return a formula with all variables on the right-hand side -# or NULL if 'allvars' cannot be found -get_allvars <- function(x, type = "") { - out <- attr(x, "allvars", TRUE) - if (is.null(out) && "allvars" %in% names(x)) { - out <- x[["allvars"]] - } - if (is.null(out) && is.formula(x)) { - type <- as_one_character(type) - type <- str_if(nzchar(type), type, "fe") - terms_fun <- get(paste0("terms_", type), mode = "function") - out <- attr(terms_fun(x), "allvars") - } - stopifnot(is.null(out) || is.formula(out)) - out -} - -# add 'x' to the right-hand side of a formula -plus_rhs <- function(x) { - if (is.formula(x)) { - x <- sub("^[^~]*~", "", formula2str(x)) - } - if (length(x) && all(nzchar(x))) { - out <- paste0(" + ", paste(x, collapse = "+")) - } else { - out <- " + 1" - } - out -} - -# like stats::terms but keeps attributes if possible -terms <- function(formula, ...) { - old_attributes <- attributes(formula) - formula <- stats::terms(formula, ...) - new_attributes <- attributes(formula) - sel_names <- setdiff(names(old_attributes), names(new_attributes)) - attributes(formula)[sel_names] <- old_attributes[sel_names] - formula -} - -is.terms <- function(x) { - inherits(x, "terms") -} - -# combine formulas for distributional parameters -# @param formula1 primary formula from which to take the RHS -# @param formula2 secondary formula used to update the RHS of formula1 -# @param lhs character string to define the left-hand side of the output -# @param update a flag to indicate whether updating should be allowed. -# Defaults to FALSE to maintain backwards compatibility -# @return a formula object -combine_formulas <- function(formula1, formula2, lhs = "", update = FALSE) { - stopifnot(is.formula(formula1)) - stopifnot(is.null(formula2) || is.formula(formula2)) - lhs <- as_one_character(lhs) - update <- as_one_logical(update) - if (is.null(formula2)) { - rhs <- str_rhs(formula1) - att <- attributes(formula1) - } else if (update && has_terms(formula1)) { - # TODO: decide about intuitive updating behavior - if (get_nl(formula1) || get_nl(formula2)) { - stop2("Cannot combine non-linear formulas.") - } - old_formula <- eval2(paste0("~ ", str_rhs(formula1))) - new_formula <- eval2(paste0("~ . + ", str_rhs(formula2))) - rhs <- str_rhs(update(old_formula, new_formula)) - att <- attributes(formula1) - att[names(attributes(formula2))] <- attributes(formula2) - } else { - rhs <- str_rhs(formula2) - att <- attributes(formula2) - } - out <- eval2(paste0(lhs, " ~ ", rhs)) - attributes(out)[names(att)] <- att - out -} - -# does the formula contain any terms? -# @return TRUE or FALSE -has_terms <- function(formula) { - stopifnot(is.formula(formula)) - terms <- try(terms(rhs(formula)), silent = TRUE) - is(terms, "try-error") || - length(attr(terms, "term.labels")) || - length(attr(terms, "offset")) -} - -# has a linear formula any terms except overall effects? -has_special_terms <- function(x) { - if (!is.btl(x)) { - return(FALSE) - } - special_terms <- c("sp", "sm", "gp", "ac", "cs", "offset") - NROW(x[["re"]]) > 0 || any(lengths(x[special_terms])) -} - -# indicate if the predictor term belongs to a non-linear parameter -is_nlpar <- function(x) { - isTRUE(nzchar(x[["nlpar"]])) -} - -# indicate if the intercept should be removed -no_int <- function(x) { - isFALSE(attr(x, "int", exact = TRUE)) -} - -# indicate if cell mean coding should be disabled -no_cmc <- function(x) { - isFALSE(attr(x, "cmc", exact = TRUE)) -} - -# indicate if centering of the design matrix should be disabled -no_center <- function(x) { - isFALSE(attr(x, "center", exact = TRUE)) -} - -# indicate if the design matrix should be handled as sparse -is_sparse <- function(x) { - isTRUE(attr(x, "sparse", exact = TRUE)) -} - -# get the decomposition type of the design matrix -get_decomp <- function(x) { - out <- attr(x, "decomp", exact = TRUE) - if (is.null(out)) { - out <- "none" - } - as_one_character(out) -} - -# extract different types of effects -get_effect <- function(x, ...) { - UseMethod("get_effect") -} - -#' @export -get_effect.default <- function(x, ...) { - NULL -} - -#' @export -get_effect.brmsfit <- function(x, ...) { - get_effect(x$formula, ...) -} - -#' @export -get_effect.brmsformula <- function(x, ...) { - get_effect(brmsterms(x), ...) -} - -#' @export -get_effect.mvbrmsformula <- function(x, ...) { - get_effect(brmsterms(x), ...) -} - -#' @export -get_effect.mvbrmsterms <- function(x, ...) { - ulapply(x$terms, get_effect, recursive = FALSE, ...) -} - -# extract formulas of a certain effect type -# @param target effect type to return -# @param all logical; include effects of nlpars and dpars? -# @return a list of formulas -#' @export -get_effect.brmsterms <- function(x, target = "fe", ...) { - out <- named_list(c(names(x$dpars), names(x$nlpars))) - for (dp in names(x$dpars)) { - out[[dp]] <- get_effect(x$dpars[[dp]], target = target) - } - for (nlp in names(x$nlpars)) { - out[[nlp]] <- get_effect(x$nlpars[[nlp]], target = target) - } - unlist(out, recursive = FALSE) -} - -#' @export -get_effect.btl <- function(x, target = "fe", ...) { - x[[target]] -} - -#' @export -get_effect.btnl <- function(x, target = "fe", ...) { - NULL -} - -all_terms <- function(x) { - if (!length(x)) { - return(character(0)) - } - if (!is.terms(x)) { - x <- terms(as.formula(x)) - } - trim_wsp(attr(x, "term.labels")) -} - -# generate a regular expression to extract special terms -# @param type one or more special term types to be extracted -regex_sp <- function(type = "all") { - choices <- c("all", "sp", "sm", "gp", "cs", "mmc", "ac", all_sp_types()) - type <- unique(match.arg(type, choices, several.ok = TRUE)) - funs <- c( - sm = "(s|(t2)|(te)|(ti))", - gp = "gp", cs = "cse?", mmc = "mmc", - ac = "((arma)|(ar)|(ma)|(cosy)|(sar)|(car)|(fcor))" - ) - funs[all_sp_types()] <- all_sp_types() - if ("sp" %in% type) { - # allows extracting all 'sp' terms at once - type <- setdiff(type, "sp") - type <- union(type, all_sp_types()) - } - if ("all" %in% type) { - # allows extracting all special terms at once - type <- names(funs) - } - funs <- funs[type] - allow_colon <- c("cs", "mmc", "ac") - inner <- ifelse(names(funs) %in% allow_colon, ".*", "[^:]*") - out <- paste0("^(", funs, ")\\(", inner, "\\)$") - paste0("(", out, ")", collapse = "|") -} - -# find special terms of a certain type -# @param x formula object of character vector from which to extract terms -# @param type special terms type to be extracted. see regex_sp() -# @param complete check if terms consist completely of single special terms? -# @param ranef include group-level terms? -# @return a character vector of matching terms -find_terms <- function(x, type, complete = TRUE, ranef = FALSE) { - if (is.formula(x)) { - x <- all_terms(x) - } else { - x <- as.character(x) - } - complete <- as_one_logical(complete) - ranef <- as_one_logical(ranef) - regex <- regex_sp(type) - is_match <- grepl_expr(regex, x) - if (!ranef) { - is_match <- is_match & !grepl("\\|", x) - } - out <- x[is_match] - if (complete) { - matches <- lapply(out, get_matches_expr, pattern = regex) - # each term may contain only one special function call - inv <- out[lengths(matches) > 1L] - if (!length(inv)) { - # each term must be exactly equal to the special function call - inv <- out[trim_wsp(unlist(matches)) != out] - } - if (length(inv)) { - stop2("The term '", inv[1], "' is invalid in brms syntax.") - } - } - out -} - -# validate a terms object (or one that can be coerced to it) -# for use primarily in 'get_model_matrix' -# @param x any R object -# @return a (possibly amended) terms object or NULL -# if 'x' could not be coerced to a terms object -validate_terms <- function(x) { - no_int <- no_int(x) - no_cmc <- no_cmc(x) - if (is.formula(x) && !is.terms(x)) { - x <- terms(x) - } - if (!is.terms(x)) { - return(NULL) - } - if (no_int || !has_intercept(x) && no_cmc) { - # allows to remove the intercept without causing cell mean coding - attr(x, "intercept") <- 1 - attr(x, "int") <- FALSE - } - x -} - -# checks if the formula contains an intercept -has_intercept <- function(formula) { - if (is.terms(formula)) { - out <- as.logical(attr(formula, "intercept")) - } else { - formula <- as.formula(formula) - try_terms <- try(terms(formula), silent = TRUE) - if (is(try_terms, "try-error")) { - out <- FALSE - } else { - out <- as.logical(attr(try_terms, "intercept")) - } - } - out -} - -# check if model makes use of the reserved intercept variables -# @param has_intercept does the model have an intercept? -# if NULL this will be inferred from formula itself -has_rsv_intercept <- function(formula, has_intercept = NULL) { - .has_rsv_intercept <- function(terms, has_intercept) { - has_intercept <- as_one_logical(has_intercept) - intercepts <- c("intercept", "Intercept") - out <- !has_intercept && any(intercepts %in% all_vars(rhs(terms))) - return(out) - } - if (is.terms(formula)) { - if (is.null(has_intercept)) { - has_intercept <- has_intercept(formula) - } - return(.has_rsv_intercept(formula, has_intercept)) - } - formula <- try(as.formula(formula), silent = TRUE) - if (is(formula, "try-error")) { - return(FALSE) - } - if (is.null(has_intercept)) { - try_terms <- try(terms(formula), silent = TRUE) - if (is(try_terms, "try-error")) { - return(FALSE) - } - has_intercept <- has_intercept(try_terms) - } - .has_rsv_intercept(formula, has_intercept) -} - -# names of reserved variables -rsv_vars <- function(bterms) { - stopifnot(is.brmsterms(bterms) || is.mvbrmsterms(bterms)) - .rsv_vars <- function(x) { - rsv_int <- any(ulapply(x$dpars, has_rsv_intercept)) - if (rsv_int) c("intercept", "Intercept") else NULL - } - if (is.mvbrmsterms(bterms)) { - out <- unique(ulapply(bterms$terms, .rsv_vars)) - } else { - out <- .rsv_vars(bterms) - } - out -} - -# are category specific effects present? -has_cs <- function(bterms) { - length(get_effect(bterms, target = "cs")) > 0L || - any(get_re(bterms)$type %in% "cs") -} - -# check if category specific effects are allowed -check_cs <- function(bterms) { - stopifnot(is.btl(bterms) || is.btnl(bterms)) - if (has_cs(bterms)) { - if (!is_equal(dpar_class(bterms$dpar), "mu")) { - stop2("Category specific effects are only supported ", - "for the main parameter 'mu'.") - } - if (!(is.null(bterms$family) || allow_cs(bterms$family))) { - stop2("Category specific effects are not supported for this family.") - } - if (needs_ordered_cs(bterms$family)) { - warning2("Category specific effects for this family should be ", - "considered experimental and may have convergence issues.") - } - } - invisible(NULL) -} - -# check for the presence of helper functions accidentally used -# within a formula instead of added to bf(). See #1103 -check_accidental_helper_functions <- function(formula) { - terms <- all_terms(formula) - # see help("brmsformula-helpers") for the list of functions - funs <- c("nlf", "lf", "acformula", "set_nl", "set_rescor", "set_mecor") - regex <- paste0("(", funs, ")", collapse = "|") - regex <- paste0("^(", regex, ")\\(") - matches <- get_matches(regex, terms, first = TRUE) - matches <- sub("\\($", "", matches) - matches <- unique(matches) - matches <- matches[nzchar(matches)] - for (m in matches) { - loc <- utils::find(m, mode = "function") - if (is_equal(loc[1], "package:brms")) { - stop2("Function '", m, "' should not be part of the right-hand side ", - "of a formula. See help('brmsformula-helpers') for the correct syntax.") - } - } - invisible(TRUE) -} - -# extract elements from objects -# @param x object from which to extract elements -# @param name name of the element to be extracted -get_element <- function(x, name, ...) { - UseMethod("get_element") -} - -#' @export -get_element.default <- function(x, name, ...) { - x[[name]] -} - -#' @export -get_element.mvbrmsformula <- function(x, name, ...) { - lapply(x$forms, get_element, name = name, ...) -} - -#' @export -get_element.mvbrmsterms <- function(x, name, ...) { - lapply(x$terms, get_element, name = name, ...) -} +#' Parse Formulas of \pkg{brms} Models +#' +#' Parse formulas objects for use in \pkg{brms}. +#' +#' @aliases parse_bf +#' +#' @inheritParams brm +#' @param check_response Logical; Indicates whether the left-hand side +#' of \code{formula} (i.e. response variables and addition arguments) +#' should be parsed. If \code{FALSE}, \code{formula} may also be one-sided. +#' @param resp_rhs_all Logical; Indicates whether to also include response +#' variables on the right-hand side of formula \code{.$allvars}, +#' where \code{.} represents the output of \code{brmsterms}. +#' @param ... Further arguments passed to or from other methods. +#' +#' @return An object of class \code{brmsterms} or \code{mvbrmsterms} +#' (for multivariate models), which is a \code{list} containing all +#' required information initially stored in \code{formula} +#' in an easier to use format, basically a list of formulas +#' (not an abstract syntax tree). +#' +#' @details This is the main formula parsing function of \pkg{brms}. +#' It should usually not be called directly, but is exported to allow +#' package developers making use of the formula syntax implemented +#' in \pkg{brms}. As long as no other packages depend on this functions, +#' it may be changed without deprecation warnings, when new features make +#' this necessary. +#' +#' @seealso +#' \code{\link{brm}}, +#' \code{\link{brmsformula}}, +#' \code{\link{mvbrmsformula}} +#' +#' @export +brmsterms <- function(formula, ...) { + UseMethod("brmsterms") +} + +# the name 'parse_bf' is deprecated as of brms 2.12.4 +# remove it eventually in brms 3.0 +#' @export +parse_bf <- function(x, ...) { + warning2("Method 'parse_bf' is deprecated. Please use 'brmsterms' instead.") + UseMethod("brmsterms") +} + +#' @rdname brmsterms +#' @export +brmsterms.default <- function(formula, ...) { + brmsterms(validate_formula(formula), ...) +} + +#' @rdname brmsterms +#' @export +brmsterms.brmsformula <- function(formula, check_response = TRUE, + resp_rhs_all = TRUE, ...) { + x <- validate_formula(formula) + mv <- isTRUE(x$mv) + rescor <- mv && isTRUE(x$rescor) + mecor <- isTRUE(x$mecor) + formula <- x$formula + family <- x$family + y <- nlist(formula, family, mv, rescor, mecor) + y$cov_ranef <- x$cov_ranef + class(y) <- "brmsterms" + + if (check_response) { + # extract response variables + y$respform <- validate_resp_formula(formula, empty_ok = FALSE) + if (mv) { + y$resp <- terms_resp(y$respform) + } else { + y$resp <- "" + } + } + + # extract addition arguments + adforms <- terms_ad(formula, family, check_response) + advars <- str2formula(ulapply(adforms, all_vars)) + y$adforms[names(adforms)] <- adforms + + # centering would lead to incorrect results for grouped threshold vectors + # as each threshold vector only affects a subset of observations + if (!is.null(get_ad_expr(y, "thres", "gr"))) { + attr(formula, "center") <- FALSE + dp_classes <- dpar_class(names(x$pforms)) + mu_names <- names(x$pforms)[dp_classes == "mu"] + for (dp in mu_names) { + attr(x$pforms[[dp]], "center") <- FALSE + } + } + + # combine the main formula with formulas for the 'mu' parameters + if (is.mixfamily(family)) { + mu_dpars <- paste0("mu", seq_along(family$mix)) + for (dp in mu_dpars) { + x$pforms[[dp]] <- combine_formulas(formula, x$pforms[[dp]], dp) + } + x$pforms <- move2start(x$pforms, mu_dpars) + } else if (conv_cats_dpars(x$family)) { + mu_dpars <- str_subset(x$family$dpars, "^mu") + for (dp in mu_dpars) { + x$pforms[[dp]] <- combine_formulas(formula, x$pforms[[dp]], dp) + } + x$pforms <- move2start(x$pforms, mu_dpars) + } else { + x$pforms[["mu"]] <- combine_formulas(formula, x$pforms[["mu"]], "mu") + x$pforms <- move2start(x$pforms, "mu") + } + + # predicted distributional parameters + resp <- ifelse(mv && !is.null(y$resp), y$resp, "") + dpars <- intersect(names(x$pforms), valid_dpars(family)) + dpar_forms <- x$pforms[dpars] + nlpars <- setdiff(names(x$pforms), dpars) + + y$dpars <- named_list(dpars) + for (dp in dpars) { + if (get_nl(dpar_forms[[dp]])) { + y$dpars[[dp]] <- terms_nlf(dpar_forms[[dp]], nlpars, resp) + } else { + y$dpars[[dp]] <- terms_lf(dpar_forms[[dp]]) + } + y$dpars[[dp]]$family <- dpar_family(family, dp) + y$dpars[[dp]]$dpar <- dp + y$dpars[[dp]]$resp <- resp + if (dpar_class(dp) == "mu") { + y$dpars[[dp]]$respform <- y$respform + y$dpars[[dp]]$adforms <- y$adforms + } + check_cs(y$dpars[[dp]]) + } + + y$nlpars <- named_list(nlpars) + if (length(nlpars)) { + nlpar_forms <- x$pforms[nlpars] + for (nlp in nlpars) { + if (is.null(attr(nlpar_forms[[nlp]], "center"))) { + # design matrices of non-linear parameters will not be + # centered by default to make prior specification easier + attr(nlpar_forms[[nlp]], "center") <- FALSE + } + if (get_nl(nlpar_forms[[nlp]])) { + y$nlpars[[nlp]] <- terms_nlf(nlpar_forms[[nlp]], nlpars, resp) + } else { + y$nlpars[[nlp]] <- terms_lf(nlpar_forms[[nlp]]) + } + y$nlpars[[nlp]]$nlpar <- nlp + y$nlpars[[nlp]]$resp <- resp + check_cs(y$nlpars[[nlp]]) + } + used_nlpars <- ulapply(c(y$dpars, y$nlpars), "[[", "used_nlpars") + unused_nlpars <- setdiff(nlpars, used_nlpars) + if (length(unused_nlpars)) { + stop2( + "The parameter '", unused_nlpars[1], "' is not a ", + "valid distributional or non-linear parameter. ", + "Did you forget to set 'nl = TRUE'?" + ) + } + # sort non-linear parameters after dependency + used_nlpars <- lapply(y$nlpars, "[[", "used_nlpars") + sorted_nlpars <- sort_dependencies(used_nlpars) + y$nlpars <- y$nlpars[sorted_nlpars] + } + + # fixed distributional parameters + valid_dpars <- valid_dpars(y) + inv_fixed_dpars <- setdiff(names(x$pfix), valid_dpars) + if (length(inv_fixed_dpars)) { + stop2("Invalid fixed parameters: ", collapse_comma(inv_fixed_dpars)) + } + if ("sigma" %in% valid_dpars && no_sigma(y)) { + # some models require setting sigma to 0 + if ("sigma" %in% c(names(x$pforms), names(x$pfix))) { + stop2("Cannot predict or fix 'sigma' in this model.") + } + x$pfix$sigma <- 0 + } + if ("nu" %in% valid_dpars && no_nu(y)) { + if ("nu" %in% c(names(x$pforms), names(x$pfix))) { + stop2("Cannot predict or fix 'nu' in this model.") + } + x$pfix$nu <- 1 + } + disc_pars <- valid_dpars[dpar_class(valid_dpars) %in% "disc"] + for (dp in disc_pars) { + # 'disc' is set to 1 and not estimated by default + if (!dp %in% c(names(x$pforms), names(x$pfix))) { + x$pfix[[dp]] <- 1 + } + } + for (dp in names(x$pfix)) { + y$fdpars[[dp]] <- list(value = x$pfix[[dp]], dpar = dp) + } + check_fdpars(y$fdpars) + + # make a formula containing all required variables + y$unused <- attr(x$formula, "unused") + lhsvars <- if (resp_rhs_all) all_vars(y$respform) + y$allvars <- allvars_formula( + lhsvars, advars, lapply(y$dpars, get_allvars), + lapply(y$nlpars, get_allvars), y$time$allvars, + get_unused_arg_vars(y) + ) + if (check_response) { + # add y$respform to the left-hand side of y$allvars + # avoid using update.formula as it is inefficient for longer formulas + formula_allvars <- y$respform + formula_allvars[[3]] <- y$allvars[[2]] + y$allvars <- formula_allvars + } + environment(y$allvars) <- environment(formula) + y +} + +#' @rdname brmsterms +#' @export +brmsterms.mvbrmsformula <- function(formula, ...) { + x <- validate_formula(formula) + x$rescor <- isTRUE(x$rescor) + x$mecor <- isTRUE(x$mecor) + out <- structure(list(), class = "mvbrmsterms") + out$terms <- named_list(names(x$forms)) + for (i in seq_along(out$terms)) { + x$forms[[i]]$rescor <- x$rescor + x$forms[[i]]$mecor <- x$mecor + x$forms[[i]]$mv <- TRUE + out$terms[[i]] <- brmsterms(x$forms[[i]], ...) + } + out$allvars <- allvars_formula(lapply(out$terms, get_allvars)) + # required to find variables used solely in the response part + lhs_resp <- function(x) deparse_combine(lhs(x$respform)[[2]]) + out$respform <- paste0(ulapply(out$terms, lhs_resp), collapse = ",") + out$respform <- formula(paste0("mvbind(", out$respform, ") ~ 1")) + out$responses <- ulapply(out$terms, "[[", "resp") + out$rescor <- x$rescor + out$mecor <- x$mecor + out$cov_ranef <- x$cov_ranef + out +} + +# parse linear/additive formulas +# @param formula an ordinary model formula +# @return a 'btl' object +terms_lf <- function(formula) { + formula <- rhs(as.formula(formula)) + y <- nlist(formula) + formula <- terms(formula) + check_accidental_helper_functions(formula) + types <- setdiff(all_term_types(), excluded_term_types(formula)) + for (t in types) { + tmp <- do_call(paste0("terms_", t), list(formula)) + if (is.data.frame(tmp) || is.formula(tmp)) { + y[[t]] <- tmp + } + } + y$allvars <- allvars_formula( + get_allvars(y$fe), get_allvars(y$re), + get_allvars(y$cs), get_allvars(y$sp), + get_allvars(y$sm), get_allvars(y$gp), + get_allvars(y$ac), get_allvars(y$offset) + ) + environment(y$allvars) <- environment(formula) + structure(y, class = "btl") +} + +# parse non-linear formulas +# @param formula non-linear model formula +# @param nlpars names of all non-linear parameters +# @param resp optional name of a response variable +# @return a 'btnl' object +terms_nlf <- function(formula, nlpars, resp = "") { + if (!length(nlpars)) { + stop2("No non-linear parameters specified.") + } + loop <- !isFALSE(attr(formula, "loop")) + formula <- rhs(as.formula(formula)) + y <- nlist(formula) + all_vars <- all_vars(formula) + y$used_nlpars <- intersect(all_vars, nlpars) + covars <- setdiff(all_vars, nlpars) + y$covars <- structure(str2formula(covars), int = FALSE) + if (!"ac" %in% excluded_term_types(formula)) { + y$ac <- terms_ac(attr(formula, "autocor")) + } + y$allvars <- allvars_formula(covars, get_allvars(y$ac)) + environment(y$allvars) <- environment(formula) + y$loop <- loop + structure(y, class = "btnl") +} + +# extract addition arguments out of formula +# @return a list of formulas each containg a single addition term +terms_ad <- function(formula, family = NULL, check_response = TRUE) { + x <- list() + ad_funs <- lsp("brms", what = "exports", pattern = "^resp_") + ad_funs <- sub("^resp_", "", ad_funs) + families <- family_names(family) + if (is.family(family) && any(nzchar(families))) { + str_formula <- formula2str(formula) + ad <- get_matches("(?<=\\|)[^~]*(?=~)", str_formula, perl = TRUE) + valid_ads <- family_info(family, "ad") + if (length(ad)) { + ad_terms <- terms(str2formula(ad)) + if (length(attr(ad_terms, "offset"))) { + stop2("Offsets are not allowed in addition terms.") + } + ad_terms <- attr(ad_terms, "term.labels") + for (a in ad_funs) { + matches <- grep(paste0("^(resp_)?", a, "\\(.*\\)$"), ad_terms) + if (length(matches) == 1L) { + x[[a]] <- ad_terms[matches] + if (!grepl("^resp_", x[[a]])) { + x[[a]] <- paste0("resp_", x[[a]]) + } + ad_terms <- ad_terms[-matches] + if (!is.na(x[[a]]) && a %in% valid_ads) { + x[[a]] <- str2formula(x[[a]]) + } else { + stop2("Argument '", a, "' is not supported for ", + "family '", summary(family), "'.") + } + } else if (length(matches) > 1L) { + stop2("Each addition argument may only be defined once.") + } + } + if (length(ad_terms)) { + stop2("The following addition terms are invalid:\n", + collapse_comma(ad_terms)) + } + } + if (check_response && "wiener" %in% families && !is.formula(x$dec)) { + stop2("Addition argument 'dec' is required for family 'wiener'.") + } + if (is.formula(x$cat)) { + # 'cat' was replaced by 'thres' in brms 2.10.5 + x$thres <- x$cat + } + } + x +} + +# extract fixed effects terms +terms_fe <- function(formula) { + if (!is.terms(formula)) { + formula <- terms(formula) + } + all_terms <- all_terms(formula) + sp_terms <- find_terms(all_terms, "all", complete = FALSE) + re_terms <- all_terms[grepl("\\|", all_terms)] + int_term <- attr(formula, "intercept") + fe_terms <- setdiff(all_terms, c(sp_terms, re_terms)) + out <- paste(c(int_term, fe_terms), collapse = "+") + out <- str2formula(out) + attr(out, "allvars") <- allvars_formula(out) + attr(out, "decomp") <- get_decomp(formula) + if (has_rsv_intercept(out, has_intercept(formula))) { + attr(out, "int") <- FALSE + } + if (no_cmc(formula)) { + attr(out, "cmc") <- FALSE + } + if (no_center(formula)) { + attr(out, "center") <- FALSE + } + if (is_sparse(formula)) { + attr(out, "sparse") <- TRUE + } + out +} + +# gather information of group-level terms +# @return a data.frame with one row per group-level term +terms_re <- function(formula) { + re_terms <- get_re_terms(formula, brackets = FALSE) + if (!length(re_terms)) { + return(NULL) + } + re_terms <- split_re_terms(re_terms) + re_parts <- re_parts(re_terms) + out <- allvars <- vector("list", length(re_terms)) + type <- attr(re_terms, "type") + for (i in seq_along(re_terms)) { + gcall <- eval2(re_parts$rhs[i]) + form <- str2formula(re_parts$lhs[i]) + group <- paste0(gcall$type, collapse(gcall$groups)) + out[[i]] <- data.frame( + group = group, gtype = gcall$type, gn = i, + id = gcall$id, type = type[i], cor = gcall$cor, + stringsAsFactors = FALSE + ) + out[[i]]$gcall <- list(gcall) + out[[i]]$form <- list(form) + # gather all variables used in the group-level term + # at this point 'cs' terms are no longer recognized as such + ftype <- str_if(type[i] %in% "cs", "", type[i]) + re_allvars <- get_allvars(form, type = ftype) + allvars[[i]] <- allvars_formula(re_allvars, gcall$allvars) + } + out <- do_call(rbind, out) + out <- out[order(out$group), ] + attr(out, "allvars") <- allvars_formula(allvars) + if (no_cmc(formula)) { + # disabling cell-mean coding in all group-level terms + # has to come last to avoid removal of attributes + for (i in seq_rows(out)) { + attr(out$form[[i]], "cmc") <- FALSE + } + } + out +} + +# extract category specific terms for ordinal models +terms_cs <- function(formula) { + out <- find_terms(formula, "cs") + if (!length(out)) { + return(NULL) + } + out <- ulapply(out, eval2, envir = environment()) + out <- str2formula(out) + attr(out, "allvars") <- allvars_formula(out) + # do not test whether variables were supplied to 'cs' + # to allow category specific group-level intercepts + attr(out, "int") <- FALSE + out +} + +# extract special effects terms +terms_sp <- function(formula) { + types <- c("mo", "me", "mi") + out <- find_terms(formula, types, complete = FALSE) + if (!length(out)) { + return(NULL) + } + uni_mo <- trim_wsp(get_matches_expr(regex_sp("mo"), out)) + uni_me <- trim_wsp(get_matches_expr(regex_sp("me"), out)) + uni_mi <- trim_wsp(get_matches_expr(regex_sp("mi"), out)) + # remove the intercept as it is handled separately + out <- str2formula(c("0", out)) + attr(out, "int") <- FALSE + attr(out, "uni_mo") <- uni_mo + attr(out, "uni_me") <- uni_me + attr(out, "uni_mi") <- uni_mi + attr(out, "allvars") <- str2formula(all_vars(out)) + # TODO: do we need sp_fake_formula at all? + # attr(out, "allvars") <- sp_fake_formula(uni_mo, uni_me, uni_mi) + out +} + +# extract spline terms +terms_sm <- function(formula) { + out <- find_terms(formula, "sm") + if (!length(out)) { + return(NULL) + } + if (any(grepl("^(te|ti)\\(", out))) { + stop2("Tensor product smooths 'te' and 'ti' are not yet ", + "implemented in brms. Consider using 't2' instead.") + } + out <- str2formula(out) + attr(out, "allvars") <- mgcv::interpret.gam(out)$fake.formula + out +} + +# extract gaussian process terms +terms_gp <- function(formula) { + out <- find_terms(formula, "gp") + if (!length(out)) { + return(NULL) + } + eterms <- lapply(out, eval2, envir = environment()) + covars <- lapply(eterms, "[[", "term") + byvars <- lapply(eterms, "[[", "by") + allvars <- str2formula(unlist(c(covars, byvars))) + allvars <- str2formula(all_vars(allvars)) + if (!length(all_vars(allvars))) { + stop2("No variable supplied to function 'gp'.") + } + out <- str2formula(out) + attr(out, "allvars") <- allvars + out +} + +# extract autocorrelation terms +terms_ac <- function(formula) { + autocor <- attr(formula, "autocor") + out <- c(find_terms(formula, "ac"), find_terms(autocor, "ac")) + if (!length(out)) { + return(NULL) + } + eterms <- lapply(out, eval2, envir = environment()) + allvars <- unlist(c( + lapply(eterms, "[[", "time"), + lapply(eterms, "[[", "gr") + )) + allvars <- str2formula(all_vars(allvars)) + out <- str2formula(out) + attr(out, "allvars") <- allvars + out +} + +# extract offset terms +terms_offset <- function(formula) { + if (!is.terms(formula)) { + formula <- terms(as.formula(formula)) + } + pos <- attr(formula, "offset") + if (is.null(pos)) { + return(NULL) + } + vars <- attr(formula, "variables") + out <- ulapply(pos, function(i) deparse(vars[[i + 1]])) + out <- str2formula(out) + attr(out, "allvars") <- str2formula(all_vars(out)) + out +} + +# extract multiple covariates in multi-membership terms +terms_mmc <- function(formula) { + out <- find_terms(formula, "mmc") + if (!length(out)) { + return(NULL) + } + # remove the intercept as it is handled separately + out <- str2formula(c("0", out)) + attr(out, "allvars") <- allvars_formula(out) + attr(out, "int") <- FALSE + out +} + +# extract response variable names +# assumes multiple response variables to be combined via mvbind +terms_resp <- function(formula, check_names = TRUE) { + formula <- lhs(as.formula(formula)) + if (is.null(formula)) { + return(NULL) + } + expr <- validate_resp_formula(formula)[[2]] + if (length(expr) <= 1L) { + out <- deparse_no_string(expr) + } else { + str_fun <- deparse_no_string(expr[[1]]) + used_mvbind <- grepl("^(brms:::?)?mvbind$", str_fun) + if (used_mvbind) { + out <- ulapply(expr[-1], deparse_no_string) + } else { + out <- deparse_no_string(expr) + } + } + if (check_names) { + out <- make_stan_names(out) + } + out +} + +#' Checks if argument is a \code{brmsterms} object +#' +#' @param x An \R object +#' +#' @seealso \code{\link[brms:brmsterms]{brmsterms}} +#' +#' @export +is.brmsterms <- function(x) { + inherits(x, "brmsterms") +} + +#' Checks if argument is a \code{mvbrmsterms} object +#' +#' @param x An \R object +#' +#' @seealso \code{\link[brms:brmsterms]{brmsterms}} +#' +#' @export +is.mvbrmsterms <- function(x) { + inherits(x, "mvbrmsterms") +} + +is.btl <- function(x) { + inherits(x, "btl") +} + +is.btnl <- function(x) { + inherits(x, "btnl") +} + +# transform mvbrmsterms objects for use in stan_llh.brmsterms +as.brmsterms <- function(x) { + stopifnot(is.mvbrmsterms(x), x$rescor) + families <- ulapply(x$terms, function(y) y$family$family) + stopifnot(all(families == families[1])) + out <- structure(list(), class = "brmsterms") + out$family <- structure( + list(family = paste0(families[1], "_mv"), link = "identity"), + class = c("brmsfamily", "family") + ) + info <- get(paste0(".family_", families[1]))() + out$family[names(info)] <- info + out$sigma_pred <- any(ulapply(x$terms, + function(x) "sigma" %in% names(x$dpar) || is.formula(x$adforms$se) + )) + weight_forms <- rmNULL(lapply(x$terms, function(x) x$adforms$weights)) + if (length(weight_forms)) { + str_wf <- unique(ulapply(weight_forms, formula2str)) + if (length(str_wf) > 1L) { + stop2("All responses should use the same", + "weights if 'rescor' is estimated.") + } + out$adforms$weights <- weight_forms[[1]] + } + miforms <- rmNULL(lapply(x$terms, function(x) x$adforms$mi)) + if (length(miforms)) { + out$adforms$mi <- miforms[[1]] + } + out +} + +# names of supported term types +all_term_types <- function() { + c("fe", "re", "sp", "cs", "sm", "gp", "ac", "offset") +} + +# avoid ambiguous parameter names +# @param names names to check for ambiguity +# @param bterms a brmsterms object +avoid_dpars <- function(names, bterms) { + dpars <- c(names(bterms$dpars), "sp", "cs") + if (length(dpars)) { + dpars_prefix <- paste0("^", dpars, "_") + invalid <- any(ulapply(dpars_prefix, grepl, names)) + if (invalid) { + dpars <- paste0("'", dpars, "_'", collapse = ", ") + stop2("Variable names starting with ", dpars, + " are not allowed for this model.") + } + } + invisible(NULL) +} + +vars_prefix <- function() { + c("dpar", "resp", "nlpar") +} + +# check and tidy parameter prefixes +check_prefix <- function(x, keep_mu = FALSE) { + vpx <- vars_prefix() + if (is.data.frame(x) && nrow(x) == 0) { + # avoids a bug in data.frames with zero rows + x <- list() + } + x[setdiff(vpx, names(x))] <- "" + x <- x[vpx] + for (i in seq_along(x)) { + x[[i]] <- as.character(x[[i]]) + if (!length(x[[i]])) { + x[[i]] <- "" + } + x[[i]] <- ifelse( + !keep_mu & names(x)[i] == "dpar" & x[[i]] %in% "mu", + yes = "", no = x[[i]] + ) + x[[i]] <- ifelse( + keep_mu & names(x)[i] == "dpar" & x[[i]] %in% "", + yes = "mu", no = x[[i]] + ) + } + x +} + +# combined parameter prefixes +# @param prefix object from which to extract prefixes +# @param keep_mu keep the 'mu' prefix if available or remove it? +# @param nlp include the 'nlp' prefix for non-linear parameters? +combine_prefix <- function(prefix, keep_mu = FALSE, nlp = FALSE) { + prefix <- check_prefix(prefix, keep_mu = keep_mu) + if (is_nlpar(prefix) && nlp) { + prefix$dpar <- "nlp" + } + prefix <- lapply(prefix, usc) + sub("^_", "", do_call(paste0, prefix)) +} + +# check validity of fixed distributional parameters +check_fdpars <- function(x) { + stopifnot(is.null(x) || is.list(x)) + pos_pars <- c( + "sigma", "shape", "nu", "phi", "kappa", + "beta", "disc", "bs", "ndt", "theta" + ) + prob_pars <- c("zi", "hu", "bias", "quantile") + for (dp in names(x)) { + apc <- dpar_class(dp) + value <- x[[dp]]$value + if (apc %in% pos_pars && value < 0) { + stop2("Parameter '", dp, "' must be positive.") + } + if (apc %in% prob_pars && (value < 0 || value > 1)) { + stop2("Parameter '", dp, "' must be between 0 and 1.") + } + } + invisible(TRUE) +} + +# combine all variables in one formuula +# @param x (list of) formulas or character strings +# @return a formula with all variables on the right-hand side +allvars_formula <- function(...) { + out <- rmNULL(c(...)) + out <- collapse(ulapply(out, plus_rhs)) + all_vars <- all_vars(out) + invalid_vars <- setdiff(all_vars, make.names(all_vars)) + if (length(invalid_vars)) { + stop2("The following variable names are invalid: ", + collapse_comma(invalid_vars)) + } + str2formula(c(out, all_vars)) +} + +# conveniently extract a formula of all relevant variables +# @param x any object from which to extract 'allvars' +# @param type predictor type; requires a 'parse_' function +# @return a formula with all variables on the right-hand side +# or NULL if 'allvars' cannot be found +get_allvars <- function(x, type = "") { + out <- attr(x, "allvars", TRUE) + if (is.null(out) && "allvars" %in% names(x)) { + out <- x[["allvars"]] + } + if (is.null(out) && is.formula(x)) { + type <- as_one_character(type) + type <- str_if(nzchar(type), type, "fe") + terms_fun <- get(paste0("terms_", type), mode = "function") + out <- attr(terms_fun(x), "allvars") + } + stopifnot(is.null(out) || is.formula(out)) + out +} + +# add 'x' to the right-hand side of a formula +plus_rhs <- function(x) { + if (is.formula(x)) { + x <- sub("^[^~]*~", "", formula2str(x)) + } + if (length(x) && all(nzchar(x))) { + out <- paste0(" + ", paste(x, collapse = "+")) + } else { + out <- " + 1" + } + out +} + +# like stats::terms but keeps attributes if possible +terms <- function(formula, ...) { + old_attributes <- attributes(formula) + formula <- stats::terms(formula, ...) + new_attributes <- attributes(formula) + sel_names <- setdiff(names(old_attributes), names(new_attributes)) + attributes(formula)[sel_names] <- old_attributes[sel_names] + formula +} + +is.terms <- function(x) { + inherits(x, "terms") +} + +# combine formulas for distributional parameters +# @param formula1 primary formula from which to take the RHS +# @param formula2 secondary formula used to update the RHS of formula1 +# @param lhs character string to define the left-hand side of the output +# @param update a flag to indicate whether updating should be allowed. +# Defaults to FALSE to maintain backwards compatibility +# @return a formula object +combine_formulas <- function(formula1, formula2, lhs = "", update = FALSE) { + stopifnot(is.formula(formula1)) + stopifnot(is.null(formula2) || is.formula(formula2)) + lhs <- as_one_character(lhs) + update <- as_one_logical(update) + if (is.null(formula2)) { + rhs <- str_rhs(formula1) + att <- attributes(formula1) + } else if (update && has_terms(formula1)) { + # TODO: decide about intuitive updating behavior + if (get_nl(formula1) || get_nl(formula2)) { + stop2("Cannot combine non-linear formulas.") + } + old_formula <- eval2(paste0("~ ", str_rhs(formula1))) + new_formula <- eval2(paste0("~ . + ", str_rhs(formula2))) + rhs <- str_rhs(update(old_formula, new_formula)) + att <- attributes(formula1) + att[names(attributes(formula2))] <- attributes(formula2) + } else { + rhs <- str_rhs(formula2) + att <- attributes(formula2) + } + out <- eval2(paste0(lhs, " ~ ", rhs)) + attributes(out)[names(att)] <- att + out +} + +# does the formula contain any terms? +# @return TRUE or FALSE +has_terms <- function(formula) { + stopifnot(is.formula(formula)) + terms <- try(terms(rhs(formula)), silent = TRUE) + is(terms, "try-error") || + length(attr(terms, "term.labels")) || + length(attr(terms, "offset")) +} + +# has a linear formula any terms except overall effects? +has_special_terms <- function(x) { + if (!is.btl(x)) { + return(FALSE) + } + special_terms <- c("sp", "sm", "gp", "ac", "cs", "offset") + NROW(x[["re"]]) > 0 || any(lengths(x[special_terms])) +} + +# indicate if the predictor term belongs to a non-linear parameter +is_nlpar <- function(x) { + isTRUE(nzchar(x[["nlpar"]])) +} + +# indicate if the intercept should be removed +no_int <- function(x) { + isFALSE(attr(x, "int", exact = TRUE)) +} + +# indicate if cell mean coding should be disabled +no_cmc <- function(x) { + isFALSE(attr(x, "cmc", exact = TRUE)) +} + +# indicate if centering of the design matrix should be disabled +no_center <- function(x) { + isFALSE(attr(x, "center", exact = TRUE)) +} + +# indicate if the design matrix should be handled as sparse +is_sparse <- function(x) { + isTRUE(attr(x, "sparse", exact = TRUE)) +} + +# get the decomposition type of the design matrix +get_decomp <- function(x) { + out <- attr(x, "decomp", exact = TRUE) + if (is.null(out)) { + out <- "none" + } + as_one_character(out) +} + +# extract different types of effects +get_effect <- function(x, ...) { + UseMethod("get_effect") +} + +#' @export +get_effect.default <- function(x, ...) { + NULL +} + +#' @export +get_effect.brmsfit <- function(x, ...) { + get_effect(x$formula, ...) +} + +#' @export +get_effect.brmsformula <- function(x, ...) { + get_effect(brmsterms(x), ...) +} + +#' @export +get_effect.mvbrmsformula <- function(x, ...) { + get_effect(brmsterms(x), ...) +} + +#' @export +get_effect.mvbrmsterms <- function(x, ...) { + ulapply(x$terms, get_effect, recursive = FALSE, ...) +} + +# extract formulas of a certain effect type +# @param target effect type to return +# @param all logical; include effects of nlpars and dpars? +# @return a list of formulas +#' @export +get_effect.brmsterms <- function(x, target = "fe", ...) { + out <- named_list(c(names(x$dpars), names(x$nlpars))) + for (dp in names(x$dpars)) { + out[[dp]] <- get_effect(x$dpars[[dp]], target = target) + } + for (nlp in names(x$nlpars)) { + out[[nlp]] <- get_effect(x$nlpars[[nlp]], target = target) + } + unlist(out, recursive = FALSE) +} + +#' @export +get_effect.btl <- function(x, target = "fe", ...) { + x[[target]] +} + +#' @export +get_effect.btnl <- function(x, target = "fe", ...) { + NULL +} + +all_terms <- function(x) { + if (!length(x)) { + return(character(0)) + } + if (!is.terms(x)) { + x <- terms(as.formula(x)) + } + trim_wsp(attr(x, "term.labels")) +} + +# generate a regular expression to extract special terms +# @param type one or more special term types to be extracted +regex_sp <- function(type = "all") { + choices <- c("all", "sp", "sm", "gp", "cs", "mmc", "ac", all_sp_types()) + type <- unique(match.arg(type, choices, several.ok = TRUE)) + funs <- c( + sm = "(s|(t2)|(te)|(ti))", + gp = "gp", cs = "cse?", mmc = "mmc", + ac = "((arma)|(ar)|(ma)|(cosy)|(sar)|(car)|(fcor))" + ) + funs[all_sp_types()] <- all_sp_types() + if ("sp" %in% type) { + # allows extracting all 'sp' terms at once + type <- setdiff(type, "sp") + type <- union(type, all_sp_types()) + } + if ("all" %in% type) { + # allows extracting all special terms at once + type <- names(funs) + } + funs <- funs[type] + allow_colon <- c("cs", "mmc", "ac") + inner <- ifelse(names(funs) %in% allow_colon, ".*", "[^:]*") + out <- paste0("^(", funs, ")\\(", inner, "\\)$") + paste0("(", out, ")", collapse = "|") +} + +# find special terms of a certain type +# @param x formula object of character vector from which to extract terms +# @param type special terms type to be extracted. see regex_sp() +# @param complete check if terms consist completely of single special terms? +# @param ranef include group-level terms? +# @return a character vector of matching terms +find_terms <- function(x, type, complete = TRUE, ranef = FALSE) { + if (is.formula(x)) { + x <- all_terms(x) + } else { + x <- as.character(x) + } + complete <- as_one_logical(complete) + ranef <- as_one_logical(ranef) + regex <- regex_sp(type) + is_match <- grepl_expr(regex, x) + if (!ranef) { + is_match <- is_match & !grepl("\\|", x) + } + out <- x[is_match] + if (complete) { + matches <- lapply(out, get_matches_expr, pattern = regex) + # each term may contain only one special function call + inv <- out[lengths(matches) > 1L] + if (!length(inv)) { + # each term must be exactly equal to the special function call + inv <- out[trim_wsp(unlist(matches)) != out] + } + if (length(inv)) { + stop2("The term '", inv[1], "' is invalid in brms syntax.") + } + } + out +} + +# validate a terms object (or one that can be coerced to it) +# for use primarily in 'get_model_matrix' +# @param x any R object +# @return a (possibly amended) terms object or NULL +# if 'x' could not be coerced to a terms object +validate_terms <- function(x) { + no_int <- no_int(x) + no_cmc <- no_cmc(x) + if (is.formula(x) && !is.terms(x)) { + x <- terms(x) + } + if (!is.terms(x)) { + return(NULL) + } + if (no_int || !has_intercept(x) && no_cmc) { + # allows to remove the intercept without causing cell mean coding + attr(x, "intercept") <- 1 + attr(x, "int") <- FALSE + } + x +} + +# checks if the formula contains an intercept +has_intercept <- function(formula) { + if (is.terms(formula)) { + out <- as.logical(attr(formula, "intercept")) + } else { + formula <- as.formula(formula) + try_terms <- try(terms(formula), silent = TRUE) + if (is(try_terms, "try-error")) { + out <- FALSE + } else { + out <- as.logical(attr(try_terms, "intercept")) + } + } + out +} + +# check if model makes use of the reserved intercept variables +# @param has_intercept does the model have an intercept? +# if NULL this will be inferred from formula itself +has_rsv_intercept <- function(formula, has_intercept = NULL) { + .has_rsv_intercept <- function(terms, has_intercept) { + has_intercept <- as_one_logical(has_intercept) + intercepts <- c("intercept", "Intercept") + out <- !has_intercept && any(intercepts %in% all_vars(rhs(terms))) + return(out) + } + if (is.terms(formula)) { + if (is.null(has_intercept)) { + has_intercept <- has_intercept(formula) + } + return(.has_rsv_intercept(formula, has_intercept)) + } + formula <- try(as.formula(formula), silent = TRUE) + if (is(formula, "try-error")) { + return(FALSE) + } + if (is.null(has_intercept)) { + try_terms <- try(terms(formula), silent = TRUE) + if (is(try_terms, "try-error")) { + return(FALSE) + } + has_intercept <- has_intercept(try_terms) + } + .has_rsv_intercept(formula, has_intercept) +} + +# names of reserved variables +rsv_vars <- function(bterms) { + stopifnot(is.brmsterms(bterms) || is.mvbrmsterms(bterms)) + .rsv_vars <- function(x) { + rsv_int <- any(ulapply(x$dpars, has_rsv_intercept)) + if (rsv_int) c("intercept", "Intercept") else NULL + } + if (is.mvbrmsterms(bterms)) { + out <- unique(ulapply(bterms$terms, .rsv_vars)) + } else { + out <- .rsv_vars(bterms) + } + out +} + +# are category specific effects present? +has_cs <- function(bterms) { + length(get_effect(bterms, target = "cs")) > 0L || + any(get_re(bterms)$type %in% "cs") +} + +# check if category specific effects are allowed +check_cs <- function(bterms) { + stopifnot(is.btl(bterms) || is.btnl(bterms)) + if (has_cs(bterms)) { + if (!is_equal(dpar_class(bterms$dpar), "mu")) { + stop2("Category specific effects are only supported ", + "for the main parameter 'mu'.") + } + if (!(is.null(bterms$family) || allow_cs(bterms$family))) { + stop2("Category specific effects are not supported for this family.") + } + if (needs_ordered_cs(bterms$family)) { + warning2("Category specific effects for this family should be ", + "considered experimental and may have convergence issues.") + } + } + invisible(NULL) +} + +# check for the presence of helper functions accidentally used +# within a formula instead of added to bf(). See #1103 +check_accidental_helper_functions <- function(formula) { + terms <- all_terms(formula) + # see help("brmsformula-helpers") for the list of functions + funs <- c("nlf", "lf", "acformula", "set_nl", "set_rescor", "set_mecor") + regex <- paste0("(", funs, ")", collapse = "|") + regex <- paste0("^(", regex, ")\\(") + matches <- get_matches(regex, terms, first = TRUE) + matches <- sub("\\($", "", matches) + matches <- unique(matches) + matches <- matches[nzchar(matches)] + for (m in matches) { + loc <- utils::find(m, mode = "function") + if (is_equal(loc[1], "package:brms")) { + stop2("Function '", m, "' should not be part of the right-hand side ", + "of a formula. See help('brmsformula-helpers') for the correct syntax.") + } + } + invisible(TRUE) +} + +# extract names of variables added via the 'unused' argument +get_unused_arg_vars <- function(x, ...) { + UseMethod("get_unused_arg_vars") +} + +#' @export +get_unused_arg_vars.brmsformula <- function(x, ...) { + all_vars(attr(x$formula, "unused")) +} + +#' @export +get_unused_arg_vars.mvbrmsformula <- function(x, ...) { + unique(ulapply(x$forms, get_unused_arg_vars, ...)) +} + +#' @export +get_unused_arg_vars.brmsterms <- function(x, ...) { + all_vars(x$unused) +} + +#' @export +get_unused_arg_vars.mvbrmsterms <- function(x, ...) { + unique(ulapply(x$terms, get_unused_arg_vars, ...)) +} + +# extract elements from objects +# @param x object from which to extract elements +# @param name name of the element to be extracted +get_element <- function(x, name, ...) { + UseMethod("get_element") +} + +#' @export +get_element.default <- function(x, name, ...) { + x[[name]] +} + +#' @export +get_element.mvbrmsformula <- function(x, name, ...) { + lapply(x$forms, get_element, name = name, ...) +} + +#' @export +get_element.mvbrmsterms <- function(x, name, ...) { + lapply(x$terms, get_element, name = name, ...) +} diff -Nru r-cran-brms-2.16.3/R/conditional_effects.R r-cran-brms-2.17.0/R/conditional_effects.R --- r-cran-brms-2.16.3/R/conditional_effects.R 2021-08-26 17:47:33.000000000 +0000 +++ r-cran-brms-2.17.0/R/conditional_effects.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,1229 +1,1232 @@ -#' Display Conditional Effects of Predictors -#' -#' Display conditional effects of one or more numeric and/or categorical -#' predictors including two-way interaction effects. -#' -#' @aliases marginal_effects marginal_effects.brmsfit -#' -#' @param x An object of class \code{brmsfit}. -#' @param effects An optional character vector naming effects (main effects or -#' interactions) for which to compute conditional plots. Interactions are -#' specified by a \code{:} between variable names. If \code{NULL} (the -#' default), plots are generated for all main effects and two-way interactions -#' estimated in the model. When specifying \code{effects} manually, \emph{all} -#' two-way interactions (including grouping variables) may be plotted -#' even if not originally modeled. -#' @param conditions An optional \code{data.frame} containing variable values -#' to condition on. Each effect defined in \code{effects} will -#' be plotted separately for each row of \code{conditions}. Values in the -#' \code{cond__} column will be used as titles of the subplots. If \code{cond__} -#' is not given, the row names will be used for this purpose instead. -#' It is recommended to only define a few rows in order to keep the plots clear. -#' See \code{\link{make_conditions}} for an easy way to define conditions. -#' If \code{NULL} (the default), numeric variables will be conditionalized by -#' using their means and factors will get their first level assigned. -#' \code{NA} values within factors are interpreted as if all dummy -#' variables of this factor are zero. This allows, for instance, to make -#' predictions of the grand mean when using sum coding. -#' @param int_conditions An optional named \code{list} whose elements are -#' vectors of values of the variables specified in \code{effects}. -#' At these values, predictions are evaluated. The names of -#' \code{int_conditions} have to match the variable names exactly. -#' Additionally, the elements of the vectors may be named themselves, -#' in which case their names appear as labels for the conditions in the plots. -#' Instead of vectors, functions returning vectors may be passed and are -#' applied on the original values of the corresponding variable. -#' If \code{NULL} (the default), predictions are evaluated at the -#' \eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at -#' all categories for factor-like predictors. -#' @param re_formula A formula containing group-level effects to be considered -#' in the conditional predictions. If \code{NULL}, include all group-level -#' effects; if \code{NA} (default), include no group-level effects. -#' @param robust If \code{TRUE} (the default) the median is used as the -#' measure of central tendency. If \code{FALSE} the mean is used instead. -#' @param prob A value between 0 and 1 indicating the desired probability -#' to be covered by the uncertainty intervals. The default is 0.95. -#' @param probs (Deprecated) The quantiles to be used in the computation of -#' uncertainty intervals. Please use argument \code{prob} instead. -#' @param method Method used to obtain predictions. Can be set to -#' \code{"posterior_epred"} (the default), \code{"posterior_predict"}, -#' or \code{"posterior_linpred"}. For more details, see the respective -#' function documentations. -#' @param spaghetti Logical. Indicates if predictions should -#' be visualized via spaghetti plots. Only applied for numeric -#' predictors. If \code{TRUE}, it is recommended -#' to set argument \code{ndraws} to a relatively small value -#' (e.g., \code{100}) in order to reduce computation time. -#' @param surface Logical. Indicates if interactions or -#' two-dimensional smooths should be visualized as a surface. -#' Defaults to \code{FALSE}. The surface type can be controlled -#' via argument \code{stype} of the related plotting method. -#' @param categorical Logical. Indicates if effects of categorical -#' or ordinal models should be shown in terms of probabilities -#' of response categories. Defaults to \code{FALSE}. -#' @param ordinal (Deprecated) Please use argument \code{categorical}. -#' Logical. Indicates if effects in ordinal models -#' should be visualized as a raster with the response categories -#' on the y-axis. Defaults to \code{FALSE}. -#' @param transform A function or a character string naming -#' a function to be applied on the predicted responses -#' before summary statistics are computed. Only allowed -#' if \code{method = "posterior_predict"}. -#' @param resolution Number of support points used to generate -#' the plots. Higher resolution leads to smoother plots. -#' Defaults to \code{100}. If \code{surface} is \code{TRUE}, -#' this implies \code{10000} support points for interaction terms, -#' so it might be necessary to reduce \code{resolution} -#' when only few RAM is available. -#' @param too_far Positive number. -#' For surface plots only: Grid points that are too -#' far away from the actual data points can be excluded from the plot. -#' \code{too_far} determines what is too far. The grid is scaled into -#' the unit square and then grid points more than \code{too_far} -#' from the predictor variables are excluded. By default, all -#' grid points are used. Ignored for non-surface plots. -#' @param select_points Positive number. -#' Only relevant if \code{points} or \code{rug} are set to \code{TRUE}: -#' Actual data points of numeric variables that -#' are too far away from the values specified in \code{conditions} -#' can be excluded from the plot. Values are scaled into -#' the unit interval and then points more than \code{select_points} -#' from the values in \code{conditions} are excluded. -#' By default, all points are used. -#' @param ... Further arguments such as \code{draw_ids} or \code{ndraws} -#' passed to \code{\link{posterior_predict}} or \code{\link{posterior_epred}}. -#' @inheritParams plot.brmsfit -#' @param ncol Number of plots to display per column for each effect. -#' If \code{NULL} (default), \code{ncol} is computed internally based -#' on the number of rows of \code{conditions}. -#' @param points Logical. Indicates if the original data points -#' should be added via \code{\link{geom_jitter}}. -#' Default is \code{FALSE}. Note that only those data points will be added -#' that match the specified conditions defined in \code{conditions}. -#' For categorical predictors, the conditions have to match exactly. -#' For numeric predictors, argument \code{select_points} is used to -#' determine, which points do match a condition. -#' @param rug Logical. Indicates if a rug representation of predictor -#' values should be added via \code{\link{geom_rug}}. -#' Default is \code{FALSE}. Depends on \code{select_points} in the same -#' way as \code{points} does. -#' @param mean Logical. Only relevant for spaghetti plots. -#' If \code{TRUE} (the default), display the mean regression -#' line on top of the regression lines for each sample. -#' @param jitter_width Only used if \code{points = TRUE}: -#' Amount of horizontal jittering of the data points. -#' Mainly useful for ordinal models. Defaults to \code{0} that -#' is no jittering. -#' @param stype Indicates how surface plots should be displayed. -#' Either \code{"contour"} or \code{"raster"}. -#' @param line_args Only used in plots of continuous predictors: -#' A named list of arguments passed to -#' \code{\link{geom_smooth}}. -#' @param cat_args Only used in plots of categorical predictors: -#' A named list of arguments passed to -#' \code{\link{geom_point}}. -#' @param errorbar_args Only used in plots of categorical predictors: -#' A named list of arguments passed to -#' \code{\link{geom_errorbar}}. -#' @param surface_args Only used in surface plots: -#' A named list of arguments passed to -#' \code{\link{geom_contour}} or -#' \code{\link{geom_raster}} -#' (depending on argument \code{stype}). -#' @param spaghetti_args Only used in spaghetti plots: -#' A named list of arguments passed to -#' \code{\link{geom_smooth}}. -#' @param point_args Only used if \code{points = TRUE}: -#' A named list of arguments passed to -#' \code{\link{geom_jitter}}. -#' @param rug_args Only used if \code{rug = TRUE}: -#' A named list of arguments passed to -#' \code{\link{geom_rug}}. -#' @param facet_args Only used if if multiple condtions are provided: -#' A named list of arguments passed to -#' \code{\link{facet_wrap}}. -#' -#' @return An object of class \code{'brms_conditional_effects'} which is a -#' named list with one data.frame per effect containing all information -#' required to generate conditional effects plots. Among others, these -#' data.frames contain some special variables, namely \code{estimate__} -#' (predicted values of the response), \code{se__} (standard error of the -#' predicted response), \code{lower__} and \code{upper__} (lower and upper -#' bounds of the uncertainty interval of the response), as well as -#' \code{cond__} (used in faceting when \code{conditions} contains multiple -#' rows). -#' -#' The corresponding \code{plot} method returns a named -#' list of \code{\link{ggplot}} objects, which can be further -#' customized using the \pkg{ggplot2} package. -#' -#' @details When creating \code{conditional_effects} for a particular predictor -#' (or interaction of two predictors), one has to choose the values of all -#' other predictors to condition on. By default, the mean is used for -#' continuous variables and the reference category is used for factors, but -#' you may change these values via argument \code{conditions}. This also has -#' an implication for the \code{points} argument: In the created plots, only -#' those points will be shown that correspond to the factor levels actually -#' used in the conditioning, in order not to create the false impression of -#' bad model fit, where it is just due to conditioning on certain factor -#' levels. -#' -#' To fully change colors of the created plots, one has to amend both -#' \code{scale_colour} and \code{scale_fill}. See -#' \code{\link{scale_colour_grey}} or \code{\link{scale_colour_gradient}} for -#' more details. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt + (1 | patient), -#' data = epilepsy, family = poisson()) -#' -#' ## plot all conditional effects -#' plot(conditional_effects(fit), ask = FALSE) -#' -#' ## change colours to grey scale -#' library(ggplot2) -#' me <- conditional_effects(fit, "zBase:Trt") -#' plot(me, plot = FALSE)[[1]] + -#' scale_color_grey() + -#' scale_fill_grey() -#' -#' ## only plot the conditional interaction effect of 'zBase:Trt' -#' ## for different values for 'zAge' -#' conditions <- data.frame(zAge = c(-1, 0, 1)) -#' plot(conditional_effects(fit, effects = "zBase:Trt", -#' conditions = conditions)) -#' -#' ## also incorporate group-level effects variance over patients -#' ## also add data points and a rug representation of predictor values -#' plot(conditional_effects(fit, effects = "zBase:Trt", -#' conditions = conditions, re_formula = NULL), -#' points = TRUE, rug = TRUE) -#' -#' ## change handling of two-way interactions -#' int_conditions <- list( -#' zBase = setNames(c(-2, 1, 0), c("b", "c", "a")) -#' ) -#' conditional_effects(fit, effects = "Trt:zBase", -#' int_conditions = int_conditions) -#' conditional_effects(fit, effects = "Trt:zBase", -#' int_conditions = list(zBase = quantile)) -#' -#' ## fit a model to illustrate how to plot 3-way interactions -#' fit3way <- brm(count ~ zAge * zBase * Trt, data = epilepsy) -#' conditions <- make_conditions(fit3way, "zAge") -#' conditional_effects(fit3way, "zBase:Trt", conditions = conditions) -#' ## only include points close to the specified values of zAge -#' me <- conditional_effects( -#' fit3way, "zBase:Trt", conditions = conditions, -#' select_points = 0.1 -#' ) -#' plot(me, points = TRUE) -#' } -#' -#' @export -conditional_effects.brmsfit <- function(x, effects = NULL, conditions = NULL, - int_conditions = NULL, re_formula = NA, - prob = 0.95, robust = TRUE, - method = "posterior_epred", - spaghetti = FALSE, surface = FALSE, - categorical = FALSE, ordinal = FALSE, - transform = NULL, resolution = 100, - select_points = 0, too_far = 0, - probs = NULL, ...) { - probs <- validate_ci_bounds(prob, probs = probs) - method <- validate_pp_method(method) - spaghetti <- as_one_logical(spaghetti) - surface <- as_one_logical(surface) - categorical <- as_one_logical(categorical) - ordinal <- as_one_logical(ordinal) - contains_draws(x) - x <- restructure(x) - new_formula <- update_re_terms(x$formula, re_formula = re_formula) - bterms <- brmsterms(new_formula) - - if (!is.null(transform) && method != "posterior_predict") { - stop2("'transform' is only allowed if 'method = posterior_predict'.") - } - if (ordinal) { - warning2("Argument 'ordinal' is deprecated. ", - "Please use 'categorical' instead.") - } - rsv_vars <- rsv_vars(bterms) - use_def_effects <- is.null(effects) - if (use_def_effects) { - effects <- get_all_effects(bterms, rsv_vars = rsv_vars) - } else { - # allow to define interactions in any order - effects <- strsplit(as.character(effects), split = ":") - if (any(unique(unlist(effects)) %in% rsv_vars)) { - stop2("Variables ", collapse_comma(rsv_vars), - " should not be used as effects for this model") - } - if (any(lengths(effects) > 2L)) { - stop2("To display interactions of order higher than 2 ", - "please use the 'conditions' argument.") - } - all_effects <- get_all_effects( - bterms, rsv_vars = rsv_vars, comb_all = TRUE - ) - ae_coll <- all_effects[lengths(all_effects) == 1L] - ae_coll <- ulapply(ae_coll, paste, collapse = ":") - matches <- match(lapply(all_effects, sort), lapply(effects, sort), 0L) - if (sum(matches) > 0 && sum(matches > 0) < length(effects)) { - invalid <- effects[setdiff(seq_along(effects), sort(matches))] - invalid <- ulapply(invalid, paste, collapse = ":") - warning2( - "Some specified effects are invalid for this model: ", - collapse_comma(invalid), "\nValid effects are ", - "(combinations of): ", collapse_comma(ae_coll) - ) - } - effects <- unique(effects[sort(matches)]) - if (!length(effects)) { - stop2( - "All specified effects are invalid for this model.\n", - "Valid effects are (combinations of): ", - collapse_comma(ae_coll) - ) - } - } - if (categorical || ordinal) { - int_effs <- lengths(effects) == 2L - if (any(int_effs)) { - effects <- effects[!int_effs] - warning2( - "Interactions cannot be plotted directly if 'categorical' ", - "is TRUE. Please use argument 'conditions' instead." - ) - } - } - if (!length(effects)) { - stop2("No valid effects detected.") - } - mf <- model.frame(x) - conditions <- prepare_conditions( - x, conditions = conditions, effects = effects, - re_formula = re_formula, rsv_vars = rsv_vars - ) - int_conditions <- lapply(int_conditions, - function(x) if (is.numeric(x)) sort(x, TRUE) else x - ) - int_vars <- get_int_vars(bterms) - group_vars <- get_group_vars(bterms) - out <- list() - for (i in seq_along(effects)) { - eff <- effects[[i]] - cond_data <- prepare_cond_data( - mf[, eff, drop = FALSE], conditions = conditions, - int_conditions = int_conditions, int_vars = int_vars, - group_vars = group_vars, surface = surface, - resolution = resolution, reorder = use_def_effects - ) - if (surface && length(eff) == 2L && too_far > 0) { - # exclude prediction grid points too far from data - ex_too_far <- mgcv::exclude.too.far( - g1 = cond_data[[eff[1]]], - g2 = cond_data[[eff[2]]], - d1 = mf[, eff[1]], - d2 = mf[, eff[2]], - dist = too_far) - cond_data <- cond_data[!ex_too_far, ] - } - c(out) <- conditional_effects( - bterms, fit = x, cond_data = cond_data, method = method, - surface = surface, spaghetti = spaghetti, categorical = categorical, - ordinal = ordinal, re_formula = re_formula, transform = transform, - conditions = conditions, int_conditions = int_conditions, - select_points = select_points, probs = probs, robust = robust, - ... - ) - } - structure(out, class = "brms_conditional_effects") -} - -#' @rdname conditional_effects.brmsfit -#' @export -conditional_effects <- function(x, ...) { - UseMethod("conditional_effects") -} - -# compute expected values of MV models for use in conditional_effects -# @return a list of summarized prediction matrices -#' @export -conditional_effects.mvbrmsterms <- function(x, resp = NULL, ...) { - resp <- validate_resp(resp, x$responses) - x$terms <- x$terms[resp] - out <- lapply(x$terms, conditional_effects, ...) - unlist(out, recursive = FALSE) -} - -# conditional_effects for univariate model -# @return a list with the summarized prediction matrix as the only element -# @note argument 'resp' exists only to be excluded from '...' (#589) -#' @export -conditional_effects.brmsterms <- function( - x, fit, cond_data, int_conditions, method, surface, - spaghetti, categorical, ordinal, probs, robust, - dpar = NULL, nlpar = NULL, resp = NULL, ... -) { - stopifnot(is.brmsfit(fit)) - effects <- attr(cond_data, "effects") - types <- attr(cond_data, "types") - catscale <- NULL - pred_args <- list( - fit, newdata = cond_data, allow_new_levels = TRUE, - dpar = dpar, nlpar = nlpar, resp = if (nzchar(x$resp)) x$resp, - incl_autocor = FALSE, ... - ) - if (method != "posterior_predict") { - # 'transform' creates problems in 'posterior_linpred' - pred_args$transform <- NULL - } - out <- do_call(method, pred_args) - rownames(cond_data) <- NULL - - if (categorical || ordinal) { - if (method != "posterior_epred") { - stop2("Can only use 'categorical' with method = 'posterior_epred'.") - } - if (!is_polytomous(x)) { - stop2("Argument 'categorical' may only be used ", - "for categorical or ordinal models.") - } - if (categorical && ordinal) { - stop2("Please use argument 'categorical' instead of 'ordinal'.") - } - catscale <- str_if(is_multinomial(x), "Count", "Probability") - cats <- dimnames(out)[[3]] - if (is.null(cats)) cats <- seq_dim(out, 3) - cond_data <- repl(cond_data, length(cats)) - cond_data <- do_call(rbind, cond_data) - cond_data$cats__ <- factor(rep(cats, each = ncol(out)), levels = cats) - effects[2] <- "cats__" - types[2] <- "factor" - } else { - if (conv_cats_dpars(x$family) && is.null(dpar)) { - stop2("Please set 'categorical' to TRUE.") - } - if (is_ordinal(x$family) && is.null(dpar) && method != "posterior_linpred") { - warning2( - "Predictions are treated as continuous variables in ", - "'conditional_effects' by default which is likely invalid ", - "for ordinal families. Please set 'categorical' to TRUE." - ) - if (method == "posterior_epred") { - out <- ordinal_probs_continuous(out) - } - } - } - - cond_data <- add_effects__(cond_data, effects) - first_numeric <- types[1] %in% "numeric" - second_numeric <- types[2] %in% "numeric" - both_numeric <- first_numeric && second_numeric - if (second_numeric && !surface) { - # only convert 'effect2__' to factor so that the original - # second effect variable remains unchanged in the data - mde2 <- round(cond_data[[effects[2]]], 2) - levels2 <- sort(unique(mde2), TRUE) - cond_data$effect2__ <- factor(mde2, levels = levels2) - labels2 <- names(int_conditions[[effects[2]]]) - if (length(labels2) == length(levels2)) { - levels(cond_data$effect2__) <- labels2 - } - } - - spag <- NULL - if (first_numeric && spaghetti) { - if (surface) { - stop2("Cannot use 'spaghetti' and 'surface' at the same time.") - } - spag <- out - if (categorical) { - spag <- do_call(cbind, array2list(spag)) - } - sample <- rep(seq_rows(spag), each = ncol(spag)) - if (length(types) == 2L) { - # draws should be unique across plotting groups - sample <- paste0(sample, "_", cond_data[[effects[2]]]) - } - spag <- data.frame(as.numeric(t(spag)), factor(sample)) - colnames(spag) <- c("estimate__", "sample__") - spag <- cbind(cond_data, spag) - } - - out <- posterior_summary(out, probs = probs, robust = robust) - if (categorical || ordinal) { - out <- do_call(rbind, array2list(out)) - } - colnames(out) <- c("estimate__", "se__", "lower__", "upper__") - out <- cbind(cond_data, out) - if (!is.null(dpar)) { - response <- dpar - } else if (!is.null(nlpar)) { - response <- nlpar - } else { - response <- as.character(x$formula[2]) - } - attr(out, "effects") <- effects - attr(out, "response") <- response - attr(out, "surface") <- unname(both_numeric && surface) - attr(out, "categorical") <- categorical - attr(out, "catscale") <- catscale - attr(out, "ordinal") <- ordinal - attr(out, "spaghetti") <- spag - attr(out, "points") <- make_point_frame(x, fit$data, effects, ...) - name <- paste0(usc(x$resp, "suffix"), paste0(effects, collapse = ":")) - setNames(list(out), name) -} - -# get combinations of variables used in predictor terms -# @param ... character vectors or formulas -# @param alist a list of character vectors or formulas -get_var_combs <- function(..., alist = list()) { - dots <- c(list(...), alist) - for (i in seq_along(dots)) { - if (is.formula(dots[[i]])) { - dots[[i]] <- attr(terms(dots[[i]]), "term.labels") - } - dots[[i]] <- lapply(dots[[i]], all_vars) - } - unique(unlist(dots, recursive = FALSE)) -} - -# extract combinations of predictor variables -get_all_effects <- function(x, ...) { - UseMethod("get_all_effects") -} - -#' @export -get_all_effects.default <- function(x, ...) { - NULL -} - -#' @export -get_all_effects.mvbrmsterms <- function(x, ...) { - out <- lapply(x$terms, get_all_effects, ...) - unique(unlist(out, recursive = FALSE)) -} - -# get all effects for use in conditional_effects -# @param bterms object of class brmsterms -# @param rsv_vars character vector of reserved variables -# @param comb_all include all main effects and two-way interactions? -# @return a list with one element per valid effect / effects combination -# excludes all 3-way or higher interactions -#' @export -get_all_effects.brmsterms <- function(x, rsv_vars = NULL, comb_all = FALSE) { - stopifnot(is.atomic(rsv_vars)) - out <- list() - for (dp in names(x$dpars)) { - out <- c(out, get_all_effects(x$dpars[[dp]])) - } - for (nlp in names(x$nlpars)) { - out <- c(out, get_all_effects(x$nlpars[[nlp]])) - } - out <- rmNULL(lapply(out, setdiff, y = rsv_vars)) - if (comb_all) { - # allow to combine all variables with each other - out <- unique(unlist(out)) - out <- c(out, get_group_vars(x)) - if (length(out)) { - int <- expand.grid(out, out, stringsAsFactors = FALSE) - int <- int[int[, 1] != int[, 2], ] - int <- as.list(as.data.frame(t(int), stringsAsFactors = FALSE)) - int <- unique(unname(lapply(int, sort))) - out <- c(as.list(out), int) - } - } - unique(out[lengths(out) <= 2L]) -} - -#' @export -get_all_effects.btl <- function(x, ...) { - c(get_var_combs(x[["fe"]], x[["cs"]]), - get_all_effects_type(x, "sp"), - get_all_effects_type(x, "sm"), - get_all_effects_type(x, "gp")) -} - -# extract variable combinations from special terms -get_all_effects_type <- function(x, type) { - stopifnot(is.btl(x)) - type <- as_one_character(type) - regex_type <- regex_sp(type) - terms <- all_terms(x[[type]]) - out <- named_list(terms) - for (i in seq_along(terms)) { - # some special terms can appear within interactions - # we did not allow ":" within these terms so we can use it for splitting - term_parts <- unlist(strsplit(terms[i], split = ":")) - vars <- vector("list", length(term_parts)) - for (j in seq_along(term_parts)) { - if (grepl_expr(regex_type, term_parts[j])) { - # evaluate a special term to extract variables - tmp <- eval2(term_parts[j]) - vars[[j]] <- setdiff(unique(c(tmp$term, tmp$by)), "NA") - } else { - # extract all variables from an ordinary term - vars[[j]] <- all_vars(term_parts[j]) - } - } - vars <- unique(unlist(vars)) - out[[i]] <- str2formula(vars, collapse = "*") - } - get_var_combs(alist = out) -} - -#' @export -get_all_effects.btnl <- function(x, ...) { - covars <- all_vars(rhs(x$covars)) - out <- as.list(covars) - if (length(covars) > 1L) { - c(out) <- utils::combn(covars, 2, simplify = FALSE) - } - unique(out) -} - -# extract names of predictor variables -get_pred_vars <- function(x) { - unique(unlist(get_all_effects(x))) -} - -# extract names of variables treated as integers -get_int_vars <- function(x, ...) { - UseMethod("get_int_vars") -} - -#' @export -get_int_vars.mvbrmsterms <- function(x, ...) { - unique(ulapply(x$terms, get_int_vars)) -} - -#' @export -get_int_vars.brmsterms <- function(x, ...) { - advars <- ulapply(rmNULL(x$adforms[c("trials", "thres", "vint")]), all_vars) - unique(c(advars, get_sp_vars(x, "mo"))) -} - -# transform posterior draws of ordinal probabilities to a -# continuous scale assuming equidistance between adjacent categories -# @param x an ndraws x nobs x ncat array of posterior draws -# @return an ndraws x nobs matrix of posterior draws -ordinal_probs_continuous <- function(x) { - stopifnot(length(dim(x)) == 3) - for (k in seq_dim(x, 3)) { - x[, , k] <- x[, , k] * k - } - x <- lapply(seq_dim(x, 2), function(s) rowSums(x[, s, ])) - do_call(cbind, x) -} - -#' Prepare Fully Crossed Conditions -#' -#' This is a helper function to prepare fully crossed conditions primarily -#' for use with the \code{conditions} argument of \code{\link{conditional_effects}}. -#' Automatically creates labels for each row in the \code{cond__} column. -#' -#' @param x An \R object from which to extract the variables -#' that should be part of the conditions. -#' @param vars Names of the variables that should be part of the conditions. -#' @param ... Arguments passed to \code{\link{rows2labels}}. -#' -#' @return A \code{data.frame} where each row indicates a condition. -#' -#' @details For factor like variables, all levels are used as conditions. -#' For numeric variables, \code{mean + (-1:1) * SD} are used as conditions. -#' -#' @seealso \code{\link{conditional_effects}}, \code{\link{rows2labels}} -#' -#' @examples -#' df <- data.frame(x = c("a", "b"), y = rnorm(10)) -#' make_conditions(df, vars = c("x", "y")) -#' -#' @export -make_conditions <- function(x, vars, ...) { - # rev ensures that the last variable varies fastest in expand.grid - vars <- rev(as.character(vars)) - if (!is.data.frame(x) && "data" %in% names(x)) { - x <- x$data - } - x <- as.data.frame(x) - out <- named_list(vars) - for (v in vars) { - tmp <- get(v, x) - if (is_like_factor(tmp)) { - tmp <- levels(as.factor(tmp)) - } else { - tmp <- mean(tmp, na.rm = TRUE) + (-1:1) * sd(tmp, na.rm = TRUE) - } - out[[v]] <- tmp - } - out <- rev(expand.grid(out)) - out$cond__ <- rows2labels(out, ...) - out -} - -# extract the cond__ variable used for faceting -get_cond__ <- function(x) { - out <- x[["cond__"]] - if (is.null(out)) { - out <- rownames(x) - } - as.character(out) -} - -#' Convert Rows to Labels -#' -#' Convert information in rows to labels for each row. -#' -#' @param x A \code{data.frame} for which to extract labels. -#' @param digits Minimal number of decimal places shown in -#' the labels of numeric variables. -#' @param sep A single character string defining the separator -#' between variables used in the labels. -#' @param incl_vars Indicates if variable names should -#' be part of the labels. Defaults to \code{TRUE}. -#' @param ... Currently unused. -#' -#' @return A character vector of the same length as the number -#' of rows of \code{x}. -#' -#' @seealso \code{\link{make_conditions}}, \code{\link{conditional_effects}} -#' -#' @export -rows2labels <- function(x, digits = 2, sep = " & ", incl_vars = TRUE, ...) { - x <- as.data.frame(x) - incl_vars <- as_one_logical(incl_vars) - out <- x - for (i in seq_along(out)) { - if (!is_like_factor(out[[i]])) { - out[[i]] <- round(out[[i]], digits) - } - if (incl_vars) { - out[[i]] <- paste0(names(out)[i], " = ", out[[i]]) - } - } - paste_sep <- function(..., sep__ = sep) { - paste(..., sep = sep__) - } - Reduce(paste_sep, out) -} - -# prepare conditions for use in conditional_effects -# @param fit an object of class 'brmsfit' -# @param conditions optional data.frame containing user defined conditions -# @param effects see conditional_effects -# @param re_formula see conditional_effects -# @param rsv_vars names of reserved variables -# @return a data.frame with (possibly updated) conditions -prepare_conditions <- function(fit, conditions = NULL, effects = NULL, - re_formula = NA, rsv_vars = NULL) { - mf <- model.frame(fit) - new_formula <- update_re_terms(fit$formula, re_formula = re_formula) - bterms <- brmsterms(new_formula) - if (any(grepl_expr("^(as\\.)?factor(.+)$", bterms$allvars))) { - # conditions are chosen based the variables stored in the data - # this approach cannot take into account possible transformations - # to factors happening inside the model formula - warning2( - "Using 'factor' or 'as.factor' in the model formula ", - "might lead to problems in 'conditional_effects'.", - "Please convert your variables to factors beforehand." - ) - } - req_vars <- all_vars(rhs(bterms$allvars)) - req_vars <- setdiff(req_vars, rsv_vars) - req_vars <- setdiff(req_vars, names(fit$data2)) - if (is.null(conditions)) { - conditions <- as.data.frame(as.list(rep(NA, length(req_vars)))) - names(conditions) <- req_vars - } else { - conditions <- as.data.frame(conditions) - if (!nrow(conditions)) { - stop2("Argument 'conditions' must have a least one row.") - } - conditions <- unique(conditions) - if (any(duplicated(get_cond__(conditions)))) { - stop2("Condition labels should be unique.") - } - req_vars <- setdiff(req_vars, names(conditions)) - } - # special treatment for 'trials' addition variables - trial_vars <- all_vars(bterms$adforms$trials) - trial_vars <- trial_vars[!vars_specified(trial_vars, conditions)] - if (length(trial_vars)) { - message("Setting all 'trials' variables to 1 by ", - "default if not specified otherwise.") - req_vars <- setdiff(req_vars, trial_vars) - for (v in trial_vars) { - conditions[[v]] <- 1L - } - } - # use sensible default values for unspecified variables - subset_vars <- get_ad_vars(bterms, "subset") - int_vars <- get_int_vars(bterms) - group_vars <- get_group_vars(bterms) - req_vars <- setdiff(req_vars, group_vars) - for (v in req_vars) { - if (is_like_factor(mf[[v]])) { - # factor-like variable - if (v %in% subset_vars) { - # avoid unintentional subsetting of newdata (#755) - conditions[[v]] <- TRUE - } else { - # use reference category for factors - levels <- levels(as.factor(mf[[v]])) - ordered <- is.ordered(mf[[v]]) - conditions[[v]] <- factor(levels[1], levels, ordered = ordered) - } - } else { - # numeric-like variable - if (v %in% subset_vars) { - # avoid unintentional subsetting of newdata (#755) - conditions[[v]] <- 1 - } else if (v %in% int_vars) { - # ensure valid integer values - conditions[[v]] <- round(median(mf[[v]], na.rm = TRUE)) - } else { - conditions[[v]] <- mean(mf[[v]], na.rm = TRUE) - } - } - } - all_vars <- c(all_vars(bterms$allvars), "cond__") - unused_vars <- setdiff(names(conditions), all_vars) - if (length(unused_vars)) { - warning2( - "The following variables in 'conditions' are not ", - "part of the model:\n", collapse_comma(unused_vars) - ) - } - cond__ <- conditions$cond__ - conditions <- validate_newdata( - conditions, fit, re_formula = re_formula, - allow_new_levels = TRUE, check_response = FALSE, - incl_autocor = FALSE - ) - conditions$cond__ <- cond__ - conditions -} - -# prepare data to be used in conditional_effects -# @param data data.frame containing only data of the predictors of interest -# @param conditions see argument 'conditions' of conditional_effects -# @param int_conditions see argument 'int_conditions' of conditional_effects -# @param int_vars names of variables being treated as integers -# @param group_vars names of grouping variables -# @param surface generate surface plots later on? -# @param resolution number of distinct points at which to evaluate -# the predictors of interest -# @param reorder reorder predictors so that numeric ones come first? -prepare_cond_data <- function(data, conditions, int_conditions = NULL, - int_vars = NULL, group_vars = NULL, - surface = FALSE, resolution = 100, - reorder = TRUE) { - effects <- names(data) - stopifnot(length(effects) %in% c(1L, 2L)) - is_factor <- ulapply(data, is_like_factor) | names(data) %in% group_vars - types <- ifelse(is_factor, "factor", "numeric") - # numeric effects should come first - if (reorder) { - new_order <- order(types, decreasing = TRUE) - effects <- effects[new_order] - types <- types[new_order] - } - # handle first predictor - if (effects[1] %in% names(int_conditions)) { - # first predictor has pre-specified conditions - int_cond <- int_conditions[[effects[1]]] - if (is.function(int_cond)) { - int_cond <- int_cond(data[[effects[1]]]) - } - values <- int_cond - } else if (types[1] == "factor") { - # first predictor is factor-like - values <- factor(unique(data[[effects[1]]])) - } else { - # first predictor is numeric - min1 <- min(data[[effects[1]]], na.rm = TRUE) - max1 <- max(data[[effects[1]]], na.rm = TRUE) - if (effects[1] %in% int_vars) { - values <- seq(min1, max1, by = 1) - } else { - values <- seq(min1, max1, length.out = resolution) - } - } - if (length(effects) == 2L) { - # handle second predictor - values <- setNames(list(values, NA), effects) - if (effects[2] %in% names(int_conditions)) { - # second predictor has pre-specified conditions - int_cond <- int_conditions[[effects[2]]] - if (is.function(int_cond)) { - int_cond <- int_cond(data[[effects[2]]]) - } - values[[2]] <- int_cond - } else if (types[2] == "factor") { - # second predictor is factor-like - values[[2]] <- factor(unique(data[[effects[2]]])) - } else { - # second predictor is numeric - if (surface) { - min2 <- min(data[[effects[2]]], na.rm = TRUE) - max2 <- max(data[[effects[2]]], na.rm = TRUE) - if (effects[2] %in% int_vars) { - values[[2]] <- seq(min2, max2, by = 1) - } else { - values[[2]] <- seq(min2, max2, length.out = resolution) - } - } else { - if (effects[2] %in% int_vars) { - median2 <- median(data[[effects[2]]]) - mad2 <- mad(data[[effects[2]]]) - values[[2]] <- round((-1:1) * mad2 + median2) - } else { - mean2 <- mean(data[[effects[2]]], na.rm = TRUE) - sd2 <- sd(data[[effects[2]]], na.rm = TRUE) - values[[2]] <- (-1:1) * sd2 + mean2 - } - } - } - data <- do_call(expand.grid, values) - } else { - stopifnot(length(effects) == 1L) - data <- structure(data.frame(values), names = effects) - } - # no need to have the same value combination more than once - data <- unique(data) - data <- data[do_call(order, as.list(data)), , drop = FALSE] - data <- replicate(nrow(conditions), data, simplify = FALSE) - cond_vars <- setdiff(names(conditions), effects) - cond__ <- get_cond__(conditions) - for (j in seq_rows(conditions)) { - data[[j]] <- fill_newdata(data[[j]], cond_vars, conditions, n = j) - data[[j]]$cond__ <- cond__[j] - } - data <- do_call(rbind, data) - data$cond__ <- factor(data$cond__, cond__) - structure(data, effects = effects, types = types) -} - -# which variables in 'vars' are specified in 'data'? -vars_specified <- function(vars, data) { - .fun <- function(v) isTRUE(v %in% names(data)) && any(!is.na(data[[v]])) - as.logical(ulapply(vars, .fun)) -} - -# prepare data points based on the provided conditions -# allows to add data points to conditional effects plots -# @return a data.frame containing the data points to be plotted -make_point_frame <- function(bterms, mf, effects, conditions, - select_points = 0, transform = NULL, ...) { - stopifnot(is.brmsterms(bterms), is.data.frame(mf)) - effects <- intersect(effects, names(mf)) - points <- mf[, effects, drop = FALSE] - points$resp__ <- model.response( - model.frame(bterms$respform, mf, na.action = na.pass) - ) - req_vars <- names(mf) - groups <- get_re_groups(bterms) - if (length(groups)) { - c(req_vars) <- unlist(strsplit(groups, ":")) - } - req_vars <- unique(setdiff(req_vars, effects)) - req_vars <- intersect(req_vars, names(conditions)) - if (length(req_vars)) { - # find out which data point is valid for which condition - cond__ <- get_cond__(conditions) - mf <- mf[, req_vars, drop = FALSE] - conditions <- conditions[, req_vars, drop = FALSE] - points$cond__ <- NA - points <- replicate(nrow(conditions), points, simplify = FALSE) - for (i in seq_along(points)) { - cond <- conditions[i, , drop = FALSE] - # ensures correct handling of matrix columns - not_na <- function(x) !any(is.na(x) | x %in% "zero__") - not_na <- ulapply(cond, not_na) - cond <- cond[, not_na, drop = FALSE] - mf_tmp <- mf[, not_na, drop = FALSE] - if (ncol(mf_tmp)) { - is_num <- sapply(mf_tmp, is.numeric) - is_num <- is_num & !names(mf_tmp) %in% groups - if (sum(is_num)) { - # handle numeric variables - stopifnot(select_points >= 0) - if (select_points > 0) { - for (v in names(mf_tmp)[is_num]) { - min <- min(mf_tmp[, v], na.rm = TRUE) - max <- max(mf_tmp[, v], na.rm = TRUE) - unit <- scale_unit(mf_tmp[, v], min, max) - unit_cond <- scale_unit(cond[, v], min, max) - unit_diff <- abs(unit - unit_cond) - close_enough <- unit_diff <= select_points - mf_tmp[[v]][close_enough] <- cond[, v] - mf_tmp[[v]][!close_enough] <- NA - } - } else { - # take all numeric values if select_points is zero - cond <- cond[, !is_num, drop = FALSE] - mf_tmp <- mf_tmp[, !is_num, drop = FALSE] - } - } - } - if (ncol(mf_tmp)) { - # handle factors and grouping variables - # do it like base::duplicated - K <- do_call("paste", c(mf_tmp, sep = "\r")) %in% - do_call("paste", c(cond, sep = "\r")) - } else { - K <- seq_rows(mf) - } - # cond__ allows to assign points to conditions - points[[i]]$cond__[K] <- cond__[i] - } - points <- do_call(rbind, points) - points <- points[!is.na(points$cond__), , drop = FALSE] - points$cond__ <- factor(points$cond__, cond__) - } - points <- add_effects__(points, effects) - if (!is.numeric(points$resp__)) { - points$resp__ <- as.numeric(as.factor(points$resp__)) - if (is_binary(bterms$family)) { - points$resp__ <- points$resp__ - 1 - } - } - if (!is.null(transform)) { - points$resp__ <- do_call(transform, list(points$resp__)) - } - points -} - -# add effect__ variables to the data -add_effects__ <- function(data, effects) { - for (i in seq_along(effects)) { - data[[paste0("effect", i, "__")]] <- eval2(effects[i], data) - } - data -} - -#' @export -print.brms_conditional_effects <- function(x, ...) { - plot(x, ...) -} - -#' @rdname conditional_effects.brmsfit -#' @method plot brms_conditional_effects -#' @export -plot.brms_conditional_effects <- function( - x, ncol = NULL, points = FALSE, rug = FALSE, mean = TRUE, - jitter_width = 0, stype = c("contour", "raster"), - line_args = list(), cat_args = list(), errorbar_args = list(), - surface_args = list(), spaghetti_args = list(), point_args = list(), - rug_args = list(), facet_args = list(), theme = NULL, ask = TRUE, - plot = TRUE, ... -) { - dots <- list(...) - plot <- use_alias(plot, dots$do_plot) - stype <- match.arg(stype) - smooths_only <- isTRUE(attr(x, "smooths_only")) - if (points && smooths_only) { - stop2("Argument 'points' is invalid for objects ", - "returned by 'conditional_smooths'.") - } - if (!is_equal(jitter_width, 0)) { - warning2("'jitter_width' is deprecated. Please use ", - "'point_args = list(width = )' instead.") - } - if (!is.null(theme) && !is.theme(theme)) { - stop2("Argument 'theme' should be a 'theme' object.") - } - if (plot) { - default_ask <- devAskNewPage() - on.exit(devAskNewPage(default_ask)) - devAskNewPage(ask = FALSE) - } - dont_replace <- c("mapping", "data", "inherit.aes") - plots <- named_list(names(x)) - for (i in seq_along(x)) { - response <- attr(x[[i]], "response") - effects <- attr(x[[i]], "effects") - ncond <- length(unique(x[[i]]$cond__)) - df_points <- attr(x[[i]], "points") - categorical <- isTRUE(attr(x[[i]], "categorical")) - catscale <- attr(x[[i]], "catscale") - surface <- isTRUE(attr(x[[i]], "surface")) - # deprecated as of brms 2.4.3 - ordinal <- isTRUE(attr(x[[i]], "ordinal")) - if (surface || ordinal) { - # surface plots for two dimensional interactions or ordinal plots - plots[[i]] <- ggplot(x[[i]]) + - aes_(~ effect1__, ~ effect2__) + - labs(x = effects[1], y = effects[2]) - if (ordinal) { - width <- ifelse(is_like_factor(x[[i]]$effect1__), 0.9, 1) - .surface_args <- nlist( - mapping = aes_(fill = ~ estimate__), - height = 0.9, width = width - ) - replace_args(.surface_args, dont_replace) <- surface_args - plots[[i]] <- plots[[i]] + - do_call(geom_tile, .surface_args) + - scale_fill_gradientn(colors = viridis6(), name = catscale) + - ylab(response) - } else if (stype == "contour") { - .surface_args <- nlist( - mapping = aes_(z = ~ estimate__, colour = ~ ..level..), - bins = 30, size = 1.3 - ) - replace_args(.surface_args, dont_replace) <- surface_args - plots[[i]] <- plots[[i]] + - do_call(geom_contour, .surface_args) + - scale_color_gradientn(colors = viridis6(), name = response) - } else if (stype == "raster") { - .surface_args <- nlist(mapping = aes_(fill = ~ estimate__)) - replace_args(.surface_args, dont_replace) <- surface_args - plots[[i]] <- plots[[i]] + - do_call(geom_raster, .surface_args) + - scale_fill_gradientn(colors = viridis6(), name = response) - } - } else { - # plot effects of single predictors or two-way interactions - gvar <- if (length(effects) == 2L) "effect2__" - spaghetti <- attr(x[[i]], "spaghetti") - plots[[i]] <- ggplot(x[[i]]) + - aes_string(x = "effect1__", y = "estimate__", colour = gvar) + - labs(x = effects[1], y = response, colour = effects[2]) - if (is.null(spaghetti)) { - plots[[i]] <- plots[[i]] + - aes_string(ymin = "lower__", ymax = "upper__", fill = gvar) + - labs(fill = effects[2]) - } - # extract suggested colors for later use - colors <- ggplot_build(plots[[i]]) - colors <- unique(colors$data[[1]][["colour"]]) - if (points && !categorical && !surface) { - # add points first so that they appear behind the predictions - .point_args <- list( - mapping = aes_string(x = "effect1__", y = "resp__"), - data = df_points, inherit.aes = FALSE, - size = 2 / ncond^0.25, height = 0, width = jitter_width - ) - if (is_like_factor(df_points[, gvar])) { - .point_args$mapping[c("colour", "fill")] <- - aes_string(colour = gvar, fill = gvar) - } - replace_args(.point_args, dont_replace) <- point_args - plots[[i]] <- plots[[i]] + - do_call(geom_jitter, .point_args) - } - if (!is.null(spaghetti)) { - # add a regression line for each sample separately - .spaghetti_args <- list( - aes_string(group = "sample__", colour = gvar), - data = spaghetti, stat = "identity", size = 0.5 - ) - if (length(effects) == 1L) { - .spaghetti_args$colour <- alpha("blue", 0.1) - } else { - # workaround to get transparent lines - plots[[i]] <- plots[[i]] + - scale_color_manual(values = alpha(colors, 0.1)) - } - replace_args(.spaghetti_args, dont_replace) <- spaghetti_args - plots[[i]] <- plots[[i]] + - do_call(geom_smooth, .spaghetti_args) - } - if (is.numeric(x[[i]]$effect1__)) { - # line plots for numeric predictors - .line_args <- list(stat = "identity") - if (!is.null(spaghetti)) { - # display a white mean regression line - .line_args$mapping <- aes_string(group = gvar) - .line_args$colour <- alpha("white", 0.8) - } - replace_args(.line_args, dont_replace) <- line_args - if (mean || is.null(spaghetti)) { - plots[[i]] <- plots[[i]] + - do_call(geom_smooth, .line_args) - } - if (rug) { - .rug_args <- list( - aes_string(x = "effect1__"), sides = "b", - data = df_points, inherit.aes = FALSE - ) - if (is_like_factor(df_points[, gvar])) { - .point_args$mapping[c("colour", "fill")] <- - aes_string(colour = gvar, fill = gvar) - } - replace_args(.rug_args, dont_replace) <- rug_args - plots[[i]] <- plots[[i]] + - do_call(geom_rug, .rug_args) - } - } else { - # points and errorbars for factors - .cat_args <- list( - position = position_dodge(width = 0.4), - size = 4 / ncond^0.25 - ) - .errorbar_args <- list( - position = position_dodge(width = 0.4), - width = 0.3 - ) - replace_args(.cat_args, dont_replace) <- cat_args - replace_args(.errorbar_args, dont_replace) <- errorbar_args - plots[[i]] <- plots[[i]] + - do_call(geom_point, .cat_args) + - do_call(geom_errorbar, .errorbar_args) - } - if (categorical) { - plots[[i]] <- plots[[i]] + ylab(catscale) + - labs(fill = response, color = response) - } - } - if (ncond > 1L) { - # one plot per row of conditions - if (is.null(ncol)) { - ncol <- max(floor(sqrt(ncond)), 3) - } - .facet_args <- nlist(facets = "cond__", ncol) - replace_args(.facet_args, dont_replace) <- facet_args - plots[[i]] <- plots[[i]] + - do_call(facet_wrap, .facet_args) - } - plots[[i]] <- plots[[i]] + theme - if (plot) { - plot(plots[[i]]) - if (i == 1) { - devAskNewPage(ask = ask) - } - } - } - invisible(plots) -} - -# the name 'marginal_effects' is deprecated as of brms 2.10.3 -# do not remove it eventually as it has been used in the brms papers -#' @export -marginal_effects <- function(x, ...) { - UseMethod("marginal_effects") -} - -#' @export -marginal_effects.brmsfit <- function(x, ...) { - warning2("Method 'marginal_effects' is deprecated. ", - "Please use 'conditional_effects' instead.") - conditional_effects.brmsfit(x, ...) -} - -#' @export -print.brmsMarginalEffects <- function(x, ...) { - class(x) <- "brms_conditional_effects" - print(x, ...) -} - -#' @export -plot.brmsMarginalEffects <- function(x, ...) { - class(x) <- "brms_conditional_effects" - plot(x, ...) -} +#' Display Conditional Effects of Predictors +#' +#' Display conditional effects of one or more numeric and/or categorical +#' predictors including two-way interaction effects. +#' +#' @aliases marginal_effects marginal_effects.brmsfit +#' +#' @param x An object of class \code{brmsfit}. +#' @param effects An optional character vector naming effects (main effects or +#' interactions) for which to compute conditional plots. Interactions are +#' specified by a \code{:} between variable names. If \code{NULL} (the +#' default), plots are generated for all main effects and two-way interactions +#' estimated in the model. When specifying \code{effects} manually, \emph{all} +#' two-way interactions (including grouping variables) may be plotted +#' even if not originally modeled. +#' @param conditions An optional \code{data.frame} containing variable values +#' to condition on. Each effect defined in \code{effects} will +#' be plotted separately for each row of \code{conditions}. Values in the +#' \code{cond__} column will be used as titles of the subplots. If \code{cond__} +#' is not given, the row names will be used for this purpose instead. +#' It is recommended to only define a few rows in order to keep the plots clear. +#' See \code{\link{make_conditions}} for an easy way to define conditions. +#' If \code{NULL} (the default), numeric variables will be conditionalized by +#' using their means and factors will get their first level assigned. +#' \code{NA} values within factors are interpreted as if all dummy +#' variables of this factor are zero. This allows, for instance, to make +#' predictions of the grand mean when using sum coding. +#' @param int_conditions An optional named \code{list} whose elements are +#' vectors of values of the variables specified in \code{effects}. +#' At these values, predictions are evaluated. The names of +#' \code{int_conditions} have to match the variable names exactly. +#' Additionally, the elements of the vectors may be named themselves, +#' in which case their names appear as labels for the conditions in the plots. +#' Instead of vectors, functions returning vectors may be passed and are +#' applied on the original values of the corresponding variable. +#' If \code{NULL} (the default), predictions are evaluated at the +#' \eqn{mean} and at \eqn{mean +/- sd} for numeric predictors and at +#' all categories for factor-like predictors. +#' @param re_formula A formula containing group-level effects to be considered +#' in the conditional predictions. If \code{NULL}, include all group-level +#' effects; if \code{NA} (default), include no group-level effects. +#' @param robust If \code{TRUE} (the default) the median is used as the +#' measure of central tendency. If \code{FALSE} the mean is used instead. +#' @param prob A value between 0 and 1 indicating the desired probability +#' to be covered by the uncertainty intervals. The default is 0.95. +#' @param probs (Deprecated) The quantiles to be used in the computation of +#' uncertainty intervals. Please use argument \code{prob} instead. +#' @param method Method used to obtain predictions. Can be set to +#' \code{"posterior_epred"} (the default), \code{"posterior_predict"}, +#' or \code{"posterior_linpred"}. For more details, see the respective +#' function documentations. +#' @param spaghetti Logical. Indicates if predictions should +#' be visualized via spaghetti plots. Only applied for numeric +#' predictors. If \code{TRUE}, it is recommended +#' to set argument \code{ndraws} to a relatively small value +#' (e.g., \code{100}) in order to reduce computation time. +#' @param surface Logical. Indicates if interactions or +#' two-dimensional smooths should be visualized as a surface. +#' Defaults to \code{FALSE}. The surface type can be controlled +#' via argument \code{stype} of the related plotting method. +#' @param categorical Logical. Indicates if effects of categorical +#' or ordinal models should be shown in terms of probabilities +#' of response categories. Defaults to \code{FALSE}. +#' @param ordinal (Deprecated) Please use argument \code{categorical}. +#' Logical. Indicates if effects in ordinal models +#' should be visualized as a raster with the response categories +#' on the y-axis. Defaults to \code{FALSE}. +#' @param transform A function or a character string naming +#' a function to be applied on the predicted responses +#' before summary statistics are computed. Only allowed +#' if \code{method = "posterior_predict"}. +#' @param resolution Number of support points used to generate +#' the plots. Higher resolution leads to smoother plots. +#' Defaults to \code{100}. If \code{surface} is \code{TRUE}, +#' this implies \code{10000} support points for interaction terms, +#' so it might be necessary to reduce \code{resolution} +#' when only few RAM is available. +#' @param too_far Positive number. +#' For surface plots only: Grid points that are too +#' far away from the actual data points can be excluded from the plot. +#' \code{too_far} determines what is too far. The grid is scaled into +#' the unit square and then grid points more than \code{too_far} +#' from the predictor variables are excluded. By default, all +#' grid points are used. Ignored for non-surface plots. +#' @param select_points Positive number. +#' Only relevant if \code{points} or \code{rug} are set to \code{TRUE}: +#' Actual data points of numeric variables that +#' are too far away from the values specified in \code{conditions} +#' can be excluded from the plot. Values are scaled into +#' the unit interval and then points more than \code{select_points} +#' from the values in \code{conditions} are excluded. +#' By default, all points are used. +#' @param ... Further arguments such as \code{draw_ids} or \code{ndraws} +#' passed to \code{\link{posterior_predict}} or \code{\link{posterior_epred}}. +#' @inheritParams plot.brmsfit +#' @param ncol Number of plots to display per column for each effect. +#' If \code{NULL} (default), \code{ncol} is computed internally based +#' on the number of rows of \code{conditions}. +#' @param points Logical. Indicates if the original data points +#' should be added via \code{\link{geom_jitter}}. +#' Default is \code{FALSE}. Note that only those data points will be added +#' that match the specified conditions defined in \code{conditions}. +#' For categorical predictors, the conditions have to match exactly. +#' For numeric predictors, argument \code{select_points} is used to +#' determine, which points do match a condition. +#' @param rug Logical. Indicates if a rug representation of predictor +#' values should be added via \code{\link{geom_rug}}. +#' Default is \code{FALSE}. Depends on \code{select_points} in the same +#' way as \code{points} does. +#' @param mean Logical. Only relevant for spaghetti plots. +#' If \code{TRUE} (the default), display the mean regression +#' line on top of the regression lines for each sample. +#' @param jitter_width Only used if \code{points = TRUE}: +#' Amount of horizontal jittering of the data points. +#' Mainly useful for ordinal models. Defaults to \code{0} that +#' is no jittering. +#' @param stype Indicates how surface plots should be displayed. +#' Either \code{"contour"} or \code{"raster"}. +#' @param line_args Only used in plots of continuous predictors: +#' A named list of arguments passed to +#' \code{\link{geom_smooth}}. +#' @param cat_args Only used in plots of categorical predictors: +#' A named list of arguments passed to +#' \code{\link{geom_point}}. +#' @param errorbar_args Only used in plots of categorical predictors: +#' A named list of arguments passed to +#' \code{\link{geom_errorbar}}. +#' @param surface_args Only used in surface plots: +#' A named list of arguments passed to +#' \code{\link{geom_contour}} or +#' \code{\link{geom_raster}} +#' (depending on argument \code{stype}). +#' @param spaghetti_args Only used in spaghetti plots: +#' A named list of arguments passed to +#' \code{\link{geom_smooth}}. +#' @param point_args Only used if \code{points = TRUE}: +#' A named list of arguments passed to +#' \code{\link{geom_jitter}}. +#' @param rug_args Only used if \code{rug = TRUE}: +#' A named list of arguments passed to +#' \code{\link{geom_rug}}. +#' @param facet_args Only used if if multiple condtions are provided: +#' A named list of arguments passed to +#' \code{\link{facet_wrap}}. +#' +#' @return An object of class \code{'brms_conditional_effects'} which is a +#' named list with one data.frame per effect containing all information +#' required to generate conditional effects plots. Among others, these +#' data.frames contain some special variables, namely \code{estimate__} +#' (predicted values of the response), \code{se__} (standard error of the +#' predicted response), \code{lower__} and \code{upper__} (lower and upper +#' bounds of the uncertainty interval of the response), as well as +#' \code{cond__} (used in faceting when \code{conditions} contains multiple +#' rows). +#' +#' The corresponding \code{plot} method returns a named +#' list of \code{\link{ggplot}} objects, which can be further +#' customized using the \pkg{ggplot2} package. +#' +#' @details When creating \code{conditional_effects} for a particular predictor +#' (or interaction of two predictors), one has to choose the values of all +#' other predictors to condition on. By default, the mean is used for +#' continuous variables and the reference category is used for factors, but +#' you may change these values via argument \code{conditions}. This also has +#' an implication for the \code{points} argument: In the created plots, only +#' those points will be shown that correspond to the factor levels actually +#' used in the conditioning, in order not to create the false impression of +#' bad model fit, where it is just due to conditioning on certain factor +#' levels. +#' +#' To fully change colors of the created plots, one has to amend both +#' \code{scale_colour} and \code{scale_fill}. See +#' \code{\link{scale_colour_grey}} or \code{\link{scale_colour_gradient}} for +#' more details. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt + (1 | patient), +#' data = epilepsy, family = poisson()) +#' +#' ## plot all conditional effects +#' plot(conditional_effects(fit), ask = FALSE) +#' +#' ## change colours to grey scale +#' library(ggplot2) +#' me <- conditional_effects(fit, "zBase:Trt") +#' plot(me, plot = FALSE)[[1]] + +#' scale_color_grey() + +#' scale_fill_grey() +#' +#' ## only plot the conditional interaction effect of 'zBase:Trt' +#' ## for different values for 'zAge' +#' conditions <- data.frame(zAge = c(-1, 0, 1)) +#' plot(conditional_effects(fit, effects = "zBase:Trt", +#' conditions = conditions)) +#' +#' ## also incorporate group-level effects variance over patients +#' ## also add data points and a rug representation of predictor values +#' plot(conditional_effects(fit, effects = "zBase:Trt", +#' conditions = conditions, re_formula = NULL), +#' points = TRUE, rug = TRUE) +#' +#' ## change handling of two-way interactions +#' int_conditions <- list( +#' zBase = setNames(c(-2, 1, 0), c("b", "c", "a")) +#' ) +#' conditional_effects(fit, effects = "Trt:zBase", +#' int_conditions = int_conditions) +#' conditional_effects(fit, effects = "Trt:zBase", +#' int_conditions = list(zBase = quantile)) +#' +#' ## fit a model to illustrate how to plot 3-way interactions +#' fit3way <- brm(count ~ zAge * zBase * Trt, data = epilepsy) +#' conditions <- make_conditions(fit3way, "zAge") +#' conditional_effects(fit3way, "zBase:Trt", conditions = conditions) +#' ## only include points close to the specified values of zAge +#' me <- conditional_effects( +#' fit3way, "zBase:Trt", conditions = conditions, +#' select_points = 0.1 +#' ) +#' plot(me, points = TRUE) +#' } +#' +#' @export +conditional_effects.brmsfit <- function(x, effects = NULL, conditions = NULL, + int_conditions = NULL, re_formula = NA, + prob = 0.95, robust = TRUE, + method = "posterior_epred", + spaghetti = FALSE, surface = FALSE, + categorical = FALSE, ordinal = FALSE, + transform = NULL, resolution = 100, + select_points = 0, too_far = 0, + probs = NULL, ...) { + probs <- validate_ci_bounds(prob, probs = probs) + method <- validate_pp_method(method) + spaghetti <- as_one_logical(spaghetti) + surface <- as_one_logical(surface) + categorical <- as_one_logical(categorical) + ordinal <- as_one_logical(ordinal) + contains_draws(x) + x <- restructure(x) + new_formula <- update_re_terms(x$formula, re_formula = re_formula) + bterms <- brmsterms(new_formula) + + if (!is.null(transform) && method != "posterior_predict") { + stop2("'transform' is only allowed if 'method = posterior_predict'.") + } + if (ordinal) { + warning2("Argument 'ordinal' is deprecated. ", + "Please use 'categorical' instead.") + } + rsv_vars <- rsv_vars(bterms) + use_def_effects <- is.null(effects) + if (use_def_effects) { + effects <- get_all_effects(bterms, rsv_vars = rsv_vars) + } else { + # allow to define interactions in any order + effects <- strsplit(as.character(effects), split = ":") + if (any(unique(unlist(effects)) %in% rsv_vars)) { + stop2("Variables ", collapse_comma(rsv_vars), + " should not be used as effects for this model") + } + if (any(lengths(effects) > 2L)) { + stop2("To display interactions of order higher than 2 ", + "please use the 'conditions' argument.") + } + all_effects <- get_all_effects( + bterms, rsv_vars = rsv_vars, comb_all = TRUE + ) + ae_coll <- all_effects[lengths(all_effects) == 1L] + ae_coll <- ulapply(ae_coll, paste, collapse = ":") + matches <- match(lapply(all_effects, sort), lapply(effects, sort), 0L) + if (sum(matches) > 0 && sum(matches > 0) < length(effects)) { + invalid <- effects[setdiff(seq_along(effects), sort(matches))] + invalid <- ulapply(invalid, paste, collapse = ":") + warning2( + "Some specified effects are invalid for this model: ", + collapse_comma(invalid), "\nValid effects are ", + "(combinations of): ", collapse_comma(ae_coll) + ) + } + effects <- unique(effects[sort(matches)]) + if (!length(effects)) { + stop2( + "All specified effects are invalid for this model.\n", + "Valid effects are (combinations of): ", + collapse_comma(ae_coll) + ) + } + } + if (categorical || ordinal) { + int_effs <- lengths(effects) == 2L + if (any(int_effs)) { + effects <- effects[!int_effs] + warning2( + "Interactions cannot be plotted directly if 'categorical' ", + "is TRUE. Please use argument 'conditions' instead." + ) + } + } + if (!length(effects)) { + stop2("No valid effects detected.") + } + mf <- model.frame(x) + conditions <- prepare_conditions( + x, conditions = conditions, effects = effects, + re_formula = re_formula, rsv_vars = rsv_vars + ) + int_conditions <- lapply(int_conditions, + function(x) if (is.numeric(x)) sort(x, TRUE) else x + ) + int_vars <- get_int_vars(bterms) + group_vars <- get_group_vars(bterms) + out <- list() + for (i in seq_along(effects)) { + eff <- effects[[i]] + cond_data <- prepare_cond_data( + mf[, eff, drop = FALSE], conditions = conditions, + int_conditions = int_conditions, int_vars = int_vars, + group_vars = group_vars, surface = surface, + resolution = resolution, reorder = use_def_effects + ) + if (surface && length(eff) == 2L && too_far > 0) { + # exclude prediction grid points too far from data + ex_too_far <- mgcv::exclude.too.far( + g1 = cond_data[[eff[1]]], + g2 = cond_data[[eff[2]]], + d1 = mf[, eff[1]], + d2 = mf[, eff[2]], + dist = too_far) + cond_data <- cond_data[!ex_too_far, ] + } + c(out) <- conditional_effects( + bterms, fit = x, cond_data = cond_data, method = method, + surface = surface, spaghetti = spaghetti, categorical = categorical, + ordinal = ordinal, re_formula = re_formula, transform = transform, + conditions = conditions, int_conditions = int_conditions, + select_points = select_points, probs = probs, robust = robust, + ... + ) + } + structure(out, class = "brms_conditional_effects") +} + +#' @rdname conditional_effects.brmsfit +#' @export +conditional_effects <- function(x, ...) { + UseMethod("conditional_effects") +} + +# compute expected values of MV models for use in conditional_effects +# @return a list of summarized prediction matrices +#' @export +conditional_effects.mvbrmsterms <- function(x, resp = NULL, ...) { + resp <- validate_resp(resp, x$responses) + x$terms <- x$terms[resp] + out <- lapply(x$terms, conditional_effects, ...) + unlist(out, recursive = FALSE) +} + +# conditional_effects for univariate model +# @return a list with the summarized prediction matrix as the only element +# @note argument 'resp' exists only to be excluded from '...' (#589) +#' @export +conditional_effects.brmsterms <- function( + x, fit, cond_data, int_conditions, method, surface, + spaghetti, categorical, ordinal, probs, robust, + dpar = NULL, nlpar = NULL, resp = NULL, ... +) { + stopifnot(is.brmsfit(fit)) + effects <- attr(cond_data, "effects") + types <- attr(cond_data, "types") + catscale <- NULL + pred_args <- list( + fit, newdata = cond_data, allow_new_levels = TRUE, + dpar = dpar, nlpar = nlpar, resp = if (nzchar(x$resp)) x$resp, + incl_autocor = FALSE, ... + ) + if (method != "posterior_predict") { + # 'transform' creates problems in 'posterior_linpred' + pred_args$transform <- NULL + } + out <- do_call(method, pred_args) + rownames(cond_data) <- NULL + + if (categorical || ordinal) { + if (method != "posterior_epred") { + stop2("Can only use 'categorical' with method = 'posterior_epred'.") + } + if (!is_polytomous(x)) { + stop2("Argument 'categorical' may only be used ", + "for categorical or ordinal models.") + } + if (categorical && ordinal) { + stop2("Please use argument 'categorical' instead of 'ordinal'.") + } + catscale <- str_if(is_multinomial(x), "Count", "Probability") + cats <- dimnames(out)[[3]] + if (is.null(cats)) cats <- seq_dim(out, 3) + cond_data <- repl(cond_data, length(cats)) + cond_data <- do_call(rbind, cond_data) + cond_data$cats__ <- factor(rep(cats, each = ncol(out)), levels = cats) + effects[2] <- "cats__" + types[2] <- "factor" + } else { + if (conv_cats_dpars(x$family) && is.null(dpar)) { + stop2("Please set 'categorical' to TRUE.") + } + if (is_ordinal(x$family) && is.null(dpar) && method != "posterior_linpred") { + warning2( + "Predictions are treated as continuous variables in ", + "'conditional_effects' by default which is likely invalid ", + "for ordinal families. Please set 'categorical' to TRUE." + ) + if (method == "posterior_epred") { + out <- ordinal_probs_continuous(out) + } + } + } + + cond_data <- add_effects__(cond_data, effects) + first_numeric <- types[1] %in% "numeric" + second_numeric <- types[2] %in% "numeric" + both_numeric <- first_numeric && second_numeric + if (second_numeric && !surface) { + # only convert 'effect2__' to factor so that the original + # second effect variable remains unchanged in the data + mde2 <- round(cond_data[[effects[2]]], 2) + levels2 <- sort(unique(mde2), TRUE) + cond_data$effect2__ <- factor(mde2, levels = levels2) + labels2 <- names(int_conditions[[effects[2]]]) + if (length(labels2) == length(levels2)) { + levels(cond_data$effect2__) <- labels2 + } + } + + spag <- NULL + if (first_numeric && spaghetti) { + if (surface) { + stop2("Cannot use 'spaghetti' and 'surface' at the same time.") + } + spag <- out + if (categorical) { + spag <- do_call(cbind, array2list(spag)) + } + sample <- rep(seq_rows(spag), each = ncol(spag)) + if (length(types) == 2L) { + # draws should be unique across plotting groups + sample <- paste0(sample, "_", cond_data[[effects[2]]]) + } + spag <- data.frame(as.numeric(t(spag)), factor(sample)) + colnames(spag) <- c("estimate__", "sample__") + # ensures that 'cbind' works even in the presence of matrix columns + cond_data_spag <- repl(cond_data, nrow(spag) / nrow(cond_data)) + cond_data_spag <- Reduce(rbind, cond_data_spag) + spag <- cbind(cond_data_spag, spag) + } + + out <- posterior_summary(out, probs = probs, robust = robust) + if (categorical || ordinal) { + out <- do_call(rbind, array2list(out)) + } + colnames(out) <- c("estimate__", "se__", "lower__", "upper__") + out <- cbind(cond_data, out) + if (!is.null(dpar)) { + response <- dpar + } else if (!is.null(nlpar)) { + response <- nlpar + } else { + response <- as.character(x$formula[2]) + } + attr(out, "effects") <- effects + attr(out, "response") <- response + attr(out, "surface") <- unname(both_numeric && surface) + attr(out, "categorical") <- categorical + attr(out, "catscale") <- catscale + attr(out, "ordinal") <- ordinal + attr(out, "spaghetti") <- spag + attr(out, "points") <- make_point_frame(x, fit$data, effects, ...) + name <- paste0(usc(x$resp, "suffix"), paste0(effects, collapse = ":")) + setNames(list(out), name) +} + +# get combinations of variables used in predictor terms +# @param ... character vectors or formulas +# @param alist a list of character vectors or formulas +get_var_combs <- function(..., alist = list()) { + dots <- c(list(...), alist) + for (i in seq_along(dots)) { + if (is.formula(dots[[i]])) { + dots[[i]] <- attr(terms(dots[[i]]), "term.labels") + } + dots[[i]] <- lapply(dots[[i]], all_vars) + } + unique(unlist(dots, recursive = FALSE)) +} + +# extract combinations of predictor variables +get_all_effects <- function(x, ...) { + UseMethod("get_all_effects") +} + +#' @export +get_all_effects.default <- function(x, ...) { + NULL +} + +#' @export +get_all_effects.mvbrmsterms <- function(x, ...) { + out <- lapply(x$terms, get_all_effects, ...) + unique(unlist(out, recursive = FALSE)) +} + +# get all effects for use in conditional_effects +# @param bterms object of class brmsterms +# @param rsv_vars character vector of reserved variables +# @param comb_all include all main effects and two-way interactions? +# @return a list with one element per valid effect / effects combination +# excludes all 3-way or higher interactions +#' @export +get_all_effects.brmsterms <- function(x, rsv_vars = NULL, comb_all = FALSE) { + stopifnot(is.atomic(rsv_vars)) + out <- list() + for (dp in names(x$dpars)) { + out <- c(out, get_all_effects(x$dpars[[dp]])) + } + for (nlp in names(x$nlpars)) { + out <- c(out, get_all_effects(x$nlpars[[nlp]])) + } + out <- rmNULL(lapply(out, setdiff, y = rsv_vars)) + if (comb_all) { + # allow to combine all variables with each other + out <- unique(unlist(out)) + out <- c(out, get_group_vars(x)) + if (length(out)) { + int <- expand.grid(out, out, stringsAsFactors = FALSE) + int <- int[int[, 1] != int[, 2], ] + int <- as.list(as.data.frame(t(int), stringsAsFactors = FALSE)) + int <- unique(unname(lapply(int, sort))) + out <- c(as.list(out), int) + } + } + unique(out[lengths(out) <= 2L]) +} + +#' @export +get_all_effects.btl <- function(x, ...) { + c(get_var_combs(x[["fe"]], x[["cs"]]), + get_all_effects_type(x, "sp"), + get_all_effects_type(x, "sm"), + get_all_effects_type(x, "gp")) +} + +# extract variable combinations from special terms +get_all_effects_type <- function(x, type) { + stopifnot(is.btl(x)) + type <- as_one_character(type) + regex_type <- regex_sp(type) + terms <- all_terms(x[[type]]) + out <- named_list(terms) + for (i in seq_along(terms)) { + # some special terms can appear within interactions + # we did not allow ":" within these terms so we can use it for splitting + term_parts <- unlist(strsplit(terms[i], split = ":")) + vars <- vector("list", length(term_parts)) + for (j in seq_along(term_parts)) { + if (grepl_expr(regex_type, term_parts[j])) { + # evaluate a special term to extract variables + tmp <- eval2(term_parts[j]) + vars[[j]] <- setdiff(unique(c(tmp$term, tmp$by)), "NA") + } else { + # extract all variables from an ordinary term + vars[[j]] <- all_vars(term_parts[j]) + } + } + vars <- unique(unlist(vars)) + out[[i]] <- str2formula(vars, collapse = "*") + } + get_var_combs(alist = out) +} + +#' @export +get_all_effects.btnl <- function(x, ...) { + covars <- all_vars(rhs(x$covars)) + out <- as.list(covars) + if (length(covars) > 1L) { + c(out) <- utils::combn(covars, 2, simplify = FALSE) + } + unique(out) +} + +# extract names of predictor variables +get_pred_vars <- function(x) { + unique(unlist(get_all_effects(x))) +} + +# extract names of variables treated as integers +get_int_vars <- function(x, ...) { + UseMethod("get_int_vars") +} + +#' @export +get_int_vars.mvbrmsterms <- function(x, ...) { + unique(ulapply(x$terms, get_int_vars)) +} + +#' @export +get_int_vars.brmsterms <- function(x, ...) { + advars <- ulapply(rmNULL(x$adforms[c("trials", "thres", "vint")]), all_vars) + unique(c(advars, get_sp_vars(x, "mo"))) +} + +# transform posterior draws of ordinal probabilities to a +# continuous scale assuming equidistance between adjacent categories +# @param x an ndraws x nobs x ncat array of posterior draws +# @return an ndraws x nobs matrix of posterior draws +ordinal_probs_continuous <- function(x) { + stopifnot(length(dim(x)) == 3) + for (k in seq_dim(x, 3)) { + x[, , k] <- x[, , k] * k + } + x <- lapply(seq_dim(x, 2), function(s) rowSums(x[, s, ])) + do_call(cbind, x) +} + +#' Prepare Fully Crossed Conditions +#' +#' This is a helper function to prepare fully crossed conditions primarily +#' for use with the \code{conditions} argument of \code{\link{conditional_effects}}. +#' Automatically creates labels for each row in the \code{cond__} column. +#' +#' @param x An \R object from which to extract the variables +#' that should be part of the conditions. +#' @param vars Names of the variables that should be part of the conditions. +#' @param ... Arguments passed to \code{\link{rows2labels}}. +#' +#' @return A \code{data.frame} where each row indicates a condition. +#' +#' @details For factor like variables, all levels are used as conditions. +#' For numeric variables, \code{mean + (-1:1) * SD} are used as conditions. +#' +#' @seealso \code{\link{conditional_effects}}, \code{\link{rows2labels}} +#' +#' @examples +#' df <- data.frame(x = c("a", "b"), y = rnorm(10)) +#' make_conditions(df, vars = c("x", "y")) +#' +#' @export +make_conditions <- function(x, vars, ...) { + # rev ensures that the last variable varies fastest in expand.grid + vars <- rev(as.character(vars)) + if (!is.data.frame(x) && "data" %in% names(x)) { + x <- x$data + } + x <- as.data.frame(x) + out <- named_list(vars) + for (v in vars) { + tmp <- get(v, x) + if (is_like_factor(tmp)) { + tmp <- levels(as.factor(tmp)) + } else { + tmp <- mean(tmp, na.rm = TRUE) + (-1:1) * sd(tmp, na.rm = TRUE) + } + out[[v]] <- tmp + } + out <- rev(expand.grid(out)) + out$cond__ <- rows2labels(out, ...) + out +} + +# extract the cond__ variable used for faceting +get_cond__ <- function(x) { + out <- x[["cond__"]] + if (is.null(out)) { + out <- rownames(x) + } + as.character(out) +} + +#' Convert Rows to Labels +#' +#' Convert information in rows to labels for each row. +#' +#' @param x A \code{data.frame} for which to extract labels. +#' @param digits Minimal number of decimal places shown in +#' the labels of numeric variables. +#' @param sep A single character string defining the separator +#' between variables used in the labels. +#' @param incl_vars Indicates if variable names should +#' be part of the labels. Defaults to \code{TRUE}. +#' @param ... Currently unused. +#' +#' @return A character vector of the same length as the number +#' of rows of \code{x}. +#' +#' @seealso \code{\link{make_conditions}}, \code{\link{conditional_effects}} +#' +#' @export +rows2labels <- function(x, digits = 2, sep = " & ", incl_vars = TRUE, ...) { + x <- as.data.frame(x) + incl_vars <- as_one_logical(incl_vars) + out <- x + for (i in seq_along(out)) { + if (!is_like_factor(out[[i]])) { + out[[i]] <- round(out[[i]], digits) + } + if (incl_vars) { + out[[i]] <- paste0(names(out)[i], " = ", out[[i]]) + } + } + paste_sep <- function(..., sep__ = sep) { + paste(..., sep = sep__) + } + Reduce(paste_sep, out) +} + +# prepare conditions for use in conditional_effects +# @param fit an object of class 'brmsfit' +# @param conditions optional data.frame containing user defined conditions +# @param effects see conditional_effects +# @param re_formula see conditional_effects +# @param rsv_vars names of reserved variables +# @return a data.frame with (possibly updated) conditions +prepare_conditions <- function(fit, conditions = NULL, effects = NULL, + re_formula = NA, rsv_vars = NULL) { + mf <- model.frame(fit) + new_formula <- update_re_terms(fit$formula, re_formula = re_formula) + bterms <- brmsterms(new_formula) + if (any(grepl_expr("^(as\\.)?factor(.+)$", bterms$allvars))) { + # conditions are chosen based the variables stored in the data + # this approach cannot take into account possible transformations + # to factors happening inside the model formula + warning2( + "Using 'factor' or 'as.factor' in the model formula ", + "might lead to problems in 'conditional_effects'.", + "Please convert your variables to factors beforehand." + ) + } + req_vars <- all_vars(rhs(bterms$allvars)) + req_vars <- setdiff(req_vars, rsv_vars) + req_vars <- setdiff(req_vars, names(fit$data2)) + if (is.null(conditions)) { + conditions <- as.data.frame(as.list(rep(NA, length(req_vars)))) + names(conditions) <- req_vars + } else { + conditions <- as.data.frame(conditions) + if (!nrow(conditions)) { + stop2("Argument 'conditions' must have a least one row.") + } + conditions <- unique(conditions) + if (any(duplicated(get_cond__(conditions)))) { + stop2("Condition labels should be unique.") + } + req_vars <- setdiff(req_vars, names(conditions)) + } + # special treatment for 'trials' addition variables + trial_vars <- all_vars(bterms$adforms$trials) + trial_vars <- trial_vars[!vars_specified(trial_vars, conditions)] + if (length(trial_vars)) { + message("Setting all 'trials' variables to 1 by ", + "default if not specified otherwise.") + req_vars <- setdiff(req_vars, trial_vars) + for (v in trial_vars) { + conditions[[v]] <- 1L + } + } + # use sensible default values for unspecified variables + subset_vars <- get_ad_vars(bterms, "subset") + int_vars <- get_int_vars(bterms) + group_vars <- get_group_vars(bterms) + req_vars <- setdiff(req_vars, group_vars) + for (v in req_vars) { + if (is_like_factor(mf[[v]])) { + # factor-like variable + if (v %in% subset_vars) { + # avoid unintentional subsetting of newdata (#755) + conditions[[v]] <- TRUE + } else { + # use reference category for factors + levels <- levels(as.factor(mf[[v]])) + ordered <- is.ordered(mf[[v]]) + conditions[[v]] <- factor(levels[1], levels, ordered = ordered) + } + } else { + # numeric-like variable + if (v %in% subset_vars) { + # avoid unintentional subsetting of newdata (#755) + conditions[[v]] <- 1 + } else if (v %in% int_vars) { + # ensure valid integer values + conditions[[v]] <- round(median(mf[[v]], na.rm = TRUE)) + } else { + conditions[[v]] <- mean(mf[[v]], na.rm = TRUE) + } + } + } + all_vars <- c(all_vars(bterms$allvars), "cond__") + unused_vars <- setdiff(names(conditions), all_vars) + if (length(unused_vars)) { + warning2( + "The following variables in 'conditions' are not ", + "part of the model:\n", collapse_comma(unused_vars) + ) + } + cond__ <- conditions$cond__ + conditions <- validate_newdata( + conditions, fit, re_formula = re_formula, + allow_new_levels = TRUE, check_response = FALSE, + incl_autocor = FALSE + ) + conditions$cond__ <- cond__ + conditions +} + +# prepare data to be used in conditional_effects +# @param data data.frame containing only data of the predictors of interest +# @param conditions see argument 'conditions' of conditional_effects +# @param int_conditions see argument 'int_conditions' of conditional_effects +# @param int_vars names of variables being treated as integers +# @param group_vars names of grouping variables +# @param surface generate surface plots later on? +# @param resolution number of distinct points at which to evaluate +# the predictors of interest +# @param reorder reorder predictors so that numeric ones come first? +prepare_cond_data <- function(data, conditions, int_conditions = NULL, + int_vars = NULL, group_vars = NULL, + surface = FALSE, resolution = 100, + reorder = TRUE) { + effects <- names(data) + stopifnot(length(effects) %in% c(1L, 2L)) + is_factor <- ulapply(data, is_like_factor) | names(data) %in% group_vars + types <- ifelse(is_factor, "factor", "numeric") + # numeric effects should come first + if (reorder) { + new_order <- order(types, decreasing = TRUE) + effects <- effects[new_order] + types <- types[new_order] + } + # handle first predictor + if (effects[1] %in% names(int_conditions)) { + # first predictor has pre-specified conditions + int_cond <- int_conditions[[effects[1]]] + if (is.function(int_cond)) { + int_cond <- int_cond(data[[effects[1]]]) + } + values <- int_cond + } else if (types[1] == "factor") { + # first predictor is factor-like + values <- factor(unique(data[[effects[1]]])) + } else { + # first predictor is numeric + min1 <- min(data[[effects[1]]], na.rm = TRUE) + max1 <- max(data[[effects[1]]], na.rm = TRUE) + if (effects[1] %in% int_vars) { + values <- seq(min1, max1, by = 1) + } else { + values <- seq(min1, max1, length.out = resolution) + } + } + if (length(effects) == 2L) { + # handle second predictor + values <- setNames(list(values, NA), effects) + if (effects[2] %in% names(int_conditions)) { + # second predictor has pre-specified conditions + int_cond <- int_conditions[[effects[2]]] + if (is.function(int_cond)) { + int_cond <- int_cond(data[[effects[2]]]) + } + values[[2]] <- int_cond + } else if (types[2] == "factor") { + # second predictor is factor-like + values[[2]] <- factor(unique(data[[effects[2]]])) + } else { + # second predictor is numeric + if (surface) { + min2 <- min(data[[effects[2]]], na.rm = TRUE) + max2 <- max(data[[effects[2]]], na.rm = TRUE) + if (effects[2] %in% int_vars) { + values[[2]] <- seq(min2, max2, by = 1) + } else { + values[[2]] <- seq(min2, max2, length.out = resolution) + } + } else { + if (effects[2] %in% int_vars) { + median2 <- median(data[[effects[2]]]) + mad2 <- mad(data[[effects[2]]]) + values[[2]] <- round((-1:1) * mad2 + median2) + } else { + mean2 <- mean(data[[effects[2]]], na.rm = TRUE) + sd2 <- sd(data[[effects[2]]], na.rm = TRUE) + values[[2]] <- (-1:1) * sd2 + mean2 + } + } + } + data <- do_call(expand.grid, values) + } else { + stopifnot(length(effects) == 1L) + data <- structure(data.frame(values), names = effects) + } + # no need to have the same value combination more than once + data <- unique(data) + data <- data[do_call(order, as.list(data)), , drop = FALSE] + data <- replicate(nrow(conditions), data, simplify = FALSE) + cond_vars <- setdiff(names(conditions), effects) + cond__ <- get_cond__(conditions) + for (j in seq_rows(conditions)) { + data[[j]] <- fill_newdata(data[[j]], cond_vars, conditions, n = j) + data[[j]]$cond__ <- cond__[j] + } + data <- do_call(rbind, data) + data$cond__ <- factor(data$cond__, cond__) + structure(data, effects = effects, types = types) +} + +# which variables in 'vars' are specified in 'data'? +vars_specified <- function(vars, data) { + .fun <- function(v) isTRUE(v %in% names(data)) && any(!is.na(data[[v]])) + as.logical(ulapply(vars, .fun)) +} + +# prepare data points based on the provided conditions +# allows to add data points to conditional effects plots +# @return a data.frame containing the data points to be plotted +make_point_frame <- function(bterms, mf, effects, conditions, + select_points = 0, transform = NULL, ...) { + stopifnot(is.brmsterms(bterms), is.data.frame(mf)) + effects <- intersect(effects, names(mf)) + points <- mf[, effects, drop = FALSE] + points$resp__ <- model.response( + model.frame(bterms$respform, mf, na.action = na.pass) + ) + req_vars <- names(mf) + groups <- get_re_groups(bterms) + if (length(groups)) { + c(req_vars) <- unlist(strsplit(groups, ":")) + } + req_vars <- unique(setdiff(req_vars, effects)) + req_vars <- intersect(req_vars, names(conditions)) + if (length(req_vars)) { + # find out which data point is valid for which condition + cond__ <- get_cond__(conditions) + mf <- mf[, req_vars, drop = FALSE] + conditions <- conditions[, req_vars, drop = FALSE] + points$cond__ <- NA + points <- replicate(nrow(conditions), points, simplify = FALSE) + for (i in seq_along(points)) { + cond <- conditions[i, , drop = FALSE] + # ensures correct handling of matrix columns + not_na <- function(x) !any(is.na(x) | x %in% "zero__") + not_na <- ulapply(cond, not_na) + cond <- cond[, not_na, drop = FALSE] + mf_tmp <- mf[, not_na, drop = FALSE] + if (ncol(mf_tmp)) { + is_num <- sapply(mf_tmp, is.numeric) + is_num <- is_num & !names(mf_tmp) %in% groups + if (sum(is_num)) { + # handle numeric variables + stopifnot(select_points >= 0) + if (select_points > 0) { + for (v in names(mf_tmp)[is_num]) { + min <- min(mf_tmp[, v], na.rm = TRUE) + max <- max(mf_tmp[, v], na.rm = TRUE) + unit <- scale_unit(mf_tmp[, v], min, max) + unit_cond <- scale_unit(cond[, v], min, max) + unit_diff <- abs(unit - unit_cond) + close_enough <- unit_diff <= select_points + mf_tmp[[v]][close_enough] <- cond[, v] + mf_tmp[[v]][!close_enough] <- NA + } + } else { + # take all numeric values if select_points is zero + cond <- cond[, !is_num, drop = FALSE] + mf_tmp <- mf_tmp[, !is_num, drop = FALSE] + } + } + } + if (ncol(mf_tmp)) { + # handle factors and grouping variables + # do it like base::duplicated + K <- do_call("paste", c(mf_tmp, sep = "\r")) %in% + do_call("paste", c(cond, sep = "\r")) + } else { + K <- seq_rows(mf) + } + # cond__ allows to assign points to conditions + points[[i]]$cond__[K] <- cond__[i] + } + points <- do_call(rbind, points) + points <- points[!is.na(points$cond__), , drop = FALSE] + points$cond__ <- factor(points$cond__, cond__) + } + points <- add_effects__(points, effects) + if (!is.numeric(points$resp__)) { + points$resp__ <- as.numeric(as.factor(points$resp__)) + if (is_binary(bterms$family)) { + points$resp__ <- points$resp__ - 1 + } + } + if (!is.null(transform)) { + points$resp__ <- do_call(transform, list(points$resp__)) + } + points +} + +# add effect__ variables to the data +add_effects__ <- function(data, effects) { + for (i in seq_along(effects)) { + data[[paste0("effect", i, "__")]] <- eval2(effects[i], data) + } + data +} + +#' @export +print.brms_conditional_effects <- function(x, ...) { + plot(x, ...) +} + +#' @rdname conditional_effects.brmsfit +#' @method plot brms_conditional_effects +#' @export +plot.brms_conditional_effects <- function( + x, ncol = NULL, points = FALSE, rug = FALSE, mean = TRUE, + jitter_width = 0, stype = c("contour", "raster"), + line_args = list(), cat_args = list(), errorbar_args = list(), + surface_args = list(), spaghetti_args = list(), point_args = list(), + rug_args = list(), facet_args = list(), theme = NULL, ask = TRUE, + plot = TRUE, ... +) { + dots <- list(...) + plot <- use_alias(plot, dots$do_plot) + stype <- match.arg(stype) + smooths_only <- isTRUE(attr(x, "smooths_only")) + if (points && smooths_only) { + stop2("Argument 'points' is invalid for objects ", + "returned by 'conditional_smooths'.") + } + if (!is_equal(jitter_width, 0)) { + warning2("'jitter_width' is deprecated. Please use ", + "'point_args = list(width = )' instead.") + } + if (!is.null(theme) && !is.theme(theme)) { + stop2("Argument 'theme' should be a 'theme' object.") + } + if (plot) { + default_ask <- devAskNewPage() + on.exit(devAskNewPage(default_ask)) + devAskNewPage(ask = FALSE) + } + dont_replace <- c("mapping", "data", "inherit.aes") + plots <- named_list(names(x)) + for (i in seq_along(x)) { + response <- attr(x[[i]], "response") + effects <- attr(x[[i]], "effects") + ncond <- length(unique(x[[i]]$cond__)) + df_points <- attr(x[[i]], "points") + categorical <- isTRUE(attr(x[[i]], "categorical")) + catscale <- attr(x[[i]], "catscale") + surface <- isTRUE(attr(x[[i]], "surface")) + # deprecated as of brms 2.4.3 + ordinal <- isTRUE(attr(x[[i]], "ordinal")) + if (surface || ordinal) { + # surface plots for two dimensional interactions or ordinal plots + plots[[i]] <- ggplot(x[[i]]) + + aes_(~ effect1__, ~ effect2__) + + labs(x = effects[1], y = effects[2]) + if (ordinal) { + width <- ifelse(is_like_factor(x[[i]]$effect1__), 0.9, 1) + .surface_args <- nlist( + mapping = aes_(fill = ~ estimate__), + height = 0.9, width = width + ) + replace_args(.surface_args, dont_replace) <- surface_args + plots[[i]] <- plots[[i]] + + do_call(geom_tile, .surface_args) + + scale_fill_gradientn(colors = viridis6(), name = catscale) + + ylab(response) + } else if (stype == "contour") { + .surface_args <- nlist( + mapping = aes_(z = ~ estimate__, colour = ~ ..level..), + bins = 30, size = 1.3 + ) + replace_args(.surface_args, dont_replace) <- surface_args + plots[[i]] <- plots[[i]] + + do_call(geom_contour, .surface_args) + + scale_color_gradientn(colors = viridis6(), name = response) + } else if (stype == "raster") { + .surface_args <- nlist(mapping = aes_(fill = ~ estimate__)) + replace_args(.surface_args, dont_replace) <- surface_args + plots[[i]] <- plots[[i]] + + do_call(geom_raster, .surface_args) + + scale_fill_gradientn(colors = viridis6(), name = response) + } + } else { + # plot effects of single predictors or two-way interactions + gvar <- if (length(effects) == 2L) "effect2__" + spaghetti <- attr(x[[i]], "spaghetti") + plots[[i]] <- ggplot(x[[i]]) + + aes_string(x = "effect1__", y = "estimate__", colour = gvar) + + labs(x = effects[1], y = response, colour = effects[2]) + if (is.null(spaghetti)) { + plots[[i]] <- plots[[i]] + + aes_string(ymin = "lower__", ymax = "upper__", fill = gvar) + + labs(fill = effects[2]) + } + # extract suggested colors for later use + colors <- ggplot_build(plots[[i]]) + colors <- unique(colors$data[[1]][["colour"]]) + if (points && !categorical && !surface) { + # add points first so that they appear behind the predictions + .point_args <- list( + mapping = aes_string(x = "effect1__", y = "resp__"), + data = df_points, inherit.aes = FALSE, + size = 2 / ncond^0.25, height = 0, width = jitter_width + ) + if (is_like_factor(df_points[, gvar])) { + .point_args$mapping[c("colour", "fill")] <- + aes_string(colour = gvar, fill = gvar) + } + replace_args(.point_args, dont_replace) <- point_args + plots[[i]] <- plots[[i]] + + do_call(geom_jitter, .point_args) + } + if (!is.null(spaghetti)) { + # add a regression line for each sample separately + .spaghetti_args <- list( + aes_string(group = "sample__", colour = gvar), + data = spaghetti, stat = "identity", size = 0.5 + ) + if (length(effects) == 1L) { + .spaghetti_args$colour <- alpha("blue", 0.1) + } else { + # workaround to get transparent lines + plots[[i]] <- plots[[i]] + + scale_color_manual(values = alpha(colors, 0.1)) + } + replace_args(.spaghetti_args, dont_replace) <- spaghetti_args + plots[[i]] <- plots[[i]] + + do_call(geom_smooth, .spaghetti_args) + } + if (is.numeric(x[[i]]$effect1__)) { + # line plots for numeric predictors + .line_args <- list(stat = "identity") + if (!is.null(spaghetti)) { + # display a white mean regression line + .line_args$mapping <- aes_string(group = gvar) + .line_args$colour <- alpha("white", 0.8) + } + replace_args(.line_args, dont_replace) <- line_args + if (mean || is.null(spaghetti)) { + plots[[i]] <- plots[[i]] + + do_call(geom_smooth, .line_args) + } + if (rug) { + .rug_args <- list( + aes_string(x = "effect1__"), sides = "b", + data = df_points, inherit.aes = FALSE + ) + if (is_like_factor(df_points[, gvar])) { + .point_args$mapping[c("colour", "fill")] <- + aes_string(colour = gvar, fill = gvar) + } + replace_args(.rug_args, dont_replace) <- rug_args + plots[[i]] <- plots[[i]] + + do_call(geom_rug, .rug_args) + } + } else { + # points and errorbars for factors + .cat_args <- list( + position = position_dodge(width = 0.4), + size = 4 / ncond^0.25 + ) + .errorbar_args <- list( + position = position_dodge(width = 0.4), + width = 0.3 + ) + replace_args(.cat_args, dont_replace) <- cat_args + replace_args(.errorbar_args, dont_replace) <- errorbar_args + plots[[i]] <- plots[[i]] + + do_call(geom_point, .cat_args) + + do_call(geom_errorbar, .errorbar_args) + } + if (categorical) { + plots[[i]] <- plots[[i]] + ylab(catscale) + + labs(fill = response, color = response) + } + } + if (ncond > 1L) { + # one plot per row of conditions + if (is.null(ncol)) { + ncol <- max(floor(sqrt(ncond)), 3) + } + .facet_args <- nlist(facets = "cond__", ncol) + replace_args(.facet_args, dont_replace) <- facet_args + plots[[i]] <- plots[[i]] + + do_call(facet_wrap, .facet_args) + } + plots[[i]] <- plots[[i]] + theme + if (plot) { + plot(plots[[i]]) + if (i == 1) { + devAskNewPage(ask = ask) + } + } + } + invisible(plots) +} + +# the name 'marginal_effects' is deprecated as of brms 2.10.3 +# do not remove it eventually as it has been used in the brms papers +#' @export +marginal_effects <- function(x, ...) { + UseMethod("marginal_effects") +} + +#' @export +marginal_effects.brmsfit <- function(x, ...) { + warning2("Method 'marginal_effects' is deprecated. ", + "Please use 'conditional_effects' instead.") + conditional_effects.brmsfit(x, ...) +} + +#' @export +print.brmsMarginalEffects <- function(x, ...) { + class(x) <- "brms_conditional_effects" + print(x, ...) +} + +#' @export +plot.brmsMarginalEffects <- function(x, ...) { + class(x) <- "brms_conditional_effects" + plot(x, ...) +} diff -Nru r-cran-brms-2.16.3/R/conditional_smooths.R r-cran-brms-2.17.0/R/conditional_smooths.R --- r-cran-brms-2.16.3/R/conditional_smooths.R 2021-11-16 11:22:58.000000000 +0000 +++ r-cran-brms-2.17.0/R/conditional_smooths.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,56 +1,56 @@ #' Display Smooth Terms -#' +#' #' Display smooth \code{s} and \code{t2} terms of models #' fitted with \pkg{brms}. -#' +#' #' @aliases marginal_smooths marginal_smooths.brmsfit -#' +#' #' @inheritParams conditional_effects.brmsfit #' @param smooths Optional character vector of smooth terms #' to display. If \code{NULL} (the default) all smooth terms #' are shown. -#' @param ndraws Positive integer indicating how many -#' posterior draws should be used. +#' @param ndraws Positive integer indicating how many +#' posterior draws should be used. #' If \code{NULL} (the default) all draws are used. #' Ignored if \code{draw_ids} is not \code{NULL}. #' @param draw_ids An integer vector specifying -#' the posterior draws to be used. +#' the posterior draws to be used. #' If \code{NULL} (the default), all draws are used. #' @param nsamples Deprecated alias of \code{ndraws}. #' @param subset Deprecated alias of \code{draw_ids}. #' @param ... Currently ignored. -#' -#' @return For the \code{brmsfit} method, +#' +#' @return For the \code{brmsfit} method, #' an object of class \code{brms_conditional_effects}. See -#' \code{\link{conditional_effects}} for +#' \code{\link{conditional_effects}} for #' more details and documentation of the related plotting function. -#' +#' #' @details Two-dimensional smooth terms will be visualized using #' either contour or raster plots. -#' -#' @examples +#' +#' @examples #' \dontrun{ -#' set.seed(0) +#' set.seed(0) #' dat <- mgcv::gamSim(1, n = 200, scale = 2) #' fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) #' # show all smooth terms #' plot(conditional_smooths(fit), rug = TRUE, ask = FALSE) #' # show only the smooth term s(x2) #' plot(conditional_smooths(fit, smooths = "s(x2)"), ask = FALSE) -#' +#' #' # fit and plot a two-dimensional smooth term #' fit2 <- brm(y ~ t2(x0, x2), data = dat) #' ms <- conditional_smooths(fit2) #' plot(ms, stype = "contour") #' plot(ms, stype = "raster") #' } -#' +#' #' @export conditional_smooths.brmsfit <- function(x, smooths = NULL, int_conditions = NULL, prob = 0.95, spaghetti = FALSE, resolution = 100, too_far = 0, - ndraws = NULL, draw_ids = NULL, + ndraws = NULL, draw_ids = NULL, nsamples = NULL, subset = NULL, probs = NULL, ...) { probs <- validate_ci_bounds(prob, probs = probs) @@ -66,8 +66,8 @@ bterms <- brmsterms(exclude_terms(x$formula, smooths_only = TRUE)) out <- conditional_smooths( bterms, fit = x, smooths = smooths, - conditions = conditions, int_conditions = int_conditions, - too_far = too_far, resolution = resolution, probs = probs, + conditions = conditions, int_conditions = int_conditions, + too_far = too_far, resolution = resolution, probs = probs, spaghetti = spaghetti, draw_ids = draw_ids ) if (!length(out)) { @@ -116,8 +116,8 @@ # @param ...: currently ignored # @return a named list with one element per smooth term #' @export -conditional_smooths.btl <- function(x, fit, smooths, conditions, int_conditions, - probs, resolution, too_far, spaghetti, +conditional_smooths.btl <- function(x, fit, smooths, conditions, int_conditions, + probs, resolution, too_far, spaghetti, ...) { stopifnot(is.brmsfit(fit)) out <- list() @@ -148,10 +148,16 @@ values <- named_list(vars) is_numeric <- setNames(rep(FALSE, ncovars), covars) for (cv in covars) { - if (is.numeric(mf[[cv]])) { - is_numeric[cv] <- TRUE + is_numeric[cv] <- is.numeric(mf[[cv]]) + if (cv %in% names(int_conditions)) { + int_cond <- int_conditions[[cv]] + if (is.function(int_cond)) { + int_cond <- int_cond(mf[[cv]]) + } + values[[cv]] <- int_cond + } else if (is_numeric[cv]) { values[[cv]] <- seq( - min(mf[[cv]]), max(mf[[cv]]), + min(mf[[cv]]), max(mf[[cv]]), length.out = resolution ) } else { @@ -177,13 +183,13 @@ if (ncovars == 2L && too_far > 0) { # exclude prediction grid points too far from data ex_too_far <- mgcv::exclude.too.far( - g1 = newdata[[covars[1]]], - g2 = newdata[[covars[2]]], + g1 = newdata[[covars[1]]], + g2 = newdata[[covars[2]]], d1 = mf[, covars[1]], d2 = mf[, covars[2]], dist = too_far ) - newdata <- newdata[!ex_too_far, ] + newdata <- newdata[!ex_too_far, ] } other_vars <- setdiff(names(conditions), vars) newdata <- fill_newdata(newdata, other_vars, conditions) @@ -192,7 +198,7 @@ cond_data <- add_effects__(newdata[, vars, drop = FALSE], effects) if (length(byvars)) { # byvars will be plotted as facets - cond_data$cond__ <- rows2labels(cond_data[, byvars, drop = FALSE]) + cond_data$cond__ <- rows2labels(cond_data[, byvars, drop = FALSE]) } else { cond_data$cond__ <- factor(1) } diff -Nru r-cran-brms-2.16.3/R/data-helpers.R r-cran-brms-2.17.0/R/data-helpers.R --- r-cran-brms-2.16.3/R/data-helpers.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/data-helpers.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,632 +1,634 @@ -# update data for use in brms functions -# @param data the data passed by the user -# @param bterms object of class brmsterms -# @param na.action function defining how to treat NAs -# @param drop.unused.levels should unused factor levels be removed? -# @param attr_terms a list of attributes of the terms object of -# the original model.frame; only used with newdata; -# this ensures that (1) calls to 'poly' work correctly -# and (2) that the number of variables matches the number -# of variable names; fixes issue #73 -# @param knots: a list of knot values for GAMMs -# @return model.frame for use in brms functions -validate_data <- function(data, bterms, data2 = list(), knots = NULL, - na.action = na.omit2, drop.unused.levels = TRUE, - attr_terms = NULL) { - if (missing(data)) { - stop2("Data must be specified using the 'data' argument.") - } - if (is.null(knots)) { - knots <- get_knots(data) - } - data <- try(as.data.frame(data), silent = TRUE) - if (is(data, "try-error")) { - stop2("Argument 'data' must be coercible to a data.frame.") - } - if (!isTRUE(nrow(data) > 0L)) { - stop2("Argument 'data' does not contain observations.") - } - data <- data_rsv_intercept(data, bterms = bterms) - all_vars_formula <- bterms$allvars - missing_vars <- setdiff(all_vars(all_vars_formula), names(data)) - if (length(missing_vars)) { - missing_vars2 <- setdiff(missing_vars, names(data2)) - if (length(missing_vars2)) { - stop2("The following variables can neither be found in ", - "'data' nor in 'data2':\n", collapse_comma(missing_vars2)) - } - # all initially missing variables can be found in 'data2' - # they are not necessarily of the length required for 'data' - # so need to be excluded from the evaluation of 'model.frame' - missing_vars_formula <- paste0(". ~ . ", collapse(" - ", missing_vars)) - all_vars_formula <- update(all_vars_formula, missing_vars_formula) - } - all_vars_terms <- terms(all_vars_formula) - # ensure that 'data2' comes first in the search path - # during the evaluation of model.frame - terms_env <- environment(all_vars_terms) - environment(all_vars_terms) <- as.environment(as.list(data2)) - parent.env(environment(all_vars_terms)) <- terms_env - attributes(all_vars_terms)[names(attr_terms)] <- attr_terms - # 'terms' prevents correct validation in 'model.frame' - attr(data, "terms") <- NULL - data <- model.frame( - all_vars_terms, data, na.action = na.pass, - drop.unused.levels = drop.unused.levels - ) - data <- na.action(data, bterms = bterms) - if (any(grepl("__|_$", colnames(data)))) { - stop2("Variable names may not contain double underscores ", - "or underscores at the end.") - } - if (!isTRUE(nrow(data) > 0L)) { - stop2("All observations in the data were removed ", - "presumably because of NA values.") - } - groups <- get_group_vars(bterms) - data <- combine_groups(data, groups) - data <- fix_factor_contrasts(data, ignore = groups) - attr(data, "knots") <- knots - data -} - -# validate the 'data2' argument -# @param data2 a named list of data objects -# @param bterms object returned by 'brmsterms' -# @param ... more named list to pass objects to data2 from other sources -# only required for backwards compatibility with deprecated arguments -# @return a validated named list of data objects -validate_data2 <- function(data2, bterms, ...) { - # TODO: specify spline-related matrices in 'data2' - # this requires adding another parser layer with bterms and data as input - if (is.null(data2)) { - data2 <- list() - } - if (!is.list(data2)) { - stop2("'data2' must be a list.") - } - if (length(data2) && !is_named(data2)) { - stop2("All elements of 'data2' must be named.") - } - dots <- list(...) - for (i in seq_along(dots)) { - if (length(dots[[i]])) { - stopifnot(is.list(dots[[i]]), is_named(dots[[i]])) - data2[names(dots[[i]])] <- dots[[i]] - } - } - # validate autocorrelation matrices - acef <- tidy_acef(bterms) - sar_M_names <- get_ac_vars(acef, "M", class = "sar") - for (M in sar_M_names) { - data2[[M]] <- validate_sar_matrix(get_from_data2(M, data2)) - attr(data2[[M]], "obs_based_matrix") <- TRUE - } - car_M_names <- get_ac_vars(acef, "M", class = "car") - for (M in car_M_names) { - data2[[M]] <- validate_car_matrix(get_from_data2(M, data2)) - # observation based CAR matrices are deprecated and - # there is no need to label them as observation based - } - fcor_M_names <- get_ac_vars(acef, "M", class = "fcor") - for (M in fcor_M_names) { - data2[[M]] <- validate_fcor_matrix(get_from_data2(M, data2)) - attr(data2[[M]], "obs_based_matrix") <- TRUE - } - # validate within-group covariance matrices - cov_names <- ulapply(get_re(bterms)$gcall, "[[", "cov") - cov_names <- cov_names[nzchar(cov_names)] - for (cov in cov_names) { - data2[[cov]] <- validate_recov_matrix(get_from_data2(cov, data2)) - } - data2 -} - -# get an object from the 'data2' argument -get_from_data2 <- function(x, data2) { - if (!x %in% names(data2)) { - stop2("Object '", x, "' was not found in 'data2'.") - } - get(x, data2) -} - -# index observation based elements in 'data2' -# @param data2 a named list of objects -# @param i observation based indices -# @return data2 with potentially indexed elements -subset_data2 <- function(data2, i) { - if (!length(data2)) { - return(data2) - } - stopifnot(is.list(data2), is_named(data2)) - for (var in names(data2)) { - if (isTRUE(attr(data2[[var]], "obs_based_matrix"))) { - # matrices with dimensions equal to the number of observations - data2[[var]] <- data2[[var]][i, i, drop = FALSE] - attr(data2[[var]], "obs_based_matrix") <- TRUE - } - } - data2 -} - -# add the reserved intercept variables to the data -data_rsv_intercept <- function(data, bterms) { - fe_forms <- get_effect(bterms, "fe") - if (any(ulapply(fe_forms, no_int))) { - if ("intercept" %in% ulapply(fe_forms, all_vars)) { - warning2("Reserved variable name 'intercept' is deprecated. ", - "Please use 'Intercept' instead.") - } - if (any(data[["intercept"]] != 1)) { - stop2("Variable name 'intercept' is reserved in models ", - "without a population-level intercept.") - } - if (any(data[["Intercept"]] != 1)) { - stop2("Variable name 'Intercept' is reserved in models ", - "without a population-level intercept.") - } - data$intercept <- data$Intercept <- rep(1, length(data[[1]])) - } - data -} - -# combine grouping factors to form new variables -# @param data data.frame to be updated -# @param ... the grouping factors to be combined -# @return 'data' including the new combined grouping factors -combine_groups <- function(data, ...) { - group <- c(...) - for (i in seq_along(group)) { - sgroup <- unlist(strsplit(group[[i]], ":")) - if (length(sgroup) > 1L && !group[[i]] %in% names(data)) { - new_var <- get(sgroup[1], data) - for (j in 2:length(sgroup)) { - new_var <- paste0(new_var, "_", get(sgroup[j], data)) - } - data[[group[[i]]]] <- new_var - } - } - data -} - -# hard code factor contrasts to be independent of the global "contrasts" option -# @param data data.frame to be updated -# @param olddata: optional data.frame from which contrasts are taken if present -# @param ignore: names of variables for which not to fix contrasts -# @return 'data' with amended contrasts attributes -fix_factor_contrasts <- function(data, olddata = NULL, ignore = NULL) { - stopifnot(is(data, "data.frame")) - stopifnot(is.null(olddata) || is.list(olddata)) - olddata <- as.data.frame(olddata) # fixes issue #105 - for (i in seq_along(data)) { - needs_contrast <- is.factor(data[[i]]) && !names(data)[i] %in% ignore - if (needs_contrast && is.null(attr(data[[i]], "contrasts"))) { - old_contrasts <- attr(olddata[[names(data)[i]]], "contrasts") - if (!is.null(old_contrasts)) { - # take contrasts from olddata - contrasts(data[[i]]) <- old_contrasts - } else if (length(unique(data[[i]])) > 1L) { - # avoid error when supplying only a single level - # hard code current global "contrasts" option - contrasts(data[[i]]) <- contrasts(data[[i]]) - } - } - } - data -} - -# order data for use in time-series models -# @param data data.frame to be ordered -# @param bterms brmsterms of mvbrmsterms object -# @return 'data' potentially ordered differently -order_data <- function(data, bterms) { - # ordering does only matter for time-series models - time <- get_ac_vars(bterms, "time", dim = "time") - gr <- get_ac_vars(bterms, "gr", dim = "time") - if (length(time) > 1L || length(gr) > 1L) { - stop2("All time-series structures must have the same ", - "'time' and 'gr' variables.") - } - if (length(time) || length(gr)) { - if (length(gr)) { - gv <- data[[gr]] - } else { - gv <- rep(1L, nrow(data)) - } - if (length(time)) { - tv <- data[[time]] - } else { - tv <- seq_rows(data) - } - if (any(duplicated(data.frame(gv, tv)))) { - stop2("Time points within groups must be unique.") - } - new_order <- do_call(order, list(gv, tv)) - data <- data[new_order, , drop = FALSE] - # old_order will allow to retrieve the initial order of the data - attr(data, "old_order") <- order(new_order) - } - data -} - -# subset data according to addition argument 'subset' -subset_data <- function(data, bterms) { - if (has_subset(bterms)) { - # only evaluate a subset of the data - subset <- as.logical(get_ad_values(bterms, "subset", "subset", data)) - if (length(subset) != nrow(data)) { - stop2("Length of 'subset' does not match the rows of 'data'.") - } - if (anyNA(subset)) { - stop2("Subset variables may not contain NAs.") - } - # cross-formula indexing is no longer trivial for subsetted models - check_cross_formula_indexing(bterms) - data <- data[subset, , drop = FALSE] - } - if (!NROW(data)) { - stop2( - "All rows of 'data' were removed via 'subset'. ", - "Please make sure that variables do not contain NAs ", - "for observations in which they are supposed to be used. ", - "Please also make sure that each subset variable is ", - "TRUE for at least one observation." - ) - } - data -} - -# like stats:::na.omit.data.frame but allows to certain NA values -na.omit2 <- function(object, bterms, ...) { - stopifnot(is.data.frame(object)) - nobs <- nrow(object) - if (is.mvbrmsterms(bterms)) { - responses <- names(bterms$terms) - subsets <- lapply(bterms$terms, get_ad_values, "subset", "subset", object) - vars_sub <- lapply(bterms$terms, function(x) all_vars(x$allvars)) - } - vars_keep_na <- vars_keep_na(bterms) - omit <- logical(nobs) - for (v in names(object)) { - x <- object[[v]] - vars_v <- all_vars(v) - keep_all_na <- all(vars_v %in% vars_keep_na) - if (!is.atomic(x) || keep_all_na) { - next - } - if (!is.mvbrmsterms(bterms)) { - # remove all NAs in this variable - keep_na <- rep(FALSE, nobs) - } else { - # allow to retain NAs in subsetted variables - keep_na <- rep(TRUE, nobs) - for (r in responses) { - if (any(vars_v %in% vars_sub[[r]])) { - if (!is.null(subsets[[r]])) { - # keep NAs ignored because of 'subset' - keep_na <- keep_na & !subsets[[r]] - } else { - # remove all NAs in this variable - keep_na <- keep_na & FALSE - } - } - } - } - is_na <- is.na(x) - d <- dim(is_na) - if (is.null(d) || length(d) != 2L) { - omit <- omit | (is_na & !keep_na) - } else { - for (ii in seq_len(d[2L])) { - omit <- omit | (is_na[, ii] & !keep_na) - } - } - } - if (any(omit > 0L)) { - out <- object[!omit, , drop = FALSE] - temp <- setNames(seq(omit)[omit], attr(object, "row.names")[omit]) - attr(temp, "class") <- "omit" - attr(out, "na.action") <- temp - warning2("Rows containing NAs were excluded from the model.") - } else { - out <- object - } - out -} - -# get a single value per group -# @param x vector of values to extract one value per group -# @param gr vector of grouping values -# @return a vector of the same length as unique(group) -get_one_value_per_group <- function(x, gr) { - stopifnot(length(x) == length(gr)) - not_dupl_gr <- !duplicated(gr) - gr_unique <- gr[not_dupl_gr] - to_order <- order(gr_unique) - gr_unique <- gr_unique[to_order] - out <- x[not_dupl_gr][to_order] - names(out) <- gr_unique - out -} - -# extract knots values for use in spline terms -get_knots <- function(data) { - attr(data, "knots", TRUE) -} - -# extract name of the data as originally passed by the user -get_data_name <- function(data) { - out <- attr(data, "data_name", TRUE) - if (is.null(out)) { - out <- "NULL" - } - out -} - -#' Validate New Data -#' -#' Validate new data passed to post-processing methods of \pkg{brms}. Unless you -#' are a package developer, you will rarely need to call \code{validate_newdata} -#' directly. -#' -#' @inheritParams prepare_predictions -#' @param newdata A \code{data.frame} containing new data to be validated. -#' @param object A \code{brmsfit} object. -#' @param check_response Logical; Indicates if response variables should -#' be checked as well. Defaults to \code{TRUE}. -#' @param group_vars Optional names of grouping variables to be validated. -#' Defaults to all grouping variables in the model. -#' @param req_vars Optional names of variables required in \code{newdata}. -#' If \code{NULL} (the default), all variables in the original data -#' are required (unless ignored for some other reason). -#' @param ... Currently ignored. -#' -#' @return A validated \code{'data.frame'} based on \code{newdata}. -#' -#' @export -validate_newdata <- function( - newdata, object, re_formula = NULL, allow_new_levels = FALSE, - newdata2 = NULL, resp = NULL, check_response = TRUE, - incl_autocor = TRUE, group_vars = NULL, req_vars = NULL, ... -) { - newdata <- try(as.data.frame(newdata), silent = TRUE) - if (is(newdata, "try-error")) { - stop2("Argument 'newdata' must be coercible to a data.frame.") - } - object <- restructure(object) - object <- exclude_terms(object, incl_autocor = incl_autocor) - resp <- validate_resp(resp, object) - new_formula <- update_re_terms(formula(object), re_formula) - bterms <- brmsterms(new_formula, resp_rhs_all = FALSE) - - # fill values of not required variables - all_vars <- all.vars(bterms$allvars) - if (is.null(req_vars)) { - req_vars <- all_vars - } else { - req_vars <- as.character(req_vars) - req_vars <- intersect(req_vars, all_vars) - } - if (is.mvbrmsterms(bterms) && !is.null(resp)) { - # variables not used in the included model parts - # do not need to be specified in newdata - resp <- validate_resp(resp, bterms$responses) - form_req_vars <- lapply(bterms$terms[resp], "[[", "allvars") - form_req_vars <- allvars_formula(form_req_vars) - req_vars <- intersect(req_vars, all.vars(form_req_vars)) - } - not_req_vars <- setdiff(all_vars, req_vars) - not_req_vars <- setdiff(not_req_vars, names(newdata)) - newdata <- fill_newdata(newdata, not_req_vars, object$data) - # check response and addition variables - only_resp <- all.vars(bterms$respform) - only_resp <- setdiff(only_resp, all.vars(rhs(bterms$allvars))) - # always require 'dec' variables to be specified - dec_vars <- get_ad_vars(bterms, "dec") - missing_resp <- setdiff(c(only_resp, dec_vars), names(newdata)) - if (length(missing_resp)) { - if (check_response) { - stop2("Response variables must be specified in 'newdata'.\n", - "Missing variables: ", collapse_comma(missing_resp)) - } else { - newdata <- fill_newdata(newdata, missing_resp) - } - } - # censoring and weighting vars are unused in post-processing methods - cens_vars <- get_ad_vars(bterms, "cens") - for (v in setdiff(cens_vars, names(newdata))) { - newdata[[v]] <- 0 - } - weights_vars <- get_ad_vars(bterms, "weights") - for (v in setdiff(weights_vars, names(newdata))) { - newdata[[v]] <- 1 - } - mf <- model.frame(object) - for (i in seq_along(mf)) { - if (is_like_factor(mf[[i]])) { - mf[[i]] <- as.factor(mf[[i]]) - } - } - # fixes issue #279 - newdata <- data_rsv_intercept(newdata, bterms) - new_group_vars <- get_group_vars(bterms) - if (allow_new_levels && length(new_group_vars)) { - # grouping factors do not need to be specified - # by the user if new levels are allowed - mis_group_vars <- new_group_vars[!grepl(":", new_group_vars)] - mis_group_vars <- setdiff(mis_group_vars, names(newdata)) - newdata <- fill_newdata(newdata, mis_group_vars) - } - newdata <- combine_groups(newdata, new_group_vars) - # validate factor levels in newdata - if (is.null(group_vars)) { - group_vars <- get_group_vars(object) - } - do_check <- union(get_pred_vars(bterms), get_int_vars(bterms)) - dont_check <- union(group_vars, cens_vars) - dont_check <- setdiff(dont_check, do_check) - dont_check <- names(mf) %in% dont_check - is_factor <- ulapply(mf, is.factor) - factors <- mf[is_factor & !dont_check] - if (length(factors)) { - factor_names <- names(factors) - for (i in seq_along(factors)) { - new_factor <- newdata[[factor_names[i]]] - if (!is.null(new_factor)) { - if (!is.factor(new_factor)) { - new_factor <- factor(new_factor) - } - old_levels <- levels(factors[[i]]) - if (length(old_levels) <= 1L) { - # contrasts are not defined for factors with 1 or fewer levels - next - } - new_levels <- levels(new_factor) - old_contrasts <- contrasts(factors[[i]]) - old_ordered <- is.ordered(factors[[i]]) - to_zero <- is.na(new_factor) | new_factor %in% "zero__" - # don't add the 'zero__' level to response variables - is_resp <- factor_names[i] %in% all.vars(bterms$respform) - if (!is_resp && any(to_zero)) { - levels(new_factor) <- c(new_levels, "zero__") - new_factor[to_zero] <- "zero__" - old_levels <- c(old_levels, "zero__") - old_contrasts <- rbind(old_contrasts, zero__ = 0) - } - if (any(!new_levels %in% old_levels)) { - stop2( - "New factor levels are not allowed.", - "\nLevels allowed: ", collapse_comma(old_levels), - "\nLevels found: ", collapse_comma(new_levels) - ) - } - newdata[[factor_names[i]]] <- - factor(new_factor, old_levels, ordered = old_ordered) - # don't use contrasts(.) here to avoid dimension checks - attr(newdata[[factor_names[i]]], "contrasts") <- old_contrasts - } - } - } - # check if originally numeric variables are still numeric - num_names <- names(mf)[!is_factor] - num_names <- setdiff(num_names, group_vars) - for (nm in intersect(num_names, names(newdata))) { - if (!anyNA(newdata[[nm]]) && !is.numeric(newdata[[nm]])) { - stop2("Variable '", nm, "' was originally ", - "numeric but is not in 'newdata'.") - } - } - # validate monotonic variables - mo_vars <- get_sp_vars(bterms, "mo") - if (length(mo_vars)) { - # factors have already been checked - num_mo_vars <- names(mf)[!is_factor & names(mf) %in% mo_vars] - for (v in num_mo_vars) { - new_values <- get(v, newdata) - min_value <- min(mf[[v]]) - invalid <- new_values < min_value | new_values > max(mf[[v]]) - invalid <- invalid | !is_wholenumber(new_values) - if (sum(invalid)) { - stop2("Invalid values in variable '", v, "': ", - collapse_comma(new_values[invalid])) - } - attr(newdata[[v]], "min") <- min_value - } - } - # update_data expects all original variables to be present - used_vars <- c(names(newdata), all.vars(bterms$allvars)) - used_vars <- union(used_vars, rsv_vars(bterms)) - all_vars <- all.vars(str2formula(names(mf))) - unused_vars <- setdiff(all_vars, used_vars) - newdata <- fill_newdata(newdata, unused_vars) - # validate grouping factors - new_ranef <- tidy_ranef(bterms, data = mf) - new_meef <- tidy_meef(bterms, data = mf) - old_levels <- get_levels(new_ranef, new_meef) - if (!allow_new_levels) { - new_levels <- get_levels( - tidy_ranef(bterms, data = newdata), - tidy_meef(bterms, data = newdata) - ) - for (g in names(old_levels)) { - unknown_levels <- setdiff(new_levels[[g]], old_levels[[g]]) - if (length(unknown_levels)) { - unknown_levels <- collapse_comma(unknown_levels) - stop2( - "Levels ", unknown_levels, " of grouping factor '", g, "' ", - "cannot be found in the fitted model. ", - "Consider setting argument 'allow_new_levels' to TRUE." - ) - } - } - } - # ensure correct handling of functions like 'poly' or 'scale' - old_terms <- attr(object$data, "terms") - attr_terms <- c("variables", "predvars") - attr_terms <- attributes(old_terms)[attr_terms] - newdata <- validate_data( - newdata, bterms = bterms, na.action = na.pass, - drop.unused.levels = FALSE, attr_terms = attr_terms, - data2 = current_data2(object, newdata2), - knots = get_knots(object$data) - ) - newdata -} - -# fill newdata with values for not required variables -# @param newdata data.frame to be filled -# @param vars character vector of not required variables -# @param olddata optional data.frame to take values from -# @param n row number of olddata to extract values from -fill_newdata <- function(newdata, vars, olddata = NULL, n = 1L) { - stopifnot(is.data.frame(newdata), is.character(vars)) - vars <- setdiff(vars, names(newdata)) - if (is.null(olddata)) { - if (length(vars)) { - newdata[, vars] <- NA - } - return(newdata) - } - stopifnot(is.data.frame(olddata), length(n) == 1L) - for (v in vars) { - # using NA for variables is not safe in all cases - # for example when processing splines using mgcv - # hence it is safer to use existing data values - cval <- olddata[n, v] %||% NA - if (length(dim(cval)) == 2L) { - # matrix columns don't have automatic broadcasting apparently - cval <- matrix(cval, nrow(newdata), ncol(cval), byrow = TRUE) - } - newdata[[v]] <- cval - } - newdata -} - -# validate new data2 -validate_newdata2 <- function(newdata2, object, ...) { - stopifnot(is.brmsfit(object)) - bterms <- brmsterms(object$formula) - validate_data2(newdata2, bterms = bterms, ...) -} - -# extract the current data -current_data <- function(object, newdata = NULL, ...) { - stopifnot(is.brmsfit(object)) - if (is.null(newdata)) { - data <- object$data - } else { - data <- validate_newdata(newdata, object = object, ...) - } - data -} - -# extract the current data2 -current_data2 <- function(object, newdata2 = NULL, ...) { - stopifnot(is.brmsfit(object)) - if (is.null(newdata2)) { - data2 <- object$data2 - } else { - data2 <- validate_newdata2(newdata2, object = object, ...) - } - data2 -} +# update data for use in brms functions +# @param data the data passed by the user +# @param bterms object of class brmsterms +# @param na.action function defining how to treat NAs +# @param drop.unused.levels should unused factor levels be removed? +# @param attr_terms a list of attributes of the terms object of +# the original model.frame; only used with newdata; +# this ensures that (1) calls to 'poly' work correctly +# and (2) that the number of variables matches the number +# of variable names; fixes issue #73 +# @param knots: a list of knot values for GAMMs +# @return model.frame for use in brms functions +validate_data <- function(data, bterms, data2 = list(), knots = NULL, + na.action = na.omit2, drop.unused.levels = TRUE, + attr_terms = NULL) { + if (missing(data)) { + stop2("Data must be specified using the 'data' argument.") + } + if (is.null(knots)) { + knots <- get_knots(data) + } + data <- try(as.data.frame(data), silent = TRUE) + if (is(data, "try-error")) { + stop2("Argument 'data' must be coercible to a data.frame.") + } + if (!isTRUE(nrow(data) > 0L)) { + stop2("Argument 'data' does not contain observations.") + } + data <- data_rsv_intercept(data, bterms = bterms) + all_vars_formula <- bterms$allvars + missing_vars <- setdiff(all_vars(all_vars_formula), names(data)) + if (length(missing_vars)) { + missing_vars2 <- setdiff(missing_vars, names(data2)) + if (length(missing_vars2)) { + stop2("The following variables can neither be found in ", + "'data' nor in 'data2':\n", collapse_comma(missing_vars2)) + } + # all initially missing variables can be found in 'data2' + # they are not necessarily of the length required for 'data' + # so need to be excluded from the evaluation of 'model.frame' + missing_vars_formula <- paste0(". ~ . ", collapse(" - ", missing_vars)) + all_vars_formula <- update(all_vars_formula, missing_vars_formula) + } + all_vars_terms <- terms(all_vars_formula) + # ensure that 'data2' comes first in the search path + # during the evaluation of model.frame + terms_env <- environment(all_vars_terms) + environment(all_vars_terms) <- as.environment(as.list(data2)) + parent.env(environment(all_vars_terms)) <- terms_env + attributes(all_vars_terms)[names(attr_terms)] <- attr_terms + # 'terms' prevents correct validation in 'model.frame' + attr(data, "terms") <- NULL + data <- model.frame( + all_vars_terms, data, na.action = na.pass, + drop.unused.levels = drop.unused.levels + ) + data <- na.action(data, bterms = bterms) + if (any(grepl("__|_$", colnames(data)))) { + stop2("Variable names may not contain double underscores ", + "or underscores at the end.") + } + if (!isTRUE(nrow(data) > 0L)) { + stop2("All observations in the data were removed ", + "presumably because of NA values.") + } + groups <- get_group_vars(bterms) + data <- combine_groups(data, groups) + data <- fix_factor_contrasts(data, ignore = groups) + attr(data, "knots") <- knots + data +} + +# validate the 'data2' argument +# @param data2 a named list of data objects +# @param bterms object returned by 'brmsterms' +# @param ... more named list to pass objects to data2 from other sources +# only required for backwards compatibility with deprecated arguments +# @return a validated named list of data objects +validate_data2 <- function(data2, bterms, ...) { + # TODO: specify spline-related matrices in 'data2' + # this requires adding another parser layer with bterms and data as input + if (is.null(data2)) { + data2 <- list() + } + if (!is.list(data2)) { + stop2("'data2' must be a list.") + } + if (length(data2) && !is_named(data2)) { + stop2("All elements of 'data2' must be named.") + } + dots <- list(...) + for (i in seq_along(dots)) { + if (length(dots[[i]])) { + stopifnot(is.list(dots[[i]]), is_named(dots[[i]])) + data2[names(dots[[i]])] <- dots[[i]] + } + } + # validate autocorrelation matrices + acef <- tidy_acef(bterms) + sar_M_names <- get_ac_vars(acef, "M", class = "sar") + for (M in sar_M_names) { + data2[[M]] <- validate_sar_matrix(get_from_data2(M, data2)) + attr(data2[[M]], "obs_based_matrix") <- TRUE + } + car_M_names <- get_ac_vars(acef, "M", class = "car") + for (M in car_M_names) { + data2[[M]] <- validate_car_matrix(get_from_data2(M, data2)) + # observation based CAR matrices are deprecated and + # there is no need to label them as observation based + } + fcor_M_names <- get_ac_vars(acef, "M", class = "fcor") + for (M in fcor_M_names) { + data2[[M]] <- validate_fcor_matrix(get_from_data2(M, data2)) + attr(data2[[M]], "obs_based_matrix") <- TRUE + } + # validate within-group covariance matrices + cov_names <- ulapply(get_re(bterms)$gcall, "[[", "cov") + cov_names <- cov_names[nzchar(cov_names)] + for (cov in cov_names) { + data2[[cov]] <- validate_recov_matrix(get_from_data2(cov, data2)) + } + data2 +} + +# get an object from the 'data2' argument +get_from_data2 <- function(x, data2) { + if (!x %in% names(data2)) { + stop2("Object '", x, "' was not found in 'data2'.") + } + get(x, data2) +} + +# index observation based elements in 'data2' +# @param data2 a named list of objects +# @param i observation based indices +# @return data2 with potentially indexed elements +subset_data2 <- function(data2, i) { + if (!length(data2)) { + return(data2) + } + stopifnot(is.list(data2), is_named(data2)) + for (var in names(data2)) { + if (isTRUE(attr(data2[[var]], "obs_based_matrix"))) { + # matrices with dimensions equal to the number of observations + data2[[var]] <- data2[[var]][i, i, drop = FALSE] + attr(data2[[var]], "obs_based_matrix") <- TRUE + } + } + data2 +} + +# add the reserved intercept variables to the data +data_rsv_intercept <- function(data, bterms) { + fe_forms <- get_effect(bterms, "fe") + if (any(ulapply(fe_forms, no_int))) { + if ("intercept" %in% ulapply(fe_forms, all_vars)) { + warning2("Reserved variable name 'intercept' is deprecated. ", + "Please use 'Intercept' instead.") + } + if (any(data[["intercept"]] != 1)) { + stop2("Variable name 'intercept' is reserved in models ", + "without a population-level intercept.") + } + if (any(data[["Intercept"]] != 1)) { + stop2("Variable name 'Intercept' is reserved in models ", + "without a population-level intercept.") + } + data$intercept <- data$Intercept <- rep(1, length(data[[1]])) + } + data +} + +# combine grouping factors to form new variables +# @param data data.frame to be updated +# @param ... the grouping factors to be combined +# @return 'data' including the new combined grouping factors +combine_groups <- function(data, ...) { + group <- c(...) + for (i in seq_along(group)) { + sgroup <- unlist(strsplit(group[[i]], ":")) + if (length(sgroup) > 1L && !group[[i]] %in% names(data)) { + new_var <- get(sgroup[1], data) + for (j in 2:length(sgroup)) { + new_var <- paste0(new_var, "_", get(sgroup[j], data)) + } + data[[group[[i]]]] <- new_var + } + } + data +} + +# hard code factor contrasts to be independent of the global "contrasts" option +# @param data data.frame to be updated +# @param olddata: optional data.frame from which contrasts are taken if present +# @param ignore: names of variables for which not to fix contrasts +# @return 'data' with amended contrasts attributes +fix_factor_contrasts <- function(data, olddata = NULL, ignore = NULL) { + stopifnot(is(data, "data.frame")) + stopifnot(is.null(olddata) || is.list(olddata)) + olddata <- as.data.frame(olddata) # fixes issue #105 + for (i in seq_along(data)) { + needs_contrast <- is.factor(data[[i]]) && !names(data)[i] %in% ignore + if (needs_contrast && is.null(attr(data[[i]], "contrasts"))) { + old_contrasts <- attr(olddata[[names(data)[i]]], "contrasts") + if (!is.null(old_contrasts)) { + # take contrasts from olddata + contrasts(data[[i]]) <- old_contrasts + } else if (length(unique(data[[i]])) > 1L) { + # avoid error when supplying only a single level + # hard code current global "contrasts" option + contrasts(data[[i]]) <- contrasts(data[[i]]) + } + } + } + data +} + +# order data for use in time-series models +# @param data data.frame to be ordered +# @param bterms brmsterms of mvbrmsterms object +# @return 'data' potentially ordered differently +order_data <- function(data, bterms) { + # ordering does only matter for time-series models + time <- get_ac_vars(bterms, "time", dim = "time") + gr <- get_ac_vars(bterms, "gr", dim = "time") + if (length(time) > 1L || length(gr) > 1L) { + stop2("All time-series structures must have the same ", + "'time' and 'gr' variables.") + } + if (length(time) || length(gr)) { + if (length(gr)) { + gv <- data[[gr]] + } else { + gv <- rep(1L, nrow(data)) + } + if (length(time)) { + tv <- data[[time]] + } else { + tv <- seq_rows(data) + } + if (any(duplicated(data.frame(gv, tv)))) { + stop2("Time points within groups must be unique.") + } + new_order <- do_call(order, list(gv, tv)) + data <- data[new_order, , drop = FALSE] + # old_order will allow to retrieve the initial order of the data + attr(data, "old_order") <- order(new_order) + } + data +} + +# subset data according to addition argument 'subset' +subset_data <- function(data, bterms) { + if (has_subset(bterms)) { + # only evaluate a subset of the data + subset <- as.logical(get_ad_values(bterms, "subset", "subset", data)) + if (length(subset) != nrow(data)) { + stop2("Length of 'subset' does not match the rows of 'data'.") + } + if (anyNA(subset)) { + stop2("Subset variables may not contain NAs.") + } + # cross-formula indexing is no longer trivial for subsetted models + check_cross_formula_indexing(bterms) + data <- data[subset, , drop = FALSE] + } + if (!NROW(data)) { + stop2( + "All rows of 'data' were removed via 'subset'. ", + "Please make sure that variables do not contain NAs ", + "for observations in which they are supposed to be used. ", + "Please also make sure that each subset variable is ", + "TRUE for at least one observation." + ) + } + data +} + +# like stats:::na.omit.data.frame but allows to certain NA values +na.omit2 <- function(object, bterms, ...) { + stopifnot(is.data.frame(object)) + nobs <- nrow(object) + if (is.mvbrmsterms(bterms)) { + responses <- names(bterms$terms) + subsets <- lapply(bterms$terms, get_ad_values, "subset", "subset", object) + vars_sub <- lapply(bterms$terms, function(x) all_vars(x$allvars)) + } + vars_keep_na <- vars_keep_na(bterms) + omit <- logical(nobs) + for (v in names(object)) { + x <- object[[v]] + vars_v <- all_vars(v) + keep_all_na <- all(vars_v %in% vars_keep_na) + if (!is.atomic(x) || keep_all_na) { + next + } + if (!is.mvbrmsterms(bterms)) { + # remove all NAs in this variable + keep_na <- rep(FALSE, nobs) + } else { + # allow to retain NAs in subsetted variables + keep_na <- rep(TRUE, nobs) + for (r in responses) { + if (any(vars_v %in% vars_sub[[r]])) { + if (!is.null(subsets[[r]])) { + # keep NAs ignored because of 'subset' + keep_na <- keep_na & !subsets[[r]] + } else { + # remove all NAs in this variable + keep_na <- keep_na & FALSE + } + } + } + } + is_na <- is.na(x) + d <- dim(is_na) + if (is.null(d) || length(d) != 2L) { + omit <- omit | (is_na & !keep_na) + } else { + for (ii in seq_len(d[2L])) { + omit <- omit | (is_na[, ii] & !keep_na) + } + } + } + if (any(omit > 0L)) { + out <- object[!omit, , drop = FALSE] + temp <- setNames(seq(omit)[omit], attr(object, "row.names")[omit]) + attr(temp, "class") <- "omit" + attr(out, "na.action") <- temp + warning2("Rows containing NAs were excluded from the model.") + } else { + out <- object + } + out +} + +# get a single value per group +# @param x vector of values to extract one value per group +# @param gr vector of grouping values +# @return a vector of the same length as unique(group) +get_one_value_per_group <- function(x, gr) { + stopifnot(length(x) == length(gr)) + not_dupl_gr <- !duplicated(gr) + gr_unique <- gr[not_dupl_gr] + to_order <- order(gr_unique) + gr_unique <- gr_unique[to_order] + out <- x[not_dupl_gr][to_order] + names(out) <- gr_unique + out +} + +# extract knots values for use in spline terms +get_knots <- function(data) { + attr(data, "knots", TRUE) +} + +# extract name of the data as originally passed by the user +get_data_name <- function(data) { + out <- attr(data, "data_name", TRUE) + if (is.null(out)) { + out <- "NULL" + } + out +} + +#' Validate New Data +#' +#' Validate new data passed to post-processing methods of \pkg{brms}. Unless you +#' are a package developer, you will rarely need to call \code{validate_newdata} +#' directly. +#' +#' @inheritParams prepare_predictions +#' @param newdata A \code{data.frame} containing new data to be validated. +#' @param object A \code{brmsfit} object. +#' @param check_response Logical; Indicates if response variables should +#' be checked as well. Defaults to \code{TRUE}. +#' @param group_vars Optional names of grouping variables to be validated. +#' Defaults to all grouping variables in the model. +#' @param req_vars Optional names of variables required in \code{newdata}. +#' If \code{NULL} (the default), all variables in the original data +#' are required (unless ignored for some other reason). +#' @param ... Currently ignored. +#' +#' @return A validated \code{'data.frame'} based on \code{newdata}. +#' +#' @export +validate_newdata <- function( + newdata, object, re_formula = NULL, allow_new_levels = FALSE, + newdata2 = NULL, resp = NULL, check_response = TRUE, + incl_autocor = TRUE, group_vars = NULL, req_vars = NULL, ... +) { + newdata <- try(as.data.frame(newdata), silent = TRUE) + if (is(newdata, "try-error")) { + stop2("Argument 'newdata' must be coercible to a data.frame.") + } + object <- restructure(object) + object <- exclude_terms(object, incl_autocor = incl_autocor) + resp <- validate_resp(resp, object) + new_formula <- update_re_terms(formula(object), re_formula) + bterms <- brmsterms(new_formula, resp_rhs_all = FALSE) + + # fill values of not required variables + all_vars <- all.vars(bterms$allvars) + if (is.null(req_vars)) { + req_vars <- all_vars + } else { + req_vars <- as.character(req_vars) + req_vars <- intersect(req_vars, all_vars) + } + if (is.mvbrmsterms(bterms) && !is.null(resp)) { + # variables not used in the included model parts + # do not need to be specified in newdata + resp <- validate_resp(resp, bterms$responses) + form_req_vars <- lapply(bterms$terms[resp], "[[", "allvars") + form_req_vars <- allvars_formula(form_req_vars) + req_vars <- intersect(req_vars, all.vars(form_req_vars)) + } + not_req_vars <- setdiff(all_vars, req_vars) + not_req_vars <- setdiff(not_req_vars, names(newdata)) + newdata <- fill_newdata(newdata, not_req_vars, object$data) + # check response and addition variables + only_resp <- all.vars(bterms$respform) + only_resp <- setdiff(only_resp, all.vars(rhs(bterms$allvars))) + # always require 'dec' variables to be specified + dec_vars <- get_ad_vars(bterms, "dec") + missing_resp <- setdiff(c(only_resp, dec_vars), names(newdata)) + if (length(missing_resp)) { + if (check_response) { + stop2("Response variables must be specified in 'newdata'.\n", + "Missing variables: ", collapse_comma(missing_resp)) + } else { + newdata <- fill_newdata(newdata, missing_resp) + } + } + # censoring and weighting vars are unused in post-processing methods + cens_vars <- get_ad_vars(bterms, "cens") + for (v in setdiff(cens_vars, names(newdata))) { + newdata[[v]] <- 0 + } + weights_vars <- get_ad_vars(bterms, "weights") + for (v in setdiff(weights_vars, names(newdata))) { + newdata[[v]] <- 1 + } + mf <- model.frame(object) + for (i in seq_along(mf)) { + if (is_like_factor(mf[[i]])) { + mf[[i]] <- as.factor(mf[[i]]) + } + } + # fixes issue #279 + newdata <- data_rsv_intercept(newdata, bterms) + new_group_vars <- get_group_vars(bterms) + if (allow_new_levels && length(new_group_vars)) { + # grouping factors do not need to be specified + # by the user if new levels are allowed + mis_group_vars <- new_group_vars[!grepl(":", new_group_vars)] + mis_group_vars <- setdiff(mis_group_vars, names(newdata)) + newdata <- fill_newdata(newdata, mis_group_vars) + } + newdata <- combine_groups(newdata, new_group_vars) + # validate factor levels in newdata + if (is.null(group_vars)) { + group_vars <- get_group_vars(object) + } + do_check <- union(get_pred_vars(bterms), get_int_vars(bterms)) + # do not check variables from the 'unused' argument #1238 + unused_arg_vars <- get_unused_arg_vars(bterms) + dont_check <- unique(c(group_vars, cens_vars, unused_arg_vars)) + dont_check <- setdiff(dont_check, do_check) + dont_check <- names(mf) %in% dont_check + is_factor <- ulapply(mf, is.factor) + factors <- mf[is_factor & !dont_check] + if (length(factors)) { + factor_names <- names(factors) + for (i in seq_along(factors)) { + new_factor <- newdata[[factor_names[i]]] + if (!is.null(new_factor)) { + if (!is.factor(new_factor)) { + new_factor <- factor(new_factor) + } + old_levels <- levels(factors[[i]]) + if (length(old_levels) <= 1L) { + # contrasts are not defined for factors with 1 or fewer levels + next + } + new_levels <- levels(new_factor) + old_contrasts <- contrasts(factors[[i]]) + old_ordered <- is.ordered(factors[[i]]) + to_zero <- is.na(new_factor) | new_factor %in% "zero__" + # don't add the 'zero__' level to response variables + is_resp <- factor_names[i] %in% all.vars(bterms$respform) + if (!is_resp && any(to_zero)) { + levels(new_factor) <- c(new_levels, "zero__") + new_factor[to_zero] <- "zero__" + old_levels <- c(old_levels, "zero__") + old_contrasts <- rbind(old_contrasts, zero__ = 0) + } + if (any(!new_levels %in% old_levels)) { + stop2( + "New factor levels are not allowed.", + "\nLevels allowed: ", collapse_comma(old_levels), + "\nLevels found: ", collapse_comma(new_levels) + ) + } + newdata[[factor_names[i]]] <- + factor(new_factor, old_levels, ordered = old_ordered) + # don't use contrasts(.) here to avoid dimension checks + attr(newdata[[factor_names[i]]], "contrasts") <- old_contrasts + } + } + } + # check if originally numeric variables are still numeric + num_names <- names(mf)[!is_factor] + num_names <- setdiff(num_names, group_vars) + for (nm in intersect(num_names, names(newdata))) { + if (!anyNA(newdata[[nm]]) && !is.numeric(newdata[[nm]])) { + stop2("Variable '", nm, "' was originally ", + "numeric but is not in 'newdata'.") + } + } + # validate monotonic variables + mo_vars <- get_sp_vars(bterms, "mo") + if (length(mo_vars)) { + # factors have already been checked + num_mo_vars <- names(mf)[!is_factor & names(mf) %in% mo_vars] + for (v in num_mo_vars) { + new_values <- get(v, newdata) + min_value <- min(mf[[v]]) + invalid <- new_values < min_value | new_values > max(mf[[v]]) + invalid <- invalid | !is_wholenumber(new_values) + if (sum(invalid)) { + stop2("Invalid values in variable '", v, "': ", + collapse_comma(new_values[invalid])) + } + attr(newdata[[v]], "min") <- min_value + } + } + # update_data expects all original variables to be present + used_vars <- c(names(newdata), all.vars(bterms$allvars)) + used_vars <- union(used_vars, rsv_vars(bterms)) + all_vars <- all.vars(str2formula(names(mf))) + unused_vars <- setdiff(all_vars, used_vars) + newdata <- fill_newdata(newdata, unused_vars) + # validate grouping factors + new_ranef <- tidy_ranef(bterms, data = mf) + new_meef <- tidy_meef(bterms, data = mf) + old_levels <- get_levels(new_ranef, new_meef) + if (!allow_new_levels) { + new_levels <- get_levels( + tidy_ranef(bterms, data = newdata), + tidy_meef(bterms, data = newdata) + ) + for (g in names(old_levels)) { + unknown_levels <- setdiff(new_levels[[g]], old_levels[[g]]) + if (length(unknown_levels)) { + unknown_levels <- collapse_comma(unknown_levels) + stop2( + "Levels ", unknown_levels, " of grouping factor '", g, "' ", + "cannot be found in the fitted model. ", + "Consider setting argument 'allow_new_levels' to TRUE." + ) + } + } + } + # ensure correct handling of functions like 'poly' or 'scale' + old_terms <- attr(object$data, "terms") + attr_terms <- c("variables", "predvars") + attr_terms <- attributes(old_terms)[attr_terms] + newdata <- validate_data( + newdata, bterms = bterms, na.action = na.pass, + drop.unused.levels = FALSE, attr_terms = attr_terms, + data2 = current_data2(object, newdata2), + knots = get_knots(object$data) + ) + newdata +} + +# fill newdata with values for not required variables +# @param newdata data.frame to be filled +# @param vars character vector of not required variables +# @param olddata optional data.frame to take values from +# @param n row number of olddata to extract values from +fill_newdata <- function(newdata, vars, olddata = NULL, n = 1L) { + stopifnot(is.data.frame(newdata), is.character(vars)) + vars <- setdiff(vars, names(newdata)) + if (is.null(olddata)) { + if (length(vars)) { + newdata[, vars] <- NA + } + return(newdata) + } + stopifnot(is.data.frame(olddata), length(n) == 1L) + for (v in vars) { + # using NA for variables is not safe in all cases + # for example when processing splines using mgcv + # hence it is safer to use existing data values + cval <- olddata[n, v] %||% NA + if (length(dim(cval)) == 2L) { + # matrix columns don't have automatic broadcasting apparently + cval <- matrix(cval, nrow(newdata), ncol(cval), byrow = TRUE) + } + newdata[[v]] <- cval + } + newdata +} + +# validate new data2 +validate_newdata2 <- function(newdata2, object, ...) { + stopifnot(is.brmsfit(object)) + bterms <- brmsterms(object$formula) + validate_data2(newdata2, bterms = bterms, ...) +} + +# extract the current data +current_data <- function(object, newdata = NULL, ...) { + stopifnot(is.brmsfit(object)) + if (is.null(newdata)) { + data <- object$data + } else { + data <- validate_newdata(newdata, object = object, ...) + } + data +} + +# extract the current data2 +current_data2 <- function(object, newdata2 = NULL, ...) { + stopifnot(is.brmsfit(object)) + if (is.null(newdata2)) { + data2 <- object$data2 + } else { + data2 <- validate_newdata2(newdata2, object = object, ...) + } + data2 +} diff -Nru r-cran-brms-2.16.3/R/data-predictor.R r-cran-brms-2.17.0/R/data-predictor.R --- r-cran-brms-2.16.3/R/data-predictor.R 2021-10-24 19:19:16.000000000 +0000 +++ r-cran-brms-2.17.0/R/data-predictor.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,983 +1,983 @@ -#' Prepare Predictor Data -#' -#' Prepare data related to predictor variables in \pkg{brms}. -#' Only exported for use in package development. -#' -#' @param x An \R object. -#' @param ... Further arguments passed to or from other methods. -#' -#' @return A named list of data related to predictor variables. -#' -#' @keywords internal -#' @export -data_predictor <- function(x, ...) { - UseMethod("data_predictor") -} - -#' @export -data_predictor.mvbrmsterms <- function(x, data, basis = NULL, ...) { - out <- list(N = nrow(data)) - for (r in names(x$terms)) { - bs <- basis$resps[[r]] - c(out) <- data_predictor(x$terms[[r]], data = data, basis = bs, ...) - } - out -} - -#' @export -data_predictor.brmsterms <- function(x, data, data2, prior, ranef, - basis = NULL, ...) { - out <- list() - data <- subset_data(data, x) - resp <- usc(combine_prefix(x)) - args_eff <- nlist(data, data2, ranef, prior, ...) - for (dp in names(x$dpars)) { - args_eff_spec <- list(x = x$dpars[[dp]], basis = basis$dpars[[dp]]) - c(out) <- do_call(data_predictor, c(args_eff_spec, args_eff)) - } - for (dp in names(x$fdpars)) { - if (is.numeric(x$fdpars[[dp]]$value)) { - out[[paste0(dp, resp)]] <- x$fdpars[[dp]]$value - } - } - for (nlp in names(x$nlpars)) { - args_eff_spec <- list(x = x$nlpars[[nlp]], basis = basis$nlpars[[nlp]]) - c(out) <- do_call(data_predictor, c(args_eff_spec, args_eff)) - } - c(out) <- data_gr_local(x, data = data, ranef = ranef) - c(out) <- data_mixture(x, data2 = data2, prior = prior) - out -} - -# prepare data for all types of effects for use in Stan -# @param data the data passed by the user -# @param ranef object retuend by 'tidy_ranef' -# @param prior an object of class brmsprior -# @param basis information from original Stan data used to correctly -# predict from new data. See 'standata_basis' for details. -# @param ... currently ignored -# @return a named list of data to be passed to Stan -#' @export -data_predictor.btl <- function(x, data, ranef = empty_ranef(), - prior = brmsprior(), data2 = list(), - index = NULL, basis = NULL, ...) { - out <- c( - data_fe(x, data), - data_sp(x, data, data2 = data2, prior = prior, index = index, basis = basis$sp), - data_re(x, data, ranef = ranef), - data_cs(x, data), - data_sm(x, data, basis = basis$sm), - data_gp(x, data, basis = basis$gp), - data_ac(x, data, data2 = data2, basis = basis$ac), - data_offset(x, data), - data_bhaz(x, data, data2 = data2, prior = prior, basis = basis$bhaz) - ) - c(out) <- data_prior(x, data, prior = prior, sdata = out) - out -} - -# prepare data for non-linear parameters for use in Stan -#' @export -data_predictor.btnl <- function(x, data, data2 = list(), - basis = NULL, ...) { - out <- list() - c(out) <- data_cnl(x, data) - c(out) <- data_ac(x, data, data2 = data2, basis = basis$ac) - out -} - -# prepare data of fixed effects -data_fe <- function(bterms, data) { - out <- list() - p <- usc(combine_prefix(bterms)) - # the intercept is removed inside the Stan code for ordinal models - cols2remove <- if (is_ordinal(bterms)) "(Intercept)" - X <- get_model_matrix(rhs(bterms$fe), data, cols2remove = cols2remove) - avoid_dpars(colnames(X), bterms = bterms) - out[[paste0("K", p)]] <- ncol(X) - out[[paste0("X", p)]] <- X - out -} - -# data preparation for splines -data_sm <- function(bterms, data, basis = NULL) { - out <- list() - smterms <- all_terms(bterms[["sm"]]) - if (!length(smterms)) { - return(out) - } - p <- usc(combine_prefix(bterms)) - new <- length(basis) > 0L - if (!new) { - knots <- get_knots(data) - basis <- named_list(smterms) - for (i in seq_along(smterms)) { - # the spline penalty has changed in 2.8.7 (#646) - diagonal.penalty <- !require_old_default("2.8.7") - basis[[i]] <- smoothCon( - eval2(smterms[i]), data = data, - knots = knots, absorb.cons = TRUE, - diagonal.penalty = diagonal.penalty - ) - } - } - bylevels <- named_list(smterms) - ns <- 0 - lXs <- list() - for (i in seq_along(basis)) { - # may contain multiple terms when 'by' is a factor - for (j in seq_along(basis[[i]])) { - ns <- ns + 1 - sm <- basis[[i]][[j]] - if (length(sm$by.level)) { - bylevels[[i]][j] <- sm$by.level - } - if (new) { - # prepare rasm for use with new data - rasm <- s2rPred(sm, data) - } else { - rasm <- mgcv::smooth2random(sm, names(data), type = 2) - } - lXs[[ns]] <- rasm$Xf - if (NCOL(lXs[[ns]])) { - colnames(lXs[[ns]]) <- paste0(sm$label, "_", seq_cols(lXs[[ns]])) - } - Zs <- rasm$rand - Zs <- setNames(Zs, paste0("Zs", p, "_", ns, "_", seq_along(Zs))) - tmp <- list(length(Zs), as.array(ulapply(Zs, ncol))) - tmp <- setNames(tmp, paste0(c("nb", "knots"), p, "_", ns)) - c(out) <- c(tmp, Zs) - } - } - Xs <- do_call(cbind, lXs) - avoid_dpars(colnames(Xs), bterms = bterms) - smcols <- lapply(lXs, function(x) which(colnames(Xs) %in% colnames(x))) - Xs <- structure(Xs, smcols = smcols, bylevels = bylevels) - colnames(Xs) <- rename(colnames(Xs)) - out[[paste0("Ks", p)]] <- ncol(Xs) - out[[paste0("Xs", p)]] <- Xs - out -} - -# prepare data for group-level effects for use in Stan -data_re <- function(bterms, data, ranef) { - out <- list() - px <- check_prefix(bterms) - take <- find_rows(ranef, ls = px) & !find_rows(ranef, type = "sp") - ranef <- ranef[take, ] - if (!nrow(ranef)) { - return(out) - } - gn <- unique(ranef$gn) - for (i in seq_along(gn)) { - r <- subset2(ranef, gn = gn[i]) - Z <- get_model_matrix(r$form[[1]], data = data, rename = FALSE) - idp <- paste0(r$id[1], usc(combine_prefix(px))) - Znames <- paste0("Z_", idp, "_", r$cn) - if (r$gtype[1] == "mm") { - ng <- length(r$gcall[[1]]$groups) - if (r$type[1] == "cs") { - stop2("'cs' is not supported in multi-membership terms.") - } - if (r$type[1] == "mmc") { - # see issue #353 for the general idea - mmc_expr <- "^mmc\\([^:]*\\)" - mmc_terms <- get_matches_expr(mmc_expr, colnames(Z)) - for (t in mmc_terms) { - pos <- which(grepl_expr(escape_all(t), colnames(Z))) - if (length(pos) != ng) { - stop2("Invalid term '", t, "': Expected ", ng, - " coefficients but found ", length(pos), ".") - } - for (j in seq_along(Znames)) { - for (k in seq_len(ng)) { - out[[paste0(Znames[j], "_", k)]] <- as.array(Z[, pos[k]]) - } - } - } - } else { - for (j in seq_along(Znames)) { - out[paste0(Znames[j], "_", seq_len(ng))] <- list(as.array(Z[, j])) - } - } - } else { - if (r$type[1] == "cs") { - ncatM1 <- nrow(r) / ncol(Z) - Z_temp <- vector("list", ncol(Z)) - for (k in seq_along(Z_temp)) { - Z_temp[[k]] <- replicate(ncatM1, Z[, k], simplify = FALSE) - } - Z <- do_call(cbind, unlist(Z_temp, recursive = FALSE)) - } - if (r$type[1] == "mmc") { - stop2("'mmc' is only supported in multi-membership terms.") - } - for (j in seq_cols(Z)) { - out[[Znames[j]]] <- as.array(Z[, j]) - } - } - } - out -} - -# compute data for each group-level-ID per univariate model -data_gr_local <- function(bterms, data, ranef) { - stopifnot(is.brmsterms(bterms)) - out <- list() - ranef <- subset2(ranef, resp = bterms$resp) - resp <- usc(bterms$resp) - for (id in unique(ranef$id)) { - id_ranef <- subset2(ranef, id = id) - idresp <- paste0(id, resp) - nranef <- nrow(id_ranef) - group <- id_ranef$group[1] - levels <- attr(ranef, "levels")[[group]] - if (id_ranef$gtype[1] == "mm") { - # multi-membership grouping term - gs <- id_ranef$gcall[[1]]$groups - ngs <- length(gs) - weights <- id_ranef$gcall[[1]]$weights - if (is.formula(weights)) { - scale <- isTRUE(attr(weights, "scale")) - weights <- as.matrix(eval_rhs(weights, data)) - if (!identical(dim(weights), c(nrow(data), ngs))) { - stop2( - "Grouping structure 'mm' expects 'weights' to be ", - "a matrix with as many columns as grouping factors." - ) - } - if (scale) { - if (isTRUE(any(weights < 0))) { - stop2("Cannot scale negative weights.") - } - weights <- sweep(weights, 1, rowSums(weights), "/") - } - } else { - # all members get equal weights by default - weights <- matrix(1 / ngs, nrow = nrow(data), ncol = ngs) - } - for (i in seq_along(gs)) { - gdata <- get(gs[i], data) - J <- match(gdata, levels) - if (anyNA(J)) { - # occurs for new levels only - new_gdata <- gdata[!gdata %in% levels] - new_levels <- unique(new_gdata) - J[is.na(J)] <- match(new_gdata, new_levels) + length(levels) - } - out[[paste0("J_", idresp, "_", i)]] <- as.array(J) - out[[paste0("W_", idresp, "_", i)]] <- as.array(weights[, i]) - } - } else { - # ordinary grouping term - g <- id_ranef$gcall[[1]]$groups - gdata <- get(g, data) - J <- match(gdata, levels) - if (anyNA(J)) { - # occurs for new levels only - new_gdata <- gdata[!gdata %in% levels] - new_levels <- unique(new_gdata) - J[is.na(J)] <- match(new_gdata, new_levels) + length(levels) - } - out[[paste0("J_", idresp)]] <- as.array(J) - } - } - out -} - -# prepare global data for each group-level-ID -data_gr_global <- function(ranef, data2) { - out <- list() - for (id in unique(ranef$id)) { - tmp <- list() - id_ranef <- subset2(ranef, id = id) - nranef <- nrow(id_ranef) - group <- id_ranef$group[1] - levels <- attr(ranef, "levels")[[group]] - tmp$N <- length(levels) - tmp$M <- nranef - tmp$NC <- as.integer(nranef * (nranef - 1) / 2) - # prepare number of levels of an optional 'by' variable - if (nzchar(id_ranef$by[1])) { - stopifnot(!nzchar(id_ranef$type[1])) - bylevels <- id_ranef$bylevels[[1]] - Jby <- match(attr(levels, "by"), bylevels) - tmp$Nby <- length(bylevels) - tmp$Jby <- as.array(Jby) - } - # prepare within-group covariance matrices - cov <- id_ranef$cov[1] - if (nzchar(cov)) { - # validation is only necessary here for compatibility with 'cov_ranef' - cov_mat <- validate_recov_matrix(data2[[cov]]) - found_levels <- rownames(cov_mat) - found <- levels %in% found_levels - if (any(!found)) { - stop2("Levels of the within-group covariance matrix for '", group, - "' do not match names of the grouping levels.") - } - cov_mat <- cov_mat[levels, levels, drop = FALSE] - tmp$Lcov <- t(chol(cov_mat)) - } - names(tmp) <- paste0(names(tmp), "_", id) - c(out) <- tmp - } - out -} - -# prepare data for special effects for use in Stan -data_sp <- function(bterms, data, data2, prior, index = NULL, basis = NULL) { - out <- list() - spef <- tidy_spef(bterms, data) - if (!nrow(spef)) return(out) - px <- check_prefix(bterms) - p <- usc(combine_prefix(px)) - # prepare general data - out[[paste0("Ksp", p)]] <- nrow(spef) - Csp <- sp_model_matrix(bterms$sp, data) - avoid_dpars(colnames(Csp), bterms = bterms) - Csp <- Csp[, spef$Ic > 0, drop = FALSE] - Csp <- lapply(seq_cols(Csp), function(i) as.array(Csp[, i])) - if (length(Csp)) { - Csp_names <- paste0("Csp", p, "_", seq_along(Csp)) - out <- c(out, setNames(Csp, Csp_names)) - } - if (any(lengths(spef$Imo) > 0)) { - # prepare data specific to monotonic effects - out[[paste0("Imo", p)]] <- max(unlist(spef$Imo)) - Xmo <- lapply(unlist(spef$calls_mo), get_mo_values, data = data) - Xmo_names <- paste0("Xmo", p, "_", seq_along(Xmo)) - c(out) <- setNames(Xmo, Xmo_names) - if (!is.null(basis$Jmo)) { - # take information from original data - Jmo <- basis$Jmo - } else { - Jmo <- as.array(ulapply(Xmo, max)) - } - out[[paste0("Jmo", p)]] <- Jmo - # prepare prior concentration of simplex parameters - simo_coef <- get_simo_labels(spef, use_id = TRUE) - ids <- unlist(spef$ids_mo) - for (j in seq_along(simo_coef)) { - # index of first ID appearance - j_id <- match(ids[j], ids) - if (is.na(ids[j]) || j_id == j) { - # only evaluate priors without ID or first appearance of the ID - # all other parameters will be copied over in the Stan code - simo_prior <- subset2(prior, - class = "simo", coef = simo_coef[j], ls = px - ) - con_simo <- eval_dirichlet(simo_prior$prior, Jmo[j], data2) - out[[paste0("con_simo", p, "_", j)]] <- as.array(con_simo) - } - } - } - uni_mi <- attr(spef, "uni_mi") - for (j in seq_rows(uni_mi)) { - if (!is.na(uni_mi$idx[j])) { - idxl <- get(uni_mi$idx[j], data) - if (is.null(index[[uni_mi$var[j]]])) { - # the 'idx' argument needs to be mapped against 'index' addition terms - stop2("Response '", uni_mi$var[j], "' needs to have an 'index' addition ", - "term to compare with 'idx'. See ?mi for examples.") - } - idxl <- match(idxl, index[[uni_mi$var[j]]]) - if (anyNA(idxl)) { - stop2("Could not match all indices in response '", uni_mi$var[j], "'.") - } - idxl_name <- paste0("idxl", p, "_", uni_mi$var[j], "_", uni_mi$idx2[j]) - out[[idxl_name]] <- as.array(idxl) - } else if (isTRUE(attr(index[[uni_mi$var[j]]], "subset"))) { - # cross-formula referencing is required for subsetted variables - stop2("mi() terms of subsetted variables require ", - "the 'idx' argument to be specified.") - } - } - out -} - -# prepare data for category specific effects -data_cs <- function(bterms, data) { - out <- list() - if (length(all_terms(bterms[["cs"]]))) { - p <- usc(combine_prefix(bterms)) - Xcs <- get_model_matrix(bterms$cs, data) - avoid_dpars(colnames(Xcs), bterms = bterms) - out <- c(out, list(Kcs = ncol(Xcs), Xcs = Xcs)) - out <- setNames(out, paste0(names(out), p)) - } - out -} - -# prepare global data for noise free variables -data_Xme <- function(meef, data) { - stopifnot(is.meef_frame(meef)) - out <- list() - groups <- unique(meef$grname) - for (i in seq_along(groups)) { - g <- groups[i] - K <- which(meef$grname %in% g) - Mme <- length(K) - out[[paste0("Mme_", i)]] <- Mme - out[[paste0("NCme_", i)]] <- Mme * (Mme - 1) / 2 - if (nzchar(g)) { - levels <- get_levels(meef)[[g]] - gr <- get_me_group(meef$term[K[1]], data) - Jme <- match(gr, levels) - if (anyNA(Jme)) { - # occurs for new levels only - # replace NAs with unique values; fixes issue #706 - gr[is.na(gr)] <- paste0("new_", seq_len(sum(is.na(gr))), "__") - new_gr <- gr[!gr %in% levels] - new_levels <- unique(new_gr) - Jme[is.na(Jme)] <- length(levels) + match(new_gr, new_levels) - } - ilevels <- unique(Jme) - out[[paste0("Nme_", i)]] <- length(ilevels) - out[[paste0("Jme_", i)]] <- Jme - } - for (k in K) { - Xn <- get_me_values(meef$term[k], data) - noise <- get_me_noise(meef$term[k], data) - if (nzchar(g)) { - for (l in ilevels) { - # validate values of the same level - take <- Jme %in% l - if (length(unique(Xn[take])) > 1L || - length(unique(noise[take])) > 1L) { - stop2( - "Measured values and measurement error should be ", - "unique for each group. Occured for level '", - levels[l], "' of group '", g, "'." - ) - } - } - Xn <- get_one_value_per_group(Xn, Jme) - noise <- get_one_value_per_group(noise, Jme) - } - out[[paste0("Xn_", k)]] <- as.array(Xn) - out[[paste0("noise_", k)]] <- as.array(noise) - } - } - out -} - -# prepare data for Gaussian process terms -# @param internal store some intermediate data for internal post-processing? -# @param ... passed to '.data_gp' -data_gp <- function(bterms, data, internal = FALSE, basis = NULL, ...) { - out <- list() - internal <- as_one_logical(internal) - px <- check_prefix(bterms) - p <- usc(combine_prefix(px)) - gpef <- tidy_gpef(bterms, data) - for (i in seq_rows(gpef)) { - pi <- paste0(p, "_", i) - Xgp <- lapply(gpef$covars[[i]], eval2, data) - D <- length(Xgp) - out[[paste0("Dgp", pi)]] <- D - invalid <- ulapply(Xgp, function(x) - !is.numeric(x) || isTRUE(length(dim(x)) > 1L) - ) - if (any(invalid)) { - stop2("Predictors of Gaussian processes should be numeric vectors.") - } - Xgp <- do_call(cbind, Xgp) - cmc <- gpef$cmc[i] - scale <- gpef$scale[i] - gr <- gpef$gr[i] - k <- gpef$k[i] - c <- gpef$c[[i]] - if (!isNA(k)) { - out[[paste0("NBgp", pi)]] <- k ^ D - Ks <- as.matrix(do_call(expand.grid, repl(seq_len(k), D))) - } - byvar <- gpef$byvars[[i]] - byfac <- length(gpef$cons[[i]]) > 0L - bynum <- !is.null(byvar) && !byfac - if (byfac) { - # for categorical 'by' variables prepare one GP per level - # as.factor will keep unused levels needed for new data - byval <- as.factor(get(byvar, data)) - byform <- str2formula(c(ifelse(cmc, "0", "1"), "byval")) - con_mat <- model.matrix(byform) - cons <- colnames(con_mat) - out[[paste0("Kgp", pi)]] <- length(cons) - Ngp <- Nsubgp <- vector("list", length(cons)) - for (j in seq_along(cons)) { - # loop along contrasts of 'by' - Cgp <- con_mat[, j] - sfx <- paste0(pi, "_", j) - tmp <- .data_gp( - Xgp, k = k, gr = gr, sfx = sfx, Cgp = Cgp, c = c, - scale = scale, internal = internal, basis = basis, - ... - ) - Ngp[[j]] <- attributes(tmp)[["Ngp"]] - Nsubgp[[j]] <- attributes(tmp)[["Nsubgp"]] - c(out) <- tmp - } - out[[paste0("Ngp", pi)]] <- unlist(Ngp) - if (gr) { - out[[paste0("Nsubgp", pi)]] <- unlist(Nsubgp) - } - } else { - out[[paste0("Kgp", pi)]] <- 1L - c(out) <- .data_gp( - Xgp, k = k, gr = gr, sfx = pi, c = c, - scale = scale, internal = internal, basis = basis, - ... - ) - if (bynum) { - Cgp <- as.numeric(get(byvar, data)) - out[[paste0("Cgp", pi)]] <- as.array(Cgp) - } - } - } - if (length(basis)) { - # original covariate values are required in new GP prediction - Xgp_old <- basis[grepl("^Xgp", names(basis))] - names(Xgp_old) <- paste0(names(Xgp_old), "_old") - out[names(Xgp_old)] <- Xgp_old - } - out -} - -# helper function to preparae GP related data -# @inheritParams data_gp -# @param Xgp matrix of covariate values -# @param k, gr, c see 'tidy_gpef' -# @param sfx suffix to put at the end of data names -# @param Cgp optional vector of values belonging to -# a certain contrast of a factor 'by' variable -.data_gp <- function(Xgp, k, gr, sfx, Cgp = NULL, c = NULL, - scale = TRUE, internal = FALSE, basis = NULL) { - out <- list() - if (!is.null(Cgp)) { - Cgp <- unname(Cgp) - Igp <- which(Cgp != 0) - Xgp <- Xgp[Igp, , drop = FALSE] - out[[paste0("Igp", sfx)]] <- as.array(Igp) - out[[paste0("Cgp", sfx)]] <- as.array(Cgp[Igp]) - attr(out, "Ngp") <- length(Igp) - } - if (gr) { - groups <- factor(match_rows(Xgp, Xgp)) - ilevels <- levels(groups) - Jgp <- match(groups, ilevels) - Nsubgp <- length(ilevels) - if (!is.null(Cgp)) { - attr(out, "Nsubgp") <- Nsubgp - } else { - out[[paste0("Nsubgp", sfx)]] <- Nsubgp - } - out[[paste0("Jgp", sfx)]] <- as.array(Jgp) - not_dupl_Jgp <- !duplicated(Jgp) - Xgp <- Xgp[not_dupl_Jgp, , drop = FALSE] - } - if (scale) { - # scale predictor for easier specification of priors - if (length(basis)) { - # scale Xgp based on the original data - dmax <- basis[[paste0("dmax", sfx)]] - } else { - dmax <- sqrt(max(diff_quad(Xgp))) - } - if (!isTRUE(dmax > 0)) { - stop2("Could not scale GP covariates. Please set 'scale' to FALSE in 'gp'.") - } - if (internal) { - # required for scaling of GPs with new data - out[[paste0("dmax", sfx)]] <- dmax - } - Xgp <- Xgp / dmax - } - if (length(basis)) { - # center Xgp based on the original data - cmeans <- basis[[paste0("cmeans", sfx)]] - } else { - cmeans <- colMeans(Xgp) - } - if (internal) { - # required for centering of approximate GPs with new data - out[[paste0("cmeans", sfx)]] <- cmeans - # required to compute inverse-gamma priors for length-scales - out[[paste0("Xgp_prior", sfx)]] <- Xgp - } - if (!isNA(k)) { - # basis function approach requires centered variables - Xgp <- sweep(Xgp, 2, cmeans) - D <- NCOL(Xgp) - L <- choose_L(Xgp, c = c) - Ks <- as.matrix(do_call(expand.grid, repl(seq_len(k), D))) - XgpL <- matrix(nrow = NROW(Xgp), ncol = NROW(Ks)) - slambda <- matrix(nrow = NROW(Ks), ncol = D) - for (m in seq_rows(Ks)) { - XgpL[, m] <- eigen_fun_cov_exp_quad(Xgp, m = Ks[m, ], L = L) - slambda[m, ] <- sqrt(eigen_val_cov_exp_quad(m = Ks[m, ], L = L)) - } - out[[paste0("Xgp", sfx)]] <- XgpL - out[[paste0("slambda", sfx)]] <- slambda - } else { - out[[paste0("Xgp", sfx)]] <- as.array(Xgp) - } - out -} - -# data for autocorrelation variables -# @param locations optional original locations for CAR models -data_ac <- function(bterms, data, data2, basis = NULL, ...) { - out <- list() - N <- nrow(data) - acef <- tidy_acef(bterms) - if (has_ac_subset(bterms, dim = "time")) { - gr <- subset2(acef, dim = "time")$gr - if (gr != "NA") { - tgroup <- as.numeric(factor(data[[gr]])) - } else { - tgroup <- rep(1, N) - } - } - if (has_ac_class(acef, "arma")) { - # ARMA correlations - acef_arma <- subset2(acef, class = "arma") - out$Kar <- acef_arma$p - out$Kma <- acef_arma$q - if (!use_ac_cov_time(acef_arma)) { - # data for the 'predictor' version of ARMA - max_lag <- max(out$Kar, out$Kma) - out$J_lag <- as.array(rep(0, N)) - for (n in seq_len(N)[-N]) { - ind <- n:max(1, n + 1 - max_lag) - # indexes errors to be used in the n+1th prediction - out$J_lag[n] <- sum(tgroup[ind] %in% tgroup[n + 1]) - } - } - } - if (use_ac_cov_time(acef)) { - # data for the 'covariance' versions of time-series structures - out$N_tg <- length(unique(tgroup)) - out$begin_tg <- as.array(ulapply(unique(tgroup), match, tgroup)) - out$nobs_tg <- as.array(with(out, - c(if (N_tg > 1L) begin_tg[2:N_tg], N + 1) - begin_tg - )) - out$end_tg <- with(out, begin_tg + nobs_tg - 1) - } - if (has_ac_class(acef, "sar")) { - acef_sar <- subset2(acef, class = "sar") - M <- data2[[acef_sar$M]] - rmd_rows <- attr(data, "na.action") - if (!is.null(rmd_rows)) { - class(rmd_rows) <- NULL - M <- M[-rmd_rows, -rmd_rows, drop = FALSE] - } - if (!is_equal(dim(M), rep(N, 2))) { - stop2("Dimensions of 'M' for SAR terms must be equal to ", - "the number of observations.") - } - out$Msar <- as.matrix(M) - out$eigenMsar <- eigen(M)$values - # simplifies code of choose_N - out$N_tg <- 1 - } - if (has_ac_class(acef, "car")) { - acef_car <- subset2(acef, class = "car") - locations <- NULL - if (length(basis)) { - locations <- basis$locations - } - M <- data2[[acef_car$M]] - if (acef_car$gr != "NA") { - loc_data <- get(acef_car$gr, data) - new_locations <- levels(factor(loc_data)) - if (is.null(locations)) { - locations <- new_locations - } else { - invalid_locations <- setdiff(new_locations, locations) - if (length(invalid_locations)) { - stop2("Cannot handle new locations in CAR models.") - } - } - Nloc <- length(locations) - Jloc <- as.array(match(loc_data, locations)) - if (is.null(rownames(M))) { - stop2("Row names are required for 'M' in CAR terms.") - } - found <- locations %in% rownames(M) - if (any(!found)) { - stop2("Row names of 'M' for CAR terms do not match ", - "the names of the grouping levels.") - } - M <- M[locations, locations, drop = FALSE] - } else { - warning2( - "Using CAR terms without a grouping factor is deprecated. ", - "Please use argument 'gr' even if each observation ", - "represents its own location." - ) - Nloc <- N - Jloc <- as.array(seq_len(Nloc)) - if (!is_equal(dim(M), rep(Nloc, 2))) { - if (length(basis)) { - stop2("Cannot handle new data in CAR terms ", - "without a grouping factor.") - } else { - stop2("Dimensions of 'M' for CAR terms must be equal ", - "to the number of observations.") - } - } - } - edges_rows <- (Matrix::tril(M)@i + 1) - edges_cols <- sort(Matrix::triu(M)@i + 1) ## sort to make consistent with rows - edges <- cbind("rows" = edges_rows, "cols" = edges_cols) - c(out) <- nlist( - Nloc, Jloc, Nedges = length(edges_rows), - edges1 = as.array(edges_rows), - edges2 = as.array(edges_cols) - ) - if (acef_car$type %in% c("escar", "esicar")) { - Nneigh <- Matrix::colSums(M) - if (any(Nneigh == 0) && !length(basis)) { - stop2( - "For exact sparse CAR, all locations should have at ", - "least one neighbor within the provided data set. ", - "Consider using type = 'icar' instead." - ) - } - inv_sqrt_D <- diag(1 / sqrt(Nneigh)) - eigenMcar <- t(inv_sqrt_D) %*% M %*% inv_sqrt_D - eigenMcar <- eigen(eigenMcar, TRUE, only.values = TRUE)$values - c(out) <- nlist(Nneigh, eigenMcar) - } else if (acef_car$type %in% "bym2") { - c(out) <- list(car_scale = .car_scale(edges, Nloc)) - } - } - if (has_ac_class(acef, "fcor")) { - acef_fcor <- subset2(acef, class = "fcor") - M <- data2[[acef_fcor$M]] - rmd_rows <- attr(data, "na.action") - if (!is.null(rmd_rows)) { - class(rmd_rows) <- NULL - M <- M[-rmd_rows, -rmd_rows, drop = FALSE] - } - if (nrow(M) != N) { - stop2("Dimensions of 'M' for FCOR terms must be equal ", - "to the number of observations.") - } - out$Mfcor <- M - # simplifies code of choose_N - out$N_tg <- 1 - } - if (length(out)) { - resp <- usc(combine_prefix(bterms)) - out <- setNames(out, paste0(names(out), resp)) - } - out -} - -# prepare data of offsets for use in Stan -data_offset <- function(bterms, data) { - out <- list() - px <- check_prefix(bterms) - if (is.formula(bterms$offset)) { - p <- usc(combine_prefix(px)) - mf <- rm_attr(data, "terms") - mf <- model.frame(bterms$offset, mf, na.action = na.pass) - offset <- model.offset(mf) - if (length(offset) == 1L) { - offset <- rep(offset, nrow(data)) - } - # use 'offsets' as 'offset' will be reserved in stanc3 - out[[paste0("offsets", p)]] <- as.array(offset) - } - out -} - -# data for covariates in non-linear models -# @param x a btnl object -# @return a named list of data passed to Stan -data_cnl <- function(bterms, data) { - stopifnot(is.btnl(bterms)) - out <- list() - covars <- all.vars(bterms$covars) - if (!length(covars)) { - return(out) - } - p <- usc(combine_prefix(bterms)) - for (i in seq_along(covars)) { - cvalues <- get(covars[i], data) - if (is_like_factor(cvalues)) { - # need to apply factor contrasts - cform <- str2formula(covars[i]) - cvalues <- get_model_matrix(cform, data, cols2remove = "(Intercept)") - if (NCOL(cvalues) > 1) { - stop2("Factors with more than two levels are not allowed as covariates.") - } - cvalues <- cvalues[, 1] - } - out[[paste0("C", p, "_", i)]] <- as.array(cvalues) - } - out -} - -# compute the spatial scaling factor of CAR models -# @param edges matrix with two columns defining the adjacency of the locations -# @param Nloc number of locations -# @return a scalar scaling factor -.car_scale <- function(edges, Nloc) { - # amended from Imad Ali's code of CAR models in rstanarm - stopifnot(is.matrix(edges), NCOL(edges) == 2) - # Build the adjacency matrix - adj_matrix <- Matrix::sparseMatrix( - i = edges[, 1], j = edges[, 2], x = 1, - symmetric = TRUE - ) - # The ICAR precision matrix (which is singular) - Q <- Matrix::Diagonal(Nloc, Matrix::rowSums(adj_matrix)) - adj_matrix - # Add a small jitter to the diagonal for numerical stability - Q_pert <- Q + Matrix::Diagonal(Nloc) * - max(Matrix::diag(Q)) * sqrt(.Machine$double.eps) - # Compute the diagonal elements of the covariance matrix subject to the - # constraint that the entries of the ICAR sum to zero. - .Q_inv <- function(Q) { - Sigma <- Matrix::solve(Q) - A <- matrix(1, 1, NROW(Sigma)) - W <- Sigma %*% t(A) - Sigma <- Sigma - W %*% solve(A %*% W) %*% Matrix::t(W) - return(Sigma) - } - Q_inv <- .Q_inv(Q_pert) - # Compute the geometric mean of the variances (diagonal of Q_inv) - exp(mean(log(Matrix::diag(Q_inv)))) -} - -# data for special priors such as horseshoe and lasso -data_prior <- function(bterms, data, prior, sdata = NULL) { - out <- list() - px <- check_prefix(bterms) - p <- usc(combine_prefix(px)) - special <- get_special_prior(prior, px) - if (!is.null(special$horseshoe)) { - # data for the horseshoe prior - hs_names <- c("df", "df_global", "df_slab", "scale_global", "scale_slab") - hs_data <- special$horseshoe[hs_names] - if (!is.null(special$horseshoe$par_ratio)) { - hs_data$scale_global <- special$horseshoe$par_ratio / sqrt(nrow(data)) - } - names(hs_data) <- paste0("hs_", hs_names, p) - out <- c(out, hs_data) - } - if (!is.null(special$R2D2)) { - # data for the R2D2 prior - R2D2_names <- c("mean_R2", "prec_R2", "cons_D2") - R2D2_data <- special$R2D2[R2D2_names] - # number of coefficients minus the intercept - K <- sdata[[paste0("K", p)]] - ifelse(stan_center_X(bterms), 1, 0) - if (length(R2D2_data$cons_D2) == 1L) { - R2D2_data$cons_D2 <- rep(R2D2_data$cons_D2, K) - } - if (length(R2D2_data$cons_D2) != K) { - stop2("Argument 'cons_D2' of the R2D2 prior must be of length 1 or ", K) - } - R2D2_data$cons_D2 <- as.array(R2D2_data$cons_D2) - names(R2D2_data) <- paste0("R2D2_", R2D2_names, p) - out <- c(out, R2D2_data) - } - if (!is.null(special$lasso)) { - lasso_names <- c("df", "scale") - lasso_data <- special$lasso[lasso_names] - names(lasso_data) <- paste0("lasso_", lasso_names, p) - out <- c(out, lasso_data) - } - out -} - -# Construct design matrices for brms models -# @param formula a formula object -# @param data A data frame created with model.frame. -# If another sort of object, model.frame is called first. -# @param cols2remove names of the columns to remove from -# the model matrix; mainly used for intercepts -# @param rename rename column names via rename()? -# @param ... passed to stats::model.matrix -# @return -# The design matrix for the given formula and data. -# For details see ?stats::model.matrix -get_model_matrix <- function(formula, data = environment(formula), - cols2remove = NULL, rename = TRUE, ...) { - stopifnot(is.atomic(cols2remove)) - terms <- validate_terms(formula) - if (is.null(terms)) { - return(NULL) - } - if (no_int(terms)) { - cols2remove <- union(cols2remove, "(Intercept)") - } - X <- stats::model.matrix(terms, data, ...) - cols2remove <- which(colnames(X) %in% cols2remove) - if (length(cols2remove)) { - X <- X[, -cols2remove, drop = FALSE] - } - if (rename) { - colnames(X) <- rename(colnames(X), check_dup = TRUE) - } - X -} - -# convenient wrapper around mgcv::PredictMat -PredictMat <- function(object, data, ...) { - data <- rm_attr(data, "terms") - out <- mgcv::PredictMat(object, data = data, ...) - if (length(dim(out)) < 2L) { - # fixes issue #494 - out <- matrix(out, nrow = 1) - } - out -} - -# convenient wrapper around mgcv::smoothCon -smoothCon <- function(object, data, ...) { - data <- rm_attr(data, "terms") - vars <- setdiff(c(object$term, object$by), "NA") - for (v in vars) { - if (is_like_factor(data[[v]])) { - # allow factor-like variables #562 - data[[v]] <- as.factor(data[[v]]) - } else if (inherits(data[[v]], "difftime")) { - # mgcv cannot handle 'difftime' variables - data[[v]] <- as.numeric(data[[v]]) - } - } - mgcv::smoothCon(object, data = data, ...) -} - -# Aid prediction from smooths represented as 'type = 2' -# originally provided by Simon Wood -# @param sm output of mgcv::smoothCon -# @param data new data supplied for prediction -# @return A list of the same structure as returned by mgcv::smoothCon -s2rPred <- function(sm, data) { - re <- mgcv::smooth2random(sm, names(data), type = 2) - # prediction matrix for new data - X <- PredictMat(sm, data) - # transform to RE parameterization - if (!is.null(re$trans.U)) { - X <- X %*% re$trans.U - } - X <- t(t(X) * re$trans.D) - # re-order columns according to random effect re-ordering - X[, re$rind] <- X[, re$pen.ind != 0] - # re-order penalization index in same way - pen.ind <- re$pen.ind - pen.ind[re$rind] <- pen.ind[pen.ind > 0] - # start returning the object - Xf <- X[, which(re$pen.ind == 0), drop = FALSE] - out <- list(rand = list(), Xf = Xf) - for (i in seq_along(re$rand)) { - # loop over random effect matrices - out$rand[[i]] <- X[, which(pen.ind == i), drop = FALSE] - attr(out$rand[[i]], "s.label") <- attr(re$rand[[i]], "s.label") - } - names(out$rand) <- names(re$rand) - out -} +#' Prepare Predictor Data +#' +#' Prepare data related to predictor variables in \pkg{brms}. +#' Only exported for use in package development. +#' +#' @param x An \R object. +#' @param ... Further arguments passed to or from other methods. +#' +#' @return A named list of data related to predictor variables. +#' +#' @keywords internal +#' @export +data_predictor <- function(x, ...) { + UseMethod("data_predictor") +} + +#' @export +data_predictor.mvbrmsterms <- function(x, data, basis = NULL, ...) { + out <- list(N = nrow(data)) + for (r in names(x$terms)) { + bs <- basis$resps[[r]] + c(out) <- data_predictor(x$terms[[r]], data = data, basis = bs, ...) + } + out +} + +#' @export +data_predictor.brmsterms <- function(x, data, data2, prior, ranef, + basis = NULL, ...) { + out <- list() + data <- subset_data(data, x) + resp <- usc(combine_prefix(x)) + args_eff <- nlist(data, data2, ranef, prior, ...) + for (dp in names(x$dpars)) { + args_eff_spec <- list(x = x$dpars[[dp]], basis = basis$dpars[[dp]]) + c(out) <- do_call(data_predictor, c(args_eff_spec, args_eff)) + } + for (dp in names(x$fdpars)) { + if (is.numeric(x$fdpars[[dp]]$value)) { + out[[paste0(dp, resp)]] <- x$fdpars[[dp]]$value + } + } + for (nlp in names(x$nlpars)) { + args_eff_spec <- list(x = x$nlpars[[nlp]], basis = basis$nlpars[[nlp]]) + c(out) <- do_call(data_predictor, c(args_eff_spec, args_eff)) + } + c(out) <- data_gr_local(x, data = data, ranef = ranef) + c(out) <- data_mixture(x, data2 = data2, prior = prior) + out +} + +# prepare data for all types of effects for use in Stan +# @param data the data passed by the user +# @param ranef object retuend by 'tidy_ranef' +# @param prior an object of class brmsprior +# @param basis information from original Stan data used to correctly +# predict from new data. See 'standata_basis' for details. +# @param ... currently ignored +# @return a named list of data to be passed to Stan +#' @export +data_predictor.btl <- function(x, data, ranef = empty_ranef(), + prior = brmsprior(), data2 = list(), + index = NULL, basis = NULL, ...) { + out <- c( + data_fe(x, data), + data_sp(x, data, data2 = data2, prior = prior, index = index, basis = basis$sp), + data_re(x, data, ranef = ranef), + data_cs(x, data), + data_sm(x, data, basis = basis$sm), + data_gp(x, data, basis = basis$gp), + data_ac(x, data, data2 = data2, basis = basis$ac), + data_offset(x, data), + data_bhaz(x, data, data2 = data2, prior = prior, basis = basis$bhaz) + ) + c(out) <- data_prior(x, data, prior = prior, sdata = out) + out +} + +# prepare data for non-linear parameters for use in Stan +#' @export +data_predictor.btnl <- function(x, data, data2 = list(), + basis = NULL, ...) { + out <- list() + c(out) <- data_cnl(x, data) + c(out) <- data_ac(x, data, data2 = data2, basis = basis$ac) + out +} + +# prepare data of fixed effects +data_fe <- function(bterms, data) { + out <- list() + p <- usc(combine_prefix(bterms)) + # the intercept is removed inside the Stan code for ordinal models + cols2remove <- if (is_ordinal(bterms)) "(Intercept)" + X <- get_model_matrix(rhs(bterms$fe), data, cols2remove = cols2remove) + avoid_dpars(colnames(X), bterms = bterms) + out[[paste0("K", p)]] <- ncol(X) + out[[paste0("X", p)]] <- X + out +} + +# data preparation for splines +data_sm <- function(bterms, data, basis = NULL) { + out <- list() + smterms <- all_terms(bterms[["sm"]]) + if (!length(smterms)) { + return(out) + } + p <- usc(combine_prefix(bterms)) + new <- length(basis) > 0L + if (!new) { + knots <- get_knots(data) + basis <- named_list(smterms) + for (i in seq_along(smterms)) { + # the spline penalty has changed in 2.8.7 (#646) + diagonal.penalty <- !require_old_default("2.8.7") + basis[[i]] <- smoothCon( + eval2(smterms[i]), data = data, + knots = knots, absorb.cons = TRUE, + diagonal.penalty = diagonal.penalty + ) + } + } + bylevels <- named_list(smterms) + ns <- 0 + lXs <- list() + for (i in seq_along(basis)) { + # may contain multiple terms when 'by' is a factor + for (j in seq_along(basis[[i]])) { + ns <- ns + 1 + sm <- basis[[i]][[j]] + if (length(sm$by.level)) { + bylevels[[i]][j] <- sm$by.level + } + if (new) { + # prepare rasm for use with new data + rasm <- s2rPred(sm, data) + } else { + rasm <- mgcv::smooth2random(sm, names(data), type = 2) + } + lXs[[ns]] <- rasm$Xf + if (NCOL(lXs[[ns]])) { + colnames(lXs[[ns]]) <- paste0(sm$label, "_", seq_cols(lXs[[ns]])) + } + Zs <- rasm$rand + Zs <- setNames(Zs, paste0("Zs", p, "_", ns, "_", seq_along(Zs))) + tmp <- list(length(Zs), as.array(ulapply(Zs, ncol))) + tmp <- setNames(tmp, paste0(c("nb", "knots"), p, "_", ns)) + c(out) <- c(tmp, Zs) + } + } + Xs <- do_call(cbind, lXs) + avoid_dpars(colnames(Xs), bterms = bterms) + smcols <- lapply(lXs, function(x) which(colnames(Xs) %in% colnames(x))) + Xs <- structure(Xs, smcols = smcols, bylevels = bylevels) + colnames(Xs) <- rename(colnames(Xs)) + out[[paste0("Ks", p)]] <- ncol(Xs) + out[[paste0("Xs", p)]] <- Xs + out +} + +# prepare data for group-level effects for use in Stan +data_re <- function(bterms, data, ranef) { + out <- list() + px <- check_prefix(bterms) + take <- find_rows(ranef, ls = px) & !find_rows(ranef, type = "sp") + ranef <- ranef[take, ] + if (!nrow(ranef)) { + return(out) + } + gn <- unique(ranef$gn) + for (i in seq_along(gn)) { + r <- subset2(ranef, gn = gn[i]) + Z <- get_model_matrix(r$form[[1]], data = data, rename = FALSE) + idp <- paste0(r$id[1], usc(combine_prefix(px))) + Znames <- paste0("Z_", idp, "_", r$cn) + if (r$gtype[1] == "mm") { + ng <- length(r$gcall[[1]]$groups) + if (r$type[1] == "cs") { + stop2("'cs' is not supported in multi-membership terms.") + } + if (r$type[1] == "mmc") { + # see issue #353 for the general idea + mmc_expr <- "^mmc\\([^:]*\\)" + mmc_terms <- get_matches_expr(mmc_expr, colnames(Z)) + for (t in mmc_terms) { + pos <- which(grepl_expr(escape_all(t), colnames(Z))) + if (length(pos) != ng) { + stop2("Invalid term '", t, "': Expected ", ng, + " coefficients but found ", length(pos), ".") + } + for (j in seq_along(Znames)) { + for (k in seq_len(ng)) { + out[[paste0(Znames[j], "_", k)]] <- as.array(Z[, pos[k]]) + } + } + } + } else { + for (j in seq_along(Znames)) { + out[paste0(Znames[j], "_", seq_len(ng))] <- list(as.array(Z[, j])) + } + } + } else { + if (r$type[1] == "cs") { + ncatM1 <- nrow(r) / ncol(Z) + Z_temp <- vector("list", ncol(Z)) + for (k in seq_along(Z_temp)) { + Z_temp[[k]] <- replicate(ncatM1, Z[, k], simplify = FALSE) + } + Z <- do_call(cbind, unlist(Z_temp, recursive = FALSE)) + } + if (r$type[1] == "mmc") { + stop2("'mmc' is only supported in multi-membership terms.") + } + for (j in seq_cols(Z)) { + out[[Znames[j]]] <- as.array(Z[, j]) + } + } + } + out +} + +# compute data for each group-level-ID per univariate model +data_gr_local <- function(bterms, data, ranef) { + stopifnot(is.brmsterms(bterms)) + out <- list() + ranef <- subset2(ranef, resp = bterms$resp) + resp <- usc(bterms$resp) + for (id in unique(ranef$id)) { + id_ranef <- subset2(ranef, id = id) + idresp <- paste0(id, resp) + nranef <- nrow(id_ranef) + group <- id_ranef$group[1] + levels <- attr(ranef, "levels")[[group]] + if (id_ranef$gtype[1] == "mm") { + # multi-membership grouping term + gs <- id_ranef$gcall[[1]]$groups + ngs <- length(gs) + weights <- id_ranef$gcall[[1]]$weights + if (is.formula(weights)) { + scale <- isTRUE(attr(weights, "scale")) + weights <- as.matrix(eval_rhs(weights, data)) + if (!identical(dim(weights), c(nrow(data), ngs))) { + stop2( + "Grouping structure 'mm' expects 'weights' to be ", + "a matrix with as many columns as grouping factors." + ) + } + if (scale) { + if (isTRUE(any(weights < 0))) { + stop2("Cannot scale negative weights.") + } + weights <- sweep(weights, 1, rowSums(weights), "/") + } + } else { + # all members get equal weights by default + weights <- matrix(1 / ngs, nrow = nrow(data), ncol = ngs) + } + for (i in seq_along(gs)) { + gdata <- get(gs[i], data) + J <- match(gdata, levels) + if (anyNA(J)) { + # occurs for new levels only + new_gdata <- gdata[!gdata %in% levels] + new_levels <- unique(new_gdata) + J[is.na(J)] <- match(new_gdata, new_levels) + length(levels) + } + out[[paste0("J_", idresp, "_", i)]] <- as.array(J) + out[[paste0("W_", idresp, "_", i)]] <- as.array(weights[, i]) + } + } else { + # ordinary grouping term + g <- id_ranef$gcall[[1]]$groups + gdata <- get(g, data) + J <- match(gdata, levels) + if (anyNA(J)) { + # occurs for new levels only + new_gdata <- gdata[!gdata %in% levels] + new_levels <- unique(new_gdata) + J[is.na(J)] <- match(new_gdata, new_levels) + length(levels) + } + out[[paste0("J_", idresp)]] <- as.array(J) + } + } + out +} + +# prepare global data for each group-level-ID +data_gr_global <- function(ranef, data2) { + out <- list() + for (id in unique(ranef$id)) { + tmp <- list() + id_ranef <- subset2(ranef, id = id) + nranef <- nrow(id_ranef) + group <- id_ranef$group[1] + levels <- attr(ranef, "levels")[[group]] + tmp$N <- length(levels) + tmp$M <- nranef + tmp$NC <- as.integer(nranef * (nranef - 1) / 2) + # prepare number of levels of an optional 'by' variable + if (nzchar(id_ranef$by[1])) { + stopifnot(!nzchar(id_ranef$type[1])) + bylevels <- id_ranef$bylevels[[1]] + Jby <- match(attr(levels, "by"), bylevels) + tmp$Nby <- length(bylevels) + tmp$Jby <- as.array(Jby) + } + # prepare within-group covariance matrices + cov <- id_ranef$cov[1] + if (nzchar(cov)) { + # validation is only necessary here for compatibility with 'cov_ranef' + cov_mat <- validate_recov_matrix(data2[[cov]]) + found_levels <- rownames(cov_mat) + found <- levels %in% found_levels + if (any(!found)) { + stop2("Levels of the within-group covariance matrix for '", group, + "' do not match names of the grouping levels.") + } + cov_mat <- cov_mat[levels, levels, drop = FALSE] + tmp$Lcov <- t(chol(cov_mat)) + } + names(tmp) <- paste0(names(tmp), "_", id) + c(out) <- tmp + } + out +} + +# prepare data for special effects for use in Stan +data_sp <- function(bterms, data, data2, prior, index = NULL, basis = NULL) { + out <- list() + spef <- tidy_spef(bterms, data) + if (!nrow(spef)) return(out) + px <- check_prefix(bterms) + p <- usc(combine_prefix(px)) + # prepare general data + out[[paste0("Ksp", p)]] <- nrow(spef) + Csp <- sp_model_matrix(bterms$sp, data) + avoid_dpars(colnames(Csp), bterms = bterms) + Csp <- Csp[, spef$Ic > 0, drop = FALSE] + Csp <- lapply(seq_cols(Csp), function(i) as.array(Csp[, i])) + if (length(Csp)) { + Csp_names <- paste0("Csp", p, "_", seq_along(Csp)) + out <- c(out, setNames(Csp, Csp_names)) + } + if (any(lengths(spef$Imo) > 0)) { + # prepare data specific to monotonic effects + out[[paste0("Imo", p)]] <- max(unlist(spef$Imo)) + Xmo <- lapply(unlist(spef$calls_mo), get_mo_values, data = data) + Xmo_names <- paste0("Xmo", p, "_", seq_along(Xmo)) + c(out) <- setNames(Xmo, Xmo_names) + if (!is.null(basis$Jmo)) { + # take information from original data + Jmo <- basis$Jmo + } else { + Jmo <- as.array(ulapply(Xmo, max)) + } + out[[paste0("Jmo", p)]] <- Jmo + # prepare prior concentration of simplex parameters + simo_coef <- get_simo_labels(spef, use_id = TRUE) + ids <- unlist(spef$ids_mo) + for (j in seq_along(simo_coef)) { + # index of first ID appearance + j_id <- match(ids[j], ids) + if (is.na(ids[j]) || j_id == j) { + # only evaluate priors without ID or first appearance of the ID + # all other parameters will be copied over in the Stan code + simo_prior <- subset2(prior, + class = "simo", coef = simo_coef[j], ls = px + ) + con_simo <- eval_dirichlet(simo_prior$prior, Jmo[j], data2) + out[[paste0("con_simo", p, "_", j)]] <- as.array(con_simo) + } + } + } + uni_mi <- attr(spef, "uni_mi") + for (j in seq_rows(uni_mi)) { + if (!is.na(uni_mi$idx[j])) { + idxl <- get(uni_mi$idx[j], data) + if (is.null(index[[uni_mi$var[j]]])) { + # the 'idx' argument needs to be mapped against 'index' addition terms + stop2("Response '", uni_mi$var[j], "' needs to have an 'index' addition ", + "term to compare with 'idx'. See ?mi for examples.") + } + idxl <- match(idxl, index[[uni_mi$var[j]]]) + if (anyNA(idxl)) { + stop2("Could not match all indices in response '", uni_mi$var[j], "'.") + } + idxl_name <- paste0("idxl", p, "_", uni_mi$var[j], "_", uni_mi$idx2[j]) + out[[idxl_name]] <- as.array(idxl) + } else if (isTRUE(attr(index[[uni_mi$var[j]]], "subset"))) { + # cross-formula referencing is required for subsetted variables + stop2("mi() terms of subsetted variables require ", + "the 'idx' argument to be specified.") + } + } + out +} + +# prepare data for category specific effects +data_cs <- function(bterms, data) { + out <- list() + if (length(all_terms(bterms[["cs"]]))) { + p <- usc(combine_prefix(bterms)) + Xcs <- get_model_matrix(bterms$cs, data) + avoid_dpars(colnames(Xcs), bterms = bterms) + out <- c(out, list(Kcs = ncol(Xcs), Xcs = Xcs)) + out <- setNames(out, paste0(names(out), p)) + } + out +} + +# prepare global data for noise free variables +data_Xme <- function(meef, data) { + stopifnot(is.meef_frame(meef)) + out <- list() + groups <- unique(meef$grname) + for (i in seq_along(groups)) { + g <- groups[i] + K <- which(meef$grname %in% g) + Mme <- length(K) + out[[paste0("Mme_", i)]] <- Mme + out[[paste0("NCme_", i)]] <- Mme * (Mme - 1) / 2 + if (nzchar(g)) { + levels <- get_levels(meef)[[g]] + gr <- get_me_group(meef$term[K[1]], data) + Jme <- match(gr, levels) + if (anyNA(Jme)) { + # occurs for new levels only + # replace NAs with unique values; fixes issue #706 + gr[is.na(gr)] <- paste0("new_", seq_len(sum(is.na(gr))), "__") + new_gr <- gr[!gr %in% levels] + new_levels <- unique(new_gr) + Jme[is.na(Jme)] <- length(levels) + match(new_gr, new_levels) + } + ilevels <- unique(Jme) + out[[paste0("Nme_", i)]] <- length(ilevels) + out[[paste0("Jme_", i)]] <- Jme + } + for (k in K) { + Xn <- get_me_values(meef$term[k], data) + noise <- get_me_noise(meef$term[k], data) + if (nzchar(g)) { + for (l in ilevels) { + # validate values of the same level + take <- Jme %in% l + if (length(unique(Xn[take])) > 1L || + length(unique(noise[take])) > 1L) { + stop2( + "Measured values and measurement error should be ", + "unique for each group. Occured for level '", + levels[l], "' of group '", g, "'." + ) + } + } + Xn <- get_one_value_per_group(Xn, Jme) + noise <- get_one_value_per_group(noise, Jme) + } + out[[paste0("Xn_", k)]] <- as.array(Xn) + out[[paste0("noise_", k)]] <- as.array(noise) + } + } + out +} + +# prepare data for Gaussian process terms +# @param internal store some intermediate data for internal post-processing? +# @param ... passed to '.data_gp' +data_gp <- function(bterms, data, internal = FALSE, basis = NULL, ...) { + out <- list() + internal <- as_one_logical(internal) + px <- check_prefix(bterms) + p <- usc(combine_prefix(px)) + gpef <- tidy_gpef(bterms, data) + for (i in seq_rows(gpef)) { + pi <- paste0(p, "_", i) + Xgp <- lapply(gpef$covars[[i]], eval2, data) + D <- length(Xgp) + out[[paste0("Dgp", pi)]] <- D + invalid <- ulapply(Xgp, function(x) + !is.numeric(x) || isTRUE(length(dim(x)) > 1L) + ) + if (any(invalid)) { + stop2("Predictors of Gaussian processes should be numeric vectors.") + } + Xgp <- do_call(cbind, Xgp) + cmc <- gpef$cmc[i] + scale <- gpef$scale[i] + gr <- gpef$gr[i] + k <- gpef$k[i] + c <- gpef$c[[i]] + if (!isNA(k)) { + out[[paste0("NBgp", pi)]] <- k ^ D + Ks <- as.matrix(do_call(expand.grid, repl(seq_len(k), D))) + } + byvar <- gpef$byvars[[i]] + byfac <- length(gpef$cons[[i]]) > 0L + bynum <- !is.null(byvar) && !byfac + if (byfac) { + # for categorical 'by' variables prepare one GP per level + # as.factor will keep unused levels needed for new data + byval <- as.factor(get(byvar, data)) + byform <- str2formula(c(ifelse(cmc, "0", "1"), "byval")) + con_mat <- model.matrix(byform) + cons <- colnames(con_mat) + out[[paste0("Kgp", pi)]] <- length(cons) + Ngp <- Nsubgp <- vector("list", length(cons)) + for (j in seq_along(cons)) { + # loop along contrasts of 'by' + Cgp <- con_mat[, j] + sfx <- paste0(pi, "_", j) + tmp <- .data_gp( + Xgp, k = k, gr = gr, sfx = sfx, Cgp = Cgp, c = c, + scale = scale, internal = internal, basis = basis, + ... + ) + Ngp[[j]] <- attributes(tmp)[["Ngp"]] + Nsubgp[[j]] <- attributes(tmp)[["Nsubgp"]] + c(out) <- tmp + } + out[[paste0("Ngp", pi)]] <- unlist(Ngp) + if (gr) { + out[[paste0("Nsubgp", pi)]] <- unlist(Nsubgp) + } + } else { + out[[paste0("Kgp", pi)]] <- 1L + c(out) <- .data_gp( + Xgp, k = k, gr = gr, sfx = pi, c = c, + scale = scale, internal = internal, basis = basis, + ... + ) + if (bynum) { + Cgp <- as.numeric(get(byvar, data)) + out[[paste0("Cgp", pi)]] <- as.array(Cgp) + } + } + } + if (length(basis)) { + # original covariate values are required in new GP prediction + Xgp_old <- basis[grepl("^Xgp", names(basis))] + names(Xgp_old) <- paste0(names(Xgp_old), "_old") + out[names(Xgp_old)] <- Xgp_old + } + out +} + +# helper function to preparae GP related data +# @inheritParams data_gp +# @param Xgp matrix of covariate values +# @param k, gr, c see 'tidy_gpef' +# @param sfx suffix to put at the end of data names +# @param Cgp optional vector of values belonging to +# a certain contrast of a factor 'by' variable +.data_gp <- function(Xgp, k, gr, sfx, Cgp = NULL, c = NULL, + scale = TRUE, internal = FALSE, basis = NULL) { + out <- list() + if (!is.null(Cgp)) { + Cgp <- unname(Cgp) + Igp <- which(Cgp != 0) + Xgp <- Xgp[Igp, , drop = FALSE] + out[[paste0("Igp", sfx)]] <- as.array(Igp) + out[[paste0("Cgp", sfx)]] <- as.array(Cgp[Igp]) + attr(out, "Ngp") <- length(Igp) + } + if (gr) { + groups <- factor(match_rows(Xgp, Xgp)) + ilevels <- levels(groups) + Jgp <- match(groups, ilevels) + Nsubgp <- length(ilevels) + if (!is.null(Cgp)) { + attr(out, "Nsubgp") <- Nsubgp + } else { + out[[paste0("Nsubgp", sfx)]] <- Nsubgp + } + out[[paste0("Jgp", sfx)]] <- as.array(Jgp) + not_dupl_Jgp <- !duplicated(Jgp) + Xgp <- Xgp[not_dupl_Jgp, , drop = FALSE] + } + if (scale) { + # scale predictor for easier specification of priors + if (length(basis)) { + # scale Xgp based on the original data + dmax <- basis[[paste0("dmax", sfx)]] + } else { + dmax <- sqrt(max(diff_quad(Xgp))) + } + if (!isTRUE(dmax > 0)) { + stop2("Could not scale GP covariates. Please set 'scale' to FALSE in 'gp'.") + } + if (internal) { + # required for scaling of GPs with new data + out[[paste0("dmax", sfx)]] <- dmax + } + Xgp <- Xgp / dmax + } + if (length(basis)) { + # center Xgp based on the original data + cmeans <- basis[[paste0("cmeans", sfx)]] + } else { + cmeans <- colMeans(Xgp) + } + if (internal) { + # required for centering of approximate GPs with new data + out[[paste0("cmeans", sfx)]] <- cmeans + # required to compute inverse-gamma priors for length-scales + out[[paste0("Xgp_prior", sfx)]] <- Xgp + } + if (!isNA(k)) { + # basis function approach requires centered variables + Xgp <- sweep(Xgp, 2, cmeans) + D <- NCOL(Xgp) + L <- choose_L(Xgp, c = c) + Ks <- as.matrix(do_call(expand.grid, repl(seq_len(k), D))) + XgpL <- matrix(nrow = NROW(Xgp), ncol = NROW(Ks)) + slambda <- matrix(nrow = NROW(Ks), ncol = D) + for (m in seq_rows(Ks)) { + XgpL[, m] <- eigen_fun_cov_exp_quad(Xgp, m = Ks[m, ], L = L) + slambda[m, ] <- sqrt(eigen_val_cov_exp_quad(m = Ks[m, ], L = L)) + } + out[[paste0("Xgp", sfx)]] <- XgpL + out[[paste0("slambda", sfx)]] <- slambda + } else { + out[[paste0("Xgp", sfx)]] <- as.array(Xgp) + } + out +} + +# data for autocorrelation variables +# @param locations optional original locations for CAR models +data_ac <- function(bterms, data, data2, basis = NULL, ...) { + out <- list() + N <- nrow(data) + acef <- tidy_acef(bterms) + if (has_ac_subset(bterms, dim = "time")) { + gr <- subset2(acef, dim = "time")$gr + if (gr != "NA") { + tgroup <- as.numeric(factor(data[[gr]])) + } else { + tgroup <- rep(1, N) + } + } + if (has_ac_class(acef, "arma")) { + # ARMA correlations + acef_arma <- subset2(acef, class = "arma") + out$Kar <- acef_arma$p + out$Kma <- acef_arma$q + if (!use_ac_cov_time(acef_arma)) { + # data for the 'predictor' version of ARMA + max_lag <- max(out$Kar, out$Kma) + out$J_lag <- as.array(rep(0, N)) + for (n in seq_len(N)[-N]) { + ind <- n:max(1, n + 1 - max_lag) + # indexes errors to be used in the n+1th prediction + out$J_lag[n] <- sum(tgroup[ind] %in% tgroup[n + 1]) + } + } + } + if (use_ac_cov_time(acef)) { + # data for the 'covariance' versions of time-series structures + out$N_tg <- length(unique(tgroup)) + out$begin_tg <- as.array(ulapply(unique(tgroup), match, tgroup)) + out$nobs_tg <- as.array(with(out, + c(if (N_tg > 1L) begin_tg[2:N_tg], N + 1) - begin_tg + )) + out$end_tg <- with(out, begin_tg + nobs_tg - 1) + } + if (has_ac_class(acef, "sar")) { + acef_sar <- subset2(acef, class = "sar") + M <- data2[[acef_sar$M]] + rmd_rows <- attr(data, "na.action") + if (!is.null(rmd_rows)) { + class(rmd_rows) <- NULL + M <- M[-rmd_rows, -rmd_rows, drop = FALSE] + } + if (!is_equal(dim(M), rep(N, 2))) { + stop2("Dimensions of 'M' for SAR terms must be equal to ", + "the number of observations.") + } + out$Msar <- as.matrix(M) + out$eigenMsar <- eigen(M)$values + # simplifies code of choose_N + out$N_tg <- 1 + } + if (has_ac_class(acef, "car")) { + acef_car <- subset2(acef, class = "car") + locations <- NULL + if (length(basis)) { + locations <- basis$locations + } + M <- data2[[acef_car$M]] + if (acef_car$gr != "NA") { + loc_data <- get(acef_car$gr, data) + new_locations <- extract_levels(loc_data) + if (is.null(locations)) { + locations <- new_locations + } else { + invalid_locations <- setdiff(new_locations, locations) + if (length(invalid_locations)) { + stop2("Cannot handle new locations in CAR models.") + } + } + Nloc <- length(locations) + Jloc <- as.array(match(loc_data, locations)) + if (is.null(rownames(M))) { + stop2("Row names are required for 'M' in CAR terms.") + } + found <- locations %in% rownames(M) + if (any(!found)) { + stop2("Row names of 'M' for CAR terms do not match ", + "the names of the grouping levels.") + } + M <- M[locations, locations, drop = FALSE] + } else { + warning2( + "Using CAR terms without a grouping factor is deprecated. ", + "Please use argument 'gr' even if each observation ", + "represents its own location." + ) + Nloc <- N + Jloc <- as.array(seq_len(Nloc)) + if (!is_equal(dim(M), rep(Nloc, 2))) { + if (length(basis)) { + stop2("Cannot handle new data in CAR terms ", + "without a grouping factor.") + } else { + stop2("Dimensions of 'M' for CAR terms must be equal ", + "to the number of observations.") + } + } + } + edges_rows <- (Matrix::tril(M)@i + 1) + edges_cols <- sort(Matrix::triu(M)@i + 1) ## sort to make consistent with rows + edges <- cbind("rows" = edges_rows, "cols" = edges_cols) + c(out) <- nlist( + Nloc, Jloc, Nedges = length(edges_rows), + edges1 = as.array(edges_rows), + edges2 = as.array(edges_cols) + ) + if (acef_car$type %in% c("escar", "esicar")) { + Nneigh <- Matrix::colSums(M) + if (any(Nneigh == 0) && !length(basis)) { + stop2( + "For exact sparse CAR, all locations should have at ", + "least one neighbor within the provided data set. ", + "Consider using type = 'icar' instead." + ) + } + inv_sqrt_D <- diag(1 / sqrt(Nneigh)) + eigenMcar <- t(inv_sqrt_D) %*% M %*% inv_sqrt_D + eigenMcar <- eigen(eigenMcar, TRUE, only.values = TRUE)$values + c(out) <- nlist(Nneigh, eigenMcar) + } else if (acef_car$type %in% "bym2") { + c(out) <- list(car_scale = .car_scale(edges, Nloc)) + } + } + if (has_ac_class(acef, "fcor")) { + acef_fcor <- subset2(acef, class = "fcor") + M <- data2[[acef_fcor$M]] + rmd_rows <- attr(data, "na.action") + if (!is.null(rmd_rows)) { + class(rmd_rows) <- NULL + M <- M[-rmd_rows, -rmd_rows, drop = FALSE] + } + if (nrow(M) != N) { + stop2("Dimensions of 'M' for FCOR terms must be equal ", + "to the number of observations.") + } + out$Mfcor <- M + # simplifies code of choose_N + out$N_tg <- 1 + } + if (length(out)) { + resp <- usc(combine_prefix(bterms)) + out <- setNames(out, paste0(names(out), resp)) + } + out +} + +# prepare data of offsets for use in Stan +data_offset <- function(bterms, data) { + out <- list() + px <- check_prefix(bterms) + if (is.formula(bterms$offset)) { + p <- usc(combine_prefix(px)) + mf <- rm_attr(data, "terms") + mf <- model.frame(bterms$offset, mf, na.action = na.pass) + offset <- model.offset(mf) + if (length(offset) == 1L) { + offset <- rep(offset, nrow(data)) + } + # use 'offsets' as 'offset' will be reserved in stanc3 + out[[paste0("offsets", p)]] <- as.array(offset) + } + out +} + +# data for covariates in non-linear models +# @param x a btnl object +# @return a named list of data passed to Stan +data_cnl <- function(bterms, data) { + stopifnot(is.btnl(bterms)) + out <- list() + covars <- all.vars(bterms$covars) + if (!length(covars)) { + return(out) + } + p <- usc(combine_prefix(bterms)) + for (i in seq_along(covars)) { + cvalues <- get(covars[i], data) + if (is_like_factor(cvalues)) { + # need to apply factor contrasts + cform <- str2formula(covars[i]) + cvalues <- get_model_matrix(cform, data, cols2remove = "(Intercept)") + if (NCOL(cvalues) > 1) { + stop2("Factors with more than two levels are not allowed as covariates.") + } + cvalues <- cvalues[, 1] + } + out[[paste0("C", p, "_", i)]] <- as.array(cvalues) + } + out +} + +# compute the spatial scaling factor of CAR models +# @param edges matrix with two columns defining the adjacency of the locations +# @param Nloc number of locations +# @return a scalar scaling factor +.car_scale <- function(edges, Nloc) { + # amended from Imad Ali's code of CAR models in rstanarm + stopifnot(is.matrix(edges), NCOL(edges) == 2) + # Build the adjacency matrix + adj_matrix <- Matrix::sparseMatrix( + i = edges[, 1], j = edges[, 2], x = 1, + symmetric = TRUE + ) + # The ICAR precision matrix (which is singular) + Q <- Matrix::Diagonal(Nloc, Matrix::rowSums(adj_matrix)) - adj_matrix + # Add a small jitter to the diagonal for numerical stability + Q_pert <- Q + Matrix::Diagonal(Nloc) * + max(Matrix::diag(Q)) * sqrt(.Machine$double.eps) + # Compute the diagonal elements of the covariance matrix subject to the + # constraint that the entries of the ICAR sum to zero. + .Q_inv <- function(Q) { + Sigma <- Matrix::solve(Q) + A <- matrix(1, 1, NROW(Sigma)) + W <- Sigma %*% t(A) + Sigma <- Sigma - W %*% solve(A %*% W) %*% Matrix::t(W) + return(Sigma) + } + Q_inv <- .Q_inv(Q_pert) + # Compute the geometric mean of the variances (diagonal of Q_inv) + exp(mean(log(Matrix::diag(Q_inv)))) +} + +# data for special priors such as horseshoe and lasso +data_prior <- function(bterms, data, prior, sdata = NULL) { + out <- list() + px <- check_prefix(bterms) + p <- usc(combine_prefix(px)) + special <- get_special_prior(prior, px) + if (!is.null(special$horseshoe)) { + # data for the horseshoe prior + hs_names <- c("df", "df_global", "df_slab", "scale_global", "scale_slab") + hs_data <- special$horseshoe[hs_names] + if (!is.null(special$horseshoe$par_ratio)) { + hs_data$scale_global <- special$horseshoe$par_ratio / sqrt(nrow(data)) + } + names(hs_data) <- paste0("hs_", hs_names, p) + out <- c(out, hs_data) + } + if (!is.null(special$R2D2)) { + # data for the R2D2 prior + R2D2_names <- c("mean_R2", "prec_R2", "cons_D2") + R2D2_data <- special$R2D2[R2D2_names] + # number of coefficients minus the intercept + K <- sdata[[paste0("K", p)]] - ifelse(stan_center_X(bterms), 1, 0) + if (length(R2D2_data$cons_D2) == 1L) { + R2D2_data$cons_D2 <- rep(R2D2_data$cons_D2, K) + } + if (length(R2D2_data$cons_D2) != K) { + stop2("Argument 'cons_D2' of the R2D2 prior must be of length 1 or ", K) + } + R2D2_data$cons_D2 <- as.array(R2D2_data$cons_D2) + names(R2D2_data) <- paste0("R2D2_", R2D2_names, p) + out <- c(out, R2D2_data) + } + if (!is.null(special$lasso)) { + lasso_names <- c("df", "scale") + lasso_data <- special$lasso[lasso_names] + names(lasso_data) <- paste0("lasso_", lasso_names, p) + out <- c(out, lasso_data) + } + out +} + +# Construct design matrices for brms models +# @param formula a formula object +# @param data A data frame created with model.frame. +# If another sort of object, model.frame is called first. +# @param cols2remove names of the columns to remove from +# the model matrix; mainly used for intercepts +# @param rename rename column names via rename()? +# @param ... passed to stats::model.matrix +# @return +# The design matrix for the given formula and data. +# For details see ?stats::model.matrix +get_model_matrix <- function(formula, data = environment(formula), + cols2remove = NULL, rename = TRUE, ...) { + stopifnot(is.atomic(cols2remove)) + terms <- validate_terms(formula) + if (is.null(terms)) { + return(NULL) + } + if (no_int(terms)) { + cols2remove <- union(cols2remove, "(Intercept)") + } + X <- stats::model.matrix(terms, data, ...) + cols2remove <- which(colnames(X) %in% cols2remove) + if (length(cols2remove)) { + X <- X[, -cols2remove, drop = FALSE] + } + if (rename) { + colnames(X) <- rename(colnames(X), check_dup = TRUE) + } + X +} + +# convenient wrapper around mgcv::PredictMat +PredictMat <- function(object, data, ...) { + data <- rm_attr(data, "terms") + out <- mgcv::PredictMat(object, data = data, ...) + if (length(dim(out)) < 2L) { + # fixes issue #494 + out <- matrix(out, nrow = 1) + } + out +} + +# convenient wrapper around mgcv::smoothCon +smoothCon <- function(object, data, ...) { + data <- rm_attr(data, "terms") + vars <- setdiff(c(object$term, object$by), "NA") + for (v in vars) { + if (is_like_factor(data[[v]])) { + # allow factor-like variables #562 + data[[v]] <- as.factor(data[[v]]) + } else if (inherits(data[[v]], "difftime")) { + # mgcv cannot handle 'difftime' variables + data[[v]] <- as.numeric(data[[v]]) + } + } + mgcv::smoothCon(object, data = data, ...) +} + +# Aid prediction from smooths represented as 'type = 2' +# originally provided by Simon Wood +# @param sm output of mgcv::smoothCon +# @param data new data supplied for prediction +# @return A list of the same structure as returned by mgcv::smoothCon +s2rPred <- function(sm, data) { + re <- mgcv::smooth2random(sm, names(data), type = 2) + # prediction matrix for new data + X <- PredictMat(sm, data) + # transform to RE parameterization + if (!is.null(re$trans.U)) { + X <- X %*% re$trans.U + } + X <- t(t(X) * re$trans.D) + # re-order columns according to random effect re-ordering + X[, re$rind] <- X[, re$pen.ind != 0] + # re-order penalization index in same way + pen.ind <- re$pen.ind + pen.ind[re$rind] <- pen.ind[pen.ind > 0] + # start returning the object + Xf <- X[, which(re$pen.ind == 0), drop = FALSE] + out <- list(rand = list(), Xf = Xf) + for (i in seq_along(re$rand)) { + # loop over random effect matrices + out$rand[[i]] <- X[, which(pen.ind == i), drop = FALSE] + attr(out$rand[[i]], "s.label") <- attr(re$rand[[i]], "s.label") + } + names(out$rand) <- names(re$rand) + out +} diff -Nru r-cran-brms-2.16.3/R/data-response.R r-cran-brms-2.17.0/R/data-response.R --- r-cran-brms-2.16.3/R/data-response.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/data-response.R 2022-03-27 14:09:19.000000000 +0000 @@ -1,603 +1,610 @@ -#' Extract response values -#' -#' Extract response values from a \code{\link{brmsfit}} object. -#' -#' @param x A \code{\link{brmsfit}} object. -#' @param resp Optional names of response variables for which to extract values. -#' @param warn For internal use only. -#' @param ... Further arguments passed to \code{\link{standata}}. -#' @inheritParams posterior_predict.brmsfit -#' -#' @return Returns a vector of response values for univariate models and a -#' matrix of response values with one column per response variable for -#' multivariate models. -#' -#' @keywords internal -#' @export -get_y <- function(x, resp = NULL, sort = FALSE, warn = FALSE, ...) { - stopifnot(is.brmsfit(x)) - resp <- validate_resp(resp, x) - sort <- as_one_logical(sort) - warn <- as_one_logical(warn) - args <- list(x, resp = resp, ...) - args$re_formula <- NA - args$check_response <- TRUE - args$only_response <- TRUE - args$internal <- TRUE - sdata <- do_call(standata, args) - if (warn) { - if (any(paste0("cens", usc(resp)) %in% names(sdata))) { - warning2("Results may not be meaningful for censored models.") - } - } - Ynames <- paste0("Y", usc(resp)) - if (length(Ynames) > 1L) { - out <- do_call(cbind, sdata[Ynames]) - colnames(out) <- resp - } else { - out <- sdata[[Ynames]] - } - old_order <- attr(sdata, "old_order") - if (!is.null(old_order) && !sort) { - stopifnot(length(old_order) == NROW(out)) - out <- p(out, old_order) - } - out -} - -#' Prepare Response Data -#' -#' Prepare data related to response variables in \pkg{brms}. -#' Only exported for use in package development. -#' -#' @param x An \R object. -#' @param ... Further arguments passed to or from other methods. -#' -#' @return A named list of data related to response variables. -#' -#' @keywords internal -#' @export -data_response <- function(x, ...) { - UseMethod("data_response") -} - -#' @export -data_response.mvbrmsterms <- function(x, basis = NULL, ...) { - out <- list() - for (i in seq_along(x$terms)) { - bs <- basis$resps[[x$responses[i]]] - c(out) <- data_response(x$terms[[i]], basis = bs, ...) - } - if (x$rescor) { - out$nresp <- length(x$responses) - out$nrescor <- out$nresp * (out$nresp - 1) / 2 - } - out -} - -#' @export -data_response.brmsterms <- function(x, data, check_response = TRUE, - internal = FALSE, basis = NULL, ...) { - data <- subset_data(data, x) - N <- nrow(data) - # TODO: rename 'Y' to 'y' - Y <- model.response(model.frame(x$respform, data, na.action = na.pass)) - out <- list(N = N, Y = unname(Y)) - if (is_binary(x$family) || is_categorical(x$family)) { - out$Y <- as_factor(out$Y, levels = basis$resp_levels) - out$Y <- as.numeric(out$Y) - if (is_binary(x$family)) { - out$Y <- out$Y - 1 - } - } - if (is_ordinal(x$family) && is.ordered(out$Y)) { - out$Y <- as.numeric(out$Y) - } - if (check_response) { - family4error <- family_names(x$family) - if (is.mixfamily(x$family)) { - family4error <- paste0(family4error, collapse = ", ") - family4error <- paste0("mixture(", family4error, ")") - } - if (!allow_factors(x$family) && !is.numeric(out$Y)) { - stop2("Family '", family4error, "' requires numeric responses.") - } - if (is_binary(x$family)) { - if (any(!out$Y %in% c(0, 1))) { - stop2("Family '", family4error, "' requires responses ", - "to contain only two different values.") - } - } - if (is_ordinal(x$family)) { - if (any(!is_wholenumber(out$Y)) || any(!out$Y > 0)) { - stop2("Family '", family4error, "' requires either positive ", - "integers or ordered factors as responses.") - } - } - if (use_int(x$family)) { - if (!all(is_wholenumber(out$Y))) { - stop2("Family '", family4error, "' requires integer responses.") - } - } - if (has_multicol(x$family)) { - if (!is.matrix(out$Y)) { - stop2("This model requires a response matrix.") - } - } - if (is_dirichlet(x$family)) { - if (!is_equal(rowSums(out$Y), rep(1, nrow(out$Y)))) { - stop2("Response values in dirichlet models must sum to 1.") - } - } - ybounds <- family_info(x$family, "ybounds") - closed <- family_info(x$family, "closed") - if (is.finite(ybounds[1])) { - y_min <- min(out$Y, na.rm = TRUE) - if (closed[1] && y_min < ybounds[1]) { - stop2("Family '", family4error, "' requires response greater ", - "than or equal to ", ybounds[1], ".") - } else if (!closed[1] && y_min <= ybounds[1]) { - stop2("Family '", family4error, "' requires response greater ", - "than ", round(ybounds[1], 2), ".") - } - } - if (is.finite(ybounds[2])) { - y_max <- max(out$Y, na.rm = TRUE) - if (closed[2] && y_max > ybounds[2]) { - stop2("Family '", family4error, "' requires response smaller ", - "than or equal to ", ybounds[2], ".") - } else if (!closed[2] && y_max >= ybounds[2]) { - stop2("Family '", family4error, "' requires response smaller ", - "than ", round(ybounds[2], 2), ".") - } - } - out$Y <- as.array(out$Y) - } - # data for addition arguments of the response - if (has_trials(x$family) || is.formula(x$adforms$trials)) { - if (!length(x$adforms$trials)) { - if (is_multinomial(x$family)) { - stop2("Specifying 'trials' is required in multinomial models.") - } - trials <- round(max(out$Y, na.rm = TRUE)) - if (isTRUE(is.finite(trials))) { - message("Using the maximum response value as the number of trials.") - warning2( - "Using 'binomial' families without specifying 'trials' ", - "on the left-hand side of the model formula is deprecated." - ) - } else if (!is.null(basis$trials)) { - trials <- max(basis$trials) - } else { - stop2("Could not compute the number of trials.") - } - } else if (is.formula(x$adforms$trials)) { - trials <- get_ad_values(x, "trials", "trials", data) - if (!is.numeric(trials)) { - stop2("Number of trials must be numeric.") - } - if (any(!is_wholenumber(trials) | trials < 0)) { - stop2("Number of trials must be non-negative integers.") - } - } else { - stop2("Argument 'trials' is misspecified.") - } - if (length(trials) == 1L) { - trials <- rep(trials, nrow(data)) - } - if (check_response) { - if (is_multinomial(x$family)) { - if (!is_equal(rowSums(out$Y), trials)) { - stop2("Number of trials does not match the number of events.") - } - } else if (has_trials(x$family)) { - if (max(trials) == 1L && !internal) { - message("Only 2 levels detected so that family 'bernoulli' ", - "might be a more efficient choice.") - } - if (any(out$Y > trials)) { - stop2("Number of trials is smaller than the number of events.") - } - } - } - out$trials <- as.array(trials) - } - if (has_cat(x$family)) { - ncat <- length(get_cats(x$family)) - if (min(ncat) < 2L) { - stop2("At least two response categories are required.") - } - if (!has_multicol(x$family)) { - if (ncat == 2L && !internal) { - message("Only 2 levels detected so that family 'bernoulli' ", - "might be a more efficient choice.") - } - if (check_response && any(out$Y > ncat)) { - stop2("Number of categories is smaller than the response ", - "variable would suggest.") - } - } - out$ncat <- ncat - } - if (has_thres(x$family)) { - thres <- family_info(x, "thres") - if (has_thres_groups(x$family)) { - groups <- get_thres_groups(x) - out$ngrthres <- length(groups) - grthres <- get_ad_values(x, "thres", "gr", data) - grthres <- factor(rename(grthres), levels = groups) - # create an matrix of threshold indices per observation - Jgrthres <- match(grthres, groups) - nthres <- as.array(rep(NA, length(groups))) - for (i in seq_along(groups)) { - nthres[i] <- max(subset2(thres, group = groups[i])$thres) - } - if (check_response && any(out$Y > nthres[Jgrthres] + 1)) { - stop2("Number of thresholds is smaller than required by the response.") - } - Kthres_cumsum <- cumsum(nthres) - Kthres_start <- c(1, Kthres_cumsum[-length(nthres)] + 1) - Kthres_end <- Kthres_cumsum - Jthres <- cbind(Kthres_start, Kthres_end)[Jgrthres, , drop = FALSE] - out$Jthres <- Jthres - } else { - nthres <- max(thres$thres) - if (check_response && any(out$Y > nthres + 1)) { - stop2("Number of thresholds is smaller than required by the response.") - } - } - if (max(nthres) == 1L && !internal) { - message("Only 2 levels detected so that family 'bernoulli' ", - "might be a more efficient choice.") - } - out$nthres <- nthres - } - if (is.formula(x$adforms$cat)) { - warning2("Addition argument 'cat' is deprecated. Use 'thres' instead. ", - "See ?brmsformula for more details.") - } - - if (is.formula(x$adforms$se)) { - se <- get_ad_values(x, "se", "se", data) - if (!is.numeric(se)) { - stop2("Standard errors must be numeric.") - } - if (min(se) < 0) { - stop2("Standard errors must be non-negative.") - } - out$se <- as.array(se) - } - if (is.formula(x$adforms$weights)) { - weights <- get_ad_values(x, "weights", "weights", data) - if (!is.numeric(weights)) { - stop2("Weights must be numeric.") - } - if (min(weights) < 0) { - stop2("Weights must be non-negative.") - } - if (get_ad_flag(x, "weights", "scale")) { - weights <- weights / sum(weights) * length(weights) - } - out$weights <- as.array(weights) - } - if (is.formula(x$adforms$dec)) { - dec <- get_ad_values(x, "dec", "dec", data) - if (is.character(dec) || is.factor(dec)) { - if (!all(unique(dec) %in% c("lower", "upper"))) { - stop2("Decisions should be 'lower' or 'upper' ", - "when supplied as characters or factors.") - } - dec <- ifelse(dec == "lower", 0, 1) - } else { - dec <- as.numeric(as.logical(dec)) - } - out$dec <- as.array(dec) - } - if (is.formula(x$adforms$rate)) { - denom <- get_ad_values(x, "rate", "denom", data) - if (!is.numeric(denom)) { - stop2("Rate denomiators should be numeric.") - } - if (isTRUE(any(denom <= 0))) { - stop2("Rate denomiators should be positive.") - } - out$denom <- as.array(denom) - } - if (is.formula(x$adforms$cens) && check_response) { - cens <- get_ad_values(x, "cens", "cens", data) - cens <- prepare_cens(cens) - if (!all(is_wholenumber(cens) & cens %in% -1:2)) { - stop2( - "Invalid censoring data. Accepted values are ", - "'left', 'none', 'right', and 'interval'\n", - "(abbreviations are allowed) or -1, 0, 1, and 2.\n", - "TRUE and FALSE are also accepted ", - "and refer to 'right' and 'none' respectively." - ) - } - out$cens <- as.array(cens) - icens <- cens %in% 2 - if (any(icens)) { - y2 <- unname(get_ad_values(x, "cens", "y2", data)) - if (is.null(y2)) { - stop2("Argument 'y2' is required for interval censored data.") - } - if (anyNA(y2[icens])) { - stop2("'y2' should not be NA for interval censored observations.") - } - if (any(out$Y[icens] >= y2[icens])) { - stop2("Left censor points must be smaller than right ", - "censor points for interval censored data.") - } - y2[!icens] <- 0 # not used in Stan - out$rcens <- as.array(y2) - } - } - if (is.formula(x$adforms$trunc)) { - lb <- as.numeric(get_ad_values(x, "trunc", "lb", data)) - ub <- as.numeric(get_ad_values(x, "trunc", "ub", data)) - if (any(lb >= ub)) { - stop2("Truncation bounds are invalid: lb >= ub") - } - if (length(lb) == 1L) { - lb <- rep(lb, N) - } - if (length(ub) == 1L) { - ub <- rep(ub, N) - } - if (length(lb) != N || length(ub) != N) { - stop2("Invalid truncation bounds.") - } - inv_bounds <- out$Y < lb | out$Y > ub - if (check_response && isTRUE(any(inv_bounds))) { - stop2("Some responses are outside of the truncation bounds.") - } - out$lb <- lb - out$ub <- ub - } - if (is.formula(x$adforms$mi)) { - sdy <- get_sdy(x, data) - if (is.null(sdy)) { - # missings only - which_mi <- which(is.na(out$Y)) - out$Jmi <- as.array(which_mi) - out$Nmi <- length(out$Jmi) - } else { - # measurement error in the response - if (length(sdy) == 1L) { - sdy <- rep(sdy, length(out$Y)) - } - if (length(sdy) != length(out$Y)) { - stop2("'sdy' must have the same length as the response.") - } - # all observations will have a latent score - which_mi <- which(is.na(out$Y) | is.infinite(sdy)) - out$Jme <- as.array(setdiff(seq_along(out$Y), which_mi)) - out$Nme <- length(out$Jme) - out$noise <- as.array(sdy) - if (!internal) { - out$noise[which_mi] <- Inf - } - } - # bounds are required for predicting new missing values - # not required in Stan right now as bounds are hard-coded there - tbounds <- trunc_bounds(x, data, incl_family = TRUE) - out$lbmi <- tbounds$lb - out$ubmi <- tbounds$ub - if (!internal) { - # Stan does not allow NAs in data - # use Inf to that min(Y) is not affected - out$Y[which_mi] <- Inf - } - } - if (is.formula(x$adforms$vreal)) { - # vectors of real values for use in custom families - vreal <- eval_rhs(x$adforms$vreal) - vreal <- lapply(vreal$vars, eval2, data) - names(vreal) <- paste0("vreal", seq_along(vreal)) - for (i in seq_along(vreal)) { - if (length(vreal[[i]]) == 1L) { - vreal[[i]] <- rep(vreal[[i]], N) - } - vreal[[i]] <- as.array(as.numeric(vreal[[i]])) - } - c(out) <- vreal - } - if (is.formula(x$adforms$vint)) { - # vectors of integer values for use in custom families - vint <- eval_rhs(x$adforms$vint) - vint <- lapply(vint$vars, eval2, data) - names(vint) <- paste0("vint", seq_along(vint)) - for (i in seq_along(vint)) { - if (length(vint[[i]]) == 1L) { - vint[[i]] <- rep(vint[[i]], N) - } - if (!all(is_wholenumber(vint[[i]]))) { - stop2("'vint' requires whole numbers as input.") - } - vint[[i]] <- as.array(vint[[i]]) - } - c(out) <- vint - } - if (length(out)) { - resp <- usc(combine_prefix(x)) - out <- setNames(out, paste0(names(out), resp)) - } - out -} - -# data specific for mixture models -data_mixture <- function(bterms, data2, prior) { - stopifnot(is.brmsterms(bterms)) - out <- list() - if (is.mixfamily(bterms$family)) { - families <- family_names(bterms$family) - dp_classes <- dpar_class(names(c(bterms$dpars, bterms$fdpars))) - if (!any(dp_classes %in% "theta")) { - # estimate mixture probabilities directly - take <- find_rows(prior, class = "theta", resp = bterms$resp) - theta_prior <- prior$prior[take] - con_theta <- eval_dirichlet(theta_prior, length(families), data2) - out$con_theta <- as.array(con_theta) - p <- usc(combine_prefix(bterms)) - names(out) <- paste0(names(out), p) - } - } - out -} - -# data for the baseline functions of Cox models -data_bhaz <- function(bterms, data, data2, prior, basis = NULL) { - out <- list() - if (!is_cox(bterms$family)) { - return(out) - } - y <- model.response(model.frame(bterms$respform, data, na.action = na.pass)) - args <- bterms$family$bhaz - bs <- basis$basis_matrix - out$Zbhaz <- bhaz_basis_matrix(y, args, basis = bs) - out$Zcbhaz <- bhaz_basis_matrix(y, args, integrate = TRUE, basis = bs) - out$Kbhaz <- NCOL(out$Zbhaz) - sbhaz_prior <- subset2(prior, class = "sbhaz", resp = bterms$resp) - con_sbhaz <- eval_dirichlet(sbhaz_prior$prior, out$Kbhaz, data2) - out$con_sbhaz <- as.array(con_sbhaz) - out -} - -# Basis matrices for baseline hazard functions of the Cox model -# @param y vector of response values -# @param args arguments passed to the spline generating functions -# @param integrate compute the I-spline instead of the M-spline basis? -# @param basis optional precomputed basis matrix -# @return the design matrix of the baseline hazard function -bhaz_basis_matrix <- function(y, args = list(), integrate = FALSE, - basis = NULL) { - require_package("splines2") - if (!is.null(basis)) { - # perform predictions based on an existing basis matrix - stopifnot(inherits(basis, "mSpline")) - if (integrate) { - # for predictions just the attibutes are required - # which are the same of M-Splines and I-Splines - class(basis) <- c("matrix", "iSpline") - } - return(predict(basis, y)) - } - stopifnot(is.list(args)) - args$x <- y - if (!is.null(args$intercept)) { - args$intercept <- as_one_logical(args$intercept) - } - if (is.null(args$Boundary.knots)) { - # avoid 'knots' outside 'Boundary.knots' error (#1143) - # we also need a smaller lower boundary knot to avoid lp = -Inf - # the below choices are ad-hoc and may need further thought - min_y <- min(y, na.rm = TRUE) - max_y <- max(y, na.rm = TRUE) - diff_y <- max_y - min_y - lower_knot <- max(min_y - diff_y / 50, 0) - upper_knot <- max_y + diff_y / 50 - args$Boundary.knots <- c(lower_knot, upper_knot) - } - if (integrate) { - out <- do_call(splines2::iSpline, args) - } else { - out <- do_call(splines2::mSpline, args) - } - out -} - -# extract names of response categories -# @param x a brmsterms object or one that can be coerced to it -# @param data user specified data -# @return a vector of category names -extract_cat_names <- function(x, data) { - stopifnot(is.brmsformula(x) || is.brmsterms(x)) - respform <- validate_resp_formula(x$formula) - mr <- model.response(model.frame(respform, data)) - if (has_multicol(x)) { - mr <- as.matrix(mr) - out <- as.character(colnames(mr)) - if (!length(out)) { - out <- as.character(seq_cols(mr)) - } - } else { - out <- levels(factor(mr)) - } - out -} - -# extract names of ordinal thresholds -# @param x a brmsterms object or one that can be coerced to it -# @param data user specified data -# @return a data.frame with columns 'thres' and 'group' -extract_thres_names <- function(x, data) { - stopifnot(is.brmsformula(x) || is.brmsterms(x), has_thres(x)) - - if (is.null(x$adforms)) { - x$adforms <- terms_ad(x$formula, x$family) - } - nthres <- get_ad_values(x, "thres", "thres", data) - if (any(!is_wholenumber(nthres) | nthres < 1L)) { - stop2("Number of thresholds must be a positive integer.") - } - grthres <- get_ad_values(x, "thres", "gr", data) - if (!is.null(grthres)) { - # grouping variable was specified - if (!is_like_factor(grthres)) { - stop2("Variable 'gr' in 'thres' needs to be factor-like.") - } - grthres <- factor(grthres) - group <- levels(grthres) - if (!length(nthres)) { - # extract number of thresholds from the response values - nthres <- rep(NA, length(group)) - for (i in seq_along(group)) { - take <- grthres %in% group[i] - nthres[i] <- extract_nthres(x$formula, data[take, , drop = FALSE]) - } - } else if (length(nthres) == 1L) { - # replicate number of thresholds across groups - nthres <- rep(nthres, length(group)) - } else { - # number of thresholds is a variable in the data - for (i in seq_along(group)) { - # validate values of the same level - take <- grthres %in% group[i] - if (length(unique(nthres[take])) > 1L) { - stop2("Number of thresholds should be unique for each group.") - } - } - nthres <- get_one_value_per_group(nthres, grthres) - } - group <- rep(rename(group), nthres) - thres <- ulapply(unname(nthres), seq_len) - } else { - # no grouping variable was specified - group <- "" - if (!length(nthres)) { - # extract number of thresholds from the response values - nthres <- extract_nthres(x$formula, data) - } - if (length(nthres) > 1L) { - stop2("Number of thresholds needs to be a single value.") - } - thres <- seq_len(nthres) - } - data.frame(thres, group, stringsAsFactors = FALSE) -} - -# extract threshold names from the response values -# @param formula with the response on the LHS -# @param data a data.frame from which to extract responses -# @return a single value for the number of thresholds -extract_nthres <- function(formula, data) { - respform <- validate_resp_formula(formula) - mr <- model.response(model.frame(respform, data)) - if (is_like_factor(mr)) { - out <- length(levels(factor(mr))) - 1 - } else { - out <- max(mr) - 1 - } - out -} +#' Extract response values +#' +#' Extract response values from a \code{\link{brmsfit}} object. +#' +#' @param x A \code{\link{brmsfit}} object. +#' @param resp Optional names of response variables for which to extract values. +#' @param warn For internal use only. +#' @param ... Further arguments passed to \code{\link{standata}}. +#' @inheritParams posterior_predict.brmsfit +#' +#' @return Returns a vector of response values for univariate models and a +#' matrix of response values with one column per response variable for +#' multivariate models. +#' +#' @keywords internal +#' @export +get_y <- function(x, resp = NULL, sort = FALSE, warn = FALSE, ...) { + stopifnot(is.brmsfit(x)) + resp <- validate_resp(resp, x) + sort <- as_one_logical(sort) + warn <- as_one_logical(warn) + args <- list(x, resp = resp, ...) + args$re_formula <- NA + args$check_response <- TRUE + args$only_response <- TRUE + args$internal <- TRUE + sdata <- do_call(standata, args) + if (warn) { + if (any(paste0("cens", usc(resp)) %in% names(sdata))) { + warning2("Results may not be meaningful for censored models.") + } + } + Ynames <- paste0("Y", usc(resp)) + if (length(Ynames) > 1L) { + out <- do_call(cbind, sdata[Ynames]) + colnames(out) <- resp + } else { + out <- sdata[[Ynames]] + } + old_order <- attr(sdata, "old_order") + if (!is.null(old_order) && !sort) { + stopifnot(length(old_order) == NROW(out)) + out <- p(out, old_order) + } + out +} + +#' Prepare Response Data +#' +#' Prepare data related to response variables in \pkg{brms}. +#' Only exported for use in package development. +#' +#' @param x An \R object. +#' @param ... Further arguments passed to or from other methods. +#' +#' @return A named list of data related to response variables. +#' +#' @keywords internal +#' @export +data_response <- function(x, ...) { + UseMethod("data_response") +} + +#' @export +data_response.mvbrmsterms <- function(x, basis = NULL, ...) { + out <- list() + for (i in seq_along(x$terms)) { + bs <- basis$resps[[x$responses[i]]] + c(out) <- data_response(x$terms[[i]], basis = bs, ...) + } + if (x$rescor) { + out$nresp <- length(x$responses) + out$nrescor <- out$nresp * (out$nresp - 1) / 2 + } + out +} + +#' @export +data_response.brmsterms <- function(x, data, check_response = TRUE, + internal = FALSE, basis = NULL, ...) { + data <- subset_data(data, x) + N <- nrow(data) + # TODO: rename 'Y' to 'y' + Y <- model.response(model.frame(x$respform, data, na.action = na.pass)) + out <- list(N = N, Y = unname(Y)) + if (is_binary(x$family)) { + bin_levels <- basis$resp_levels + if (is.null(bin_levels)) { + bin_levels <- sort(unique(out$Y)) + } + # fixes issue #1298 + if (is.numeric(out$Y) && length(bin_levels) == 1L && !0 %in% bin_levels) { + bin_levels <- c(0, bin_levels) + } + out$Y <- as.numeric(as_factor(out$Y, levels = bin_levels)) - 1 + } + if (is_categorical(x$family)) { + out$Y <- as.numeric(as_factor(out$Y, levels = basis$resp_levels)) + } + if (is_ordinal(x$family) && is.ordered(out$Y)) { + out$Y <- as.numeric(out$Y) + } + if (check_response) { + family4error <- family_names(x$family) + if (is.mixfamily(x$family)) { + family4error <- paste0(family4error, collapse = ", ") + family4error <- paste0("mixture(", family4error, ")") + } + if (!allow_factors(x$family) && !is.numeric(out$Y)) { + stop2("Family '", family4error, "' requires numeric responses.") + } + if (is_binary(x$family)) { + if (any(!out$Y %in% c(0, 1))) { + stop2("Family '", family4error, "' requires responses ", + "to contain only two different values.") + } + } + if (is_ordinal(x$family)) { + if (any(!is_wholenumber(out$Y)) || any(!out$Y > 0)) { + stop2("Family '", family4error, "' requires either positive ", + "integers or ordered factors as responses.") + } + } + if (use_int(x$family)) { + if (!all(is_wholenumber(out$Y))) { + stop2("Family '", family4error, "' requires integer responses.") + } + } + if (has_multicol(x$family)) { + if (!is.matrix(out$Y)) { + stop2("This model requires a response matrix.") + } + } + if (is_simplex(x$family)) { + if (!is_equal(rowSums(out$Y), rep(1, nrow(out$Y)))) { + stop2("Response values in simplex models must sum to 1.") + } + } + ybounds <- family_info(x$family, "ybounds") + closed <- family_info(x$family, "closed") + if (is.finite(ybounds[1])) { + y_min <- min(out$Y, na.rm = TRUE) + if (closed[1] && y_min < ybounds[1]) { + stop2("Family '", family4error, "' requires response greater ", + "than or equal to ", ybounds[1], ".") + } else if (!closed[1] && y_min <= ybounds[1]) { + stop2("Family '", family4error, "' requires response greater ", + "than ", round(ybounds[1], 2), ".") + } + } + if (is.finite(ybounds[2])) { + y_max <- max(out$Y, na.rm = TRUE) + if (closed[2] && y_max > ybounds[2]) { + stop2("Family '", family4error, "' requires response smaller ", + "than or equal to ", ybounds[2], ".") + } else if (!closed[2] && y_max >= ybounds[2]) { + stop2("Family '", family4error, "' requires response smaller ", + "than ", round(ybounds[2], 2), ".") + } + } + out$Y <- as.array(out$Y) + } + # data for addition arguments of the response + if (has_trials(x$family) || is.formula(x$adforms$trials)) { + if (!length(x$adforms$trials)) { + if (is_multinomial(x$family)) { + stop2("Specifying 'trials' is required in multinomial models.") + } + trials <- round(max(out$Y, na.rm = TRUE)) + if (isTRUE(is.finite(trials))) { + message("Using the maximum response value as the number of trials.") + warning2( + "Using 'binomial' families without specifying 'trials' ", + "on the left-hand side of the model formula is deprecated." + ) + } else if (!is.null(basis$trials)) { + trials <- max(basis$trials) + } else { + stop2("Could not compute the number of trials.") + } + } else if (is.formula(x$adforms$trials)) { + trials <- get_ad_values(x, "trials", "trials", data) + if (!is.numeric(trials)) { + stop2("Number of trials must be numeric.") + } + if (any(!is_wholenumber(trials) | trials < 0)) { + stop2("Number of trials must be non-negative integers.") + } + } else { + stop2("Argument 'trials' is misspecified.") + } + if (length(trials) == 1L) { + trials <- rep(trials, nrow(data)) + } + if (check_response) { + if (is_multinomial(x$family)) { + if (!is_equal(rowSums(out$Y), trials)) { + stop2("Number of trials does not match the number of events.") + } + } else if (has_trials(x$family)) { + if (max(trials) == 1L && !internal) { + message("Only 2 levels detected so that family 'bernoulli' ", + "might be a more efficient choice.") + } + if (any(out$Y > trials)) { + stop2("Number of trials is smaller than the number of events.") + } + } + } + out$trials <- as.array(trials) + } + if (has_cat(x$family)) { + ncat <- length(get_cats(x$family)) + if (min(ncat) < 2L) { + stop2("At least two response categories are required.") + } + if (!has_multicol(x$family)) { + if (ncat == 2L && !internal) { + message("Only 2 levels detected so that family 'bernoulli' ", + "might be a more efficient choice.") + } + if (check_response && any(out$Y > ncat)) { + stop2("Number of categories is smaller than the response ", + "variable would suggest.") + } + } + out$ncat <- ncat + } + if (has_thres(x$family)) { + thres <- family_info(x, "thres") + if (has_thres_groups(x$family)) { + groups <- get_thres_groups(x) + out$ngrthres <- length(groups) + grthres <- get_ad_values(x, "thres", "gr", data) + grthres <- factor(rename(grthres), levels = groups) + # create an matrix of threshold indices per observation + Jgrthres <- match(grthres, groups) + nthres <- as.array(rep(NA, length(groups))) + for (i in seq_along(groups)) { + nthres[i] <- max(subset2(thres, group = groups[i])$thres) + } + if (check_response && any(out$Y > nthres[Jgrthres] + 1)) { + stop2("Number of thresholds is smaller than required by the response.") + } + Kthres_cumsum <- cumsum(nthres) + Kthres_start <- c(1, Kthres_cumsum[-length(nthres)] + 1) + Kthres_end <- Kthres_cumsum + Jthres <- cbind(Kthres_start, Kthres_end)[Jgrthres, , drop = FALSE] + out$Jthres <- Jthres + } else { + nthres <- max(thres$thres) + if (check_response && any(out$Y > nthres + 1)) { + stop2("Number of thresholds is smaller than required by the response.") + } + } + if (max(nthres) == 1L && !internal) { + message("Only 2 levels detected so that family 'bernoulli' ", + "might be a more efficient choice.") + } + out$nthres <- nthres + } + if (is.formula(x$adforms$cat)) { + warning2("Addition argument 'cat' is deprecated. Use 'thres' instead. ", + "See ?brmsformula for more details.") + } + + if (is.formula(x$adforms$se)) { + se <- get_ad_values(x, "se", "se", data) + if (!is.numeric(se)) { + stop2("Standard errors must be numeric.") + } + if (min(se) < 0) { + stop2("Standard errors must be non-negative.") + } + out$se <- as.array(se) + } + if (is.formula(x$adforms$weights)) { + weights <- get_ad_values(x, "weights", "weights", data) + if (!is.numeric(weights)) { + stop2("Weights must be numeric.") + } + if (min(weights) < 0) { + stop2("Weights must be non-negative.") + } + if (get_ad_flag(x, "weights", "scale")) { + weights <- weights / sum(weights) * length(weights) + } + out$weights <- as.array(weights) + } + if (is.formula(x$adforms$dec)) { + dec <- get_ad_values(x, "dec", "dec", data) + if (is.character(dec) || is.factor(dec)) { + if (!all(unique(dec) %in% c("lower", "upper"))) { + stop2("Decisions should be 'lower' or 'upper' ", + "when supplied as characters or factors.") + } + dec <- ifelse(dec == "lower", 0, 1) + } else { + dec <- as.numeric(as.logical(dec)) + } + out$dec <- as.array(dec) + } + if (is.formula(x$adforms$rate)) { + denom <- get_ad_values(x, "rate", "denom", data) + if (!is.numeric(denom)) { + stop2("Rate denomiators should be numeric.") + } + if (isTRUE(any(denom <= 0))) { + stop2("Rate denomiators should be positive.") + } + out$denom <- as.array(denom) + } + if (is.formula(x$adforms$cens) && check_response) { + cens <- get_ad_values(x, "cens", "cens", data) + cens <- prepare_cens(cens) + if (!all(is_wholenumber(cens) & cens %in% -1:2)) { + stop2( + "Invalid censoring data. Accepted values are ", + "'left', 'none', 'right', and 'interval'\n", + "(abbreviations are allowed) or -1, 0, 1, and 2.\n", + "TRUE and FALSE are also accepted ", + "and refer to 'right' and 'none' respectively." + ) + } + out$cens <- as.array(cens) + icens <- cens %in% 2 + if (any(icens)) { + y2 <- unname(get_ad_values(x, "cens", "y2", data)) + if (is.null(y2)) { + stop2("Argument 'y2' is required for interval censored data.") + } + if (anyNA(y2[icens])) { + stop2("'y2' should not be NA for interval censored observations.") + } + if (any(out$Y[icens] >= y2[icens])) { + stop2("Left censor points must be smaller than right ", + "censor points for interval censored data.") + } + y2[!icens] <- 0 # not used in Stan + out$rcens <- as.array(y2) + } + } + if (is.formula(x$adforms$trunc)) { + lb <- as.numeric(get_ad_values(x, "trunc", "lb", data)) + ub <- as.numeric(get_ad_values(x, "trunc", "ub", data)) + if (any(lb >= ub)) { + stop2("Truncation bounds are invalid: lb >= ub") + } + if (length(lb) == 1L) { + lb <- rep(lb, N) + } + if (length(ub) == 1L) { + ub <- rep(ub, N) + } + if (length(lb) != N || length(ub) != N) { + stop2("Invalid truncation bounds.") + } + inv_bounds <- out$Y < lb | out$Y > ub + if (check_response && isTRUE(any(inv_bounds))) { + stop2("Some responses are outside of the truncation bounds.") + } + out$lb <- lb + out$ub <- ub + } + if (is.formula(x$adforms$mi)) { + sdy <- get_sdy(x, data) + if (is.null(sdy)) { + # missings only + which_mi <- which(is.na(out$Y)) + out$Jmi <- as.array(which_mi) + out$Nmi <- length(out$Jmi) + } else { + # measurement error in the response + if (length(sdy) == 1L) { + sdy <- rep(sdy, length(out$Y)) + } + if (length(sdy) != length(out$Y)) { + stop2("'sdy' must have the same length as the response.") + } + # all observations will have a latent score + which_mi <- which(is.na(out$Y) | is.infinite(sdy)) + out$Jme <- as.array(setdiff(seq_along(out$Y), which_mi)) + out$Nme <- length(out$Jme) + out$noise <- as.array(sdy) + if (!internal) { + out$noise[which_mi] <- Inf + } + } + # bounds are required for predicting new missing values + # not required in Stan right now as bounds are hard-coded there + tbounds <- trunc_bounds(x, data, incl_family = TRUE) + out$lbmi <- tbounds$lb + out$ubmi <- tbounds$ub + if (!internal) { + # Stan does not allow NAs in data + # use Inf to that min(Y) is not affected + out$Y[which_mi] <- Inf + } + } + if (is.formula(x$adforms$vreal)) { + # vectors of real values for use in custom families + vreal <- eval_rhs(x$adforms$vreal) + vreal <- lapply(vreal$vars, eval2, data) + names(vreal) <- paste0("vreal", seq_along(vreal)) + for (i in seq_along(vreal)) { + if (length(vreal[[i]]) == 1L) { + vreal[[i]] <- rep(vreal[[i]], N) + } + vreal[[i]] <- as.array(as.numeric(vreal[[i]])) + } + c(out) <- vreal + } + if (is.formula(x$adforms$vint)) { + # vectors of integer values for use in custom families + vint <- eval_rhs(x$adforms$vint) + vint <- lapply(vint$vars, eval2, data) + names(vint) <- paste0("vint", seq_along(vint)) + for (i in seq_along(vint)) { + if (length(vint[[i]]) == 1L) { + vint[[i]] <- rep(vint[[i]], N) + } + if (!all(is_wholenumber(vint[[i]]))) { + stop2("'vint' requires whole numbers as input.") + } + vint[[i]] <- as.array(vint[[i]]) + } + c(out) <- vint + } + if (length(out)) { + resp <- usc(combine_prefix(x)) + out <- setNames(out, paste0(names(out), resp)) + } + out +} + +# data specific for mixture models +data_mixture <- function(bterms, data2, prior) { + stopifnot(is.brmsterms(bterms)) + out <- list() + if (is.mixfamily(bterms$family)) { + families <- family_names(bterms$family) + dp_classes <- dpar_class(names(c(bterms$dpars, bterms$fdpars))) + if (!any(dp_classes %in% "theta")) { + # estimate mixture probabilities directly + take <- find_rows(prior, class = "theta", resp = bterms$resp) + theta_prior <- prior$prior[take] + con_theta <- eval_dirichlet(theta_prior, length(families), data2) + out$con_theta <- as.array(con_theta) + p <- usc(combine_prefix(bterms)) + names(out) <- paste0(names(out), p) + } + } + out +} + +# data for the baseline functions of Cox models +data_bhaz <- function(bterms, data, data2, prior, basis = NULL) { + out <- list() + if (!is_cox(bterms$family)) { + return(out) + } + y <- model.response(model.frame(bterms$respform, data, na.action = na.pass)) + args <- bterms$family$bhaz + bs <- basis$basis_matrix + out$Zbhaz <- bhaz_basis_matrix(y, args, basis = bs) + out$Zcbhaz <- bhaz_basis_matrix(y, args, integrate = TRUE, basis = bs) + out$Kbhaz <- NCOL(out$Zbhaz) + sbhaz_prior <- subset2(prior, class = "sbhaz", resp = bterms$resp) + con_sbhaz <- eval_dirichlet(sbhaz_prior$prior, out$Kbhaz, data2) + out$con_sbhaz <- as.array(con_sbhaz) + out +} + +# Basis matrices for baseline hazard functions of the Cox model +# @param y vector of response values +# @param args arguments passed to the spline generating functions +# @param integrate compute the I-spline instead of the M-spline basis? +# @param basis optional precomputed basis matrix +# @return the design matrix of the baseline hazard function +bhaz_basis_matrix <- function(y, args = list(), integrate = FALSE, + basis = NULL) { + require_package("splines2") + if (!is.null(basis)) { + # perform predictions based on an existing basis matrix + stopifnot(inherits(basis, "mSpline")) + if (integrate) { + # for predictions just the attibutes are required + # which are the same of M-Splines and I-Splines + class(basis) <- c("matrix", "iSpline") + } + return(predict(basis, y)) + } + stopifnot(is.list(args)) + args$x <- y + if (!is.null(args$intercept)) { + args$intercept <- as_one_logical(args$intercept) + } + if (is.null(args$Boundary.knots)) { + # avoid 'knots' outside 'Boundary.knots' error (#1143) + # we also need a smaller lower boundary knot to avoid lp = -Inf + # the below choices are ad-hoc and may need further thought + min_y <- min(y, na.rm = TRUE) + max_y <- max(y, na.rm = TRUE) + diff_y <- max_y - min_y + lower_knot <- max(min_y - diff_y / 50, 0) + upper_knot <- max_y + diff_y / 50 + args$Boundary.knots <- c(lower_knot, upper_knot) + } + if (integrate) { + out <- do_call(splines2::iSpline, args) + } else { + out <- do_call(splines2::mSpline, args) + } + out +} + +# extract names of response categories +# @param x a brmsterms object or one that can be coerced to it +# @param data user specified data +# @return a vector of category names +extract_cat_names <- function(x, data) { + stopifnot(is.brmsformula(x) || is.brmsterms(x)) + respform <- validate_resp_formula(x$formula) + mr <- model.response(model.frame(respform, data)) + if (has_multicol(x)) { + mr <- as.matrix(mr) + out <- as.character(colnames(mr)) + if (!length(out)) { + out <- as.character(seq_cols(mr)) + } + } else { + out <- levels(factor(mr)) + } + out +} + +# extract names of ordinal thresholds +# @param x a brmsterms object or one that can be coerced to it +# @param data user specified data +# @return a data.frame with columns 'thres' and 'group' +extract_thres_names <- function(x, data) { + stopifnot(is.brmsformula(x) || is.brmsterms(x), has_thres(x)) + + if (is.null(x$adforms)) { + x$adforms <- terms_ad(x$formula, x$family) + } + nthres <- get_ad_values(x, "thres", "thres", data) + if (any(!is_wholenumber(nthres) | nthres < 1L)) { + stop2("Number of thresholds must be a positive integer.") + } + grthres <- get_ad_values(x, "thres", "gr", data) + if (!is.null(grthres)) { + # grouping variable was specified + if (!is_like_factor(grthres)) { + stop2("Variable 'gr' in 'thres' needs to be factor-like.") + } + grthres <- factor(grthres) + group <- levels(grthres) + if (!length(nthres)) { + # extract number of thresholds from the response values + nthres <- rep(NA, length(group)) + for (i in seq_along(group)) { + take <- grthres %in% group[i] + nthres[i] <- extract_nthres(x$formula, data[take, , drop = FALSE]) + } + } else if (length(nthres) == 1L) { + # replicate number of thresholds across groups + nthres <- rep(nthres, length(group)) + } else { + # number of thresholds is a variable in the data + for (i in seq_along(group)) { + # validate values of the same level + take <- grthres %in% group[i] + if (length(unique(nthres[take])) > 1L) { + stop2("Number of thresholds should be unique for each group.") + } + } + nthres <- get_one_value_per_group(nthres, grthres) + } + group <- rep(rename(group), nthres) + thres <- ulapply(unname(nthres), seq_len) + } else { + # no grouping variable was specified + group <- "" + if (!length(nthres)) { + # extract number of thresholds from the response values + nthres <- extract_nthres(x$formula, data) + } + if (length(nthres) > 1L) { + stop2("Number of thresholds needs to be a single value.") + } + thres <- seq_len(nthres) + } + data.frame(thres, group, stringsAsFactors = FALSE) +} + +# extract threshold names from the response values +# @param formula with the response on the LHS +# @param data a data.frame from which to extract responses +# @return a single value for the number of thresholds +extract_nthres <- function(formula, data) { + respform <- validate_resp_formula(formula) + mr <- model.response(model.frame(respform, data)) + if (is_like_factor(mr)) { + out <- length(levels(factor(mr))) - 1 + } else { + out <- max(mr) - 1 + } + out +} diff -Nru r-cran-brms-2.16.3/R/datasets.R r-cran-brms-2.17.0/R/datasets.R --- r-cran-brms-2.16.3/R/datasets.R 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/R/datasets.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,194 +1,194 @@ -#' Infections in kidney patients -#' -#' @description This dataset, originally discussed in -#' McGilchrist and Aisbett (1991), describes the first and second -#' (possibly right censored) recurrence time of -#' infection in kidney patients using portable dialysis equipment. -#' In addition, information on the risk variables age, sex and disease -#' type is provided. -#' -#' @format A data frame of 76 observations containing -#' information on the following 7 variables. -#' \describe{ -#' \item{time}{The time to first or second recurrence of the infection, -#' or the time of censoring} -#' \item{recur}{A factor of levels \code{1} or \code{2} -#' indicating if the infection recurred for the first -#' or second time for this patient} -#' \item{censored}{Either \code{0} or \code{1}, where \code{0} indicates -#' no censoring of recurrence time and \code{1} indicates right censoring} -#' \item{patient}{The patient number} -#' \item{age}{The age of the patient} -#' \item{sex}{The sex of the patient} -#' \item{disease}{A factor of levels \code{other, GN, AN}, -#' and \code{PKD} specifying the type of disease} -#' } -#' -#' @source McGilchrist, C. A., & Aisbett, C. W. (1991). -#' Regression with frailty in survival analysis. -#' \emph{Biometrics}, 47(2), 461-466. -#' -#' @examples -#' \dontrun{ -#' ## performing surivival analysis using the "weibull" family -#' fit1 <- brm(time | cens(censored) ~ age + sex + disease, -#' data = kidney, family = weibull, inits = "0") -#' summary(fit1) -#' plot(fit1) -#' -#' ## adding random intercepts over patients -#' fit2 <- brm(time | cens(censored) ~ age + sex + disease + (1|patient), -#' data = kidney, family = weibull(), inits = "0", -#' prior = set_prior("cauchy(0,2)", class = "sd")) -#' summary(fit2) -#' plot(fit2) -#' } -#' -"kidney" - - -#' Clarity of inhaler instructions -#' -#' @description Ezzet and Whitehead (1991) analyze data from a two-treatment, -#' two-period crossover trial to compare 2 inhalation devices for -#' delivering the drug salbutamol in 286 asthma patients. -#' Patients were asked to rate the clarity of leaflet instructions -#' accompanying each device, using a 4-point ordinal scale. -#' -#' @format A data frame of 572 observations containing -#' information on the following 5 variables. -#' \describe{ -#' \item{subject}{The subject number} -#' \item{rating}{The rating of the inhaler instructions -#' on a scale ranging from 1 to 4} -#' \item{treat}{A contrast to indicate which of -#' the two inhaler devices was used} -#' \item{period}{A contrast to indicate the time of administration} -#' \item{carry}{A contrast to indicate possible carry over effects} -#' } -#' -#' @source Ezzet, F., & Whitehead, J. (1991). -#' A random effects model for ordinal responses from a crossover trial. -#' \emph{Statistics in Medicine}, 10(6), 901-907. -#' -#' @examples -#' \dontrun{ -#' ## ordinal regression with family "sratio" -#' fit1 <- brm(rating ~ treat + period + carry, -#' data = inhaler, family = sratio(), -#' prior = set_prior("normal(0,5)")) -#' summary(fit1) -#' plot(fit1) -#' -#' ## ordinal regression with family "cumulative" -#' ## and random intercept over subjects -#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler, family = cumulative(), -#' prior = set_prior("normal(0,5)")) -#' summary(fit2) -#' plot(fit2) -#' } -#' -"inhaler" - - -#' Epileptic seizure counts -#' -#' @description Breslow and Clayton (1993) analyze data initially -#' provided by Thall and Vail (1990) concerning -#' seizure counts in a randomized trial of anti-convulsant -#' therapy in epilepsy. Covariates are treatment, -#' 8-week baseline seizure counts, and age of the patients in years. -#' -#' @format A data frame of 236 observations containing information -#' on the following 9 variables. -#' \describe{ -#' \item{Age}{The age of the patients in years} -#' \item{Base}{The seizure count at 8-weeks baseline} -#' \item{Trt}{Either \code{0} or \code{1} indicating -#' if the patient received anti-convulsant therapy} -#' \item{patient}{The patient number} -#' \item{visit}{The session number from \code{1} (first visit) -#' to \code{4} (last visit)} -#' \item{count}{The seizure count between two visits} -#' \item{obs}{The observation number, that is -#' a unique identifier for each observation} -#' \item{zAge}{Standardized \code{Age}} -#' \item{zBase}{Standardized \code{Base}} -#' } -#' -#' @source Thall, P. F., & Vail, S. C. (1990). -#' Some covariance models for longitudinal count data with overdispersion. -#' \emph{Biometrics, 46(2)}, 657-671. \cr -#' -#' Breslow, N. E., & Clayton, D. G. (1993). -#' Approximate inference in generalized linear mixed models. -#' \emph{Journal of the American Statistical Association}, 88(421), 9-25. -#' -#' @examples -#' \dontrun{ -#' ## poisson regression without random effects. -#' fit1 <- brm(count ~ zAge + zBase * Trt, -#' data = epilepsy, family = poisson()) -#' summary(fit1) -#' plot(fit1) -#' -#' ## poisson regression with varying intercepts of patients -#' ## as well as normal priors for overall effects parameters. -#' fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient), -#' data = epilepsy, family = poisson(), -#' prior = set_prior("normal(0,5)")) -#' summary(fit2) -#' plot(fit2) -#' } -#' -"epilepsy" - -#' Cumulative Insurance Loss Payments -#' -#' @description This dataset, discussed in Gesmann & Morris (2020), contains -#' cumulative insurance loss payments over the course of ten years. -#' -#' @format A data frame of 55 observations containing information -#' on the following 4 variables. -#' \describe{ -#' \item{AY}{Origin year of the insurance (1991 to 2000)} -#' \item{dev}{Deviation from the origin year in months} -#' \item{cum}{Cumulative loss payments} -#' \item{premium}{Achieved premiums for the given origin year} -#' } -#' -#' @source Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving -#' Models. \emph{CAS Research Papers}. -#' -#' @examples -#' \dontrun{ -#' # non-linear model to predict cumulative loss payments -#' fit_loss <- brm( -#' bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), -#' ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, -#' nl = TRUE), -#' data = loss, family = gaussian(), -#' prior = c( -#' prior(normal(5000, 1000), nlpar = "ult"), -#' prior(normal(1, 2), nlpar = "omega"), -#' prior(normal(45, 10), nlpar = "theta") -#' ), -#' control = list(adapt_delta = 0.9) -#' ) -#' -#' # basic summaries -#' summary(fit_loss) -#' conditional_effects(fit_loss) -#' -#' # plot predictions per origin year -#' conditions <- data.frame(AY = unique(loss$AY)) -#' rownames(conditions) <- unique(loss$AY) -#' me_loss <- conditional_effects( -#' fit_loss, conditions = conditions, -#' re_formula = NULL, method = "predict" -#' ) -#' plot(me_loss, ncol = 5, points = TRUE) -#' } -#' -"loss" +#' Infections in kidney patients +#' +#' @description This dataset, originally discussed in +#' McGilchrist and Aisbett (1991), describes the first and second +#' (possibly right censored) recurrence time of +#' infection in kidney patients using portable dialysis equipment. +#' In addition, information on the risk variables age, sex and disease +#' type is provided. +#' +#' @format A data frame of 76 observations containing +#' information on the following 7 variables. +#' \describe{ +#' \item{time}{The time to first or second recurrence of the infection, +#' or the time of censoring} +#' \item{recur}{A factor of levels \code{1} or \code{2} +#' indicating if the infection recurred for the first +#' or second time for this patient} +#' \item{censored}{Either \code{0} or \code{1}, where \code{0} indicates +#' no censoring of recurrence time and \code{1} indicates right censoring} +#' \item{patient}{The patient number} +#' \item{age}{The age of the patient} +#' \item{sex}{The sex of the patient} +#' \item{disease}{A factor of levels \code{other, GN, AN}, +#' and \code{PKD} specifying the type of disease} +#' } +#' +#' @source McGilchrist, C. A., & Aisbett, C. W. (1991). +#' Regression with frailty in survival analysis. +#' \emph{Biometrics}, 47(2), 461-466. +#' +#' @examples +#' \dontrun{ +#' ## performing surivival analysis using the "weibull" family +#' fit1 <- brm(time | cens(censored) ~ age + sex + disease, +#' data = kidney, family = weibull, init = "0") +#' summary(fit1) +#' plot(fit1) +#' +#' ## adding random intercepts over patients +#' fit2 <- brm(time | cens(censored) ~ age + sex + disease + (1|patient), +#' data = kidney, family = weibull(), init = "0", +#' prior = set_prior("cauchy(0,2)", class = "sd")) +#' summary(fit2) +#' plot(fit2) +#' } +#' +"kidney" + + +#' Clarity of inhaler instructions +#' +#' @description Ezzet and Whitehead (1991) analyze data from a two-treatment, +#' two-period crossover trial to compare 2 inhalation devices for +#' delivering the drug salbutamol in 286 asthma patients. +#' Patients were asked to rate the clarity of leaflet instructions +#' accompanying each device, using a 4-point ordinal scale. +#' +#' @format A data frame of 572 observations containing +#' information on the following 5 variables. +#' \describe{ +#' \item{subject}{The subject number} +#' \item{rating}{The rating of the inhaler instructions +#' on a scale ranging from 1 to 4} +#' \item{treat}{A contrast to indicate which of +#' the two inhaler devices was used} +#' \item{period}{A contrast to indicate the time of administration} +#' \item{carry}{A contrast to indicate possible carry over effects} +#' } +#' +#' @source Ezzet, F., & Whitehead, J. (1991). +#' A random effects model for ordinal responses from a crossover trial. +#' \emph{Statistics in Medicine}, 10(6), 901-907. +#' +#' @examples +#' \dontrun{ +#' ## ordinal regression with family "sratio" +#' fit1 <- brm(rating ~ treat + period + carry, +#' data = inhaler, family = sratio(), +#' prior = set_prior("normal(0,5)")) +#' summary(fit1) +#' plot(fit1) +#' +#' ## ordinal regression with family "cumulative" +#' ## and random intercept over subjects +#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler, family = cumulative(), +#' prior = set_prior("normal(0,5)")) +#' summary(fit2) +#' plot(fit2) +#' } +#' +"inhaler" + + +#' Epileptic seizure counts +#' +#' @description Breslow and Clayton (1993) analyze data initially +#' provided by Thall and Vail (1990) concerning +#' seizure counts in a randomized trial of anti-convulsant +#' therapy in epilepsy. Covariates are treatment, +#' 8-week baseline seizure counts, and age of the patients in years. +#' +#' @format A data frame of 236 observations containing information +#' on the following 9 variables. +#' \describe{ +#' \item{Age}{The age of the patients in years} +#' \item{Base}{The seizure count at 8-weeks baseline} +#' \item{Trt}{Either \code{0} or \code{1} indicating +#' if the patient received anti-convulsant therapy} +#' \item{patient}{The patient number} +#' \item{visit}{The session number from \code{1} (first visit) +#' to \code{4} (last visit)} +#' \item{count}{The seizure count between two visits} +#' \item{obs}{The observation number, that is +#' a unique identifier for each observation} +#' \item{zAge}{Standardized \code{Age}} +#' \item{zBase}{Standardized \code{Base}} +#' } +#' +#' @source Thall, P. F., & Vail, S. C. (1990). +#' Some covariance models for longitudinal count data with overdispersion. +#' \emph{Biometrics, 46(2)}, 657-671. \cr +#' +#' Breslow, N. E., & Clayton, D. G. (1993). +#' Approximate inference in generalized linear mixed models. +#' \emph{Journal of the American Statistical Association}, 88(421), 9-25. +#' +#' @examples +#' \dontrun{ +#' ## poisson regression without random effects. +#' fit1 <- brm(count ~ zAge + zBase * Trt, +#' data = epilepsy, family = poisson()) +#' summary(fit1) +#' plot(fit1) +#' +#' ## poisson regression with varying intercepts of patients +#' ## as well as normal priors for overall effects parameters. +#' fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient), +#' data = epilepsy, family = poisson(), +#' prior = set_prior("normal(0,5)")) +#' summary(fit2) +#' plot(fit2) +#' } +#' +"epilepsy" + +#' Cumulative Insurance Loss Payments +#' +#' @description This dataset, discussed in Gesmann & Morris (2020), contains +#' cumulative insurance loss payments over the course of ten years. +#' +#' @format A data frame of 55 observations containing information +#' on the following 4 variables. +#' \describe{ +#' \item{AY}{Origin year of the insurance (1991 to 2000)} +#' \item{dev}{Deviation from the origin year in months} +#' \item{cum}{Cumulative loss payments} +#' \item{premium}{Achieved premiums for the given origin year} +#' } +#' +#' @source Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving +#' Models. \emph{CAS Research Papers}. +#' +#' @examples +#' \dontrun{ +#' # non-linear model to predict cumulative loss payments +#' fit_loss <- brm( +#' bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), +#' ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, +#' nl = TRUE), +#' data = loss, family = gaussian(), +#' prior = c( +#' prior(normal(5000, 1000), nlpar = "ult"), +#' prior(normal(1, 2), nlpar = "omega"), +#' prior(normal(45, 10), nlpar = "theta") +#' ), +#' control = list(adapt_delta = 0.9) +#' ) +#' +#' # basic summaries +#' summary(fit_loss) +#' conditional_effects(fit_loss) +#' +#' # plot predictions per origin year +#' conditions <- data.frame(AY = unique(loss$AY)) +#' rownames(conditions) <- unique(loss$AY) +#' me_loss <- conditional_effects( +#' fit_loss, conditions = conditions, +#' re_formula = NULL, method = "predict" +#' ) +#' plot(me_loss, ncol = 5, points = TRUE) +#' } +#' +"loss" diff -Nru r-cran-brms-2.16.3/R/diagnostics.R r-cran-brms-2.17.0/R/diagnostics.R --- r-cran-brms-2.16.3/R/diagnostics.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/diagnostics.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,101 +1,101 @@ -#' Extract Diagnostic Quantities of \pkg{brms} Models -#' -#' Extract quantities that can be used to diagnose sampling behavior -#' of the algorithms applied by \pkg{Stan} at the back-end of \pkg{brms}. -#' -#' @name diagnostic-quantities -#' @aliases log_posterior nuts_params rhat neff_ratio -#' -#' @param object A \code{brmsfit} object. -#' @param pars An optional character vector of parameter names. -#' For \code{nuts_params} these will be NUTS sampler parameter -#' names rather than model parameters. If pars is omitted -#' all parameters are included. -#' @param ... Arguments passed to individual methods. -#' -#' @return The exact form of the output depends on the method. -#' -#' @details For more details see -#' \code{\link[bayesplot:bayesplot-extractors]{bayesplot-extractors}}. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(time ~ age * sex, data = kidney) -#' -#' lp <- log_posterior(fit) -#' head(lp) -#' -#' np <- nuts_params(fit) -#' str(np) -#' # extract the number of divergence transitions -#' sum(subset(np, Parameter == "divergent__")$Value) -#' -#' head(rhat(fit)) -#' head(neff_ratio(fit)) -#' } -NULL - -#' @rdname diagnostic-quantities -#' @importFrom bayesplot log_posterior -#' @export log_posterior -#' @export -log_posterior.brmsfit <- function(object, ...) { - contains_draws(object) - bayesplot::log_posterior(object$fit, ...) -} - -#' @rdname diagnostic-quantities -#' @importFrom bayesplot nuts_params -#' @export nuts_params -#' @export -nuts_params.brmsfit <- function(object, pars = NULL, ...) { - contains_draws(object) - bayesplot::nuts_params(object$fit, pars = pars, ...) -} - -#' @rdname diagnostic-quantities -#' @importFrom bayesplot rhat -#' @export rhat -#' @export -rhat.brmsfit <- function(object, pars = NULL, ...) { - contains_draws(object) - bayesplot::rhat(object$fit, pars = pars, ...) -} - -#' @rdname diagnostic-quantities -#' @importFrom bayesplot neff_ratio -#' @export neff_ratio -#' @export -neff_ratio.brmsfit <- function(object, pars = NULL, ...) { - contains_draws(object) - bayesplot::neff_ratio(object$fit, pars = pars, ...) -} - -#' Extract Control Parameters of the NUTS Sampler -#' -#' Extract control parameters of the NUTS sampler such as -#' \code{adapt_delta} or \code{max_treedepth}. -#' -#' @param x An \R object -#' @param pars Optional names of the control parameters to be returned. -#' If \code{NULL} (the default) all control parameters are returned. -#' See \code{\link[rstan:stan]{stan}} for more details. -#' @param ... Currently ignored. -#' -#' @return A named \code{list} with control parameter values. -#' -#' @export -control_params <- function(x, ...) { - UseMethod("control_params") -} - -#' @rdname control_params -#' @export -control_params.brmsfit <- function(x, pars = NULL, ...) { - contains_draws(x) - out <- attr(x$fit@sim$samples[[1]], "args")$control - if (!is.null(pars)) { - out <- out[pars] - } - out -} +#' Extract Diagnostic Quantities of \pkg{brms} Models +#' +#' Extract quantities that can be used to diagnose sampling behavior +#' of the algorithms applied by \pkg{Stan} at the back-end of \pkg{brms}. +#' +#' @name diagnostic-quantities +#' @aliases log_posterior nuts_params rhat neff_ratio +#' +#' @param object A \code{brmsfit} object. +#' @param pars An optional character vector of parameter names. +#' For \code{nuts_params} these will be NUTS sampler parameter +#' names rather than model parameters. If pars is omitted +#' all parameters are included. +#' @param ... Arguments passed to individual methods. +#' +#' @return The exact form of the output depends on the method. +#' +#' @details For more details see +#' \code{\link[bayesplot:bayesplot-extractors]{bayesplot-extractors}}. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(time ~ age * sex, data = kidney) +#' +#' lp <- log_posterior(fit) +#' head(lp) +#' +#' np <- nuts_params(fit) +#' str(np) +#' # extract the number of divergence transitions +#' sum(subset(np, Parameter == "divergent__")$Value) +#' +#' head(rhat(fit)) +#' head(neff_ratio(fit)) +#' } +NULL + +#' @rdname diagnostic-quantities +#' @importFrom bayesplot log_posterior +#' @export log_posterior +#' @export +log_posterior.brmsfit <- function(object, ...) { + contains_draws(object) + bayesplot::log_posterior(object$fit, ...) +} + +#' @rdname diagnostic-quantities +#' @importFrom bayesplot nuts_params +#' @export nuts_params +#' @export +nuts_params.brmsfit <- function(object, pars = NULL, ...) { + contains_draws(object) + bayesplot::nuts_params(object$fit, pars = pars, ...) +} + +#' @rdname diagnostic-quantities +#' @importFrom bayesplot rhat +#' @export rhat +#' @export +rhat.brmsfit <- function(object, pars = NULL, ...) { + contains_draws(object) + bayesplot::rhat(object$fit, pars = pars, ...) +} + +#' @rdname diagnostic-quantities +#' @importFrom bayesplot neff_ratio +#' @export neff_ratio +#' @export +neff_ratio.brmsfit <- function(object, pars = NULL, ...) { + contains_draws(object) + bayesplot::neff_ratio(object$fit, pars = pars, ...) +} + +#' Extract Control Parameters of the NUTS Sampler +#' +#' Extract control parameters of the NUTS sampler such as +#' \code{adapt_delta} or \code{max_treedepth}. +#' +#' @param x An \R object +#' @param pars Optional names of the control parameters to be returned. +#' If \code{NULL} (the default) all control parameters are returned. +#' See \code{\link[rstan:stan]{stan}} for more details. +#' @param ... Currently ignored. +#' +#' @return A named \code{list} with control parameter values. +#' +#' @export +control_params <- function(x, ...) { + UseMethod("control_params") +} + +#' @rdname control_params +#' @export +control_params.brmsfit <- function(x, pars = NULL, ...) { + contains_draws(x) + out <- attr(x$fit@sim$samples[[1]], "args")$control + if (!is.null(pars)) { + out <- out[pars] + } + out +} diff -Nru r-cran-brms-2.16.3/R/distributions.R r-cran-brms-2.17.0/R/distributions.R --- r-cran-brms-2.16.3/R/distributions.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/distributions.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,2458 +1,2557 @@ -#' The Student-t Distribution -#' -#' Density, distribution function, quantile function and random generation -#' for the Student-t distribution with location \code{mu}, scale \code{sigma}, -#' and degrees of freedom \code{df}. -#' -#' @name StudentT -#' -#' @param x,q Vector of quantiles. -#' @param p Vector of probabilities. -#' @param n Number of draws to sample from the distribution. -#' @param mu Vector of location values. -#' @param sigma Vector of scale values. -#' @param df Vector of degrees of freedom. -#' @param log,log.p Logical; If \code{TRUE}, values are returned on the log scale. -#' @param lower.tail Logical; If \code{TRUE} (default), return P(X <= x). -#' Else, return P(X > x) . -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @seealso \code{\link[stats:TDist]{TDist}} -#' -#' @export -dstudent_t <- function(x, df, mu = 0, sigma = 1, log = FALSE) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - if (log) { - dt((x - mu) / sigma, df = df, log = TRUE) - log(sigma) - } else { - dt((x - mu) / sigma, df = df) / sigma - } -} - -#' @rdname StudentT -#' @export -pstudent_t <- function(q, df, mu = 0, sigma = 1, - lower.tail = TRUE, log.p = FALSE) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - pt((q - mu) / sigma, df = df, lower.tail = lower.tail, log.p = log.p) -} - -#' @rdname StudentT -#' @export -qstudent_t <- function(p, df, mu = 0, sigma = 1) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - mu + sigma * qt(p, df = df) -} - -#' @rdname StudentT -#' @export -rstudent_t <- function(n, df, mu = 0, sigma = 1) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - mu + sigma * rt(n, df = df) -} - -#' The Multivariate Normal Distribution -#' -#' Density function and random generation for the multivariate normal -#' distribution with mean vector \code{mu} and covariance matrix \code{Sigma}. -#' -#' @name MultiNormal -#' -#' @inheritParams StudentT -#' @param x Vector or matrix of quantiles. If \code{x} is a matrix, -#' each row is taken to be a quantile. -#' @param mu Mean vector with length equal to the number of dimensions. -#' @param Sigma Covariance matrix. -#' @param check Logical; Indicates whether several input checks -#' should be performed. Defaults to \code{FALSE} to improve -#' efficiency. -#' -#' @details See the Stan user's manual \url{https://mc-stan.org/documentation/} -#' for details on the parameterization -#' -#' @export -dmulti_normal <- function(x, mu, Sigma, log = FALSE, check = FALSE) { - if (is.vector(x) || length(dim(x)) == 1L) { - x <- matrix(x, ncol = length(x)) - } - p <- ncol(x) - if (check) { - if (length(mu) != p) { - stop2("Dimension of mu is incorrect.") - } - if (!all(dim(Sigma) == c(p, p))) { - stop2("Dimension of Sigma is incorrect.") - } - if (!is_symmetric(Sigma)) { - stop2("Sigma must be a symmetric matrix.") - } - } - chol_Sigma <- chol(Sigma) - rooti <- backsolve(chol_Sigma, t(x) - mu, transpose = TRUE) - quads <- colSums(rooti^2) - out <- -(p / 2) * log(2 * pi) - sum(log(diag(chol_Sigma))) - .5 * quads - if (!log) { - out <- exp(out) - } - out -} - -#' @rdname MultiNormal -#' @export -rmulti_normal <- function(n, mu, Sigma, check = FALSE) { - p <- length(mu) - if (check) { - if (!(is_wholenumber(n) && n > 0)) { - stop2("n must be a positive integer.") - } - if (!all(dim(Sigma) == c(p, p))) { - stop2("Dimension of Sigma is incorrect.") - } - if (!is_symmetric(Sigma)) { - stop2("Sigma must be a symmetric matrix.") - } - } - draws <- matrix(rnorm(n * p), nrow = n, ncol = p) - mu + draws %*% chol(Sigma) -} - -#' The Multivariate Student-t Distribution -#' -#' Density function and random generation for the multivariate Student-t -#' distribution with location vector \code{mu}, covariance matrix \code{Sigma}, -#' and degrees of freedom \code{df}. -#' -#' @name MultiStudentT -#' -#' @inheritParams StudentT -#' @param x Vector or matrix of quantiles. If \code{x} is a matrix, -#' each row is taken to be a quantile. -#' @param mu Location vector with length equal to the number of dimensions. -#' @param Sigma Covariance matrix. -#' @param check Logical; Indicates whether several input checks -#' should be performed. Defaults to \code{FALSE} to improve -#' efficiency. -#' -#' @details See the Stan user's manual \url{https://mc-stan.org/documentation/} -#' for details on the parameterization -#' -#' @export -dmulti_student_t <- function(x, df, mu, Sigma, log = FALSE, check = FALSE) { - if (is.vector(x) || length(dim(x)) == 1L) { - x <- matrix(x, ncol = length(x)) - } - p <- ncol(x) - if (check) { - if (isTRUE(any(df <= 0))) { - stop2("df must be greater than 0.") - } - if (length(mu) != p) { - stop2("Dimension of mu is incorrect.") - } - if (!all(dim(Sigma) == c(p, p))) { - stop2("Dimension of Sigma is incorrect.") - } - if (!is_symmetric(Sigma)) { - stop2("Sigma must be a symmetric matrix.") - } - } - chol_Sigma <- chol(Sigma) - rooti <- backsolve(chol_Sigma, t(x) - mu, transpose = TRUE) - quads <- colSums(rooti^2) - out <- lgamma((p + df)/2) - (lgamma(df / 2) + sum(log(diag(chol_Sigma))) + - p / 2 * log(pi * df)) - 0.5 * (df + p) * log1p(quads / df) - if (!log) { - out <- exp(out) - } - out -} - -#' @rdname MultiStudentT -#' @export -rmulti_student_t <- function(n, df, mu, Sigma, check = FALSE) { - p <- length(mu) - if (isTRUE(any(df <= 0))) { - stop2("df must be greater than 0.") - } - draws <- rmulti_normal(n, mu = rep(0, p), Sigma = Sigma, check = check) - draws <- draws / sqrt(rchisq(n, df = df) / df) - sweep(draws, 2, mu, "+") -} - -#' The Skew-Normal Distribution -#' -#' Density, distribution function, and random generation for the -#' skew-normal distribution with mean \code{mu}, -#' standard deviation \code{sigma}, and skewness \code{alpha}. -#' -#' @name SkewNormal -#' -#' @inheritParams StudentT -#' @param x,q Vector of quantiles. -#' @param mu Vector of mean values. -#' @param sigma Vector of standard deviation values. -#' @param alpha Vector of skewness values. -#' @param xi Optional vector of location values. -#' If \code{NULL} (the default), will be computed internally. -#' @param omega Optional vector of scale values. -#' If \code{NULL} (the default), will be computed internally. -#' @param tol Tolerance of the approximation used in the -#' computation of quantiles. -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @export -dskew_normal <- function(x, mu = 0, sigma = 1, alpha = 0, - xi = NULL, omega = NULL, log = FALSE) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be greater than 0.") - } - args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, x = x) - out <- with(args, { - # do it like sn::dsn - z <- (x - xi) / omega - if (length(alpha) == 1L) { - alpha <- rep(alpha, length(z)) - } - logN <- -log(sqrt(2 * pi)) - log(omega) - z^2 / 2 - logS <- ifelse( - abs(alpha) < Inf, - pnorm(alpha * z, log.p = TRUE), - log(as.numeric(sign(alpha) * z > 0)) - ) - out <- logN + logS - pnorm(0, log.p = TRUE) - ifelse(abs(z) == Inf, -Inf, out) - }) - if (!log) { - out <- exp(out) - } - out -} - -#' @rdname SkewNormal -#' @export -pskew_normal <- function(q, mu = 0, sigma = 1, alpha = 0, - xi = NULL, omega = NULL, - lower.tail = TRUE, log.p = FALSE) { - require_package("mnormt") - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, q = q) - out <- with(args, { - # do it like sn::psn - z <- (q - xi) / omega - nz <- length(z) - is_alpha_inf <- abs(alpha) == Inf - delta[is_alpha_inf] <- sign(alpha[is_alpha_inf]) - out <- numeric(nz) - for (k in seq_len(nz)) { - if (is_alpha_inf[k]) { - if (alpha[k] > 0) { - out[k] <- 2 * (pnorm(pmax(z[k], 0)) - 0.5) - } else { - out[k] <- 1 - 2 * (0.5 - pnorm(pmin(z[k], 0))) - } - } else { - S <- matrix(c(1, -delta[k], -delta[k], 1), 2, 2) - out[k] <- 2 * mnormt::biv.nt.prob( - 0, lower = rep(-Inf, 2), upper = c(z[k], 0), - mean = c(0, 0), S = S - ) - } - } - pmin(1, pmax(0, out)) - }) - if (!lower.tail) { - out <- 1 - out - } - if (log.p) { - out <- log(out) - } - out -} - -#' @rdname SkewNormal -#' @export -qskew_normal <- function(p, mu = 0, sigma = 1, alpha = 0, - xi = NULL, omega = NULL, - lower.tail = TRUE, log.p = FALSE, - tol = 1e-8) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - if (log.p) { - p <- exp(p) - } - if (!lower.tail) { - p <- 1 - p - } - args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, p = p) - out <- with(args, { - # do it like sn::qsn - na <- is.na(p) | (p < 0) | (p > 1) - zero <- (p == 0) - one <- (p == 1) - p <- replace(p, (na | zero | one), 0.5) - cum <- skew_normal_cumulants(0, 1, alpha, n = 4) - g1 <- cum[, 3] / cum[, 2]^(3 / 2) - g2 <- cum[, 4] / cum[, 2]^2 - x <- qnorm(p) - x <- x + (x^2 - 1) * g1 / 6 + - x * (x^2 - 3) * g2 / 24 - - x * (2 * x^2 - 5) * g1^2 / 36 - x <- cum[, 1] + sqrt(cum[, 2]) * x - px <- pskew_normal(x, xi = 0, omega = 1, alpha = alpha) - max_err <- 1 - while (max_err > tol) { - x1 <- x - (px - p) / - dskew_normal(x, xi = 0, omega = 1, alpha = alpha) - x <- x1 - px <- pskew_normal(x, xi = 0, omega = 1, alpha = alpha) - max_err <- max(abs(px - p)) - if (is.na(max_err)) { - warning2("Approximation in 'qskew_normal' might have failed.") - } - } - x <- replace(x, na, NA) - x <- replace(x, zero, -Inf) - x <- replace(x, one, Inf) - as.numeric(xi + omega * x) - }) - out -} - -#' @rdname SkewNormal -#' @export -rskew_normal <- function(n, mu = 0, sigma = 1, alpha = 0, - xi = NULL, omega = NULL) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega) - with(args, { - # do it like sn::rsn - z1 <- rnorm(n) - z2 <- rnorm(n) - id <- z2 > args$alpha * z1 - z1[id] <- -z1[id] - xi + omega * z1 - }) -} - -# convert skew-normal mixed-CP to DP parameterization -# @return a data.frame containing all relevant parameters -cp2dp <- function(mu = 0, sigma = 1, alpha = 0, - xi = NULL, omega = NULL, ...) { - delta <- alpha / sqrt(1 + alpha^2) - if (is.null(omega)) { - omega <- sigma / sqrt(1 - 2 / pi * delta^2) - } - if (is.null(xi)) { - xi <- mu - omega * delta * sqrt(2 / pi) - } - expand(dots = nlist(mu, sigma, alpha, xi, omega, delta, ...)) -} - -# helper function for qskew_normal -# code basis taken from sn::sn.cumulants -# uses xi and omega rather than mu and sigma -skew_normal_cumulants <- function(xi = 0, omega = 1, alpha = 0, n = 4) { - cumulants_half_norm <- function(n) { - n <- max(n, 2) - n <- as.integer(2 * ceiling(n/2)) - half.n <- as.integer(n/2) - m <- 0:(half.n - 1) - a <- sqrt(2/pi)/(gamma(m + 1) * 2^m * (2 * m + 1)) - signs <- rep(c(1, -1), half.n)[seq_len(half.n)] - a <- as.vector(rbind(signs * a, rep(0, half.n))) - coeff <- rep(a[1], n) - for (k in 2:n) { - ind <- seq_len(k - 1) - coeff[k] <- a[k] - sum(ind * coeff[ind] * a[rev(ind)]/k) - } - kappa <- coeff * gamma(seq_len(n) + 1) - kappa[2] <- 1 + kappa[2] - return(kappa) - } - - args <- expand(dots = nlist(xi, omega, alpha)) - with(args, { - # do it like sn::sn.cumulants - delta <- alpha / sqrt(1 + alpha^2) - kv <- cumulants_half_norm(n) - if (length(kv) > n) { - kv <- kv[-(n + 1)] - } - kv[2] <- kv[2] - 1 - kappa <- outer(delta, 1:n, "^") * - matrix(rep(kv, length(xi)), ncol = n, byrow = TRUE) - kappa[, 2] <- kappa[, 2] + 1 - kappa <- kappa * outer(omega, 1:n, "^") - kappa[, 1] <- kappa[, 1] + xi - kappa - }) -} - -# CDF of the inverse gamma function -pinvgamma <- function(q, shape, rate, lower.tail = TRUE, log.p = FALSE) { - pgamma(1/q, shape, rate = rate, lower.tail = !lower.tail, log.p = log.p) -} - -#' The von Mises Distribution -#' -#' Density, distribution function, and random generation for the -#' von Mises distribution with location \code{mu}, and precision \code{kappa}. -#' -#' @name VonMises -#' -#' @inheritParams StudentT -#' @param x,q Vector of quantiles. -#' @param kappa Vector of precision values. -#' @param acc Accuracy of numerical approximations. -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @export -dvon_mises <- function(x, mu, kappa, log = FALSE) { - if (isTRUE(any(kappa < 0))) { - stop2("kappa must be non-negative") - } - # expects x in [-pi, pi] rather than [0, 2*pi] as CircStats::dvm - be <- besselI(kappa, nu = 0, expon.scaled = TRUE) - out <- -log(2 * pi * be) + kappa * (cos(x - mu) - 1) - if (!log) { - out <- exp(out) - } - out -} - -#' @rdname VonMises -#' @export -pvon_mises <- function(q, mu, kappa, lower.tail = TRUE, - log.p = FALSE, acc = 1e-20) { - if (isTRUE(any(kappa < 0))) { - stop2("kappa must be non-negative") - } - pi <- base::pi - pi2 <- 2 * pi - q <- (q + pi) %% pi2 - mu <- (mu + pi) %% pi2 - args <- expand(q = q, mu = mu, kappa = kappa) - q <- args$q - mu <- args$mu - kappa <- args$kappa - rm(args) - - # code basis taken from CircStats::pvm but improved - # considerably with respect to speed and stability - rec_sum <- function(q, kappa, acc, sum = 0, i = 1) { - # compute the sum of of besselI functions recursively - term <- (besselI(kappa, nu = i) * sin(i * q)) / i - sum <- sum + term - rd <- abs(term) >= acc - if (sum(rd)) { - sum[rd] <- rec_sum( - q[rd], kappa[rd], acc, sum = sum[rd], i = i + 1 - ) - } - sum - } - - .pvon_mises <- function(q, kappa, acc) { - sum <- rec_sum(q, kappa, acc) - q / pi2 + sum / (pi * besselI(kappa, nu = 0)) - } - - out <- rep(NA, length(mu)) - zero_mu <- mu == 0 - if (sum(zero_mu)) { - out[zero_mu] <- .pvon_mises(q[zero_mu], kappa[zero_mu], acc) - } - lq_mu <- q <= mu - if (sum(lq_mu)) { - upper <- (q[lq_mu] - mu[lq_mu]) %% pi2 - upper[upper == 0] <- pi2 - lower <- (-mu[lq_mu]) %% pi2 - out[lq_mu] <- - .pvon_mises(upper, kappa[lq_mu], acc) - - .pvon_mises(lower, kappa[lq_mu], acc) - } - uq_mu <- q > mu - if (sum(uq_mu)) { - upper <- q[uq_mu] - mu[uq_mu] - lower <- mu[uq_mu] %% pi2 - out[uq_mu] <- - .pvon_mises(upper, kappa[uq_mu], acc) + - .pvon_mises(lower, kappa[uq_mu], acc) - } - if (!lower.tail) { - out <- 1 - out - } - if (log.p) { - out <- log(out) - } - out -} - -#' @rdname VonMises -#' @export -rvon_mises <- function(n, mu, kappa) { - if (isTRUE(any(kappa < 0))) { - stop2("kappa must be non-negative") - } - args <- expand(mu = mu, kappa = kappa, length = n) - mu <- args$mu - kappa <- args$kappa - rm(args) - pi <- base::pi - mu <- mu + pi - - # code basis taken from CircStats::rvm but improved - # considerably with respect to speed and stability - rvon_mises_outer <- function(r, mu, kappa) { - n <- length(r) - U1 <- runif(n, 0, 1) - z <- cos(pi * U1) - f <- (1 + r * z) / (r + z) - c <- kappa * (r - f) - U2 <- runif(n, 0, 1) - outer <- is.na(f) | is.infinite(f) | - !(c * (2 - c) - U2 > 0 | log(c / U2) + 1 - c >= 0) - inner <- !outer - out <- rep(NA, n) - if (sum(inner)) { - out[inner] <- rvon_mises_inner(f[inner], mu[inner]) - } - if (sum(outer)) { - # evaluate recursively until a valid sample is found - out[outer] <- rvon_mises_outer(r[outer], mu[outer], kappa[outer]) - } - out - } - - rvon_mises_inner <- function(f, mu) { - n <- length(f) - U3 <- runif(n, 0, 1) - (sign(U3 - 0.5) * acos(f) + mu) %% (2 * pi) - } - - a <- 1 + (1 + 4 * (kappa^2))^0.5 - b <- (a - (2 * a)^0.5) / (2 * kappa) - r <- (1 + b^2) / (2 * b) - # indicates underflow due to kappa being close to zero - is_uf <- is.na(r) | is.infinite(r) - not_uf <- !is_uf - out <- rep(NA, n) - if (sum(is_uf)) { - out[is_uf] <- runif(sum(is_uf), 0, 2 * pi) - } - if (sum(not_uf)) { - out[not_uf] <- rvon_mises_outer(r[not_uf], mu[not_uf], kappa[not_uf]) - } - out - pi -} - -#' The Exponentially Modified Gaussian Distribution -#' -#' Density, distribution function, and random generation -#' for the exponentially modified Gaussian distribution with -#' mean \code{mu} and standard deviation \code{sigma} of the gaussian -#' component, as well as scale \code{beta} of the exponential -#' component. -#' -#' @name ExGaussian -#' -#' @inheritParams StudentT -#' @param x,q Vector of quantiles. -#' @param mu Vector of means of the combined distribution. -#' @param sigma Vector of standard deviations of the gaussian component. -#' @param beta Vector of scales of the exponential component. -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @export -dexgaussian <- function(x, mu, sigma, beta, log = FALSE) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - if (isTRUE(any(beta < 0))) { - stop2("beta must be non-negative.") - } - args <- nlist(x, mu, sigma, beta) - args <- do_call(expand, args) - args$mu <- with(args, mu - beta) - args$z <- with(args, x - mu - sigma^2 / beta) - - out <- with(args, - -log(beta) - (z + sigma^2 / (2 * beta)) / beta + - pnorm(z / sigma, log.p = TRUE) - ) - if (!log) { - out <- exp(out) - } - out -} - -#' @rdname ExGaussian -#' @export -pexgaussian <- function(q, mu, sigma, beta, - lower.tail = TRUE, log.p = FALSE) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - if (isTRUE(any(beta < 0))) { - stop2("beta must be non-negative.") - } - args <- nlist(q, mu, sigma, beta) - args <- do_call(expand, args) - args$mu <- with(args, mu - beta) - args$z <- with(args, q - mu - sigma^2 / beta) - - out <- with(args, - pnorm((q - mu) / sigma) - pnorm(z / sigma) * - exp(((mu + sigma^2 / beta)^2 - mu^2 - 2 * q * sigma^2 / beta) / - (2 * sigma^2)) - ) - if (!lower.tail) { - out <- 1 - out - } - if (log.p) { - out <- log(out) - } - out -} - -#' @rdname ExGaussian -#' @export -rexgaussian <- function(n, mu, sigma, beta) { - if (isTRUE(any(sigma < 0))) { - stop2("sigma must be non-negative.") - } - if (isTRUE(any(beta < 0))) { - stop2("beta must be non-negative.") - } - mu <- mu - beta - rnorm(n, mean = mu, sd = sigma) + rexp(n, rate = 1 / beta) -} - -#' The Frechet Distribution -#' -#' Density, distribution function, quantile function and random generation -#' for the Frechet distribution with location \code{loc}, scale \code{scale}, -#' and shape \code{shape}. -#' -#' @name Frechet -#' -#' @inheritParams StudentT -#' @param x,q Vector of quantiles. -#' @param loc Vector of locations. -#' @param scale Vector of scales. -#' @param shape Vector of shapes. -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @export -dfrechet <- function(x, loc = 0, scale = 1, shape = 1, log = FALSE) { - if (isTRUE(any(scale <= 0))) { - stop2("Argument 'scale' must be positive.") - } - if (isTRUE(any(shape <= 0))) { - stop2("Argument 'shape' must be positive.") - } - x <- (x - loc) / scale - args <- nlist(x, loc, scale, shape) - args <- do_call(expand, args) - out <- with(args, - log(shape / scale) - (1 + shape) * log(x) - x^(-shape) - ) - if (!log) { - out <- exp(out) - } - out -} - -#' @rdname Frechet -#' @export -pfrechet <- function(q, loc = 0, scale = 1, shape = 1, - lower.tail = TRUE, log.p = FALSE) { - if (isTRUE(any(scale <= 0))) { - stop2("Argument 'scale' must be positive.") - } - if (isTRUE(any(shape <= 0))) { - stop2("Argument 'shape' must be positive.") - } - q <- pmax((q - loc) / scale, 0) - out <- exp(-q^(-shape)) - if (!lower.tail) { - out <- 1 - out - } - if (log.p) { - out <- log(out) - } - out -} - -#' @rdname Frechet -#' @export -qfrechet <- function(p, loc = 0, scale = 1, shape = 1, - lower.tail = TRUE, log.p = FALSE) { - if (isTRUE(any(p <= 0)) || isTRUE(any(p >= 1))) { - stop("'p' must contain probabilities in (0,1)") - } - if (isTRUE(any(scale <= 0))) { - stop2("Argument 'scale' must be positive.") - } - if (isTRUE(any(shape <= 0))) { - stop2("Argument 'shape' must be positive.") - } - if (log.p) { - p <- exp(p) - } - if (!lower.tail) { - p <- 1 - p - } - loc + scale * (-log(p))^(-1/shape) -} - -#' @rdname Frechet -#' @export -rfrechet <- function(n, loc = 0, scale = 1, shape = 1) { - if (isTRUE(any(scale <= 0))) { - stop2("Argument 'scale' must be positive.") - } - if (isTRUE(any(shape <= 0))) { - stop2("Argument 'shape' must be positive.") - } - loc + scale * rexp(n)^(-1 / shape) -} - -#' The Shifted Log Normal Distribution -#' -#' Density, distribution function, quantile function and random generation -#' for the shifted log normal distribution with mean \code{meanlog}, -#' standard deviation \code{sdlog}, and shift parameter \code{shift}. -#' -#' @name Shifted_Lognormal -#' -#' @inheritParams StudentT -#' @param x,q Vector of quantiles. -#' @param meanlog Vector of means. -#' @param sdlog Vector of standard deviations. -#' @param shift Vector of shifts. -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @export -dshifted_lnorm <- function(x, meanlog = 0, sdlog = 1, shift = 0, log = FALSE) { - args <- nlist(dist = "lnorm", x, shift, meanlog, sdlog, log) - do_call(dshifted, args) -} - -#' @rdname Shifted_Lognormal -#' @export -pshifted_lnorm <- function(q, meanlog = 0, sdlog = 1, shift = 0, - lower.tail = TRUE, log.p = FALSE) { - args <- nlist(dist = "lnorm", q, shift, meanlog, sdlog, lower.tail, log.p) - do_call(pshifted, args) -} - -#' @rdname Shifted_Lognormal -#' @export -qshifted_lnorm <- function(p, meanlog = 0, sdlog = 1, shift = 0, - lower.tail = TRUE, log.p = FALSE) { - args <- nlist(dist = "lnorm", p, shift, meanlog, sdlog, lower.tail, log.p) - do_call(qshifted, args) -} - -#' @rdname Shifted_Lognormal -#' @export -rshifted_lnorm <- function(n, meanlog = 0, sdlog = 1, shift = 0) { - args <- nlist(dist = "lnorm", n, shift, meanlog, sdlog) - do_call(rshifted, args) -} - -#' The Inverse Gaussian Distribution -#' -#' Density, distribution function, and random generation -#' for the inverse Gaussian distribution with location \code{mu}, -#' and shape \code{shape}. -#' -#' @name InvGaussian -#' -#' @inheritParams StudentT -#' @param x,q Vector of quantiles. -#' @param mu Vector of locations. -#' @param shape Vector of shapes. -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @export -dinv_gaussian <- function(x, mu = 1, shape = 1, log = FALSE) { - if (isTRUE(any(mu <= 0))) { - stop2("Argument 'mu' must be positive.") - } - if (isTRUE(any(shape <= 0))) { - stop2("Argument 'shape' must be positive.") - } - args <- nlist(x, mu, shape) - args <- do_call(expand, args) - out <- with(args, - 0.5 * log(shape / (2 * pi)) - - 1.5 * log(x) - 0.5 * shape * (x - mu)^2 / (x * mu^2) - ) - if (!log) { - out <- exp(out) - } - out -} - -#' @rdname InvGaussian -#' @export -pinv_gaussian <- function(q, mu = 1, shape = 1, lower.tail = TRUE, - log.p = FALSE) { - if (isTRUE(any(mu <= 0))) { - stop2("Argument 'mu' must be positive.") - } - if (isTRUE(any(shape <= 0))) { - stop2("Argument 'shape' must be positive.") - } - args <- nlist(q, mu, shape) - args <- do_call(expand, args) - out <- with(args, - pnorm(sqrt(shape / q) * (q / mu - 1)) + - exp(2 * shape / mu) * pnorm(-sqrt(shape / q) * (q / mu + 1)) - ) - if (!lower.tail) { - out <- 1 - out - } - if (log.p) { - out <- log(out) - } - out -} - -#' @rdname InvGaussian -#' @export -rinv_gaussian <- function(n, mu = 1, shape = 1) { - # create random numbers for the inverse gaussian distribution - # Args: - # Args: see dinv_gaussian - if (isTRUE(any(mu <= 0))) { - stop2("Argument 'mu' must be positive.") - } - if (isTRUE(any(shape <= 0))) { - stop2("Argument 'shape' must be positive.") - } - args <- nlist(mu, shape, length = n) - args <- do_call(expand, args) - # algorithm from wikipedia - args$y <- rnorm(n)^2 - args$x <- with(args, - mu + (mu^2 * y) / (2 * shape) - mu / (2 * shape) * - sqrt(4 * mu * shape * y + mu^2 * y^2) - ) - args$z <- runif(n) - with(args, ifelse(z <= mu / (mu + x), x, mu^2 / x)) -} - -#' The Generalized Extreme Value Distribution -#' -#' Density, distribution function, and random generation -#' for the generalized extreme value distribution with -#' location \code{mu}, scale \code{sigma} and shape \code{xi}. -#' -#' @name GenExtremeValue -#' -#' @inheritParams StudentT -#' @param x,q Vector of quantiles. -#' @param mu Vector of locations. -#' @param sigma Vector of scales. -#' @param xi Vector of shapes. -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @export -dgen_extreme_value <- function(x, mu = 0, sigma = 1, xi = 0, log = FALSE) { - if (isTRUE(any(sigma <= 0))) { - stop2("sigma bust be positive.") - } - x <- (x - mu) / sigma - args <- nlist(x, mu, sigma, xi) - args <- do_call(expand, args) - args$t <- with(args, 1 + xi * x) - out <- with(args, ifelse( - xi == 0, - -log(sigma) - x - exp(-x), - -log(sigma) - (1 + 1 / xi) * log(t) - t^(-1 / xi) - )) - if (!log) { - out <- exp(out) - } - out -} - -#' @rdname GenExtremeValue -#' @export -pgen_extreme_value <- function(q, mu = 0, sigma = 1, xi = 0, - lower.tail = TRUE, log.p = FALSE) { - if (isTRUE(any(sigma <= 0))) { - stop2("sigma bust be positive.") - } - q <- (q - mu) / sigma - args <- nlist(q, mu, sigma, xi) - args <- do_call(expand, args) - out <- with(args, ifelse( - xi == 0, - exp(-exp(-q)), - exp(-(1 + xi * q)^(-1 / xi)) - )) - if (!lower.tail) { - out <- 1 - out - } - if (log.p) { - out <- log(out) - } - out -} - -#' @rdname GenExtremeValue -#' @export -rgen_extreme_value <- function(n, mu = 0, sigma = 1, xi = 0) { - if (isTRUE(any(sigma <= 0))) { - stop2("sigma bust be positive.") - } - args <- nlist(mu, sigma, xi, length = n) - args <- do_call(expand, args) - with(args, ifelse( - xi == 0, - mu - sigma * log(rexp(n)), - mu + sigma * (rexp(n)^(-xi) - 1) / xi - )) -} - -#' The Asymmetric Laplace Distribution -#' -#' Density, distribution function, quantile function and random generation -#' for the asymmetric Laplace distribution with location \code{mu}, -#' scale \code{sigma} and asymmetry parameter \code{quantile}. -#' -#' @name AsymLaplace -#' -#' @inheritParams StudentT -#' @param x,q Vector of quantiles. -#' @param mu Vector of locations. -#' @param sigma Vector of scales. -#' @param quantile Asymmetry parameter corresponding to quantiles -#' in quantile regression (hence the name). -#' -#' @details See \code{vignette("brms_families")} for details -#' on the parameterization. -#' -#' @export -dasym_laplace <- function(x, mu = 0, sigma = 1, quantile = 0.5, - log = FALSE) { - out <- ifelse(x < mu, - yes = (quantile * (1 - quantile) / sigma) * - exp((1 - quantile) * (x - mu) / sigma), - no = (quantile * (1 - quantile) / sigma) * - exp(-quantile * (x - mu) / sigma) - ) - if (log) { - out <- log(out) - } - out -} - -#' @rdname AsymLaplace -#' @export -pasym_laplace <- function(q, mu = 0, sigma = 1, quantile = 0.5, - lower.tail = TRUE, log.p = FALSE) { - out <- ifelse(q < mu, - yes = quantile * exp((1 - quantile) * (q - mu) / sigma), - no = 1 - (1 - quantile) * exp(-quantile * (q - mu) / sigma) - ) - if (!lower.tail) { - out <- 1 - out - } - if (log.p) { - out <- log(out) - } - out -} - -#' @rdname AsymLaplace -#' @export -qasym_laplace <- function(p, mu = 0, sigma = 1, quantile = 0.5, - lower.tail = TRUE, log.p = FALSE) { - if (log.p) { - p <- exp(p) - } - if (!lower.tail) { - p <- 1 - p - } - if (length(quantile) == 1L) { - quantile <- rep(quantile, length(mu)) - } - ifelse(p < quantile, - yes = mu + ((sigma * log(p / quantile)) / (1 - quantile)), - no = mu - ((sigma * log((1 - p) / (1 - quantile))) / quantile) - ) -} - -#' @rdname AsymLaplace -#' @export -rasym_laplace <- function(n, mu = 0, sigma = 1, quantile = 0.5) { - u <- runif(n) - qasym_laplace(u, mu = mu, sigma = sigma, quantile = quantile) -} - -# The Discrete Weibull Distribution -# -# Density, distribution function, quantile function and random generation -# for the discrete Weibull distribution with location \code{mu} and -# shape \code{shape}. -# -# @name DiscreteWeibull -# -# @inheritParams StudentT -# @param mu Location parameter in the unit interval. -# @param shape Positive shape parameter. -# -# @details See \code{vignette("brms_families")} for details -# on the parameterization. -# -# @export -ddiscrete_weibull <- function(x, mu, shape, log = FALSE) { - if (isTRUE(any(mu < 0 | mu > 1))) { - stop2("mu bust be between 0 and 1.") - } - if (isTRUE(any(shape <= 0))) { - stop2("shape bust be positive.") - } - x <- round(x) - out <- mu^x^shape - mu^(x + 1)^shape - out[x < 0] <- 0 - if (log) { - out <- log(out) - } - out -} - -# @rdname DiscreteWeibull -# @export -pdiscrete_weibull <- function(x, mu, shape, lower.tail = TRUE, log.p = FALSE) { - if (isTRUE(any(mu < 0 | mu > 1))) { - stop2("mu bust be between 0 and 1.") - } - if (isTRUE(any(shape <= 0))) { - stop2("shape bust be positive.") - } - x <- round(x) - if (lower.tail) { - out <- 1 - mu^(x + 1)^shape - out[x < 0] <- 0 - } else { - out <- mu^(x + 1)^shape - out[x < 0] <- 1 - } - if (log.p) { - out <- log(out) - } - out -} - -# @rdname DiscreteWeibull -# @export -qdiscrete_weibull <- function(p, mu, shape, lower.tail = TRUE, log.p = FALSE) { - if (isTRUE(any(mu < 0 | mu > 1))) { - stop2("mu bust be between 0 and 1.") - } - if (isTRUE(any(shape <= 0))) { - stop2("shape bust be positive.") - } - if (log.p) { - p <- exp(p) - } - if (!lower.tail) { - p <- 1 - p - } - ceiling((log(1 - p) / log(mu))^(1 / shape) - 1) -} - -# @rdname DiscreteWeibull -# @export -rdiscrete_weibull <- function(n, mu, shape) { - u <- runif(n, 0, 1) - qdiscrete_weibull(u, mu, shape) -} - -# mean of the discrete weibull distribution -# @param mu location parameter -# @param shape shape parameter -# @param M maximal evaluated element of the series -# @param thres threshold for new elements at which to stop evaluation -mean_discrete_weibull <- function(mu, shape, M = 1000, thres = 0.001) { - opt_M <- ceiling(max((log(thres) / log(mu))^(1 / shape))) - if (opt_M <= M) { - M <- opt_M - } else { - # avoid the loop below running too slow - warning2( - "Approximating the mean of the 'discrete_weibull' ", - "distribution failed and results be inaccurate." - ) - } - out <- 0 - for (y in seq_len(M)) { - out <- out + mu^y^shape - } - # approximation of the residual series (see Englehart & Li, 2011) - # returns unreasonably large values presumably due to numerical issues - out -} - -# PDF of the COM-Poisson distribution -# com_poisson in brms uses the mode parameterization -dcom_poisson <- function(x, mu, shape, log = FALSE) { - x <- round(x) - log_mu <- log(mu) - log_Z <- log_Z_com_poisson(log_mu, shape) - out <- shape * (x * log_mu - lgamma(x + 1)) - log_Z - if (!log) { - out <- exp(out) - } - out -} - -# random numbers from the COM-Poisson distribution -rcom_poisson <- function(n, mu, shape, M = 10000) { - n <- check_n_rdist(n, mu, shape) - M <- as.integer(as_one_numeric(M)) - log_mu <- log(mu) - # approximating log_Z may yield too large random draws - log_Z <- log_Z_com_poisson(log_mu, shape, approx = FALSE) - u <- runif(n, 0, 1) - cdf <- exp(-log_Z) - lfac <- 0 - y <- 0 - out <- rep(0, n) - not_found <- cdf < u - while (any(not_found) && y <= M) { - y <- y + 1 - out[not_found] <- y - lfac <- lfac + log(y) - cdf <- cdf + exp(shape * (y * log_mu - lfac) - log_Z) - not_found <- cdf < u - } - if (any(not_found)) { - out[not_found] <- NA - nfailed <- sum(not_found) - warning2( - "Drawing random numbers from the 'com_poisson' ", - "distribution failed in ", nfailed, " cases." - ) - } - out -} - -# CDF of the COM-Poisson distribution -pcom_poisson <- function(x, mu, shape, lower.tail = TRUE, log.p = FALSE) { - x <- round(x) - args <- expand(x = x, mu = mu, shape = shape) - x <- args$x - mu <- args$mu - shape <- args$shape - - log_mu <- log(mu) - log_Z <- log_Z_com_poisson(log_mu, shape) - out <- rep(0, length(x)) - dim(out) <- attributes(args)$max_dim - out[x > 0] <- log1p_exp(shape * log_mu) - k <- 2 - lfac <- 0 - while (any(x >= k)) { - lfac <- lfac + log(k) - term <- shape * (k * log_mu - lfac) - out[x >= k] <- log_sum_exp(out[x >= k], term) - k <- k + 1 - } - out <- out - log_Z - out[out > 0] <- 0 - if (!lower.tail) { - out <- log1m_exp(out) - } - if (!log.p) { - out <- exp(out) - } - out -} - -# log normalizing constant of the COM Poisson distribution -# @param log_mu log location parameter -# @param shape shape parameter -# @param M maximal evaluated element of the series -# @param thres threshold for new elements at which to stop evaluation -# @param approx use a closed form approximation of the mean if appropriate? -log_Z_com_poisson <- function(log_mu, shape, M = 10000, thres = 1e-16, - approx = TRUE) { - if (isTRUE(any(shape <= 0))) { - stop2("'shape' must be positive.") - } - if (isTRUE(any(shape == Inf))) { - stop2("'shape' must be finite.") - } - approx <- as_one_logical(approx) - args <- expand(log_mu = log_mu, shape = shape) - log_mu <- args$log_mu - shape <- args$shape - - out <- rep(NA, length(log_mu)) - dim(out) <- attributes(args)$max_dim - use_poisson <- shape == 1 - if (any(use_poisson)) { - # shape == 1 implies the poisson distribution - out[use_poisson] <- exp(log_mu[use_poisson]) - } - if (approx) { - # use a closed form approximation if appropriate - use_approx <- log_mu * shape >= log(1.5) & log_mu >= log(1.5) - if (any(use_approx)) { - out[use_approx] <- log_Z_com_poisson_approx( - log_mu[use_approx], shape[use_approx] - ) - } - } - use_exact <- is.na(out) - if (any(use_exact)) { - # direct computation of the truncated series - M <- as.integer(as_one_numeric(M)) - thres <- as_one_numeric(thres) - log_thres <- log(thres) - log_mu <- log_mu[use_exact] - shape <- shape[use_exact] - # first 2 terms of the series - out_exact <- log1p_exp(shape * log_mu) - lfac <- 0 - k <- 2 - converged <- FALSE - while (!converged && k <= M) { - lfac <- lfac + log(k) - term <- shape * (k * log_mu - lfac) - out_exact <- log_sum_exp(out_exact, term) - converged <- all(term <= log_thres) - k <- k + 1 - } - out[use_exact] <- out_exact - if (!converged) { - warning2( - "Approximating the normalizing constant of the 'com_poisson' ", - "distribution failed and results may be inaccurate." - ) - } - } - out -} - -# approximate the log normalizing constant of the COM Poisson distribution -# based on doi:10.1007/s10463-017-0629-6 -log_Z_com_poisson_approx <- function(log_mu, shape) { - shape_mu <- shape * exp(log_mu) - shape2 <- shape^2 - # first 4 terms of the residual series - log_sum_resid <- log( - 1 + shape_mu^(-1) * (shape2 - 1) / 24 + - shape_mu^(-2) * (shape2 - 1) / 1152 * (shape2 + 23) + - shape_mu^(-3) * (shape2 - 1) / 414720 * - (5 * shape2^2 - 298 * shape2 + 11237) - ) - shape_mu + log_sum_resid - - ((log(2 * pi) + log_mu) * (shape - 1) / 2 + log(shape) / 2) -} - -# compute the log mean of the COM Poisson distribution -# @param mu location parameter -# @param shape shape parameter -# @param M maximal evaluated element of the series -# @param thres threshold for new elements at which to stop evaluation -# @param approx use a closed form approximation of the mean if appropriate? -mean_com_poisson <- function(mu, shape, M = 10000, thres = 1e-16, - approx = TRUE) { - if (isTRUE(any(shape <= 0))) { - stop2("'shape' must be positive.") - } - if (isTRUE(any(shape == Inf))) { - stop2("'shape' must be finite.") - } - approx <- as_one_logical(approx) - args <- expand(mu = mu, shape = shape) - mu <- args$mu - shape <- args$shape - - out <- rep(NA, length(mu)) - dim(out) <- attributes(args)$max_dim - use_poisson <- shape == 1 - if (any(use_poisson)) { - # shape == 1 implies the poisson distribution - out[use_poisson] <- mu[use_poisson] - } - if (approx) { - # use a closed form approximation if appropriate - use_approx <- mu^shape >= 1.5 & mu >= 1.5 - if (any(use_approx)) { - out[use_approx] <- mean_com_poisson_approx( - mu[use_approx], shape[use_approx] - ) - } - } - use_exact <- is.na(out) - if (any(use_exact)) { - # direct computation of the truncated series - M <- as.integer(as_one_numeric(M)) - thres <- as_one_numeric(thres) - log_thres <- log(thres) - mu <- mu[use_exact] - shape <- shape[use_exact] - log_mu <- log(mu) - # first 2 terms of the series - log_num <- shape * log_mu # numerator - log_Z <- log1p_exp(shape * log_mu) # denominator - lfac <- 0 - k <- 2 - converged <- FALSE - while (!converged && k <= M) { - log_k <- log(k) - lfac <- lfac + log_k - term <- shape * (k * log_mu - lfac) - log_num <- log_sum_exp(log_num, log_k + term) - log_Z <- log_sum_exp(log_Z, term) - converged <- all(term <= log_thres) - k <- k + 1 - } - if (!converged) { - warning2( - "Approximating the mean of the 'com_poisson' ", - "distribution failed and results may be inaccurate." - ) - } - out[use_exact] <- exp(log_num - log_Z) - } - out -} - -# approximate the mean of COM-Poisson distribution -# based on doi:10.1007/s10463-017-0629-6 -mean_com_poisson_approx <- function(mu, shape) { - term <- 1 - (shape - 1) / (2 * shape) * mu^(-1) - - (shape^2 - 1) / (24 * shape^2) * mu^(-2) - - (shape^2 - 1) / (24 * shape^3) * mu^(-3) - mu * term -} - -#' The Dirichlet Distribution -#' -#' Density function and random number generation for the dirichlet -#' distribution with shape parameter vector \code{alpha}. -#' -#' @name Dirichlet -#' -#' @inheritParams StudentT -#' @param x Matrix of quantiles. Each row corresponds to one probability vector. -#' @param alpha Matrix of positive shape parameters. Each row corresponds to one -#' probability vector. -#' -#' @details See \code{vignette("brms_families")} for details on the -#' parameterization. -#' -#' @export -ddirichlet <- function(x, alpha, log = FALSE) { - log <- as_one_logical(log) - if (!is.matrix(x)) { - x <- matrix(x, nrow = 1) - } - if (!is.matrix(alpha)) { - alpha <- matrix(alpha, nrow(x), length(alpha), byrow = TRUE) - } - if (nrow(x) == 1L && nrow(alpha) > 1L) { - x <- repl(x, nrow(alpha)) - x <- do_call(rbind, x) - } else if (nrow(x) > 1L && nrow(alpha) == 1L) { - alpha <- repl(alpha, nrow(x)) - alpha <- do_call(rbind, alpha) - } - if (isTRUE(any(x < 0))) { - stop2("x must be non-negative.") - } - if (!is_equal(rowSums(x), rep(1, nrow(x)))) { - stop2("x must sum to 1 per row.") - } - if (isTRUE(any(alpha <= 0))) { - stop2("alpha must be positive.") - } - out <- lgamma(rowSums(alpha)) - rowSums(lgamma(alpha)) + - rowSums((alpha - 1) * log(x)) - if (!log) { - out <- exp(out) - } - return(out) -} - -#' @rdname Dirichlet -#' @export -rdirichlet <- function(n, alpha) { - n <- as_one_numeric(n) - if (!is.matrix(alpha)) { - alpha <- matrix(alpha, nrow = 1) - } - if (prod(dim(alpha)) == 0) { - stop2("alpha should be non-empty.") - } - if (isTRUE(any(alpha <= 0))) { - stop2("alpha must be positive.") - } - if (n == 1) { - n <- nrow(alpha) - } - if (n > nrow(alpha)) { - alpha <- matrix(alpha, nrow = n, ncol = ncol(alpha), byrow = TRUE) - } - x <- matrix(rgamma(ncol(alpha) * n, alpha), ncol = ncol(alpha)) - x / rowSums(x) -} - -#' The Wiener Diffusion Model Distribution -#' -#' Density function and random generation for the Wiener -#' diffusion model distribution with boundary separation \code{alpha}, -#' non-decision time \code{tau}, bias \code{beta} and -#' drift rate \code{delta}. -#' -#' @name Wiener -#' -#' @inheritParams StudentT -#' @param alpha Boundary separation parameter. -#' @param tau Non-decision time parameter. -#' @param beta Bias parameter. -#' @param delta Drift rate parameter. -#' @param resp Response: \code{"upper"} or \code{"lower"}. -#' If no character vector, it is coerced to logical -#' where \code{TRUE} indicates \code{"upper"} and -#' \code{FALSE} indicates \code{"lower"}. -#' @param types Which types of responses to return? By default, -#' return both the response times \code{"q"} and the dichotomous -#' responses \code{"resp"}. If either \code{"q"} or \code{"resp"}, -#' return only one of the two types. -#' @param backend Name of the package to use as backend for the computations. -#' Either \code{"Rwiener"} (the default) or \code{"rtdists"}. -#' Can be set globally for the current \R session via the -#' \code{"wiener_backend"} option (see \code{\link{options}}). -#' -#' @details -#' These are wrappers around functions of the \pkg{RWiener} or \pkg{rtdists} -#' package (depending on the chosen \code{backend}). See -#' \code{vignette("brms_families")} for details on the parameterization. -#' -#' @seealso \code{\link[RWiener:wienerdist]{wienerdist}}, -#' \code{\link[rtdists:Diffusion]{Diffusion}} -#' -#' @export -dwiener <- function(x, alpha, tau, beta, delta, resp = 1, log = FALSE, - backend = getOption("wiener_backend", "Rwiener")) { - alpha <- as.numeric(alpha) - tau <- as.numeric(tau) - beta <- as.numeric(beta) - delta <- as.numeric(delta) - if (!is.character(resp)) { - resp <- ifelse(resp, "upper", "lower") - } - log <- as_one_logical(log) - backend <- match.arg(backend, c("Rwiener", "rtdists")) - .dwiener <- paste0(".dwiener_", backend) - args <- nlist(x, alpha, tau, beta, delta, resp) - args <- as.list(do_call(expand, args)) - args$log <- log - do_call(.dwiener, args) -} - -# dwiener using Rwiener as backend -.dwiener_Rwiener <- function(x, alpha, tau, beta, delta, resp, log) { - require_package("RWiener") - .dwiener <- Vectorize( - RWiener::dwiener, - c("q", "alpha", "tau", "beta", "delta", "resp") - ) - args <- nlist(q = x, alpha, tau, beta, delta, resp, give_log = log) - do_call(.dwiener, args) -} - -# dwiener using rtdists as backend -.dwiener_rtdists <- function(x, alpha, tau, beta, delta, resp, log) { - require_package("rtdists") - args <- list( - rt = x, response = resp, a = alpha, - t0 = tau, z = beta * alpha, v = delta - ) - out <- do_call(rtdists::ddiffusion, args) - if (log) { - out <- log(out) - } - out -} - -#' @rdname Wiener -#' @export -rwiener <- function(n, alpha, tau, beta, delta, types = c("q", "resp"), - backend = getOption("wiener_backend", "Rwiener")) { - n <- as_one_numeric(n) - alpha <- as.numeric(alpha) - tau <- as.numeric(tau) - beta <- as.numeric(beta) - delta <- as.numeric(delta) - types <- match.arg(types, several.ok = TRUE) - backend <- match.arg(backend, c("Rwiener", "rtdists")) - .rwiener <- paste0(".rwiener_", backend) - args <- nlist(n, alpha, tau, beta, delta, types) - do_call(.rwiener, args) -} - -# rwiener using Rwiener as backend -.rwiener_Rwiener <- function(n, alpha, tau, beta, delta, types) { - require_package("RWiener") - max_len <- max(lengths(list(alpha, tau, beta, delta))) - if (max_len > 1L) { - if (!n %in% c(1, max_len)) { - stop2("Can only sample exactly once for each condition.") - } - n <- 1 - } - # helper function to return a numeric vector instead - # of a data.frame with two columns as for RWiener::rwiener - .rwiener_num <- function(n, alpha, tau, beta, delta, types) { - out <- RWiener::rwiener(n, alpha, tau, beta, delta) - out$resp <- ifelse(out$resp == "upper", 1, 0) - if (length(types) == 1L) { - out <- out[[types]] - } - out - } - # vectorized version of .rwiener_num - .rwiener <- function(...) { - fun <- Vectorize( - .rwiener_num, - c("alpha", "tau", "beta", "delta"), - SIMPLIFY = FALSE - ) - do_call(rbind, fun(...)) - } - args <- nlist(n, alpha, tau, beta, delta, types) - do_call(.rwiener, args) -} - -# rwiener using rtdists as backend -.rwiener_rtdists <- function(n, alpha, tau, beta, delta, types) { - require_package("rtdists") - max_len <- max(lengths(list(alpha, tau, beta, delta))) - if (max_len > 1L) { - if (!n %in% c(1, max_len)) { - stop2("Can only sample exactly once for each condition.") - } - n <- max_len - } - out <- rtdists::rdiffusion( - n, a = alpha, t0 = tau, z = beta * alpha, v = delta - ) - # TODO: use column names of rtdists in the output? - names(out)[names(out) == "rt"] <- "q" - names(out)[names(out) == "response"] <- "resp" - out$resp <- ifelse(out$resp == "upper", 1, 0) - if (length(types) == 1L) { - out <- out[[types]] - } - out -} - -# density of the cox proportional hazards model -# @param x currently ignored as the information is passed -# via 'bhaz' and 'cbhaz'. Before exporting the cox distribution -# functions, this needs to be refactored so that x is actually used -# @param mu positive location parameter -# @param bhaz baseline hazard -# @param cbhaz cumulative baseline hazard -dcox <- function(x, mu, bhaz, cbhaz, log = FALSE) { - out <- hcox(x, mu, bhaz, cbhaz, log = TRUE) + - pcox(x, mu, bhaz, cbhaz, lower.tail = FALSE, log.p = TRUE) - if (!log) { - out <- exp(out) - } - out -} - -# hazard function of the cox model -hcox <- function(x, mu, bhaz, cbhaz, log = FALSE) { - out <- log(bhaz) + log(mu) - if (!log) { - out <- exp(out) - } - out -} - -# distribution function of the cox model -pcox <- function(q, mu, bhaz, cbhaz, lower.tail = TRUE, log.p = FALSE) { - log_surv <- -cbhaz * mu - if (lower.tail) { - if (log.p) { - out <- log1m_exp(log_surv) - } else { - out <- 1 - exp(log_surv) - } - } else { - if (log.p) { - out <- log_surv - } else { - out <- exp(log_surv) - } - } - out -} - -#' Zero-Inflated Distributions -#' -#' Density and distribution functions for zero-inflated distributions. -#' -#' @name ZeroInflated -#' -#' @inheritParams StudentT -#' @param zi zero-inflation probability -#' @param mu,lambda location parameter -#' @param shape,shape1,shape2 shape parameter -#' @param size number of trials -#' @param prob probability of success on each trial -#' -#' @details -#' The density of a zero-inflated distribution can be specified as follows. -#' If \eqn{x = 0} set \eqn{f(x) = \theta + (1 - \theta) * g(0)}. -#' Else set \eqn{f(x) = (1 - \theta) * g(x)}, -#' where \eqn{g(x)} is the density of the non-zero-inflated part. -NULL - -#' @rdname ZeroInflated -#' @export -dzero_inflated_poisson <- function(x, lambda, zi, log = FALSE) { - pars <- nlist(lambda) - .dzero_inflated(x, "pois", zi, pars, log) -} - -#' @rdname ZeroInflated -#' @export -pzero_inflated_poisson <- function(q, lambda, zi, lower.tail = TRUE, - log.p = FALSE) { - pars <- nlist(lambda) - .pzero_inflated(q, "pois", zi, pars, lower.tail, log.p) -} - -#' @rdname ZeroInflated -#' @export -dzero_inflated_negbinomial <- function(x, mu, shape, zi, log = FALSE) { - pars <- nlist(mu, size = shape) - .dzero_inflated(x, "nbinom", zi, pars, log) -} - -#' @rdname ZeroInflated -#' @export -pzero_inflated_negbinomial <- function(q, mu, shape, zi, lower.tail = TRUE, - log.p = FALSE) { - pars <- nlist(mu, size = shape) - .pzero_inflated(q, "nbinom", zi, pars, lower.tail, log.p) -} - -#' @rdname ZeroInflated -#' @export -dzero_inflated_binomial <- function(x, size, prob, zi, log = FALSE) { - pars <- nlist(size, prob) - .dzero_inflated(x, "binom", zi, pars, log) -} - -#' @rdname ZeroInflated -#' @export -pzero_inflated_binomial <- function(q, size, prob, zi, lower.tail = TRUE, - log.p = FALSE) { - pars <- nlist(size, prob) - .pzero_inflated(q, "binom", zi, pars, lower.tail, log.p) -} - -#' @rdname ZeroInflated -#' @export -dzero_inflated_beta <- function(x, shape1, shape2, zi, log = FALSE) { - pars <- nlist(shape1, shape2) - # zi_beta is technically a hurdle model - .dhurdle(x, "beta", zi, pars, log, type = "real") -} - -#' @rdname ZeroInflated -#' @export -pzero_inflated_beta <- function(q, shape1, shape2, zi, lower.tail = TRUE, - log.p = FALSE) { - pars <- nlist(shape1, shape2) - # zi_beta is technically a hurdle model - .phurdle(q, "beta", zi, pars, lower.tail, log.p, type = "real") -} - -# @rdname ZeroInflated -# @export -dzero_inflated_asym_laplace <- function(x, mu, sigma, quantile, zi, - log = FALSE) { - pars <- nlist(mu, sigma, quantile) - # zi_asym_laplace is technically a hurdle model - .dhurdle(x, "asym_laplace", zi, pars, log, type = "real") -} - -# @rdname ZeroInflated -# @export -pzero_inflated_asym_laplace <- function(q, mu, sigma, quantile, zi, - lower.tail = TRUE, log.p = FALSE) { - pars <- nlist(mu, sigma, quantile) - # zi_asym_laplace is technically a hurdle model - .phurdle(q, "asym_laplace", zi, pars, lower.tail, log.p, - type = "real", lb = -Inf, ub = Inf) -} - -# density of a zero-inflated distribution -# @param dist name of the distribution -# @param zi bernoulli zero-inflated parameter -# @param pars list of parameters passed to pdf -.dzero_inflated <- function(x, dist, zi, pars, log) { - stopifnot(is.list(pars)) - dist <- as_one_character(dist) - log <- as_one_logical(log) - args <- expand(dots = c(nlist(x, zi), pars)) - x <- args$x - zi <- args$zi - pars <- args[names(pars)] - pdf <- paste0("d", dist) - out <- ifelse(x == 0, - log(zi + (1 - zi) * do_call(pdf, c(0, pars))), - log(1 - zi) + do_call(pdf, c(list(x), pars, log = TRUE)) - ) - if (!log) { - out <- exp(out) - } - out -} - -# CDF of a zero-inflated distribution -# @param dist name of the distribution -# @param zi bernoulli zero-inflated parameter -# @param pars list of parameters passed to pdf -# @param lb lower bound of the conditional distribution -# @param ub upper bound of the conditional distribution -.pzero_inflated <- function(q, dist, zi, pars, lower.tail, log.p, - lb = 0, ub = Inf) { - stopifnot(is.list(pars)) - dist <- as_one_character(dist) - lower.tail <- as_one_logical(lower.tail) - log.p <- as_one_logical(log.p) - lb <- as_one_numeric(lb) - ub <- as_one_numeric(ub) - args <- expand(dots = c(nlist(q, zi), pars)) - q <- args$q - zi <- args$zi - pars <- args[names(pars)] - cdf <- paste0("p", dist) - # compute log CCDF values - out <- log(1 - zi) + - do_call(cdf, c(list(q), pars, lower.tail = FALSE, log.p = TRUE)) - # take the limits of the distribution into account - out <- ifelse(q < lb, 0, out) - out <- ifelse(q > ub, -Inf, out) - if (lower.tail) { - out <- 1 - exp(out) - if (log.p) { - out <- log(out) - } - } else { - if (!log.p) { - out <- exp(out) - } - } - out -} - -#' Hurdle Distributions -#' -#' Density and distribution functions for hurdle distributions. -#' -#' @name Hurdle -#' -#' @inheritParams StudentT -#' @param hu hurdle probability -#' @param mu,lambda location parameter -#' @param shape shape parameter -#' @param sigma,scale scale parameter -#' -#' @details -#' The density of a hurdle distribution can be specified as follows. -#' If \eqn{x = 0} set \eqn{f(x) = \theta}. Else set -#' \eqn{f(x) = (1 - \theta) * g(x) / (1 - G(0))} -#' where \eqn{g(x)} and \eqn{G(x)} are the density and distribution -#' function of the non-hurdle part, respectively. -NULL - -#' @rdname Hurdle -#' @export -dhurdle_poisson <- function(x, lambda, hu, log = FALSE) { - pars <- nlist(lambda) - .dhurdle(x, "pois", hu, pars, log, type = "int") -} - -#' @rdname Hurdle -#' @export -phurdle_poisson <- function(q, lambda, hu, lower.tail = TRUE, - log.p = FALSE) { - pars <- nlist(lambda) - .phurdle(q, "pois", hu, pars, lower.tail, log.p, type = "int") -} - -#' @rdname Hurdle -#' @export -dhurdle_negbinomial <- function(x, mu, shape, hu, log = FALSE) { - pars <- nlist(mu, size = shape) - .dhurdle(x, "nbinom", hu, pars, log, type = "int") -} - -#' @rdname Hurdle -#' @export -phurdle_negbinomial <- function(q, mu, shape, hu, lower.tail = TRUE, - log.p = FALSE) { - pars <- nlist(mu, size = shape) - .phurdle(q, "nbinom", hu, pars, lower.tail, log.p, type = "int") -} - -#' @rdname Hurdle -#' @export -dhurdle_gamma <- function(x, shape, scale, hu, log = FALSE) { - pars <- nlist(shape, scale) - .dhurdle(x, "gamma", hu, pars, log, type = "real") -} - -#' @rdname Hurdle -#' @export -phurdle_gamma <- function(q, shape, scale, hu, lower.tail = TRUE, - log.p = FALSE) { - pars <- nlist(shape, scale) - .phurdle(q, "gamma", hu, pars, lower.tail, log.p, type = "real") -} - -#' @rdname Hurdle -#' @export -dhurdle_lognormal <- function(x, mu, sigma, hu, log = FALSE) { - pars <- list(meanlog = mu, sdlog = sigma) - .dhurdle(x, "lnorm", hu, pars, log, type = "real") -} - -#' @rdname Hurdle -#' @export -phurdle_lognormal <- function(q, mu, sigma, hu, lower.tail = TRUE, - log.p = FALSE) { - pars <- list(meanlog = mu, sdlog = sigma) - .phurdle(q, "lnorm", hu, pars, lower.tail, log.p, type = "real") -} - -# density of a hurdle distribution -# @param dist name of the distribution -# @param hu bernoulli hurdle parameter -# @param pars list of parameters passed to pdf -# @param type support of distribution (int or real) -.dhurdle <- function(x, dist, hu, pars, log, type) { - stopifnot(is.list(pars)) - dist <- as_one_character(dist) - log <- as_one_logical(log) - type <- match.arg(type, c("int", "real")) - args <- expand(dots = c(nlist(x, hu), pars)) - x <- args$x - hu <- args$hu - pars <- args[names(pars)] - pdf <- paste0("d", dist) - if (type == "int") { - lccdf0 <- log(1 - do_call(pdf, c(0, pars))) - } else { - lccdf0 <- 0 - } - out <- ifelse(x == 0, - log(hu), - log(1 - hu) + do_call(pdf, c(list(x), pars, log = TRUE)) - lccdf0 - ) - if (!log) { - out <- exp(out) - } - out -} - -# CDF of a hurdle distribution -# @param dist name of the distribution -# @param hu bernoulli hurdle parameter -# @param pars list of parameters passed to pdf -# @param type support of distribution (int or real) -# @param lb lower bound of the conditional distribution -# @param ub upper bound of the conditional distribution -.phurdle <- function(q, dist, hu, pars, lower.tail, log.p, type, - lb = 0, ub = Inf) { - stopifnot(is.list(pars)) - dist <- as_one_character(dist) - lower.tail <- as_one_logical(lower.tail) - log.p <- as_one_logical(log.p) - type <- match.arg(type, c("int", "real")) - lb <- as_one_numeric(lb) - ub <- as_one_numeric(ub) - args <- expand(dots = c(nlist(q, hu), pars)) - q <- args$q - hu <- args$hu - pars <- args[names(pars)] - cdf <- paste0("p", dist) - # compute log CCDF values - out <- log(1 - hu) + - do_call(cdf, c(list(q), pars, lower.tail = FALSE, log.p = TRUE)) - if (type == "int") { - pdf <- paste0("d", dist) - out <- out - log(1 - do_call(pdf, c(0, pars))) - } - out <- ifelse(q < 0, log_sum_exp(out, log(hu)), out) - # take the limits of the distribution into account - out <- ifelse(q < lb, 0, out) - out <- ifelse(q > ub, -Inf, out) - if (lower.tail) { - out <- 1 - exp(out) - if (log.p) { - out <- log(out) - } - } else { - if (!log.p) { - out <- exp(out) - } - } - out -} - -# density of the categorical distribution with the softmax transform -# @param x positive integers not greater than ncat -# @param eta the linear predictor (of length or ncol ncat) -# @param log return values on the log scale? -dcategorical <- function(x, eta, log = FALSE) { - if (is.null(dim(eta))) { - eta <- matrix(eta, nrow = 1) - } - if (length(dim(eta)) != 2L) { - stop2("eta must be a numeric vector or matrix.") - } - out <- inv_link_categorical(eta, log = log) - out[, x, drop = FALSE] -} - -# generic inverse link function for the categorical family -# -# @param x Matrix (S x `ncat` or S x `ncat - 1` (depending on -# `insert_refcat_fam`), with S denoting the number of posterior draws and -# `ncat` denoting the number of response categories) with values of `eta` for -# one observation (see dcategorical()) or an array (S x N x `ncat` or S x N x -# `ncat - 1` (depending on `insert_refcat_fam`)) containing the same values as -# the matrix just described, but for N observations. -# @param insert_refcat_fam Either NULL or an object of class "brmsfamily". If -# NULL, `x` is not modified at all. If an object of class "brmsfamily", then -# insert_refcat() is used to insert values for the reference category into -# `x`. -# @param log Logical (length 1) indicating whether to log the return value. -# -# @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the -# number of posterior draws and `ncat` denoting the number of response -# categories) containing the values of the inverse-link function applied to -# `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same -# values as the matrix just described, but for N observations. -inv_link_categorical <- function(x, insert_refcat_fam = NULL, log = FALSE) { - if (!is.null(insert_refcat_fam)) { - x <- insert_refcat(x, family = insert_refcat_fam) - } - if (log) { - out <- log_softmax(x) - } else { - out <- softmax(x) - } - out -} - -# generic link function for the categorical family -# -# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and -# `ncat` denoting the number of response categories) of probabilities for the -# response categories or an array (S x N x `ncat`) containing the same values -# as the matrix just described, but for N observations. -# @param refcat Numeric (length 1) giving the index of the reference category. -# @param return_refcat Logical (length 1) indicating whether to include the -# reference category in the return value. -# -# @return If `x` is a matrix, then a matrix (S x `ncat` or S x `ncat - 1` -# (depending on `return_refcat`), with S denoting the number of posterior -# draws and `ncat` denoting the number of response categories) containing the -# values of the link function applied to `x`. If `x` is an array, then an -# array (S x N x `ncat` or S x N x `ncat - 1` (depending on `return_refcat`)) -# containing the same values as the matrix just described, but for N -# observations. -link_categorical <- function(x, refcat = 1, return_refcat = TRUE) { - ndim <- length(dim(x)) - marg_noncat <- seq_along(dim(x))[-ndim] - if (return_refcat) { - x_tosweep <- x - } else { - x_tosweep <- slice(x, ndim, -refcat, drop = FALSE) - } - log(sweep( - x_tosweep, - MARGIN = marg_noncat, - STATS = slice(x, ndim, refcat), - FUN = "/" - )) -} - -# CDF of the categorical distribution with the softmax transform -# @param q positive integers not greater than ncat -# @param eta the linear predictor (of length or ncol ncat) -# @param log.p return values on the log scale? -pcategorical <- function(q, eta, log.p = FALSE) { - p <- dcategorical(seq_len(max(q)), eta = eta) - out <- cblapply(q, function(j) rowSums(p[, 1:j, drop = FALSE])) - if (log.p) { - out <- log(out) - } - out -} - -# density of the multinomial distribution with the softmax transform -# @param x positive integers not greater than ncat -# @param eta the linear predictor (of length or ncol ncat) -# @param log return values on the log scale? -dmultinomial <- function(x, eta, log = FALSE) { - if (is.null(dim(eta))) { - eta <- matrix(eta, nrow = 1) - } - if (length(dim(eta)) != 2L) { - stop2("eta must be a numeric vector or matrix.") - } - log_prob <- log_softmax(eta) - size <- sum(x) - x <- data2draws(x, dim = dim(eta)) - out <- lgamma(size + 1) + rowSums(x * log_prob - lgamma(x + 1)) - if (!log) { - out <- exp(out) - } - out -} - -# density of the cumulative distribution -# -# @param x Integer vector containing response category indices to return the -# "densities" (probability masses) for. -# @param eta Vector (length S, with S denoting the number of posterior draws) of -# linear predictor draws. -# @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior -# draws and `ncat` denoting the number of response categories) of threshold -# draws. -# @param disc Vector (length S, with S denoting the number of posterior draws, -# or length 1 for recycling) of discrimination parameter draws. -# @param link Character vector (length 1) giving the name of the link function. -# -# @return A matrix (S x `length(x)`) containing the values of the inverse-link -# function applied to `disc * (thres - eta)`. -dcumulative <- function(x, eta, thres, disc = 1, link = "logit") { - eta <- disc * (thres - eta) - if (link == "identity") { - out <- eta - } else { - out <- inv_link_cumulative(eta, link = link) - } - out[, x, drop = FALSE] -} - -# generic inverse link function for the cumulative family -# -# @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws -# and `ncat` denoting the number of response categories) with values of -# `disc * (thres - eta)` for one observation (see dcumulative()) or an array -# (S x N x `ncat - 1`) containing the same values as the matrix just -# described, but for N observations. -# @param link Character vector (length 1) giving the name of the link function. -# -# @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the -# number of posterior draws and `ncat` denoting the number of response -# categories) containing the values of the inverse-link function applied to -# `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same -# values as the matrix just described, but for N observations. -inv_link_cumulative <- function(x, link) { - x <- ilink(x, link) - ndim <- length(dim(x)) - dim_noncat <- dim(x)[-ndim] - ones_arr <- array(1, dim = c(dim_noncat, 1)) - zeros_arr <- array(0, dim = c(dim_noncat, 1)) - abind::abind(x, ones_arr) - abind::abind(zeros_arr, x) -} - -# generic link function for the cumulative family -# -# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and -# `ncat` denoting the number of response categories) of probabilities for the -# response categories or an array (S x N x `ncat`) containing the same values -# as the matrix just described, but for N observations. -# @param link Character string (length 1) giving the name of the link function. -# -# @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the -# number of posterior draws and `ncat` denoting the number of response -# categories) containing the values of the link function applied to `x`. If -# `x` is an array, then an array (S x N x `ncat - 1`) containing the same -# values as the matrix just described, but for N observations. -link_cumulative <- function(x, link) { - ndim <- length(dim(x)) - ncat <- dim(x)[ndim] - dim_noncat <- dim(x)[-ndim] - nthres <- dim(x)[ndim] - 1 - marg_noncat <- seq_along(dim(x))[-ndim] - dim_t <- c(nthres, dim_noncat) - x <- apply(slice(x, ndim, -ncat, drop = FALSE), marg_noncat, cumsum) - x <- aperm(array(x, dim = dim_t), perm = c(marg_noncat + 1, 1)) - link(x, link) -} - -# density of the sratio distribution -# -# @param x Integer vector containing response category indices to return the -# "densities" (probability masses) for. -# @param eta Vector (length S, with S denoting the number of posterior draws) of -# linear predictor draws. -# @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior -# draws and `ncat` denoting the number of response categories) of threshold -# draws. -# @param disc Vector (length S, with S denoting the number of posterior draws, -# or length 1 for recycling) of discrimination parameter draws. -# @param link Character vector (length 1) giving the name of the link function. -# -# @return A matrix (S x `length(x)`) containing the values of the inverse-link -# function applied to `disc * (thres - eta)`. -dsratio <- function(x, eta, thres, disc = 1, link = "logit") { - eta <- disc * (thres - eta) - if (link == "identity") { - out <- eta - } else { - out <- inv_link_sratio(eta, link = link) - } - out[, x, drop = FALSE] -} - -# generic inverse link function for the sratio family -# -# @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws -# and `ncat` denoting the number of response categories) with values of -# `disc * (thres - eta)` for one observation (see dsratio()) or an array -# (S x N x `ncat - 1`) containing the same values as the matrix just -# described, but for N observations. -# @param link Character vector (length 1) giving the name of the link function. -# -# @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the -# number of posterior draws and `ncat` denoting the number of response -# categories) containing the values of the inverse-link function applied to -# `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same -# values as the matrix just described, but for N observations. -inv_link_sratio <- function(x, link) { - x <- ilink(x, link) - ndim <- length(dim(x)) - dim_noncat <- dim(x)[-ndim] - nthres <- dim(x)[ndim] - marg_noncat <- seq_along(dim(x))[-ndim] - ones_arr <- array(1, dim = c(dim_noncat, 1)) - dim_t <- c(nthres, dim_noncat) - Sx_cumprod <- aperm( - array(apply(1 - x, marg_noncat, cumprod), dim = dim_t), - perm = c(marg_noncat + 1, 1) - ) - abind::abind(x, ones_arr) * abind::abind(ones_arr, Sx_cumprod) -} - -# generic link function for the sratio family -# -# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and -# `ncat` denoting the number of response categories) of probabilities for the -# response categories or an array (S x N x `ncat`) containing the same values -# as the matrix just described, but for N observations. -# @param link Character string (length 1) giving the name of the link function. -# -# @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the -# number of posterior draws and `ncat` denoting the number of response -# categories) containing the values of the link function applied to `x`. If -# `x` is an array, then an array (S x N x `ncat - 1`) containing the same -# values as the matrix just described, but for N observations. -link_sratio <- function(x, link) { - ndim <- length(dim(x)) - .F_k <- function(k) { - if (k == 1) { - prev_res <- list(F_k = NULL, S_km1_prod = 1) - } else { - prev_res <- .F_k(k - 1) - } - F_k <- slice(x, ndim, k, drop = FALSE) / prev_res$S_km1_prod - .out <- list( - F_k = abind::abind(prev_res$F_k, F_k), - S_km1_prod = prev_res$S_km1_prod * (1 - F_k) - ) - return(.out) - } - x <- .F_k(dim(x)[ndim] - 1)$F_k - link(x, link) -} - -# density of the cratio distribution -# -# @param x Integer vector containing response category indices to return the -# "densities" (probability masses) for. -# @param eta Vector (length S, with S denoting the number of posterior draws) of -# linear predictor draws. -# @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior -# draws and `ncat` denoting the number of response categories) of threshold -# draws. -# @param disc Vector (length S, with S denoting the number of posterior draws, -# or length 1 for recycling) of discrimination parameter draws. -# @param link Character vector (length 1) giving the name of the link function. -# -# @return A matrix (S x `length(x)`) containing the values of the inverse-link -# function applied to `disc * (thres - eta)`. -dcratio <- function(x, eta, thres, disc = 1, link = "logit") { - eta <- disc * (eta - thres) - if (link == "identity") { - out <- eta - } else { - out <- inv_link_cratio(eta, link = link) - } - out[, x, drop = FALSE] -} - -# generic inverse link function for the cratio family -# -# @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws -# and `ncat` denoting the number of response categories) with values of -# `disc * (thres - eta)` for one observation (see dcratio()) or an array -# (S x N x `ncat - 1`) containing the same values as the matrix just -# described, but for N observations. -# @param link Character vector (length 1) giving the name of the link function. -# -# @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the -# number of posterior draws and `ncat` denoting the number of response -# categories) containing the values of the inverse-link function applied to -# `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same -# values as the matrix just described, but for N observations. -inv_link_cratio <- function(x, link) { - x <- ilink(x, link) - ndim <- length(dim(x)) - dim_noncat <- dim(x)[-ndim] - nthres <- dim(x)[ndim] - marg_noncat <- seq_along(dim(x))[-ndim] - ones_arr <- array(1, dim = c(dim_noncat, 1)) - dim_t <- c(nthres, dim_noncat) - x_cumprod <- aperm( - array(apply(x, marg_noncat, cumprod), dim = dim_t), - perm = c(marg_noncat + 1, 1) - ) - abind::abind(1 - x, ones_arr) * abind::abind(ones_arr, x_cumprod) -} - -# generic link function for the cratio family -# -# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and -# `ncat` denoting the number of response categories) of probabilities for the -# response categories or an array (S x N x `ncat`) containing the same values -# as the matrix just described, but for N observations. -# @param link Character string (length 1) giving the name of the link function. -# -# @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the -# number of posterior draws and `ncat` denoting the number of response -# categories) containing the values of the link function applied to `x`. If -# `x` is an array, then an array (S x N x `ncat - 1`) containing the same -# values as the matrix just described, but for N observations. -link_cratio <- function(x, link) { - ndim <- length(dim(x)) - .F_k <- function(k) { - if (k == 1) { - prev_res <- list(F_k = NULL, F_km1_prod = 1) - } else { - prev_res <- .F_k(k - 1) - } - F_k <- 1 - slice(x, ndim, k, drop = FALSE) / prev_res$F_km1_prod - .out <- list( - F_k = abind::abind(prev_res$F_k, F_k), - F_km1_prod = prev_res$F_km1_prod * F_k - ) - return(.out) - } - x <- .F_k(dim(x)[ndim] - 1)$F_k - link(x, link) -} - -# density of the acat distribution -# -# @param x Integer vector containing response category indices to return the -# "densities" (probability masses) for. -# @param eta Vector (length S, with S denoting the number of posterior draws) of -# linear predictor draws. -# @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior -# draws and `ncat` denoting the number of response categories) of threshold -# draws. -# @param disc Vector (length S, with S denoting the number of posterior draws, -# or length 1 for recycling) of discrimination parameter draws. -# @param link Character vector (length 1) giving the name of the link function. -# -# @return A matrix (S x `length(x)`) containing the values of the inverse-link -# function applied to `disc * (thres - eta)`. -dacat <- function(x, eta, thres, disc = 1, link = "logit") { - eta <- disc * (eta - thres) - if (link == "identity") { - out <- eta - } else { - out <- inv_link_acat(eta, link = link) - } - out[, x, drop = FALSE] -} - -# generic inverse link function for the acat family -# -# @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws -# and `ncat` denoting the number of response categories) with values of -# `disc * (thres - eta)` (see dacat()). -# @param link Character vector (length 1) giving the name of the link function. -# -# @return A matrix (S x `ncat`, with S denoting the number of posterior draws -# and `ncat` denoting the number of response categories) containing the values -# of the inverse-link function applied to `x`. -inv_link_acat <- function(x, link) { - ndim <- length(dim(x)) - dim_noncat <- dim(x)[-ndim] - nthres <- dim(x)[ndim] - marg_noncat <- seq_along(dim(x))[-ndim] - ones_arr <- array(1, dim = c(dim_noncat, 1)) - dim_t <- c(nthres, dim_noncat) - if (link == "logit") { - # faster evaluation in this case - exp_x_cumprod <- aperm( - array(apply(exp(x), marg_noncat, cumprod), dim = dim_t), - perm = c(marg_noncat + 1, 1) - ) - out <- abind::abind(ones_arr, exp_x_cumprod) - } else { - x <- ilink(x, link) - x_cumprod <- aperm( - array(apply(x, marg_noncat, cumprod), dim = dim_t), - perm = c(marg_noncat + 1, 1) - ) - Sx_cumprod_rev <- apply( - 1 - slice(x, ndim, rev(seq_len(nthres)), drop = FALSE), - marg_noncat, cumprod - ) - Sx_cumprod_rev <- aperm( - array(Sx_cumprod_rev, dim = dim_t), - perm = c(marg_noncat + 1, 1) - ) - Sx_cumprod_rev <- slice( - Sx_cumprod_rev, ndim, rev(seq_len(nthres)), drop = FALSE - ) - out <- abind::abind(ones_arr, x_cumprod) * - abind::abind(Sx_cumprod_rev, ones_arr) - } - catsum <- array(apply(out, marg_noncat, sum), dim = dim_noncat) - sweep(out, marg_noncat, catsum, "/") -} - -# generic link function for the acat family -# -# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and -# `ncat` denoting the number of response categories) of probabilities for the -# response categories or an array (S x N x `ncat`) containing the same values -# as the matrix just described, but for N observations. -# @param link Character string (length 1) giving the name of the link function. -# -# @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the -# number of posterior draws and `ncat` denoting the number of response -# categories) containing the values of the link function applied to `x`. If -# `x` is an array, then an array (S x N x `ncat - 1`) containing the same -# values as the matrix just described, but for N observations. -link_acat <- function(x, link) { - ndim <- length(dim(x)) - ncat <- dim(x)[ndim] - x <- slice(x, ndim, -1, drop = FALSE) / slice(x, ndim, -ncat, drop = FALSE) - if (link == "logit") { - # faster evaluation in this case - out <- log(x) - } else { - x <- inv_odds(x) - out <- link(x, link) - } - out -} - -# CDF for ordinal distributions -# @param q positive integers not greater than ncat -# @param eta draws of the linear predictor -# @param thres draws of threshold parameters -# @param disc draws of the discrimination parameter -# @param family a character string naming the family -# @param link a character string naming the link -# @return a matrix of probabilities P(x <= q) -pordinal <- function(q, eta, thres, disc = 1, family = NULL, link = "logit") { - family <- as_one_character(family) - link <- as_one_character(link) - args <- nlist(x = seq_len(max(q)), eta, thres, disc, link) - p <- do_call(paste0("d", family), args) - .fun <- function(j) rowSums(as.matrix(p[, 1:j, drop = FALSE])) - cblapply(q, .fun) -} - -# helper functions to shift arbitrary distributions -dshifted <- function(dist, x, shift = 0, ...) { - do_call(paste0("d", dist), list(x - shift, ...)) -} - -pshifted <- function(dist, q, shift = 0, ...) { - do_call(paste0("p", dist), list(q - shift, ...)) -} - -qshifted <- function(dist, p, shift = 0, ...) { - do_call(paste0("q", dist), list(p, ...)) + shift -} - -rshifted <- function(dist, n, shift = 0, ...) { - do_call(paste0("r", dist), list(n, ...)) + shift -} - -# check if 'n' in r functions is valid -# @param n number of desired random draws -# @param .. parameter vectors -# @return validated 'n' -check_n_rdist <- function(n, ...) { - n <- as.integer(as_one_numeric(n)) - max_len <- max(lengths(list(...))) - if (max_len > 1L) { - if (!n %in% c(1, max_len)) { - stop2("'n' must match the maximum length of the parameter vectors.") - } - n <- max_len - } - n -} +#' The Student-t Distribution +#' +#' Density, distribution function, quantile function and random generation +#' for the Student-t distribution with location \code{mu}, scale \code{sigma}, +#' and degrees of freedom \code{df}. +#' +#' @name StudentT +#' +#' @param x,q Vector of quantiles. +#' @param p Vector of probabilities. +#' @param n Number of draws to sample from the distribution. +#' @param mu Vector of location values. +#' @param sigma Vector of scale values. +#' @param df Vector of degrees of freedom. +#' @param log,log.p Logical; If \code{TRUE}, values are returned on the log scale. +#' @param lower.tail Logical; If \code{TRUE} (default), return P(X <= x). +#' Else, return P(X > x) . +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @seealso \code{\link[stats:TDist]{TDist}} +#' +#' @export +dstudent_t <- function(x, df, mu = 0, sigma = 1, log = FALSE) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + if (log) { + dt((x - mu) / sigma, df = df, log = TRUE) - log(sigma) + } else { + dt((x - mu) / sigma, df = df) / sigma + } +} + +#' @rdname StudentT +#' @export +pstudent_t <- function(q, df, mu = 0, sigma = 1, + lower.tail = TRUE, log.p = FALSE) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + pt((q - mu) / sigma, df = df, lower.tail = lower.tail, log.p = log.p) +} + +#' @rdname StudentT +#' @export +qstudent_t <- function(p, df, mu = 0, sigma = 1) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + mu + sigma * qt(p, df = df) +} + +#' @rdname StudentT +#' @export +rstudent_t <- function(n, df, mu = 0, sigma = 1) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + mu + sigma * rt(n, df = df) +} + +#' The Multivariate Normal Distribution +#' +#' Density function and random generation for the multivariate normal +#' distribution with mean vector \code{mu} and covariance matrix \code{Sigma}. +#' +#' @name MultiNormal +#' +#' @inheritParams StudentT +#' @param x Vector or matrix of quantiles. If \code{x} is a matrix, +#' each row is taken to be a quantile. +#' @param mu Mean vector with length equal to the number of dimensions. +#' @param Sigma Covariance matrix. +#' @param check Logical; Indicates whether several input checks +#' should be performed. Defaults to \code{FALSE} to improve +#' efficiency. +#' +#' @details See the Stan user's manual \url{https://mc-stan.org/documentation/} +#' for details on the parameterization +#' +#' @export +dmulti_normal <- function(x, mu, Sigma, log = FALSE, check = FALSE) { + if (is.vector(x) || length(dim(x)) == 1L) { + x <- matrix(x, ncol = length(x)) + } + p <- ncol(x) + if (check) { + if (length(mu) != p) { + stop2("Dimension of mu is incorrect.") + } + if (!all(dim(Sigma) == c(p, p))) { + stop2("Dimension of Sigma is incorrect.") + } + if (!is_symmetric(Sigma)) { + stop2("Sigma must be a symmetric matrix.") + } + } + chol_Sigma <- chol(Sigma) + rooti <- backsolve(chol_Sigma, t(x) - mu, transpose = TRUE) + quads <- colSums(rooti^2) + out <- -(p / 2) * log(2 * pi) - sum(log(diag(chol_Sigma))) - .5 * quads + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname MultiNormal +#' @export +rmulti_normal <- function(n, mu, Sigma, check = FALSE) { + p <- length(mu) + if (check) { + if (!(is_wholenumber(n) && n > 0)) { + stop2("n must be a positive integer.") + } + if (!all(dim(Sigma) == c(p, p))) { + stop2("Dimension of Sigma is incorrect.") + } + if (!is_symmetric(Sigma)) { + stop2("Sigma must be a symmetric matrix.") + } + } + draws <- matrix(rnorm(n * p), nrow = n, ncol = p) + mu + draws %*% chol(Sigma) +} + +#' The Multivariate Student-t Distribution +#' +#' Density function and random generation for the multivariate Student-t +#' distribution with location vector \code{mu}, covariance matrix \code{Sigma}, +#' and degrees of freedom \code{df}. +#' +#' @name MultiStudentT +#' +#' @inheritParams StudentT +#' @param x Vector or matrix of quantiles. If \code{x} is a matrix, +#' each row is taken to be a quantile. +#' @param mu Location vector with length equal to the number of dimensions. +#' @param Sigma Covariance matrix. +#' @param check Logical; Indicates whether several input checks +#' should be performed. Defaults to \code{FALSE} to improve +#' efficiency. +#' +#' @details See the Stan user's manual \url{https://mc-stan.org/documentation/} +#' for details on the parameterization +#' +#' @export +dmulti_student_t <- function(x, df, mu, Sigma, log = FALSE, check = FALSE) { + if (is.vector(x) || length(dim(x)) == 1L) { + x <- matrix(x, ncol = length(x)) + } + p <- ncol(x) + if (check) { + if (isTRUE(any(df <= 0))) { + stop2("df must be greater than 0.") + } + if (length(mu) != p) { + stop2("Dimension of mu is incorrect.") + } + if (!all(dim(Sigma) == c(p, p))) { + stop2("Dimension of Sigma is incorrect.") + } + if (!is_symmetric(Sigma)) { + stop2("Sigma must be a symmetric matrix.") + } + } + chol_Sigma <- chol(Sigma) + rooti <- backsolve(chol_Sigma, t(x) - mu, transpose = TRUE) + quads <- colSums(rooti^2) + out <- lgamma((p + df)/2) - (lgamma(df / 2) + sum(log(diag(chol_Sigma))) + + p / 2 * log(pi * df)) - 0.5 * (df + p) * log1p(quads / df) + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname MultiStudentT +#' @export +rmulti_student_t <- function(n, df, mu, Sigma, check = FALSE) { + p <- length(mu) + if (isTRUE(any(df <= 0))) { + stop2("df must be greater than 0.") + } + draws <- rmulti_normal(n, mu = rep(0, p), Sigma = Sigma, check = check) + draws <- draws / sqrt(rchisq(n, df = df) / df) + sweep(draws, 2, mu, "+") +} + +#' The (Multivariate) Logistic Normal Distribution +#' +#' Density function and random generation for the (multivariate) logistic normal +#' distribution with latent mean vector \code{mu} and covariance matrix \code{Sigma}. +#' +#' @name LogisticNormal +#' +#' @inheritParams StudentT +#' @param x Vector or matrix of quantiles. If \code{x} is a matrix, +#' each row is taken to be a quantile. +#' @param mu Mean vector with length equal to the number of dimensions. +#' @param Sigma Covariance matrix. +#' @param refcat A single integer indicating the reference category. +#' Defaults to \code{1}. +#' @param check Logical; Indicates whether several input checks +#' should be performed. Defaults to \code{FALSE} to improve +#' efficiency. +#' +#' @export +dlogistic_normal <- function(x, mu, Sigma, refcat = 1, log = FALSE, + check = FALSE) { + if (is.vector(x) || length(dim(x)) == 1L) { + x <- matrix(x, ncol = length(x)) + } + lx <- link_categorical(x, refcat) + out <- dmulti_normal(lx, mu, Sigma, log = TRUE) - rowSums(log(x)) + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname LogisticNormal +#' @export +rlogistic_normal <- function(n, mu, Sigma, refcat = 1, check = FALSE) { + out <- rmulti_normal(n, mu, Sigma, check = check) + inv_link_categorical(out, refcat = refcat) +} + +#' The Skew-Normal Distribution +#' +#' Density, distribution function, and random generation for the +#' skew-normal distribution with mean \code{mu}, +#' standard deviation \code{sigma}, and skewness \code{alpha}. +#' +#' @name SkewNormal +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param mu Vector of mean values. +#' @param sigma Vector of standard deviation values. +#' @param alpha Vector of skewness values. +#' @param xi Optional vector of location values. +#' If \code{NULL} (the default), will be computed internally. +#' @param omega Optional vector of scale values. +#' If \code{NULL} (the default), will be computed internally. +#' @param tol Tolerance of the approximation used in the +#' computation of quantiles. +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @export +dskew_normal <- function(x, mu = 0, sigma = 1, alpha = 0, + xi = NULL, omega = NULL, log = FALSE) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be greater than 0.") + } + args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, x = x) + out <- with(args, { + # do it like sn::dsn + z <- (x - xi) / omega + if (length(alpha) == 1L) { + alpha <- rep(alpha, length(z)) + } + logN <- -log(sqrt(2 * pi)) - log(omega) - z^2 / 2 + logS <- ifelse( + abs(alpha) < Inf, + pnorm(alpha * z, log.p = TRUE), + log(as.numeric(sign(alpha) * z > 0)) + ) + out <- logN + logS - pnorm(0, log.p = TRUE) + ifelse(abs(z) == Inf, -Inf, out) + }) + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname SkewNormal +#' @export +pskew_normal <- function(q, mu = 0, sigma = 1, alpha = 0, + xi = NULL, omega = NULL, + lower.tail = TRUE, log.p = FALSE) { + require_package("mnormt") + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, q = q) + out <- with(args, { + # do it like sn::psn + z <- (q - xi) / omega + nz <- length(z) + is_alpha_inf <- abs(alpha) == Inf + delta[is_alpha_inf] <- sign(alpha[is_alpha_inf]) + out <- numeric(nz) + for (k in seq_len(nz)) { + if (is_alpha_inf[k]) { + if (alpha[k] > 0) { + out[k] <- 2 * (pnorm(pmax(z[k], 0)) - 0.5) + } else { + out[k] <- 1 - 2 * (0.5 - pnorm(pmin(z[k], 0))) + } + } else { + S <- matrix(c(1, -delta[k], -delta[k], 1), 2, 2) + out[k] <- 2 * mnormt::biv.nt.prob( + 0, lower = rep(-Inf, 2), upper = c(z[k], 0), + mean = c(0, 0), S = S + ) + } + } + pmin(1, pmax(0, out)) + }) + if (!lower.tail) { + out <- 1 - out + } + if (log.p) { + out <- log(out) + } + out +} + +#' @rdname SkewNormal +#' @export +qskew_normal <- function(p, mu = 0, sigma = 1, alpha = 0, + xi = NULL, omega = NULL, + lower.tail = TRUE, log.p = FALSE, + tol = 1e-8) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + if (log.p) { + p <- exp(p) + } + if (!lower.tail) { + p <- 1 - p + } + args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega, p = p) + out <- with(args, { + # do it like sn::qsn + na <- is.na(p) | (p < 0) | (p > 1) + zero <- (p == 0) + one <- (p == 1) + p <- replace(p, (na | zero | one), 0.5) + cum <- skew_normal_cumulants(0, 1, alpha, n = 4) + g1 <- cum[, 3] / cum[, 2]^(3 / 2) + g2 <- cum[, 4] / cum[, 2]^2 + x <- qnorm(p) + x <- x + (x^2 - 1) * g1 / 6 + + x * (x^2 - 3) * g2 / 24 - + x * (2 * x^2 - 5) * g1^2 / 36 + x <- cum[, 1] + sqrt(cum[, 2]) * x + px <- pskew_normal(x, xi = 0, omega = 1, alpha = alpha) + max_err <- 1 + while (max_err > tol) { + x1 <- x - (px - p) / + dskew_normal(x, xi = 0, omega = 1, alpha = alpha) + x <- x1 + px <- pskew_normal(x, xi = 0, omega = 1, alpha = alpha) + max_err <- max(abs(px - p)) + if (is.na(max_err)) { + warning2("Approximation in 'qskew_normal' might have failed.") + } + } + x <- replace(x, na, NA) + x <- replace(x, zero, -Inf) + x <- replace(x, one, Inf) + as.numeric(xi + omega * x) + }) + out +} + +#' @rdname SkewNormal +#' @export +rskew_normal <- function(n, mu = 0, sigma = 1, alpha = 0, + xi = NULL, omega = NULL) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + args <- cp2dp(mu, sigma, alpha, xi = xi, omega = omega) + with(args, { + # do it like sn::rsn + z1 <- rnorm(n) + z2 <- rnorm(n) + id <- z2 > args$alpha * z1 + z1[id] <- -z1[id] + xi + omega * z1 + }) +} + +# convert skew-normal mixed-CP to DP parameterization +# @return a data.frame containing all relevant parameters +cp2dp <- function(mu = 0, sigma = 1, alpha = 0, + xi = NULL, omega = NULL, ...) { + delta <- alpha / sqrt(1 + alpha^2) + if (is.null(omega)) { + omega <- sigma / sqrt(1 - 2 / pi * delta^2) + } + if (is.null(xi)) { + xi <- mu - omega * delta * sqrt(2 / pi) + } + expand(dots = nlist(mu, sigma, alpha, xi, omega, delta, ...)) +} + +# helper function for qskew_normal +# code basis taken from sn::sn.cumulants +# uses xi and omega rather than mu and sigma +skew_normal_cumulants <- function(xi = 0, omega = 1, alpha = 0, n = 4) { + cumulants_half_norm <- function(n) { + n <- max(n, 2) + n <- as.integer(2 * ceiling(n/2)) + half.n <- as.integer(n/2) + m <- 0:(half.n - 1) + a <- sqrt(2/pi)/(gamma(m + 1) * 2^m * (2 * m + 1)) + signs <- rep(c(1, -1), half.n)[seq_len(half.n)] + a <- as.vector(rbind(signs * a, rep(0, half.n))) + coeff <- rep(a[1], n) + for (k in 2:n) { + ind <- seq_len(k - 1) + coeff[k] <- a[k] - sum(ind * coeff[ind] * a[rev(ind)]/k) + } + kappa <- coeff * gamma(seq_len(n) + 1) + kappa[2] <- 1 + kappa[2] + return(kappa) + } + + args <- expand(dots = nlist(xi, omega, alpha)) + with(args, { + # do it like sn::sn.cumulants + delta <- alpha / sqrt(1 + alpha^2) + kv <- cumulants_half_norm(n) + if (length(kv) > n) { + kv <- kv[-(n + 1)] + } + kv[2] <- kv[2] - 1 + kappa <- outer(delta, 1:n, "^") * + matrix(rep(kv, length(xi)), ncol = n, byrow = TRUE) + kappa[, 2] <- kappa[, 2] + 1 + kappa <- kappa * outer(omega, 1:n, "^") + kappa[, 1] <- kappa[, 1] + xi + kappa + }) +} + +# CDF of the inverse gamma function +pinvgamma <- function(q, shape, rate, lower.tail = TRUE, log.p = FALSE) { + pgamma(1/q, shape, rate = rate, lower.tail = !lower.tail, log.p = log.p) +} + +#' The von Mises Distribution +#' +#' Density, distribution function, and random generation for the +#' von Mises distribution with location \code{mu}, and precision \code{kappa}. +#' +#' @name VonMises +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param kappa Vector of precision values. +#' @param acc Accuracy of numerical approximations. +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @export +dvon_mises <- function(x, mu, kappa, log = FALSE) { + if (isTRUE(any(kappa < 0))) { + stop2("kappa must be non-negative") + } + # expects x in [-pi, pi] rather than [0, 2*pi] as CircStats::dvm + be <- besselI(kappa, nu = 0, expon.scaled = TRUE) + out <- -log(2 * pi * be) + kappa * (cos(x - mu) - 1) + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname VonMises +#' @export +pvon_mises <- function(q, mu, kappa, lower.tail = TRUE, + log.p = FALSE, acc = 1e-20) { + if (isTRUE(any(kappa < 0))) { + stop2("kappa must be non-negative") + } + pi <- base::pi + pi2 <- 2 * pi + q <- (q + pi) %% pi2 + mu <- (mu + pi) %% pi2 + args <- expand(q = q, mu = mu, kappa = kappa) + q <- args$q + mu <- args$mu + kappa <- args$kappa + rm(args) + + # code basis taken from CircStats::pvm but improved + # considerably with respect to speed and stability + rec_sum <- function(q, kappa, acc, sum = 0, i = 1) { + # compute the sum of of besselI functions recursively + term <- (besselI(kappa, nu = i) * sin(i * q)) / i + sum <- sum + term + rd <- abs(term) >= acc + if (sum(rd)) { + sum[rd] <- rec_sum( + q[rd], kappa[rd], acc, sum = sum[rd], i = i + 1 + ) + } + sum + } + + .pvon_mises <- function(q, kappa, acc) { + sum <- rec_sum(q, kappa, acc) + q / pi2 + sum / (pi * besselI(kappa, nu = 0)) + } + + out <- rep(NA, length(mu)) + zero_mu <- mu == 0 + if (sum(zero_mu)) { + out[zero_mu] <- .pvon_mises(q[zero_mu], kappa[zero_mu], acc) + } + lq_mu <- q <= mu + if (sum(lq_mu)) { + upper <- (q[lq_mu] - mu[lq_mu]) %% pi2 + upper[upper == 0] <- pi2 + lower <- (-mu[lq_mu]) %% pi2 + out[lq_mu] <- + .pvon_mises(upper, kappa[lq_mu], acc) - + .pvon_mises(lower, kappa[lq_mu], acc) + } + uq_mu <- q > mu + if (sum(uq_mu)) { + upper <- q[uq_mu] - mu[uq_mu] + lower <- mu[uq_mu] %% pi2 + out[uq_mu] <- + .pvon_mises(upper, kappa[uq_mu], acc) + + .pvon_mises(lower, kappa[uq_mu], acc) + } + if (!lower.tail) { + out <- 1 - out + } + if (log.p) { + out <- log(out) + } + out +} + +#' @rdname VonMises +#' @export +rvon_mises <- function(n, mu, kappa) { + if (isTRUE(any(kappa < 0))) { + stop2("kappa must be non-negative") + } + args <- expand(mu = mu, kappa = kappa, length = n) + mu <- args$mu + kappa <- args$kappa + rm(args) + pi <- base::pi + mu <- mu + pi + + # code basis taken from CircStats::rvm but improved + # considerably with respect to speed and stability + rvon_mises_outer <- function(r, mu, kappa) { + n <- length(r) + U1 <- runif(n, 0, 1) + z <- cos(pi * U1) + f <- (1 + r * z) / (r + z) + c <- kappa * (r - f) + U2 <- runif(n, 0, 1) + outer <- is.na(f) | is.infinite(f) | + !(c * (2 - c) - U2 > 0 | log(c / U2) + 1 - c >= 0) + inner <- !outer + out <- rep(NA, n) + if (sum(inner)) { + out[inner] <- rvon_mises_inner(f[inner], mu[inner]) + } + if (sum(outer)) { + # evaluate recursively until a valid sample is found + out[outer] <- rvon_mises_outer(r[outer], mu[outer], kappa[outer]) + } + out + } + + rvon_mises_inner <- function(f, mu) { + n <- length(f) + U3 <- runif(n, 0, 1) + (sign(U3 - 0.5) * acos(f) + mu) %% (2 * pi) + } + + a <- 1 + (1 + 4 * (kappa^2))^0.5 + b <- (a - (2 * a)^0.5) / (2 * kappa) + r <- (1 + b^2) / (2 * b) + # indicates underflow due to kappa being close to zero + is_uf <- is.na(r) | is.infinite(r) + not_uf <- !is_uf + out <- rep(NA, n) + if (sum(is_uf)) { + out[is_uf] <- runif(sum(is_uf), 0, 2 * pi) + } + if (sum(not_uf)) { + out[not_uf] <- rvon_mises_outer(r[not_uf], mu[not_uf], kappa[not_uf]) + } + out - pi +} + +#' The Exponentially Modified Gaussian Distribution +#' +#' Density, distribution function, and random generation +#' for the exponentially modified Gaussian distribution with +#' mean \code{mu} and standard deviation \code{sigma} of the gaussian +#' component, as well as scale \code{beta} of the exponential +#' component. +#' +#' @name ExGaussian +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param mu Vector of means of the combined distribution. +#' @param sigma Vector of standard deviations of the gaussian component. +#' @param beta Vector of scales of the exponential component. +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @export +dexgaussian <- function(x, mu, sigma, beta, log = FALSE) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + if (isTRUE(any(beta < 0))) { + stop2("beta must be non-negative.") + } + args <- nlist(x, mu, sigma, beta) + args <- do_call(expand, args) + args$mu <- with(args, mu - beta) + args$z <- with(args, x - mu - sigma^2 / beta) + + out <- with(args, + -log(beta) - (z + sigma^2 / (2 * beta)) / beta + + pnorm(z / sigma, log.p = TRUE) + ) + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname ExGaussian +#' @export +pexgaussian <- function(q, mu, sigma, beta, + lower.tail = TRUE, log.p = FALSE) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + if (isTRUE(any(beta < 0))) { + stop2("beta must be non-negative.") + } + args <- nlist(q, mu, sigma, beta) + args <- do_call(expand, args) + args$mu <- with(args, mu - beta) + args$z <- with(args, q - mu - sigma^2 / beta) + + out <- with(args, + pnorm((q - mu) / sigma) - pnorm(z / sigma) * + exp(((mu + sigma^2 / beta)^2 - mu^2 - 2 * q * sigma^2 / beta) / + (2 * sigma^2)) + ) + if (!lower.tail) { + out <- 1 - out + } + if (log.p) { + out <- log(out) + } + out +} + +#' @rdname ExGaussian +#' @export +rexgaussian <- function(n, mu, sigma, beta) { + if (isTRUE(any(sigma < 0))) { + stop2("sigma must be non-negative.") + } + if (isTRUE(any(beta < 0))) { + stop2("beta must be non-negative.") + } + mu <- mu - beta + rnorm(n, mean = mu, sd = sigma) + rexp(n, rate = 1 / beta) +} + +#' The Frechet Distribution +#' +#' Density, distribution function, quantile function and random generation +#' for the Frechet distribution with location \code{loc}, scale \code{scale}, +#' and shape \code{shape}. +#' +#' @name Frechet +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param loc Vector of locations. +#' @param scale Vector of scales. +#' @param shape Vector of shapes. +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @export +dfrechet <- function(x, loc = 0, scale = 1, shape = 1, log = FALSE) { + if (isTRUE(any(scale <= 0))) { + stop2("Argument 'scale' must be positive.") + } + if (isTRUE(any(shape <= 0))) { + stop2("Argument 'shape' must be positive.") + } + x <- (x - loc) / scale + args <- nlist(x, loc, scale, shape) + args <- do_call(expand, args) + out <- with(args, + log(shape / scale) - (1 + shape) * log(x) - x^(-shape) + ) + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname Frechet +#' @export +pfrechet <- function(q, loc = 0, scale = 1, shape = 1, + lower.tail = TRUE, log.p = FALSE) { + if (isTRUE(any(scale <= 0))) { + stop2("Argument 'scale' must be positive.") + } + if (isTRUE(any(shape <= 0))) { + stop2("Argument 'shape' must be positive.") + } + q <- pmax((q - loc) / scale, 0) + out <- exp(-q^(-shape)) + if (!lower.tail) { + out <- 1 - out + } + if (log.p) { + out <- log(out) + } + out +} + +#' @rdname Frechet +#' @export +qfrechet <- function(p, loc = 0, scale = 1, shape = 1, + lower.tail = TRUE, log.p = FALSE) { + if (isTRUE(any(p <= 0)) || isTRUE(any(p >= 1))) { + stop("'p' must contain probabilities in (0,1)") + } + if (isTRUE(any(scale <= 0))) { + stop2("Argument 'scale' must be positive.") + } + if (isTRUE(any(shape <= 0))) { + stop2("Argument 'shape' must be positive.") + } + if (log.p) { + p <- exp(p) + } + if (!lower.tail) { + p <- 1 - p + } + loc + scale * (-log(p))^(-1/shape) +} + +#' @rdname Frechet +#' @export +rfrechet <- function(n, loc = 0, scale = 1, shape = 1) { + if (isTRUE(any(scale <= 0))) { + stop2("Argument 'scale' must be positive.") + } + if (isTRUE(any(shape <= 0))) { + stop2("Argument 'shape' must be positive.") + } + loc + scale * rexp(n)^(-1 / shape) +} + +#' The Shifted Log Normal Distribution +#' +#' Density, distribution function, quantile function and random generation +#' for the shifted log normal distribution with mean \code{meanlog}, +#' standard deviation \code{sdlog}, and shift parameter \code{shift}. +#' +#' @name Shifted_Lognormal +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param meanlog Vector of means. +#' @param sdlog Vector of standard deviations. +#' @param shift Vector of shifts. +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @export +dshifted_lnorm <- function(x, meanlog = 0, sdlog = 1, shift = 0, log = FALSE) { + args <- nlist(dist = "lnorm", x, shift, meanlog, sdlog, log) + do_call(dshifted, args) +} + +#' @rdname Shifted_Lognormal +#' @export +pshifted_lnorm <- function(q, meanlog = 0, sdlog = 1, shift = 0, + lower.tail = TRUE, log.p = FALSE) { + args <- nlist(dist = "lnorm", q, shift, meanlog, sdlog, lower.tail, log.p) + do_call(pshifted, args) +} + +#' @rdname Shifted_Lognormal +#' @export +qshifted_lnorm <- function(p, meanlog = 0, sdlog = 1, shift = 0, + lower.tail = TRUE, log.p = FALSE) { + args <- nlist(dist = "lnorm", p, shift, meanlog, sdlog, lower.tail, log.p) + do_call(qshifted, args) +} + +#' @rdname Shifted_Lognormal +#' @export +rshifted_lnorm <- function(n, meanlog = 0, sdlog = 1, shift = 0) { + args <- nlist(dist = "lnorm", n, shift, meanlog, sdlog) + do_call(rshifted, args) +} + +#' The Inverse Gaussian Distribution +#' +#' Density, distribution function, and random generation +#' for the inverse Gaussian distribution with location \code{mu}, +#' and shape \code{shape}. +#' +#' @name InvGaussian +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param mu Vector of locations. +#' @param shape Vector of shapes. +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @export +dinv_gaussian <- function(x, mu = 1, shape = 1, log = FALSE) { + if (isTRUE(any(mu <= 0))) { + stop2("Argument 'mu' must be positive.") + } + if (isTRUE(any(shape <= 0))) { + stop2("Argument 'shape' must be positive.") + } + args <- nlist(x, mu, shape) + args <- do_call(expand, args) + out <- with(args, + 0.5 * log(shape / (2 * pi)) - + 1.5 * log(x) - 0.5 * shape * (x - mu)^2 / (x * mu^2) + ) + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname InvGaussian +#' @export +pinv_gaussian <- function(q, mu = 1, shape = 1, lower.tail = TRUE, + log.p = FALSE) { + if (isTRUE(any(mu <= 0))) { + stop2("Argument 'mu' must be positive.") + } + if (isTRUE(any(shape <= 0))) { + stop2("Argument 'shape' must be positive.") + } + args <- nlist(q, mu, shape) + args <- do_call(expand, args) + out <- with(args, + pnorm(sqrt(shape / q) * (q / mu - 1)) + + exp(2 * shape / mu) * pnorm(-sqrt(shape / q) * (q / mu + 1)) + ) + if (!lower.tail) { + out <- 1 - out + } + if (log.p) { + out <- log(out) + } + out +} + +#' @rdname InvGaussian +#' @export +rinv_gaussian <- function(n, mu = 1, shape = 1) { + # create random numbers for the inverse gaussian distribution + # Args: + # Args: see dinv_gaussian + if (isTRUE(any(mu <= 0))) { + stop2("Argument 'mu' must be positive.") + } + if (isTRUE(any(shape <= 0))) { + stop2("Argument 'shape' must be positive.") + } + args <- nlist(mu, shape, length = n) + args <- do_call(expand, args) + # algorithm from wikipedia + args$y <- rnorm(n)^2 + args$x <- with(args, + mu + (mu^2 * y) / (2 * shape) - mu / (2 * shape) * + sqrt(4 * mu * shape * y + mu^2 * y^2) + ) + args$z <- runif(n) + with(args, ifelse(z <= mu / (mu + x), x, mu^2 / x)) +} + +#' The Beta-binomial Distribution +#' +#' Cumulative density & mass functions, and random number generation for the +#' Beta-binomial distribution using the following re-parameterisation of the +#' \href{https://mc-stan.org/docs/2_29/functions-reference/beta-binomial-distribution.html}{Stan +#' Beta-binomial definition}: +#' \itemize{ +#' \item{\code{mu = alpha * beta}} mean probability of trial success. +#' \item{\code{phi = (1 - mu) * beta}} precision or over-dispersion, component. +#' } +#' +#' @name BetaBinomial +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param size Vector of number of trials (zero or more). +#' @param mu Vector of means. +#' @param phi Vector of precisions. +#' +#' @export +dbeta_binomial <- function(x, size, mu, phi, log = FALSE) { + require_package("extraDistr") + alpha <- mu * phi + beta <- (1 - mu) * phi + extraDistr::dbbinom(x, size, alpha = alpha, beta = beta, log = log) +} + +#' @rdname BetaBinomial +#' @export +pbeta_binomial <- function(q, size, mu, phi, lower.tail = TRUE, log.p = FALSE) { + require_package("extraDistr") + alpha <- mu * phi + beta <- (1 - mu) * phi + extraDistr::pbbinom(q, size, alpha = alpha, beta = beta, + lower.tail = lower.tail, log.p = log.p) +} + +#' @rdname BetaBinomial +#' @export +rbeta_binomial <- function(n, size, mu, phi) { + # beta location-scale probabilities + probs <- rbeta(n, mu * phi, (1 - mu) * phi) + # binomial draws + rbinom(n, size = size, prob = probs) +} + +#' The Generalized Extreme Value Distribution +#' +#' Density, distribution function, and random generation +#' for the generalized extreme value distribution with +#' location \code{mu}, scale \code{sigma} and shape \code{xi}. +#' +#' @name GenExtremeValue +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param mu Vector of locations. +#' @param sigma Vector of scales. +#' @param xi Vector of shapes. +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @export +dgen_extreme_value <- function(x, mu = 0, sigma = 1, xi = 0, log = FALSE) { + if (isTRUE(any(sigma <= 0))) { + stop2("sigma bust be positive.") + } + x <- (x - mu) / sigma + args <- nlist(x, mu, sigma, xi) + args <- do_call(expand, args) + args$t <- with(args, 1 + xi * x) + out <- with(args, ifelse( + xi == 0, + -log(sigma) - x - exp(-x), + -log(sigma) - (1 + 1 / xi) * log(t) - t^(-1 / xi) + )) + if (!log) { + out <- exp(out) + } + out +} + +#' @rdname GenExtremeValue +#' @export +pgen_extreme_value <- function(q, mu = 0, sigma = 1, xi = 0, + lower.tail = TRUE, log.p = FALSE) { + if (isTRUE(any(sigma <= 0))) { + stop2("sigma bust be positive.") + } + q <- (q - mu) / sigma + args <- nlist(q, mu, sigma, xi) + args <- do_call(expand, args) + out <- with(args, ifelse( + xi == 0, + exp(-exp(-q)), + exp(-(1 + xi * q)^(-1 / xi)) + )) + if (!lower.tail) { + out <- 1 - out + } + if (log.p) { + out <- log(out) + } + out +} + +#' @rdname GenExtremeValue +#' @export +rgen_extreme_value <- function(n, mu = 0, sigma = 1, xi = 0) { + if (isTRUE(any(sigma <= 0))) { + stop2("sigma bust be positive.") + } + args <- nlist(mu, sigma, xi, length = n) + args <- do_call(expand, args) + with(args, ifelse( + xi == 0, + mu - sigma * log(rexp(n)), + mu + sigma * (rexp(n)^(-xi) - 1) / xi + )) +} + +#' The Asymmetric Laplace Distribution +#' +#' Density, distribution function, quantile function and random generation +#' for the asymmetric Laplace distribution with location \code{mu}, +#' scale \code{sigma} and asymmetry parameter \code{quantile}. +#' +#' @name AsymLaplace +#' +#' @inheritParams StudentT +#' @param x,q Vector of quantiles. +#' @param mu Vector of locations. +#' @param sigma Vector of scales. +#' @param quantile Asymmetry parameter corresponding to quantiles +#' in quantile regression (hence the name). +#' +#' @details See \code{vignette("brms_families")} for details +#' on the parameterization. +#' +#' @export +dasym_laplace <- function(x, mu = 0, sigma = 1, quantile = 0.5, + log = FALSE) { + out <- ifelse(x < mu, + yes = (quantile * (1 - quantile) / sigma) * + exp((1 - quantile) * (x - mu) / sigma), + no = (quantile * (1 - quantile) / sigma) * + exp(-quantile * (x - mu) / sigma) + ) + if (log) { + out <- log(out) + } + out +} + +#' @rdname AsymLaplace +#' @export +pasym_laplace <- function(q, mu = 0, sigma = 1, quantile = 0.5, + lower.tail = TRUE, log.p = FALSE) { + out <- ifelse(q < mu, + yes = quantile * exp((1 - quantile) * (q - mu) / sigma), + no = 1 - (1 - quantile) * exp(-quantile * (q - mu) / sigma) + ) + if (!lower.tail) { + out <- 1 - out + } + if (log.p) { + out <- log(out) + } + out +} + +#' @rdname AsymLaplace +#' @export +qasym_laplace <- function(p, mu = 0, sigma = 1, quantile = 0.5, + lower.tail = TRUE, log.p = FALSE) { + if (log.p) { + p <- exp(p) + } + if (!lower.tail) { + p <- 1 - p + } + if (length(quantile) == 1L) { + quantile <- rep(quantile, length(mu)) + } + ifelse(p < quantile, + yes = mu + ((sigma * log(p / quantile)) / (1 - quantile)), + no = mu - ((sigma * log((1 - p) / (1 - quantile))) / quantile) + ) +} + +#' @rdname AsymLaplace +#' @export +rasym_laplace <- function(n, mu = 0, sigma = 1, quantile = 0.5) { + u <- runif(n) + qasym_laplace(u, mu = mu, sigma = sigma, quantile = quantile) +} + +# The Discrete Weibull Distribution +# +# Density, distribution function, quantile function and random generation +# for the discrete Weibull distribution with location \code{mu} and +# shape \code{shape}. +# +# @name DiscreteWeibull +# +# @inheritParams StudentT +# @param mu Location parameter in the unit interval. +# @param shape Positive shape parameter. +# +# @details See \code{vignette("brms_families")} for details +# on the parameterization. +# +# @export +ddiscrete_weibull <- function(x, mu, shape, log = FALSE) { + if (isTRUE(any(mu < 0 | mu > 1))) { + stop2("mu bust be between 0 and 1.") + } + if (isTRUE(any(shape <= 0))) { + stop2("shape bust be positive.") + } + x <- round(x) + out <- mu^x^shape - mu^(x + 1)^shape + out[x < 0] <- 0 + if (log) { + out <- log(out) + } + out +} + +# @rdname DiscreteWeibull +# @export +pdiscrete_weibull <- function(x, mu, shape, lower.tail = TRUE, log.p = FALSE) { + if (isTRUE(any(mu < 0 | mu > 1))) { + stop2("mu bust be between 0 and 1.") + } + if (isTRUE(any(shape <= 0))) { + stop2("shape bust be positive.") + } + x <- round(x) + if (lower.tail) { + out <- 1 - mu^(x + 1)^shape + out[x < 0] <- 0 + } else { + out <- mu^(x + 1)^shape + out[x < 0] <- 1 + } + if (log.p) { + out <- log(out) + } + out +} + +# @rdname DiscreteWeibull +# @export +qdiscrete_weibull <- function(p, mu, shape, lower.tail = TRUE, log.p = FALSE) { + if (isTRUE(any(mu < 0 | mu > 1))) { + stop2("mu bust be between 0 and 1.") + } + if (isTRUE(any(shape <= 0))) { + stop2("shape bust be positive.") + } + if (log.p) { + p <- exp(p) + } + if (!lower.tail) { + p <- 1 - p + } + ceiling((log(1 - p) / log(mu))^(1 / shape) - 1) +} + +# @rdname DiscreteWeibull +# @export +rdiscrete_weibull <- function(n, mu, shape) { + u <- runif(n, 0, 1) + qdiscrete_weibull(u, mu, shape) +} + +# mean of the discrete weibull distribution +# @param mu location parameter +# @param shape shape parameter +# @param M maximal evaluated element of the series +# @param thres threshold for new elements at which to stop evaluation +mean_discrete_weibull <- function(mu, shape, M = 1000, thres = 0.001) { + opt_M <- ceiling(max((log(thres) / log(mu))^(1 / shape))) + if (opt_M <= M) { + M <- opt_M + } else { + # avoid the loop below running too slow + warning2( + "Approximating the mean of the 'discrete_weibull' ", + "distribution failed and results be inaccurate." + ) + } + out <- 0 + for (y in seq_len(M)) { + out <- out + mu^y^shape + } + # approximation of the residual series (see Englehart & Li, 2011) + # returns unreasonably large values presumably due to numerical issues + out +} + +# PDF of the COM-Poisson distribution +# com_poisson in brms uses the mode parameterization +dcom_poisson <- function(x, mu, shape, log = FALSE) { + x <- round(x) + log_mu <- log(mu) + log_Z <- log_Z_com_poisson(log_mu, shape) + out <- shape * (x * log_mu - lgamma(x + 1)) - log_Z + if (!log) { + out <- exp(out) + } + out +} + +# random numbers from the COM-Poisson distribution +rcom_poisson <- function(n, mu, shape, M = 10000) { + n <- check_n_rdist(n, mu, shape) + M <- as.integer(as_one_numeric(M)) + log_mu <- log(mu) + # approximating log_Z may yield too large random draws + log_Z <- log_Z_com_poisson(log_mu, shape, approx = FALSE) + u <- runif(n, 0, 1) + cdf <- exp(-log_Z) + lfac <- 0 + y <- 0 + out <- rep(0, n) + not_found <- cdf < u + while (any(not_found) && y <= M) { + y <- y + 1 + out[not_found] <- y + lfac <- lfac + log(y) + cdf <- cdf + exp(shape * (y * log_mu - lfac) - log_Z) + not_found <- cdf < u + } + if (any(not_found)) { + out[not_found] <- NA + nfailed <- sum(not_found) + warning2( + "Drawing random numbers from the 'com_poisson' ", + "distribution failed in ", nfailed, " cases." + ) + } + out +} + +# CDF of the COM-Poisson distribution +pcom_poisson <- function(x, mu, shape, lower.tail = TRUE, log.p = FALSE) { + x <- round(x) + args <- expand(x = x, mu = mu, shape = shape) + x <- args$x + mu <- args$mu + shape <- args$shape + + log_mu <- log(mu) + log_Z <- log_Z_com_poisson(log_mu, shape) + out <- rep(0, length(x)) + dim(out) <- attributes(args)$max_dim + out[x > 0] <- log1p_exp(shape * log_mu) + k <- 2 + lfac <- 0 + while (any(x >= k)) { + lfac <- lfac + log(k) + term <- shape * (k * log_mu - lfac) + out[x >= k] <- log_sum_exp(out[x >= k], term) + k <- k + 1 + } + out <- out - log_Z + out[out > 0] <- 0 + if (!lower.tail) { + out <- log1m_exp(out) + } + if (!log.p) { + out <- exp(out) + } + out +} + +# log normalizing constant of the COM Poisson distribution +# @param log_mu log location parameter +# @param shape shape parameter +# @param M maximal evaluated element of the series +# @param thres threshold for new elements at which to stop evaluation +# @param approx use a closed form approximation of the mean if appropriate? +log_Z_com_poisson <- function(log_mu, shape, M = 10000, thres = 1e-16, + approx = TRUE) { + if (isTRUE(any(shape <= 0))) { + stop2("'shape' must be positive.") + } + if (isTRUE(any(shape == Inf))) { + stop2("'shape' must be finite.") + } + approx <- as_one_logical(approx) + args <- expand(log_mu = log_mu, shape = shape) + log_mu <- args$log_mu + shape <- args$shape + + out <- rep(NA, length(log_mu)) + dim(out) <- attributes(args)$max_dim + use_poisson <- shape == 1 + if (any(use_poisson)) { + # shape == 1 implies the poisson distribution + out[use_poisson] <- exp(log_mu[use_poisson]) + } + if (approx) { + # use a closed form approximation if appropriate + use_approx <- log_mu * shape >= log(1.5) & log_mu >= log(1.5) + if (any(use_approx)) { + out[use_approx] <- log_Z_com_poisson_approx( + log_mu[use_approx], shape[use_approx] + ) + } + } + use_exact <- is.na(out) + if (any(use_exact)) { + # direct computation of the truncated series + M <- as.integer(as_one_numeric(M)) + thres <- as_one_numeric(thres) + log_thres <- log(thres) + log_mu <- log_mu[use_exact] + shape <- shape[use_exact] + # first 2 terms of the series + out_exact <- log1p_exp(shape * log_mu) + lfac <- 0 + k <- 2 + converged <- FALSE + while (!converged && k <= M) { + lfac <- lfac + log(k) + term <- shape * (k * log_mu - lfac) + out_exact <- log_sum_exp(out_exact, term) + converged <- all(term <= log_thres) + k <- k + 1 + } + out[use_exact] <- out_exact + if (!converged) { + warning2( + "Approximating the normalizing constant of the 'com_poisson' ", + "distribution failed and results may be inaccurate." + ) + } + } + out +} + +# approximate the log normalizing constant of the COM Poisson distribution +# based on doi:10.1007/s10463-017-0629-6 +log_Z_com_poisson_approx <- function(log_mu, shape) { + shape_mu <- shape * exp(log_mu) + shape2 <- shape^2 + # first 4 terms of the residual series + log_sum_resid <- log( + 1 + shape_mu^(-1) * (shape2 - 1) / 24 + + shape_mu^(-2) * (shape2 - 1) / 1152 * (shape2 + 23) + + shape_mu^(-3) * (shape2 - 1) / 414720 * + (5 * shape2^2 - 298 * shape2 + 11237) + ) + shape_mu + log_sum_resid - + ((log(2 * pi) + log_mu) * (shape - 1) / 2 + log(shape) / 2) +} + +# compute the log mean of the COM Poisson distribution +# @param mu location parameter +# @param shape shape parameter +# @param M maximal evaluated element of the series +# @param thres threshold for new elements at which to stop evaluation +# @param approx use a closed form approximation of the mean if appropriate? +mean_com_poisson <- function(mu, shape, M = 10000, thres = 1e-16, + approx = TRUE) { + if (isTRUE(any(shape <= 0))) { + stop2("'shape' must be positive.") + } + if (isTRUE(any(shape == Inf))) { + stop2("'shape' must be finite.") + } + approx <- as_one_logical(approx) + args <- expand(mu = mu, shape = shape) + mu <- args$mu + shape <- args$shape + + out <- rep(NA, length(mu)) + dim(out) <- attributes(args)$max_dim + use_poisson <- shape == 1 + if (any(use_poisson)) { + # shape == 1 implies the poisson distribution + out[use_poisson] <- mu[use_poisson] + } + if (approx) { + # use a closed form approximation if appropriate + use_approx <- mu^shape >= 1.5 & mu >= 1.5 + if (any(use_approx)) { + out[use_approx] <- mean_com_poisson_approx( + mu[use_approx], shape[use_approx] + ) + } + } + use_exact <- is.na(out) + if (any(use_exact)) { + # direct computation of the truncated series + M <- as.integer(as_one_numeric(M)) + thres <- as_one_numeric(thres) + log_thres <- log(thres) + mu <- mu[use_exact] + shape <- shape[use_exact] + log_mu <- log(mu) + # first 2 terms of the series + log_num <- shape * log_mu # numerator + log_Z <- log1p_exp(shape * log_mu) # denominator + lfac <- 0 + k <- 2 + converged <- FALSE + while (!converged && k <= M) { + log_k <- log(k) + lfac <- lfac + log_k + term <- shape * (k * log_mu - lfac) + log_num <- log_sum_exp(log_num, log_k + term) + log_Z <- log_sum_exp(log_Z, term) + converged <- all(term <= log_thres) + k <- k + 1 + } + if (!converged) { + warning2( + "Approximating the mean of the 'com_poisson' ", + "distribution failed and results may be inaccurate." + ) + } + out[use_exact] <- exp(log_num - log_Z) + } + out +} + +# approximate the mean of COM-Poisson distribution +# based on doi:10.1007/s10463-017-0629-6 +mean_com_poisson_approx <- function(mu, shape) { + term <- 1 - (shape - 1) / (2 * shape) * mu^(-1) - + (shape^2 - 1) / (24 * shape^2) * mu^(-2) - + (shape^2 - 1) / (24 * shape^3) * mu^(-3) + mu * term +} + +#' The Dirichlet Distribution +#' +#' Density function and random number generation for the dirichlet +#' distribution with shape parameter vector \code{alpha}. +#' +#' @name Dirichlet +#' +#' @inheritParams StudentT +#' @param x Matrix of quantiles. Each row corresponds to one probability vector. +#' @param alpha Matrix of positive shape parameters. Each row corresponds to one +#' probability vector. +#' +#' @details See \code{vignette("brms_families")} for details on the +#' parameterization. +#' +#' @export +ddirichlet <- function(x, alpha, log = FALSE) { + log <- as_one_logical(log) + if (!is.matrix(x)) { + x <- matrix(x, nrow = 1) + } + if (!is.matrix(alpha)) { + alpha <- matrix(alpha, nrow(x), length(alpha), byrow = TRUE) + } + if (nrow(x) == 1L && nrow(alpha) > 1L) { + x <- repl(x, nrow(alpha)) + x <- do_call(rbind, x) + } else if (nrow(x) > 1L && nrow(alpha) == 1L) { + alpha <- repl(alpha, nrow(x)) + alpha <- do_call(rbind, alpha) + } + if (isTRUE(any(x < 0))) { + stop2("x must be non-negative.") + } + if (!is_equal(rowSums(x), rep(1, nrow(x)))) { + stop2("x must sum to 1 per row.") + } + if (isTRUE(any(alpha <= 0))) { + stop2("alpha must be positive.") + } + out <- lgamma(rowSums(alpha)) - rowSums(lgamma(alpha)) + + rowSums((alpha - 1) * log(x)) + if (!log) { + out <- exp(out) + } + return(out) +} + +#' @rdname Dirichlet +#' @export +rdirichlet <- function(n, alpha) { + n <- as_one_numeric(n) + if (!is.matrix(alpha)) { + alpha <- matrix(alpha, nrow = 1) + } + if (prod(dim(alpha)) == 0) { + stop2("alpha should be non-empty.") + } + if (isTRUE(any(alpha <= 0))) { + stop2("alpha must be positive.") + } + if (n == 1) { + n <- nrow(alpha) + } + if (n > nrow(alpha)) { + alpha <- matrix(alpha, nrow = n, ncol = ncol(alpha), byrow = TRUE) + } + x <- matrix(rgamma(ncol(alpha) * n, alpha), ncol = ncol(alpha)) + x / rowSums(x) +} + +#' The Wiener Diffusion Model Distribution +#' +#' Density function and random generation for the Wiener +#' diffusion model distribution with boundary separation \code{alpha}, +#' non-decision time \code{tau}, bias \code{beta} and +#' drift rate \code{delta}. +#' +#' @name Wiener +#' +#' @inheritParams StudentT +#' @param alpha Boundary separation parameter. +#' @param tau Non-decision time parameter. +#' @param beta Bias parameter. +#' @param delta Drift rate parameter. +#' @param resp Response: \code{"upper"} or \code{"lower"}. +#' If no character vector, it is coerced to logical +#' where \code{TRUE} indicates \code{"upper"} and +#' \code{FALSE} indicates \code{"lower"}. +#' @param types Which types of responses to return? By default, +#' return both the response times \code{"q"} and the dichotomous +#' responses \code{"resp"}. If either \code{"q"} or \code{"resp"}, +#' return only one of the two types. +#' @param backend Name of the package to use as backend for the computations. +#' Either \code{"Rwiener"} (the default) or \code{"rtdists"}. +#' Can be set globally for the current \R session via the +#' \code{"wiener_backend"} option (see \code{\link{options}}). +#' +#' @details +#' These are wrappers around functions of the \pkg{RWiener} or \pkg{rtdists} +#' package (depending on the chosen \code{backend}). See +#' \code{vignette("brms_families")} for details on the parameterization. +#' +#' @seealso \code{\link[RWiener:wienerdist]{wienerdist}}, +#' \code{\link[rtdists:Diffusion]{Diffusion}} +#' +#' @export +dwiener <- function(x, alpha, tau, beta, delta, resp = 1, log = FALSE, + backend = getOption("wiener_backend", "Rwiener")) { + alpha <- as.numeric(alpha) + tau <- as.numeric(tau) + beta <- as.numeric(beta) + delta <- as.numeric(delta) + if (!is.character(resp)) { + resp <- ifelse(resp, "upper", "lower") + } + log <- as_one_logical(log) + backend <- match.arg(backend, c("Rwiener", "rtdists")) + .dwiener <- paste0(".dwiener_", backend) + args <- nlist(x, alpha, tau, beta, delta, resp) + args <- as.list(do_call(expand, args)) + args$log <- log + do_call(.dwiener, args) +} + +# dwiener using Rwiener as backend +.dwiener_Rwiener <- function(x, alpha, tau, beta, delta, resp, log) { + require_package("RWiener") + .dwiener <- Vectorize( + RWiener::dwiener, + c("q", "alpha", "tau", "beta", "delta", "resp") + ) + args <- nlist(q = x, alpha, tau, beta, delta, resp, give_log = log) + do_call(.dwiener, args) +} + +# dwiener using rtdists as backend +.dwiener_rtdists <- function(x, alpha, tau, beta, delta, resp, log) { + require_package("rtdists") + args <- list( + rt = x, response = resp, a = alpha, + t0 = tau, z = beta * alpha, v = delta + ) + out <- do_call(rtdists::ddiffusion, args) + if (log) { + out <- log(out) + } + out +} + +#' @rdname Wiener +#' @export +rwiener <- function(n, alpha, tau, beta, delta, types = c("q", "resp"), + backend = getOption("wiener_backend", "Rwiener")) { + n <- as_one_numeric(n) + alpha <- as.numeric(alpha) + tau <- as.numeric(tau) + beta <- as.numeric(beta) + delta <- as.numeric(delta) + types <- match.arg(types, several.ok = TRUE) + backend <- match.arg(backend, c("Rwiener", "rtdists")) + .rwiener <- paste0(".rwiener_", backend) + args <- nlist(n, alpha, tau, beta, delta, types) + do_call(.rwiener, args) +} + +# rwiener using Rwiener as backend +.rwiener_Rwiener <- function(n, alpha, tau, beta, delta, types) { + require_package("RWiener") + max_len <- max(lengths(list(alpha, tau, beta, delta))) + if (max_len > 1L) { + if (!n %in% c(1, max_len)) { + stop2("Can only sample exactly once for each condition.") + } + n <- 1 + } + # helper function to return a numeric vector instead + # of a data.frame with two columns as for RWiener::rwiener + .rwiener_num <- function(n, alpha, tau, beta, delta, types) { + out <- RWiener::rwiener(n, alpha, tau, beta, delta) + out$resp <- ifelse(out$resp == "upper", 1, 0) + if (length(types) == 1L) { + out <- out[[types]] + } + out + } + # vectorized version of .rwiener_num + .rwiener <- function(...) { + fun <- Vectorize( + .rwiener_num, + c("alpha", "tau", "beta", "delta"), + SIMPLIFY = FALSE + ) + do_call(rbind, fun(...)) + } + args <- nlist(n, alpha, tau, beta, delta, types) + do_call(.rwiener, args) +} + +# rwiener using rtdists as backend +.rwiener_rtdists <- function(n, alpha, tau, beta, delta, types) { + require_package("rtdists") + max_len <- max(lengths(list(alpha, tau, beta, delta))) + if (max_len > 1L) { + if (!n %in% c(1, max_len)) { + stop2("Can only sample exactly once for each condition.") + } + n <- max_len + } + out <- rtdists::rdiffusion( + n, a = alpha, t0 = tau, z = beta * alpha, v = delta + ) + # TODO: use column names of rtdists in the output? + names(out)[names(out) == "rt"] <- "q" + names(out)[names(out) == "response"] <- "resp" + out$resp <- ifelse(out$resp == "upper", 1, 0) + if (length(types) == 1L) { + out <- out[[types]] + } + out +} + +# density of the cox proportional hazards model +# @param x currently ignored as the information is passed +# via 'bhaz' and 'cbhaz'. Before exporting the cox distribution +# functions, this needs to be refactored so that x is actually used +# @param mu positive location parameter +# @param bhaz baseline hazard +# @param cbhaz cumulative baseline hazard +dcox <- function(x, mu, bhaz, cbhaz, log = FALSE) { + out <- hcox(x, mu, bhaz, cbhaz, log = TRUE) + + pcox(x, mu, bhaz, cbhaz, lower.tail = FALSE, log.p = TRUE) + if (!log) { + out <- exp(out) + } + out +} + +# hazard function of the cox model +hcox <- function(x, mu, bhaz, cbhaz, log = FALSE) { + out <- log(bhaz) + log(mu) + if (!log) { + out <- exp(out) + } + out +} + +# distribution function of the cox model +pcox <- function(q, mu, bhaz, cbhaz, lower.tail = TRUE, log.p = FALSE) { + log_surv <- -cbhaz * mu + if (lower.tail) { + if (log.p) { + out <- log1m_exp(log_surv) + } else { + out <- 1 - exp(log_surv) + } + } else { + if (log.p) { + out <- log_surv + } else { + out <- exp(log_surv) + } + } + out +} + +#' Zero-Inflated Distributions +#' +#' Density and distribution functions for zero-inflated distributions. +#' +#' @name ZeroInflated +#' +#' @inheritParams StudentT +#' @param zi zero-inflation probability +#' @param mu,lambda location parameter +#' @param shape,shape1,shape2 shape parameter +#' @param phi precision parameter +#' @param size number of trials +#' @param prob probability of success on each trial +#' +#' @details +#' The density of a zero-inflated distribution can be specified as follows. +#' If \eqn{x = 0} set \eqn{f(x) = \theta + (1 - \theta) * g(0)}. +#' Else set \eqn{f(x) = (1 - \theta) * g(x)}, +#' where \eqn{g(x)} is the density of the non-zero-inflated part. +NULL + +#' @rdname ZeroInflated +#' @export +dzero_inflated_poisson <- function(x, lambda, zi, log = FALSE) { + pars <- nlist(lambda) + .dzero_inflated(x, "pois", zi, pars, log) +} + +#' @rdname ZeroInflated +#' @export +pzero_inflated_poisson <- function(q, lambda, zi, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(lambda) + .pzero_inflated(q, "pois", zi, pars, lower.tail, log.p) +} + +#' @rdname ZeroInflated +#' @export +dzero_inflated_negbinomial <- function(x, mu, shape, zi, log = FALSE) { + pars <- nlist(mu, size = shape) + .dzero_inflated(x, "nbinom", zi, pars, log) +} + +#' @rdname ZeroInflated +#' @export +pzero_inflated_negbinomial <- function(q, mu, shape, zi, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(mu, size = shape) + .pzero_inflated(q, "nbinom", zi, pars, lower.tail, log.p) +} + +#' @rdname ZeroInflated +#' @export +dzero_inflated_binomial <- function(x, size, prob, zi, log = FALSE) { + pars <- nlist(size, prob) + .dzero_inflated(x, "binom", zi, pars, log) +} + +#' @rdname ZeroInflated +#' @export +pzero_inflated_binomial <- function(q, size, prob, zi, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(size, prob) + .pzero_inflated(q, "binom", zi, pars, lower.tail, log.p) +} + +#' @rdname ZeroInflated +#' @export +dzero_inflated_beta_binomial <- function(x, size, mu, phi, zi, log = FALSE) { + pars <- nlist(size, mu, phi) + .dzero_inflated(x, "beta_binomial", zi, pars, log) +} + +#' @rdname ZeroInflated +#' @export +pzero_inflated_beta_binomial <- function(q, size, mu, phi, zi, + lower.tail = TRUE, log.p = FALSE) { + pars <- nlist(size, mu, phi) + .pzero_inflated(q, "beta_binomial", zi, pars, lower.tail, log.p) +} + +#' @rdname ZeroInflated +#' @export +dzero_inflated_beta <- function(x, shape1, shape2, zi, log = FALSE) { + pars <- nlist(shape1, shape2) + # zi_beta is technically a hurdle model + .dhurdle(x, "beta", zi, pars, log, type = "real") +} + +#' @rdname ZeroInflated +#' @export +pzero_inflated_beta <- function(q, shape1, shape2, zi, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(shape1, shape2) + # zi_beta is technically a hurdle model + .phurdle(q, "beta", zi, pars, lower.tail, log.p, type = "real") +} + +# @rdname ZeroInflated +# @export +dzero_inflated_asym_laplace <- function(x, mu, sigma, quantile, zi, + log = FALSE) { + pars <- nlist(mu, sigma, quantile) + # zi_asym_laplace is technically a hurdle model + .dhurdle(x, "asym_laplace", zi, pars, log, type = "real") +} + +# @rdname ZeroInflated +# @export +pzero_inflated_asym_laplace <- function(q, mu, sigma, quantile, zi, + lower.tail = TRUE, log.p = FALSE) { + pars <- nlist(mu, sigma, quantile) + # zi_asym_laplace is technically a hurdle model + .phurdle(q, "asym_laplace", zi, pars, lower.tail, log.p, + type = "real", lb = -Inf, ub = Inf) +} + +# density of a zero-inflated distribution +# @param dist name of the distribution +# @param zi bernoulli zero-inflated parameter +# @param pars list of parameters passed to pdf +.dzero_inflated <- function(x, dist, zi, pars, log) { + stopifnot(is.list(pars)) + dist <- as_one_character(dist) + log <- as_one_logical(log) + args <- expand(dots = c(nlist(x, zi), pars)) + x <- args$x + zi <- args$zi + pars <- args[names(pars)] + pdf <- paste0("d", dist) + out <- ifelse(x == 0, + log(zi + (1 - zi) * do_call(pdf, c(0, pars))), + log(1 - zi) + do_call(pdf, c(list(x), pars, log = TRUE)) + ) + if (!log) { + out <- exp(out) + } + out +} + +# CDF of a zero-inflated distribution +# @param dist name of the distribution +# @param zi bernoulli zero-inflated parameter +# @param pars list of parameters passed to pdf +# @param lb lower bound of the conditional distribution +# @param ub upper bound of the conditional distribution +.pzero_inflated <- function(q, dist, zi, pars, lower.tail, log.p, + lb = 0, ub = Inf) { + stopifnot(is.list(pars)) + dist <- as_one_character(dist) + lower.tail <- as_one_logical(lower.tail) + log.p <- as_one_logical(log.p) + lb <- as_one_numeric(lb) + ub <- as_one_numeric(ub) + args <- expand(dots = c(nlist(q, zi), pars)) + q <- args$q + zi <- args$zi + pars <- args[names(pars)] + cdf <- paste0("p", dist) + # compute log CCDF values + out <- log(1 - zi) + + do_call(cdf, c(list(q), pars, lower.tail = FALSE, log.p = TRUE)) + # take the limits of the distribution into account + out <- ifelse(q < lb, 0, out) + out <- ifelse(q > ub, -Inf, out) + if (lower.tail) { + out <- 1 - exp(out) + if (log.p) { + out <- log(out) + } + } else { + if (!log.p) { + out <- exp(out) + } + } + out +} + +#' Hurdle Distributions +#' +#' Density and distribution functions for hurdle distributions. +#' +#' @name Hurdle +#' +#' @inheritParams StudentT +#' @param hu hurdle probability +#' @param mu,lambda location parameter +#' @param shape shape parameter +#' @param sigma,scale scale parameter +#' +#' @details +#' The density of a hurdle distribution can be specified as follows. +#' If \eqn{x = 0} set \eqn{f(x) = \theta}. Else set +#' \eqn{f(x) = (1 - \theta) * g(x) / (1 - G(0))} +#' where \eqn{g(x)} and \eqn{G(x)} are the density and distribution +#' function of the non-hurdle part, respectively. +NULL + +#' @rdname Hurdle +#' @export +dhurdle_poisson <- function(x, lambda, hu, log = FALSE) { + pars <- nlist(lambda) + .dhurdle(x, "pois", hu, pars, log, type = "int") +} + +#' @rdname Hurdle +#' @export +phurdle_poisson <- function(q, lambda, hu, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(lambda) + .phurdle(q, "pois", hu, pars, lower.tail, log.p, type = "int") +} + +#' @rdname Hurdle +#' @export +dhurdle_negbinomial <- function(x, mu, shape, hu, log = FALSE) { + pars <- nlist(mu, size = shape) + .dhurdle(x, "nbinom", hu, pars, log, type = "int") +} + +#' @rdname Hurdle +#' @export +phurdle_negbinomial <- function(q, mu, shape, hu, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(mu, size = shape) + .phurdle(q, "nbinom", hu, pars, lower.tail, log.p, type = "int") +} + +#' @rdname Hurdle +#' @export +dhurdle_gamma <- function(x, shape, scale, hu, log = FALSE) { + pars <- nlist(shape, scale) + .dhurdle(x, "gamma", hu, pars, log, type = "real") +} + +#' @rdname Hurdle +#' @export +phurdle_gamma <- function(q, shape, scale, hu, lower.tail = TRUE, + log.p = FALSE) { + pars <- nlist(shape, scale) + .phurdle(q, "gamma", hu, pars, lower.tail, log.p, type = "real") +} + +#' @rdname Hurdle +#' @export +dhurdle_lognormal <- function(x, mu, sigma, hu, log = FALSE) { + pars <- list(meanlog = mu, sdlog = sigma) + .dhurdle(x, "lnorm", hu, pars, log, type = "real") +} + +#' @rdname Hurdle +#' @export +phurdle_lognormal <- function(q, mu, sigma, hu, lower.tail = TRUE, + log.p = FALSE) { + pars <- list(meanlog = mu, sdlog = sigma) + .phurdle(q, "lnorm", hu, pars, lower.tail, log.p, type = "real") +} + +# density of a hurdle distribution +# @param dist name of the distribution +# @param hu bernoulli hurdle parameter +# @param pars list of parameters passed to pdf +# @param type support of distribution (int or real) +.dhurdle <- function(x, dist, hu, pars, log, type) { + stopifnot(is.list(pars)) + dist <- as_one_character(dist) + log <- as_one_logical(log) + type <- match.arg(type, c("int", "real")) + args <- expand(dots = c(nlist(x, hu), pars)) + x <- args$x + hu <- args$hu + pars <- args[names(pars)] + pdf <- paste0("d", dist) + if (type == "int") { + lccdf0 <- log(1 - do_call(pdf, c(0, pars))) + } else { + lccdf0 <- 0 + } + out <- ifelse(x == 0, + log(hu), + log(1 - hu) + do_call(pdf, c(list(x), pars, log = TRUE)) - lccdf0 + ) + if (!log) { + out <- exp(out) + } + out +} + +# CDF of a hurdle distribution +# @param dist name of the distribution +# @param hu bernoulli hurdle parameter +# @param pars list of parameters passed to pdf +# @param type support of distribution (int or real) +# @param lb lower bound of the conditional distribution +# @param ub upper bound of the conditional distribution +.phurdle <- function(q, dist, hu, pars, lower.tail, log.p, type, + lb = 0, ub = Inf) { + stopifnot(is.list(pars)) + dist <- as_one_character(dist) + lower.tail <- as_one_logical(lower.tail) + log.p <- as_one_logical(log.p) + type <- match.arg(type, c("int", "real")) + lb <- as_one_numeric(lb) + ub <- as_one_numeric(ub) + args <- expand(dots = c(nlist(q, hu), pars)) + q <- args$q + hu <- args$hu + pars <- args[names(pars)] + cdf <- paste0("p", dist) + # compute log CCDF values + out <- log(1 - hu) + + do_call(cdf, c(list(q), pars, lower.tail = FALSE, log.p = TRUE)) + if (type == "int") { + pdf <- paste0("d", dist) + out <- out - log(1 - do_call(pdf, c(0, pars))) + } + out <- ifelse(q < 0, log_sum_exp(out, log(hu)), out) + # take the limits of the distribution into account + out <- ifelse(q < lb, 0, out) + out <- ifelse(q > ub, -Inf, out) + if (lower.tail) { + out <- 1 - exp(out) + if (log.p) { + out <- log(out) + } + } else { + if (!log.p) { + out <- exp(out) + } + } + out +} + +# density of the categorical distribution with the softmax transform +# @param x positive integers not greater than ncat +# @param eta the linear predictor (of length or ncol ncat) +# @param log return values on the log scale? +dcategorical <- function(x, eta, log = FALSE) { + if (is.null(dim(eta))) { + eta <- matrix(eta, nrow = 1) + } + if (length(dim(eta)) != 2L) { + stop2("eta must be a numeric vector or matrix.") + } + out <- inv_link_categorical(eta, log = log, refcat = NULL) + out[, x, drop = FALSE] +} + +# generic inverse link function for the categorical family +# +# @param x Matrix (S x `ncat` or S x `ncat - 1` (depending on `refcat_obj`), +# with S denoting the number of posterior draws and `ncat` denoting the number +# of response categories) with values of `eta` for one observation (see +# dcategorical()) or an array (S x N x `ncat` or S x N x `ncat - 1` (depending +# on `refcat_obj`)) containing the same values as the matrix just described, +# but for N observations. +# @param refcat Integer indicating the reference category to be inserted in 'x'. +# If NULL, `x` is not modified at all. +# @param log Logical (length 1) indicating whether to log the return value. +# +# @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the +# number of posterior draws and `ncat` denoting the number of response +# categories) containing the values of the inverse-link function applied to +# `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same +# values as the matrix just described, but for N observations. +inv_link_categorical <- function(x, refcat = 1, log = FALSE) { + if (!is.null(refcat)) { + x <- insert_refcat(x, refcat = refcat) + } + if (log) { + out <- log_softmax(x) + } else { + out <- softmax(x) + } + out +} + +# generic link function for the categorical family +# +# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and +# `ncat` denoting the number of response categories) of probabilities for the +# response categories or an array (S x N x `ncat`) containing the same values +# as the matrix just described, but for N observations. +# @param refcat Numeric (length 1) giving the index of the reference category. +# @param return_refcat Logical (length 1) indicating whether to include the +# reference category in the return value. +# +# @return If `x` is a matrix, then a matrix (S x `ncat` or S x `ncat - 1` +# (depending on `return_refcat`), with S denoting the number of posterior +# draws and `ncat` denoting the number of response categories) containing the +# values of the link function applied to `x`. If `x` is an array, then an +# array (S x N x `ncat` or S x N x `ncat - 1` (depending on `return_refcat`)) +# containing the same values as the matrix just described, but for N +# observations. +link_categorical <- function(x, refcat = 1, return_refcat = FALSE) { + ndim <- length(dim(x)) + marg_noncat <- seq_along(dim(x))[-ndim] + if (return_refcat) { + x_tosweep <- x + } else { + x_tosweep <- slice(x, ndim, -refcat, drop = FALSE) + } + log(sweep( + x_tosweep, + MARGIN = marg_noncat, + STATS = slice(x, ndim, refcat), + FUN = "/" + )) +} + +# CDF of the categorical distribution with the softmax transform +# @param q positive integers not greater than ncat +# @param eta the linear predictor (of length or ncol ncat) +# @param log.p return values on the log scale? +pcategorical <- function(q, eta, log.p = FALSE) { + p <- dcategorical(seq_len(max(q)), eta = eta) + out <- cblapply(q, function(j) rowSums(p[, 1:j, drop = FALSE])) + if (log.p) { + out <- log(out) + } + out +} + +# density of the multinomial distribution with the softmax transform +# @param x positive integers not greater than ncat +# @param eta the linear predictor (of length or ncol ncat) +# @param log return values on the log scale? +dmultinomial <- function(x, eta, log = FALSE) { + if (is.null(dim(eta))) { + eta <- matrix(eta, nrow = 1) + } + if (length(dim(eta)) != 2L) { + stop2("eta must be a numeric vector or matrix.") + } + log_prob <- log_softmax(eta) + size <- sum(x) + x <- data2draws(x, dim = dim(eta)) + out <- lgamma(size + 1) + rowSums(x * log_prob - lgamma(x + 1)) + if (!log) { + out <- exp(out) + } + out +} + +# density of the cumulative distribution +# +# @param x Integer vector containing response category indices to return the +# "densities" (probability masses) for. +# @param eta Vector (length S, with S denoting the number of posterior draws) of +# linear predictor draws. +# @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior +# draws and `ncat` denoting the number of response categories) of threshold +# draws. +# @param disc Vector (length S, with S denoting the number of posterior draws, +# or length 1 for recycling) of discrimination parameter draws. +# @param link Character vector (length 1) giving the name of the link function. +# +# @return A matrix (S x `length(x)`) containing the values of the inverse-link +# function applied to `disc * (thres - eta)`. +dcumulative <- function(x, eta, thres, disc = 1, link = "logit") { + eta <- disc * (thres - eta) + if (link == "identity") { + out <- eta + } else { + out <- inv_link_cumulative(eta, link = link) + } + out[, x, drop = FALSE] +} + +# generic inverse link function for the cumulative family +# +# @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws +# and `ncat` denoting the number of response categories) with values of +# `disc * (thres - eta)` for one observation (see dcumulative()) or an array +# (S x N x `ncat - 1`) containing the same values as the matrix just +# described, but for N observations. +# @param link Character vector (length 1) giving the name of the link function. +# +# @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the +# number of posterior draws and `ncat` denoting the number of response +# categories) containing the values of the inverse-link function applied to +# `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same +# values as the matrix just described, but for N observations. +inv_link_cumulative <- function(x, link) { + x <- inv_link(x, link) + ndim <- length(dim(x)) + dim_noncat <- dim(x)[-ndim] + ones_arr <- array(1, dim = c(dim_noncat, 1)) + zeros_arr <- array(0, dim = c(dim_noncat, 1)) + abind::abind(x, ones_arr) - abind::abind(zeros_arr, x) +} + +# generic link function for the cumulative family +# +# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and +# `ncat` denoting the number of response categories) of probabilities for the +# response categories or an array (S x N x `ncat`) containing the same values +# as the matrix just described, but for N observations. +# @param link Character string (length 1) giving the name of the link function. +# +# @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the +# number of posterior draws and `ncat` denoting the number of response +# categories) containing the values of the link function applied to `x`. If +# `x` is an array, then an array (S x N x `ncat - 1`) containing the same +# values as the matrix just described, but for N observations. +link_cumulative <- function(x, link) { + ndim <- length(dim(x)) + ncat <- dim(x)[ndim] + dim_noncat <- dim(x)[-ndim] + nthres <- dim(x)[ndim] - 1 + marg_noncat <- seq_along(dim(x))[-ndim] + dim_t <- c(nthres, dim_noncat) + x <- apply(slice(x, ndim, -ncat, drop = FALSE), marg_noncat, cumsum) + x <- aperm(array(x, dim = dim_t), perm = c(marg_noncat + 1, 1)) + link(x, link) +} + +# density of the sratio distribution +# +# @param x Integer vector containing response category indices to return the +# "densities" (probability masses) for. +# @param eta Vector (length S, with S denoting the number of posterior draws) of +# linear predictor draws. +# @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior +# draws and `ncat` denoting the number of response categories) of threshold +# draws. +# @param disc Vector (length S, with S denoting the number of posterior draws, +# or length 1 for recycling) of discrimination parameter draws. +# @param link Character vector (length 1) giving the name of the link function. +# +# @return A matrix (S x `length(x)`) containing the values of the inverse-link +# function applied to `disc * (thres - eta)`. +dsratio <- function(x, eta, thres, disc = 1, link = "logit") { + eta <- disc * (thres - eta) + if (link == "identity") { + out <- eta + } else { + out <- inv_link_sratio(eta, link = link) + } + out[, x, drop = FALSE] +} + +# generic inverse link function for the sratio family +# +# @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws +# and `ncat` denoting the number of response categories) with values of +# `disc * (thres - eta)` for one observation (see dsratio()) or an array +# (S x N x `ncat - 1`) containing the same values as the matrix just +# described, but for N observations. +# @param link Character vector (length 1) giving the name of the link function. +# +# @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the +# number of posterior draws and `ncat` denoting the number of response +# categories) containing the values of the inverse-link function applied to +# `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same +# values as the matrix just described, but for N observations. +inv_link_sratio <- function(x, link) { + x <- inv_link(x, link) + ndim <- length(dim(x)) + dim_noncat <- dim(x)[-ndim] + nthres <- dim(x)[ndim] + marg_noncat <- seq_along(dim(x))[-ndim] + ones_arr <- array(1, dim = c(dim_noncat, 1)) + dim_t <- c(nthres, dim_noncat) + Sx_cumprod <- aperm( + array(apply(1 - x, marg_noncat, cumprod), dim = dim_t), + perm = c(marg_noncat + 1, 1) + ) + abind::abind(x, ones_arr) * abind::abind(ones_arr, Sx_cumprod) +} + +# generic link function for the sratio family +# +# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and +# `ncat` denoting the number of response categories) of probabilities for the +# response categories or an array (S x N x `ncat`) containing the same values +# as the matrix just described, but for N observations. +# @param link Character string (length 1) giving the name of the link function. +# +# @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the +# number of posterior draws and `ncat` denoting the number of response +# categories) containing the values of the link function applied to `x`. If +# `x` is an array, then an array (S x N x `ncat - 1`) containing the same +# values as the matrix just described, but for N observations. +link_sratio <- function(x, link) { + ndim <- length(dim(x)) + .F_k <- function(k) { + if (k == 1) { + prev_res <- list(F_k = NULL, S_km1_prod = 1) + } else { + prev_res <- .F_k(k - 1) + } + F_k <- slice(x, ndim, k, drop = FALSE) / prev_res$S_km1_prod + .out <- list( + F_k = abind::abind(prev_res$F_k, F_k), + S_km1_prod = prev_res$S_km1_prod * (1 - F_k) + ) + return(.out) + } + x <- .F_k(dim(x)[ndim] - 1)$F_k + link(x, link) +} + +# density of the cratio distribution +# +# @param x Integer vector containing response category indices to return the +# "densities" (probability masses) for. +# @param eta Vector (length S, with S denoting the number of posterior draws) of +# linear predictor draws. +# @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior +# draws and `ncat` denoting the number of response categories) of threshold +# draws. +# @param disc Vector (length S, with S denoting the number of posterior draws, +# or length 1 for recycling) of discrimination parameter draws. +# @param link Character vector (length 1) giving the name of the link function. +# +# @return A matrix (S x `length(x)`) containing the values of the inverse-link +# function applied to `disc * (thres - eta)`. +dcratio <- function(x, eta, thres, disc = 1, link = "logit") { + eta <- disc * (eta - thres) + if (link == "identity") { + out <- eta + } else { + out <- inv_link_cratio(eta, link = link) + } + out[, x, drop = FALSE] +} + +# generic inverse link function for the cratio family +# +# @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws +# and `ncat` denoting the number of response categories) with values of +# `disc * (thres - eta)` for one observation (see dcratio()) or an array +# (S x N x `ncat - 1`) containing the same values as the matrix just +# described, but for N observations. +# @param link Character vector (length 1) giving the name of the link function. +# +# @return If `x` is a matrix, then a matrix (S x `ncat`, with S denoting the +# number of posterior draws and `ncat` denoting the number of response +# categories) containing the values of the inverse-link function applied to +# `x`. If `x` is an array, then an array (S x N x `ncat`) containing the same +# values as the matrix just described, but for N observations. +inv_link_cratio <- function(x, link) { + x <- inv_link(x, link) + ndim <- length(dim(x)) + dim_noncat <- dim(x)[-ndim] + nthres <- dim(x)[ndim] + marg_noncat <- seq_along(dim(x))[-ndim] + ones_arr <- array(1, dim = c(dim_noncat, 1)) + dim_t <- c(nthres, dim_noncat) + x_cumprod <- aperm( + array(apply(x, marg_noncat, cumprod), dim = dim_t), + perm = c(marg_noncat + 1, 1) + ) + abind::abind(1 - x, ones_arr) * abind::abind(ones_arr, x_cumprod) +} + +# generic link function for the cratio family +# +# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and +# `ncat` denoting the number of response categories) of probabilities for the +# response categories or an array (S x N x `ncat`) containing the same values +# as the matrix just described, but for N observations. +# @param link Character string (length 1) giving the name of the link function. +# +# @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the +# number of posterior draws and `ncat` denoting the number of response +# categories) containing the values of the link function applied to `x`. If +# `x` is an array, then an array (S x N x `ncat - 1`) containing the same +# values as the matrix just described, but for N observations. +link_cratio <- function(x, link) { + ndim <- length(dim(x)) + .F_k <- function(k) { + if (k == 1) { + prev_res <- list(F_k = NULL, F_km1_prod = 1) + } else { + prev_res <- .F_k(k - 1) + } + F_k <- 1 - slice(x, ndim, k, drop = FALSE) / prev_res$F_km1_prod + .out <- list( + F_k = abind::abind(prev_res$F_k, F_k), + F_km1_prod = prev_res$F_km1_prod * F_k + ) + return(.out) + } + x <- .F_k(dim(x)[ndim] - 1)$F_k + link(x, link) +} + +# density of the acat distribution +# +# @param x Integer vector containing response category indices to return the +# "densities" (probability masses) for. +# @param eta Vector (length S, with S denoting the number of posterior draws) of +# linear predictor draws. +# @param thres Matrix (S x `ncat - 1`, with S denoting the number of posterior +# draws and `ncat` denoting the number of response categories) of threshold +# draws. +# @param disc Vector (length S, with S denoting the number of posterior draws, +# or length 1 for recycling) of discrimination parameter draws. +# @param link Character vector (length 1) giving the name of the link function. +# +# @return A matrix (S x `length(x)`) containing the values of the inverse-link +# function applied to `disc * (thres - eta)`. +dacat <- function(x, eta, thres, disc = 1, link = "logit") { + eta <- disc * (eta - thres) + if (link == "identity") { + out <- eta + } else { + out <- inv_link_acat(eta, link = link) + } + out[, x, drop = FALSE] +} + +# generic inverse link function for the acat family +# +# @param x Matrix (S x `ncat - 1`, with S denoting the number of posterior draws +# and `ncat` denoting the number of response categories) with values of +# `disc * (thres - eta)` (see dacat()). +# @param link Character vector (length 1) giving the name of the link function. +# +# @return A matrix (S x `ncat`, with S denoting the number of posterior draws +# and `ncat` denoting the number of response categories) containing the values +# of the inverse-link function applied to `x`. +inv_link_acat <- function(x, link) { + ndim <- length(dim(x)) + dim_noncat <- dim(x)[-ndim] + nthres <- dim(x)[ndim] + marg_noncat <- seq_along(dim(x))[-ndim] + ones_arr <- array(1, dim = c(dim_noncat, 1)) + dim_t <- c(nthres, dim_noncat) + if (link == "logit") { + # faster evaluation in this case + exp_x_cumprod <- aperm( + array(apply(exp(x), marg_noncat, cumprod), dim = dim_t), + perm = c(marg_noncat + 1, 1) + ) + out <- abind::abind(ones_arr, exp_x_cumprod) + } else { + x <- inv_link(x, link) + x_cumprod <- aperm( + array(apply(x, marg_noncat, cumprod), dim = dim_t), + perm = c(marg_noncat + 1, 1) + ) + Sx_cumprod_rev <- apply( + 1 - slice(x, ndim, rev(seq_len(nthres)), drop = FALSE), + marg_noncat, cumprod + ) + Sx_cumprod_rev <- aperm( + array(Sx_cumprod_rev, dim = dim_t), + perm = c(marg_noncat + 1, 1) + ) + Sx_cumprod_rev <- slice( + Sx_cumprod_rev, ndim, rev(seq_len(nthres)), drop = FALSE + ) + out <- abind::abind(ones_arr, x_cumprod) * + abind::abind(Sx_cumprod_rev, ones_arr) + } + catsum <- array(apply(out, marg_noncat, sum), dim = dim_noncat) + sweep(out, marg_noncat, catsum, "/") +} + +# generic link function for the acat family +# +# @param x Matrix (S x `ncat`, with S denoting the number of posterior draws and +# `ncat` denoting the number of response categories) of probabilities for the +# response categories or an array (S x N x `ncat`) containing the same values +# as the matrix just described, but for N observations. +# @param link Character string (length 1) giving the name of the link function. +# +# @return If `x` is a matrix, then a matrix (S x `ncat - 1`, with S denoting the +# number of posterior draws and `ncat` denoting the number of response +# categories) containing the values of the link function applied to `x`. If +# `x` is an array, then an array (S x N x `ncat - 1`) containing the same +# values as the matrix just described, but for N observations. +link_acat <- function(x, link) { + ndim <- length(dim(x)) + ncat <- dim(x)[ndim] + x <- slice(x, ndim, -1, drop = FALSE) / slice(x, ndim, -ncat, drop = FALSE) + if (link == "logit") { + # faster evaluation in this case + out <- log(x) + } else { + x <- inv_odds(x) + out <- link(x, link) + } + out +} + +# CDF for ordinal distributions +# @param q positive integers not greater than ncat +# @param eta draws of the linear predictor +# @param thres draws of threshold parameters +# @param disc draws of the discrimination parameter +# @param family a character string naming the family +# @param link a character string naming the link +# @return a matrix of probabilities P(x <= q) +pordinal <- function(q, eta, thres, disc = 1, family = NULL, link = "logit") { + family <- as_one_character(family) + link <- as_one_character(link) + args <- nlist(x = seq_len(max(q)), eta, thres, disc, link) + p <- do_call(paste0("d", family), args) + .fun <- function(j) rowSums(as.matrix(p[, 1:j, drop = FALSE])) + cblapply(q, .fun) +} + +# helper functions to shift arbitrary distributions +dshifted <- function(dist, x, shift = 0, ...) { + do_call(paste0("d", dist), list(x - shift, ...)) +} + +pshifted <- function(dist, q, shift = 0, ...) { + do_call(paste0("p", dist), list(q - shift, ...)) +} + +qshifted <- function(dist, p, shift = 0, ...) { + do_call(paste0("q", dist), list(p, ...)) + shift +} + +rshifted <- function(dist, n, shift = 0, ...) { + do_call(paste0("r", dist), list(n, ...)) + shift +} + +# check if 'n' in r functions is valid +# @param n number of desired random draws +# @param .. parameter vectors +# @return validated 'n' +check_n_rdist <- function(n, ...) { + n <- as.integer(as_one_numeric(n)) + max_len <- max(lengths(list(...))) + if (max_len > 1L) { + if (!n %in% c(1, max_len)) { + stop2("'n' must match the maximum length of the parameter vectors.") + } + n <- max_len + } + n +} diff -Nru r-cran-brms-2.16.3/R/emmeans.R r-cran-brms-2.17.0/R/emmeans.R --- r-cran-brms-2.16.3/R/emmeans.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/emmeans.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,210 +1,210 @@ -#' Support Functions for \pkg{emmeans} -#' -#' Functions required for compatibility of \pkg{brms} with \pkg{emmeans}. -#' Users are not required to call these functions themselves. Instead, -#' they will be called automatically by the \code{emmeans} function -#' of the \pkg{emmeans} package. -#' -#' @name emmeans-brms-helpers -#' -#' @inheritParams posterior_epred.brmsfit -#' @param re_formula Optional formula containing group-level effects to be -#' considered in the prediction. If \code{NULL}, include all group-level -#' effects; if \code{NA} (default), include no group-level effects. -#' @param epred Logical. If \code{TRUE} compute predictions of -#' the posterior predictive distribution's mean -#' (see \code{\link{posterior_epred.brmsfit}}) while ignoring -#' arguments \code{dpar} and \code{nlpar}. Defaults to \code{FALSE}. -#' @param data,trms,xlev,grid,vcov. Arguments required by \pkg{emmeans}. -#' @param ... Additional arguments passed to \pkg{emmeans}. -#' -#' @details -#' In order to ensure compatibility of most \pkg{brms} models with -#' \pkg{emmeans}, predictions are not generated 'manually' via a design matrix -#' and coefficient vector, but rather via \code{\link{posterior_linpred.brmsfit}}. -#' This appears to generally work well, but note that it produces an `.@linfct` -#' slot that contains the computed predictions as columns instead of the -#' coefficients. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), -#' data = kidney, family = lognormal()) -#' summary(fit) -#' -#' # summarize via 'emmeans' -#' library(emmeans) -#' rg <- ref_grid(fit) -#' em <- emmeans(rg, "disease") -#' summary(em, point.est = mean) -#' -#' # obtain estimates for the posterior predictive distribution's mean -#' epred <- emmeans(fit, "disease", epred = TRUE) -#' summary(epred, point.est = mean) -#' } -NULL - -# recover the variables used in the model predictions -# @param data only added to prevent it from being passed further via ... -#' @rdname emmeans-brms-helpers -recover_data.brmsfit <- function(object, data, resp = NULL, dpar = NULL, - nlpar = NULL, re_formula = NA, - epred = FALSE, ...) { - bterms <- .extract_par_terms( - object, resp = resp, dpar = dpar, nlpar = nlpar, - re_formula = re_formula, epred = epred - ) - trms <- attr(model.frame(bterms$allvars, data = object$data), "terms") - # brms has no call component so the call is just a dummy - emmeans::recover_data(call("brms"), trms, "na.omit", data = object$data, ...) -} - -# Calculate the basis for making predictions. In some sense, this is -# similar to the fitted() function with new data on the link scale. -# Transforming to response scale, if desired, is handled by emmeans. -#' @rdname emmeans-brms-helpers -emm_basis.brmsfit <- function(object, trms, xlev, grid, vcov., resp = NULL, - dpar = NULL, nlpar = NULL, re_formula = NA, - epred = FALSE, ...) { - if (is_equal(dpar, "mean")) { - # deprecated as of version 2.15.9 - warning2("dpar = 'mean' is deprecated. Please use epred = TRUE instead.") - epred <- TRUE - dpar <- NULL - } - epred <- as_one_logical(epred) - bterms <- .extract_par_terms( - object, resp = resp, dpar = dpar, nlpar = nlpar, - re_formula = re_formula, epred = epred - ) - if (epred) { - post.beta <- posterior_epred( - object, newdata = grid, re_formula = re_formula, - resp = resp, incl_autocor = FALSE, ... - ) - } else { - req_vars <- all_vars(bterms$allvars) - post.beta <- posterior_linpred( - object, newdata = grid, re_formula = re_formula, - resp = resp, dpar = dpar, nlpar = nlpar, - incl_autocor = FALSE, req_vars = req_vars, ... - ) - } - if (anyNA(post.beta)) { - stop2("emm_basis.brmsfit created NAs. Please check your reference grid.") - } - misc <- bterms$.misc - if (length(dim(post.beta)) == 3L) { - # reshape to a 2D matrix, for example, in multivariate models - ynames <- dimnames(post.beta)[[3]] - if (is.null(ynames)) { - ynames <- as.character(seq_len(dim(post.beta)[3])) - } - dims <- dim(post.beta) - post.beta <- matrix(post.beta, ncol = prod(dims[2:3])) - misc$ylevs = list(rep.meas = ynames) - } - attr(post.beta, "n.chains") <- object$fit@sim$chains - X <- diag(ncol(post.beta)) - bhat <- apply(post.beta, 2, mean) - V <- cov(post.beta) - nbasis <- matrix(NA) - dfargs <- list() - dffun <- function(k, dfargs) Inf - environment(dffun) <- baseenv() - nlist(X, bhat, nbasis, V, dffun, dfargs, misc, post.beta) -} - -# extract terms of specific predicted parameter(s) in the model -# currently, the only slots that matter in the returned object are -# allvars: formula with all required variables on the right-hand side -# .misc: a named list with additional info to be interpreted by emmeans -.extract_par_terms <- function(x, ...) { - UseMethod(".extract_par_terms") -} - -#' @export -.extract_par_terms.brmsfit <- function(x, resp = NULL, re_formula = NA, - dpar = NULL, epred = FALSE, ...) { - if (is_equal(dpar, "mean")) { - # deprecation warning already provided in emm_basis.brmsfit - epred <- TRUE - dpar <- NULL - } - resp <- validate_resp(resp, x) - new_formula <- update_re_terms(formula(x), re_formula) - bterms <- brmsterms(new_formula, resp_rhs_all = FALSE) - if (is_ordinal(bterms)) { - warning2("brms' emmeans support for ordinal models is experimental ", - "and currently ignores the threshold parameters.") - } - .extract_par_terms(bterms, resp = resp, dpar = dpar, epred = epred, ...) -} - -#' @export -.extract_par_terms.mvbrmsterms <- function(x, resp, epred, ...) { - stopifnot(is.character(resp)) - epred <- as_one_logical(epred) - out <- x - # only use selected univariate models - out$terms <- out$terms[resp] - if (epred) { - out$allvars <- allvars_formula(lapply(out$terms, get_allvars)) - out$.misc <- list() - return(out) - } - for (i in seq_along(out$terms)) { - out$terms[[i]] <- .extract_par_terms(out$terms[[i]], epred = epred, ...) - } - out$allvars <- allvars_formula(lapply(out$terms, get_allvars)) - misc_list <- unique(lapply(out$terms, "[[", ".misc")) - if (length(misc_list) > 1L){ - stop2("brms' emmeans support for multivariate models is limited ", - "to cases where all univariate models have the same family.") - } - out$.misc <- misc_list[[1]] - out -} - -#' @export -.extract_par_terms.brmsterms <- function(x, dpar, nlpar, epred, ...) { - epred <- as_one_logical(epred) - all_dpars <- names(x$dpars) - all_nlpars <- names(x$nlpars) - out <- x - if (epred) { - out$.misc <- list() - return(out) - } - if (!is.null(nlpar)) { - if (!is.null(dpar)) { - stop2("'dpar' and 'nlpar' cannot be specified at the same time.") - } - nlpar <- as_one_character(nlpar) - if (!nlpar %in% all_nlpars) { - stop2( - "Non-linear parameter '", nlpar, "' is not part of the model.", - "\nSupported parameters are: ", collapse_comma(all_nlpars) - ) - } - out <- x$nlpars[[nlpar]] - } else if (!is.null(dpar)) { - dpar <- as_one_character(dpar) - if (!dpar %in% all_dpars) { - stop2( - "Distributional parameter '", dpar, "' is not part of the model.", - "\nSupported parameters are: ", collapse_comma(all_dpars) - ) - } - out <- x$dpars[[dpar]] - } else { - # extract 'mu' parameter by default - if (!"mu" %in% names(x$dpars)) { - # concerns categorical-like and mixture models - stop2("emmeans is not yet supported for this brms model.") - } - out <- x$dpars[["mu"]] - } - out$.misc <- emmeans::.std.link.labels(out$family, list()) - out -} +#' Support Functions for \pkg{emmeans} +#' +#' Functions required for compatibility of \pkg{brms} with \pkg{emmeans}. +#' Users are not required to call these functions themselves. Instead, +#' they will be called automatically by the \code{emmeans} function +#' of the \pkg{emmeans} package. +#' +#' @name emmeans-brms-helpers +#' +#' @inheritParams posterior_epred.brmsfit +#' @param re_formula Optional formula containing group-level effects to be +#' considered in the prediction. If \code{NULL}, include all group-level +#' effects; if \code{NA} (default), include no group-level effects. +#' @param epred Logical. If \code{TRUE} compute predictions of +#' the posterior predictive distribution's mean +#' (see \code{\link{posterior_epred.brmsfit}}) while ignoring +#' arguments \code{dpar} and \code{nlpar}. Defaults to \code{FALSE}. +#' @param data,trms,xlev,grid,vcov. Arguments required by \pkg{emmeans}. +#' @param ... Additional arguments passed to \pkg{emmeans}. +#' +#' @details +#' In order to ensure compatibility of most \pkg{brms} models with +#' \pkg{emmeans}, predictions are not generated 'manually' via a design matrix +#' and coefficient vector, but rather via \code{\link{posterior_linpred.brmsfit}}. +#' This appears to generally work well, but note that it produces an `.@linfct` +#' slot that contains the computed predictions as columns instead of the +#' coefficients. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), +#' data = kidney, family = lognormal()) +#' summary(fit) +#' +#' # summarize via 'emmeans' +#' library(emmeans) +#' rg <- ref_grid(fit) +#' em <- emmeans(rg, "disease") +#' summary(em, point.est = mean) +#' +#' # obtain estimates for the posterior predictive distribution's mean +#' epred <- emmeans(fit, "disease", epred = TRUE) +#' summary(epred, point.est = mean) +#' } +NULL + +# recover the variables used in the model predictions +# @param data only added to prevent it from being passed further via ... +#' @rdname emmeans-brms-helpers +recover_data.brmsfit <- function(object, data, resp = NULL, dpar = NULL, + nlpar = NULL, re_formula = NA, + epred = FALSE, ...) { + bterms <- .extract_par_terms( + object, resp = resp, dpar = dpar, nlpar = nlpar, + re_formula = re_formula, epred = epred + ) + trms <- attr(model.frame(bterms$allvars, data = object$data), "terms") + # brms has no call component so the call is just a dummy + emmeans::recover_data(call("brms"), trms, "na.omit", data = object$data, ...) +} + +# Calculate the basis for making predictions. In some sense, this is +# similar to the fitted() function with new data on the link scale. +# Transforming to response scale, if desired, is handled by emmeans. +#' @rdname emmeans-brms-helpers +emm_basis.brmsfit <- function(object, trms, xlev, grid, vcov., resp = NULL, + dpar = NULL, nlpar = NULL, re_formula = NA, + epred = FALSE, ...) { + if (is_equal(dpar, "mean")) { + # deprecated as of version 2.15.9 + warning2("dpar = 'mean' is deprecated. Please use epred = TRUE instead.") + epred <- TRUE + dpar <- NULL + } + epred <- as_one_logical(epred) + bterms <- .extract_par_terms( + object, resp = resp, dpar = dpar, nlpar = nlpar, + re_formula = re_formula, epred = epred + ) + if (epred) { + post.beta <- posterior_epred( + object, newdata = grid, re_formula = re_formula, + resp = resp, incl_autocor = FALSE, ... + ) + } else { + req_vars <- all_vars(bterms$allvars) + post.beta <- posterior_linpred( + object, newdata = grid, re_formula = re_formula, + resp = resp, dpar = dpar, nlpar = nlpar, + incl_autocor = FALSE, req_vars = req_vars, ... + ) + } + if (anyNA(post.beta)) { + stop2("emm_basis.brmsfit created NAs. Please check your reference grid.") + } + misc <- bterms$.misc + if (length(dim(post.beta)) == 3L) { + # reshape to a 2D matrix, for example, in multivariate models + ynames <- dimnames(post.beta)[[3]] + if (is.null(ynames)) { + ynames <- as.character(seq_len(dim(post.beta)[3])) + } + dims <- dim(post.beta) + post.beta <- matrix(post.beta, ncol = prod(dims[2:3])) + misc$ylevs = list(rep.meas = ynames) + } + attr(post.beta, "n.chains") <- object$fit@sim$chains + X <- diag(ncol(post.beta)) + bhat <- apply(post.beta, 2, mean) + V <- cov(post.beta) + nbasis <- matrix(NA) + dfargs <- list() + dffun <- function(k, dfargs) Inf + environment(dffun) <- baseenv() + nlist(X, bhat, nbasis, V, dffun, dfargs, misc, post.beta) +} + +# extract terms of specific predicted parameter(s) in the model +# currently, the only slots that matter in the returned object are +# allvars: formula with all required variables on the right-hand side +# .misc: a named list with additional info to be interpreted by emmeans +.extract_par_terms <- function(x, ...) { + UseMethod(".extract_par_terms") +} + +#' @export +.extract_par_terms.brmsfit <- function(x, resp = NULL, re_formula = NA, + dpar = NULL, epred = FALSE, ...) { + if (is_equal(dpar, "mean")) { + # deprecation warning already provided in emm_basis.brmsfit + epred <- TRUE + dpar <- NULL + } + resp <- validate_resp(resp, x) + new_formula <- update_re_terms(formula(x), re_formula) + bterms <- brmsterms(new_formula, resp_rhs_all = FALSE) + if (is_ordinal(bterms)) { + warning2("brms' emmeans support for ordinal models is experimental ", + "and currently ignores the threshold parameters.") + } + .extract_par_terms(bterms, resp = resp, dpar = dpar, epred = epred, ...) +} + +#' @export +.extract_par_terms.mvbrmsterms <- function(x, resp, epred, ...) { + stopifnot(is.character(resp)) + epred <- as_one_logical(epred) + out <- x + # only use selected univariate models + out$terms <- out$terms[resp] + if (epred) { + out$allvars <- allvars_formula(lapply(out$terms, get_allvars)) + out$.misc <- list() + return(out) + } + for (i in seq_along(out$terms)) { + out$terms[[i]] <- .extract_par_terms(out$terms[[i]], epred = epred, ...) + } + out$allvars <- allvars_formula(lapply(out$terms, get_allvars)) + misc_list <- unique(lapply(out$terms, "[[", ".misc")) + if (length(misc_list) > 1L){ + stop2("brms' emmeans support for multivariate models is limited ", + "to cases where all univariate models have the same family.") + } + out$.misc <- misc_list[[1]] + out +} + +#' @export +.extract_par_terms.brmsterms <- function(x, dpar, nlpar, epred, ...) { + epred <- as_one_logical(epred) + all_dpars <- names(x$dpars) + all_nlpars <- names(x$nlpars) + out <- x + if (epred) { + out$.misc <- list() + return(out) + } + if (!is.null(nlpar)) { + if (!is.null(dpar)) { + stop2("'dpar' and 'nlpar' cannot be specified at the same time.") + } + nlpar <- as_one_character(nlpar) + if (!nlpar %in% all_nlpars) { + stop2( + "Non-linear parameter '", nlpar, "' is not part of the model.", + "\nSupported parameters are: ", collapse_comma(all_nlpars) + ) + } + out <- x$nlpars[[nlpar]] + } else if (!is.null(dpar)) { + dpar <- as_one_character(dpar) + if (!dpar %in% all_dpars) { + stop2( + "Distributional parameter '", dpar, "' is not part of the model.", + "\nSupported parameters are: ", collapse_comma(all_dpars) + ) + } + out <- x$dpars[[dpar]] + } else { + # extract 'mu' parameter by default + if (!"mu" %in% names(x$dpars)) { + # concerns categorical-like and mixture models + stop2("emmeans is not yet supported for this brms model.") + } + out <- x$dpars[["mu"]] + } + out$.misc <- emmeans::.std.link.labels(out$family, list()) + out +} diff -Nru r-cran-brms-2.16.3/R/exclude_pars.R r-cran-brms-2.17.0/R/exclude_pars.R --- r-cran-brms-2.16.3/R/exclude_pars.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/exclude_pars.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,218 +1,218 @@ -# list parameters NOT to be saved by Stan -# @return a vector of parameter names to be excluded -exclude_pars <- function(x, ...) { - UseMethod("exclude_pars") -} - -#' @export -exclude_pars.default <- function(x, ...) { - character(0) -} - -#' @export -exclude_pars.brmsfit <- function(x, ...) { - out <- character(0) - save_pars <- x$save_pars - bterms <- brmsterms(x$formula) - c(out) <- exclude_pars(bterms, data = x$data, save_pars = save_pars, ...) - meef <- tidy_meef(bterms, x$data) - if (has_rows(meef)) { - I <- seq_along(unique(meef$grname)) - K <- seq_rows(meef) - c(out) <- paste0(c("Corme_"), I) - if (!save_pars$all) { - c(out) <- c(paste0("zme_", K), paste0("Lme_", I)) - } - if (isFALSE(save_pars$latent)) { - c(out) <- paste0("Xme_", K) - } else if (is.character(save_pars$latent)) { - sub_K <- K[!meef$xname %in% save_pars$latent] - if (length(sub_K)) { - c(out) <- paste0("Xme_", sub_K) - } - } - } - ranef <- x$ranef - if (has_rows(ranef)) { - rm_re_pars <- c(if (!save_pars$all) c("z", "L"), "Cor", "r") - for (id in unique(ranef$id)) { - c(out) <- paste0(rm_re_pars, "_", id) - } - if (isFALSE(save_pars$group)) { - p <- usc(combine_prefix(ranef)) - c(out) <- paste0("r_", ranef$id, p, "_", ranef$cn) - } else if (is.character(save_pars$group)) { - sub_ranef <- ranef[!ranef$group %in% save_pars$group, ] - if (has_rows(sub_ranef)) { - sub_p <- usc(combine_prefix(sub_ranef)) - c(out) <- paste0("r_", sub_ranef$id, sub_p, "_", sub_ranef$cn) - } - } - tranef <- get_dist_groups(ranef, "student") - if (!save_pars$all && has_rows(tranef)) { - c(out) <- paste0(c("udf_", "dfm_"), tranef$ggn) - } - } - out <- unique(out) - out <- setdiff(out, save_pars$manual) - out -} - -#' @export -exclude_pars.mvbrmsterms <- function(x, save_pars, ...) { - out <- c("Rescor", "Sigma") - if (!save_pars$all) { - c(out) <- c("Lrescor", "LSigma") - } - for (i in seq_along(x$terms)) { - c(out) <- exclude_pars(x$terms[[i]], save_pars = save_pars, ...) - } - out -} - -#' @export -exclude_pars.brmsterms <- function(x, save_pars, ...) { - out <- character(0) - resp <- usc(combine_prefix(x)) - if (!save_pars$all) { - par_classes <- c("ordered_Intercept", "fixed_Intercept", "theta") - c(out) <- paste0(par_classes, resp) - } - for (dp in names(x$dpars)) { - c(out) <- exclude_pars(x$dpars[[dp]], save_pars = save_pars, ...) - } - for (nlp in names(x$nlpars)) { - c(out) <- exclude_pars(x$nlpars[[nlp]], save_pars = save_pars, ...) - } - if (is.formula(x$adforms$mi)) { - if (!(isTRUE(save_pars$latent) || x$resp %in% save_pars$latent)) { - c(out) <- paste0("Yl", resp) - } - } - if (!(isTRUE(save_pars$group) || ".err" %in% save_pars$group)) { - # latent residuals are like group-level effects - c(out) <- paste0("err", resp) - } - out -} - -#' @export -exclude_pars.btl <- function(x, data, save_pars, ...) { - out <- character(0) - p <- usc(combine_prefix(x)) - c(out) <- paste0("chol_cor", p) - if (!save_pars$all) { - par_classes <- c( - "bQ", "hs_global", "hs_local", "hs_slab", "zb", "hs_localsp", - "R2D2_tau2", "zbsp", "Intercept", "first_Intercept", - "merged_Intercept", "zcar", "nszcar", "zerr" - ) - c(out) <- paste0(par_classes, p) - smef <- tidy_smef(x, data) - for (i in seq_rows(smef)) { - nb <- seq_len(smef$nbases[i]) - c(out) <- paste0("zs", p, "_", i, "_", nb) - } - } - out -} - -#' Control Saving of Parameter Draws -#' -#' Control which (draws of) parameters should be saved in a \pkg{brms} -#' model. The output of this function is ment for usage in the -#' \code{save_pars} argument of \code{\link{brm}}. -#' -#' @param group A flag to indicate if group-level coefficients for -#' each level of the grouping factors should be saved (default is -#' \code{TRUE}). Set to \code{FALSE} to save memory. Alternatively, -#' \code{group} may also be a character vector naming the grouping factors -#' for which to save draws of coefficients. -#' @param latent A flag to indicate if draws of latent variables obtained by -#' using \code{me} and \code{mi} terms should be saved (default is -#' \code{FALSE}). Saving these draws allows to better use methods such as -#' \code{posterior_predict} with the latent variables but leads to very large -#' \R objects even for models of moderate size and complexity. Alternatively, -#' \code{latent} may also be a character vector naming the latent variables -#' for which to save draws. -#' @param all A flag to indicate if draws of all variables defined in Stan's -#' \code{parameters} block should be saved (default is \code{FALSE}). Saving -#' these draws is required in order to apply the certain methods such as -#' \code{bridge_sampler} and \code{bayes_factor}. -#' @param manual A character vector naming Stan variable names which should be -#' saved. These names should match the variable names inside the Stan code -#' before renaming. This feature is meant for power users only and will rarely -#' be useful outside of very special cases. -#' -#' @return A list of class \code{"save_pars"}. -#' -#' @examples -#' \dontrun{ -#' # don't store group-level coefficients -#' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), -#' data = epilepsy, family = poisson(), -#' save_pars = save_pars(group = FALSE)) -#' variables(fit) -#' } -#' -#' @export -save_pars <- function(group = TRUE, latent = FALSE, all = FALSE, - manual = NULL) { - out <- list() - if (is.logical(group)) { - out$group <- as_one_logical(group) - } else { - out$group <- as.character(group) - } - if (is.logical(latent)) { - out$latent <- as_one_logical(latent) - } else { - out$latent <- as.character(latent) - } - out$all <- as_one_logical(all) - out$manual <- as.character(manual) - class(out) <- "save_pars" - out -} - -# validate 'save_pars' argument -# deprecated arguments: -# @param save_ranef save varying effects per level? -# @param save_mevars save noise-free variables? -# @param save_all_pars save all variables from the 'parameters' block? -# @return validated 'save_pars' argument -validate_save_pars <- function(save_pars, save_ranef = NULL, save_mevars = NULL, - save_all_pars = NULL) { - if (is.null(save_pars)) { - save_pars <- save_pars() - } - if (!is.save_pars(save_pars)) { - stop2("Argument 'save_pars' needed to be created via 'save_pars()'.") - } - if (!is.null(save_ranef)) { - warning2( - "Argument 'save_ranef' is deprecated. Please use argument ", - "'group' in function 'save_pars()' instead." - ) - save_pars$group <- as_one_logical(save_ranef) - } - if (!is.null(save_mevars)) { - warning2( - "Argument 'save_mevars' is deprecated. Please use argument ", - "'latent' in function 'save_pars()' instead." - ) - save_pars$latent <- as_one_logical(save_mevars) - } - if (!is.null(save_all_pars)) { - warning2( - "Argument 'save_all_pars' is deprecated. Please use argument ", - "'all' in function 'save_pars()' instead." - ) - save_pars$all <- as_one_logical(save_all_pars) - } - save_pars -} - -is.save_pars <- function(x) { - inherits(x, "save_pars") -} +# list parameters NOT to be saved by Stan +# @return a vector of parameter names to be excluded +exclude_pars <- function(x, ...) { + UseMethod("exclude_pars") +} + +#' @export +exclude_pars.default <- function(x, ...) { + character(0) +} + +#' @export +exclude_pars.brmsfit <- function(x, ...) { + out <- character(0) + save_pars <- x$save_pars + bterms <- brmsterms(x$formula) + c(out) <- exclude_pars(bterms, data = x$data, save_pars = save_pars, ...) + meef <- tidy_meef(bterms, x$data) + if (has_rows(meef)) { + I <- seq_along(unique(meef$grname)) + K <- seq_rows(meef) + c(out) <- paste0(c("Corme_"), I) + if (!save_pars$all) { + c(out) <- c(paste0("zme_", K), paste0("Lme_", I)) + } + if (isFALSE(save_pars$latent)) { + c(out) <- paste0("Xme_", K) + } else if (is.character(save_pars$latent)) { + sub_K <- K[!meef$xname %in% save_pars$latent] + if (length(sub_K)) { + c(out) <- paste0("Xme_", sub_K) + } + } + } + ranef <- x$ranef + if (has_rows(ranef)) { + rm_re_pars <- c(if (!save_pars$all) c("z", "L"), "Cor", "r") + for (id in unique(ranef$id)) { + c(out) <- paste0(rm_re_pars, "_", id) + } + if (isFALSE(save_pars$group)) { + p <- usc(combine_prefix(ranef)) + c(out) <- paste0("r_", ranef$id, p, "_", ranef$cn) + } else if (is.character(save_pars$group)) { + sub_ranef <- ranef[!ranef$group %in% save_pars$group, ] + if (has_rows(sub_ranef)) { + sub_p <- usc(combine_prefix(sub_ranef)) + c(out) <- paste0("r_", sub_ranef$id, sub_p, "_", sub_ranef$cn) + } + } + tranef <- get_dist_groups(ranef, "student") + if (!save_pars$all && has_rows(tranef)) { + c(out) <- paste0(c("udf_", "dfm_"), tranef$ggn) + } + } + out <- unique(out) + out <- setdiff(out, save_pars$manual) + out +} + +#' @export +exclude_pars.mvbrmsterms <- function(x, save_pars, ...) { + out <- c("Rescor", "Sigma") + if (!save_pars$all) { + c(out) <- c("Lrescor", "LSigma") + } + for (i in seq_along(x$terms)) { + c(out) <- exclude_pars(x$terms[[i]], save_pars = save_pars, ...) + } + out +} + +#' @export +exclude_pars.brmsterms <- function(x, save_pars, ...) { + out <- "Lncor" + resp <- usc(combine_prefix(x)) + if (!save_pars$all) { + par_classes <- c("ordered_Intercept", "fixed_Intercept", "theta", "Llncor") + c(out) <- paste0(par_classes, resp) + } + for (dp in names(x$dpars)) { + c(out) <- exclude_pars(x$dpars[[dp]], save_pars = save_pars, ...) + } + for (nlp in names(x$nlpars)) { + c(out) <- exclude_pars(x$nlpars[[nlp]], save_pars = save_pars, ...) + } + if (is.formula(x$adforms$mi)) { + if (!(isTRUE(save_pars$latent) || x$resp %in% save_pars$latent)) { + c(out) <- paste0("Yl", resp) + } + } + if (!(isTRUE(save_pars$group) || ".err" %in% save_pars$group)) { + # latent residuals are like group-level effects + c(out) <- paste0("err", resp) + } + out +} + +#' @export +exclude_pars.btl <- function(x, data, save_pars, ...) { + out <- character(0) + p <- usc(combine_prefix(x)) + c(out) <- paste0("chol_cor", p) + if (!save_pars$all) { + par_classes <- c( + "bQ", "hs_global", "hs_local", "hs_slab", "zb", "hs_localsp", + "R2D2_tau2", "zbsp", "Intercept", "first_Intercept", + "merged_Intercept", "zcar", "nszcar", "zerr" + ) + c(out) <- paste0(par_classes, p) + smef <- tidy_smef(x, data) + for (i in seq_rows(smef)) { + nb <- seq_len(smef$nbases[i]) + c(out) <- paste0("zs", p, "_", i, "_", nb) + } + } + out +} + +#' Control Saving of Parameter Draws +#' +#' Control which (draws of) parameters should be saved in a \pkg{brms} +#' model. The output of this function is ment for usage in the +#' \code{save_pars} argument of \code{\link{brm}}. +#' +#' @param group A flag to indicate if group-level coefficients for +#' each level of the grouping factors should be saved (default is +#' \code{TRUE}). Set to \code{FALSE} to save memory. Alternatively, +#' \code{group} may also be a character vector naming the grouping factors +#' for which to save draws of coefficients. +#' @param latent A flag to indicate if draws of latent variables obtained by +#' using \code{me} and \code{mi} terms should be saved (default is +#' \code{FALSE}). Saving these draws allows to better use methods such as +#' \code{posterior_predict} with the latent variables but leads to very large +#' \R objects even for models of moderate size and complexity. Alternatively, +#' \code{latent} may also be a character vector naming the latent variables +#' for which to save draws. +#' @param all A flag to indicate if draws of all variables defined in Stan's +#' \code{parameters} block should be saved (default is \code{FALSE}). Saving +#' these draws is required in order to apply the certain methods such as +#' \code{bridge_sampler} and \code{bayes_factor}. +#' @param manual A character vector naming Stan variable names which should be +#' saved. These names should match the variable names inside the Stan code +#' before renaming. This feature is meant for power users only and will rarely +#' be useful outside of very special cases. +#' +#' @return A list of class \code{"save_pars"}. +#' +#' @examples +#' \dontrun{ +#' # don't store group-level coefficients +#' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), +#' data = epilepsy, family = poisson(), +#' save_pars = save_pars(group = FALSE)) +#' variables(fit) +#' } +#' +#' @export +save_pars <- function(group = TRUE, latent = FALSE, all = FALSE, + manual = NULL) { + out <- list() + if (is.logical(group)) { + out$group <- as_one_logical(group) + } else { + out$group <- as.character(group) + } + if (is.logical(latent)) { + out$latent <- as_one_logical(latent) + } else { + out$latent <- as.character(latent) + } + out$all <- as_one_logical(all) + out$manual <- as.character(manual) + class(out) <- "save_pars" + out +} + +# validate 'save_pars' argument +# deprecated arguments: +# @param save_ranef save varying effects per level? +# @param save_mevars save noise-free variables? +# @param save_all_pars save all variables from the 'parameters' block? +# @return validated 'save_pars' argument +validate_save_pars <- function(save_pars, save_ranef = NULL, save_mevars = NULL, + save_all_pars = NULL) { + if (is.null(save_pars)) { + save_pars <- save_pars() + } + if (!is.save_pars(save_pars)) { + stop2("Argument 'save_pars' needed to be created via 'save_pars()'.") + } + if (!is.null(save_ranef)) { + warning2( + "Argument 'save_ranef' is deprecated. Please use argument ", + "'group' in function 'save_pars()' instead." + ) + save_pars$group <- as_one_logical(save_ranef) + } + if (!is.null(save_mevars)) { + warning2( + "Argument 'save_mevars' is deprecated. Please use argument ", + "'latent' in function 'save_pars()' instead." + ) + save_pars$latent <- as_one_logical(save_mevars) + } + if (!is.null(save_all_pars)) { + warning2( + "Argument 'save_all_pars' is deprecated. Please use argument ", + "'all' in function 'save_pars()' instead." + ) + save_pars$all <- as_one_logical(save_all_pars) + } + save_pars +} + +is.save_pars <- function(x) { + inherits(x, "save_pars") +} diff -Nru r-cran-brms-2.16.3/R/exclude_terms.R r-cran-brms-2.17.0/R/exclude_terms.R --- r-cran-brms-2.16.3/R/exclude_terms.R 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/R/exclude_terms.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,57 +1,57 @@ -# exclude predictor terms from being evaluated -exclude_terms <- function(x, ...) { - UseMethod("exclude_terms") -} - -#' @export -exclude_terms.brmsfit <- function(x, ...) { - x$formula <- exclude_terms(x$formula, ...) - x -} - -#' @export -exclude_terms.mvbrmsformula <- function(x, ...) { - for (i in seq_along(x$forms)) { - x$forms[[i]] <- exclude_terms(x$forms[[i]], ...) - } - x -} - -#' @export -exclude_terms.brmsformula <- function( - x, excl_term_types = NULL, incl_autocor = TRUE, - smooths_only = FALSE, offset = TRUE, ... -) { - excl_term_types <- as.character(excl_term_types) - # TODO: deprecate the three arguments below? - incl_autocor <- as_one_logical(incl_autocor) - smooths_only <- as_one_logical(smooths_only) - offset <- as_one_logical(offset) - if (!incl_autocor) { - c(excl_term_types) <- "ac" - } - if (!offset) { - c(excl_term_types) <- "offset" - } - if (smooths_only) { - excl_term_types <- setdiff(all_term_types(), "sm") - } - if (!length(excl_term_types)) { - return(x) - } - invalid_types <- setdiff(excl_term_types, all_term_types()) - if (length(invalid_types)) { - stop2("The following term types are invalid: ", - collapse_comma(invalid_types)) - } - attr(x$formula, "excl_term_types") <- excl_term_types - for (i in seq_along(x$pforms)) { - attr(x$pforms[[i]], "excl_term_types") <- excl_term_types - } - x -} - -# extract names of excluded term types -excluded_term_types <- function(x) { - as.character(attr(x, "excl_term_types", TRUE)) -} +# exclude predictor terms from being evaluated +exclude_terms <- function(x, ...) { + UseMethod("exclude_terms") +} + +#' @export +exclude_terms.brmsfit <- function(x, ...) { + x$formula <- exclude_terms(x$formula, ...) + x +} + +#' @export +exclude_terms.mvbrmsformula <- function(x, ...) { + for (i in seq_along(x$forms)) { + x$forms[[i]] <- exclude_terms(x$forms[[i]], ...) + } + x +} + +#' @export +exclude_terms.brmsformula <- function( + x, excl_term_types = NULL, incl_autocor = TRUE, + smooths_only = FALSE, offset = TRUE, ... +) { + excl_term_types <- as.character(excl_term_types) + # TODO: deprecate the three arguments below? + incl_autocor <- as_one_logical(incl_autocor) + smooths_only <- as_one_logical(smooths_only) + offset <- as_one_logical(offset) + if (!incl_autocor) { + c(excl_term_types) <- "ac" + } + if (!offset) { + c(excl_term_types) <- "offset" + } + if (smooths_only) { + excl_term_types <- setdiff(all_term_types(), "sm") + } + if (!length(excl_term_types)) { + return(x) + } + invalid_types <- setdiff(excl_term_types, all_term_types()) + if (length(invalid_types)) { + stop2("The following term types are invalid: ", + collapse_comma(invalid_types)) + } + attr(x$formula, "excl_term_types") <- excl_term_types + for (i in seq_along(x$pforms)) { + attr(x$pforms[[i]], "excl_term_types") <- excl_term_types + } + x +} + +# extract names of excluded term types +excluded_term_types <- function(x) { + as.character(attr(x, "excl_term_types", TRUE)) +} diff -Nru r-cran-brms-2.16.3/R/families.R r-cran-brms-2.17.0/R/families.R --- r-cran-brms-2.16.3/R/families.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/families.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,1802 +1,1877 @@ -#' Special Family Functions for \pkg{brms} Models -#' -#' Family objects provide a convenient way to specify the details of the models -#' used by many model fitting functions. The family functions presented here are -#' for use with \pkg{brms} only and will **not** work with other model -#' fitting functions such as \code{glm} or \code{glmer}. -#' However, the standard family functions as described in -#' \code{\link[stats:family]{family}} will work with \pkg{brms}. -#' You can also specify custom families for use in \pkg{brms} with -#' the \code{\link{custom_family}} function. -#' -#' @param family A character string naming the distribution of the response -#' variable be used in the model. Currently, the following families are -#' supported: \code{gaussian}, \code{student}, \code{binomial}, -#' \code{bernoulli}, \code{poisson}, \code{negbinomial}, \code{geometric}, -#' \code{Gamma}, \code{skew_normal}, \code{lognormal}, -#' \code{shifted_lognormal}, \code{exgaussian}, \code{wiener}, -#' \code{inverse.gaussian}, \code{exponential}, \code{weibull}, -#' \code{frechet}, \code{Beta}, \code{dirichlet}, \code{von_mises}, -#' \code{asym_laplace}, \code{gen_extreme_value}, \code{categorical}, -#' \code{multinomial}, \code{cumulative}, \code{cratio}, \code{sratio}, -#' \code{acat}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, -#' \code{hurdle_gamma}, \code{hurdle_lognormal}, -#' \code{zero_inflated_binomial}, \code{zero_inflated_beta}, -#' \code{zero_inflated_negbinomial}, \code{zero_inflated_poisson}, and -#' \code{zero_one_inflated_beta}. -#' @param link A specification for the model link function. This can be a -#' name/expression or character string. See the 'Details' section for more -#' information on link functions supported by each family. -#' @param link_sigma Link of auxiliary parameter \code{sigma} if being predicted. -#' @param link_shape Link of auxiliary parameter \code{shape} if being predicted. -#' @param link_nu Link of auxiliary parameter \code{nu} if being predicted. -#' @param link_phi Link of auxiliary parameter \code{phi} if being predicted. -#' @param link_kappa Link of auxiliary parameter \code{kappa} if being predicted. -#' @param link_beta Link of auxiliary parameter \code{beta} if being predicted. -#' @param link_zi Link of auxiliary parameter \code{zi} if being predicted. -#' @param link_hu Link of auxiliary parameter \code{hu} if being predicted. -#' @param link_zoi Link of auxiliary parameter \code{zoi} if being predicted. -#' @param link_coi Link of auxiliary parameter \code{coi} if being predicted. -#' @param link_disc Link of auxiliary parameter \code{disc} if being predicted. -#' @param link_bs Link of auxiliary parameter \code{bs} if being predicted. -#' @param link_ndt Link of auxiliary parameter \code{ndt} if being predicted. -#' @param link_bias Link of auxiliary parameter \code{bias} if being predicted. -#' @param link_alpha Link of auxiliary parameter \code{alpha} if being predicted. -#' @param link_quantile Link of auxiliary parameter \code{quantile} if being predicted. -#' @param link_xi Link of auxiliary parameter \code{xi} if being predicted. -#' @param threshold A character string indicating the type -#' of thresholds (i.e. intercepts) used in an ordinal model. -#' \code{"flexible"} provides the standard unstructured thresholds, -#' \code{"equidistant"} restricts the distance between -#' consecutive thresholds to the same value, and -#' \code{"sum_to_zero"} ensures the thresholds sum to zero. -#' @param refcat Optional name of the reference response category used in -#' categorical, multinomial, and dirichlet models. If \code{NULL} (the -#' default), the first category is used as the reference. If \code{NA}, all -#' categories will be predicted, which requires strong priors or carefully -#' specified predictor terms in order to lead to an identified model. -#' @param bhaz Currently for experimental purposes only. -#' -#' @details -#' Below, we list common use cases for the different families. -#' This list is not ment to be exhaustive. -#' \itemize{ -#' \item{Family \code{gaussian} can be used for linear regression.} -#' -#' \item{Family \code{student} can be used for robust linear regression -#' that is less influenced by outliers.} -#' -#' \item{Family \code{skew_normal} can handle skewed responses in linear -#' regression.} -#' -#' \item{Families \code{poisson}, \code{negbinomial}, and \code{geometric} -#' can be used for regression of unbounded count data.} -#' -#' \item{Families \code{bernoulli} and \code{binomial} can be used for -#' binary regression (i.e., most commonly logistic regression).} -#' -#' \item{Families \code{categorical} and \code{multinomial} can be used for -#' multi-logistic regression when there are more than two possible outcomes.} -#' -#' \item{Families \code{cumulative}, \code{cratio} ('continuation ratio'), -#' \code{sratio} ('stopping ratio'), and \code{acat} ('adjacent category') -#' leads to ordinal regression.} -#' -#' \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, -#' \code{lognormal}, \code{frechet}, \code{inverse.gaussian}, and \code{cox} -#' (Cox proportional hazards model) can be used (among others) for -#' time-to-event regression also known as survival regression.} -#' -#' \item{Families \code{weibull}, \code{frechet}, and \code{gen_extreme_value} -#' ('generalized extreme value') allow for modeling extremes.} -#' -#' \item{Families \code{beta} and \code{dirichlet} can be used to model -#' responses representing rates or probabilities.} -#' -#' \item{Family \code{asym_laplace} allows for quantile regression when fixing -#' the auxiliary \code{quantile} parameter to the quantile of interest.} -#' -#' \item{Family \code{exgaussian} ('exponentially modified Gaussian') and -#' \code{shifted_lognormal} are especially suited to model reaction times.} -#' -#' \item{Family \code{wiener} provides an implementation of the Wiener -#' diffusion model. For this family, the main formula predicts the drift -#' parameter 'delta' and all other parameters are modeled as auxiliary parameters -#' (see \code{\link{brmsformula}} for details).} -#' -#' \item{Families \code{hurdle_poisson}, \code{hurdle_negbinomial}, -#' \code{hurdle_gamma}, \code{hurdle_lognormal}, \code{zero_inflated_poisson}, -#' \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, -#' \code{zero_inflated_beta}, and \code{zero_one_inflated_beta} -#' allow to estimate zero-inflated and hurdle models. -#' These models can be very helpful when there are many zeros in the data -#' (or ones in case of one-inflated models) -#' that cannot be explained by the primary distribution of the response.} -#' } -#' -#' Below, we list all possible links for each family. -#' The first link mentioned for each family is the default. -#' \itemize{ -#' \item{Families \code{gaussian}, \code{student}, \code{skew_normal}, -#' \code{exgaussian}, \code{asym_laplace}, and \code{gen_extreme_value} -#' support the links (as names) \code{identity}, \code{log}, \code{inverse}, -#' and \code{softplus}.} -#' -#' \item{Families \code{poisson}, \code{negbinomial}, \code{geometric}, -#' \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, -#' \code{hurdle_poisson}, and \code{hurdle_negbinomial} support -#' \code{log}, \code{identity}, \code{sqrt}, and \code{softplus}.} -#' -#' \item{Families \code{binomial}, \code{bernoulli}, \code{Beta}, -#' \code{zero_inflated_binomial}, \code{zero_inflated_beta}, -#' and \code{zero_one_inflated_beta} support \code{logit}, -#' \code{probit}, \code{probit_approx}, \code{cloglog}, -#' \code{cauchit}, and \code{identity}.} -#' -#' \item{Families \code{cumulative}, \code{cratio}, \code{sratio}, -#' and \code{acat} support \code{logit}, \code{probit}, -#' \code{probit_approx}, \code{cloglog}, and \code{cauchit}.} -#' -#' \item{Families \code{categorical}, \code{multinomial}, and \code{dirichlet} -#' support \code{logit}.} -#' -#' \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, -#' \code{frechet}, and \code{hurdle_gamma} support -#' \code{log}, \code{identity}, \code{inverse}, and \code{softplus}.} -#' -#' \item{Families \code{lognormal} and \code{hurdle_lognormal} -#' support \code{identity} and \code{inverse}.} -#' -#' \item{Family \code{inverse.gaussian} supports \code{1/mu^2}, -#' \code{inverse}, \code{identity}, \code{log}, and \code{softplus}.} -#' -#' \item{Family \code{von_mises} supports \code{tan_half} and -#' \code{identity}.} -#' -#' \item{Family \code{cox} supports \code{log}, \code{identity}, -#' and \code{softplus} for the proportional hazards parameter.} -#' -#' \item{Family \code{wiener} supports \code{identity}, \code{log}, -#' and \code{softplus} for the main parameter which represents the -#' drift rate.} -#' } -#' -#' Please note that when calling the \code{\link[stats:family]{Gamma}} family -#' function of the \pkg{stats} package, the default link will be -#' \code{inverse} instead of \code{log} although the latter is the default in -#' \pkg{brms}. Also, when using the family functions \code{gaussian}, -#' \code{binomial}, \code{poisson}, and \code{Gamma} of the \pkg{stats} -#' package (see \code{\link[stats:family]{family}}), special link functions -#' such as \code{softplus} or \code{cauchit} won't work. In this case, you -#' have to use \code{brmsfamily} to specify the family with corresponding link -#' function. -#' -#' @seealso \code{\link[brms:brm]{brm}}, -#' \code{\link[stats:family]{family}}, -#' \code{\link{customfamily}} -#' -#' @examples -#' # create a family object -#' (fam1 <- student("log")) -#' # alternatively use the brmsfamily function -#' (fam2 <- brmsfamily("student", "log")) -#' # both leads to the same object -#' identical(fam1, fam2) -#' -#' @export -brmsfamily <- function(family, link = NULL, link_sigma = "log", - link_shape = "log", link_nu = "logm1", - link_phi = "log", link_kappa = "log", - link_beta = "log", link_zi = "logit", - link_hu = "logit", link_zoi = "logit", - link_coi = "logit", link_disc = "log", - link_bs = "log", link_ndt = "log", - link_bias = "logit", link_xi = "log1p", - link_alpha = "identity", - link_quantile = "logit", - threshold = "flexible", - refcat = NULL, bhaz = NULL) { - slink <- substitute(link) - .brmsfamily( - family, link = link, slink = slink, - link_sigma = link_sigma, link_shape = link_shape, - link_nu = link_nu, link_phi = link_phi, - link_kappa = link_kappa, link_beta = link_beta, - link_zi = link_zi, link_hu = link_hu, - link_zoi = link_zoi, link_coi = link_coi, - link_disc = link_disc, link_bs = link_bs, - link_ndt = link_ndt, link_bias = link_bias, - link_alpha = link_alpha, link_xi = link_xi, - link_quantile = link_quantile, - threshold = threshold, refcat = refcat, - bhaz = bhaz - ) -} - -# helper function to prepare brmsfamily objects -# @param family character string naming the model family -# @param link character string naming the link function -# @param slink can be used with substitute(link) for -# non-standard evaluation of the link function -# @param threshold threshold type for ordinal models -# @param ... link functions (as character strings) of parameters -# @return an object of 'brmsfamily' which inherits from 'family' -.brmsfamily <- function(family, link = NULL, slink = link, - threshold = "flexible", - refcat = NULL, bhaz = NULL, ...) { - family <- tolower(as_one_character(family)) - aux_links <- list(...) - pattern <- c("^normal$", "^zi_", "^hu_") - replacement <- c("gaussian", "zero_inflated_", "hurdle_") - family <- rename(family, pattern, replacement, fixed = FALSE) - ok_families <- lsp("brms", pattern = "^\\.family_") - ok_families <- sub("^\\.family_", "", ok_families) - if (!family %in% ok_families) { - stop2(family, " is not a supported family. Supported ", - "families are:\n", collapse_comma(ok_families)) - } - family_info <- get(paste0(".family_", family))() - ok_links <- family_info$links - family_info$links <- NULL - # non-standard evaluation of link - if (!is.character(slink)) { - slink <- deparse(slink) - } - if (!slink %in% ok_links) { - if (is.character(link)) { - slink <- link - } else if (!length(link) || identical(link, NA)) { - slink <- NA - } - } - if (length(slink) != 1L) { - stop2("Argument 'link' must be of length 1.") - } - if (is.na(slink)) { - slink <- ok_links[1] - } - if (!slink %in% ok_links) { - stop2("'", slink, "' is not a supported link ", - "for family '", family, "'.\nSupported links are: ", - collapse_comma(ok_links)) - } - out <- list( - family = family, link = slink, - linkfun = function(mu) link(mu, link = slink), - linkinv = function(eta) ilink(eta, link = slink) - ) - out[names(family_info)] <- family_info - class(out) <- c("brmsfamily", "family") - for (dp in valid_dpars(out)) { - alink <- as.character(aux_links[[paste0("link_", dp)]]) - if (length(alink)) { - alink <- as_one_character(alink) - valid_links <- links_dpars(dp) - if (!alink %in% valid_links) { - stop2( - "'", alink, "' is not a supported link ", - "for parameter '", dp, "'.\nSupported links are: ", - collapse_comma(valid_links) - ) - } - out[[paste0("link_", dp)]] <- alink - } - } - if (is_ordinal(out$family)) { - # TODO: move specification of 'threshold' to the 'resp_thres' function? - thres_options <- c("flexible", "equidistant", "sum_to_zero") - out$threshold <- match.arg(threshold, thres_options) - } - if (conv_cats_dpars(out$family)) { - if (!has_joint_link(out$family)) { - out$refcat <- NA - } else if (!is.null(refcat)) { - out$refcat <- as_one_character(refcat, allow_na = TRUE) - } - } - if (is_cox(out$family)) { - if (!is.null(bhaz)) { - if (!is.list(bhaz)) { - stop2("'bhaz' should be a list.") - } - out$bhaz <- bhaz - } else { - out$bhaz <- list() - } - # set default arguments - if (is.null(out$bhaz$df)) { - out$bhaz$df <- 5L - } - if (is.null(out$bhaz$intercept)) { - out$bhaz$intercept <- TRUE - } - } - out -} - -# checks and corrects validity of the model family -# @param family Either a function, an object of class 'family' -# or a character string of length one or two -# @param link an optional character string naming the link function -# ignored if family is a function or a family object -# @param threshold optional character string specifying the threshold -# type in ordinal models -validate_family <- function(family, link = NULL, threshold = NULL) { - if (is.function(family)) { - family <- family() - } - if (!is(family, "brmsfamily")) { - if (is.family(family)) { - link <- family$link - family <- family$family - } - if (is.character(family)) { - if (is.null(link)) { - link <- family[2] - } - family <- .brmsfamily(family[1], link = link) - } else { - stop2("Argument 'family' is invalid.") - } - } - if (is_ordinal(family) && !is.null(threshold)) { - # slot 'threshold' deprecated as of brms > 1.7.0 - threshold <- match.arg(threshold, c("flexible", "equidistant")) - family$threshold <- threshold - } - family -} - -# extract special information of families -# @param x object from which to extract -# @param y name of the component to extract -family_info <- function(x, y, ...) { - UseMethod("family_info") -} - -#' @export -family_info.default <- function(x, y, ...) { - x <- as.character(x) - ulapply(x, .family_info, y = y, ...) -} - -.family_info <- function(x, y, ...) { - x <- as_one_character(x) - y <- as_one_character(y) - if (y == "family") { - return(x) - } - if (!nzchar(x)) { - return(NULL) - } - info <- get(paste0(".family_", x))() - if (y == "link") { - out <- info$links[1] # default link - } else { - info$links <- NULL - out <- info[[y]] - } - out -} - -family_info.NULL <- function(x, y, ...) { - NULL -} - -#' @export -family_info.list <- function(x, y, ...) { - ulapply(x, family_info, y = y, ...) -} - -#' @export -family_info.family <- function(x, y, ...) { - family_info(x$family, y = y, ...) -} - -#' @export -family_info.brmsfamily <- function(x, y, ...) { - y <- as_one_character(y) - out <- x[[y]] - if (is.null(out)) { - # required for models fitted with brms 2.2 or earlier - out <- family_info(x$family, y = y, ...) - } - out -} - -#' @export -family_info.mixfamily <- function(x, y, ...) { - out <- lapply(x$mix, family_info, y = y, ...) - combine_family_info(out, y = y) -} - -#' @export -family_info.brmsformula <- function(x, y, ...) { - family_info(x$family, y = y, ...) -} - -#' @export -family_info.mvbrmsformula <- function(x, y, ...) { - out <- lapply(x$forms, family_info, y = y, ...) - combine_family_info(out, y = y) -} - -#' @export -family_info.brmsterms <- function(x, y, ...) { - family_info(x$family, y = y, ...) -} - -#' @export -family_info.mvbrmsterms <- function(x, y, ...) { - out <- lapply(x$terms, family_info, y = y, ...) - combine_family_info(out, y = y) -} - -#' @export -family_info.btl <- function(x, y, ...) { - family_info(x$family, y = y, ...) -} - -#' @export -family_info.btnl <- function(x, y, ...) { - family_info(x$family, y = y, ...) -} - -#' @export -family_info.brmsfit <- function(x, y, ...) { - family_info(x$formula, y = y, ...) -} - -# combine information from multiple families -# provides special handling for certain elements -combine_family_info <- function(x, y, ...) { - y <- as_one_character(y) - unite <- c( - "dpars", "type", "specials", "include", - "const", "cats", "ad", "normalized" - ) - if (y %in% c("family", "link")) { - x <- unlist(x) - } else if (y %in% unite) { - x <- Reduce("union", x) - } else if (y == "ybounds") { - x <- do_call(rbind, x) - x <- c(max(x[, 1]), min(x[, 2])) - } else if (y == "closed") { - # closed only if no bounds are open - x <- do_call(rbind, x) - clb <- !any(ulapply(x[, 1], isFALSE)) - cub <- !any(ulapply(x[, 2], isFALSE)) - x <- c(clb, cub) - } else if (y == "thres") { - # thresholds are the same across mixture components - x <- x[[1]] - } - x -} - -#' @rdname brmsfamily -#' @export -student <- function(link = "identity", link_sigma = "log", link_nu = "logm1") { - slink <- substitute(link) - .brmsfamily("student", link = link, slink = slink, - link_sigma = link_sigma, link_nu = link_nu) -} - -#' @rdname brmsfamily -#' @export -bernoulli <- function(link = "logit") { - slink <- substitute(link) - .brmsfamily("bernoulli", link = link, slink = slink) -} - -#' @rdname brmsfamily -#' @export -negbinomial <- function(link = "log", link_shape = "log") { - slink <- substitute(link) - .brmsfamily("negbinomial", link = link, slink = slink, - link_shape = link_shape) -} - -# not yet officially supported -# @rdname brmsfamily -# @export -negbinomial2 <- function(link = "log", link_sigma = "log") { - slink <- substitute(link) - .brmsfamily("negbinomial2", link = link, slink = slink, - link_sigma = link_sigma) -} - -#' @rdname brmsfamily -#' @export -geometric <- function(link = "log") { - slink <- substitute(link) - .brmsfamily("geometric", link = link, slink = slink) -} - -# do not export yet! -# @rdname brmsfamily -# @export -discrete_weibull <- function(link = "logit", link_shape = "log") { - slink <- substitute(link) - .brmsfamily("discrete_weibull", link = link, slink = slink, - link_shape = link_shape) -} - -# do not export yet! -# @rdname brmsfamily -# @export -com_poisson <- function(link = "log", link_shape = "log") { - slink <- substitute(link) - .brmsfamily("com_poisson", link = link, slink = slink, - link_shape = link_shape) -} - -#' @rdname brmsfamily -#' @export -lognormal <- function(link = "identity", link_sigma = "log") { - slink <- substitute(link) - .brmsfamily("lognormal", link = link, slink = slink, - link_sigma = link_sigma) -} - -#' @rdname brmsfamily -#' @export -shifted_lognormal <- function(link = "identity", link_sigma = "log", - link_ndt = "log") { - slink <- substitute(link) - .brmsfamily("shifted_lognormal", link = link, slink = slink, - link_sigma = link_sigma, link_ndt = link_ndt) -} - -#' @rdname brmsfamily -#' @export -skew_normal <- function(link = "identity", link_sigma = "log", - link_alpha = "identity") { - slink <- substitute(link) - .brmsfamily("skew_normal", link = link, slink = slink, - link_sigma = link_sigma, link_alpha = link_alpha) -} - -#' @rdname brmsfamily -#' @export -exponential <- function(link = "log") { - slink <- substitute(link) - .brmsfamily("exponential", link = link, slink = slink) -} - -#' @rdname brmsfamily -#' @export -weibull <- function(link = "log", link_shape = "log") { - slink <- substitute(link) - .brmsfamily("weibull", link = link, slink = slink, - link_shape = link_shape) -} - -#' @rdname brmsfamily -#' @export -frechet <- function(link = "log", link_nu = "logm1") { - slink <- substitute(link) - .brmsfamily("frechet", link = link, slink = slink, - link_nu = link_nu) -} - -#' @rdname brmsfamily -#' @export -gen_extreme_value <- function(link = "identity", link_sigma = "log", - link_xi = "log1p") { - slink <- substitute(link) - .brmsfamily("gen_extreme_value", link = link, slink = slink, - link_sigma = link_sigma, link_xi = link_xi) -} - -#' @rdname brmsfamily -#' @export -exgaussian <- function(link = "identity", link_sigma = "log", - link_beta = "log") { - slink <- substitute(link) - .brmsfamily("exgaussian", link = link, slink = slink, - link_sigma = link_sigma, link_beta = link_beta) -} - -#' @rdname brmsfamily -#' @export -wiener <- function(link = "identity", link_bs = "log", - link_ndt = "log", link_bias = "logit") { - slink <- substitute(link) - .brmsfamily("wiener", link = link, slink = slink, - link_bs = link_bs, link_ndt = link_ndt, - link_bias = link_bias) -} - -#' @rdname brmsfamily -#' @export -Beta <- function(link = "logit", link_phi = "log") { - slink <- substitute(link) - .brmsfamily("beta", link = link, slink = slink, - link_phi = link_phi) -} - -#' @rdname brmsfamily -#' @export -dirichlet <- function(link = "logit", link_phi = "log", refcat = NULL) { - slink <- substitute(link) - .brmsfamily("dirichlet", link = link, slink = slink, - link_phi = link_phi, refcat = refcat) -} - -# not yet exported -# @rdname brmsfamily -# @export -dirichlet2 <- function(link = "log") { - slink <- substitute(link) - .brmsfamily("dirichlet2", link = link, slink = slink, refcat = NA) -} - -#' @rdname brmsfamily -#' @export -von_mises <- function(link = "tan_half", link_kappa = "log") { - slink <- substitute(link) - .brmsfamily("von_mises", link = link, slink = slink, - link_kappa = link_kappa) -} - -#' @rdname brmsfamily -#' @export -asym_laplace <- function(link = "identity", link_sigma = "log", - link_quantile = "logit") { - slink <- substitute(link) - .brmsfamily("asym_laplace", link = link, slink = slink, - link_sigma = link_sigma, link_quantile = link_quantile) -} - -# do not export yet! -# @rdname brmsfamily -# @export -zero_inflated_asym_laplace <- function(link = "identity", link_sigma = "log", - link_quantile = "logit", - link_zi = "logit") { - slink <- substitute(link) - .brmsfamily("zero_inflated_asym_laplace", link = link, slink = slink, - link_sigma = link_sigma, link_quantile = link_quantile, - link_zi = link_zi) -} - -#' @rdname brmsfamily -#' @export -cox <- function(link = "log", bhaz = NULL) { - slink <- substitute(link) - .brmsfamily("cox", link = link, bhaz = bhaz) -} - -#' @rdname brmsfamily -#' @export -hurdle_poisson <- function(link = "log") { - slink <- substitute(link) - .brmsfamily("hurdle_poisson", link = link, slink = slink) -} - -#' @rdname brmsfamily -#' @export -hurdle_negbinomial <- function(link = "log", link_shape = "log", - link_hu = "logit") { - slink <- substitute(link) - .brmsfamily("hurdle_negbinomial", link = link, slink = slink, - link_shape = link_shape, link_hu = link_hu) -} - -#' @rdname brmsfamily -#' @export -hurdle_gamma <- function(link = "log", link_shape = "log", - link_hu = "logit") { - slink <- substitute(link) - .brmsfamily("hurdle_gamma", link = link, slink = slink, - link_shape = link_shape, link_hu = link_hu) -} - -#' @rdname brmsfamily -#' @export -hurdle_lognormal <- function(link = "identity", link_sigma = "log", - link_hu = "logit") { - slink <- substitute(link) - .brmsfamily("hurdle_lognormal", link = link, slink = slink, - link_sigma = link_sigma, link_hu = link_hu) -} - -#' @rdname brmsfamily -#' @export -zero_inflated_beta <- function(link = "logit", link_phi = "log", - link_zi = "logit") { - slink <- substitute(link) - .brmsfamily("zero_inflated_beta", link = link, slink = slink, - link_phi = link_phi, link_zi = link_zi) -} - -#' @rdname brmsfamily -#' @export -zero_one_inflated_beta <- function(link = "logit", link_phi = "log", - link_zoi = "logit", link_coi = "logit") { - slink <- substitute(link) - .brmsfamily("zero_one_inflated_beta", link = link, slink = slink, - link_phi = link_phi, link_zoi = link_zoi, - link_coi = link_coi) -} - -#' @rdname brmsfamily -#' @export -zero_inflated_poisson <- function(link = "log", link_zi = "logit") { - slink <- substitute(link) - .brmsfamily("zero_inflated_poisson", link = link, slink = slink, - link_zi = link_zi) -} - -#' @rdname brmsfamily -#' @export -zero_inflated_negbinomial <- function(link = "log", link_shape = "log", - link_zi = "logit") { - slink <- substitute(link) - .brmsfamily("zero_inflated_negbinomial", link = link, slink = slink, - link_shape = link_shape, link_zi = link_zi) -} - -#' @rdname brmsfamily -#' @export -zero_inflated_binomial <- function(link = "logit", link_zi = "logit") { - slink <- substitute(link) - .brmsfamily("zero_inflated_binomial", link = link, slink = slink, - link_zi = link_zi) -} - -#' @rdname brmsfamily -#' @export -categorical <- function(link = "logit", refcat = NULL) { - slink <- substitute(link) - .brmsfamily("categorical", link = link, slink = slink, refcat = refcat) -} - -#' @rdname brmsfamily -#' @export -multinomial <- function(link = "logit", refcat = NULL) { - slink <- substitute(link) - .brmsfamily("multinomial", link = link, slink = slink, refcat = refcat) -} - -#' @rdname brmsfamily -#' @export -cumulative <- function(link = "logit", link_disc = "log", - threshold = "flexible") { - slink <- substitute(link) - .brmsfamily("cumulative", link = link, slink = slink, - link_disc = link_disc, threshold = threshold) -} - -#' @rdname brmsfamily -#' @export -sratio <- function(link = "logit", link_disc = "log", - threshold = "flexible") { - slink <- substitute(link) - .brmsfamily("sratio", link = link, slink = slink, - link_disc = link_disc, threshold = threshold) -} - -#' @rdname brmsfamily -#' @export -cratio <- function(link = "logit", link_disc = "log", - threshold = "flexible") { - slink <- substitute(link) - .brmsfamily("cratio", link = link, slink = slink, - link_disc = link_disc, threshold = threshold) -} - -#' @rdname brmsfamily -#' @export -acat <- function(link = "logit", link_disc = "log", - threshold = "flexible") { - slink <- substitute(link) - .brmsfamily("acat", link = link, slink = slink, - link_disc = link_disc, threshold = threshold) -} - -#' Finite Mixture Families in \pkg{brms} -#' -#' Set up a finite mixture family for use in \pkg{brms}. -#' -#' @param ... One or more objects providing a description of the -#' response distributions to be combined in the mixture model. -#' These can be family functions, calls to family functions or -#' character strings naming the families. For details of supported -#' families see \code{\link{brmsfamily}}. -#' @param flist Optional list of objects, which are treated in the -#' same way as objects passed via the \code{...} argument. -#' @param nmix Optional numeric vector specifying the number of times -#' each family is repeated. If specified, it must have the same length -#' as the number of families passed via \code{...} and \code{flist}. -#' @param order Ordering constraint to identify mixture components. -#' If \code{'mu'} or \code{TRUE}, population-level intercepts -#' of the mean parameters are ordered in non-ordinal models -#' and fixed to the same value in ordinal models (see details). -#' If \code{'none'} or \code{FALSE}, no ordering constraint is applied. -#' If \code{NULL} (the default), \code{order} is set to \code{'mu'} -#' if all families are the same and \code{'none'} otherwise. -#' Other ordering constraints may be implemented in the future. -#' -#' @return An object of class \code{mixfamily}. -#' -#' @details -#' -#' Most families supported by \pkg{brms} can be used to form mixtures. The -#' response variable has to be valid for all components of the mixture family. -#' Currently, the number of mixture components has to be specified by the user. -#' It is not yet possible to estimate the number of mixture components from the -#' data. -#' -#' Ordering intercepts in mixtures of ordinal families is not possible as each -#' family has itself a set of vector of intercepts (i.e. ordinal thresholds). -#' Instead, \pkg{brms} will fix the vector of intercepts across components in -#' ordinal mixtures, if desired, so that users can try to identify the mixture -#' model via selective inclusion of predictors. -#' -#' For most mixture models, you may want to specify priors on the -#' population-level intercepts via \code{\link{set_prior}} to improve -#' convergence. In addition, it is sometimes necessary to set \code{inits = 0} -#' in the call to \code{\link{brm}} to allow chains to initialize properly. -#' -#' For more details on the specification of mixture -#' models, see \code{\link{brmsformula}}. -#' -#' @examples -#' \dontrun{ -#' ## simulate some data -#' set.seed(1234) -#' dat <- data.frame( -#' y = c(rnorm(200), rnorm(100, 6)), -#' x = rnorm(300), -#' z = sample(0:1, 300, TRUE) -#' ) -#' -#' ## fit a simple normal mixture model -#' mix <- mixture(gaussian, gaussian) -#' prior <- c( -#' prior(normal(0, 7), Intercept, dpar = mu1), -#' prior(normal(5, 7), Intercept, dpar = mu2) -#' ) -#' fit1 <- brm(bf(y ~ x + z), dat, family = mix, -#' prior = prior, chains = 2) -#' summary(fit1) -#' pp_check(fit1) -#' -#' ## use different predictors for the components -#' fit2 <- brm(bf(y ~ 1, mu1 ~ x, mu2 ~ z), dat, family = mix, -#' prior = prior, chains = 2) -#' summary(fit2) -#' -#' ## fix the mixing proportions -#' fit3 <- brm(bf(y ~ x + z, theta1 = 1, theta2 = 2), -#' dat, family = mix, prior = prior, -#' inits = 0, chains = 2) -#' summary(fit3) -#' pp_check(fit3) -#' -#' ## predict the mixing proportions -#' fit4 <- brm(bf(y ~ x + z, theta2 ~ x), -#' dat, family = mix, prior = prior, -#' inits = 0, chains = 2) -#' summary(fit4) -#' pp_check(fit4) -#' -#' ## compare model fit -#' LOO(fit1, fit2, fit3, fit4) -#' } -#' -#' @export -mixture <- function(..., flist = NULL, nmix = 1, order = NULL) { - dots <- c(list(...), flist) - if (length(nmix) == 1L) { - nmix <- rep(nmix, length(dots)) - } - if (length(dots) != length(nmix)) { - stop2("The length of 'nmix' should be the same ", - "as the number of mixture components.") - } - dots <- dots[rep(seq_along(dots), nmix)] - family <- list( - family = "mixture", - link = "identity", - mix = lapply(dots, validate_family) - ) - class(family) <- c("mixfamily", "brmsfamily", "family") - # validity checks - if (length(family$mix) < 2L) { - stop2("Expecting at least 2 mixture components.") - } - if (use_real(family) && use_int(family)) { - stop2("Cannot mix families with real and integer support.") - } - is_ordinal <- ulapply(family$mix, is_ordinal) - if (any(is_ordinal) && any(!is_ordinal)) { - stop2("Cannot mix ordinal and non-ordinal families.") - } - no_mixture <- ulapply(family$mix, no_mixture) - if (any(no_mixture)) { - stop2("Some of the families are not allowed in mixture models.") - } - for (fam in family$mix) { - if (is.customfamily(fam) && "theta" %in% fam$dpars) { - stop2("Parameter name 'theta' is reserved in mixture models.") - } - } - if (is.null(order)) { - if (any(is_ordinal)) { - family$order <- "none" - message("Setting order = 'none' for mixtures of ordinal families.") - } else if (length(unique(family_names(family))) == 1L) { - family$order <- "mu" - message("Setting order = 'mu' for mixtures of the same family.") - } else { - family$order <- "none" - message("Setting order = 'none' for mixtures of different families.") - } - } else { - if (length(order) != 1L) { - stop2("Argument 'order' must be of length 1.") - } - if (is.character(order)) { - valid_order <- c("none", "mu") - if (!order %in% valid_order) { - stop2("Argument 'order' is invalid. Valid options are: ", - collapse_comma(valid_order)) - } - family$order <- order - } else { - family$order <- ifelse(as.logical(order), "mu", "none") - } - } - family -} - -#' Custom Families in \pkg{brms} Models -#' -#' Define custom families (i.e. response distribution) for use in -#' \pkg{brms} models. It allows users to benefit from the modeling -#' flexibility of \pkg{brms}, while applying their self-defined likelihood -#' functions. All of the post-processing methods for \code{brmsfit} -#' objects can be made compatible with custom families. -#' See \code{vignette("brms_customfamilies")} for more details. -#' For a list of built-in families see \code{\link{brmsfamily}}. -#' -#' @aliases customfamily -#' -#' @param name Name of the custom family. -#' @param dpars Names of the distributional parameters of -#' the family. One parameter must be named \code{"mu"} and -#' the main formula of the model will correspond to that -#' parameter. -#' @param links Names of the link functions of the -#' distributional parameters. -#' @param type Indicates if the response distribution is -#' continuous (\code{"real"}) or discrete (\code{"int"}). This controls -#' if the corresponding density function will be named with -#' \code{_lpdf} or \code{_lpmf}. -#' @param lb Vector of lower bounds of the distributional -#' parameters. Defaults to \code{NA} that is no lower bound. -#' @param ub Vector of upper bounds of the distributional -#' parameters. Defaults to \code{NA} that is no upper bound. -#' @param vars Names of variables that are part of the likelihood function -#' without being distributional parameters. That is, \code{vars} can be used -#' to pass data to the likelihood. Such arguments will be added to the list of -#' function arguments at the end, after the distributional parameters. See -#' \code{\link{stanvar}} for details about adding self-defined data to the -#' generated \pkg{Stan} model. Addition arguments \code{vreal} and \code{vint} -#' may be used for this purpose as well (see Examples below). See also -#' \code{\link{brmsformula}} and \code{\link{addition-terms}} for more -#' details. -#' @param loop Logical; Should the likelihood be evaluated via a loop -#' (\code{TRUE}; the default) over observations in Stan? -#' If \code{FALSE}, the Stan code will be written in a vectorized -#' manner over observations if possible. -#' @param specials A character vector of special options to enable -#' for this custom family. Currently for internal use only. -#' @param threshold Optional threshold type for custom ordinal families. -#' Ignored for non-ordinal families. -#' @param log_lik Optional function to compute log-likelihood values of -#' the model in \R. This is only relevant if one wants to ensure -#' compatibility with method \code{\link[brms:log_lik.brmsfit]{log_lik}}. -#' @param posterior_predict Optional function to compute posterior prediction of -#' the model in \R. This is only relevant if one wants to ensure compatibility -#' with method \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}. -#' @param posterior_epred Optional function to compute expected values of the -#' posterior predictive distribution of the model in \R. This is only relevant -#' if one wants to ensure compatibility with method -#' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. -#' @param predict Deprecated alias of `posterior_predict`. -#' @param fitted Deprecated alias of `posterior_epred`. -#' @param env An \code{\link{environment}} in which certain post-processing -#' functions related to the custom family can be found, if there were not -#' directly passed to \code{custom_family}. This is only -#' relevant if one wants to ensure compatibility with the methods -#' \code{\link[brms:log_lik.brmsfit]{log_lik}}, -#' \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}, or -#' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. -#' By default, \code{env} is the environment from which -#' \code{custom_family} is called. -#' -#' @details The corresponding probability density or mass \code{Stan} -#' functions need to have the same name as the custom family. -#' That is if a family is called \code{myfamily}, then the -#' \pkg{Stan} functions should be called \code{myfamily_lpdf} or -#' \code{myfamily_lpmf} depending on whether it defines a -#' continuous or discrete distribution. -#' -#' @return An object of class \code{customfamily} inheriting -#' from class \code{\link{brmsfamily}}. -#' -#' @seealso \code{\link{brmsfamily}}, \code{\link{brmsformula}}, -#' \code{\link{stanvar}} -#' -#' @examples -#' \dontrun{ -#' ## demonstrate how to fit a beta-binomial model -#' ## generate some fake data -#' phi <- 0.7 -#' n <- 300 -#' z <- rnorm(n, sd = 0.2) -#' ntrials <- sample(1:10, n, replace = TRUE) -#' eta <- 1 + z -#' mu <- exp(eta) / (1 + exp(eta)) -#' a <- mu * phi -#' b <- (1 - mu) * phi -#' p <- rbeta(n, a, b) -#' y <- rbinom(n, ntrials, p) -#' dat <- data.frame(y, z, ntrials) -#' -#' # define a custom family -#' beta_binomial2 <- custom_family( -#' "beta_binomial2", dpars = c("mu", "phi"), -#' links = c("logit", "log"), lb = c(NA, 0), -#' type = "int", vars = "vint1[n]" -#' ) -#' -#' # define the corresponding Stan density function -#' stan_density <- " -#' real beta_binomial2_lpmf(int y, real mu, real phi, int N) { -#' return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); -#' } -#' " -#' stanvars <- stanvar(scode = stan_density, block = "functions") -#' -#' # fit the model -#' fit <- brm(y | vint(ntrials) ~ z, data = dat, -#' family = beta_binomial2, stanvars = stanvars) -#' summary(fit) -#' -#' -#' # define a *vectorized* custom family (no loop over observations) -#' # notice also that 'vint' no longer has an observation index -#' beta_binomial2_vec <- custom_family( -#' "beta_binomial2", dpars = c("mu", "phi"), -#' links = c("logit", "log"), lb = c(NA, 0), -#' type = "int", vars = "vint1", loop = FALSE -#' ) -#' -#' # define the corresponding Stan density function -#' stan_density_vec <- " -#' real beta_binomial2_lpmf(int[] y, vector mu, real phi, int[] N) { -#' return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); -#' } -#' " -#' stanvars_vec <- stanvar(scode = stan_density_vec, block = "functions") -#' -#' # fit the model -#' fit_vec <- brm(y | vint(ntrials) ~ z, data = dat, -#' family = beta_binomial2_vec, -#' stanvars = stanvars_vec) -#' summary(fit_vec) -#' } -#' -#' @export -custom_family <- function(name, dpars = "mu", links = "identity", - type = c("real", "int"), lb = NA, ub = NA, - vars = NULL, loop = TRUE, specials = NULL, - threshold = "flexible", - log_lik = NULL, posterior_predict = NULL, - posterior_epred = NULL, predict = NULL, - fitted = NULL, env = parent.frame()) { - name <- as_one_character(name) - dpars <- as.character(dpars) - links <- as.character(links) - type <- match.arg(type) - lb <- as.character(lb) - ub <- as.character(ub) - vars <- as.character(vars) - loop <- as_one_logical(loop) - specials <- as.character(specials) - env <- as.environment(env) - posterior_predict <- use_alias(posterior_predict, predict) - posterior_epred <- use_alias(posterior_epred, fitted) - if (any(duplicated(dpars))) { - stop2("Duplicated 'dpars' are not allowed.") - } - if (!"mu" %in% dpars) { - stop2("All families must have a 'mu' parameter.") - } - if (any(grepl("_|\\.", dpars))) { - stop2("Dots or underscores are not allowed in 'dpars'.") - } - if (any(grepl("[[:digit:]]+$", dpars))) { - stop2("'dpars' should not end with a number.") - } - for (arg in c("links", "lb", "ub")) { - obj <- get(arg) - if (length(obj) == 1L) { - obj <- rep(obj, length(dpars)) - assign(arg, obj) - } - if (length(dpars) != length(obj)) { - stop2("'", arg, "' must be of the same length as 'dpars'.") - } - } - if (!is.null(log_lik)) { - log_lik <- as.function(log_lik) - args <- names(formals(log_lik)) - if (!is_equal(args[1:2], c("i", "draws"))) { - stop2("The first two arguments of 'log_lik' ", - "should be 'i' and 'draws'.") - } - } - if (!is.null(posterior_predict)) { - posterior_predict <- as.function(posterior_predict) - args <- names(formals(posterior_predict)) - if (!is_equal(args[1:3], c("i", "draws", "..."))) { - stop2("The first three arguments of 'posterior_predict' ", - "should be 'i', 'draws', and '...'.") - } - } - if (!is.null(posterior_epred)) { - posterior_epred <- as.function(posterior_epred) - args <- names(formals(posterior_epred)) - if (!is_equal(args[1], "draws")) { - stop2("The first argument of 'posterior_epred' should be 'draws'.") - } - } - lb <- named_list(dpars, lb) - ub <- named_list(dpars, ub) - is_mu <- "mu" == dpars - link <- links[is_mu] - normalized <- "" - out <- nlist( - family = "custom", link, name, - dpars, lb, ub, type, vars, loop, specials, - log_lik, posterior_predict, posterior_epred, env, - normalized - ) - if (length(dpars) > 1L) { - out[paste0("link_", dpars[!is_mu])] <- links[!is_mu] - } - class(out) <- c("customfamily", "brmsfamily", "family") - if (is_ordinal(out)) { - threshold <- match.arg(threshold) - out$threshold <- threshold - } - out -} - -# get post-processing methods for custom families -custom_family_method <- function(family, name) { - if (!is.customfamily(family)) { - return(NULL) - } - out <- family[[name]] - if (!is.function(out)) { - out <- paste0(name, "_", family$name) - out <- get(out, family$env) - } - out -} - -# get valid distributional parameters for a family -valid_dpars <- function(family, ...) { - UseMethod("valid_dpars") -} - -#' @export -valid_dpars.default <- function(family, ...) { - if (!length(family)) { - return("mu") - } - family <- validate_family(family) - family_info(family, "dpars", ...) -} - -#' @export -valid_dpars.mixfamily <- function(family, ...) { - out <- lapply(family$mix, valid_dpars, ...) - for (i in seq_along(out)) { - out[[i]] <- paste0(out[[i]], i) - } - c(unlist(out), paste0("theta", seq_along(out))) -} - -#' @export -valid_dpars.brmsformula <- function(family, ...) { - valid_dpars(family$family, ...) -} - -#' @export -valid_dpars.mvbrmsformula <- function(family, ...) { - ulapply(family$forms, valid_dpars, ...) -} - -#' @export -valid_dpars.brmsterms <- function(family, ...) { - valid_dpars(family$family, ...) -} - -#' @export -valid_dpars.mvbrmsterms <- function(family, ...) { - ulapply(family$terms, valid_dpars, ...) -} - -#' @export -valid_dpars.brmsfit <- function(family, ...) { - valid_dpars(family$formula, ...) -} - -# class of a distributional parameter -dpar_class <- function(dpar, family = NULL) { - out <- sub("[[:digit:]]*$", "", dpar) - if (!is.null(family)) { - # TODO: avoid this special case by changing naming conventions - if (conv_cats_dpars(family) && grepl("^mu", out)) { - # categorical-like models have non-integer suffixes - # that will not be caught by the standard procedure - out <- "mu" - } - } - out -} - -# id of a distributional parameter -dpar_id <- function(dpar) { - out <- get_matches("[[:digit:]]+$", dpar, simplify = FALSE) - ulapply(out, function(x) ifelse(length(x), x, "")) -} - -# link functions for distributional parameters -links_dpars <- function(dpar) { - if (!length(dpar)) dpar <- "" - switch(dpar, - character(0), - mu = "identity", # not actually used - sigma = c("log", "identity", "softplus", "squareplus"), - shape = c("log", "identity", "softplus", "squareplus"), - nu = c("logm1", "identity"), - phi = c("log", "identity", "softplus", "squareplus"), - kappa = c("log", "identity", "softplus", "squareplus"), - beta = c("log", "identity", "softplus", "squareplus"), - zi = c("logit", "identity"), - hu = c("logit", "identity"), - zoi = c("logit", "identity"), - coi = c("logit", "identity"), - disc = c("log", "identity", "softplus", "squareplus"), - bs = c("log", "identity", "softplus", "squareplus"), - ndt = c("log", "identity", "softplus", "squareplus"), - bias = c("logit", "identity"), - quantile = c("logit", "identity"), - xi = c("log1p", "identity"), - alpha = c("identity", "log", "softplus", "squareplus"), - theta = c("identity") - ) -} - -# generate a family object of a distributional parameter -dpar_family <- function(family, dpar, ...) { - UseMethod("dpar_family") -} - -#' @export -dpar_family.default <- function(family, dpar, ...) { - dp_class <- dpar_class(dpar, family) - if (dp_class == "mu") { - if (conv_cats_dpars(family)) { - link <- NULL - if (!has_joint_link(family)) { - link <- family$link - } - # joint links are applied directly in the likelihood function - # so link is treated as 'identity' - out <- .dpar_family(dpar, link) - } else { - # standard single mu parameters just store the original family - out <- family - } - } else { - # link_ is always defined for non-mu parameters - link <- family[[paste0("link_", dp_class)]] - out <- .dpar_family(dpar, link) - } - out -} - -#' @export -dpar_family.mixfamily <- function(family, dpar, ...) { - dp_id <- as.numeric(dpar_id(dpar)) - if (!(length(dp_id) == 1L && is.numeric(dp_id))) { - stop2("Parameter '", dpar, "' is not a valid mixture parameter.") - } - out <- dpar_family(family$mix[[dp_id]], dpar, ...) - out$order <- family$order - out -} - -# set up special family objects for distributional parameters -# @param dpar name of the distributional parameter -# @param link optional link function of the parameter -.dpar_family <- function(dpar = NULL, link = NULL) { - links <- links_dpars(dpar_class(dpar)) - if (!length(link)) { - if (!length(links)) { - link <- "identity" - } else { - link <- links[1] - } - } - link <- as_one_character(link) - structure( - nlist(family = "", link, dpar), - class = c("brmsfamily", "family") - ) -} - -#' @export -print.brmsfamily <- function(x, links = FALSE, newline = TRUE, ...) { - cat("\nFamily:", x$family, "\n") - cat("Link function:", x$link, "\n") - if (!is.null(x$threshold)) { - cat("Threshold:", x$threshold, "\n") - } - if (isTRUE(links) || is.character(links)) { - dp_links <- x[grepl("^link_", names(x))] - names(dp_links) <- sub("^link_", "", names(dp_links)) - if (is.character(links)) { - dp_links <- rmNULL(dp_links[links]) - } - for (dp in names(dp_links)) { - cat(paste0( - "Link function of '", dp, "' (if predicted): ", - dp_links[[dp]], "\n" - )) - } - } - if (newline) { - cat("\n") - } - invisible(x) -} - -#' @export -print.mixfamily <- function(x, newline = TRUE, ...) { - cat("\nMixture\n") - for (i in seq_along(x$mix)) { - print(x$mix[[i]], newline = FALSE, ...) - } - if (newline) { - cat("\n") - } - invisible(x) -} - -#' @export -print.customfamily <- function(x, links = FALSE, newline = TRUE, ...) { - cat("\nCustom family:", x$name, "\n") - cat("Link function:", x$link, "\n") - cat("Parameters:", paste0(x$dpars, collapse = ", "), "\n") - if (isTRUE(links) || is.character(links)) { - dp_links <- x[grepl("^link_", names(x))] - names(dp_links) <- sub("^link_", "", names(dp_links)) - if (is.character(links)) { - dp_links <- rmNULL(dp_links[links]) - } - for (dp in names(dp_links)) { - cat(paste0( - "Link function of '", dp, "' (if predicted): ", - dp_links[[dp]], "\n" - )) - } - } - if (newline) { - cat("\n") - } - invisible(x) -} - -#' @method summary family -#' @export -summary.family <- function(object, link = TRUE, ...) { - out <- object$family - if (link) { - out <- paste0(out, "(", object$link, ")") - } - out -} - -#' @method summary mixfamily -#' @export -summary.mixfamily <- function(object, link = FALSE, ...) { - families <- ulapply(object$mix, summary, link = link, ...) - paste0("mixture(", paste0(families, collapse = ", "), ")") -} - -#' @method summary customfamily -#' @export -summary.customfamily <- function(object, link = TRUE, ...) { - object$family <- object$name - summary.family(object, link = link, ...) -} - -summarise_families <- function(x) { - # summary of families used in summary.brmsfit - UseMethod("summarise_families") -} - -#' @export -summarise_families.mvbrmsformula <- function(x, ...) { - out <- ulapply(x$forms, summarise_families, ...) - paste0("MV(", paste0(out, collapse = ", "), ")") -} - -#' @export -summarise_families.brmsformula <- function(x, ...) { - summary(x$family, link = FALSE, ...) -} - -summarise_links <- function(x, ...) { - # summary of link functions used in summary.brmsfit - UseMethod("summarise_links") -} - -#' @export -summarise_links.mvbrmsformula <- function(x, wsp = 0, ...) { - str_wsp <- collapse(rep(" ", wsp)) - links <- ulapply(x$forms, summarise_links, mv = TRUE, ...) - paste0(links, collapse = paste0("\n", str_wsp)) -} - -#' @export -summarise_links.brmsformula <- function(x, mv = FALSE, ...) { - x <- brmsterms(x) - dpars <- valid_dpars(x) - links <- setNames(rep("identity", length(dpars)), dpars) - links_pred <- ulapply(x$dpars, function(x) x$family$link) - links[names(links_pred)] <- links_pred - if (conv_cats_dpars(x)) { - links[grepl("^mu", names(links))] <- x$family$link - } - resp <- if (mv) usc(combine_prefix(x)) - names(links) <- paste0(names(links), resp) - paste0(names(links), " = ", links, collapse = "; ") -} - -is.family <- function(x) { - inherits(x, "family") -} - -is.brmsfamily <- function(x) { - inherits(x, "brmsfamily") -} - -is.mixfamily <- function(x) { - inherits(x, "mixfamily") -} - -is.customfamily <- function(x) { - inherits(x, "customfamily") -} - -family_names <- function(x) { - family_info(x, "family") -} - -# indicate if family uses real responses -use_real <- function(family) { - "real" %in% family_info(family, "type") -} - -# indicate if family uses integer responses -use_int <- function(family) { - "int" %in% family_info(family, "type") -} - -is_binary <- function(family) { - "binary" %in% family_info(family, "specials") -} - -is_categorical <- function(family) { - "categorical" %in% family_info(family, "specials") -} - -is_ordinal <- function(family) { - "ordinal" %in% family_info(family, "specials") -} - -is_multinomial <- function(family) { - "multinomial" %in% family_info(family, "specials") -} - -is_dirichlet <- function(family) { - "dirichlet" %in% family_info(family, "specials") -} - -is_polytomous <- function(family) { - is_categorical(family) || is_ordinal(family) || - is_multinomial(family) || is_dirichlet(family) -} - -is_cox <- function(family) { - "cox" %in% family_info(family, "specials") -} - -# has joint link function over multiple inputs -has_joint_link <- function(family) { - "joint_link" %in% family_info(family, "specials") -} - -allow_factors <- function(family) { - specials <- c("binary", "categorical", "ordinal") - any(specials %in% family_info(family, "specials")) -} - -# check if the family has natural residuals -has_natural_residuals <- function(family) { - "residuals" %in% family_info(family, "specials") -} - -# check if the family allows for residual correlations -has_rescor <- function(family) { - "rescor" %in% family_info(family, "specials") -} - -# check if category specific effects are allowed -allow_cs <- function(family) { - any(c("cs", "ocs") %in% family_info(family, "specials")) -} - -# check if category specific effects should be ordered -needs_ordered_cs <- function(family) { - "ocs" %in% family_info(family, "specials") -} - -# choose dpar names based on categories? -conv_cats_dpars <- function(family) { - is_categorical(family) || is_multinomial(family) || is_dirichlet(family) -} - -# check if mixtures of the given families are allowed -no_mixture <- function(family) { - is_categorical(family) || is_multinomial(family) || is_dirichlet(family) -} - -# indicate if the response should consist of multiple columns -has_multicol <- function(family) { - is_multinomial(family) || is_dirichlet(family) -} - -# indicate if the response is modeled on the log-scale -# even if formally the link function is not 'log' -has_logscale <- function(family) { - "logscale" %in% family_info(family, "specials") -} - -# indicate if family makes use of argument trials -has_trials <- function(family) { - "trials" %in% family_info(family, "ad") && - !"custom" %in% family_names(family) -} - -# indicate if family has more than two response categories -has_cat <- function(family) { - is_categorical(family) || is_multinomial(family) || is_dirichlet(family) -} - -# indicate if family has thresholds -has_thres <- function(family) { - is_ordinal(family) -} - -# indicate if family has equidistant thresholds -has_equidistant_thres <- function(family) { - "equidistant" %in% family_info(family, "threshold") -} - -# indicate if family has sum-to-zero thresholds -has_sum_to_zero_thres <- function(family) { - "sum_to_zero" %in% family_info(family, "threshold") -} - -# indicate if family has ordered thresholds -has_ordered_thres <- function(family) { - "ordered_thres" %in% family_info(family, "specials") -} - -# compute threshold - eta in the likelihood -has_thres_minus_eta <- function(family) { - "thres_minus_eta" %in% family_info(family, "specials") -} - -# compute eta - threshold in the likelihood -has_eta_minus_thres <- function(family) { - "eta_minus_thres" %in% family_info(family, "specials") -} - -# get names of response categories -# @param group name of a group for which to extract categories -get_cats <- function(family) { - family_info(family, "cats") -} - -# get names of ordinal thresholds for prior specification -# @param group name of a group for which to extract categories -get_thres <- function(family, group = "") { - group <- as_one_character(group) - thres <- family_info(family, "thres") - subset2(thres, group = group)$thres -} - -# get group names of ordinal thresholds -get_thres_groups <- function(family) { - thres <- family_info(family, "thres") - unique(thres$group) -} - -# has the model group specific thresholds? -has_thres_groups <- function(family) { - groups <- get_thres_groups(family) - any(nzchar(groups)) -} - -has_ndt <- function(family) { - "ndt" %in% dpar_class(family_info(family, "dpars")) -} - -has_sigma <- function(family) { - "sigma" %in% dpar_class(family_info(family, "dpars")) -} - -# check if sigma should be explicitely set to 0 -no_sigma <- function(bterms) { - stopifnot(is.brmsterms(bterms)) - if (is.formula(bterms$adforms$se)) { - se <- eval_rhs(bterms$adforms$se) - se_only <- isFALSE(se$flags$sigma) - if (se_only && use_ac_cov_time(bterms)) { - stop2("Please set argument 'sigma' of function 'se' ", - "to TRUE when modeling time-series covariance matrices.") - } - } else { - se_only <- FALSE - } - se_only -} - -# has the model a non-predicted but estimated sigma parameter? -simple_sigma <- function(bterms) { - stopifnot(is.brmsterms(bterms)) - has_sigma(bterms) && !no_sigma(bterms) && !pred_sigma(bterms) -} - -# has the model a predicted sigma parameter? -pred_sigma <- function(bterms) { - stopifnot(is.brmsterms(bterms)) - "sigma" %in% dpar_class(names(bterms$dpars)) -} - -# do not include a 'nu' parameter in a univariate model? -no_nu <- function(bterms) { - # the multi_student_t family only has a single 'nu' parameter - isTRUE(bterms$rescor) && "student" %in% family_names(bterms) -} - -# does the family-link combination have a built-in Stan function? -has_built_in_fun <- function(family, link = NULL, dpar = NULL, cdf = FALSE) { - link <- link %||% family$link - glm_special <- paste0("sbi", usc(dpar), "_", link, str_if(cdf, "_cdf")) - all(glm_special %in% family_info(family, "specials")) -} - -# suffixes of Stan lpdfs or lpmfs for which only a normalized version exists -always_normalized <- function(family) { - family_info(family, "normalized") -} - -# prepare for calling family specific post-processing functions -prepare_family <- function(x) { - stopifnot(is.brmsformula(x) || is.brmsterms(x)) - family <- x$family - acef <- tidy_acef(x) - if (use_ac_cov_time(acef) && has_natural_residuals(x)) { - family$fun <- paste0(family$family, "_time") - } else if (has_ac_class(acef, "sar")) { - acef_sar <- subset2(acef, class = "sar") - if (has_ac_subset(acef_sar, type = "lag")) { - family$fun <- paste0(family$family, "_lagsar") - } else if (has_ac_subset(acef_sar, type = "error")) { - family$fun <- paste0(family$family, "_errorsar") - } - } else if (has_ac_class(acef, "fcor")) { - family$fun <- paste0(family$family, "_fcor") - } else { - family$fun <- family$family - } - family -} - -# order intercepts to help identifying mixture components? -# does not work in ordinal models as they have vectors of intercepts -order_intercepts <- function(bterms) { - dpar <- dpar_class(bterms[["dpar"]]) - if (!length(dpar)) dpar <- "mu" - isTRUE(!is_ordinal(bterms) && dpar %in% bterms$family[["order"]]) -} - -# fix intercepts to help identifying mixture components? -# currently enabled only in ordinal models -fix_intercepts <- function(bterms) { - dpar <- dpar_class(bterms[["dpar"]]) - if (!length(dpar)) dpar <- "mu" - isTRUE(is_ordinal(bterms) && dpar %in% bterms$family[["order"]]) -} - -# does the mixture have a joint parameter vector 'theta' -has_joint_theta <- function(bterms) { - stopifnot(is.brmsterms(bterms)) - is.mixfamily(bterms$family) && - !"theta" %in% dpar_class(names(c(bterms$dpars, bterms$fdpars))) -} - -# extract family boundaries -family_bounds <- function(x, ...) { - UseMethod("family_bounds") -} - -# @return a named list with one element per response variable -#' @export -family_bounds.mvbrmsterms <- function(x, ...) { - lapply(x$terms, family_bounds, ...) -} - -# bounds of likelihood families -# @return a list with elements 'lb' and 'ub' -#' @export -family_bounds.brmsterms <- function(x, ...) { - family <- x$family$family - if (is.null(family)) { - return(list(lb = -Inf, ub = Inf)) - } - resp <- usc(x$resp) - # TODO: define in family-lists.R - pos_families <- c( - "poisson", "negbinomial", "negbinomial2", "geometric", - "gamma", "weibull", "exponential", "lognormal", - "frechet", "inverse.gaussian", - "hurdle_poisson", "hurdle_negbinomial", "hurdle_gamma", - "hurdle_lognormal", "zero_inflated_poisson", - "zero_inflated_negbinomial" - ) - beta_families <- c("beta", "zero_inflated_beta", "zero_one_inflated_beta") - ordinal_families <- c("cumulative", "cratio", "sratio", "acat") - if (family %in% pos_families) { - out <- list(lb = 0, ub = Inf) - } else if (family %in% c("bernoulli", beta_families)) { - out <- list(lb = 0, ub = 1) - } else if (family %in% c("categorical", ordinal_families)) { - out <- list(lb = 1, ub = paste0("ncat", resp)) - } else if (family %in% c("binomial", "zero_inflated_binomial")) { - out <- list(lb = 0, ub = paste0("trials", resp)) - } else if (family %in% "von_mises") { - out <- list(lb = -pi, ub = pi) - } else if (family %in% c("wiener", "shifted_lognormal")) { - out <- list(lb = paste("min_Y", resp), ub = Inf) - } else { - out <- list(lb = -Inf, ub = Inf) - } - out -} +#' Special Family Functions for \pkg{brms} Models +#' +#' Family objects provide a convenient way to specify the details of the models +#' used by many model fitting functions. The family functions presented here are +#' for use with \pkg{brms} only and will **not** work with other model +#' fitting functions such as \code{glm} or \code{glmer}. +#' However, the standard family functions as described in +#' \code{\link[stats:family]{family}} will work with \pkg{brms}. +#' You can also specify custom families for use in \pkg{brms} with +#' the \code{\link{custom_family}} function. +#' +#' @param family A character string naming the distribution of the response +#' variable be used in the model. Currently, the following families are +#' supported: \code{gaussian}, \code{student}, \code{binomial}, +#' \code{bernoulli}, \code{beta-binomial}, \code{poisson}, \code{negbinomial}, +#' \code{geometric}, \code{Gamma}, \code{skew_normal}, \code{lognormal}, +#' \code{shifted_lognormal}, \code{exgaussian}, \code{wiener}, +#' \code{inverse.gaussian}, \code{exponential}, \code{weibull}, +#' \code{frechet}, \code{Beta}, \code{dirichlet}, \code{von_mises}, +#' \code{asym_laplace}, \code{gen_extreme_value}, \code{categorical}, +#' \code{multinomial}, \code{cumulative}, \code{cratio}, \code{sratio}, +#' \code{acat}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, +#' \code{hurdle_gamma}, \code{hurdle_lognormal}, +#' \code{zero_inflated_binomial}, \code{zero_inflated_beta_binomial}, +#' \code{zero_inflated_beta}, \code{zero_inflated_negbinomial}, +#' \code{zero_inflated_poisson}, and \code{zero_one_inflated_beta}. +#' @param link A specification for the model link function. This can be a +#' name/expression or character string. See the 'Details' section for more +#' information on link functions supported by each family. +#' @param link_sigma Link of auxiliary parameter \code{sigma} if being predicted. +#' @param link_shape Link of auxiliary parameter \code{shape} if being predicted. +#' @param link_nu Link of auxiliary parameter \code{nu} if being predicted. +#' @param link_phi Link of auxiliary parameter \code{phi} if being predicted. +#' @param link_kappa Link of auxiliary parameter \code{kappa} if being predicted. +#' @param link_beta Link of auxiliary parameter \code{beta} if being predicted. +#' @param link_zi Link of auxiliary parameter \code{zi} if being predicted. +#' @param link_hu Link of auxiliary parameter \code{hu} if being predicted. +#' @param link_zoi Link of auxiliary parameter \code{zoi} if being predicted. +#' @param link_coi Link of auxiliary parameter \code{coi} if being predicted. +#' @param link_disc Link of auxiliary parameter \code{disc} if being predicted. +#' @param link_bs Link of auxiliary parameter \code{bs} if being predicted. +#' @param link_ndt Link of auxiliary parameter \code{ndt} if being predicted. +#' @param link_bias Link of auxiliary parameter \code{bias} if being predicted. +#' @param link_alpha Link of auxiliary parameter \code{alpha} if being predicted. +#' @param link_quantile Link of auxiliary parameter \code{quantile} if being predicted. +#' @param link_xi Link of auxiliary parameter \code{xi} if being predicted. +#' @param threshold A character string indicating the type +#' of thresholds (i.e. intercepts) used in an ordinal model. +#' \code{"flexible"} provides the standard unstructured thresholds, +#' \code{"equidistant"} restricts the distance between +#' consecutive thresholds to the same value, and +#' \code{"sum_to_zero"} ensures the thresholds sum to zero. +#' @param refcat Optional name of the reference response category used in +#' \code{categorical}, \code{multinomial}, \code{dirichlet} and +#' \code{logistic_normal} models. If \code{NULL} (the default), the first +#' category is used as the reference. If \code{NA}, all categories will be +#' predicted, which requires strong priors or carefully specified predictor +#' terms in order to lead to an identified model. +#' @param bhaz Currently for experimental purposes only. +#' +#' @details +#' Below, we list common use cases for the different families. +#' This list is not ment to be exhaustive. +#' \itemize{ +#' \item{Family \code{gaussian} can be used for linear regression.} +#' +#' \item{Family \code{student} can be used for robust linear regression +#' that is less influenced by outliers.} +#' +#' \item{Family \code{skew_normal} can handle skewed responses in linear +#' regression.} +#' +#' \item{Families \code{poisson}, \code{negbinomial}, and \code{geometric} +#' can be used for regression of unbounded count data.} +#' +#' \item{Families \code{bernoulli}, \code{binomial}, and \code{beta_binomial} +#' can be used for binary regression (i.e., most commonly logistic +#' regression).} +#' +#' \item{Families \code{categorical} and \code{multinomial} can be used for +#' multi-logistic regression when there are more than two possible outcomes.} +#' +#' \item{Families \code{cumulative}, \code{cratio} ('continuation ratio'), +#' \code{sratio} ('stopping ratio'), and \code{acat} ('adjacent category') +#' leads to ordinal regression.} +#' +#' \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, +#' \code{lognormal}, \code{frechet}, \code{inverse.gaussian}, and \code{cox} +#' (Cox proportional hazards model) can be used (among others) for +#' time-to-event regression also known as survival regression.} +#' +#' \item{Families \code{weibull}, \code{frechet}, and \code{gen_extreme_value} +#' ('generalized extreme value') allow for modeling extremes.} +#' +#' \item{Families \code{beta}, \code{dirichlet}, and \code{logistic_normal} +#' can be used to model responses representing rates or probabilities.} +#' +#' \item{Family \code{asym_laplace} allows for quantile regression when fixing +#' the auxiliary \code{quantile} parameter to the quantile of interest.} +#' +#' \item{Family \code{exgaussian} ('exponentially modified Gaussian') and +#' \code{shifted_lognormal} are especially suited to model reaction times.} +#' +#' \item{Family \code{wiener} provides an implementation of the Wiener +#' diffusion model. For this family, the main formula predicts the drift +#' parameter 'delta' and all other parameters are modeled as auxiliary parameters +#' (see \code{\link{brmsformula}} for details).} +#' +#' \item{Families \code{hurdle_poisson}, \code{hurdle_negbinomial}, +#' \code{hurdle_gamma}, \code{hurdle_lognormal}, \code{zero_inflated_poisson}, +#' \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, +#' \code{zero_inflated_beta_binomial}, \code{zero_inflated_beta}, and +#' \code{zero_one_inflated_beta} allow to estimate zero-inflated and hurdle +#' models. These models can be very helpful when there are many zeros in the +#' data (or ones in case of one-inflated models) +#' that cannot be explained by the primary distribution of the response.} +#' } +#' +#' Below, we list all possible links for each family. +#' The first link mentioned for each family is the default. +#' \itemize{ +#' \item{Families \code{gaussian}, \code{student}, \code{skew_normal}, +#' \code{exgaussian}, \code{asym_laplace}, and \code{gen_extreme_value} +#' support the links (as names) \code{identity}, \code{log}, \code{inverse}, +#' and \code{softplus}.} +#' +#' \item{Families \code{poisson}, \code{negbinomial}, \code{geometric}, +#' \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, +#' \code{hurdle_poisson}, and \code{hurdle_negbinomial} support +#' \code{log}, \code{identity}, \code{sqrt}, and \code{softplus}.} +#' +#' \item{Families \code{binomial}, \code{bernoulli}, \code{beta_binomial}, +#' \code{zero_inflated_binomial}, \code{zero_inflated_beta_binomial}, +#' \code{Beta}, \code{zero_inflated_beta}, and \code{zero_one_inflated_beta} +#' support \code{logit}, \code{probit}, \code{probit_approx}, \code{cloglog}, +#' \code{cauchit}, \code{identity}, and \code{log}.} +#' +#' \item{Families \code{cumulative}, \code{cratio}, \code{sratio}, +#' and \code{acat} support \code{logit}, \code{probit}, +#' \code{probit_approx}, \code{cloglog}, and \code{cauchit}.} +#' +#' \item{Families \code{categorical}, \code{multinomial}, and \code{dirichlet} +#' support \code{logit}.} +#' +#' \item{Families \code{Gamma}, \code{weibull}, \code{exponential}, +#' \code{frechet}, and \code{hurdle_gamma} support +#' \code{log}, \code{identity}, \code{inverse}, and \code{softplus}.} +#' +#' \item{Families \code{lognormal} and \code{hurdle_lognormal} +#' support \code{identity} and \code{inverse}.} +#' +#' \item{Family \code{logistic_normal} supports \code{identity}.} +#' +#' \item{Family \code{inverse.gaussian} supports \code{1/mu^2}, +#' \code{inverse}, \code{identity}, \code{log}, and \code{softplus}.} +#' +#' \item{Family \code{von_mises} supports \code{tan_half} and +#' \code{identity}.} +#' +#' \item{Family \code{cox} supports \code{log}, \code{identity}, +#' and \code{softplus} for the proportional hazards parameter.} +#' +#' \item{Family \code{wiener} supports \code{identity}, \code{log}, +#' and \code{softplus} for the main parameter which represents the +#' drift rate.} +#' } +#' +#' Please note that when calling the \code{\link[stats:family]{Gamma}} family +#' function of the \pkg{stats} package, the default link will be +#' \code{inverse} instead of \code{log} although the latter is the default in +#' \pkg{brms}. Also, when using the family functions \code{gaussian}, +#' \code{binomial}, \code{poisson}, and \code{Gamma} of the \pkg{stats} +#' package (see \code{\link[stats:family]{family}}), special link functions +#' such as \code{softplus} or \code{cauchit} won't work. In this case, you +#' have to use \code{brmsfamily} to specify the family with corresponding link +#' function. +#' +#' @seealso \code{\link[brms:brm]{brm}}, +#' \code{\link[stats:family]{family}}, +#' \code{\link{customfamily}} +#' +#' @examples +#' # create a family object +#' (fam1 <- student("log")) +#' # alternatively use the brmsfamily function +#' (fam2 <- brmsfamily("student", "log")) +#' # both leads to the same object +#' identical(fam1, fam2) +#' +#' @export +brmsfamily <- function(family, link = NULL, link_sigma = "log", + link_shape = "log", link_nu = "logm1", + link_phi = "log", link_kappa = "log", + link_beta = "log", link_zi = "logit", + link_hu = "logit", link_zoi = "logit", + link_coi = "logit", link_disc = "log", + link_bs = "log", link_ndt = "log", + link_bias = "logit", link_xi = "log1p", + link_alpha = "identity", + link_quantile = "logit", + threshold = "flexible", + refcat = NULL, bhaz = NULL) { + slink <- substitute(link) + .brmsfamily( + family, link = link, slink = slink, + link_sigma = link_sigma, link_shape = link_shape, + link_nu = link_nu, link_phi = link_phi, + link_kappa = link_kappa, link_beta = link_beta, + link_zi = link_zi, link_hu = link_hu, + link_zoi = link_zoi, link_coi = link_coi, + link_disc = link_disc, link_bs = link_bs, + link_ndt = link_ndt, link_bias = link_bias, + link_alpha = link_alpha, link_xi = link_xi, + link_quantile = link_quantile, + threshold = threshold, refcat = refcat, + bhaz = bhaz + ) +} + +# helper function to prepare brmsfamily objects +# @param family character string naming the model family +# @param link character string naming the link function +# @param slink can be used with substitute(link) for +# non-standard evaluation of the link function +# @param threshold threshold type for ordinal models +# @param ... link functions (as character strings) of parameters +# @return an object of 'brmsfamily' which inherits from 'family' +.brmsfamily <- function(family, link = NULL, slink = link, + threshold = "flexible", + refcat = NULL, bhaz = NULL, ...) { + family <- tolower(as_one_character(family)) + aux_links <- list(...) + pattern <- c("^normal$", "^zi_", "^hu_") + replacement <- c("gaussian", "zero_inflated_", "hurdle_") + family <- rename(family, pattern, replacement, fixed = FALSE) + ok_families <- lsp("brms", pattern = "^\\.family_") + ok_families <- sub("^\\.family_", "", ok_families) + if (!family %in% ok_families) { + stop2(family, " is not a supported family. Supported ", + "families are:\n", collapse_comma(ok_families)) + } + family_info <- get(paste0(".family_", family))() + ok_links <- family_info$links + family_info$links <- NULL + # non-standard evaluation of link + if (!is.character(slink)) { + slink <- deparse(slink) + } + if (!slink %in% ok_links) { + if (is.character(link)) { + slink <- link + } else if (!length(link) || identical(link, NA)) { + slink <- NA + } + } + if (length(slink) != 1L) { + stop2("Argument 'link' must be of length 1.") + } + if (is.na(slink)) { + slink <- ok_links[1] + } + if (!slink %in% ok_links) { + stop2("'", slink, "' is not a supported link ", + "for family '", family, "'.\nSupported links are: ", + collapse_comma(ok_links)) + } + out <- list( + family = family, link = slink, + linkfun = function(mu) link(mu, link = slink), + linkinv = function(eta) inv_link(eta, link = slink) + ) + out[names(family_info)] <- family_info + class(out) <- c("brmsfamily", "family") + all_valid_dpars <- c(valid_dpars(out), valid_dpars(out, type = "multi")) + for (dp in all_valid_dpars) { + alink <- as.character(aux_links[[paste0("link_", dp)]]) + if (length(alink)) { + alink <- as_one_character(alink) + valid_links <- links_dpars(dp) + if (!alink %in% valid_links) { + stop2( + "'", alink, "' is not a supported link ", + "for parameter '", dp, "'.\nSupported links are: ", + collapse_comma(valid_links) + ) + } + out[[paste0("link_", dp)]] <- alink + } + } + if (is_ordinal(out$family)) { + # TODO: move specification of 'threshold' to the 'resp_thres' function? + thres_options <- c("flexible", "equidistant", "sum_to_zero") + out$threshold <- match.arg(threshold, thres_options) + } + if (conv_cats_dpars(out$family)) { + if (!has_joint_link(out$family)) { + out$refcat <- NA + } else if (!is.null(refcat)) { + allow_na_ref <- !is_logistic_normal(out$family) + out$refcat <- as_one_character(refcat, allow_na = allow_na_ref) + } + } + if (is_cox(out$family)) { + if (!is.null(bhaz)) { + if (!is.list(bhaz)) { + stop2("'bhaz' should be a list.") + } + out$bhaz <- bhaz + } else { + out$bhaz <- list() + } + # set default arguments + if (is.null(out$bhaz$df)) { + out$bhaz$df <- 5L + } + if (is.null(out$bhaz$intercept)) { + out$bhaz$intercept <- TRUE + } + } + out +} + +# checks and corrects validity of the model family +# @param family Either a function, an object of class 'family' +# or a character string of length one or two +# @param link an optional character string naming the link function +# ignored if family is a function or a family object +# @param threshold optional character string specifying the threshold +# type in ordinal models +validate_family <- function(family, link = NULL, threshold = NULL) { + if (is.function(family)) { + family <- family() + } + if (!is(family, "brmsfamily")) { + if (is.family(family)) { + link <- family$link + family <- family$family + } + if (is.character(family)) { + if (is.null(link)) { + link <- family[2] + } + family <- .brmsfamily(family[1], link = link) + } else { + stop2("Argument 'family' is invalid.") + } + } + if (is_ordinal(family) && !is.null(threshold)) { + # slot 'threshold' deprecated as of brms > 1.7.0 + threshold <- match.arg(threshold, c("flexible", "equidistant")) + family$threshold <- threshold + } + family +} + +# extract special information of families +# @param x object from which to extract +# @param y name of the component to extract +family_info <- function(x, y, ...) { + UseMethod("family_info") +} + +#' @export +family_info.default <- function(x, y, ...) { + x <- as.character(x) + ulapply(x, .family_info, y = y, ...) +} + +.family_info <- function(x, y, ...) { + x <- as_one_character(x) + y <- as_one_character(y) + if (y == "family") { + return(x) + } + if (!nzchar(x)) { + return(NULL) + } + info <- get(paste0(".family_", x))() + if (y == "link") { + out <- info$links[1] # default link + } else { + info$links <- NULL + out <- info[[y]] + } + out +} + +family_info.NULL <- function(x, y, ...) { + NULL +} + +#' @export +family_info.list <- function(x, y, ...) { + ulapply(x, family_info, y = y, ...) +} + +#' @export +family_info.family <- function(x, y, ...) { + family_info(x$family, y = y, ...) +} + +#' @export +family_info.brmsfamily <- function(x, y, ...) { + y <- as_one_character(y) + out <- x[[y]] + if (is.null(out)) { + # required for models fitted with brms 2.2 or earlier + out <- family_info(x$family, y = y, ...) + } + out +} + +#' @export +family_info.mixfamily <- function(x, y, ...) { + out <- lapply(x$mix, family_info, y = y, ...) + combine_family_info(out, y = y) +} + +#' @export +family_info.brmsformula <- function(x, y, ...) { + family_info(x$family, y = y, ...) +} + +#' @export +family_info.mvbrmsformula <- function(x, y, ...) { + out <- lapply(x$forms, family_info, y = y, ...) + combine_family_info(out, y = y) +} + +#' @export +family_info.brmsterms <- function(x, y, ...) { + family_info(x$family, y = y, ...) +} + +#' @export +family_info.mvbrmsterms <- function(x, y, ...) { + out <- lapply(x$terms, family_info, y = y, ...) + combine_family_info(out, y = y) +} + +#' @export +family_info.btl <- function(x, y, ...) { + family_info(x$family, y = y, ...) +} + +#' @export +family_info.btnl <- function(x, y, ...) { + family_info(x$family, y = y, ...) +} + +#' @export +family_info.brmsfit <- function(x, y, ...) { + family_info(x$formula, y = y, ...) +} + +# combine information from multiple families +# provides special handling for certain elements +combine_family_info <- function(x, y, ...) { + y <- as_one_character(y) + unite <- c( + "dpars", "type", "specials", "include", + "const", "cats", "ad", "normalized" + ) + if (y %in% c("family", "link")) { + x <- unlist(x) + } else if (y %in% unite) { + x <- Reduce("union", x) + } else if (y == "ybounds") { + x <- do_call(rbind, x) + x <- c(max(x[, 1]), min(x[, 2])) + } else if (y == "closed") { + # closed only if no bounds are open + x <- do_call(rbind, x) + clb <- !any(ulapply(x[, 1], isFALSE)) + cub <- !any(ulapply(x[, 2], isFALSE)) + x <- c(clb, cub) + } else if (y == "thres") { + # thresholds are the same across mixture components + x <- x[[1]] + } + x +} + +#' @rdname brmsfamily +#' @export +student <- function(link = "identity", link_sigma = "log", link_nu = "logm1") { + slink <- substitute(link) + .brmsfamily("student", link = link, slink = slink, + link_sigma = link_sigma, link_nu = link_nu) +} + +#' @rdname brmsfamily +#' @export +bernoulli <- function(link = "logit") { + slink <- substitute(link) + .brmsfamily("bernoulli", link = link, slink = slink) +} + +#' @rdname brmsfamily +#' @export +beta_binomial <- function(link = "logit", link_phi = "log") { + slink <- substitute(link) + .brmsfamily("beta_binomial", link = link, slink = slink, link_phi = link_phi) +} + +#' @rdname brmsfamily +#' @export +negbinomial <- function(link = "log", link_shape = "log") { + slink <- substitute(link) + .brmsfamily("negbinomial", link = link, slink = slink, + link_shape = link_shape) +} + +# not yet officially supported +# @rdname brmsfamily +# @export +negbinomial2 <- function(link = "log", link_sigma = "log") { + slink <- substitute(link) + .brmsfamily("negbinomial2", link = link, slink = slink, + link_sigma = link_sigma) +} + +#' @rdname brmsfamily +#' @export +geometric <- function(link = "log") { + slink <- substitute(link) + .brmsfamily("geometric", link = link, slink = slink) +} + +# do not export yet! +# @rdname brmsfamily +# @export +discrete_weibull <- function(link = "logit", link_shape = "log") { + slink <- substitute(link) + .brmsfamily("discrete_weibull", link = link, slink = slink, + link_shape = link_shape) +} + +# do not export yet! +# @rdname brmsfamily +# @export +com_poisson <- function(link = "log", link_shape = "log") { + slink <- substitute(link) + .brmsfamily("com_poisson", link = link, slink = slink, + link_shape = link_shape) +} + +#' @rdname brmsfamily +#' @export +lognormal <- function(link = "identity", link_sigma = "log") { + slink <- substitute(link) + .brmsfamily("lognormal", link = link, slink = slink, + link_sigma = link_sigma) +} + +#' @rdname brmsfamily +#' @export +shifted_lognormal <- function(link = "identity", link_sigma = "log", + link_ndt = "log") { + slink <- substitute(link) + .brmsfamily("shifted_lognormal", link = link, slink = slink, + link_sigma = link_sigma, link_ndt = link_ndt) +} + +#' @rdname brmsfamily +#' @export +skew_normal <- function(link = "identity", link_sigma = "log", + link_alpha = "identity") { + slink <- substitute(link) + .brmsfamily("skew_normal", link = link, slink = slink, + link_sigma = link_sigma, link_alpha = link_alpha) +} + +#' @rdname brmsfamily +#' @export +exponential <- function(link = "log") { + slink <- substitute(link) + .brmsfamily("exponential", link = link, slink = slink) +} + +#' @rdname brmsfamily +#' @export +weibull <- function(link = "log", link_shape = "log") { + slink <- substitute(link) + .brmsfamily("weibull", link = link, slink = slink, + link_shape = link_shape) +} + +#' @rdname brmsfamily +#' @export +frechet <- function(link = "log", link_nu = "logm1") { + slink <- substitute(link) + .brmsfamily("frechet", link = link, slink = slink, + link_nu = link_nu) +} + +#' @rdname brmsfamily +#' @export +gen_extreme_value <- function(link = "identity", link_sigma = "log", + link_xi = "log1p") { + slink <- substitute(link) + .brmsfamily("gen_extreme_value", link = link, slink = slink, + link_sigma = link_sigma, link_xi = link_xi) +} + +#' @rdname brmsfamily +#' @export +exgaussian <- function(link = "identity", link_sigma = "log", + link_beta = "log") { + slink <- substitute(link) + .brmsfamily("exgaussian", link = link, slink = slink, + link_sigma = link_sigma, link_beta = link_beta) +} + +#' @rdname brmsfamily +#' @export +wiener <- function(link = "identity", link_bs = "log", + link_ndt = "log", link_bias = "logit") { + slink <- substitute(link) + .brmsfamily("wiener", link = link, slink = slink, + link_bs = link_bs, link_ndt = link_ndt, + link_bias = link_bias) +} + +#' @rdname brmsfamily +#' @export +Beta <- function(link = "logit", link_phi = "log") { + slink <- substitute(link) + .brmsfamily("beta", link = link, slink = slink, + link_phi = link_phi) +} + +#' @rdname brmsfamily +#' @export +dirichlet <- function(link = "logit", link_phi = "log", refcat = NULL) { + slink <- substitute(link) + .brmsfamily("dirichlet", link = link, slink = slink, + link_phi = link_phi, refcat = refcat) +} + +# not yet exported +# @rdname brmsfamily +# @export +dirichlet2 <- function(link = "log") { + slink <- substitute(link) + .brmsfamily("dirichlet2", link = link, slink = slink, refcat = NA) +} + +#' @rdname brmsfamily +#' @export +logistic_normal <- function(link = "identity", link_sigma = "log", + refcat = NULL) { + slink <- substitute(link) + .brmsfamily("logistic_normal", link = link, slink = slink, + link_sigma = link_sigma, refcat = refcat) +} + +#' @rdname brmsfamily +#' @export +von_mises <- function(link = "tan_half", link_kappa = "log") { + slink <- substitute(link) + .brmsfamily("von_mises", link = link, slink = slink, + link_kappa = link_kappa) +} + +#' @rdname brmsfamily +#' @export +asym_laplace <- function(link = "identity", link_sigma = "log", + link_quantile = "logit") { + slink <- substitute(link) + .brmsfamily("asym_laplace", link = link, slink = slink, + link_sigma = link_sigma, link_quantile = link_quantile) +} + +# do not export yet! +# @rdname brmsfamily +# @export +zero_inflated_asym_laplace <- function(link = "identity", link_sigma = "log", + link_quantile = "logit", + link_zi = "logit") { + slink <- substitute(link) + .brmsfamily("zero_inflated_asym_laplace", link = link, slink = slink, + link_sigma = link_sigma, link_quantile = link_quantile, + link_zi = link_zi) +} + +#' @rdname brmsfamily +#' @export +cox <- function(link = "log", bhaz = NULL) { + slink <- substitute(link) + .brmsfamily("cox", link = link, bhaz = bhaz) +} + +#' @rdname brmsfamily +#' @export +hurdle_poisson <- function(link = "log") { + slink <- substitute(link) + .brmsfamily("hurdle_poisson", link = link, slink = slink) +} + +#' @rdname brmsfamily +#' @export +hurdle_negbinomial <- function(link = "log", link_shape = "log", + link_hu = "logit") { + slink <- substitute(link) + .brmsfamily("hurdle_negbinomial", link = link, slink = slink, + link_shape = link_shape, link_hu = link_hu) +} + +#' @rdname brmsfamily +#' @export +hurdle_gamma <- function(link = "log", link_shape = "log", + link_hu = "logit") { + slink <- substitute(link) + .brmsfamily("hurdle_gamma", link = link, slink = slink, + link_shape = link_shape, link_hu = link_hu) +} + +#' @rdname brmsfamily +#' @export +hurdle_lognormal <- function(link = "identity", link_sigma = "log", + link_hu = "logit") { + slink <- substitute(link) + .brmsfamily("hurdle_lognormal", link = link, slink = slink, + link_sigma = link_sigma, link_hu = link_hu) +} + +#' @rdname brmsfamily +#' @export +zero_inflated_beta <- function(link = "logit", link_phi = "log", + link_zi = "logit") { + slink <- substitute(link) + .brmsfamily("zero_inflated_beta", link = link, slink = slink, + link_phi = link_phi, link_zi = link_zi) +} + +#' @rdname brmsfamily +#' @export +zero_one_inflated_beta <- function(link = "logit", link_phi = "log", + link_zoi = "logit", link_coi = "logit") { + slink <- substitute(link) + .brmsfamily("zero_one_inflated_beta", link = link, slink = slink, + link_phi = link_phi, link_zoi = link_zoi, + link_coi = link_coi) +} + +#' @rdname brmsfamily +#' @export +zero_inflated_poisson <- function(link = "log", link_zi = "logit") { + slink <- substitute(link) + .brmsfamily("zero_inflated_poisson", link = link, slink = slink, + link_zi = link_zi) +} + +#' @rdname brmsfamily +#' @export +zero_inflated_negbinomial <- function(link = "log", link_shape = "log", + link_zi = "logit") { + slink <- substitute(link) + .brmsfamily("zero_inflated_negbinomial", link = link, slink = slink, + link_shape = link_shape, link_zi = link_zi) +} + +#' @rdname brmsfamily +#' @export +zero_inflated_binomial <- function(link = "logit", link_zi = "logit") { + slink <- substitute(link) + .brmsfamily("zero_inflated_binomial", link = link, slink = slink, + link_zi = link_zi) +} + +#' @rdname brmsfamily +#' @export +zero_inflated_beta_binomial <- function(link = "logit", link_phi = "log", + link_zi = "logit") { + slink <- substitute(link) + .brmsfamily("zero_inflated_beta_binomial", link = link, slink = slink, + link_phi = link_phi, link_zi = link_zi) +} + +#' @rdname brmsfamily +#' @export +categorical <- function(link = "logit", refcat = NULL) { + slink <- substitute(link) + .brmsfamily("categorical", link = link, slink = slink, refcat = refcat) +} + +#' @rdname brmsfamily +#' @export +multinomial <- function(link = "logit", refcat = NULL) { + slink <- substitute(link) + .brmsfamily("multinomial", link = link, slink = slink, refcat = refcat) +} + +#' @rdname brmsfamily +#' @export +cumulative <- function(link = "logit", link_disc = "log", + threshold = "flexible") { + slink <- substitute(link) + .brmsfamily("cumulative", link = link, slink = slink, + link_disc = link_disc, threshold = threshold) +} + +#' @rdname brmsfamily +#' @export +sratio <- function(link = "logit", link_disc = "log", + threshold = "flexible") { + slink <- substitute(link) + .brmsfamily("sratio", link = link, slink = slink, + link_disc = link_disc, threshold = threshold) +} + +#' @rdname brmsfamily +#' @export +cratio <- function(link = "logit", link_disc = "log", + threshold = "flexible") { + slink <- substitute(link) + .brmsfamily("cratio", link = link, slink = slink, + link_disc = link_disc, threshold = threshold) +} + +#' @rdname brmsfamily +#' @export +acat <- function(link = "logit", link_disc = "log", + threshold = "flexible") { + slink <- substitute(link) + .brmsfamily("acat", link = link, slink = slink, + link_disc = link_disc, threshold = threshold) +} + +#' Finite Mixture Families in \pkg{brms} +#' +#' Set up a finite mixture family for use in \pkg{brms}. +#' +#' @param ... One or more objects providing a description of the +#' response distributions to be combined in the mixture model. +#' These can be family functions, calls to family functions or +#' character strings naming the families. For details of supported +#' families see \code{\link{brmsfamily}}. +#' @param flist Optional list of objects, which are treated in the +#' same way as objects passed via the \code{...} argument. +#' @param nmix Optional numeric vector specifying the number of times +#' each family is repeated. If specified, it must have the same length +#' as the number of families passed via \code{...} and \code{flist}. +#' @param order Ordering constraint to identify mixture components. +#' If \code{'mu'} or \code{TRUE}, population-level intercepts +#' of the mean parameters are ordered in non-ordinal models +#' and fixed to the same value in ordinal models (see details). +#' If \code{'none'} or \code{FALSE}, no ordering constraint is applied. +#' If \code{NULL} (the default), \code{order} is set to \code{'mu'} +#' if all families are the same and \code{'none'} otherwise. +#' Other ordering constraints may be implemented in the future. +#' +#' @return An object of class \code{mixfamily}. +#' +#' @details +#' +#' Most families supported by \pkg{brms} can be used to form mixtures. The +#' response variable has to be valid for all components of the mixture family. +#' Currently, the number of mixture components has to be specified by the user. +#' It is not yet possible to estimate the number of mixture components from the +#' data. +#' +#' Ordering intercepts in mixtures of ordinal families is not possible as each +#' family has itself a set of vector of intercepts (i.e. ordinal thresholds). +#' Instead, \pkg{brms} will fix the vector of intercepts across components in +#' ordinal mixtures, if desired, so that users can try to identify the mixture +#' model via selective inclusion of predictors. +#' +#' For most mixture models, you may want to specify priors on the +#' population-level intercepts via \code{\link{set_prior}} to improve +#' convergence. In addition, it is sometimes necessary to set \code{init = 0} +#' in the call to \code{\link{brm}} to allow chains to initialize properly. +#' +#' For more details on the specification of mixture +#' models, see \code{\link{brmsformula}}. +#' +#' @examples +#' \dontrun{ +#' ## simulate some data +#' set.seed(1234) +#' dat <- data.frame( +#' y = c(rnorm(200), rnorm(100, 6)), +#' x = rnorm(300), +#' z = sample(0:1, 300, TRUE) +#' ) +#' +#' ## fit a simple normal mixture model +#' mix <- mixture(gaussian, gaussian) +#' prior <- c( +#' prior(normal(0, 7), Intercept, dpar = mu1), +#' prior(normal(5, 7), Intercept, dpar = mu2) +#' ) +#' fit1 <- brm(bf(y ~ x + z), dat, family = mix, +#' prior = prior, chains = 2) +#' summary(fit1) +#' pp_check(fit1) +#' +#' ## use different predictors for the components +#' fit2 <- brm(bf(y ~ 1, mu1 ~ x, mu2 ~ z), dat, family = mix, +#' prior = prior, chains = 2) +#' summary(fit2) +#' +#' ## fix the mixing proportions +#' fit3 <- brm(bf(y ~ x + z, theta1 = 1, theta2 = 2), +#' dat, family = mix, prior = prior, +#' init = 0, chains = 2) +#' summary(fit3) +#' pp_check(fit3) +#' +#' ## predict the mixing proportions +#' fit4 <- brm(bf(y ~ x + z, theta2 ~ x), +#' dat, family = mix, prior = prior, +#' init = 0, chains = 2) +#' summary(fit4) +#' pp_check(fit4) +#' +#' ## compare model fit +#' LOO(fit1, fit2, fit3, fit4) +#' } +#' +#' @export +mixture <- function(..., flist = NULL, nmix = 1, order = NULL) { + dots <- c(list(...), flist) + if (length(nmix) == 1L) { + nmix <- rep(nmix, length(dots)) + } + if (length(dots) != length(nmix)) { + stop2("The length of 'nmix' should be the same ", + "as the number of mixture components.") + } + dots <- dots[rep(seq_along(dots), nmix)] + family <- list( + family = "mixture", + link = "identity", + mix = lapply(dots, validate_family) + ) + class(family) <- c("mixfamily", "brmsfamily", "family") + # validity checks + if (length(family$mix) < 2L) { + stop2("Expecting at least 2 mixture components.") + } + if (use_real(family) && use_int(family)) { + stop2("Cannot mix families with real and integer support.") + } + is_ordinal <- ulapply(family$mix, is_ordinal) + if (any(is_ordinal) && any(!is_ordinal)) { + stop2("Cannot mix ordinal and non-ordinal families.") + } + no_mixture <- ulapply(family$mix, no_mixture) + if (any(no_mixture)) { + stop2("Some of the families are not allowed in mixture models.") + } + for (fam in family$mix) { + if (is.customfamily(fam) && "theta" %in% fam$dpars) { + stop2("Parameter name 'theta' is reserved in mixture models.") + } + } + if (is.null(order)) { + if (any(is_ordinal)) { + family$order <- "none" + message("Setting order = 'none' for mixtures of ordinal families.") + } else if (length(unique(family_names(family))) == 1L) { + family$order <- "mu" + message("Setting order = 'mu' for mixtures of the same family.") + } else { + family$order <- "none" + message("Setting order = 'none' for mixtures of different families.") + } + } else { + if (length(order) != 1L) { + stop2("Argument 'order' must be of length 1.") + } + if (is.character(order)) { + valid_order <- c("none", "mu") + if (!order %in% valid_order) { + stop2("Argument 'order' is invalid. Valid options are: ", + collapse_comma(valid_order)) + } + family$order <- order + } else { + family$order <- ifelse(as.logical(order), "mu", "none") + } + } + family +} + +#' Custom Families in \pkg{brms} Models +#' +#' Define custom families (i.e. response distribution) for use in +#' \pkg{brms} models. It allows users to benefit from the modeling +#' flexibility of \pkg{brms}, while applying their self-defined likelihood +#' functions. All of the post-processing methods for \code{brmsfit} +#' objects can be made compatible with custom families. +#' See \code{vignette("brms_customfamilies")} for more details. +#' For a list of built-in families see \code{\link{brmsfamily}}. +#' +#' @aliases customfamily +#' +#' @param name Name of the custom family. +#' @param dpars Names of the distributional parameters of +#' the family. One parameter must be named \code{"mu"} and +#' the main formula of the model will correspond to that +#' parameter. +#' @param links Names of the link functions of the +#' distributional parameters. +#' @param type Indicates if the response distribution is +#' continuous (\code{"real"}) or discrete (\code{"int"}). This controls +#' if the corresponding density function will be named with +#' \code{_lpdf} or \code{_lpmf}. +#' @param lb Vector of lower bounds of the distributional +#' parameters. Defaults to \code{NA} that is no lower bound. +#' @param ub Vector of upper bounds of the distributional +#' parameters. Defaults to \code{NA} that is no upper bound. +#' @param vars Names of variables that are part of the likelihood function +#' without being distributional parameters. That is, \code{vars} can be used +#' to pass data to the likelihood. Such arguments will be added to the list of +#' function arguments at the end, after the distributional parameters. See +#' \code{\link{stanvar}} for details about adding self-defined data to the +#' generated \pkg{Stan} model. Addition arguments \code{vreal} and \code{vint} +#' may be used for this purpose as well (see Examples below). See also +#' \code{\link{brmsformula}} and \code{\link{addition-terms}} for more +#' details. +#' @param loop Logical; Should the likelihood be evaluated via a loop +#' (\code{TRUE}; the default) over observations in Stan? +#' If \code{FALSE}, the Stan code will be written in a vectorized +#' manner over observations if possible. +#' @param specials A character vector of special options to enable +#' for this custom family. Currently for internal use only. +#' @param threshold Optional threshold type for custom ordinal families. +#' Ignored for non-ordinal families. +#' @param log_lik Optional function to compute log-likelihood values of +#' the model in \R. This is only relevant if one wants to ensure +#' compatibility with method \code{\link[brms:log_lik.brmsfit]{log_lik}}. +#' @param posterior_predict Optional function to compute posterior prediction of +#' the model in \R. This is only relevant if one wants to ensure compatibility +#' with method \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}. +#' @param posterior_epred Optional function to compute expected values of the +#' posterior predictive distribution of the model in \R. This is only relevant +#' if one wants to ensure compatibility with method +#' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. +#' @param predict Deprecated alias of `posterior_predict`. +#' @param fitted Deprecated alias of `posterior_epred`. +#' @param env An \code{\link{environment}} in which certain post-processing +#' functions related to the custom family can be found, if there were not +#' directly passed to \code{custom_family}. This is only +#' relevant if one wants to ensure compatibility with the methods +#' \code{\link[brms:log_lik.brmsfit]{log_lik}}, +#' \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}}, or +#' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}}. +#' By default, \code{env} is the environment from which +#' \code{custom_family} is called. +#' +#' @details The corresponding probability density or mass \code{Stan} +#' functions need to have the same name as the custom family. +#' That is if a family is called \code{myfamily}, then the +#' \pkg{Stan} functions should be called \code{myfamily_lpdf} or +#' \code{myfamily_lpmf} depending on whether it defines a +#' continuous or discrete distribution. +#' +#' @return An object of class \code{customfamily} inheriting +#' from class \code{\link{brmsfamily}}. +#' +#' @seealso \code{\link{brmsfamily}}, \code{\link{brmsformula}}, +#' \code{\link{stanvar}} +#' +#' @examples +#' \dontrun{ +#' ## demonstrate how to fit a beta-binomial model +#' ## generate some fake data +#' phi <- 0.7 +#' n <- 300 +#' z <- rnorm(n, sd = 0.2) +#' ntrials <- sample(1:10, n, replace = TRUE) +#' eta <- 1 + z +#' mu <- exp(eta) / (1 + exp(eta)) +#' a <- mu * phi +#' b <- (1 - mu) * phi +#' p <- rbeta(n, a, b) +#' y <- rbinom(n, ntrials, p) +#' dat <- data.frame(y, z, ntrials) +#' +#' # define a custom family +#' beta_binomial2 <- custom_family( +#' "beta_binomial2", dpars = c("mu", "phi"), +#' links = c("logit", "log"), lb = c(NA, 0), +#' type = "int", vars = "vint1[n]" +#' ) +#' +#' # define the corresponding Stan density function +#' stan_density <- " +#' real beta_binomial2_lpmf(int y, real mu, real phi, int N) { +#' return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); +#' } +#' " +#' stanvars <- stanvar(scode = stan_density, block = "functions") +#' +#' # fit the model +#' fit <- brm(y | vint(ntrials) ~ z, data = dat, +#' family = beta_binomial2, stanvars = stanvars) +#' summary(fit) +#' +#' +#' # define a *vectorized* custom family (no loop over observations) +#' # notice also that 'vint' no longer has an observation index +#' beta_binomial2_vec <- custom_family( +#' "beta_binomial2", dpars = c("mu", "phi"), +#' links = c("logit", "log"), lb = c(NA, 0), +#' type = "int", vars = "vint1", loop = FALSE +#' ) +#' +#' # define the corresponding Stan density function +#' stan_density_vec <- " +#' real beta_binomial2_lpmf(int[] y, vector mu, real phi, int[] N) { +#' return beta_binomial_lpmf(y | N, mu * phi, (1 - mu) * phi); +#' } +#' " +#' stanvars_vec <- stanvar(scode = stan_density_vec, block = "functions") +#' +#' # fit the model +#' fit_vec <- brm(y | vint(ntrials) ~ z, data = dat, +#' family = beta_binomial2_vec, +#' stanvars = stanvars_vec) +#' summary(fit_vec) +#' } +#' +#' @export +custom_family <- function(name, dpars = "mu", links = "identity", + type = c("real", "int"), lb = NA, ub = NA, + vars = NULL, loop = TRUE, specials = NULL, + threshold = "flexible", + log_lik = NULL, posterior_predict = NULL, + posterior_epred = NULL, predict = NULL, + fitted = NULL, env = parent.frame()) { + name <- as_one_character(name) + dpars <- as.character(dpars) + links <- as.character(links) + type <- match.arg(type) + lb <- as.character(lb) + ub <- as.character(ub) + vars <- as.character(vars) + loop <- as_one_logical(loop) + specials <- as.character(specials) + env <- as.environment(env) + posterior_predict <- use_alias(posterior_predict, predict) + posterior_epred <- use_alias(posterior_epred, fitted) + if (any(duplicated(dpars))) { + stop2("Duplicated 'dpars' are not allowed.") + } + if (!"mu" %in% dpars) { + stop2("All families must have a 'mu' parameter.") + } + if (any(grepl("_|\\.", dpars))) { + stop2("Dots or underscores are not allowed in 'dpars'.") + } + if (any(grepl("[[:digit:]]+$", dpars))) { + stop2("'dpars' should not end with a number.") + } + for (arg in c("links", "lb", "ub")) { + obj <- get(arg) + if (length(obj) == 1L) { + obj <- rep(obj, length(dpars)) + assign(arg, obj) + } + if (length(dpars) != length(obj)) { + stop2("'", arg, "' must be of the same length as 'dpars'.") + } + } + if (!is.null(log_lik)) { + log_lik <- as.function(log_lik) + args <- names(formals(log_lik)) + if (!is_equal(args[1:2], c("i", "prep"))) { + stop2("The first two arguments of 'log_lik' ", + "should be 'i' and 'prep'.") + } + } + if (!is.null(posterior_predict)) { + posterior_predict <- as.function(posterior_predict) + args <- names(formals(posterior_predict)) + if (!is_equal(args[1:3], c("i", "prep", "..."))) { + stop2("The first three arguments of 'posterior_predict' ", + "should be 'i', 'prep', and '...'.") + } + } + if (!is.null(posterior_epred)) { + posterior_epred <- as.function(posterior_epred) + args <- names(formals(posterior_epred)) + if (!is_equal(args[1], "prep")) { + stop2("The first argument of 'posterior_epred' should be 'prep'.") + } + } + lb <- named_list(dpars, lb) + ub <- named_list(dpars, ub) + is_mu <- "mu" == dpars + link <- links[is_mu] + normalized <- "" + out <- nlist( + family = "custom", link, name, + dpars, lb, ub, type, vars, loop, specials, + log_lik, posterior_predict, posterior_epred, env, + normalized + ) + if (length(dpars) > 1L) { + out[paste0("link_", dpars[!is_mu])] <- links[!is_mu] + } + class(out) <- c("customfamily", "brmsfamily", "family") + if (is_ordinal(out)) { + threshold <- match.arg(threshold) + out$threshold <- threshold + } + out +} + +# get post-processing methods for custom families +custom_family_method <- function(family, name) { + if (!is.customfamily(family)) { + return(NULL) + } + out <- family[[name]] + if (!is.function(out)) { + out <- paste0(name, "_", family$name) + out <- get(out, family$env) + } + out +} + +# get valid distributional parameters for a family +valid_dpars <- function(family, ...) { + UseMethod("valid_dpars") +} + +#' @export +valid_dpars.default <- function(family, type = NULL, ...) { + if (!length(family)) { + if (is.null(type)) { + return("mu") + } else { + return(NULL) + } + } + family <- validate_family(family) + info <- paste0(usc(type, "suffix"), "dpars") + family_info(family, info, ...) +} + +#' @export +valid_dpars.mixfamily <- function(family, type = NULL, ...) { + out <- lapply(family$mix, valid_dpars, type = type, ...) + for (i in seq_along(out)) { + if (length(out[[i]])) { + out[[i]] <- paste0(out[[i]], i) + } + } + out <- unlist(out) + if (is.null(type)) { + c(out) <- paste0("theta", seq_along(family$mix)) + } + out +} + +#' @export +valid_dpars.brmsformula <- function(family, ...) { + valid_dpars(family$family, ...) +} + +#' @export +valid_dpars.mvbrmsformula <- function(family, ...) { + ulapply(family$forms, valid_dpars, ...) +} + +#' @export +valid_dpars.brmsterms <- function(family, ...) { + valid_dpars(family$family, ...) +} + +#' @export +valid_dpars.mvbrmsterms <- function(family, ...) { + ulapply(family$terms, valid_dpars, ...) +} + +#' @export +valid_dpars.brmsfit <- function(family, ...) { + valid_dpars(family$formula, ...) +} + +# class of a distributional parameter +dpar_class <- function(dpar, family = NULL) { + out <- sub("[[:digit:]]*$", "", dpar) + if (!is.null(family)) { + # TODO: avoid these special cases by changing naming conventions + # perhaps add a protected "C" before category names + # and a protected "M" for mixture components + if (conv_cats_dpars(family)) { + # categorical-like models have non-integer suffixes + # that will not be caught by the standard procedure + multi_dpars <- valid_dpars(family, type = "multi") + for (dp in multi_dpars) { + sel <- grepl(paste0("^", dp), out) + out[sel] <- dp + } + } + } + out +} + +# id of a distributional parameter +dpar_id <- function(dpar) { + out <- get_matches("[[:digit:]]+$", dpar, simplify = FALSE) + ulapply(out, function(x) ifelse(length(x), x, "")) +} + +# link functions for distributional parameters +links_dpars <- function(dpar) { + if (!length(dpar)) dpar <- "" + switch(dpar, + character(0), + mu = "identity", # not actually used + sigma = c("log", "identity", "softplus", "squareplus"), + shape = c("log", "identity", "softplus", "squareplus"), + nu = c("logm1", "identity"), + phi = c("log", "identity", "softplus", "squareplus"), + kappa = c("log", "identity", "softplus", "squareplus"), + beta = c("log", "identity", "softplus", "squareplus"), + zi = c("logit", "identity"), + hu = c("logit", "identity"), + zoi = c("logit", "identity"), + coi = c("logit", "identity"), + disc = c("log", "identity", "softplus", "squareplus"), + bs = c("log", "identity", "softplus", "squareplus"), + ndt = c("log", "identity", "softplus", "squareplus"), + bias = c("logit", "identity"), + quantile = c("logit", "identity"), + xi = c("log1p", "identity"), + alpha = c("identity", "log", "softplus", "squareplus"), + theta = c("identity") + ) +} + +# is a distributional parameter a mixture proportion? +is_mix_proportion <- function(dpar, family) { + dpar_class <- dpar_class(dpar, family) + dpar_class %in% "theta" & is.mixfamily(family) +} + +# generate a family object of a distributional parameter +dpar_family <- function(family, dpar, ...) { + UseMethod("dpar_family") +} + +#' @export +dpar_family.default <- function(family, dpar, ...) { + dp_class <- dpar_class(dpar, family) + if (dp_class == "mu") { + if (conv_cats_dpars(family)) { + link <- NULL + if (!has_joint_link(family)) { + link <- family$link + } + # joint links are applied directly in the likelihood function + # so link is treated as 'identity' + out <- .dpar_family(dpar, link) + } else { + # standard single mu parameters just store the original family + out <- family + } + } else { + # link_ is always defined for non-mu parameters + link <- family[[paste0("link_", dp_class)]] + out <- .dpar_family(dpar, link) + } + out +} + +#' @export +dpar_family.mixfamily <- function(family, dpar, ...) { + dp_id <- as.numeric(dpar_id(dpar)) + if (!(length(dp_id) == 1L && is.numeric(dp_id))) { + stop2("Parameter '", dpar, "' is not a valid mixture parameter.") + } + out <- dpar_family(family$mix[[dp_id]], dpar, ...) + out$order <- family$order + out +} + +# set up special family objects for distributional parameters +# @param dpar name of the distributional parameter +# @param link optional link function of the parameter +.dpar_family <- function(dpar = NULL, link = NULL) { + links <- links_dpars(dpar_class(dpar)) + if (!length(link)) { + if (!length(links)) { + link <- "identity" + } else { + link <- links[1] + } + } + link <- as_one_character(link) + structure( + nlist(family = "", link, dpar), + class = c("brmsfamily", "family") + ) +} + +#' @export +print.brmsfamily <- function(x, links = FALSE, newline = TRUE, ...) { + cat("\nFamily:", x$family, "\n") + cat("Link function:", x$link, "\n") + if (!is.null(x$threshold)) { + cat("Threshold:", x$threshold, "\n") + } + if (isTRUE(links) || is.character(links)) { + dp_links <- x[grepl("^link_", names(x))] + names(dp_links) <- sub("^link_", "", names(dp_links)) + if (is.character(links)) { + dp_links <- rmNULL(dp_links[links]) + } + for (dp in names(dp_links)) { + cat(paste0( + "Link function of '", dp, "' (if predicted): ", + dp_links[[dp]], "\n" + )) + } + } + if (newline) { + cat("\n") + } + invisible(x) +} + +#' @export +print.mixfamily <- function(x, newline = TRUE, ...) { + cat("\nMixture\n") + for (i in seq_along(x$mix)) { + print(x$mix[[i]], newline = FALSE, ...) + } + if (newline) { + cat("\n") + } + invisible(x) +} + +#' @export +print.customfamily <- function(x, links = FALSE, newline = TRUE, ...) { + cat("\nCustom family:", x$name, "\n") + cat("Link function:", x$link, "\n") + cat("Parameters:", paste0(x$dpars, collapse = ", "), "\n") + if (isTRUE(links) || is.character(links)) { + dp_links <- x[grepl("^link_", names(x))] + names(dp_links) <- sub("^link_", "", names(dp_links)) + if (is.character(links)) { + dp_links <- rmNULL(dp_links[links]) + } + for (dp in names(dp_links)) { + cat(paste0( + "Link function of '", dp, "' (if predicted): ", + dp_links[[dp]], "\n" + )) + } + } + if (newline) { + cat("\n") + } + invisible(x) +} + +#' @method summary family +#' @export +summary.family <- function(object, link = TRUE, ...) { + out <- object$family + if (link) { + out <- paste0(out, "(", object$link, ")") + } + out +} + +#' @method summary mixfamily +#' @export +summary.mixfamily <- function(object, link = FALSE, ...) { + families <- ulapply(object$mix, summary, link = link, ...) + paste0("mixture(", paste0(families, collapse = ", "), ")") +} + +#' @method summary customfamily +#' @export +summary.customfamily <- function(object, link = TRUE, ...) { + object$family <- object$name + summary.family(object, link = link, ...) +} + +summarise_families <- function(x) { + # summary of families used in summary.brmsfit + UseMethod("summarise_families") +} + +#' @export +summarise_families.mvbrmsformula <- function(x, ...) { + out <- ulapply(x$forms, summarise_families, ...) + paste0("MV(", paste0(out, collapse = ", "), ")") +} + +#' @export +summarise_families.brmsformula <- function(x, ...) { + summary(x$family, link = FALSE, ...) +} + +summarise_links <- function(x, ...) { + # summary of link functions used in summary.brmsfit + UseMethod("summarise_links") +} + +#' @export +summarise_links.mvbrmsformula <- function(x, wsp = 0, ...) { + str_wsp <- collapse(rep(" ", wsp)) + links <- ulapply(x$forms, summarise_links, mv = TRUE, ...) + paste0(links, collapse = paste0("\n", str_wsp)) +} + +#' @export +summarise_links.brmsformula <- function(x, mv = FALSE, ...) { + x <- brmsterms(x) + dpars <- valid_dpars(x) + links <- setNames(rep("identity", length(dpars)), dpars) + links_pred <- ulapply(x$dpars, function(x) x$family$link) + links[names(links_pred)] <- links_pred + if (conv_cats_dpars(x)) { + links[grepl("^mu", names(links))] <- x$family$link + } + resp <- if (mv) usc(combine_prefix(x)) + names(links) <- paste0(names(links), resp) + paste0(names(links), " = ", links, collapse = "; ") +} + +is.family <- function(x) { + inherits(x, "family") +} + +is.brmsfamily <- function(x) { + inherits(x, "brmsfamily") +} + +is.mixfamily <- function(x) { + inherits(x, "mixfamily") +} + +is.customfamily <- function(x) { + inherits(x, "customfamily") +} + +family_names <- function(x) { + family_info(x, "family") +} + +# indicate if family uses real responses +use_real <- function(family) { + "real" %in% family_info(family, "type") +} + +# indicate if family uses integer responses +use_int <- function(family) { + "int" %in% family_info(family, "type") +} + +is_binary <- function(family) { + "binary" %in% family_info(family, "specials") +} + +is_categorical <- function(family) { + "categorical" %in% family_info(family, "specials") +} + +is_ordinal <- function(family) { + "ordinal" %in% family_info(family, "specials") +} + +is_multinomial <- function(family) { + "multinomial" %in% family_info(family, "specials") +} + +is_logistic_normal <- function(family) { + "logistic_normal" %in% family_info(family, "specials") +} + +is_simplex <- function(family) { + "simplex" %in% family_info(family, "specials") +} + +is_polytomous <- function(family) { + is_categorical(family) || is_ordinal(family) || + is_multinomial(family) || is_simplex(family) +} + +is_cox <- function(family) { + "cox" %in% family_info(family, "specials") +} + +# has joint link function over multiple inputs +has_joint_link <- function(family) { + "joint_link" %in% family_info(family, "specials") +} + +allow_factors <- function(family) { + specials <- c("binary", "categorical", "ordinal") + any(specials %in% family_info(family, "specials")) +} + +# check if the family has natural residuals +has_natural_residuals <- function(family) { + "residuals" %in% family_info(family, "specials") +} + +# check if the family allows for residual correlations +has_rescor <- function(family) { + "rescor" %in% family_info(family, "specials") +} + +# check if category specific effects are allowed +allow_cs <- function(family) { + any(c("cs", "ocs") %in% family_info(family, "specials")) +} + +# check if category specific effects should be ordered +needs_ordered_cs <- function(family) { + "ocs" %in% family_info(family, "specials") +} + +# choose dpar names based on categories? +conv_cats_dpars <- function(family) { + is_categorical(family) || is_multinomial(family) || is_simplex(family) +} + +# check if mixtures of the given families are allowed +no_mixture <- function(family) { + is_categorical(family) || is_multinomial(family) || is_simplex(family) +} + +# indicate if the response should consist of multiple columns +has_multicol <- function(family) { + is_multinomial(family) || is_simplex(family) +} + +# indicate if the response is modeled on the log-scale +# even if formally the link function is not 'log' +has_logscale <- function(family) { + "logscale" %in% family_info(family, "specials") +} + +# indicate if family makes use of argument trials +has_trials <- function(family) { + "trials" %in% family_info(family, "ad") && + !"custom" %in% family_names(family) +} + +# indicate if family has more than two response categories +has_cat <- function(family) { + is_categorical(family) || is_multinomial(family) || is_simplex(family) +} + +# indicate if family has thresholds +has_thres <- function(family) { + is_ordinal(family) +} + +# indicate if family has equidistant thresholds +has_equidistant_thres <- function(family) { + "equidistant" %in% family_info(family, "threshold") +} + +# indicate if family has sum-to-zero thresholds +has_sum_to_zero_thres <- function(family) { + "sum_to_zero" %in% family_info(family, "threshold") +} + +# indicate if family has ordered thresholds +has_ordered_thres <- function(family) { + "ordered_thres" %in% family_info(family, "specials") +} + +# compute threshold - eta in the likelihood +has_thres_minus_eta <- function(family) { + "thres_minus_eta" %in% family_info(family, "specials") +} + +# compute eta - threshold in the likelihood +has_eta_minus_thres <- function(family) { + "eta_minus_thres" %in% family_info(family, "specials") +} + +# get names of response categories +get_cats <- function(family) { + family_info(family, "cats") +} + +# get reference category categorical-like models +get_refcat <- function(family, int = FALSE) { + refcat <- family_info(family, "refcat") + if (int) { + cats <- family_info(family, "cats") + refcat <- match(refcat, cats) + } + refcat +} + +# get names of predicted categories categorical-like models +get_predcats <- function(family) { + refcat <- family_info(family, "refcat") + cats <- family_info(family, "cats") + setdiff(cats, refcat) +} + +# get names of ordinal thresholds for prior specification +# @param group name of a group for which to extract categories +get_thres <- function(family, group = "") { + group <- as_one_character(group) + thres <- family_info(family, "thres") + subset2(thres, group = group)$thres +} + +# get group names of ordinal thresholds +get_thres_groups <- function(family) { + thres <- family_info(family, "thres") + unique(thres$group) +} + +# has the model group specific thresholds? +has_thres_groups <- function(family) { + groups <- get_thres_groups(family) + any(nzchar(groups)) +} + +has_ndt <- function(family) { + "ndt" %in% dpar_class(family_info(family, "dpars")) +} + +has_sigma <- function(family) { + "sigma" %in% dpar_class(family_info(family, "dpars")) +} + +# check if sigma should be explicitely set to 0 +no_sigma <- function(bterms) { + stopifnot(is.brmsterms(bterms)) + if (is.formula(bterms$adforms$se)) { + se <- eval_rhs(bterms$adforms$se) + se_only <- isFALSE(se$flags$sigma) + if (se_only && use_ac_cov_time(bterms)) { + stop2("Please set argument 'sigma' of function 'se' ", + "to TRUE when modeling time-series covariance matrices.") + } + } else { + se_only <- FALSE + } + se_only +} + +# has the model a non-predicted but estimated sigma parameter? +simple_sigma <- function(bterms) { + stopifnot(is.brmsterms(bterms)) + has_sigma(bterms) && !no_sigma(bterms) && !pred_sigma(bterms) +} + +# has the model a predicted sigma parameter? +pred_sigma <- function(bterms) { + stopifnot(is.brmsterms(bterms)) + "sigma" %in% dpar_class(names(bterms$dpars)) +} + +# do not include a 'nu' parameter in a univariate model? +no_nu <- function(bterms) { + # the multi_student_t family only has a single 'nu' parameter + isTRUE(bterms$rescor) && "student" %in% family_names(bterms) +} + +# does the family-link combination have a built-in Stan function? +has_built_in_fun <- function(family, link = NULL, dpar = NULL, cdf = FALSE) { + link <- link %||% family$link + glm_special <- paste0("sbi", usc(dpar), "_", link, str_if(cdf, "_cdf")) + all(glm_special %in% family_info(family, "specials")) +} + +# suffixes of Stan lpdfs or lpmfs for which only a normalized version exists +always_normalized <- function(family) { + family_info(family, "normalized") +} + +# prepare for calling family specific post-processing functions +prepare_family <- function(x) { + stopifnot(is.brmsformula(x) || is.brmsterms(x)) + family <- x$family + acef <- tidy_acef(x) + if (use_ac_cov_time(acef) && has_natural_residuals(x)) { + family$fun <- paste0(family$family, "_time") + } else if (has_ac_class(acef, "sar")) { + acef_sar <- subset2(acef, class = "sar") + if (has_ac_subset(acef_sar, type = "lag")) { + family$fun <- paste0(family$family, "_lagsar") + } else if (has_ac_subset(acef_sar, type = "error")) { + family$fun <- paste0(family$family, "_errorsar") + } + } else if (has_ac_class(acef, "fcor")) { + family$fun <- paste0(family$family, "_fcor") + } else { + family$fun <- family$family + } + family +} + +# order intercepts to help identifying mixture components? +# does not work in ordinal models as they have vectors of intercepts +order_intercepts <- function(bterms) { + dpar <- dpar_class(bterms[["dpar"]]) + if (!length(dpar)) dpar <- "mu" + isTRUE(!is_ordinal(bterms) && dpar %in% bterms$family[["order"]]) +} + +# fix intercepts to help identifying mixture components? +# currently enabled only in ordinal models +fix_intercepts <- function(bterms) { + dpar <- dpar_class(bterms[["dpar"]]) + if (!length(dpar)) dpar <- "mu" + isTRUE(is_ordinal(bterms) && dpar %in% bterms$family[["order"]]) +} + +# does the mixture have a joint parameter vector 'theta' +has_joint_theta <- function(bterms) { + stopifnot(is.brmsterms(bterms)) + is.mixfamily(bterms$family) && + !"theta" %in% dpar_class(names(c(bterms$dpars, bterms$fdpars))) +} + +# extract family boundaries +family_bounds <- function(x, ...) { + UseMethod("family_bounds") +} + +# @return a named list with one element per response variable +#' @export +family_bounds.mvbrmsterms <- function(x, ...) { + lapply(x$terms, family_bounds, ...) +} + +# bounds of likelihood families +# @return a list with elements 'lb' and 'ub' +#' @export +family_bounds.brmsterms <- function(x, ...) { + family <- x$family$family + if (is.null(family)) { + return(list(lb = -Inf, ub = Inf)) + } + resp <- usc(x$resp) + # TODO: define in family-lists.R + pos_families <- c( + "poisson", "negbinomial", "negbinomial2", "geometric", + "gamma", "weibull", "exponential", "lognormal", + "frechet", "inverse.gaussian", + "hurdle_poisson", "hurdle_negbinomial", "hurdle_gamma", + "hurdle_lognormal", "zero_inflated_poisson", + "zero_inflated_negbinomial" + ) + beta_families <- c("beta", "zero_inflated_beta", "zero_one_inflated_beta") + ordinal_families <- c("cumulative", "cratio", "sratio", "acat") + if (family %in% pos_families) { + out <- list(lb = 0, ub = Inf) + } else if (family %in% c("bernoulli", beta_families)) { + out <- list(lb = 0, ub = 1) + } else if (family %in% c("categorical", ordinal_families)) { + out <- list(lb = 1, ub = paste0("ncat", resp)) + } else if (family %in% c("binomial", "zero_inflated_binomial", + "beta_binomial", "zero_inflated_beta_binomial")) { + out <- list(lb = 0, ub = paste0("trials", resp)) + } else if (family %in% "von_mises") { + out <- list(lb = -pi, ub = pi) + } else if (family %in% c("wiener", "shifted_lognormal")) { + out <- list(lb = paste("min_Y", resp), ub = Inf) + } else { + out <- list(lb = -Inf, ub = Inf) + } + out +} diff -Nru r-cran-brms-2.16.3/R/family-lists.R r-cran-brms-2.17.0/R/family-lists.R --- r-cran-brms-2.16.3/R/family-lists.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/family-lists.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,528 +1,579 @@ -# This file contains a list for every native family. -# These lists may contain the following elements: -# links: possible link function (first is default) -# dpars: distributional parameters of the family -# type: either real or int (i.e. continuous or discrete) -# ybounds: area of definition of the response values -# closed: is the interval closed or open? -# ad: supported addition arguments -# include: names of user-defined Stan functions -# to be included in the Stan code -# normalized: suffixes of Stan lpdfs or lpmfs which only exist as normalized -# versions; can also be "" in which case the family is always normalized -# specials: character vector specialties of some families - -.family_gaussian <- function() { - list( - links = c("identity", "log", "inverse", "softplus", "squareplus"), - dpars = c("mu", "sigma"), type = "real", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index"), - normalized = c("_time_hom", "_time_het", "_lagsar", "_errorsar", "_fcor"), - specials = c("residuals", "rescor") - ) -} - -.family_student <- function() { - list( - links = c("identity", "log", "inverse", "softplus", "squareplus"), - dpars = c("mu", "sigma", "nu"), type = "real", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index"), - include = "fun_logm1.stan", - normalized = c("_time_hom", "_time_het", "_lagsar", "_errorsar", "_fcor"), - specials = c("residuals", "rescor") - ) -} - -.family_skew_normal <- function() { - list( - links = c("identity", "log", "inverse", "softplus", "squareplus"), - dpars = c("mu", "sigma", "alpha"), type = "real", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index") - ) -} - -.family_binomial <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit", "identity" - ), - dpars = c("mu"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "trials", "cens", "trunc", "index"), - specials = "sbi_logit" - ) -} - -.family_bernoulli <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit", "identity" - ), - dpars = c("mu"), type = "int", - ybounds = c(0, 1), closed = c(TRUE, TRUE), - ad = c("weights", "subset", "index"), - specials = c("binary", "sbi_logit") - ) -} - -.family_categorical <- function() { - list( - links = "logit", - dpars = NULL, # is determined based on the data - type = "int", ybounds = c(-Inf, Inf), - closed = c(NA, NA), - ad = c("weights", "subset", "index"), - specials = c("categorical", "joint_link", "sbi_logit") - ) -} - -.family_multinomial <- function() { - list( - links = "logit", - dpars = NULL, # is determined based on the data - type = "int", ybounds = c(-Inf, Inf), - closed = c(NA, NA), - ad = c("weights", "subset", "trials", "index"), - specials = c("multinomial", "joint_link"), - include = "fun_multinomial_logit.stan", - normalized = "" - ) -} - -.family_beta <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit", "identity" - ), - dpars = c("mu", "phi"), type = "real", - ybounds = c(0, 1), closed = c(FALSE, FALSE), - ad = c("weights", "subset", "cens", "trunc", "mi", "index") - ) -} - -.family_dirichlet <- function() { - list( - links = "logit", - dpars = "phi", # more dpars are determined based on the data - type = "real", ybounds = c(0, 1), - closed = c(FALSE, FALSE), - ad = c("weights", "subset", "index"), - specials = c("dirichlet", "joint_link"), - include = "fun_dirichlet_logit.stan", - normalized = "" - ) -} - -.family_dirichlet2 <- function() { - list( - links = c("log", "softplus", "squareplus", "identity", "logm1"), - dpars = NULL, # is determind based on the data - type = "real", ybounds = c(0, 1), - closed = c(FALSE, FALSE), - ad = c("weights", "subset", "index"), - specials = c("dirichlet"), - include = "fun_logm1.stan", - normalized = "" - ) -} - -.family_poisson <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "rate", "index"), - specials = "sbi_log" - ) -} - -.family_negbinomial <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu", "shape"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "rate", "index"), - specials = "sbi_log" - ) -} - -# as negbinomial but with sigma = 1 / shape parameterization -.family_negbinomial2 <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu", "sigma"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "rate", "index"), - specials = "sbi_log" - ) -} - -.family_geometric <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "rate", "index"), - specials = "sbi_log" - ) -} - -.family_discrete_weibull <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit", "identity" - ), - dpars = c("mu", "shape"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_discrete_weibull.stan" - ) -} - -.family_com_poisson <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu", "shape"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_com_poisson.stan", - specials = "sbi_log" - ) -} - -.family_gamma <- function() { - list( - links = c("log", "identity", "inverse", "softplus", "squareplus"), - dpars = c("mu", "shape"), type = "real", - ybounds = c(0, Inf), closed = c(FALSE, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - specials = "transeta" # see stan_eta_ilink() - ) -} - -.family_weibull <- function() { - list( - links = c("log", "identity", "inverse", "softplus", "squareplus"), - dpars = c("mu", "shape"), type = "real", - ybounds = c(0, Inf), closed = c(FALSE, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - specials = "transeta" # see stan_eta_ilink() - ) -} - -.family_exponential <- function() { - list( - links = c("log", "identity", "inverse", "softplus", "squareplus"), - dpars = "mu", type = "real", - ybounds = c(0, Inf), closed = c(FALSE, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - specials = "transeta" # see stan_eta_ilink() - ) -} - -.family_frechet <- function() { - list( - links = c("log", "identity", "inverse", "softplus", "squareplus"), - dpars = c("mu", "nu"), type = "real", - ybounds = c(0, Inf), closed = c(FALSE, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - include = "fun_logm1.stan", - specials = "transeta" # see stan_eta_ilink() - ) -} - -.family_inverse.gaussian <- function() { - list( - links = c("1/mu^2", "inverse", "identity", "log", "softplus", "squareplus"), - dpars = c("mu", "shape"), type = "real", - ybounds = c(0, Inf), closed = c(FALSE, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - include = "fun_inv_gaussian.stan" - ) -} - -.family_lognormal <- function() { - list( - links = c("identity", "inverse"), - dpars = c("mu", "sigma"), type = "real", - ybounds = c(0, Inf), closed = c(FALSE, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - specials = "logscale" - ) -} - -.family_shifted_lognormal <- function() { - list( - links = c("identity", "inverse"), - dpars = c("mu", "sigma", "ndt"), type = "real", - ybounds = c(0, Inf), closed = c(FALSE, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - specials = "logscale" - ) -} - -.family_exgaussian <- function() { - list( - links = c("identity", "log", "inverse", "softplus", "squareplus"), - dpars = c("mu", "sigma", "beta"), type = "real", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index") - ) -} - -.family_wiener <- function() { - list( - links = c("identity", "log", "softplus", "squareplus"), - dpars = c("mu", "bs", "ndt", "bias"), type = "real", - ybounds = c(0, Inf), closed = c(FALSE, NA), - ad = c("weights", "subset", "dec", "index"), - include = "fun_wiener_diffusion.stan", - normalized = "" - ) -} - -.family_gen_extreme_value <- function() { - list( - links = c("identity", "log", "inverse", "softplus", "squareplus"), - dpars = c("mu", "sigma", "xi"), type = "real", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - include = c("fun_gen_extreme_value.stan", "fun_scale_xi.stan"), - normalized = "" - ) -} - -.family_von_mises <- function() { - list( - links = c("tan_half", "identity"), - dpars = c("mu", "kappa"), type = "real", - ybounds = c(-pi, pi), closed = c(TRUE, TRUE), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - include = c("fun_tan_half.stan", "fun_von_mises.stan"), - normalized = "" - ) -} - -.family_asym_laplace <- function() { - list( - links = c("identity", "log", "inverse", "softplus", "squareplus"), - dpars = c("mu", "sigma", "quantile"), type = "real", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "cens", "trunc", "mi", "index"), - include = "fun_asym_laplace.stan", - normalized = "" - ) -} - -.family_zero_inflated_asym_laplace <- function() { - list( - links = c("identity", "log", "inverse", "softplus", "squareplus"), - dpars = c("mu", "sigma", "quantile", "zi"), type = "real", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = c("fun_asym_laplace.stan", "fun_zero_inflated_asym_laplace.stan") - ) -} - -.family_cox <- function() { - list( - links = c("log", "identity", "softplus", "squareplus"), - dpars = c("mu"), type = "real", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_cox.stan", - specials = c("cox", "sbi_log", "sbi_log_cdf"), - normalized = "" - ) -} - -.family_cumulative <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit" - ), - dpars = c("mu", "disc"), type = "int", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "thres", "cat", "index"), - specials = c( - "ordinal", "ordered_thres", "thres_minus_eta", - "joint_link", "ocs", "sbi_logit" - ), - normalized = "" - ) -} - -.family_sratio <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit" - ), - dpars = c("mu", "disc"), type = "int", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "thres", "cat", "index"), - specials = c("ordinal", "cs", "thres_minus_eta", "joint_link"), - normalized = "" - ) -} - -.family_cratio <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit" - ), - dpars = c("mu", "disc"), type = "int", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "thres", "cat", "index"), - specials = c("ordinal", "cs", "eta_minus_thres", "joint_link"), - normalized = "" - ) -} - -.family_acat <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit" - ), - dpars = c("mu", "disc"), type = "int", - ybounds = c(-Inf, Inf), closed = c(NA, NA), - ad = c("weights", "subset", "thres", "cat", "index"), - specials = c("ordinal", "cs", "eta_minus_thres", "joint_link"), - normalized = "" - ) -} - -.family_hurdle_poisson <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu", "hu"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_hurdle_poisson.stan", - specials = c("sbi_log", "sbi_hu_logit"), - normalized = "" - ) -} - -.family_hurdle_negbinomial <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu", "shape", "hu"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_hurdle_negbinomial.stan", - specials = c("sbi_log", "sbi_hu_logit"), - normalized = "" - ) -} - -.family_hurdle_gamma <- function() { - list( - links = c("log", "identity", "inverse", "softplus", "squareplus"), - dpars = c("mu", "shape", "hu"), type = "real", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_hurdle_gamma.stan", - specials = "sbi_hu_logit", - normalized = "" - ) -} - -.family_hurdle_lognormal <- function() { - list( - links = c("identity", "inverse"), - dpars = c("mu", "sigma", "hu"), type = "real", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_hurdle_lognormal.stan", - specials = c("logscale", "sbi_hu_logit"), - normalized = "" - ) -} - -.family_zero_inflated_poisson <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu", "zi"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_zero_inflated_poisson.stan", - specials = c("sbi_log", "sbi_zi_logit"), - normalized = "" - ) -} - -.family_zero_inflated_negbinomial <- function() { - list( - links = c("log", "identity", "sqrt", "softplus", "squareplus"), - dpars = c("mu", "shape", "zi"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_zero_inflated_negbinomial.stan", - specials = c("sbi_log", "sbi_zi_logit"), - normalized = "" - ) -} - -.family_zero_inflated_binomial <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit", "identity" - ), - dpars = c("mu", "zi"), type = "int", - ybounds = c(0, Inf), closed = c(TRUE, NA), - ad = c("weights", "subset", "trials", "cens", "trunc", "index"), - include = "fun_zero_inflated_binomial.stan", - specials = c("sbi_logit", "sbi_zi_logit"), - normalized = "" - ) -} - -.family_zero_inflated_beta <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit", "identity" - ), - dpars = c("mu", "phi", "zi"), type = "real", - ybounds = c(0, 1), closed = c(TRUE, FALSE), - ad = c("weights", "subset", "cens", "trunc", "index"), - include = "fun_zero_inflated_beta.stan", - specials = "sbi_zi_logit", - normalized = "" - ) -} - -.family_zero_one_inflated_beta <- function() { - list( - links = c( - "logit", "probit", "probit_approx", - "cloglog", "cauchit", "identity" - ), - dpars = c("mu", "phi", "zoi", "coi"), type = "real", - ybounds = c(0, 1), closed = c(TRUE, TRUE), - ad = c("weights", "subset", "index"), - include = "fun_zero_one_inflated_beta.stan", - specials = "sbi_zi_logit", - normalized = "" - ) -} - -.family_custom <- function() { - list( - ad = c("weights", "subset", "se", "cens", "trunc", "trials", - "thres", "cat", "dec", "mi", "index", "vreal", "vint"), - ybounds = c(-Inf, Inf), closed = c(NA, NA) - ) -} +# This file contains a list for every native family. +# These lists may contain the following elements: +# links: possible link function (first is default) +# dpars: distributional parameters of the family +# type: either real or int (i.e. continuous or discrete) +# ybounds: area of definition of the response values +# closed: is the interval closed or open? +# ad: supported addition arguments +# include: names of user-defined Stan functions +# to be included in the Stan code +# normalized: suffixes of Stan lpdfs or lpmfs which only exist as normalized +# versions; can also be "" in which case the family is always normalized +# specials: character vector specialties of some families + +.family_gaussian <- function() { + list( + links = c("identity", "log", "inverse", "softplus", "squareplus", + "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit"), + dpars = c("mu", "sigma"), type = "real", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index"), + normalized = c("_time_hom", "_time_het", "_lagsar", "_errorsar", "_fcor"), + specials = c("residuals", "rescor") + ) +} + +.family_student <- function() { + list( + links = c("identity", "log", "inverse", "softplus", "squareplus", + "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit"), + dpars = c("mu", "sigma", "nu"), type = "real", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index"), + include = "fun_logm1.stan", + normalized = c("_time_hom", "_time_het", "_lagsar", "_errorsar", "_fcor"), + specials = c("residuals", "rescor") + ) +} + +.family_skew_normal <- function() { + list( + links = c("identity", "log", "inverse", "softplus", "squareplus", + "logit", "probit", "probit_approx", "cloglog", "cauchit", "softit"), + dpars = c("mu", "sigma", "alpha"), type = "real", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "se", "cens", "trunc", "mi", "index") + ) +} + +.family_binomial <- function() { + list( + links = c( + "logit", "probit", "probit_approx", "cloglog", + "cauchit", "softit", "identity", "log" + ), + dpars = c("mu"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "trials", "cens", "trunc", "index"), + specials = "sbi_logit" + ) +} + +.family_beta_binomial <- function() { + list( + links = c( + "logit", "probit", "probit_approx", + "cloglog", "cauchit", "softit", "identity" + ), + dpars = c("mu", "phi"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "trials", "cens", "trunc", "index") + ) +} + +.family_bernoulli <- function() { + list( + links = c( + "logit", "probit", "probit_approx", "cloglog", + "cauchit", "softit", "identity", "log" + ), + dpars = c("mu"), type = "int", + ybounds = c(0, 1), closed = c(TRUE, TRUE), + ad = c("weights", "subset", "index"), + specials = c("binary", "sbi_logit") + ) +} + +.family_categorical <- function() { + list( + links = "logit", + dpars = NULL, + multi_dpars = "mu", # size determined by the data + type = "int", ybounds = c(-Inf, Inf), + closed = c(NA, NA), + ad = c("weights", "subset", "index"), + specials = c("categorical", "joint_link", "sbi_logit") + ) +} + +.family_multinomial <- function() { + list( + links = "logit", + dpars = NULL, + multi_dpars = "mu", # size determined by the data + type = "int", ybounds = c(-Inf, Inf), + closed = c(NA, NA), + ad = c("weights", "subset", "trials", "index"), + specials = c("multinomial", "joint_link"), + include = "fun_multinomial_logit.stan", + normalized = "" + ) +} + +.family_beta <- function() { + list( + links = c( + "logit", "probit", "probit_approx", "cloglog", + "cauchit", "softit", "identity", "log" + ), + dpars = c("mu", "phi"), type = "real", + ybounds = c(0, 1), closed = c(FALSE, FALSE), + ad = c("weights", "subset", "cens", "trunc", "mi", "index") + ) +} + +.family_dirichlet <- function() { + list( + links = "logit", + dpars = "phi", + multi_dpars = "mu", # size determined by the data + type = "real", ybounds = c(0, 1), + closed = c(FALSE, FALSE), + ad = c("weights", "subset", "index"), + specials = c("simplex", "joint_link"), + include = "fun_dirichlet_logit.stan", + normalized = "" + ) +} + +.family_dirichlet2 <- function() { + list( + links = c("log", "softplus", "squareplus", "identity", "logm1"), + dpars = NULL, + multi_dpars = "mu", # size determined by the data + type = "real", ybounds = c(0, 1), + closed = c(FALSE, FALSE), + ad = c("weights", "subset", "index"), + specials = c("simplex"), + include = "fun_logm1.stan", + normalized = "" + ) +} + +.family_logistic_normal <- function() { + list( + links = "identity", + dpars = NULL, + multi_dpars = c("mu", "sigma"), # size determined by the data + type = "real", ybounds = c(0, 1), + closed = c(FALSE, FALSE), + ad = c("weights", "subset", "index"), + specials = c("simplex", "logistic_normal", "joint_link"), + include = "fun_logistic_normal.stan", + normalized = "" + ) +} + +.family_poisson <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "rate", "index"), + specials = "sbi_log" + ) +} + +.family_negbinomial <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu", "shape"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "rate", "index"), + specials = "sbi_log" + ) +} + +# as negbinomial but with sigma = 1 / shape parameterization +.family_negbinomial2 <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu", "sigma"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "rate", "index"), + specials = "sbi_log" + ) +} + +.family_geometric <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "rate", "index"), + specials = "sbi_log" + ) +} + +.family_discrete_weibull <- function() { + list( + links = c( + "logit", "probit", "probit_approx", + "cloglog", "cauchit", "softit", "identity" + ), + dpars = c("mu", "shape"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_discrete_weibull.stan" + ) +} + +.family_com_poisson <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu", "shape"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_com_poisson.stan", + specials = "sbi_log" + ) +} + +.family_gamma <- function() { + list( + links = c("log", "identity", "inverse", "softplus", "squareplus"), + dpars = c("mu", "shape"), type = "real", + ybounds = c(0, Inf), closed = c(FALSE, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + specials = "transeta" # see stan_eta_inv_link() + ) +} + +.family_weibull <- function() { + list( + links = c("log", "identity", "inverse", "softplus", "squareplus"), + dpars = c("mu", "shape"), type = "real", + ybounds = c(0, Inf), closed = c(FALSE, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + specials = "transeta" # see stan_eta_inv_link() + ) +} + +.family_exponential <- function() { + list( + links = c("log", "identity", "inverse", "softplus", "squareplus"), + dpars = "mu", type = "real", + ybounds = c(0, Inf), closed = c(FALSE, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + specials = "transeta" # see stan_eta_inv_link() + ) +} + +.family_frechet <- function() { + list( + links = c("log", "identity", "inverse", "softplus", "squareplus"), + dpars = c("mu", "nu"), type = "real", + ybounds = c(0, Inf), closed = c(FALSE, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + include = "fun_logm1.stan", + specials = "transeta" # see stan_eta_inv_link() + ) +} + +.family_inverse.gaussian <- function() { + list( + links = c("1/mu^2", "inverse", "identity", "log", "softplus", "squareplus"), + dpars = c("mu", "shape"), type = "real", + ybounds = c(0, Inf), closed = c(FALSE, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + include = "fun_inv_gaussian.stan" + ) +} + +.family_lognormal <- function() { + list( + links = c("identity", "inverse"), + dpars = c("mu", "sigma"), type = "real", + ybounds = c(0, Inf), closed = c(FALSE, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + specials = "logscale" + ) +} + +.family_shifted_lognormal <- function() { + list( + links = c("identity", "inverse"), + dpars = c("mu", "sigma", "ndt"), type = "real", + ybounds = c(0, Inf), closed = c(FALSE, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + specials = "logscale" + ) +} + +.family_exgaussian <- function() { + list( + links = c("identity", "log", "inverse", "softplus", "squareplus"), + dpars = c("mu", "sigma", "beta"), type = "real", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index") + ) +} + +.family_wiener <- function() { + list( + links = c("identity", "log", "softplus", "squareplus"), + dpars = c("mu", "bs", "ndt", "bias"), type = "real", + ybounds = c(0, Inf), closed = c(FALSE, NA), + ad = c("weights", "subset", "dec", "index"), + include = "fun_wiener_diffusion.stan", + normalized = "" + ) +} + +.family_gen_extreme_value <- function() { + list( + links = c("identity", "log", "inverse", "softplus", "squareplus"), + dpars = c("mu", "sigma", "xi"), + tmp_dpars = "xi", type = "real", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + include = c("fun_gen_extreme_value.stan", "fun_scale_xi.stan"), + normalized = "" + ) +} + +.family_von_mises <- function() { + list( + links = c("tan_half", "identity"), + dpars = c("mu", "kappa"), type = "real", + ybounds = c(-pi, pi), closed = c(TRUE, TRUE), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + include = c("fun_tan_half.stan", "fun_von_mises.stan"), + normalized = "" + ) +} + +.family_asym_laplace <- function() { + list( + links = c("identity", "log", "inverse", "softplus", "squareplus"), + dpars = c("mu", "sigma", "quantile"), type = "real", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "cens", "trunc", "mi", "index"), + include = "fun_asym_laplace.stan", + normalized = "" + ) +} + +.family_zero_inflated_asym_laplace <- function() { + list( + links = c("identity", "log", "inverse", "softplus", "squareplus"), + dpars = c("mu", "sigma", "quantile", "zi"), type = "real", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = c("fun_asym_laplace.stan", "fun_zero_inflated_asym_laplace.stan") + ) +} + +.family_cox <- function() { + list( + links = c("log", "identity", "softplus", "squareplus"), + dpars = c("mu"), type = "real", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_cox.stan", + specials = c("cox", "sbi_log", "sbi_log_cdf"), + normalized = "" + ) +} + +.family_cumulative <- function() { + list( + links = c( + "logit", "probit", "probit_approx", + "cloglog", "cauchit", "softit" + ), + dpars = c("mu", "disc"), type = "int", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "thres", "cat", "index"), + specials = c( + "ordinal", "ordered_thres", "thres_minus_eta", + "joint_link", "ocs", "sbi_logit" + ), + normalized = "" + ) +} + +.family_sratio <- function() { + list( + links = c( + "logit", "probit", "probit_approx", + "cloglog", "cauchit" # , "softit" + ), + dpars = c("mu", "disc"), type = "int", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "thres", "cat", "index"), + specials = c("ordinal", "cs", "thres_minus_eta", "joint_link"), + normalized = "" + ) +} + +.family_cratio <- function() { + list( + links = c( + "logit", "probit", "probit_approx", + "cloglog", "cauchit" # , "softit" + ), + dpars = c("mu", "disc"), type = "int", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "thres", "cat", "index"), + specials = c("ordinal", "cs", "eta_minus_thres", "joint_link"), + normalized = "" + ) +} + +.family_acat <- function() { + list( + links = c( + "logit", "probit", "probit_approx", + "cloglog", "cauchit", "softit" + ), + dpars = c("mu", "disc"), type = "int", + ybounds = c(-Inf, Inf), closed = c(NA, NA), + ad = c("weights", "subset", "thres", "cat", "index"), + specials = c("ordinal", "cs", "eta_minus_thres", "joint_link"), + normalized = "" + ) +} + +.family_hurdle_poisson <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu", "hu"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_hurdle_poisson.stan", + specials = c("sbi_log", "sbi_hu_logit"), + normalized = "" + ) +} + +.family_hurdle_negbinomial <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu", "shape", "hu"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_hurdle_negbinomial.stan", + specials = c("sbi_log", "sbi_hu_logit"), + normalized = "" + ) +} + +.family_hurdle_gamma <- function() { + list( + links = c("log", "identity", "inverse", "softplus", "squareplus"), + dpars = c("mu", "shape", "hu"), type = "real", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_hurdle_gamma.stan", + specials = "sbi_hu_logit", + normalized = "" + ) +} + +.family_hurdle_lognormal <- function() { + list( + links = c("identity", "inverse"), + dpars = c("mu", "sigma", "hu"), type = "real", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_hurdle_lognormal.stan", + specials = c("logscale", "sbi_hu_logit"), + normalized = "" + ) +} + +.family_zero_inflated_poisson <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu", "zi"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_zero_inflated_poisson.stan", + specials = c("sbi_log", "sbi_zi_logit"), + normalized = "" + ) +} + +.family_zero_inflated_negbinomial <- function() { + list( + links = c("log", "identity", "sqrt", "softplus", "squareplus"), + dpars = c("mu", "shape", "zi"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_zero_inflated_negbinomial.stan", + specials = c("sbi_log", "sbi_zi_logit"), + normalized = "" + ) +} + +.family_zero_inflated_binomial <- function() { + list( + links = c( + "logit", "probit", "probit_approx", "cloglog", + "cauchit", "softit", "identity", "log" + ), + dpars = c("mu", "zi"), type = "int", + ybounds = c(0, Inf), closed = c(TRUE, NA), + ad = c("weights", "subset", "trials", "cens", "trunc", "index"), + include = "fun_zero_inflated_binomial.stan", + specials = c("sbi_logit", "sbi_zi_logit"), + normalized = "" + ) +} + +.family_zero_inflated_beta_binomial <- function() { + list( + links = c( + "logit", "probit", "probit_approx", "cloglog", + "cauchit", "softit", "identity", "log" + ), + dpars = c("mu", "phi", "zi"), + type = "int", + ybounds = c(0, Inf), + closed = c(TRUE, NA), + ad = c("weights", "subset", "trials", "cens", "trunc", "index"), + include = "fun_zero_inflated_beta_binomial.stan", + specials = c("sbi_zi_logit"), + normalized = "" + ) +} + +.family_zero_inflated_beta <- function() { + list( + links = c( + "logit", "probit", "probit_approx", "cloglog", + "cauchit", "softit", "identity", "log" + ), + dpars = c("mu", "phi", "zi"), type = "real", + ybounds = c(0, 1), closed = c(TRUE, FALSE), + ad = c("weights", "subset", "cens", "trunc", "index"), + include = "fun_zero_inflated_beta.stan", + specials = "sbi_zi_logit", + normalized = "" + ) +} + +.family_zero_one_inflated_beta <- function() { + list( + links = c( + "logit", "probit", "probit_approx", "cloglog", + "cauchit", "softit", "identity", "log" + ), + dpars = c("mu", "phi", "zoi", "coi"), type = "real", + ybounds = c(0, 1), closed = c(TRUE, TRUE), + ad = c("weights", "subset", "index"), + include = "fun_zero_one_inflated_beta.stan", + specials = "sbi_zi_logit", + normalized = "" + ) +} + +.family_custom <- function() { + list( + ad = c("weights", "subset", "se", "cens", "trunc", "trials", + "thres", "cat", "dec", "mi", "index", "vreal", "vint"), + ybounds = c(-Inf, Inf), closed = c(NA, NA) + ) +} diff -Nru r-cran-brms-2.16.3/R/formula-ac.R r-cran-brms-2.17.0/R/formula-ac.R --- r-cran-brms-2.16.3/R/formula-ac.R 2021-11-03 11:08:02.000000000 +0000 +++ r-cran-brms-2.17.0/R/formula-ac.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,5 +1,5 @@ #' Autocorrelation structures -#' +#' #' Specify autocorrelation terms in \pkg{brms} models. Currently supported terms #' are \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, #' \code{\link{cosy}}, \code{\link{sar}}, \code{\link{car}}, and @@ -7,45 +7,45 @@ #' passed to the \code{autocor} argument of \code{\link{brmsformula}} in the #' form of a one-sided formula. For deprecated ways of specifying #' autocorrelation terms, see \code{\link{cor_brms}}. -#' +#' #' @name autocor-terms -#' -#' @details The autocor term functions are almost solely useful when called in -#' formulas passed to the \pkg{brms} package. They do not evaluate its +#' +#' @details The autocor term functions are almost solely useful when called in +#' formulas passed to the \pkg{brms} package. They do not evaluate its #' arguments -- but exist purely to help set up a model with autocorrelation #' terms. -#' +#' #' @seealso \code{\link{brmsformula}}, \code{\link{acformula}}, #' \code{\link{arma}}, \code{\link{ar}}, \code{\link{ma}}, #' \code{\link{cosy}}, \code{\link{sar}}, \code{\link{car}}, #' \code{\link{fcor}} -#' -#' @examples +#' +#' @examples #' # specify autocor terms within the formula #' y ~ x + arma(p = 1, q = 1) + car(M) -#' +#' #' # specify autocor terms in the 'autocor' argument #' bf(y ~ x, autocor = ~ arma(p = 1, q = 1) + car(M)) -#' +#' #' # specify autocor terms via 'acformula' #' bf(y ~ x) + acformula(~ arma(p = 1, q = 1) + car(M)) -NULL +NULL #' Set up ARMA(p,q) correlation structures -#' +#' #' Set up an autoregressive moving average (ARMA) term of order (p, q) in #' \pkg{brms}. The function does not evaluate its arguments -- it exists purely #' to help set up a model with ARMA terms. -#' +#' #' @param time An optional time variable specifying the time ordering -#' of the observations. By default, the existing order of the observations +#' of the observations. By default, the existing order of the observations #' in the data is used. #' @param gr An optional grouping variable. If specified, the correlation #' structure is assumed to apply only to observations within the same grouping #' level. -#' @param p A non-negative integer specifying the autoregressive (AR) -#' order of the ARMA structure. Default is \code{1}. -#' @param q A non-negative integer specifying the moving average (MA) +#' @param p A non-negative integer specifying the autoregressive (AR) +#' order of the ARMA structure. Default is \code{1}. +#' @param q A non-negative integer specifying the moving average (MA) #' order of the ARMA structure. Default is \code{1}. #' @param cov A flag indicating whether ARMA effects should be estimated by #' means of residual covariance matrices. This is currently only possible for @@ -53,15 +53,15 @@ #' natural residuals, latent residuals are added automatically. If #' \code{FALSE} (the default), a regression formulation is used that is #' considerably faster and allows for ARMA effects of order higher than 1 but -#' is only available for \code{gaussian} models and some of its +#' is only available for \code{gaussian} models and some of its #' generalizations. -#' -#' @return An object of class \code{'arma_term'}, which is a list -#' of arguments to be interpreted by the formula +#' +#' @return An object of class \code{'arma_term'}, which is a list +#' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. -#' +#' #' @seealso \code{\link{autocor-terms}}, \code{\link{ar}}, \code{\link{ma}}, -#' +#' #' @examples #' \dontrun{ #' data("LakeHuron") @@ -69,7 +69,7 @@ #' fit <- brm(x ~ arma(p = 2, q = 1), data = LakeHuron) #' summary(fit) #' } -#' +#' #' @export arma <- function(time = NA, gr = NA, p = 1, q = 1, cov = FALSE) { label <- deparse(match.call()) @@ -79,19 +79,19 @@ } #' Set up AR(p) correlation structures -#' +#' #' Set up an autoregressive (AR) term of order p in \pkg{brms}. The function #' does not evaluate its arguments -- it exists purely to help set up a model #' with AR terms. -#' +#' #' @inheritParams arma -#' -#' @return An object of class \code{'arma_term'}, which is a list -#' of arguments to be interpreted by the formula +#' +#' @return An object of class \code{'arma_term'}, which is a list +#' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. -#' +#' #' @seealso \code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ma}} -#' +#' #' @examples #' \dontrun{ #' data("LakeHuron") @@ -99,7 +99,7 @@ #' fit <- brm(x ~ ar(p = 2), data = LakeHuron) #' summary(fit) #' } -#' +#' #' @export ar <- function(time = NA, gr = NA, p = 1, cov = FALSE) { label <- deparse(match.call()) @@ -109,19 +109,19 @@ } #' Set up MA(q) correlation structures -#' +#' #' Set up a moving average (MA) term of order q in \pkg{brms}. The function does #' not evaluate its arguments -- it exists purely to help set up a model with #' MA terms. -#' +#' #' @inheritParams arma -#' -#' @return An object of class \code{'arma_term'}, which is a list -#' of arguments to be interpreted by the formula +#' +#' @return An object of class \code{'arma_term'}, which is a list +#' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. -#' +#' #' @seealso \code{\link{autocor-terms}}, \code{\link{arma}}, \code{\link{ar}} -#' +#' #' @examples #' \dontrun{ #' data("LakeHuron") @@ -129,7 +129,7 @@ #' fit <- brm(x ~ ma(p = 2), data = LakeHuron) #' summary(fit) #' } -#' +#' #' @export ma <- function(time = NA, gr = NA, q = 1, cov = FALSE) { label <- deparse(match.call()) @@ -156,7 +156,7 @@ } cov <- as_one_logical(cov) if (cov && (p > 1 || q > 1)) { - stop2("Covariance formulation of ARMA structures is ", + stop2("Covariance formulation of ARMA structures is ", "only possible for effects of maximal order one.") } label <- as_one_character(label) @@ -166,19 +166,19 @@ } #' Set up COSY correlation structures -#' +#' #' Set up a compounds symmetry (COSY) term in \pkg{brms}. The function does #' not evaluate its arguments -- it exists purely to help set up a model with #' COSY terms. -#' +#' #' @inheritParams arma -#' -#' @return An object of class \code{'cosy_term'}, which is a list -#' of arguments to be interpreted by the formula +#' +#' @return An object of class \code{'cosy_term'}, which is a list +#' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. -#' +#' #' @seealso \code{\link{autocor-terms}} -#' +#' #' @examples #' \dontrun{ #' data("lh") @@ -186,7 +186,7 @@ #' fit <- brm(x ~ cosy(), data = lh) #' summary(fit) #' } -#' +#' #' @export #' @export cosy <- function(time = NA, gr = NA) { @@ -201,50 +201,50 @@ } #' Spatial simultaneous autoregressive (SAR) structures -#' +#' #' Set up an spatial simultaneous autoregressive (SAR) term in \pkg{brms}. The #' function does not evaluate its arguments -- it exists purely to help set up a #' model with SAR terms. -#' +#' #' @param M An object specifying the spatial weighting matrix. -#' Can be either the spatial weight matrix itself or an +#' Can be either the spatial weight matrix itself or an #' object of class \code{listw} or \code{nb}, from which #' the spatial weighting matrix can be computed. -#' @param type Type of the SAR structure. Either \code{"lag"} -#' (for SAR of the response values) or \code{"error"} +#' @param type Type of the SAR structure. Either \code{"lag"} +#' (for SAR of the response values) or \code{"error"} #' (for SAR of the residuals). More information is #' provided in the 'Details' section. -#' +#' #' @details The \code{lagsar} structure implements SAR of the response values: #' \deqn{y = \rho W y + \eta + e} -#' The \code{errorsar} structure implements SAR of the residuals: -#' \deqn{y = \eta + u, u = \rho W u + e} +#' The \code{errorsar} structure implements SAR of the residuals: +#' \deqn{y = \eta + u, u = \rho W u + e} #' In the above equations, \eqn{\eta} is the predictor term and \eqn{e} are #' independent normally or t-distributed residuals. Currently, only families #' \code{gaussian} and \code{student} support SAR structures. -#' -#' @return An object of class \code{'sar_term'}, which is a list -#' of arguments to be interpreted by the formula +#' +#' @return An object of class \code{'sar_term'}, which is a list +#' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. -#' +#' #' @seealso \code{\link{autocor-terms}} -#' -#' @examples +#' +#' @examples #' \dontrun{ #' data(oldcol, package = "spdep") -#' fit1 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "lag"), +#' fit1 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "lag"), #' data = COL.OLD, data2 = list(COL.nb = COL.nb), #' chains = 2, cores = 2) #' summary(fit1) #' plot(fit1) -#' -#' fit2 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "error"), +#' +#' fit2 <- brm(CRIME ~ INC + HOVAL + sar(COL.nb, type = "error"), #' data = COL.OLD, data2 = list(COL.nb = COL.nb), #' chains = 2, cores = 2) #' summary(fit2) #' plot(fit2) #' } -#' +#' #' @export sar <- function(M, type = "lag") { label <- deparse(match.call()) @@ -261,11 +261,11 @@ } #' Spatial conditional autoregressive (CAR) structures -#' +#' #' Set up an spatial conditional autoregressive (CAR) term in \pkg{brms}. The #' function does not evaluate its arguments -- it exists purely to help set up a -#' model with CAR terms. -#' +#' model with CAR terms. +#' #' @param M Adjacency matrix of locations. All non-zero entries are treated as #' if the two locations are adjacent. If \code{gr} is specified, the row names #' of \code{M} have to match the levels of the grouping factor. @@ -277,31 +277,31 @@ #' \code{"escar"} (exact sparse CAR), \code{"esicar"} (exact sparse intrinsic #' CAR), \code{"icar"} (intrinsic CAR), and \code{"bym2"}. More information is #' provided in the 'Details' section. -#' -#' @return An object of class \code{'car_term'}, which is a list -#' of arguments to be interpreted by the formula +#' +#' @return An object of class \code{'car_term'}, which is a list +#' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. -#' +#' #' @seealso \code{\link{autocor-terms}} -#' -#' @details The \code{escar} and \code{esicar} types are +#' +#' @details The \code{escar} and \code{esicar} types are #' implemented based on the case study of Max Joseph -#' (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and +#' (\url{https://github.com/mbjoseph/CARstan}). The \code{icar} and #' \code{bym2} type is implemented based on the case study of Mitzi Morris #' (\url{https://mc-stan.org/users/documentation/case-studies/icar_stan.html}). -#' +#' #' @examples #' \dontrun{ #' # generate some spatial data #' east <- north <- 1:10 #' Grid <- expand.grid(east, north) #' K <- nrow(Grid) -#' +#' #' # set up distance and neighbourhood matrices #' distance <- as.matrix(dist(Grid)) #' W <- array(0, c(K, K)) -#' W[distance == 1] <- 1 -#' +#' W[distance == 1] <- 1 +#' #' # generate the covariates and response data #' x1 <- rnorm(K) #' x2 <- rnorm(K) @@ -314,14 +314,14 @@ #' size <- rep(50, K) #' y <- rbinom(n = K, size = size, prob = prob) #' dat <- data.frame(y, size, x1, x2) -#' +#' #' # fit a CAR model -#' fit <- brm(y | trials(size) ~ x1 + x2 + car(W), +#' fit <- brm(y | trials(size) ~ x1 + x2 + car(W), #' data = dat, data2 = list(W = W), -#' family = binomial()) +#' family = binomial()) #' summary(fit) #' } -#' +#' #' @export car <- function(M, gr = NA, type = "escar") { label <- deparse(match.call()) @@ -340,31 +340,31 @@ } #' Fixed residual correlation (FCOR) structures -#' +#' #' Set up a fixed residual correlation (FCOR) term in \pkg{brms}. The function #' does not evaluate its arguments -- it exists purely to help set up a model #' with FCOR terms. #' #' @param M Known correlation/covariance matrix of the response variable. -#' If a vector is passed, it will be used as diagonal entries +#' If a vector is passed, it will be used as diagonal entries #' (variances) and correlations/covariances will be set to zero. #' The actual covariance matrix used in the likelihood is obtained #' by multiplying \code{M} by the square of the residual standard #' deviation parameter \code{sigma} estimated as part of the model. #' -#' @return An object of class \code{'fcor_term'}, which is a list -#' of arguments to be interpreted by the formula +#' @return An object of class \code{'fcor_term'}, which is a list +#' of arguments to be interpreted by the formula #' parsing functions of \pkg{brms}. -#' +#' #' @seealso \code{\link{autocor-terms}} -#' -#' @examples +#' +#' @examples #' \dontrun{ #' dat <- data.frame(y = rnorm(3)) #' V <- cbind(c(0.5, 0.3, 0.2), c(0.3, 1, 0.1), c(0.2, 0.1, 0.2)) #' fit <- brm(y ~ 1 + fcor(V), data = dat, data2 = list(V = V)) #' } -#' +#' #' @export fcor <- function(M) { label <- deparse(match.call()) @@ -417,7 +417,7 @@ tidy_acef.mvbrmsterms <- function(x, ...) { out <- lapply(x$terms, tidy_acef, ...) out <- do_call(rbind, out) - structure(out, class = acef_class()) + structure(out, class = acef_class()) } #' @export @@ -435,7 +435,7 @@ } if (use_ac_cov(out)) { if (isTRUE(x$rescor)) { - stop2("Explicit covariance terms cannot be modeled ", + stop2("Explicit covariance terms cannot be modeled ", "when 'rescor' is estimated at the same time.") } } @@ -638,7 +638,7 @@ # regex to extract all parameter names of autocorrelation structures regex_autocor_pars <- function() { - p <- c("ar", "ma", "sderr", "cosy", "lagsar", "errorsar", + p <- c("ar", "ma", "sderr", "cosy", "lagsar", "errorsar", "car", "sdcar", "rhocar") p <- paste0("(", p, ")", collapse = "|") paste0("^(", p, ")(\\[|_|$)") diff -Nru r-cran-brms-2.16.3/R/formula-ad.R r-cran-brms-2.17.0/R/formula-ad.R --- r-cran-brms-2.16.3/R/formula-ad.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/formula-ad.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,426 +1,430 @@ -#' Additional Response Information -#' -#' Provide additional information on the response variable -#' in \pkg{brms} models, such as censoring, truncation, or -#' known measurement error. -#' -#' @name addition-terms -#' -#' @param x A vector; usually a variable defined in the data. Allowed values -#' depend on the function: \code{resp_se} and \code{resp_weights} require -#' positive numeric values. \code{resp_trials}, \code{resp_thres}, and -#' \code{resp_cat} require positive integers. \code{resp_dec} requires -#' \code{0} and \code{1}, or alternatively \code{'lower'} and \code{'upper'}. -#' \code{resp_subset} requires \code{0} and \code{1}, or alternatively -#' \code{FALSE} and \code{TRUE}. \code{resp_cens} requires \code{'left'}, -#' \code{'none'}, \code{'right'}, and \code{'interval'} (or equivalently -#' \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate left, no, right, -#' or interval censoring. \code{resp_index} does not make any requirements -#' other than the value being unique for each observation. -#' @param sigma Logical; Indicates whether the residual standard deviation -#' parameter \code{sigma} should be included in addition to the known -#' measurement error. Defaults to \code{FALSE} for backwards compatibility, -#' but setting it to \code{TRUE} is usually the better choice. -#' @param scale Logical; Indicates whether weights should be scaled -#' so that the average weight equals one. Defaults to \code{FALSE}. -#' @param y2 A vector specifying the upper bounds in interval censoring. -#' Will be ignored for non-interval censored observations. However, it -#' should NOT be \code{NA} even for non-interval censored observations to -#' avoid accidental exclusion of these observations. -#' @param lb A numeric vector or single numeric value specifying -#' the lower truncation bound. -#' @param ub A numeric vector or single numeric value specifying -#' the upper truncation bound. -#' @param sdy Optional known measurement error of the response -#' treated as standard deviation. If specified, handles -#' measurement error and (completely) missing values -#' at the same time using the plausible-values-technique. -#' @param denom A vector of positive numeric values specifying -#' the denominator values from which the response rates are computed. -#' @param gr A vector of grouping indicators. -#' @param ... For \code{resp_vreal}, vectors of real values. -#' For \code{resp_vint}, vectors of integer values. In Stan, -#' these variables will be named \code{vreal1}, \code{vreal2}, ..., -#' and \code{vint1}, \code{vint2}, ..., respectively. -#' -#' @return A list of additional response information to be processed further -#' by \pkg{brms}. -#' -#' @details -#' These functions are almost solely useful when -#' called in formulas passed to the \pkg{brms} package. -#' Within formulas, the \code{resp_} prefix may be omitted. -#' More information is given in the 'Details' section -#' of \code{\link{brmsformula}}. -#' -#' @seealso -#' \code{\link{brm}}, -#' \code{\link{brmsformula}} -#' -#' @examples -#' \dontrun{ -#' ## Random effects meta-analysis -#' nstudies <- 20 -#' true_effects <- rnorm(nstudies, 0.5, 0.2) -#' sei <- runif(nstudies, 0.05, 0.3) -#' outcomes <- rnorm(nstudies, true_effects, sei) -#' data1 <- data.frame(outcomes, sei) -#' fit1 <- brm(outcomes | se(sei, sigma = TRUE) ~ 1, -#' data = data1) -#' summary(fit1) -#' -#' ## Probit regression using the binomial family -#' n <- sample(1:10, 100, TRUE) # number of trials -#' success <- rbinom(100, size = n, prob = 0.4) -#' x <- rnorm(100) -#' data2 <- data.frame(n, success, x) -#' fit2 <- brm(success | trials(n) ~ x, data = data2, -#' family = binomial("probit")) -#' summary(fit2) -#' -#' ## Survival regression modeling the time between the first -#' ## and second recurrence of an infection in kidney patients. -#' fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), -#' data = kidney, family = lognormal()) -#' summary(fit3) -#' -#' ## Poisson model with truncated counts -#' fit4 <- brm(count | trunc(ub = 104) ~ zBase * Trt, -#' data = epilepsy, family = poisson()) -#' summary(fit4) -#' } -#' -NULL - -#' @rdname addition-terms -#' @export -resp_se <- function(x, sigma = FALSE) { - se <- deparse(substitute(x)) - sigma <- as_one_logical(sigma) - class_resp_special( - "se", call = match.call(), - vars = nlist(se), flags = nlist(sigma) - ) -} - -#' @rdname addition-terms -#' @export -resp_weights <- function(x, scale = FALSE) { - weights <- deparse(substitute(x)) - scale <- as_one_logical(scale) - class_resp_special( - "weights", call = match.call(), - vars = nlist(weights), flags = nlist(scale) - ) -} - -#' @rdname addition-terms -#' @export -resp_trials <- function(x) { - trials <- deparse(substitute(x)) - class_resp_special("trials", call = match.call(), vars = nlist(trials)) -} - -#' @rdname addition-terms -#' @export -resp_thres <- function(x, gr = NA) { - thres <- deparse(substitute(x)) - gr <- deparse(substitute(gr)) - class_resp_special("thres", call = match.call(), vars = nlist(thres, gr)) -} - -#' @rdname addition-terms -#' @export -resp_cat <- function(x) { - # deprecated as of brms 2.10.5 - # number of thresholds = number of response categories - 1 - thres <- deparse(substitute(x)) - str_add(thres) <- " - 1" - class_resp_special( - "thres", call = match.call(), - vars = nlist(thres, gr = "NA") - ) -} - -#' @rdname addition-terms -#' @export -resp_dec <- function(x) { - dec <- deparse(substitute(x)) - class_resp_special("dec", call = match.call(), vars = nlist(dec)) -} - -#' @rdname addition-terms -#' @export -resp_cens <- function(x, y2 = NA) { - cens <- deparse(substitute(x)) - y2 <- deparse(substitute(y2)) - class_resp_special("cens", call = match.call(), vars = nlist(cens, y2)) -} - -#' @rdname addition-terms -#' @export -resp_trunc <- function(lb = -Inf, ub = Inf) { - lb <- deparse(substitute(lb)) - ub <- deparse(substitute(ub)) - class_resp_special("trunc", call = match.call(), vars = nlist(lb, ub)) -} - -#' @rdname addition-terms -#' @export -resp_mi <- function(sdy = NA) { - sdy <- deparse(substitute(sdy)) - class_resp_special("mi", call = match.call(), vars = nlist(sdy)) -} - -#' @rdname addition-terms -#' @export -resp_index <- function(x) { - index <- deparse(substitute(x)) - class_resp_special("index", call = match.call(), vars = nlist(index)) -} - -#' @rdname addition-terms -#' @export -resp_rate <- function(denom) { - denom <- deparse(substitute(denom)) - class_resp_special("rate", call = match.call(), vars = nlist(denom)) -} - -#' @rdname addition-terms -#' @export -resp_subset <- function(x) { - subset <- deparse(substitute(x)) - class_resp_special("subset", call = match.call(), vars = nlist(subset)) -} - -#' @rdname addition-terms -#' @export -resp_vreal <- function(...) { - vars <- as.list(substitute(list(...)))[-1] - class_resp_special("vreal", call = match.call(), vars = vars) -} - -#' @rdname addition-terms -#' @export -resp_vint <- function(...) { - vars <- as.list(substitute(list(...)))[-1] - class_resp_special("vint", call = match.call(), vars = vars) -} - -# class underlying response addition terms -# @param type type of the addition term -# @param call the call to the original addition term function -# @param vars named list of unevaluated variables -# @param flags named list of (evaluated) logical indicators -class_resp_special <- function(type, call, vars = list(), flags = list()) { - type <- as_one_character(type) - stopifnot(is.call(call), is.list(vars), is.list(flags)) - label <- deparse(call) - out <- nlist(type, call, label, vars, flags) - class(out) <- c("resp_special") - out -} - -# computes data for addition arguments -eval_rhs <- function(formula, data = NULL) { - formula <- as.formula(formula) - eval(rhs(formula)[[2]], data, environment(formula)) -} - -# get expression for a variable of an addition term -# @param x list with potential $adforms elements -# @param ad name of the addition term -# @param target name of the element to extract -# @type type of the element to extract -# @return a character string or NULL -get_ad_expr <- function(x, ad, name, type = "vars") { - ad <- as_one_character(ad) - name <- as_one_character(name) - type <- as_one_character(type) - if (is.null(x$adforms[[ad]])) { - return(NULL) - } - out <- eval_rhs(x$adforms[[ad]])[[type]][[name]] - if (type == "vars" && is_equal(out, "NA")) { - out <- NULL - } - out -} - -# get values of a variable used in an addition term -# @return a vector of values or NULL -get_ad_values <- function(x, ad, name, data) { - expr <- get_ad_expr(x, ad, name, type = "vars") - eval2(expr, data) -} - -# get a flag used in an addition term -# @return TRUE or FALSE -get_ad_flag <- function(x, ad, name) { - expr <- get_ad_expr(x, ad, name, type = "flags") - as_one_logical(eval2(expr)) -} - -# get variable names used in addition terms -get_ad_vars <- function(x, ...) { - UseMethod("get_ad_vars") -} - -#' @export -get_ad_vars.brmsterms <- function(x, ad, ...) { - ad <- as_one_character(ad) - all_vars(x$adforms[[ad]]) -} - -#' @export -get_ad_vars.mvbrmsterms <- function(x, ad, ...) { - unique(ulapply(x$terms, get_ad_vars, ad = ad, ...)) -} - -# coerce censored values into the right format -# @param x vector of censoring indicators -# @return transformed vector of censoring indicators -prepare_cens <- function(x) { - .prepare_cens <- function(x) { - stopifnot(length(x) == 1L) - regx <- paste0("^", x) - if (grepl(regx, "left")) { - x <- -1 - } else if (grepl(regx, "none") || isFALSE(x)) { - x <- 0 - } else if (grepl(regx, "right") || isTRUE(x)) { - x <- 1 - } else if (grepl(regx, "interval")) { - x <- 2 - } - return(x) - } - x <- unname(x) - if (is.factor(x)) { - x <- as.character(x) - } - ulapply(x, .prepare_cens) -} - -# extract information on censoring of the response variable -# @return vector of censoring indicators or NULL in case of no censoring -get_cens <- function(bterms, data, resp = NULL) { - if (!is.null(resp)) { - bterms <- bterms$terms[[resp]] - } - out <- NULL - if (is.formula(bterms$adforms$cens)) { - out <- get_ad_values(bterms, "cens", "cens", data) - out <- prepare_cens(out) - } - out -} - -# extract truncation boundaries -# @param bterms a brmsterms object -# @param data data.frame containing the truncation variables -# @param incl_family include the family in the derivation of the bounds? -# @param stan return bounds in form of Stan syntax? -# @return a list with elements 'lb' and 'ub' or corresponding Stan code -trunc_bounds <- function(bterms, data = NULL, incl_family = FALSE, - stan = FALSE, ...) { - stopifnot(is.brmsterms(bterms)) - if (is.formula(bterms$adforms$trunc)) { - trunc <- eval_rhs(bterms$adforms$trunc) - } else { - trunc <- resp_trunc() - } - out <- list( - lb = eval2(trunc$vars$lb, data), - ub = eval2(trunc$vars$ub, data) - ) - if (incl_family) { - family_bounds <- family_bounds(bterms) - out$lb <- max(out$lb, family_bounds$lb) - out$ub <- min(out$ub, family_bounds$ub) - } - if (stan) { - if (any(out$lb > -Inf | out$ub < Inf)) { - tmp <- c( - if (out$lb > -Inf) paste0("lower=", out$lb), - if (out$ub < Inf) paste0("upper=", out$ub) - ) - out <- paste0("<", paste0(tmp, collapse = ","), ">") - } else { - out <- "" - } - } - out -} - -# check if addition argument 'subset' ist used in the model -has_subset <- function(bterms) { - .has_subset <- function(x) { - is.formula(x$adforms$subset) - } - if (is.brmsterms(bterms)) { - out <- .has_subset(bterms) - } else if (is.mvbrmsterms(bterms)) { - out <- any(ulapply(bterms$terms, .has_subset)) - } else { - out <- FALSE - } - out -} - -# construct a list of indices for cross-formula referencing -tidy_index <- function(x, data) { - out <- .tidy_index(x, data) - if (is.brmsterms(x)) { - # ensure consistent format for both uni- and multivariate models - out <- list(out) - names(out)[1] <- terms_resp(x$respform) - } - out -} - -# internal version of tidy_index -.tidy_index <- function(x, ...) { - UseMethod(".tidy_index") -} - -#' @export -.tidy_index.brmsterms <- function(x, data, ...) { - out <- get_ad_values(x, "index", "index", data) - if (is.null(out)) { - return(NULL) - } - if (has_subset(x)) { - subset <- as.logical(get_ad_values(x, "subset", "subset", data)) - out <- out[subset] - attr(out, "subset") <- TRUE - } - if (anyNA(out)) { - stop2("NAs are not allowed in 'index' variables.") - } - if (anyDuplicated(out)) { - stop2("Index of response '", names(out), "' contains duplicated values.") - } - out -} - -#' @export -.tidy_index.mvbrmsterms <- function(x, data, ...) { - lapply(x$terms, .tidy_index, data = data, ...) -} - -# check if cross-formula referencing is possible in subsetted models -check_cross_formula_indexing <- function(bterms) { - sp_terms <- ulapply(get_effect(bterms, "sp"), all_terms) - me_terms <- get_matches_expr(regex_sp("me"), sp_terms) - if (length(me_terms)) { - stop2("Cannot use me() terms in subsetted formulas.") - } - mi_terms <- get_matches_expr(regex_sp("mi"), sp_terms) - idx_vars <- lapply(mi_terms, function(x) eval2(x)$idx) - if (any(idx_vars == "NA")) { - stop2("mi() terms in subsetted formulas require ", - "the 'idx' argument to be specified.") - } - invisible(TRUE) -} +#' Additional Response Information +#' +#' Provide additional information on the response variable +#' in \pkg{brms} models, such as censoring, truncation, or +#' known measurement error. Detailed documentation on the use +#' of each of these functions can be found in the Details section +#' of \code{\link{brmsformula}} (under "Additional response information"). +#' +#' @name addition-terms +#' @aliases se weights trials thres cat dec cens trunc +#' @aliases index rate subset vreal vint +#' +#' @param x A vector; usually a variable defined in the data. Allowed values +#' depend on the function: \code{resp_se} and \code{resp_weights} require +#' positive numeric values. \code{resp_trials}, \code{resp_thres}, and +#' \code{resp_cat} require positive integers. \code{resp_dec} requires +#' \code{0} and \code{1}, or alternatively \code{'lower'} and \code{'upper'}. +#' \code{resp_subset} requires \code{0} and \code{1}, or alternatively +#' \code{FALSE} and \code{TRUE}. \code{resp_cens} requires \code{'left'}, +#' \code{'none'}, \code{'right'}, and \code{'interval'} (or equivalently +#' \code{-1}, \code{0}, \code{1}, and \code{2}) to indicate left, no, right, +#' or interval censoring. \code{resp_index} does not make any requirements +#' other than the value being unique for each observation. +#' @param sigma Logical; Indicates whether the residual standard deviation +#' parameter \code{sigma} should be included in addition to the known +#' measurement error. Defaults to \code{FALSE} for backwards compatibility, +#' but setting it to \code{TRUE} is usually the better choice. +#' @param scale Logical; Indicates whether weights should be scaled +#' so that the average weight equals one. Defaults to \code{FALSE}. +#' @param y2 A vector specifying the upper bounds in interval censoring. +#' Will be ignored for non-interval censored observations. However, it +#' should NOT be \code{NA} even for non-interval censored observations to +#' avoid accidental exclusion of these observations. +#' @param lb A numeric vector or single numeric value specifying +#' the lower truncation bound. +#' @param ub A numeric vector or single numeric value specifying +#' the upper truncation bound. +#' @param sdy Optional known measurement error of the response +#' treated as standard deviation. If specified, handles +#' measurement error and (completely) missing values +#' at the same time using the plausible-values-technique. +#' @param denom A vector of positive numeric values specifying +#' the denominator values from which the response rates are computed. +#' @param gr A vector of grouping indicators. +#' @param ... For \code{resp_vreal}, vectors of real values. +#' For \code{resp_vint}, vectors of integer values. In Stan, +#' these variables will be named \code{vreal1}, \code{vreal2}, ..., +#' and \code{vint1}, \code{vint2}, ..., respectively. +#' +#' @return A list of additional response information to be processed further +#' by \pkg{brms}. +#' +#' @details +#' These functions are almost solely useful when +#' called in formulas passed to the \pkg{brms} package. +#' Within formulas, the \code{resp_} prefix may be omitted. +#' More information is given in the 'Details' section +#' of \code{\link{brmsformula}} (under "Additional response information"). +#' +#' @seealso +#' \code{\link{brm}}, +#' \code{\link{brmsformula}} +#' +#' @examples +#' \dontrun{ +#' ## Random effects meta-analysis +#' nstudies <- 20 +#' true_effects <- rnorm(nstudies, 0.5, 0.2) +#' sei <- runif(nstudies, 0.05, 0.3) +#' outcomes <- rnorm(nstudies, true_effects, sei) +#' data1 <- data.frame(outcomes, sei) +#' fit1 <- brm(outcomes | se(sei, sigma = TRUE) ~ 1, +#' data = data1) +#' summary(fit1) +#' +#' ## Probit regression using the binomial family +#' n <- sample(1:10, 100, TRUE) # number of trials +#' success <- rbinom(100, size = n, prob = 0.4) +#' x <- rnorm(100) +#' data2 <- data.frame(n, success, x) +#' fit2 <- brm(success | trials(n) ~ x, data = data2, +#' family = binomial("probit")) +#' summary(fit2) +#' +#' ## Survival regression modeling the time between the first +#' ## and second recurrence of an infection in kidney patients. +#' fit3 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), +#' data = kidney, family = lognormal()) +#' summary(fit3) +#' +#' ## Poisson model with truncated counts +#' fit4 <- brm(count | trunc(ub = 104) ~ zBase * Trt, +#' data = epilepsy, family = poisson()) +#' summary(fit4) +#' } +#' +NULL + +#' @rdname addition-terms +#' @export +resp_se <- function(x, sigma = FALSE) { + se <- deparse(substitute(x)) + sigma <- as_one_logical(sigma) + class_resp_special( + "se", call = match.call(), + vars = nlist(se), flags = nlist(sigma) + ) +} + +#' @rdname addition-terms +#' @export +resp_weights <- function(x, scale = FALSE) { + weights <- deparse(substitute(x)) + scale <- as_one_logical(scale) + class_resp_special( + "weights", call = match.call(), + vars = nlist(weights), flags = nlist(scale) + ) +} + +#' @rdname addition-terms +#' @export +resp_trials <- function(x) { + trials <- deparse(substitute(x)) + class_resp_special("trials", call = match.call(), vars = nlist(trials)) +} + +#' @rdname addition-terms +#' @export +resp_thres <- function(x, gr = NA) { + thres <- deparse(substitute(x)) + gr <- deparse(substitute(gr)) + class_resp_special("thres", call = match.call(), vars = nlist(thres, gr)) +} + +#' @rdname addition-terms +#' @export +resp_cat <- function(x) { + # deprecated as of brms 2.10.5 + # number of thresholds = number of response categories - 1 + thres <- deparse(substitute(x)) + str_add(thres) <- " - 1" + class_resp_special( + "thres", call = match.call(), + vars = nlist(thres, gr = "NA") + ) +} + +#' @rdname addition-terms +#' @export +resp_dec <- function(x) { + dec <- deparse(substitute(x)) + class_resp_special("dec", call = match.call(), vars = nlist(dec)) +} + +#' @rdname addition-terms +#' @export +resp_cens <- function(x, y2 = NA) { + cens <- deparse(substitute(x)) + y2 <- deparse(substitute(y2)) + class_resp_special("cens", call = match.call(), vars = nlist(cens, y2)) +} + +#' @rdname addition-terms +#' @export +resp_trunc <- function(lb = -Inf, ub = Inf) { + lb <- deparse(substitute(lb)) + ub <- deparse(substitute(ub)) + class_resp_special("trunc", call = match.call(), vars = nlist(lb, ub)) +} + +#' @rdname addition-terms +#' @export +resp_mi <- function(sdy = NA) { + sdy <- deparse(substitute(sdy)) + class_resp_special("mi", call = match.call(), vars = nlist(sdy)) +} + +#' @rdname addition-terms +#' @export +resp_index <- function(x) { + index <- deparse(substitute(x)) + class_resp_special("index", call = match.call(), vars = nlist(index)) +} + +#' @rdname addition-terms +#' @export +resp_rate <- function(denom) { + denom <- deparse(substitute(denom)) + class_resp_special("rate", call = match.call(), vars = nlist(denom)) +} + +#' @rdname addition-terms +#' @export +resp_subset <- function(x) { + subset <- deparse(substitute(x)) + class_resp_special("subset", call = match.call(), vars = nlist(subset)) +} + +#' @rdname addition-terms +#' @export +resp_vreal <- function(...) { + vars <- as.list(substitute(list(...)))[-1] + class_resp_special("vreal", call = match.call(), vars = vars) +} + +#' @rdname addition-terms +#' @export +resp_vint <- function(...) { + vars <- as.list(substitute(list(...)))[-1] + class_resp_special("vint", call = match.call(), vars = vars) +} + +# class underlying response addition terms +# @param type type of the addition term +# @param call the call to the original addition term function +# @param vars named list of unevaluated variables +# @param flags named list of (evaluated) logical indicators +class_resp_special <- function(type, call, vars = list(), flags = list()) { + type <- as_one_character(type) + stopifnot(is.call(call), is.list(vars), is.list(flags)) + label <- deparse(call) + out <- nlist(type, call, label, vars, flags) + class(out) <- c("resp_special") + out +} + +# computes data for addition arguments +eval_rhs <- function(formula, data = NULL) { + formula <- as.formula(formula) + eval(rhs(formula)[[2]], data, environment(formula)) +} + +# get expression for a variable of an addition term +# @param x list with potential $adforms elements +# @param ad name of the addition term +# @param target name of the element to extract +# @type type of the element to extract +# @return a character string or NULL +get_ad_expr <- function(x, ad, name, type = "vars") { + ad <- as_one_character(ad) + name <- as_one_character(name) + type <- as_one_character(type) + if (is.null(x$adforms[[ad]])) { + return(NULL) + } + out <- eval_rhs(x$adforms[[ad]])[[type]][[name]] + if (type == "vars" && is_equal(out, "NA")) { + out <- NULL + } + out +} + +# get values of a variable used in an addition term +# @return a vector of values or NULL +get_ad_values <- function(x, ad, name, data) { + expr <- get_ad_expr(x, ad, name, type = "vars") + eval2(expr, data) +} + +# get a flag used in an addition term +# @return TRUE or FALSE +get_ad_flag <- function(x, ad, name) { + expr <- get_ad_expr(x, ad, name, type = "flags") + as_one_logical(eval2(expr)) +} + +# get variable names used in addition terms +get_ad_vars <- function(x, ...) { + UseMethod("get_ad_vars") +} + +#' @export +get_ad_vars.brmsterms <- function(x, ad, ...) { + ad <- as_one_character(ad) + all_vars(x$adforms[[ad]]) +} + +#' @export +get_ad_vars.mvbrmsterms <- function(x, ad, ...) { + unique(ulapply(x$terms, get_ad_vars, ad = ad, ...)) +} + +# coerce censored values into the right format +# @param x vector of censoring indicators +# @return transformed vector of censoring indicators +prepare_cens <- function(x) { + .prepare_cens <- function(x) { + stopifnot(length(x) == 1L) + regx <- paste0("^", x) + if (grepl(regx, "left")) { + x <- -1 + } else if (grepl(regx, "none") || isFALSE(x)) { + x <- 0 + } else if (grepl(regx, "right") || isTRUE(x)) { + x <- 1 + } else if (grepl(regx, "interval")) { + x <- 2 + } + return(x) + } + x <- unname(x) + if (is.factor(x)) { + x <- as.character(x) + } + ulapply(x, .prepare_cens) +} + +# extract information on censoring of the response variable +# @return vector of censoring indicators or NULL in case of no censoring +get_cens <- function(bterms, data, resp = NULL) { + if (!is.null(resp)) { + bterms <- bterms$terms[[resp]] + } + out <- NULL + if (is.formula(bterms$adforms$cens)) { + out <- get_ad_values(bterms, "cens", "cens", data) + out <- prepare_cens(out) + } + out +} + +# extract truncation boundaries +# @param bterms a brmsterms object +# @param data data.frame containing the truncation variables +# @param incl_family include the family in the derivation of the bounds? +# @param stan return bounds in form of Stan syntax? +# @return a list with elements 'lb' and 'ub' or corresponding Stan code +trunc_bounds <- function(bterms, data = NULL, incl_family = FALSE, + stan = FALSE, ...) { + stopifnot(is.brmsterms(bterms)) + if (is.formula(bterms$adforms$trunc)) { + trunc <- eval_rhs(bterms$adforms$trunc) + } else { + trunc <- resp_trunc() + } + out <- list( + lb = eval2(trunc$vars$lb, data), + ub = eval2(trunc$vars$ub, data) + ) + if (incl_family) { + family_bounds <- family_bounds(bterms) + out$lb <- max(out$lb, family_bounds$lb) + out$ub <- min(out$ub, family_bounds$ub) + } + if (stan) { + if (any(out$lb > -Inf | out$ub < Inf)) { + tmp <- c( + if (out$lb > -Inf) paste0("lower=", out$lb), + if (out$ub < Inf) paste0("upper=", out$ub) + ) + out <- paste0("<", paste0(tmp, collapse = ","), ">") + } else { + out <- "" + } + } + out +} + +# check if addition argument 'subset' ist used in the model +has_subset <- function(bterms) { + .has_subset <- function(x) { + is.formula(x$adforms$subset) + } + if (is.brmsterms(bterms)) { + out <- .has_subset(bterms) + } else if (is.mvbrmsterms(bterms)) { + out <- any(ulapply(bterms$terms, .has_subset)) + } else { + out <- FALSE + } + out +} + +# construct a list of indices for cross-formula referencing +tidy_index <- function(x, data) { + out <- .tidy_index(x, data) + if (is.brmsterms(x)) { + # ensure consistent format for both uni- and multivariate models + out <- list(out) + names(out)[1] <- terms_resp(x$respform) + } + out +} + +# internal version of tidy_index +.tidy_index <- function(x, ...) { + UseMethod(".tidy_index") +} + +#' @export +.tidy_index.brmsterms <- function(x, data, ...) { + out <- get_ad_values(x, "index", "index", data) + if (is.null(out)) { + return(NULL) + } + if (has_subset(x)) { + subset <- as.logical(get_ad_values(x, "subset", "subset", data)) + out <- out[subset] + attr(out, "subset") <- TRUE + } + if (anyNA(out)) { + stop2("NAs are not allowed in 'index' variables.") + } + if (anyDuplicated(out)) { + stop2("Index of response '", names(out), "' contains duplicated values.") + } + out +} + +#' @export +.tidy_index.mvbrmsterms <- function(x, data, ...) { + lapply(x$terms, .tidy_index, data = data, ...) +} + +# check if cross-formula referencing is possible in subsetted models +check_cross_formula_indexing <- function(bterms) { + sp_terms <- ulapply(get_effect(bterms, "sp"), all_terms) + me_terms <- get_matches_expr(regex_sp("me"), sp_terms) + if (length(me_terms)) { + stop2("Cannot use me() terms in subsetted formulas.") + } + mi_terms <- get_matches_expr(regex_sp("mi"), sp_terms) + idx_vars <- lapply(mi_terms, function(x) eval2(x)$idx) + if (any(idx_vars == "NA")) { + stop2("mi() terms in subsetted formulas require ", + "the 'idx' argument to be specified.") + } + invisible(TRUE) +} diff -Nru r-cran-brms-2.16.3/R/formula-cs.R r-cran-brms-2.17.0/R/formula-cs.R --- r-cran-brms-2.16.3/R/formula-cs.R 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/R/formula-cs.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,35 +1,35 @@ -#' Category Specific Predictors in \pkg{brms} Models -#' -#' @aliases cse -#' -#' @param expr Expression containing predictors, -#' for which category specific effects should be estimated. -#' For evaluation, \R formula syntax is applied. -#' -#' @details For detailed documentation see \code{help(brmsformula)} -#' as well as \code{vignette("brms_overview")}. -#' -#' This function is almost solely useful when -#' called in formulas passed to the \pkg{brms} package. -#' -#' @seealso \code{\link{brmsformula}} -#' -#' @examples -#' \dontrun{ -#' fit <- brm(rating ~ period + carry + cs(treat), -#' data = inhaler, family = sratio("cloglog"), -#' prior = set_prior("normal(0,5)"), chains = 2) -#' summary(fit) -#' plot(fit, ask = FALSE) -#' } -#' -#' @export -cs <- function(expr) { - deparse_no_string(substitute(expr)) -} - -# alias of function 'cs' used in the JSS paper of brms -#' @export -cse <- function(expr) { - deparse_no_string(substitute(expr)) -} +#' Category Specific Predictors in \pkg{brms} Models +#' +#' @aliases cse +#' +#' @param expr Expression containing predictors, +#' for which category specific effects should be estimated. +#' For evaluation, \R formula syntax is applied. +#' +#' @details For detailed documentation see \code{help(brmsformula)} +#' as well as \code{vignette("brms_overview")}. +#' +#' This function is almost solely useful when +#' called in formulas passed to the \pkg{brms} package. +#' +#' @seealso \code{\link{brmsformula}} +#' +#' @examples +#' \dontrun{ +#' fit <- brm(rating ~ period + carry + cs(treat), +#' data = inhaler, family = sratio("cloglog"), +#' prior = set_prior("normal(0,5)"), chains = 2) +#' summary(fit) +#' plot(fit, ask = FALSE) +#' } +#' +#' @export +cs <- function(expr) { + deparse_no_string(substitute(expr)) +} + +# alias of function 'cs' used in the JSS paper of brms +#' @export +cse <- function(expr) { + deparse_no_string(substitute(expr)) +} diff -Nru r-cran-brms-2.16.3/R/formula-gp.R r-cran-brms-2.17.0/R/formula-gp.R --- r-cran-brms-2.16.3/R/formula-gp.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/formula-gp.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,321 +1,321 @@ -# R helper functions for Gaussian Processes - -#' Set up Gaussian process terms in \pkg{brms} -#' -#' Set up a Gaussian process (GP) term in \pkg{brms}. The function does not -#' evaluate its arguments -- it exists purely to help set up a model with -#' GP terms. -#' -#' @param ... One or more predictors for the GP. -#' @param by A numeric or factor variable of the same length as -#' each predictor. In the numeric vector case, the elements multiply -#' the values returned by the GP. In the factor variable -#' case, a separate GP is fitted for each factor level. -#' @param k Optional number of basis functions for computing approximate -#' GPs. If \code{NA} (the default), exact GPs are computed. -#' @param cov Name of the covariance kernel. By default, -#' the exponentiated-quadratic kernel \code{"exp_quad"} is used. -#' @param iso A flag to indicate whether an isotropic (\code{TRUE}; the -#' default) of a non-isotropic GP should be used. -#' In the former case, the same amount of smoothing is applied to all -#' predictors. In the latter case, predictors may have different smoothing. -#' Ignored if only a single predictors is supplied. -#' @param gr Logical; Indicates if auto-grouping should be used (defaults -#' to \code{TRUE}). If enabled, observations sharing the same -#' predictor values will be represented by the same latent variable -#' in the GP. This will improve sampling efficiency -#' drastically if the number of unique predictor combinations is small -#' relative to the number of observations. -#' @param cmc Logical; Only relevant if \code{by} is a factor. If \code{TRUE} -#' (the default), cell-mean coding is used for the \code{by}-factor, that is -#' one GP per level is estimated. If \code{FALSE}, contrast GPs are estimated -#' according to the contrasts set for the \code{by}-factor. -#' @param scale Logical; If \code{TRUE} (the default), predictors are -#' scaled so that the maximum Euclidean distance between two points -#' is 1. This often improves sampling speed and convergence. -#' Scaling also affects the estimated length-scale parameters -#' in that they resemble those of scaled predictors (not of the original -#' predictors) if \code{scale} is \code{TRUE}. -#' @param c Numeric value only used in approximate GPs. Defines the -#' multiplicative constant of the predictors' range over which -#' predictions should be computed. A good default could be \code{c = 5/4} -#' but we are still working on providing better recommendations. -#' -#' @details A GP is a stochastic process, which -#' describes the relation between one or more predictors -#' \eqn{x = (x_1, ..., x_d)} and a response \eqn{f(x)}, where -#' \eqn{d} is the number of predictors. A GP is the -#' generalization of the multivariate normal distribution -#' to an infinite number of dimensions. Thus, it can be -#' interpreted as a prior over functions. Any finite sample -#' realized from this stochastic process is jointly multivariate -#' normal, with a covariance matrix defined by the covariance -#' kernel \eqn{k_p(x)}, where \eqn{p} is the vector of parameters -#' of the GP: -#' \deqn{f(x) ~ MVN(0, k_p(x))} -#' The smoothness and general behavior of the function \eqn{f} -#' depends only on the choice of covariance kernel. -#' For a more detailed introduction to Gaussian processes, -#' see \url{https://en.wikipedia.org/wiki/Gaussian_process}. -#' -#' Below, we describe the currently supported covariance kernels: -#' \itemize{ -#' \item{"exp_quad": }{The exponentiated-quadratic kernel is defined as -#' \eqn{k(x_i, x_j) = sdgp^2 exp(- || x_i - x_j ||^2 / (2 lscale^2))}, -#' where \eqn{|| . ||} is the Euclidean norm, \eqn{sdgp} is a -#' standard deviation parameter, and \eqn{lscale} is characteristic -#' length-scale parameter. The latter practically measures how close two -#' points \eqn{x_i} and \eqn{x_j} have to be to influence each other -#' substantially.} -#' } -#' -#' In the current implementation, \code{"exp_quad"} is the only supported -#' covariance kernel. More options will follow in the future. -#' -#' @return An object of class \code{'gp_term'}, which is a list -#' of arguments to be interpreted by the formula -#' parsing functions of \pkg{brms}. -#' -#' @examples -#' \dontrun{ -#' # simulate data using the mgcv package -#' dat <- mgcv::gamSim(1, n = 30, scale = 2) -#' -#' # fit a simple GP model -#' fit1 <- brm(y ~ gp(x2), dat, chains = 2) -#' summary(fit1) -#' me1 <- conditional_effects(fit1, ndraws = 200, spaghetti = TRUE) -#' plot(me1, ask = FALSE, points = TRUE) -#' -#' # fit a more complicated GP model -#' fit2 <- brm(y ~ gp(x0) + x1 + gp(x2) + x3, dat, chains = 2) -#' summary(fit2) -#' me2 <- conditional_effects(fit2, ndraws = 200, spaghetti = TRUE) -#' plot(me2, ask = FALSE, points = TRUE) -#' -#' # fit a multivariate GP model -#' fit3 <- brm(y ~ gp(x1, x2), dat, chains = 2) -#' summary(fit3) -#' me3 <- conditional_effects(fit3, ndraws = 200, spaghetti = TRUE) -#' plot(me3, ask = FALSE, points = TRUE) -#' -#' # compare model fit -#' LOO(fit1, fit2, fit3) -#' -#' # simulate data with a factor covariate -#' dat2 <- mgcv::gamSim(4, n = 90, scale = 2) -#' -#' # fit separate gaussian processes for different levels of 'fac' -#' fit4 <- brm(y ~ gp(x2, by = fac), dat2, chains = 2) -#' summary(fit4) -#' plot(conditional_effects(fit4), points = TRUE) -#' } -#' -#' @seealso \code{\link{brmsformula}} -#' @export -gp <- function(..., by = NA, k = NA, cov = "exp_quad", iso = TRUE, - gr = TRUE, cmc = TRUE, scale = TRUE, c = NULL) { - cov <- match.arg(cov, choices = c("exp_quad")) - call <- match.call() - label <- deparse(call) - vars <- as.list(substitute(list(...)))[-1] - by <- deparse(substitute(by)) - cmc <- as_one_logical(cmc) - if (is.null(call[["gr"]]) && require_old_default("2.12.8")) { - # the default of 'gr' has changed in version 2.12.8 - gr <- FALSE - } else { - gr <- as_one_logical(gr) - } - if (length(vars) > 1L) { - iso <- as_one_logical(iso) - } else { - iso <- TRUE - } - if (!isNA(k)) { - k <- as.integer(as_one_numeric(k)) - if (k < 1L) { - stop2("'k' must be positive.") - } - if (is.null(c)) { - stop2( - "'c' must be specified for approximate GPs. ", - "A good default could be c = 5/4 but we are still ", - "working on providing better recommendations." - ) - } - c <- as.numeric(c) - if (length(c) == 1L) { - c <- rep(c, length(vars)) - } - if (length(c) != length(vars)) { - stop2("'c' must be of the same length as the number of covariates.") - } - if (any(c <= 0)) { - stop2("'c' must be positive.") - } - } else { - c <- NA - } - scale <- as_one_logical(scale) - term <- ulapply(vars, deparse, backtick = TRUE, width.cutoff = 500) - out <- nlist(term, label, by, cov, k, iso, gr, cmc, scale, c) - structure(out, class = "gp_term") -} - -# get labels of gaussian process terms -# @param x either a formula or a list containing an element "gp" -# @param data data frame containing the covariates -# @return a data.frame with one row per GP term -tidy_gpef <- function(x, data) { - if (is.formula(x)) { - x <- brmsterms(x, check_response = FALSE)$dpars$mu - } - form <- x[["gp"]] - if (!is.formula(form)) { - return(empty_data_frame()) - } - out <- data.frame(term = all_terms(form), stringsAsFactors = FALSE) - nterms <- nrow(out) - out$cons <- out$byvars <- out$covars <- - out$sfx1 <- out$sfx2 <- out$c <- vector("list", nterms) - for (i in seq_len(nterms)) { - gp <- eval2(out$term[i]) - out$label[i] <- paste0("gp", rename(collapse(gp$term))) - out$cov[i] <- gp$cov - out$k[i] <- gp$k - out$c[[i]] <- gp$c - out$iso[i] <- gp$iso - out$cmc[i] <- gp$cmc - out$gr[i] <- gp$gr - out$scale[i] <- gp$scale - out$covars[[i]] <- gp$term - if (gp$by != "NA") { - out$byvars[[i]] <- gp$by - str_add(out$label[i]) <- rename(gp$by) - byval <- get(gp$by, data) - if (is_like_factor(byval)) { - byval <- unique(as.factor(byval)) - byform <- str2formula(c(ifelse(gp$cmc, "0", "1"), "byval")) - cons <- rename(colnames(model.matrix(byform))) - out$cons[[i]] <- rm_wsp(sub("^byval", "", cons)) - } - } - # sfx1 is for sdgp and sfx2 is for lscale - out$sfx1[[i]] <- paste0(out$label[i], out$cons[[i]]) - if (out$iso[i]) { - out$sfx2[[i]] <- matrix(out$sfx1[[i]]) - } else { - out$sfx2[[i]] <- outer(out$sfx1[[i]], out$covars[[i]], paste0) - } - } - out -} - -# exponential-quadratic covariance matrix -# not vectorized over parameter values -cov_exp_quad <- function(x, x_new = NULL, sdgp = 1, lscale = 1) { - sdgp <- as.numeric(sdgp) - lscale <- as.numeric(lscale) - Dls <- length(lscale) - if (Dls == 1L) { - # one dimensional or isotropic GP - diff_quad <- diff_quad(x = x, x_new = x_new) - out <- sdgp^2 * exp(-diff_quad / (2 * lscale^2)) - } else { - # multi-dimensional non-isotropic GP - diff_quad <- diff_quad(x = x[, 1], x_new = x_new[, 1]) - out <- sdgp^2 * exp(-diff_quad / (2 * lscale[1]^2)) - for (d in seq_len(Dls)[-1]) { - diff_quad <- diff_quad(x = x[, d], x_new = x_new[, d]) - out <- out * exp(-diff_quad / (2 * lscale[d]^2)) - } - } - out -} - -# compute squared differences -# @param x vector or matrix -# @param x_new optional vector of matrix with the same ncol as x -# @return an nrow(x) times nrow(x_new) matrix -# @details if matrices are passed results are summed over the columns -diff_quad <- function(x, x_new = NULL) { - x <- as.matrix(x) - if (is.null(x_new)) { - x_new <- x - } else { - x_new <- as.matrix(x_new) - } - .diff_quad <- function(x1, x2) (x1 - x2)^2 - out <- 0 - for (i in seq_cols(x)) { - out <- out + outer(x[, i], x_new[, i], .diff_quad) - } - out -} - -# spectral density function -# vectorized over parameter values -spd_cov_exp_quad <- function(x, sdgp = 1, lscale = 1) { - NB <- NROW(x) - D <- NCOL(x) - Dls <- NCOL(lscale) - out <- matrix(nrow = length(sdgp), ncol = NB) - if (Dls == 1L) { - # one dimensional or isotropic GP - constant <- sdgp^2 * (sqrt(2 * pi) * lscale)^D - neg_half_lscale2 <- -0.5 * lscale^2 - for (m in seq_len(NB)) { - out[, m] <- constant * exp(neg_half_lscale2 * sum(x[m, ]^2)) - } - } else { - # multi-dimensional non-isotropic GP - constant <- sdgp^2 * sqrt(2 * pi)^D * matrixStats::rowProds(lscale) - neg_half_lscale2 = -0.5 * lscale^2 - for (m in seq_len(NB)) { - x2 <- data2draws(x[m, ]^2, dim = dim(lscale)) - out[, m] <- constant * exp(rowSums(neg_half_lscale2 * x2)) - } - } - out -} - -# compute the mth eigen value of an approximate GP -eigen_val_cov_exp_quad <- function(m, L) { - ((m * pi) / (2 * L))^2 -} - -# compute the mth eigen function of an approximate GP -eigen_fun_cov_exp_quad <- function(x, m, L) { - x <- as.matrix(x) - D <- ncol(x) - stopifnot(length(m) == D, length(L) == D) - out <- vector("list", D) - for (i in seq_cols(x)) { - out[[i]] <- 1 / sqrt(L[i]) * - sin((m[i] * pi) / (2 * L[i]) * (x[, i] + L[i])) - } - Reduce("*", out) -} - -# extended range of input data for which predictions should be made -choose_L <- function(x, c) { - if (!length(x)) { - range <- 1 - } else { - range <- max(1, max(x, na.rm = TRUE) - min(x, na.rm = TRUE)) - } - c * range -} - -# try to evaluate a GP term and -# return an informative error message if it fails -try_nug <- function(expr, nug) { - out <- try(expr, silent = TRUE) - if (is(out, "try-error")) { - stop2("The Gaussian process covariance matrix is not positive ", - "definite.\nThis occurs for numerical reasons. Setting ", - "'nug' above ", nug, " may help.") - } - out -} +# R helper functions for Gaussian Processes + +#' Set up Gaussian process terms in \pkg{brms} +#' +#' Set up a Gaussian process (GP) term in \pkg{brms}. The function does not +#' evaluate its arguments -- it exists purely to help set up a model with +#' GP terms. +#' +#' @param ... One or more predictors for the GP. +#' @param by A numeric or factor variable of the same length as +#' each predictor. In the numeric vector case, the elements multiply +#' the values returned by the GP. In the factor variable +#' case, a separate GP is fitted for each factor level. +#' @param k Optional number of basis functions for computing approximate +#' GPs. If \code{NA} (the default), exact GPs are computed. +#' @param cov Name of the covariance kernel. By default, +#' the exponentiated-quadratic kernel \code{"exp_quad"} is used. +#' @param iso A flag to indicate whether an isotropic (\code{TRUE}; the +#' default) or a non-isotropic GP should be used. +#' In the former case, the same amount of smoothing is applied to all +#' predictors. In the latter case, predictors may have different smoothing. +#' Ignored if only a single predictor is supplied. +#' @param gr Logical; Indicates if auto-grouping should be used (defaults +#' to \code{TRUE}). If enabled, observations sharing the same +#' predictor values will be represented by the same latent variable +#' in the GP. This will improve sampling efficiency +#' drastically if the number of unique predictor combinations is small +#' relative to the number of observations. +#' @param cmc Logical; Only relevant if \code{by} is a factor. If \code{TRUE} +#' (the default), cell-mean coding is used for the \code{by}-factor, that is +#' one GP per level is estimated. If \code{FALSE}, contrast GPs are estimated +#' according to the contrasts set for the \code{by}-factor. +#' @param scale Logical; If \code{TRUE} (the default), predictors are +#' scaled so that the maximum Euclidean distance between two points +#' is 1. This often improves sampling speed and convergence. +#' Scaling also affects the estimated length-scale parameters +#' in that they resemble those of scaled predictors (not of the original +#' predictors) if \code{scale} is \code{TRUE}. +#' @param c Numeric value only used in approximate GPs. Defines the +#' multiplicative constant of the predictors' range over which +#' predictions should be computed. A good default could be \code{c = 5/4} +#' but we are still working on providing better recommendations. +#' +#' @details A GP is a stochastic process, which +#' describes the relation between one or more predictors +#' \eqn{x = (x_1, ..., x_d)} and a response \eqn{f(x)}, where +#' \eqn{d} is the number of predictors. A GP is the +#' generalization of the multivariate normal distribution +#' to an infinite number of dimensions. Thus, it can be +#' interpreted as a prior over functions. The values of \eqn{f( )} +#' at any finite set of locations are jointly multivariate +#' normal, with a covariance matrix defined by the covariance +#' kernel \eqn{k_p(x_i, x_j)}, where \eqn{p} is the vector of parameters +#' of the GP: +#' \deqn{(f(x_1), \ldots f(x_n) \sim MVN(0, (k_p(x_i, x_j))_{i,j=1}^n) .} +#' The smoothness and general behavior of the function \eqn{f} +#' depends only on the choice of covariance kernel. +#' For a more detailed introduction to Gaussian processes, +#' see \url{https://en.wikipedia.org/wiki/Gaussian_process}. +#' +#' Below, we describe the currently supported covariance kernels: +#' \itemize{ +#' \item{"exp_quad": }{The exponentiated-quadratic kernel is defined as +#' \eqn{k(x_i, x_j) = sdgp^2 \exp(- || x_i - x_j ||^2 / (2 lscale^2))}, +#' where \eqn{|| . ||} is the Euclidean norm, \eqn{sdgp} is a +#' standard deviation parameter, and \eqn{lscale} is characteristic +#' length-scale parameter. The latter practically measures how close two +#' points \eqn{x_i} and \eqn{x_j} have to be to influence each other +#' substantially.} +#' } +#' +#' In the current implementation, \code{"exp_quad"} is the only supported +#' covariance kernel. More options will follow in the future. +#' +#' @return An object of class \code{'gp_term'}, which is a list +#' of arguments to be interpreted by the formula +#' parsing functions of \pkg{brms}. +#' +#' @examples +#' \dontrun{ +#' # simulate data using the mgcv package +#' dat <- mgcv::gamSim(1, n = 30, scale = 2) +#' +#' # fit a simple GP model +#' fit1 <- brm(y ~ gp(x2), dat, chains = 2) +#' summary(fit1) +#' me1 <- conditional_effects(fit1, ndraws = 200, spaghetti = TRUE) +#' plot(me1, ask = FALSE, points = TRUE) +#' +#' # fit a more complicated GP model +#' fit2 <- brm(y ~ gp(x0) + x1 + gp(x2) + x3, dat, chains = 2) +#' summary(fit2) +#' me2 <- conditional_effects(fit2, ndraws = 200, spaghetti = TRUE) +#' plot(me2, ask = FALSE, points = TRUE) +#' +#' # fit a multivariate GP model +#' fit3 <- brm(y ~ gp(x1, x2), dat, chains = 2) +#' summary(fit3) +#' me3 <- conditional_effects(fit3, ndraws = 200, spaghetti = TRUE) +#' plot(me3, ask = FALSE, points = TRUE) +#' +#' # compare model fit +#' LOO(fit1, fit2, fit3) +#' +#' # simulate data with a factor covariate +#' dat2 <- mgcv::gamSim(4, n = 90, scale = 2) +#' +#' # fit separate gaussian processes for different levels of 'fac' +#' fit4 <- brm(y ~ gp(x2, by = fac), dat2, chains = 2) +#' summary(fit4) +#' plot(conditional_effects(fit4), points = TRUE) +#' } +#' +#' @seealso \code{\link{brmsformula}} +#' @export +gp <- function(..., by = NA, k = NA, cov = "exp_quad", iso = TRUE, + gr = TRUE, cmc = TRUE, scale = TRUE, c = NULL) { + cov <- match.arg(cov, choices = c("exp_quad")) + call <- match.call() + label <- deparse(call) + vars <- as.list(substitute(list(...)))[-1] + by <- deparse(substitute(by)) + cmc <- as_one_logical(cmc) + if (is.null(call[["gr"]]) && require_old_default("2.12.8")) { + # the default of 'gr' has changed in version 2.12.8 + gr <- FALSE + } else { + gr <- as_one_logical(gr) + } + if (length(vars) > 1L) { + iso <- as_one_logical(iso) + } else { + iso <- TRUE + } + if (!isNA(k)) { + k <- as.integer(as_one_numeric(k)) + if (k < 1L) { + stop2("'k' must be positive.") + } + if (is.null(c)) { + stop2( + "'c' must be specified for approximate GPs. ", + "A good default could be c = 5/4 but we are still ", + "working on providing better recommendations." + ) + } + c <- as.numeric(c) + if (length(c) == 1L) { + c <- rep(c, length(vars)) + } + if (length(c) != length(vars)) { + stop2("'c' must be of the same length as the number of covariates.") + } + if (any(c <= 0)) { + stop2("'c' must be positive.") + } + } else { + c <- NA + } + scale <- as_one_logical(scale) + term <- ulapply(vars, deparse, backtick = TRUE, width.cutoff = 500) + out <- nlist(term, label, by, cov, k, iso, gr, cmc, scale, c) + structure(out, class = "gp_term") +} + +# get labels of gaussian process terms +# @param x either a formula or a list containing an element "gp" +# @param data data frame containing the covariates +# @return a data.frame with one row per GP term +tidy_gpef <- function(x, data) { + if (is.formula(x)) { + x <- brmsterms(x, check_response = FALSE)$dpars$mu + } + form <- x[["gp"]] + if (!is.formula(form)) { + return(empty_data_frame()) + } + out <- data.frame(term = all_terms(form), stringsAsFactors = FALSE) + nterms <- nrow(out) + out$cons <- out$byvars <- out$covars <- + out$sfx1 <- out$sfx2 <- out$c <- vector("list", nterms) + for (i in seq_len(nterms)) { + gp <- eval2(out$term[i]) + out$label[i] <- paste0("gp", rename(collapse(gp$term))) + out$cov[i] <- gp$cov + out$k[i] <- gp$k + out$c[[i]] <- gp$c + out$iso[i] <- gp$iso + out$cmc[i] <- gp$cmc + out$gr[i] <- gp$gr + out$scale[i] <- gp$scale + out$covars[[i]] <- gp$term + if (gp$by != "NA") { + out$byvars[[i]] <- gp$by + str_add(out$label[i]) <- rename(gp$by) + byval <- get(gp$by, data) + if (is_like_factor(byval)) { + byval <- unique(as.factor(byval)) + byform <- str2formula(c(ifelse(gp$cmc, "0", "1"), "byval")) + cons <- rename(colnames(model.matrix(byform))) + out$cons[[i]] <- rm_wsp(sub("^byval", "", cons)) + } + } + # sfx1 is for sdgp and sfx2 is for lscale + out$sfx1[[i]] <- paste0(out$label[i], out$cons[[i]]) + if (out$iso[i]) { + out$sfx2[[i]] <- matrix(out$sfx1[[i]]) + } else { + out$sfx2[[i]] <- outer(out$sfx1[[i]], out$covars[[i]], paste0) + } + } + out +} + +# exponential-quadratic covariance matrix +# not vectorized over parameter values +cov_exp_quad <- function(x, x_new = NULL, sdgp = 1, lscale = 1) { + sdgp <- as.numeric(sdgp) + lscale <- as.numeric(lscale) + Dls <- length(lscale) + if (Dls == 1L) { + # one dimensional or isotropic GP + diff_quad <- diff_quad(x = x, x_new = x_new) + out <- sdgp^2 * exp(-diff_quad / (2 * lscale^2)) + } else { + # multi-dimensional non-isotropic GP + diff_quad <- diff_quad(x = x[, 1], x_new = x_new[, 1]) + out <- sdgp^2 * exp(-diff_quad / (2 * lscale[1]^2)) + for (d in seq_len(Dls)[-1]) { + diff_quad <- diff_quad(x = x[, d], x_new = x_new[, d]) + out <- out * exp(-diff_quad / (2 * lscale[d]^2)) + } + } + out +} + +# compute squared differences +# @param x vector or matrix +# @param x_new optional vector of matrix with the same ncol as x +# @return an nrow(x) times nrow(x_new) matrix +# @details if matrices are passed results are summed over the columns +diff_quad <- function(x, x_new = NULL) { + x <- as.matrix(x) + if (is.null(x_new)) { + x_new <- x + } else { + x_new <- as.matrix(x_new) + } + .diff_quad <- function(x1, x2) (x1 - x2)^2 + out <- 0 + for (i in seq_cols(x)) { + out <- out + outer(x[, i], x_new[, i], .diff_quad) + } + out +} + +# spectral density function +# vectorized over parameter values +spd_cov_exp_quad <- function(x, sdgp = 1, lscale = 1) { + NB <- NROW(x) + D <- NCOL(x) + Dls <- NCOL(lscale) + out <- matrix(nrow = length(sdgp), ncol = NB) + if (Dls == 1L) { + # one dimensional or isotropic GP + constant <- sdgp^2 * (sqrt(2 * pi) * lscale)^D + neg_half_lscale2 <- -0.5 * lscale^2 + for (m in seq_len(NB)) { + out[, m] <- constant * exp(neg_half_lscale2 * sum(x[m, ]^2)) + } + } else { + # multi-dimensional non-isotropic GP + constant <- sdgp^2 * sqrt(2 * pi)^D * matrixStats::rowProds(lscale) + neg_half_lscale2 = -0.5 * lscale^2 + for (m in seq_len(NB)) { + x2 <- data2draws(x[m, ]^2, dim = dim(lscale)) + out[, m] <- constant * exp(rowSums(neg_half_lscale2 * x2)) + } + } + out +} + +# compute the mth eigen value of an approximate GP +eigen_val_cov_exp_quad <- function(m, L) { + ((m * pi) / (2 * L))^2 +} + +# compute the mth eigen function of an approximate GP +eigen_fun_cov_exp_quad <- function(x, m, L) { + x <- as.matrix(x) + D <- ncol(x) + stopifnot(length(m) == D, length(L) == D) + out <- vector("list", D) + for (i in seq_cols(x)) { + out[[i]] <- 1 / sqrt(L[i]) * + sin((m[i] * pi) / (2 * L[i]) * (x[, i] + L[i])) + } + Reduce("*", out) +} + +# extended range of input data for which predictions should be made +choose_L <- function(x, c) { + if (!length(x)) { + range <- 1 + } else { + range <- max(1, max(x, na.rm = TRUE) - min(x, na.rm = TRUE)) + } + c * range +} + +# try to evaluate a GP term and +# return an informative error message if it fails +try_nug <- function(expr, nug) { + out <- try(expr, silent = TRUE) + if (is(out, "try-error")) { + stop2("The Gaussian process covariance matrix is not positive ", + "definite.\nThis occurs for numerical reasons. Setting ", + "'nug' above ", nug, " may help.") + } + out +} diff -Nru r-cran-brms-2.16.3/R/formula-re.R r-cran-brms-2.17.0/R/formula-re.R --- r-cran-brms-2.16.3/R/formula-re.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/formula-re.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,877 +1,884 @@ -# This file contains functions dealing with the extended -# lme4-like formula syntax to specify group-level terms - -#' Set up basic grouping terms in \pkg{brms} -#' -#' Function used to set up a basic grouping term in \pkg{brms}. -#' The function does not evaluate its arguments -- -#' it exists purely to help set up a model with grouping terms. -#' \code{gr} is called implicitly inside the package -#' and there is usually no need to call it directly. -#' -#' @param ... One or more terms containing grouping factors. -#' @param by An optional factor variable, specifying sub-populations of the -#' groups. For each level of the \code{by} variable, a separate -#' variance-covariance matrix will be fitted. Levels of the grouping factor -#' must be nested in levels of the \code{by} variable. -#' @param cor Logical. If \code{TRUE} (the default), group-level terms will be -#' modelled as correlated. -#' @param id Optional character string. All group-level terms across the model -#' with the same \code{id} will be modeled as correlated (if \code{cor} is -#' \code{TRUE}). See \code{\link{brmsformula}} for more details. -#' @param cov An optional matrix which is proportional to the withon-group -#' covariance matrix of the group-level effects. All levels of the grouping -#' factor should appear as rownames of the corresponding matrix. This argument -#' can be used, among others, to model pedigrees and phylogenetic effects. See -#' \code{vignette("brms_phylogenetics")} for more details. By default, levels -#' of the same grouping factor are modeled as independent of each other. -#' @param dist Name of the distribution of the group-level effects. -#' Currently \code{"gaussian"} is the only option. -#' -#' @seealso \code{\link{brmsformula}} -#' -#' @examples -#' \dontrun{ -#' # model using basic lme4-style formula -#' fit1 <- brm(count ~ Trt + (1|patient), data = epilepsy) -#' summary(fit1) -#' -#' # equivalent model using 'gr' which is called anyway internally -#' fit2 <- brm(count ~ Trt + (1|gr(patient)), data = epilepsy) -#' summary(fit2) -#' -#' # include Trt as a by variable -#' fit3 <- brm(count ~ Trt + (1|gr(patient, by = Trt)), data = epilepsy) -#' summary(fit3) -#' } -#' -#' @export -gr <- function(..., by = NULL, cor = TRUE, id = NA, - cov = NULL, dist = "gaussian") { - label <- deparse(match.call()) - groups <- as.character(as.list(substitute(list(...)))[-1]) - if (length(groups) > 1L) { - stop2("Grouping structure 'gr' expects only a single grouping term") - } - stopif_illegal_group(groups[1]) - cor <- as_one_logical(cor) - id <- as_one_character(id, allow_na = TRUE) - by <- substitute(by) - if (!is.null(by)) { - by <- deparse_combine(by) - } else { - by <- "" - } - cov <- substitute(cov) - if (!is.null(cov)) { - cov <- all.vars(cov) - if (length(cov) != 1L) { - stop2("Argument 'cov' must contain exactly one variable.") - } - } else { - cov <- "" - } - dist <- match.arg(dist, c("gaussian", "student")) - byvars <- all_vars(by) - allvars <- str2formula(c(groups, byvars)) - nlist(groups, allvars, label, by, cor, id, cov, dist, type = "") -} - -#' Set up multi-membership grouping terms in \pkg{brms} -#' -#' Function to set up a multi-membership grouping term in \pkg{brms}. -#' The function does not evaluate its arguments -- -#' it exists purely to help set up a model with grouping terms. -#' -#' @inheritParams gr -#' @param weights A matrix specifying the weights of each member. -#' It should have as many columns as grouping terms specified in \code{...}. -#' If \code{NULL} (the default), equally weights are used. -#' @param by An optional factor matrix, specifying sub-populations of the -#' groups. It should have as many columns as grouping terms specified in -#' \code{...}. For each level of the \code{by} variable, a separate -#' variance-covariance matrix will be fitted. Levels of the grouping factor -#' must be nested in levels of the \code{by} variable matrix. -#' @param scale Logical; if \code{TRUE} (the default), -#' weights are standardized in order to sum to one per row. -#' If negative weights are specified, \code{scale} needs -#' to be set to \code{FALSE}. -#' -#' @seealso \code{\link{brmsformula}}, \code{\link{mmc}} -#' -#' @examples -#' \dontrun{ -#' # simulate some data -#' dat <- data.frame( -#' y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), -#' g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) -#' ) -#' -#' # multi-membership model with two members per group and equal weights -#' fit1 <- brm(y ~ x1 + (1|mm(g1, g2)), data = dat) -#' summary(fit1) -#' -#' # weight the first member two times for than the second member -#' dat$w1 <- rep(2, 100) -#' dat$w2 <- rep(1, 100) -#' fit2 <- brm(y ~ x1 + (1|mm(g1, g2, weights = cbind(w1, w2))), data = dat) -#' summary(fit2) -#' -#' # multi-membership model with level specific covariate values -#' dat$xc <- (dat$x1 + dat$x2) / 2 -#' fit3 <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) -#' summary(fit3) -#' } -#' -#' @export -mm <- function(..., weights = NULL, scale = TRUE, by = NULL, cor = TRUE, - id = NA, cov = NULL, dist = "gaussian") { - label <- deparse(match.call()) - groups <- as.character(as.list(substitute(list(...)))[-1]) - if (length(groups) < 2) { - stop2("Multi-membership terms require at least two grouping variables.") - } - for (i in seq_along(groups)) { - stopif_illegal_group(groups[i]) - } - cor <- as_one_logical(cor) - id <- as_one_character(id, allow_na = TRUE) - by <- substitute(by) - if (!is.null(by)) { - by <- deparse_combine(by) - } else { - by <- "" - } - cov <- substitute(cov) - if (!is.null(cov)) { - cov <- all.vars(cov) - if (length(cov) != 1L) { - stop2("Argument 'cov' must contain exactly one variable.") - } - } else { - cov <- "" - } - dist <- match.arg(dist, c("gaussian", "student")) - scale <- as_one_logical(scale) - weights <- substitute(weights) - weightvars <- all_vars(weights) - byvars <- all_vars(by) - allvars <- str2formula(c(groups, weightvars, byvars)) - if (!is.null(weights)) { - weights <- str2formula(deparse_no_string(weights)) - attr(weights, "scale") <- scale - weightvars <- str2formula(weightvars) - } - nlist( - groups, weights, weightvars, allvars, label, - by, cor, id, cov, dist, type = "mm" - ) -} - -#' Multi-Membership Covariates -#' -#' Specify covariates that vary over different levels -#' of multi-membership grouping factors thus requiring -#' special treatment. This function is almost solely useful, -#' when called in combination with \code{\link{mm}}. -#' Outside of multi-membership terms it will behave -#' very much like \code{\link{cbind}}. -#' -#' @param ... One or more terms containing covariates -#' corresponding to the grouping levels specified in \code{\link{mm}}. -#' -#' @return A matrix with covariates as columns. -#' -#' @seealso \code{\link{mm}} -#' -#' @examples -#' \dontrun{ -#' # simulate some data -#' dat <- data.frame( -#' y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), -#' g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) -#' ) -#' -#' # multi-membership model with level specific covariate values -#' dat$xc <- (dat$x1 + dat$x2) / 2 -#' fit <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) -#' summary(fit) -#' } -#' -#' @export -mmc <- function(...) { - dots <- list(...) - if (any(ulapply(dots, is_like_factor))) { - stop2("'mmc' requires numeric variables.") - } - out <- cbind(...) - colnames(out) <- paste0("?", colnames(out)) - out -} - -# check if the group part of a group-level term is invalid -# @param group the group part of a group-level term -illegal_group_expr <- function(group) { - group <- as_one_character(group) - valid_expr <- ":|([^([:digit:]|[:punct:])]|\\.)[[:alnum:]_\\.]*" - rsv_signs <- c("+", "-", "*", "/", "|", "::") - nzchar(gsub(valid_expr, "", group)) || - any(ulapply(rsv_signs, grepl, x = group, fixed = TRUE)) -} - -stopif_illegal_group <- function(group) { - if (illegal_group_expr(group)) { - stop2( - "Illegal grouping term '", group, "'. It may contain ", - "only variable names combined by the symbol ':'" - ) - } - invisible(NULL) -} - -re_lhs <- function(re_terms) { - get_matches("^[^\\|]*", re_terms) -} - -re_mid <- function(re_terms) { - get_matches("\\|([^\\|]*\\||)", re_terms) -} - -re_rhs <- function(re_terms) { - sub("^\\|", "", get_matches("\\|[^\\|]*$", re_terms)) -} - -# extract the three parts of group-level terms -# @param re_terms character vector of RE terms in lme4 syntax -# @return a data.frame with one row per group-level term -re_parts <- function(re_terms) { - lhs <- re_lhs(re_terms) - mid <- re_mid(re_terms) - rhs <- re_rhs(re_terms) - out <- nlist(lhs, mid, rhs) - if (any(lengths(out) != length(re_terms))) { - stop2("Invalid syntax used in group-level terms.") - } - as.data.frame(out, stringsAsFactors = FALSE) -} - -# split nested group-level terms and check for special effects terms -# @param re_terms character vector of RE terms in extended lme4 syntax -split_re_terms <- function(re_terms) { - if (!length(re_terms)) { - return(re_terms) - } - stopifnot(is.character(re_terms)) - - # split after grouping factor terms - re_parts <- re_parts(re_terms) - new_re_terms <- vector("list", length(re_terms)) - for (i in seq_along(re_terms)) { - new_re_rhs <- terms(formula(paste0("~", re_parts$rhs[i]))) - new_re_rhs <- attr(new_re_rhs, "term.labels") - new_re_rhs <- ifelse( - !grepl("^(gr|mm)\\(", new_re_rhs), - paste0("gr(", new_re_rhs, ")"), new_re_rhs - ) - new_re_terms[[i]] <- paste0( - re_parts$lhs[i], re_parts$mid[i], new_re_rhs - ) - } - re_terms <- unlist(new_re_terms) - - # split after coefficient types - re_parts <- re_parts(re_terms) - new_re_terms <- type <- vector("list", length(re_terms)) - for (i in seq_along(re_terms)) { - lhs_form <- formula(paste("~", re_parts$lhs[i])) - lhs_all_terms <- all_terms(lhs_form) - # otherwise varying intercepts cannot be handled reliably - is_cs_term <- grepl_expr(regex_sp("cs"), lhs_all_terms) - if (any(is_cs_term) && !all(is_cs_term)) { - stop2("Please specify category specific effects ", - "in separate group-level terms.") - } - new_lhs <- NULL - # prepare effects of special terms - valid_types <- c("sp", "cs", "mmc") - invalid_types <- c("sm", "gp") - for (t in c(valid_types, invalid_types)) { - lhs_tform <- do_call(paste0("terms_", t), list(lhs_form)) - if (is.formula(lhs_tform)) { - if (t %in% invalid_types) { - stop2("Cannot handle splines or GPs in group-level terms.") - } - new_lhs <- c(new_lhs, formula2str(lhs_tform, rm = 1)) - type[[i]] <- c(type[[i]], t) - } - } - # prepare effects of basic terms - lhs_terms <- terms(lhs_form) - fe_form <- terms_fe(lhs_terms) - fe_terms <- all_terms(fe_form) - # the intercept lives within not outside of 'cs' terms - has_intercept <- has_intercept(lhs_terms) && !"cs" %in% type[[i]] - if (length(fe_terms) || has_intercept) { - new_lhs <- c(new_lhs, formula2str(fe_form, rm = 1)) - type[[i]] <- c(type[[i]], "") - } - # extract information from the mid section of the terms - rhs_call <- str2lang(re_parts$rhs[i]) - if (re_parts$mid[i] == "||") { - # ||-syntax overwrites the 'cor' argument - rhs_call$cor <- FALSE - } - gcall <- eval(rhs_call) - if (gcall$cor) { - id <- gsub("\\|", "", re_parts$mid[i]) - if (nzchar(id)) { - # ID-syntax overwrites the 'id' argument - rhs_call$id <- id - } else { - id <- gcall$id - } - if (length(new_lhs) > 1 && isNA(id)) { - # ID is required to model coefficients as correlated - # if multiple types are provided within the same term - rhs_call$id <- collapse(sample(0:9, 10, TRUE)) - } - } - re_parts$mid[i] <- "|" - re_parts$rhs[i] <- deparse_combine(rhs_call) - new_re_terms[[i]] <- paste0(new_lhs, re_parts$mid[i], re_parts$rhs[i]) - new_re_terms[[i]] <- new_re_terms[[i]][order(type[[i]])] - type[[i]] <- sort(type[[i]]) - } - re_terms <- unlist(new_re_terms) - structure(re_terms, type = unlist(type)) -} - -# extract group-level terms from a formula of character vector -# @param x formula or character vector -# @param formula return a formula rather than a character string? -# @param brackets include group-level terms in brackets? -get_re_terms <- function(x, formula = FALSE, brackets = TRUE) { - if (is.formula(x)) { - x <- all_terms(x) - } - re_pos <- grepl("\\|", x) - out <- x[re_pos] - if (brackets && length(out)) { - out <- paste0("(", out, ")") - } - if (formula) { - out <- str2formula(out) - } - out -} - -# validate the re_formula argument -# @inheritParams extract_draws.brmsfit -# @param formula: formula to match re_formula with -# @return updated re_formula containing only terms existent in formula -check_re_formula <- function(re_formula, formula) { - old_re_formula <- get_re_terms(formula, formula = TRUE) - if (is.null(re_formula)) { - re_formula <- old_re_formula - } else if (SW(anyNA(re_formula))) { - re_formula <- ~1 - } else { - re_formula <- get_re_terms(as.formula(re_formula), formula = TRUE) - new <- brmsterms(re_formula, check_response = FALSE)$dpars$mu[["re"]] - old <- brmsterms(old_re_formula, check_response = FALSE)$dpars$mu[["re"]] - if (NROW(new) && NROW(old)) { - # compare old and new ranefs - new_terms <- lapply(new$form, terms) - found <- rep(FALSE, NROW(new)) - for (i in seq_rows(new)) { - group <- new$group[[i]] - old_terms <- lapply(old$form[old$group == group], terms) - j <- 1 - while (!found[i] && j <= length(old_terms)) { - new_term_labels <- attr(new_terms[[i]], "term.labels") - old_term_labels <- attr(old_terms[[j]], "term.labels") - new_intercept <- attr(new_terms[[i]], "intercept") - old_intercept <- attr(old_terms[[j]], "intercept") - found[i] <- isTRUE( - all(new_term_labels %in% old_term_labels) && - new_intercept <= old_intercept - ) - if (found[i]) { - # terms have to maintain the original order so that Z_* data - # and r_* parameters match in 'extract_draws' (fixes issue #844) - term_matches <- match(new_term_labels, old_term_labels) - if (is.unsorted(term_matches)) { - stop2("Order of terms in 're_formula' should match the original order.") - } - } - j <- j + 1 - } - } - new <- new[found, ] - if (NROW(new)) { - forms <- ulapply(new$form, formula2str, rm = 1) - groups <- ulapply(new$gcall, "[[", "label") - re_terms <- paste("(", forms, "|", groups, ")") - re_formula <- formula(paste("~", paste(re_terms, collapse = "+"))) - } else { - re_formula <- ~1 - } - } else { - re_formula <- ~1 - } - } - re_formula -} - -# remove existing group-level terms in formula and -# add valid group-level terms of re_formula -update_re_terms <- function(formula, re_formula) { - UseMethod("update_re_terms") -} - -#' @export -update_re_terms.mvbrmsformula <- function(formula, re_formula) { - formula$forms <- lapply(formula$forms, update_re_terms, re_formula) - formula -} - -#' @export -update_re_terms.brmsformula <- function(formula, re_formula) { - formula$formula <- update_re_terms(formula$formula, re_formula) - formula$pforms <- lapply(formula$pforms, update_re_terms, re_formula) - formula -} - -#' @export -update_re_terms.formula <- function(formula, re_formula = NULL) { - if (is.null(re_formula) || get_nl(formula)) { - return(formula) - } - re_formula <- check_re_formula(re_formula, formula) - new_formula <- formula2str(formula) - old_re_terms <- get_re_terms(formula, brackets = FALSE) - if (length(old_re_terms)) { - # remove old group-level terms - rm_terms <- c( - paste0("+ (", old_re_terms, ")"), - paste0("(", old_re_terms, ")"), - old_re_terms - ) - new_formula <- rename(new_formula, rm_terms, "") - if (grepl("~( *\\+*)*$", new_formula)) { - # lhs only formulas are syntactically invalid - # also check for trailing '+' signs (#769) - new_formula <- paste(new_formula, "1") - } - } - # add new group-level terms - new_re_terms <- get_re_terms(re_formula) - new_formula <- paste(c(new_formula, new_re_terms), collapse = "+") - new_formula <- formula(new_formula) - attributes(new_formula) <- attributes(formula) - new_formula -} - -# extract group-level terms -get_re <- function(x, ...) { - UseMethod("get_re") -} - -#' @export -get_re.default <- function(x, ...) { - NULL -} - -# get group-level information in a data.frame -# @param bterms object of class 'brmsterms' -# @param all logical; include ranefs of additional parameters? -#' @export -get_re.brmsterms <- function(x, ...) { - re <- named_list(c(names(x$dpars), names(x$nlpars))) - for (dp in names(x$dpars)) { - re[[dp]] <- get_re(x$dpars[[dp]]) - } - for (nlp in names(x$nlpars)) { - re[[nlp]] <- get_re(x$nlpars[[nlp]]) - } - do_call(rbind, re) -} - -#' @export -get_re.mvbrmsterms <- function(x, ...) { - do_call(rbind, lapply(x$terms, get_re, ...)) -} - -#' @export -get_re.btl <- function(x, ...) { - px <- check_prefix(x) - re <- x[["re"]] - if (is.null(re)) { - re <- empty_re() - } - re$resp <- rep(px$resp, nrow(re)) - re$dpar <- rep(px$dpar, nrow(re)) - re$nlpar <- rep(px$nlpar, nrow(re)) - re -} - -# gather information on group-level effects -# @param bterms object of class brmsterms -# @param data data.frame containing all model variables -# @param old_levels optional original levels of the grouping factors -# @return a tidy data.frame with the following columns: -# id: ID of the group-level effect -# group: name of the grouping factor -# gn: number of the grouping term within the respective formula -# coef: name of the group-level effect -# cn: number of the effect within the ID -# resp: name of the response variable -# dpar: name of the distributional parameter -# nlpar: name of the non-linear parameter -# cor: are correlations modeled for this effect? -# ggn: global number of the grouping factor -# type: special effects type; can be 'sp' or 'cs' -# gcall: output of functions 'gr' or 'mm' -# form: formula used to compute the effects -tidy_ranef <- function(bterms, data, old_levels = NULL) { - data <- combine_groups(data, get_group_vars(bterms)) - re <- get_re(bterms) - ranef <- vector("list", nrow(re)) - used_ids <- new_ids <- NULL - id_groups <- list() - j <- 1 - for (i in seq_rows(re)) { - if (!nzchar(re$type[i])) { - coef <- colnames(get_model_matrix(re$form[[i]], data)) - } else if (re$type[i] == "sp") { - coef <- tidy_spef(re$form[[i]], data)$coef - } else if (re$type[i] == "mmc") { - coef <- rename(all_terms(re$form[[i]])) - } else if (re$type[i] == "cs") { - resp <- re$resp[i] - if (nzchar(resp)) { - stopifnot(is.mvbrmsterms(bterms)) - nthres <- max(get_thres(bterms$terms[[resp]])) - } else { - stopifnot(is.brmsterms(bterms)) - nthres <- max(get_thres(bterms)) - } - indices <- paste0("[", seq_len(nthres), "]") - coef <- colnames(get_model_matrix(re$form[[i]], data = data)) - coef <- as.vector(t(outer(coef, indices, paste0))) - } - avoid_dpars(coef, bterms = bterms) - rdat <- data.frame( - id = re$id[[i]], - group = re$group[[i]], - gn = re$gn[[i]], - gtype = re$gtype[[i]], - coef = coef, - cn = NA, - resp = re$resp[[i]], - dpar = re$dpar[[i]], - nlpar = re$nlpar[[i]], - ggn = NA, - cor = re$cor[[i]], - type = re$type[[i]], - by = re$gcall[[i]]$by, - cov = re$gcall[[i]]$cov, - dist = re$gcall[[i]]$dist, - stringsAsFactors = FALSE - ) - bylevels <- NULL - if (nzchar(rdat$by[1])) { - bylevels <- eval2(rdat$by[1], data) - bylevels <- rm_wsp(levels(factor(bylevels))) - } - rdat$bylevels <- repl(bylevels, nrow(rdat)) - rdat$form <- repl(re$form[[i]], nrow(rdat)) - rdat$gcall <- repl(re$gcall[[i]], nrow(rdat)) - # prepare group-level IDs - id <- re$id[[i]] - if (is.na(id)) { - rdat$id <- j - j <- j + 1 - } else { - if (id %in% used_ids) { - k <- match(id, used_ids) - rdat$id <- new_ids[k] - new_id_groups <- c(re$group[[i]], re$gcall[[i]]$groups) - if (!identical(new_id_groups, id_groups[[k]])) { - stop2("Can only combine group-level terms of the ", - "same grouping factors.") - } - } else { - used_ids <- c(used_ids, id) - k <- length(used_ids) - rdat$id <- new_ids[k] <- j - id_groups[[k]] <- c(re$group[[i]], re$gcall[[i]]$groups) - j <- j + 1 - } - } - ranef[[i]] <- rdat - } - ranef <- do_call(rbind, c(list(empty_ranef()), ranef)) - # check for overlap between different group types - rsv_groups <- ranef[nzchar(ranef$gtype), "group"] - other_groups <- ranef[!nzchar(ranef$gtype), "group"] - inv_groups <- intersect(rsv_groups, other_groups) - if (length(inv_groups)) { - inv_groups <- paste0("'", inv_groups, "'", collapse = ", ") - stop2("Grouping factor names ", inv_groups, " are resevered.") - } - # check for duplicated and thus not identified effects - dup <- duplicated(ranef[, c("group", "coef", vars_prefix())]) - if (any(dup)) { - dr <- ranef[which(dup)[1], ] - stop2( - "Duplicated group-level effects are not allowed.\n", - "Occured for effect '", dr$coef, "' of group '", dr$group, "'." - ) - } - if (nrow(ranef)) { - for (id in unique(ranef$id)) { - ranef$cn[ranef$id == id] <- seq_len(sum(ranef$id == id)) - } - ranef$ggn <- match(ranef$group, unique(ranef$group)) - if (is.null(old_levels)) { - rsub <- ranef[!duplicated(ranef$group), ] - levels <- named_list(rsub$group) - for (i in seq_along(levels)) { - # combine levels of all grouping factors within one grouping term - levels[[i]] <- unique(ulapply( - rsub$gcall[[i]]$groups, - function(g) levels(factor(get(g, data))) - )) - # store information of corresponding by levels - if (nzchar(rsub$by[i])) { - stopifnot(rsub$type[i] %in% c("", "mmc")) - by <- rsub$by[i] - bylevels <- rsub$bylevels[[i]] - byvar <- rm_wsp(eval2(by, data)) - groups <- rsub$gcall[[i]]$groups - if (rsub$gtype[i] == "mm") { - byvar <- as.matrix(byvar) - if (!identical(dim(byvar), c(nrow(data), length(groups)))) { - stop2( - "Grouping structure 'mm' expects 'by' to be ", - "a matrix with as many columns as grouping factors." - ) - } - df <- J <- named_list(groups) - for (k in seq_along(groups)) { - J[[k]] <- match(get(groups[k], data), levels[[i]]) - df[[k]] <- data.frame(J = J[[k]], by = byvar[, k]) - } - J <- unlist(J) - df <- do_call(rbind, df) - } else { - J <- match(get(groups, data), levels[[i]]) - df <- data.frame(J = J, by = byvar) - } - df <- unique(df) - if (nrow(df) > length(unique(J))) { - stop2("Some levels of ", collapse_comma(groups), - " correspond to multiple levels of '", by, "'.") - } - df <- df[order(df$J), ] - by_per_level <- bylevels[match(df$by, bylevels)] - attr(levels[[i]], "by") <- by_per_level - } - } - attr(ranef, "levels") <- levels - } else { - # for newdata numeration has to depend on the original levels - attr(ranef, "levels") <- old_levels - } - # incorporate deprecated 'cov_ranef' argument - ranef <- update_ranef_cov(ranef, bterms) - } - # ordering after IDs matches the order of the posterior draws - # if multiple IDs are used for the same grouping factor (#835) - ranef <- ranef[order(ranef$id), , drop = FALSE] - structure(ranef, class = c("ranef_frame", "data.frame")) -} - -empty_ranef <- function() { - structure( - data.frame( - id = numeric(0), group = character(0), gn = numeric(0), - coef = character(0), cn = numeric(0), resp = character(0), - dpar = character(0), nlpar = character(0), ggn = numeric(0), - cor = logical(0), type = character(0), form = character(0), - stringsAsFactors = FALSE - ), - class = c("ranef_frame", "data.frame") - ) -} - -empty_re <- function() { - data.frame( - group = character(0), gtype = character(0), - gn = numeric(0), id = numeric(0), type = character(0), - cor = logical(0), form = character(0) - ) -} - -is.ranef_frame <- function(x) { - inherits(x, "ranef_frame") -} - -# extract names of all grouping variables -get_group_vars <- function(x, ...) { - UseMethod("get_group_vars") -} - -#' @export -get_group_vars.brmsfit <- function(x, ...) { - get_group_vars(x$formula, ...) -} - -#' @export -get_group_vars.default <- function(x, ...) { - get_group_vars(brmsterms(x), ...) -} - -#' @export -get_group_vars.brmsterms <- function(x, ...) { - .get_group_vars(x, ...) -} - -#' @export -get_group_vars.mvbrmsterms <- function(x, ...) { - .get_group_vars(x, ...) -} - -.get_group_vars <- function(x, ...) { - out <- c(get_re_groups(x), get_me_groups(x), get_ac_groups(x)) - out <- out[nzchar(out)] - if (length(out)) { - c(out) <- unlist(strsplit(out, ":")) - out <- sort(unique(out)) - } - out -} - -# get names of grouping variables of re terms -get_re_groups <- function(x, ...) { - ulapply(get_re(x)$gcall, "[[", "groups") -} - -# extract information about groups with a certain distribution -get_dist_groups <- function(ranef, dist) { - out <- subset2(ranef, dist = dist) - out[!duplicated(out$group), c("group", "ggn", "id")] -} - -# extract list of levels with one element per grouping factor -# @param ... objects with a level attribute -get_levels <- function(...) { - dots <- list(...) - out <- vector("list", length(dots)) - for (i in seq_along(out)) { - levels <- attr(dots[[i]], "levels", exact = TRUE) - if (is.list(levels)) { - stopifnot(!is.null(names(levels))) - out[[i]] <- as.list(levels) - } else if (!is.null(levels)) { - stopifnot(isTRUE(nzchar(names(dots)[i]))) - out[[i]] <- setNames(list(levels), names(dots)[[i]]) - } - } - out <- unlist(out, recursive = FALSE) - out[!duplicated(names(out))] -} - -# extract names of group-level effects -# @param ranef output of tidy_ranef() -# @param group optinal name of a grouping factor for -# which to extract effect names -# @param bylevels optional names of 'by' levels for -# which to extract effect names -# @return a vector of character strings -get_rnames <- function(ranef, group = NULL, bylevels = NULL) { - stopifnot(is.data.frame(ranef)) - if (!is.null(group)) { - group <- as_one_character(group) - ranef <- subset2(ranef, group = group) - } - stopifnot(length(unique(ranef$group)) == 1L) - out <- paste0(usc(combine_prefix(ranef), "suffix"), ranef$coef) - if (isTRUE(nzchar(ranef$by[1]))) { - if (!is.null(bylevels)) { - stopifnot(all(bylevels %in% ranef$bylevels[[1]])) - } else { - bylevels <- ranef$bylevels[[1]] - } - bylabels <- paste0(ranef$by[1], bylevels) - out <- outer(out, bylabels, paste, sep = ":") - } - out -} - -# validate within-group covariance matrices -# @param M a matrix to be validated -validate_recov_matrix <- function(M) { - M <- as.matrix(M) - if (!isSymmetric(unname(M))) { - stop2("Within-group covariance matrices must be symmetric.") - } - found_levels <- rownames(M) - if (is.null(found_levels)) { - found_levels <- colnames(M) - } - if (is.null(found_levels)) { - stop2("Row or column names are required for within-group covariance matrices.") - } - rownames(M) <- colnames(M) <- found_levels - evs <- eigen(M, symmetric = TRUE, only.values = TRUE)$values - if (min(evs) <= 0) { - stop2("Within-group covariance matrices must be positive definite.") - } - M -} - -# check validity of the 'cov_ranef' argument -# argument 'cov_ranef' is deprecated as of version 2.12.5 -validate_cov_ranef <- function(cov_ranef) { - if (is.null(cov_ranef)) { - return(cov_ranef) - } - warning2( - "Argument 'cov_ranef' is deprecated and will be removed in the future. ", - "Please use argument 'cov' in function 'gr' instead." - ) - cr_names <- names(cov_ranef) - cr_is_named <- length(cr_names) && all(nzchar(cr_names)) - if (!is.list(cov_ranef) || !cr_is_named) { - stop2("'cov_ranef' must be a named list.") - } - if (any(duplicated(cr_names))) { - stop2("Names of 'cov_ranef' must be unique.") - } - cov_ranef -} - -# update 'ranef' according to information in 'cov_ranef' -# argument 'cov_ranef' is deprecated as of version 2.12.5 -update_ranef_cov <- function(ranef, bterms) { - cr_names <- names(bterms$cov_ranef) - if (!length(cr_names)) { - return(ranef) - } - unused_names <- setdiff(cr_names, ranef$group) - if (length(unused_names)) { - stop2("The following elements of 'cov_ranef' are unused: ", - collapse_comma(unused_names)) - } - has_cov <- ranef$group %in% cr_names - ranef$cov[has_cov] <- ranef$group[has_cov] - ranef -} - -# extract 'cov_ranef' for storage in 'data2' -# @param x a list-like object -get_data2_cov_ranef <- function(x) { - x[["cov_ranef"]] -} +# This file contains functions dealing with the extended +# lme4-like formula syntax to specify group-level terms + +#' Set up basic grouping terms in \pkg{brms} +#' +#' Function used to set up a basic grouping term in \pkg{brms}. +#' The function does not evaluate its arguments -- +#' it exists purely to help set up a model with grouping terms. +#' \code{gr} is called implicitly inside the package +#' and there is usually no need to call it directly. +#' +#' @param ... One or more terms containing grouping factors. +#' @param by An optional factor variable, specifying sub-populations of the +#' groups. For each level of the \code{by} variable, a separate +#' variance-covariance matrix will be fitted. Levels of the grouping factor +#' must be nested in levels of the \code{by} variable. +#' @param cor Logical. If \code{TRUE} (the default), group-level terms will be +#' modelled as correlated. +#' @param id Optional character string. All group-level terms across the model +#' with the same \code{id} will be modeled as correlated (if \code{cor} is +#' \code{TRUE}). See \code{\link{brmsformula}} for more details. +#' @param cov An optional matrix which is proportional to the withon-group +#' covariance matrix of the group-level effects. All levels of the grouping +#' factor should appear as rownames of the corresponding matrix. This argument +#' can be used, among others, to model pedigrees and phylogenetic effects. See +#' \code{vignette("brms_phylogenetics")} for more details. By default, levels +#' of the same grouping factor are modeled as independent of each other. +#' @param dist Name of the distribution of the group-level effects. +#' Currently \code{"gaussian"} is the only option. +#' +#' @seealso \code{\link{brmsformula}} +#' +#' @examples +#' \dontrun{ +#' # model using basic lme4-style formula +#' fit1 <- brm(count ~ Trt + (1|patient), data = epilepsy) +#' summary(fit1) +#' +#' # equivalent model using 'gr' which is called anyway internally +#' fit2 <- brm(count ~ Trt + (1|gr(patient)), data = epilepsy) +#' summary(fit2) +#' +#' # include Trt as a by variable +#' fit3 <- brm(count ~ Trt + (1|gr(patient, by = Trt)), data = epilepsy) +#' summary(fit3) +#' } +#' +#' @export +gr <- function(..., by = NULL, cor = TRUE, id = NA, + cov = NULL, dist = "gaussian") { + label <- deparse(match.call()) + groups <- as.character(as.list(substitute(list(...)))[-1]) + if (length(groups) > 1L) { + stop2("Grouping structure 'gr' expects only a single grouping term") + } + stopif_illegal_group(groups[1]) + cor <- as_one_logical(cor) + id <- as_one_character(id, allow_na = TRUE) + by <- substitute(by) + if (!is.null(by)) { + by <- deparse_combine(by) + } else { + by <- "" + } + cov <- substitute(cov) + if (!is.null(cov)) { + cov <- all.vars(cov) + if (length(cov) != 1L) { + stop2("Argument 'cov' must contain exactly one variable.") + } + } else { + cov <- "" + } + dist <- match.arg(dist, c("gaussian", "student")) + byvars <- all_vars(by) + allvars <- str2formula(c(groups, byvars)) + nlist(groups, allvars, label, by, cor, id, cov, dist, type = "") +} + +#' Set up multi-membership grouping terms in \pkg{brms} +#' +#' Function to set up a multi-membership grouping term in \pkg{brms}. +#' The function does not evaluate its arguments -- +#' it exists purely to help set up a model with grouping terms. +#' +#' @inheritParams gr +#' @param weights A matrix specifying the weights of each member. +#' It should have as many columns as grouping terms specified in \code{...}. +#' If \code{NULL} (the default), equally weights are used. +#' @param by An optional factor matrix, specifying sub-populations of the +#' groups. It should have as many columns as grouping terms specified in +#' \code{...}. For each level of the \code{by} variable, a separate +#' variance-covariance matrix will be fitted. Levels of the grouping factor +#' must be nested in levels of the \code{by} variable matrix. +#' @param scale Logical; if \code{TRUE} (the default), +#' weights are standardized in order to sum to one per row. +#' If negative weights are specified, \code{scale} needs +#' to be set to \code{FALSE}. +#' +#' @seealso \code{\link{brmsformula}}, \code{\link{mmc}} +#' +#' @examples +#' \dontrun{ +#' # simulate some data +#' dat <- data.frame( +#' y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), +#' g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) +#' ) +#' +#' # multi-membership model with two members per group and equal weights +#' fit1 <- brm(y ~ x1 + (1|mm(g1, g2)), data = dat) +#' summary(fit1) +#' +#' # weight the first member two times for than the second member +#' dat$w1 <- rep(2, 100) +#' dat$w2 <- rep(1, 100) +#' fit2 <- brm(y ~ x1 + (1|mm(g1, g2, weights = cbind(w1, w2))), data = dat) +#' summary(fit2) +#' +#' # multi-membership model with level specific covariate values +#' dat$xc <- (dat$x1 + dat$x2) / 2 +#' fit3 <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) +#' summary(fit3) +#' } +#' +#' @export +mm <- function(..., weights = NULL, scale = TRUE, by = NULL, cor = TRUE, + id = NA, cov = NULL, dist = "gaussian") { + label <- deparse(match.call()) + groups <- as.character(as.list(substitute(list(...)))[-1]) + if (length(groups) < 2) { + stop2("Multi-membership terms require at least two grouping variables.") + } + for (i in seq_along(groups)) { + stopif_illegal_group(groups[i]) + } + cor <- as_one_logical(cor) + id <- as_one_character(id, allow_na = TRUE) + by <- substitute(by) + if (!is.null(by)) { + by <- deparse_combine(by) + } else { + by <- "" + } + cov <- substitute(cov) + if (!is.null(cov)) { + cov <- all.vars(cov) + if (length(cov) != 1L) { + stop2("Argument 'cov' must contain exactly one variable.") + } + } else { + cov <- "" + } + dist <- match.arg(dist, c("gaussian", "student")) + scale <- as_one_logical(scale) + weights <- substitute(weights) + weightvars <- all_vars(weights) + byvars <- all_vars(by) + allvars <- str2formula(c(groups, weightvars, byvars)) + if (!is.null(weights)) { + weights <- str2formula(deparse_no_string(weights)) + attr(weights, "scale") <- scale + weightvars <- str2formula(weightvars) + } + nlist( + groups, weights, weightvars, allvars, label, + by, cor, id, cov, dist, type = "mm" + ) +} + +#' Multi-Membership Covariates +#' +#' Specify covariates that vary over different levels +#' of multi-membership grouping factors thus requiring +#' special treatment. This function is almost solely useful, +#' when called in combination with \code{\link{mm}}. +#' Outside of multi-membership terms it will behave +#' very much like \code{\link{cbind}}. +#' +#' @param ... One or more terms containing covariates +#' corresponding to the grouping levels specified in \code{\link{mm}}. +#' +#' @return A matrix with covariates as columns. +#' +#' @seealso \code{\link{mm}} +#' +#' @examples +#' \dontrun{ +#' # simulate some data +#' dat <- data.frame( +#' y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), +#' g1 = sample(1:10, 100, TRUE), g2 = sample(1:10, 100, TRUE) +#' ) +#' +#' # multi-membership model with level specific covariate values +#' dat$xc <- (dat$x1 + dat$x2) / 2 +#' fit <- brm(y ~ xc + (1 + mmc(x1, x2) | mm(g1, g2)), data = dat) +#' summary(fit) +#' } +#' +#' @export +mmc <- function(...) { + dots <- list(...) + if (any(ulapply(dots, is_like_factor))) { + stop2("'mmc' requires numeric variables.") + } + out <- cbind(...) + colnames(out) <- paste0("?", colnames(out)) + out +} + +# check if the group part of a group-level term is invalid +# @param group the group part of a group-level term +illegal_group_expr <- function(group) { + group <- as_one_character(group) + valid_expr <- ":|([^([:digit:]|[:punct:])]|\\.)[[:alnum:]_\\.]*" + rsv_signs <- c("+", "-", "*", "/", "|", "::") + nzchar(gsub(valid_expr, "", group)) || + any(ulapply(rsv_signs, grepl, x = group, fixed = TRUE)) +} + +stopif_illegal_group <- function(group) { + if (illegal_group_expr(group)) { + stop2( + "Illegal grouping term '", group, "'. It may contain ", + "only variable names combined by the symbol ':'" + ) + } + invisible(NULL) +} + +re_lhs <- function(re_terms) { + get_matches("^[^\\|]*", re_terms) +} + +re_mid <- function(re_terms) { + get_matches("\\|([^\\|]*\\||)", re_terms) +} + +re_rhs <- function(re_terms) { + sub("^\\|", "", get_matches("\\|[^\\|]*$", re_terms)) +} + +# extract the three parts of group-level terms +# @param re_terms character vector of RE terms in lme4 syntax +# @return a data.frame with one row per group-level term +re_parts <- function(re_terms) { + lhs <- re_lhs(re_terms) + mid <- re_mid(re_terms) + rhs <- re_rhs(re_terms) + out <- nlist(lhs, mid, rhs) + if (any(lengths(out) != length(re_terms))) { + stop2("Invalid syntax used in group-level terms.") + } + as.data.frame(out, stringsAsFactors = FALSE) +} + +# split nested group-level terms and check for special effects terms +# @param re_terms character vector of RE terms in extended lme4 syntax +split_re_terms <- function(re_terms) { + if (!length(re_terms)) { + return(re_terms) + } + stopifnot(is.character(re_terms)) + + # split after grouping factor terms + re_parts <- re_parts(re_terms) + new_re_terms <- vector("list", length(re_terms)) + for (i in seq_along(re_terms)) { + new_re_rhs <- terms(formula(paste0("~", re_parts$rhs[i]))) + new_re_rhs <- attr(new_re_rhs, "term.labels") + new_re_rhs <- ifelse( + !grepl("^(gr|mm)\\(", new_re_rhs), + paste0("gr(", new_re_rhs, ")"), new_re_rhs + ) + new_re_terms[[i]] <- paste0( + re_parts$lhs[i], re_parts$mid[i], new_re_rhs + ) + } + re_terms <- unlist(new_re_terms) + + # split after coefficient types + re_parts <- re_parts(re_terms) + new_re_terms <- type <- vector("list", length(re_terms)) + for (i in seq_along(re_terms)) { + lhs_form <- formula(paste("~", re_parts$lhs[i])) + lhs_all_terms <- all_terms(lhs_form) + # otherwise varying intercepts cannot be handled reliably + is_cs_term <- grepl_expr(regex_sp("cs"), lhs_all_terms) + if (any(is_cs_term) && !all(is_cs_term)) { + stop2("Please specify category specific effects ", + "in separate group-level terms.") + } + new_lhs <- NULL + # prepare effects of special terms + valid_types <- c("sp", "cs", "mmc") + invalid_types <- c("sm", "gp") + for (t in c(valid_types, invalid_types)) { + lhs_tform <- do_call(paste0("terms_", t), list(lhs_form)) + if (is.formula(lhs_tform)) { + if (t %in% invalid_types) { + stop2("Cannot handle splines or GPs in group-level terms.") + } + new_lhs <- c(new_lhs, formula2str(lhs_tform, rm = 1)) + type[[i]] <- c(type[[i]], t) + } + } + # prepare effects of basic terms + lhs_terms <- terms(lhs_form) + fe_form <- terms_fe(lhs_terms) + fe_terms <- all_terms(fe_form) + # the intercept lives within not outside of 'cs' terms + has_intercept <- has_intercept(lhs_terms) && !"cs" %in% type[[i]] + if (length(fe_terms) || has_intercept) { + new_lhs <- c(new_lhs, formula2str(fe_form, rm = 1)) + type[[i]] <- c(type[[i]], "") + } + # extract information from the mid section of the terms + rhs_call <- str2lang(re_parts$rhs[i]) + if (re_parts$mid[i] == "||") { + # ||-syntax overwrites the 'cor' argument + rhs_call$cor <- FALSE + } + gcall <- eval(rhs_call) + if (gcall$cor) { + id <- gsub("\\|", "", re_parts$mid[i]) + if (nzchar(id)) { + # ID-syntax overwrites the 'id' argument + rhs_call$id <- id + } else { + id <- gcall$id + } + if (length(new_lhs) > 1 && isNA(id)) { + # ID is required to model coefficients as correlated + # if multiple types are provided within the same term + rhs_call$id <- collapse(sample(0:9, 10, TRUE)) + } + } + re_parts$mid[i] <- "|" + re_parts$rhs[i] <- deparse_combine(rhs_call) + new_re_terms[[i]] <- paste0(new_lhs, re_parts$mid[i], re_parts$rhs[i]) + new_re_terms[[i]] <- new_re_terms[[i]][order(type[[i]])] + type[[i]] <- sort(type[[i]]) + } + re_terms <- unlist(new_re_terms) + structure(re_terms, type = unlist(type)) +} + +# extract group-level terms from a formula of character vector +# @param x formula or character vector +# @param formula return a formula rather than a character string? +# @param brackets include group-level terms in brackets? +get_re_terms <- function(x, formula = FALSE, brackets = TRUE) { + if (is.formula(x)) { + x <- all_terms(x) + } + re_pos <- grepl("\\|", x) + out <- x[re_pos] + if (brackets && length(out)) { + out <- paste0("(", out, ")") + } + if (formula) { + out <- str2formula(out) + } + out +} + +# validate the re_formula argument +# @inheritParams extract_draws.brmsfit +# @param formula: formula to match re_formula with +# @return updated re_formula containing only terms existent in formula +check_re_formula <- function(re_formula, formula) { + old_re_formula <- get_re_terms(formula, formula = TRUE) + if (is.null(re_formula)) { + re_formula <- old_re_formula + } else if (SW(anyNA(re_formula))) { + re_formula <- ~1 + } else { + re_formula <- get_re_terms(as.formula(re_formula), formula = TRUE) + new <- brmsterms(re_formula, check_response = FALSE)$dpars$mu[["re"]] + old <- brmsterms(old_re_formula, check_response = FALSE)$dpars$mu[["re"]] + if (NROW(new) && NROW(old)) { + # compare old and new ranefs + new_terms <- lapply(new$form, terms) + found <- rep(FALSE, NROW(new)) + for (i in seq_rows(new)) { + group <- new$group[[i]] + old_terms <- lapply(old$form[old$group == group], terms) + j <- 1 + while (!found[i] && j <= length(old_terms)) { + new_term_labels <- attr(new_terms[[i]], "term.labels") + old_term_labels <- attr(old_terms[[j]], "term.labels") + new_intercept <- attr(new_terms[[i]], "intercept") + old_intercept <- attr(old_terms[[j]], "intercept") + found[i] <- isTRUE( + all(new_term_labels %in% old_term_labels) && + new_intercept <= old_intercept + ) + if (found[i]) { + # terms have to maintain the original order so that Z_* data + # and r_* parameters match in 'extract_draws' (fixes issue #844) + term_matches <- match(new_term_labels, old_term_labels) + if (is.unsorted(term_matches)) { + stop2("Order of terms in 're_formula' should match the original order.") + } + } + j <- j + 1 + } + } + new <- new[found, ] + if (NROW(new)) { + forms <- ulapply(new$form, formula2str, rm = 1) + groups <- ulapply(new$gcall, "[[", "label") + re_terms <- paste("(", forms, "|", groups, ")") + re_formula <- formula(paste("~", paste(re_terms, collapse = "+"))) + } else { + re_formula <- ~1 + } + } else { + re_formula <- ~1 + } + } + re_formula +} + +# remove existing group-level terms in formula and +# add valid group-level terms of re_formula +update_re_terms <- function(formula, re_formula) { + UseMethod("update_re_terms") +} + +#' @export +update_re_terms.mvbrmsformula <- function(formula, re_formula) { + formula$forms <- lapply(formula$forms, update_re_terms, re_formula) + formula +} + +#' @export +update_re_terms.brmsformula <- function(formula, re_formula) { + formula$formula <- update_re_terms(formula$formula, re_formula) + formula$pforms <- lapply(formula$pforms, update_re_terms, re_formula) + formula +} + +#' @export +update_re_terms.formula <- function(formula, re_formula = NULL) { + if (is.null(re_formula) || get_nl(formula)) { + return(formula) + } + re_formula <- check_re_formula(re_formula, formula) + new_formula <- formula2str(formula) + old_re_terms <- get_re_terms(formula, brackets = FALSE) + if (length(old_re_terms)) { + # remove old group-level terms + rm_terms <- c( + paste0("+ (", old_re_terms, ")"), + paste0("(", old_re_terms, ")"), + old_re_terms + ) + new_formula <- rename(new_formula, rm_terms, "") + if (grepl("~( *\\+*)*$", new_formula)) { + # lhs only formulas are syntactically invalid + # also check for trailing '+' signs (#769) + new_formula <- paste(new_formula, "1") + } + } + # add new group-level terms + new_re_terms <- get_re_terms(re_formula) + new_formula <- paste(c(new_formula, new_re_terms), collapse = "+") + new_formula <- formula(new_formula) + attributes(new_formula) <- attributes(formula) + new_formula +} + +# extract group-level terms +get_re <- function(x, ...) { + UseMethod("get_re") +} + +#' @export +get_re.default <- function(x, ...) { + NULL +} + +# get group-level information in a data.frame +# @param bterms object of class 'brmsterms' +# @param all logical; include ranefs of additional parameters? +#' @export +get_re.brmsterms <- function(x, ...) { + re <- named_list(c(names(x$dpars), names(x$nlpars))) + for (dp in names(x$dpars)) { + re[[dp]] <- get_re(x$dpars[[dp]]) + } + for (nlp in names(x$nlpars)) { + re[[nlp]] <- get_re(x$nlpars[[nlp]]) + } + do_call(rbind, re) +} + +#' @export +get_re.mvbrmsterms <- function(x, ...) { + do_call(rbind, lapply(x$terms, get_re, ...)) +} + +#' @export +get_re.btl <- function(x, ...) { + px <- check_prefix(x) + re <- x[["re"]] + if (is.null(re)) { + re <- empty_re() + } + re$resp <- rep(px$resp, nrow(re)) + re$dpar <- rep(px$dpar, nrow(re)) + re$nlpar <- rep(px$nlpar, nrow(re)) + re +} + +# gather information on group-level effects +# @param bterms object of class brmsterms +# @param data data.frame containing all model variables +# @param old_levels optional original levels of the grouping factors +# @return a tidy data.frame with the following columns: +# id: ID of the group-level effect +# group: name of the grouping factor +# gn: number of the grouping term within the respective formula +# coef: name of the group-level effect +# cn: number of the effect within the ID +# resp: name of the response variable +# dpar: name of the distributional parameter +# nlpar: name of the non-linear parameter +# cor: are correlations modeled for this effect? +# ggn: global number of the grouping factor +# type: special effects type; can be 'sp' or 'cs' +# gcall: output of functions 'gr' or 'mm' +# form: formula used to compute the effects +tidy_ranef <- function(bterms, data, old_levels = NULL) { + data <- combine_groups(data, get_group_vars(bterms)) + re <- get_re(bterms) + ranef <- vector("list", nrow(re)) + used_ids <- new_ids <- NULL + id_groups <- list() + j <- 1 + for (i in seq_rows(re)) { + if (!nzchar(re$type[i])) { + coef <- colnames(get_model_matrix(re$form[[i]], data)) + } else if (re$type[i] == "sp") { + coef <- tidy_spef(re$form[[i]], data)$coef + } else if (re$type[i] == "mmc") { + coef <- rename(all_terms(re$form[[i]])) + } else if (re$type[i] == "cs") { + resp <- re$resp[i] + if (nzchar(resp)) { + stopifnot(is.mvbrmsterms(bterms)) + nthres <- max(get_thres(bterms$terms[[resp]])) + } else { + stopifnot(is.brmsterms(bterms)) + nthres <- max(get_thres(bterms)) + } + indices <- paste0("[", seq_len(nthres), "]") + coef <- colnames(get_model_matrix(re$form[[i]], data = data)) + coef <- as.vector(t(outer(coef, indices, paste0))) + } + avoid_dpars(coef, bterms = bterms) + rdat <- data.frame( + id = re$id[[i]], + group = re$group[[i]], + gn = re$gn[[i]], + gtype = re$gtype[[i]], + coef = coef, + cn = NA, + resp = re$resp[[i]], + dpar = re$dpar[[i]], + nlpar = re$nlpar[[i]], + ggn = NA, + cor = re$cor[[i]], + type = re$type[[i]], + by = re$gcall[[i]]$by, + cov = re$gcall[[i]]$cov, + dist = re$gcall[[i]]$dist, + stringsAsFactors = FALSE + ) + bylevels <- NULL + if (nzchar(rdat$by[1])) { + bylevels <- eval2(rdat$by[1], data) + bylevels <- rm_wsp(extract_levels(bylevels)) + } + rdat$bylevels <- repl(bylevels, nrow(rdat)) + rdat$form <- repl(re$form[[i]], nrow(rdat)) + rdat$gcall <- repl(re$gcall[[i]], nrow(rdat)) + # prepare group-level IDs + id <- re$id[[i]] + if (is.na(id)) { + rdat$id <- j + j <- j + 1 + } else { + if (id %in% used_ids) { + k <- match(id, used_ids) + rdat$id <- new_ids[k] + new_id_groups <- c(re$group[[i]], re$gcall[[i]]$groups) + if (!identical(new_id_groups, id_groups[[k]])) { + stop2("Can only combine group-level terms of the ", + "same grouping factors.") + } + } else { + used_ids <- c(used_ids, id) + k <- length(used_ids) + rdat$id <- new_ids[k] <- j + id_groups[[k]] <- c(re$group[[i]], re$gcall[[i]]$groups) + j <- j + 1 + } + } + ranef[[i]] <- rdat + } + ranef <- do_call(rbind, c(list(empty_ranef()), ranef)) + # check for overlap between different group types + rsv_groups <- ranef[nzchar(ranef$gtype), "group"] + other_groups <- ranef[!nzchar(ranef$gtype), "group"] + inv_groups <- intersect(rsv_groups, other_groups) + if (length(inv_groups)) { + inv_groups <- paste0("'", inv_groups, "'", collapse = ", ") + stop2("Grouping factor names ", inv_groups, " are resevered.") + } + # check for duplicated and thus not identified effects + dup <- duplicated(ranef[, c("group", "coef", vars_prefix())]) + if (any(dup)) { + dr <- ranef[which(dup)[1], ] + stop2( + "Duplicated group-level effects are not allowed.\n", + "Occured for effect '", dr$coef, "' of group '", dr$group, "'." + ) + } + if (nrow(ranef)) { + for (id in unique(ranef$id)) { + ranef$cn[ranef$id == id] <- seq_len(sum(ranef$id == id)) + } + ranef$ggn <- match(ranef$group, unique(ranef$group)) + if (is.null(old_levels)) { + rsub <- ranef[!duplicated(ranef$group), ] + levels <- named_list(rsub$group) + for (i in seq_along(levels)) { + # combine levels of all grouping factors within one grouping term + levels[[i]] <- unique(ulapply( + rsub$gcall[[i]]$groups, + function(g) extract_levels(get(g, data)) + )) + # store information of corresponding by levels + if (nzchar(rsub$by[i])) { + stopifnot(rsub$type[i] %in% c("", "mmc")) + by <- rsub$by[i] + bylevels <- rsub$bylevels[[i]] + byvar <- rm_wsp(eval2(by, data)) + groups <- rsub$gcall[[i]]$groups + if (rsub$gtype[i] == "mm") { + byvar <- as.matrix(byvar) + if (!identical(dim(byvar), c(nrow(data), length(groups)))) { + stop2( + "Grouping structure 'mm' expects 'by' to be ", + "a matrix with as many columns as grouping factors." + ) + } + df <- J <- named_list(groups) + for (k in seq_along(groups)) { + J[[k]] <- match(get(groups[k], data), levels[[i]]) + df[[k]] <- data.frame(J = J[[k]], by = byvar[, k]) + } + J <- unlist(J) + df <- do_call(rbind, df) + } else { + J <- match(get(groups, data), levels[[i]]) + df <- data.frame(J = J, by = byvar) + } + df <- unique(df) + if (nrow(df) > length(unique(J))) { + stop2("Some levels of ", collapse_comma(groups), + " correspond to multiple levels of '", by, "'.") + } + df <- df[order(df$J), ] + by_per_level <- bylevels[match(df$by, bylevels)] + attr(levels[[i]], "by") <- by_per_level + } + } + attr(ranef, "levels") <- levels + } else { + # for newdata numeration has to depend on the original levels + attr(ranef, "levels") <- old_levels + } + # incorporate deprecated 'cov_ranef' argument + ranef <- update_ranef_cov(ranef, bterms) + } + # ordering after IDs matches the order of the posterior draws + # if multiple IDs are used for the same grouping factor (#835) + ranef <- ranef[order(ranef$id), , drop = FALSE] + structure(ranef, class = c("ranef_frame", "data.frame")) +} + +empty_ranef <- function() { + structure( + data.frame( + id = numeric(0), group = character(0), gn = numeric(0), + coef = character(0), cn = numeric(0), resp = character(0), + dpar = character(0), nlpar = character(0), ggn = numeric(0), + cor = logical(0), type = character(0), form = character(0), + stringsAsFactors = FALSE + ), + class = c("ranef_frame", "data.frame") + ) +} + +empty_re <- function() { + data.frame( + group = character(0), gtype = character(0), + gn = numeric(0), id = numeric(0), type = character(0), + cor = logical(0), form = character(0) + ) +} + +is.ranef_frame <- function(x) { + inherits(x, "ranef_frame") +} + +# extract names of all grouping variables +get_group_vars <- function(x, ...) { + UseMethod("get_group_vars") +} + +#' @export +get_group_vars.brmsfit <- function(x, ...) { + get_group_vars(x$formula, ...) +} + +#' @export +get_group_vars.default <- function(x, ...) { + get_group_vars(brmsterms(x), ...) +} + +#' @export +get_group_vars.brmsterms <- function(x, ...) { + .get_group_vars(x, ...) +} + +#' @export +get_group_vars.mvbrmsterms <- function(x, ...) { + .get_group_vars(x, ...) +} + +.get_group_vars <- function(x, ...) { + out <- c(get_re_groups(x), get_me_groups(x), get_ac_groups(x)) + out <- out[nzchar(out)] + if (length(out)) { + c(out) <- unlist(strsplit(out, ":")) + out <- sort(unique(out)) + } + out +} + +# get names of grouping variables of re terms +get_re_groups <- function(x, ...) { + ulapply(get_re(x)$gcall, "[[", "groups") +} + +# extract information about groups with a certain distribution +get_dist_groups <- function(ranef, dist) { + out <- subset2(ranef, dist = dist) + out[!duplicated(out$group), c("group", "ggn", "id")] +} + +# extract list of levels with one element per grouping factor +# @param ... objects with a level attribute +get_levels <- function(...) { + dots <- list(...) + out <- vector("list", length(dots)) + for (i in seq_along(out)) { + levels <- attr(dots[[i]], "levels", exact = TRUE) + if (is.list(levels)) { + stopifnot(!is.null(names(levels))) + out[[i]] <- as.list(levels) + } else if (!is.null(levels)) { + stopifnot(isTRUE(nzchar(names(dots)[i]))) + out[[i]] <- setNames(list(levels), names(dots)[[i]]) + } + } + out <- unlist(out, recursive = FALSE) + out[!duplicated(names(out))] +} + +extract_levels <- function(x) { + if (anyNA(x)) { + stop2("NAs are not allowed in grouping variables.") + } + levels(factor(x)) +} + +# extract names of group-level effects +# @param ranef output of tidy_ranef() +# @param group optinal name of a grouping factor for +# which to extract effect names +# @param bylevels optional names of 'by' levels for +# which to extract effect names +# @return a vector of character strings +get_rnames <- function(ranef, group = NULL, bylevels = NULL) { + stopifnot(is.data.frame(ranef)) + if (!is.null(group)) { + group <- as_one_character(group) + ranef <- subset2(ranef, group = group) + } + stopifnot(length(unique(ranef$group)) == 1L) + out <- paste0(usc(combine_prefix(ranef), "suffix"), ranef$coef) + if (isTRUE(nzchar(ranef$by[1]))) { + if (!is.null(bylevels)) { + stopifnot(all(bylevels %in% ranef$bylevels[[1]])) + } else { + bylevels <- ranef$bylevels[[1]] + } + bylabels <- paste0(ranef$by[1], bylevels) + out <- outer(out, bylabels, paste, sep = ":") + } + out +} + +# validate within-group covariance matrices +# @param M a matrix to be validated +validate_recov_matrix <- function(M) { + M <- as.matrix(M) + if (!isSymmetric(unname(M))) { + stop2("Within-group covariance matrices must be symmetric.") + } + found_levels <- rownames(M) + if (is.null(found_levels)) { + found_levels <- colnames(M) + } + if (is.null(found_levels)) { + stop2("Row or column names are required for within-group covariance matrices.") + } + rownames(M) <- colnames(M) <- found_levels + evs <- eigen(M, symmetric = TRUE, only.values = TRUE)$values + if (min(evs) <= 0) { + stop2("Within-group covariance matrices must be positive definite.") + } + M +} + +# check validity of the 'cov_ranef' argument +# argument 'cov_ranef' is deprecated as of version 2.12.5 +validate_cov_ranef <- function(cov_ranef) { + if (is.null(cov_ranef)) { + return(cov_ranef) + } + warning2( + "Argument 'cov_ranef' is deprecated and will be removed in the future. ", + "Please use argument 'cov' in function 'gr' instead." + ) + cr_names <- names(cov_ranef) + cr_is_named <- length(cr_names) && all(nzchar(cr_names)) + if (!is.list(cov_ranef) || !cr_is_named) { + stop2("'cov_ranef' must be a named list.") + } + if (any(duplicated(cr_names))) { + stop2("Names of 'cov_ranef' must be unique.") + } + cov_ranef +} + +# update 'ranef' according to information in 'cov_ranef' +# argument 'cov_ranef' is deprecated as of version 2.12.5 +update_ranef_cov <- function(ranef, bterms) { + cr_names <- names(bterms$cov_ranef) + if (!length(cr_names)) { + return(ranef) + } + unused_names <- setdiff(cr_names, ranef$group) + if (length(unused_names)) { + stop2("The following elements of 'cov_ranef' are unused: ", + collapse_comma(unused_names)) + } + has_cov <- ranef$group %in% cr_names + ranef$cov[has_cov] <- ranef$group[has_cov] + ranef +} + +# extract 'cov_ranef' for storage in 'data2' +# @param x a list-like object +get_data2_cov_ranef <- function(x) { + x[["cov_ranef"]] +} diff -Nru r-cran-brms-2.16.3/R/formula-sm.R r-cran-brms-2.17.0/R/formula-sm.R --- r-cran-brms-2.16.3/R/formula-sm.R 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/R/formula-sm.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,101 +1,101 @@ -# This file contains functions dealing with the extended -# formula syntax to specify smooth terms via mgcv - -#' Defining smooths in \pkg{brms} formulas -#' -#' Functions used in definition of smooth terms within a model formulas. -#' The function does not evaluate a (spline) smooth - it exists purely -#' to help set up a model using spline based smooths. -#' -#' @param ... Arguments passed to \code{\link[mgcv:s]{mgcv::s}} or -#' \code{\link[mgcv:t2]{mgcv::t2}}. -#' -#' @details The function defined here are just simple wrappers -#' of the respective functions of the \pkg{mgcv} package. -#' -#' @seealso \code{\link{brmsformula}}, -#' \code{\link[mgcv:s]{mgcv::s}}, \code{\link[mgcv:t2]{mgcv::t2}} -#' -#' @examples -#' \dontrun{ -#' # simulate some data -#' dat <- mgcv::gamSim(1, n = 200, scale = 2) -#' -#' # fit univariate smooths for all predictors -#' fit1 <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), -#' data = dat, chains = 2) -#' summary(fit1) -#' plot(conditional_smooths(fit1), ask = FALSE) -#' -#' # fit a more complicated smooth model -#' fit2 <- brm(y ~ t2(x0, x1) + s(x2, by = x3), -#' data = dat, chains = 2) -#' summary(fit2) -#' plot(conditional_smooths(fit2), ask = FALSE) -#' } -#' -#' @export -s <- function(...) { - mgcv::s(...) -} - -#' @rdname s -#' @export -t2 <- function(...) { - mgcv::t2(...) -} - -# extract information about smooth terms -# @param x either a formula or a list containing an element "sm" -# @param data data.frame containing the covariates -tidy_smef <- function(x, data) { - if (is.formula(x)) { - x <- brmsterms(x, check_response = FALSE)$dpars$mu - } - form <- x[["sm"]] - if (!is.formula(form)) { - return(empty_data_frame()) - } - out <- data.frame(term = all_terms(form), stringsAsFactors = FALSE) - nterms <- nrow(out) - out$sfun <- get_matches("^[^\\(]+", out$term) - out$vars <- out$byvars <- out$covars <- vector("list", nterms) - for (i in seq_len(nterms)) { - sm <- eval2(out$term[i]) - out$covars[[i]] <- sm$term - if (sm$by != "NA") { - out$byvars[[i]] <- sm$by - } - out$vars[[i]] <- c(out$covars[[i]], out$byvars[[i]]) - } - out$label <- paste0(out$sfun, rename(ulapply(out$vars, collapse))) - # prepare information inferred from the data - sdata <- data_sm(x, data) - bylevels <- attr(sdata$Xs, "bylevels") - nby <- lengths(bylevels) - tmp <- vector("list", nterms) - for (i in seq_len(nterms)) { - tmp[[i]] <- out[i, , drop = FALSE] - tmp[[i]]$termnum <- i - if (nby[i] > 0L) { - tmp[[i]] <- do_call(rbind, repl(tmp[[i]], nby[i])) - tmp[[i]]$bylevel <- rm_wsp(bylevels[[i]]) - tmp[[i]]$byterm <- paste0(tmp[[i]]$term, tmp[[i]]$bylevel) - str_add(tmp[[i]]$label) <- rename(tmp[[i]]$bylevel) - } else { - tmp[[i]]$bylevel <- NA - tmp[[i]]$byterm <- tmp[[i]]$term - } - } - out <- do_call(rbind, tmp) - out$knots <- sdata[grepl("^knots_", names(sdata))] - out$nbases <- lengths(out$knots) - attr(out, "Xs_names") <- colnames(sdata$Xs) - rownames(out) <- NULL - out -} - -# check if smooths are present in the model -has_smooths <- function(bterms) { - length(get_effect(bterms, target = "sm")) > 0L -} +# This file contains functions dealing with the extended +# formula syntax to specify smooth terms via mgcv + +#' Defining smooths in \pkg{brms} formulas +#' +#' Functions used in definition of smooth terms within a model formulas. +#' The function does not evaluate a (spline) smooth - it exists purely +#' to help set up a model using spline based smooths. +#' +#' @param ... Arguments passed to \code{\link[mgcv:s]{mgcv::s}} or +#' \code{\link[mgcv:t2]{mgcv::t2}}. +#' +#' @details The function defined here are just simple wrappers +#' of the respective functions of the \pkg{mgcv} package. +#' +#' @seealso \code{\link{brmsformula}}, +#' \code{\link[mgcv:s]{mgcv::s}}, \code{\link[mgcv:t2]{mgcv::t2}} +#' +#' @examples +#' \dontrun{ +#' # simulate some data +#' dat <- mgcv::gamSim(1, n = 200, scale = 2) +#' +#' # fit univariate smooths for all predictors +#' fit1 <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), +#' data = dat, chains = 2) +#' summary(fit1) +#' plot(conditional_smooths(fit1), ask = FALSE) +#' +#' # fit a more complicated smooth model +#' fit2 <- brm(y ~ t2(x0, x1) + s(x2, by = x3), +#' data = dat, chains = 2) +#' summary(fit2) +#' plot(conditional_smooths(fit2), ask = FALSE) +#' } +#' +#' @export +s <- function(...) { + mgcv::s(...) +} + +#' @rdname s +#' @export +t2 <- function(...) { + mgcv::t2(...) +} + +# extract information about smooth terms +# @param x either a formula or a list containing an element "sm" +# @param data data.frame containing the covariates +tidy_smef <- function(x, data) { + if (is.formula(x)) { + x <- brmsterms(x, check_response = FALSE)$dpars$mu + } + form <- x[["sm"]] + if (!is.formula(form)) { + return(empty_data_frame()) + } + out <- data.frame(term = all_terms(form), stringsAsFactors = FALSE) + nterms <- nrow(out) + out$sfun <- get_matches("^[^\\(]+", out$term) + out$vars <- out$byvars <- out$covars <- vector("list", nterms) + for (i in seq_len(nterms)) { + sm <- eval2(out$term[i]) + out$covars[[i]] <- sm$term + if (sm$by != "NA") { + out$byvars[[i]] <- sm$by + } + out$vars[[i]] <- c(out$covars[[i]], out$byvars[[i]]) + } + out$label <- paste0(out$sfun, rename(ulapply(out$vars, collapse))) + # prepare information inferred from the data + sdata <- data_sm(x, data) + bylevels <- attr(sdata$Xs, "bylevels") + nby <- lengths(bylevels) + tmp <- vector("list", nterms) + for (i in seq_len(nterms)) { + tmp[[i]] <- out[i, , drop = FALSE] + tmp[[i]]$termnum <- i + if (nby[i] > 0L) { + tmp[[i]] <- do_call(rbind, repl(tmp[[i]], nby[i])) + tmp[[i]]$bylevel <- rm_wsp(bylevels[[i]]) + tmp[[i]]$byterm <- paste0(tmp[[i]]$term, tmp[[i]]$bylevel) + str_add(tmp[[i]]$label) <- rename(tmp[[i]]$bylevel) + } else { + tmp[[i]]$bylevel <- NA + tmp[[i]]$byterm <- tmp[[i]]$term + } + } + out <- do_call(rbind, tmp) + out$knots <- sdata[grepl("^knots_", names(sdata))] + out$nbases <- lengths(out$knots) + attr(out, "Xs_names") <- colnames(sdata$Xs) + rownames(out) <- NULL + out +} + +# check if smooths are present in the model +has_smooths <- function(bterms) { + length(get_effect(bterms, target = "sm")) > 0L +} diff -Nru r-cran-brms-2.16.3/R/formula-sp.R r-cran-brms-2.17.0/R/formula-sp.R --- r-cran-brms-2.16.3/R/formula-sp.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/formula-sp.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,621 +1,624 @@ -# This file contains functions dealing with the extended -# formula syntax to specify special effects terms - -#' Predictors with Measurement Error in \pkg{brms} Models -#' -#' (Soft deprecated) Specify predictors with measurement error. The function -#' does not evaluate its arguments -- it exists purely to help set up a model. -#' -#' @param x The variable measured with error. -#' @param sdx Known measurement error of \code{x} -#' treated as standard deviation. -#' @param gr Optional grouping factor to specify which -#' values of \code{x} correspond to the same value of the -#' latent variable. If \code{NULL} (the default) each -#' observation will have its own value of the latent variable. -#' -#' @details -#' For detailed documentation see \code{help(brmsformula)}. -#' \code{me} terms are soft deprecated in favor of the more -#' general and consistent \code{\link{mi}} terms. -#' By default, latent noise-free variables are assumed -#' to be correlated. To change that, add \code{set_mecor(FALSE)} -#' to your model formula object (see examples). -#' -#' @seealso -#' \code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} -#' -#' @examples -#' \dontrun{ -#' # sample some data -#' N <- 100 -#' dat <- data.frame( -#' y = rnorm(N), x1 = rnorm(N), -#' x2 = rnorm(N), sdx = abs(rnorm(N, 1)) -#' ) -#' # fit a simple error-in-variables model -#' fit1 <- brm(y ~ me(x1, sdx) + me(x2, sdx), data = dat, -#' save_pars = save_pars(latent = TRUE)) -#' summary(fit1) -#' -#' # turn off modeling of correlations -#' bform <- bf(y ~ me(x1, sdx) + me(x2, sdx)) + set_mecor(FALSE) -#' fit2 <- brm(bform, data = dat, save_pars = save_pars(latent = TRUE)) -#' summary(fit2) -#' } -#' -#' @export -me <- function(x, sdx, gr = NULL) { - # use 'term' for consistency with other special terms - term <- deparse(substitute(x)) - sdx <- deparse(substitute(sdx)) - gr <- substitute(gr) - if (!is.null(gr)) { - gr <- deparse_combine(gr) - stopif_illegal_group(gr) - } else { - gr <- "" - } - label <- deparse(match.call()) - out <- nlist(term, sdx, gr, label) - class(out) <- c("me_term", "sp_term") - out -} - -#' Predictors with Missing Values in \pkg{brms} Models -#' -#' Specify predictor term with missing values in \pkg{brms}. The function does -#' not evaluate its arguments -- it exists purely to help set up a model. -#' -#' @param x The variable containing missing values. -#' @param idx An optional variable containing indices of observations in `x` -#' that are to be used in the model. This is mostly relevant in partially -#' subsetted models (via \code{resp_subset}) but may also have other -#' applications that I haven't thought of. -#' -#' @details For detailed documentation see \code{help(brmsformula)}. -#' -#' @seealso \code{\link{brmsformula}} -#' -#' @examples -#' \dontrun{ -#' data("nhanes", package = "mice") -#' N <- nrow(nhanes) -#' -#' # simple model with missing data -#' bform1 <- bf(bmi | mi() ~ age * mi(chl)) + -#' bf(chl | mi() ~ age) + -#' set_rescor(FALSE) -#' -#' fit1 <- brm(bform1, data = nhanes) -#' -#' summary(fit1) -#' plot(conditional_effects(fit1, resp = "bmi"), ask = FALSE) -#' loo(fit1, newdata = na.omit(fit1$data)) -#' -#' # simulate some measurement noise -#' nhanes$se <- rexp(N, 2) -#' -#' # measurement noise can be handled within 'mi' terms -#' # with or without the presence of missing values -#' bform2 <- bf(bmi | mi() ~ age * mi(chl)) + -#' bf(chl | mi(se) ~ age) + -#' set_rescor(FALSE) -#' -#' fit2 <- brm(bform2, data = nhanes) -#' -#' summary(fit2) -#' plot(conditional_effects(fit2, resp = "bmi"), ask = FALSE) -#' -#' # 'mi' terms can also be used when some responses are subsetted -#' nhanes$sub <- TRUE -#' nhanes$sub[1:2] <- FALSE -#' nhanes$id <- 1:N -#' nhanes$idx <- sample(3:N, N, TRUE) -#' -#' # this requires the addition term 'index' being specified -#' # in the subsetted part of the model -#' bform3 <- bf(bmi | mi() ~ age * mi(chl, idx)) + -#' bf(chl | mi(se) + subset(sub) + index(id) ~ age) + -#' set_rescor(FALSE) -#' -#' fit3 <- brm(bform3, data = nhanes) -#' -#' summary(fit3) -#' plot(conditional_effects(fit3, resp = "bmi"), ask = FALSE) -#' } -#' -#' @export -mi <- function(x, idx = NA) { - # use 'term' for consistency with other special terms - term <- deparse(substitute(x)) - term_vars <- all_vars(term) - if (!is_equal(term, term_vars)) { - stop2("'mi' only accepts single untransformed variables.") - } - idx <- deparse(substitute(idx)) - if (idx != "NA") { - idx_vars <- all_vars(idx) - if (!is_equal(idx, idx_vars)) { - stop2("'mi' only accepts single untransformed variables.") - } - } - label <- deparse(match.call()) - out <- nlist(term, idx, label) - class(out) <- c("mi_term", "sp_term") - out -} - -#' Monotonic Predictors in \pkg{brms} Models -#' -#' Specify a monotonic predictor term in \pkg{brms}. The function does not -#' evaluate its arguments -- it exists purely to help set up a model. -#' -#' @param x An integer variable or an ordered factor to be modeled as monotonic. -#' @param id Optional character string. All monotonic terms -#' with the same \code{id} within one formula will be modeled as -#' having the same simplex (shape) parameter vector. If all monotonic terms -#' of the same predictor have the same \code{id}, the resulting -#' predictions will be conditionally monotonic for all values of -#' interacting covariates (Bürkner & Charpentier, 2020). -#' -#' @details See Bürkner and Charpentier (2020) for the underlying theory. For -#' detailed documentation of the formula syntax used for monotonic terms, -#' see \code{help(brmsformula)} as well as \code{vignette("brms_monotonic")}. -#' -#' @seealso \code{\link{brmsformula}} -#' -#' @references -#' Bürkner P. C. & Charpentier E. (2020). Modeling Monotonic Effects of Ordinal -#' Predictors in Regression Models. British Journal of Mathematical and -#' Statistical Psychology. doi:10.1111/bmsp.12195 -#' -#' @examples -#' \dontrun{ -#' # generate some data -#' income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") -#' income <- factor(sample(income_options, 100, TRUE), -#' levels = income_options, ordered = TRUE) -#' mean_ls <- c(30, 60, 70, 75) -#' ls <- mean_ls[income] + rnorm(100, sd = 7) -#' dat <- data.frame(income, ls) -#' -#' # fit a simple monotonic model -#' fit1 <- brm(ls ~ mo(income), data = dat) -#' summary(fit1) -#' plot(fit1, N = 6) -#' plot(conditional_effects(fit1), points = TRUE) -#' -#' # model interaction with other variables -#' dat$x <- sample(c("a", "b", "c"), 100, TRUE) -#' fit2 <- brm(ls ~ mo(income)*x, data = dat) -#' summary(fit2) -#' plot(conditional_effects(fit2), points = TRUE) -#' -#' # ensure conditional monotonicity -#' fit3 <- brm(ls ~ mo(income, id = "i")*x, data = dat) -#' summary(fit3) -#' plot(conditional_effects(fit3), points = TRUE) -#' } -#' -#' @export -mo <- function(x, id = NA) { - # use 'term' for consistency with other special terms - term <- deparse(substitute(x)) - id <- as_one_character(id, allow_na = TRUE) - label <- deparse(match.call()) - out <- nlist(term, id, label) - class(out) <- c("mo_term", "sp_term") - out -} - -# find variable names for which to keep NAs -vars_keep_na <- function(x, ...) { - UseMethod("vars_keep_na") -} - -#' @export -vars_keep_na.mvbrmsterms <- function(x, ...) { - resps <- get_element(x, "respform") - resps <- ulapply(resps, terms_resp, check_names = FALSE) - out <- lapply(x$terms, vars_keep_na, responses = resps, ...) - vars_mi <- unique(ulapply(out, attr, "vars_mi")) - out <- unique(unlist(out)) - miss_mi <- setdiff(vars_mi, out) - if (length(miss_mi)) { - stop2( - "Response models of variables in 'mi' terms require " , - "specification of the addition argument 'mi'. See ?mi. ", - "Error occurred for ", collapse_comma(miss_mi), "." - ) - } - out -} - -#' @export -vars_keep_na.brmsterms <- function(x, responses = NULL, ...) { - out <- character(0) - if (is.formula(x$adforms$mi)) { - mi_respcall <- terms_resp(x$respform, check_names = FALSE) - mi_respvars <- all_vars(mi_respcall) - mi_advars <- all_vars(x$adforms$mi) - c(out) <- unique(c(mi_respcall, mi_respvars, mi_advars)) - } - if (is.formula(x$adforms$cens)) { - y2_expr <- get_ad_expr(x, "cens", "y2", type = "vars") - c(out) <- all_vars(y2_expr) - } - uni_mi <- ulapply(get_effect(x, "sp"), attr, "uni_mi") - if (length(uni_mi)) { - vars_mi <- ulapply(uni_mi, function(term) eval2(term)$term) - miss_mi <- setdiff(vars_mi, responses) - if (length(miss_mi)) { - stop2( - "Variables in 'mi' terms should also be specified " , - "as response variables in the model. See ?mi. ", - "Error occurred for ", collapse_comma(miss_mi), "." - ) - } - attr(out, "vars_mi") <- vars_mi - } - out -} - -# extract unique names of noise-free terms -get_uni_me <- function(x) { - uni_me <- ulapply(get_effect(x, "sp"), attr, "uni_me") - if (!length(uni_me)) { - return(NULL) - } - xname <- ulapply(uni_me, function(term) eval2(term)$term) - df <- data.frame(xname, uni_me) - df <- df[!duplicated(df), ] - xdupl <- df$xname[duplicated(df$xname)] - if (length(xdupl)) { - calls <- df$uni_me[df$xname == xdupl[1]] - stop2( - "Variable '", xdupl[1], "' is used in different calls to 'me'.\n", - "Associated calls are: ", collapse_comma(calls) - ) - } - unique(uni_me) -} - -# save all me-terms within a tidy data.frame -tidy_meef <- function(bterms, data, old_levels = NULL) { - uni_me <- get_uni_me(bterms) - if (!length(uni_me)) { - return(empty_meef()) - } - if (has_subset(bterms)) { - # 'Xme' variables need to be the same across univariate models - stop2("Argument 'subset' is not supported when using 'me' terms.") - } - out <- data.frame( - term = uni_me, xname = "", grname = "", - stringsAsFactors = FALSE - ) - levels <- vector("list", nrow(out)) - for (i in seq_rows(out)) { - tmp <- eval2(out$term[i]) - out$xname[i] <- tmp$term - if (isTRUE(nzchar(tmp$gr))) { - out$grname[i] <- tmp$gr - if (length(old_levels)) { - levels[[i]] <- old_levels[[tmp$gr]] - } else { - levels[[i]] <- levels(factor(get(tmp$gr, data))) - } - } - } - out$coef <- rename(paste0("me", out$xname)) - out$cor <- isTRUE(bterms$mecor) - names(levels) <- out$grname - levels <- levels[lengths(levels) > 0L] - if (length(levels)) { - levels <- levels[!duplicated(names(levels))] - attr(out, "levels") <- levels - } - structure(out, class = c("meef_frame", "data.frame")) -} - -empty_meef <- function() { - out <- data.frame( - term = character(0), xname = character(0), - grname = character(0), cor = logical(0), - stringsAsFactors = FALSE - ) - structure(out, class = c("meef_frame", "data.frame")) -} - -is.meef_frame <- function(x) { - inherits(x, "meef_frame") -} - -# handle default of correlations between 'me' terms -default_mecor <- function(mecor = NULL) { - if (is.null(mecor)) TRUE else as_one_logical(mecor) -} - -# find names of all variables used in a special effects type -get_sp_vars <- function(x, type) { - sp_terms <- ulapply(get_effect(x, "sp"), all_terms) - all_vars(str2formula(get_matches_expr(regex_sp(type), sp_terms))) -} - -# gather information of special effects terms -# @param x either a formula or a list containing an element "sp" -# @param data data frame containing the monotonic variables -# @return a data.frame with one row per special term -# TODO: refactor to store in long format to avoid several list columns? -tidy_spef <- function(x, data) { - if (is.formula(x)) { - x <- brmsterms(x, check_response = FALSE)$dpars$mu - } - form <- x[["sp"]] - if (!is.formula(form)) { - return(empty_data_frame()) - } - mm <- sp_model_matrix(form, data, rename = FALSE) - out <- data.frame(term = trim_wsp(colnames(mm)), stringsAsFactors = FALSE) - out$coef <- rename(out$term) - calls_cols <- c(paste0("calls_", all_sp_types()), "joint_call") - list_cols <- c("vars_mi", "idx_mi", "idx2_mi", "ids_mo", "Imo") - for (col in c(calls_cols, list_cols)) { - out[[col]] <- vector("list", nrow(out)) - } - kmo <- 0 - terms_split <- strsplit(out$term, ":") - for (i in seq_rows(out)) { - # prepare mo terms - take_mo <- grepl_expr(regex_sp("mo"), terms_split[[i]]) - if (sum(take_mo)) { - out$calls_mo[[i]] <- terms_split[[i]][take_mo] - nmo <- length(out$calls_mo[[i]]) - out$Imo[[i]] <- (kmo + 1):(kmo + nmo) - out$ids_mo[[i]] <- rep(NA, nmo) - kmo <- kmo + nmo - for (j in seq_along(out$calls_mo[[i]])) { - mo_term <- out$calls_mo[[i]][[j]] - mo_match <- get_matches_expr(regex_sp("mo"), mo_term) - if (length(mo_match) > 1L || nchar(mo_match) < nchar(mo_term)) { - stop2("The monotonic term '", mo_term, "' is invalid.") - } - out$ids_mo[[i]][j] <- eval2(mo_term)$id - } - } - # prepare me terms - take_me <- grepl_expr(regex_sp("me"), terms_split[[i]]) - if (sum(take_me)) { - out$calls_me[[i]] <- terms_split[[i]][take_me] - # remove 'I' (identity) function calls that - # were used solely to separate formula terms - out$calls_me[[i]] <- gsub("^I\\(", "(", out$calls_me[[i]]) - } - # prepare mi terms - take_mi <- grepl_expr(regex_sp("mi"), terms_split[[i]]) - if (sum(take_mi)) { - mi_parts <- terms_split[[i]][take_mi] - out$calls_mi[[i]] <- get_matches_expr(regex_sp("mi"), mi_parts) - out$vars_mi[[i]] <- out$idx_mi[[i]] <- rep(NA, length(out$calls_mi[[i]])) - for (j in seq_along(out$calls_mi[[i]])) { - mi_term <- eval2(out$calls_mi[[i]][[j]]) - out$vars_mi[[i]][j] <- mi_term$term - if (mi_term$idx != "NA") { - out$idx_mi[[i]][j] <- mi_term$idx - } - } - # do it like terms_resp to ensure correct matching - out$vars_mi[[i]] <- gsub("\\.|_", "", make.names(out$vars_mi[[i]])) - } - has_sp_calls <- grepl_expr(regex_sp(all_sp_types()), terms_split[[i]]) - sp_calls <- sub("^I\\(", "(", terms_split[[i]][has_sp_calls]) - out$joint_call[[i]] <- paste0(sp_calls, collapse = " * ") - out$Ic[i] <- any(!has_sp_calls) - } - - # extract data frame to track all required index variables - uni_mi <- unique(data.frame( - var = unlist(out$vars_mi), - idx = unlist(out$idx_mi) - )) - uni_mi$idx2 <- rep(NA, nrow(uni_mi)) - for (i in seq_rows(uni_mi)) { - uni_mi_sub <- subset2(uni_mi, var = uni_mi$var[i]) - uni_mi$idx2[i] <- match(uni_mi$idx[i], na.omit(uni_mi_sub$idx)) - } - attr(out, "uni_mi") <- uni_mi - for (i in seq_rows(out)) { - for (j in seq_along(out$idx_mi[[i]])) { - sub <- subset2( - uni_mi, var = out$vars_mi[[i]][j], - idx = out$idx_mi[[i]][j] - ) - out$idx2_mi[[i]][j] <- sub$idx2 - } - } - - # extract information on covariates - not_one <- apply(mm, 2, function(x) any(x != 1)) - out$Ic <- cumsum(out$Ic | not_one) - out -} - -# extract names of monotonic simplex parameters -# @param spef output of tidy_spef -# @param use_id use the 'id' argument to construct simo labels? -# @return a character vector of length nrow(spef) -get_simo_labels <- function(spef, use_id = FALSE) { - out <- named_list(spef$term) - I <- which(lengths(spef$Imo) > 0) - for (i in I) { - # use the ID as label if specified - out[[i]] <- ifelse( - use_id & !is.na(spef$ids_mo[[i]]), spef$ids_mo[[i]], - paste0(spef$coef[i], seq_along(spef$Imo[[i]])) - ) - } - unlist(out) -} - -# standard errors of variables with missing values -get_sdy <- function(x, data = NULL) { - stopifnot(is.brmsterms(x)) - miform <- x$adforms[["mi"]] - sdy <- NULL - if (is.formula(miform)) { - mi <- eval_rhs(miform) - if (mi$vars$sdy != "NA") { - sdy <- eval2(mi$vars$sdy, data) - if (!is.null(sdy) && !is.numeric(sdy)) { - stop2("Measurement error should be numeric.") - } - if (isTRUE(any(sdy <= 0))) { - stop2("Measurement error should be positive.") - } - } - } - sdy -} - -# names of grouping variables used in measurement error terms -get_me_groups <- function(x) { - uni_me <- get_uni_me(x) - out <- lapply(uni_me, eval2) - out <- ulapply(out, "[[", "gr") - out[nzchar(out)] -} - -# get the design matrix of special effects terms -# @param formula a formula containing special effects terms -# @param data data.frame passed by the user -# @param types types of special terms to consider -# @param ... passed to get_model_matrix -# @details special terms will be evaluated to 1 so that columns -# containing not only ones are those with covariates -# @return design matrix of special effects terms and their covariates -sp_model_matrix <- function(formula, data, types = all_sp_types(), ...) { - attributes(data)$terms <- NULL - terms_split <- strsplit(all_terms(formula), split = ":") - terms_unique <- unique(unlist(terms_split)) - regex <- regex_sp(types) - terms_replace <- terms_unique[grepl_expr(regex, terms_unique)] - dummies <- paste0("dummy", seq_along(terms_replace), "__") - data[dummies] <- list(1) - terms_comb <- rep(NA, length(terms_split)) - # loop over terms and add dummy variables - for (i in seq_along(terms_split)) { - replace_i <- grepl_expr(regex, terms_split[[i]]) - terms_i_replace <- terms_split[[i]][replace_i] - dummies_i <- dummies[match(terms_i_replace, terms_replace)] - terms_split[[i]][replace_i] <- dummies_i - terms_comb[i] <- paste0(terms_split[[i]], collapse = ":") - } - new_formula <- str2formula(terms_comb) - attributes(new_formula) <- attributes(formula) - out <- get_model_matrix(new_formula, data, ...) - # recover original column names - colnames(out) <- rename(colnames(out), dummies, terms_replace) - out -} - -# formula of variables used in special effects terms -sp_fake_formula <- function(...) { - dots <- c(...) - out <- vector("list", length(dots)) - for (i in seq_along(dots)) { - tmp <- eval2(dots[[i]]) - out[[i]] <- all_vars(c(tmp$term, tmp$sdx, tmp$gr)) - } - str2formula(unique(unlist(out))) -} - -# extract an me variable -get_me_values <- function(term, data) { - term <- get_sp_term(term) - stopifnot(is.me_term(term)) - x <- as.vector(eval2(term$term, data)) - if (!is.numeric(x)) { - stop2("Noisy variables should be numeric.") - } - as.array(x) -} - -# extract the measurement error of an me term -get_me_noise <- function(term, data) { - term <- get_sp_term(term) - stopifnot(is.me_term(term)) - sdx <- as.vector(eval2(term$sdx, data)) - if (length(sdx) == 0L) { - stop2("Argument 'sdx' is missing in function 'me'.") - } else if (length(sdx) == 1L) { - sdx <- rep(sdx, nrow(data)) - } - if (!is.numeric(sdx)) { - stop2("Measurement error should be numeric.") - } - if (isTRUE(any(sdx <= 0))) { - stop2("Measurement error should be positive.") - } - as.array(sdx) -} - -# extract the grouping variable of an me term -get_me_group <- function(term, data) { - term <- get_sp_term(term) - stopifnot(is.me_term(term)) - as.array(eval2(term$gr, data)) -} - -# extract mo variables -get_mo_values <- function(term, data) { - term <- get_sp_term(term) - stopifnot(is.mo_term(term)) - x <- eval2(term$term, data) - if (is.ordered(x)) { - # counting starts at zero - x <- as.numeric(x) - 1 - } else if (all(is_wholenumber(x))) { - min_value <- attr(x, "min") - if (is.null(min_value)) { - min_value <- min(x) - } - x <- x - min_value - } else { - stop2( - "Monotonic predictors must be integers or ordered ", - "factors. Error occurred for variable '", term$term, "'." - ) - } - as.array(x) -} - -# prepare 'sp_term' objects -get_sp_term <- function(term) { - if (!is.sp_term(term)) { - term <- eval2(as_one_character(term)) - } - term -} - -# all effects which fall under the 'sp' category of brms -all_sp_types <- function() { - c("mo", "me", "mi") -} - -# classes used to set up special effects terms -is.sp_term <- function(x) { - inherits(x, "sp_term") -} - -is.mo_term <- function(x) { - inherits(x, "mo_term") -} - -is.me_term <- function(x) { - inherits(x, "me_term") -} - -is.mi_term <- function(x) { - inherits(x, "mi_term") -} +# This file contains functions dealing with the extended +# formula syntax to specify special effects terms + +#' Predictors with Measurement Error in \pkg{brms} Models +#' +#' (Soft deprecated) Specify predictors with measurement error. The function +#' does not evaluate its arguments -- it exists purely to help set up a model. +#' +#' @param x The variable measured with error. +#' @param sdx Known measurement error of \code{x} +#' treated as standard deviation. +#' @param gr Optional grouping factor to specify which +#' values of \code{x} correspond to the same value of the +#' latent variable. If \code{NULL} (the default) each +#' observation will have its own value of the latent variable. +#' +#' @details +#' For detailed documentation see \code{help(brmsformula)}. +#' \code{me} terms are soft deprecated in favor of the more +#' general and consistent \code{\link{mi}} terms. +#' By default, latent noise-free variables are assumed +#' to be correlated. To change that, add \code{set_mecor(FALSE)} +#' to your model formula object (see examples). +#' +#' @seealso +#' \code{\link{brmsformula}}, \code{\link{brmsformula-helpers}} +#' +#' @examples +#' \dontrun{ +#' # sample some data +#' N <- 100 +#' dat <- data.frame( +#' y = rnorm(N), x1 = rnorm(N), +#' x2 = rnorm(N), sdx = abs(rnorm(N, 1)) +#' ) +#' # fit a simple error-in-variables model +#' fit1 <- brm(y ~ me(x1, sdx) + me(x2, sdx), data = dat, +#' save_pars = save_pars(latent = TRUE)) +#' summary(fit1) +#' +#' # turn off modeling of correlations +#' bform <- bf(y ~ me(x1, sdx) + me(x2, sdx)) + set_mecor(FALSE) +#' fit2 <- brm(bform, data = dat, save_pars = save_pars(latent = TRUE)) +#' summary(fit2) +#' } +#' +#' @export +me <- function(x, sdx, gr = NULL) { + # use 'term' for consistency with other special terms + term <- deparse(substitute(x)) + sdx <- deparse(substitute(sdx)) + gr <- substitute(gr) + if (!is.null(gr)) { + gr <- deparse_combine(gr) + stopif_illegal_group(gr) + } else { + gr <- "" + } + label <- deparse(match.call()) + out <- nlist(term, sdx, gr, label) + class(out) <- c("me_term", "sp_term") + out +} + +#' Predictors with Missing Values in \pkg{brms} Models +#' +#' Specify predictor term with missing values in \pkg{brms}. The function does +#' not evaluate its arguments -- it exists purely to help set up a model. +#' For documentation on how to specify missing values in response variables, +#' see \code{\link{resp_mi}}. +#' +#' @param x The variable containing missing values. +#' @param idx An optional variable containing indices of observations in `x` +#' that are to be used in the model. This is mostly relevant in partially +#' subsetted models (via \code{resp_subset}) but may also have other +#' applications that I haven't thought of. +#' +#' @details For detailed documentation see \code{help(brmsformula)}. +#' +#' @seealso \code{\link{brmsformula}} +#' +#' @examples +#' \dontrun{ +#' data("nhanes", package = "mice") +#' N <- nrow(nhanes) +#' +#' # simple model with missing data +#' bform1 <- bf(bmi | mi() ~ age * mi(chl)) + +#' bf(chl | mi() ~ age) + +#' set_rescor(FALSE) +#' +#' fit1 <- brm(bform1, data = nhanes) +#' +#' summary(fit1) +#' plot(conditional_effects(fit1, resp = "bmi"), ask = FALSE) +#' loo(fit1, newdata = na.omit(fit1$data)) +#' +#' # simulate some measurement noise +#' nhanes$se <- rexp(N, 2) +#' +#' # measurement noise can be handled within 'mi' terms +#' # with or without the presence of missing values +#' bform2 <- bf(bmi | mi() ~ age * mi(chl)) + +#' bf(chl | mi(se) ~ age) + +#' set_rescor(FALSE) +#' +#' fit2 <- brm(bform2, data = nhanes) +#' +#' summary(fit2) +#' plot(conditional_effects(fit2, resp = "bmi"), ask = FALSE) +#' +#' # 'mi' terms can also be used when some responses are subsetted +#' nhanes$sub <- TRUE +#' nhanes$sub[1:2] <- FALSE +#' nhanes$id <- 1:N +#' nhanes$idx <- sample(3:N, N, TRUE) +#' +#' # this requires the addition term 'index' being specified +#' # in the subsetted part of the model +#' bform3 <- bf(bmi | mi() ~ age * mi(chl, idx)) + +#' bf(chl | mi(se) + subset(sub) + index(id) ~ age) + +#' set_rescor(FALSE) +#' +#' fit3 <- brm(bform3, data = nhanes) +#' +#' summary(fit3) +#' plot(conditional_effects(fit3, resp = "bmi"), ask = FALSE) +#' } +#' +#' @export +mi <- function(x, idx = NA) { + # use 'term' for consistency with other special terms + term <- deparse(substitute(x)) + term_vars <- all_vars(term) + if (!is_equal(term, term_vars)) { + stop2("'mi' only accepts single untransformed variables.") + } + idx <- deparse(substitute(idx)) + if (idx != "NA") { + idx_vars <- all_vars(idx) + if (!is_equal(idx, idx_vars)) { + stop2("'mi' only accepts single untransformed variables.") + } + } + label <- deparse(match.call()) + out <- nlist(term, idx, label) + class(out) <- c("mi_term", "sp_term") + out +} + +#' Monotonic Predictors in \pkg{brms} Models +#' +#' Specify a monotonic predictor term in \pkg{brms}. The function does not +#' evaluate its arguments -- it exists purely to help set up a model. +#' +#' @param x An integer variable or an ordered factor to be modeled as monotonic. +#' @param id Optional character string. All monotonic terms +#' with the same \code{id} within one formula will be modeled as +#' having the same simplex (shape) parameter vector. If all monotonic terms +#' of the same predictor have the same \code{id}, the resulting +#' predictions will be conditionally monotonic for all values of +#' interacting covariates (Bürkner & Charpentier, 2020). +#' +#' @details See Bürkner and Charpentier (2020) for the underlying theory. For +#' detailed documentation of the formula syntax used for monotonic terms, +#' see \code{help(brmsformula)} as well as \code{vignette("brms_monotonic")}. +#' +#' @seealso \code{\link{brmsformula}} +#' +#' @references +#' Bürkner P. C. & Charpentier E. (2020). Modeling Monotonic Effects of Ordinal +#' Predictors in Regression Models. British Journal of Mathematical and +#' Statistical Psychology. doi:10.1111/bmsp.12195 +#' +#' @examples +#' \dontrun{ +#' # generate some data +#' income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") +#' income <- factor(sample(income_options, 100, TRUE), +#' levels = income_options, ordered = TRUE) +#' mean_ls <- c(30, 60, 70, 75) +#' ls <- mean_ls[income] + rnorm(100, sd = 7) +#' dat <- data.frame(income, ls) +#' +#' # fit a simple monotonic model +#' fit1 <- brm(ls ~ mo(income), data = dat) +#' summary(fit1) +#' plot(fit1, N = 6) +#' plot(conditional_effects(fit1), points = TRUE) +#' +#' # model interaction with other variables +#' dat$x <- sample(c("a", "b", "c"), 100, TRUE) +#' fit2 <- brm(ls ~ mo(income)*x, data = dat) +#' summary(fit2) +#' plot(conditional_effects(fit2), points = TRUE) +#' +#' # ensure conditional monotonicity +#' fit3 <- brm(ls ~ mo(income, id = "i")*x, data = dat) +#' summary(fit3) +#' plot(conditional_effects(fit3), points = TRUE) +#' } +#' +#' @export +mo <- function(x, id = NA) { + # use 'term' for consistency with other special terms + term <- deparse(substitute(x)) + id <- as_one_character(id, allow_na = TRUE) + label <- deparse(match.call()) + out <- nlist(term, id, label) + class(out) <- c("mo_term", "sp_term") + out +} + +# find variable names for which to keep NAs +vars_keep_na <- function(x, ...) { + UseMethod("vars_keep_na") +} + +#' @export +vars_keep_na.mvbrmsterms <- function(x, ...) { + resps <- get_element(x, "respform") + resps <- ulapply(resps, terms_resp, check_names = FALSE) + out <- lapply(x$terms, vars_keep_na, responses = resps, ...) + vars_mi <- unique(ulapply(out, attr, "vars_mi")) + out <- unique(unlist(out)) + miss_mi <- setdiff(vars_mi, out) + if (length(miss_mi)) { + stop2( + "Response models of variables in 'mi' terms require " , + "specification of the addition argument 'mi'. See ?mi. ", + "Error occurred for ", collapse_comma(miss_mi), "." + ) + } + out +} + +#' @export +vars_keep_na.brmsterms <- function(x, responses = NULL, ...) { + out <- character(0) + if (is.formula(x$adforms$mi)) { + mi_respcall <- terms_resp(x$respform, check_names = FALSE) + mi_respvars <- all_vars(mi_respcall) + mi_advars <- all_vars(x$adforms$mi) + c(out) <- unique(c(mi_respcall, mi_respvars, mi_advars)) + } + if (is.formula(x$adforms$cens)) { + y2_expr <- get_ad_expr(x, "cens", "y2", type = "vars") + c(out) <- all_vars(y2_expr) + } + uni_mi <- ulapply(get_effect(x, "sp"), attr, "uni_mi") + if (length(uni_mi)) { + vars_mi <- ulapply(uni_mi, function(term) eval2(term)$term) + miss_mi <- setdiff(vars_mi, responses) + if (length(miss_mi)) { + stop2( + "Variables in 'mi' terms should also be specified " , + "as response variables in the model. See ?mi. ", + "Error occurred for ", collapse_comma(miss_mi), "." + ) + } + attr(out, "vars_mi") <- vars_mi + } + out +} + +# extract unique names of noise-free terms +get_uni_me <- function(x) { + uni_me <- ulapply(get_effect(x, "sp"), attr, "uni_me") + if (!length(uni_me)) { + return(NULL) + } + xname <- ulapply(uni_me, function(term) eval2(term)$term) + df <- data.frame(xname, uni_me) + df <- df[!duplicated(df), ] + xdupl <- df$xname[duplicated(df$xname)] + if (length(xdupl)) { + calls <- df$uni_me[df$xname == xdupl[1]] + stop2( + "Variable '", xdupl[1], "' is used in different calls to 'me'.\n", + "Associated calls are: ", collapse_comma(calls) + ) + } + unique(uni_me) +} + +# save all me-terms within a tidy data.frame +tidy_meef <- function(bterms, data, old_levels = NULL) { + uni_me <- get_uni_me(bterms) + if (!length(uni_me)) { + return(empty_meef()) + } + if (has_subset(bterms)) { + # 'Xme' variables need to be the same across univariate models + stop2("Argument 'subset' is not supported when using 'me' terms.") + } + out <- data.frame( + term = uni_me, xname = "", grname = "", + stringsAsFactors = FALSE + ) + levels <- vector("list", nrow(out)) + for (i in seq_rows(out)) { + tmp <- eval2(out$term[i]) + out$xname[i] <- tmp$term + if (isTRUE(nzchar(tmp$gr))) { + out$grname[i] <- tmp$gr + if (length(old_levels)) { + levels[[i]] <- old_levels[[tmp$gr]] + } else { + levels[[i]] <- extract_levels(get(tmp$gr, data)) + } + } + } + out$coef <- rename(paste0("me", out$xname)) + out$cor <- isTRUE(bterms$mecor) + names(levels) <- out$grname + levels <- levels[lengths(levels) > 0L] + if (length(levels)) { + levels <- levels[!duplicated(names(levels))] + attr(out, "levels") <- levels + } + structure(out, class = c("meef_frame", "data.frame")) +} + +empty_meef <- function() { + out <- data.frame( + term = character(0), xname = character(0), + grname = character(0), cor = logical(0), + stringsAsFactors = FALSE + ) + structure(out, class = c("meef_frame", "data.frame")) +} + +is.meef_frame <- function(x) { + inherits(x, "meef_frame") +} + +# handle default of correlations between 'me' terms +default_mecor <- function(mecor = NULL) { + if (is.null(mecor)) TRUE else as_one_logical(mecor) +} + +# find names of all variables used in a special effects type +get_sp_vars <- function(x, type) { + sp_terms <- ulapply(get_effect(x, "sp"), all_terms) + all_vars(str2formula(get_matches_expr(regex_sp(type), sp_terms))) +} + +# gather information of special effects terms +# @param x either a formula or a list containing an element "sp" +# @param data data frame containing the monotonic variables +# @return a data.frame with one row per special term +# TODO: refactor to store in long format to avoid several list columns? +tidy_spef <- function(x, data) { + if (is.formula(x)) { + x <- brmsterms(x, check_response = FALSE)$dpars$mu + } + form <- x[["sp"]] + if (!is.formula(form)) { + return(empty_data_frame()) + } + mm <- sp_model_matrix(form, data, rename = FALSE) + out <- data.frame(term = trim_wsp(colnames(mm)), stringsAsFactors = FALSE) + out$coef <- rename(out$term) + calls_cols <- c(paste0("calls_", all_sp_types()), "joint_call") + list_cols <- c("vars_mi", "idx_mi", "idx2_mi", "ids_mo", "Imo") + for (col in c(calls_cols, list_cols)) { + out[[col]] <- vector("list", nrow(out)) + } + kmo <- 0 + terms_split <- strsplit(out$term, ":") + for (i in seq_rows(out)) { + # prepare mo terms + take_mo <- grepl_expr(regex_sp("mo"), terms_split[[i]]) + if (sum(take_mo)) { + out$calls_mo[[i]] <- terms_split[[i]][take_mo] + nmo <- length(out$calls_mo[[i]]) + out$Imo[[i]] <- (kmo + 1):(kmo + nmo) + out$ids_mo[[i]] <- rep(NA, nmo) + kmo <- kmo + nmo + for (j in seq_along(out$calls_mo[[i]])) { + mo_term <- out$calls_mo[[i]][[j]] + mo_match <- get_matches_expr(regex_sp("mo"), mo_term) + if (length(mo_match) > 1L || nchar(mo_match) < nchar(mo_term)) { + stop2("The monotonic term '", mo_term, "' is invalid.") + } + out$ids_mo[[i]][j] <- eval2(mo_term)$id + } + } + # prepare me terms + take_me <- grepl_expr(regex_sp("me"), terms_split[[i]]) + if (sum(take_me)) { + out$calls_me[[i]] <- terms_split[[i]][take_me] + # remove 'I' (identity) function calls that + # were used solely to separate formula terms + out$calls_me[[i]] <- gsub("^I\\(", "(", out$calls_me[[i]]) + } + # prepare mi terms + take_mi <- grepl_expr(regex_sp("mi"), terms_split[[i]]) + if (sum(take_mi)) { + mi_parts <- terms_split[[i]][take_mi] + out$calls_mi[[i]] <- get_matches_expr(regex_sp("mi"), mi_parts) + out$vars_mi[[i]] <- out$idx_mi[[i]] <- rep(NA, length(out$calls_mi[[i]])) + for (j in seq_along(out$calls_mi[[i]])) { + mi_term <- eval2(out$calls_mi[[i]][[j]]) + out$vars_mi[[i]][j] <- mi_term$term + if (mi_term$idx != "NA") { + out$idx_mi[[i]][j] <- mi_term$idx + } + } + # do it like terms_resp to ensure correct matching + out$vars_mi[[i]] <- gsub("\\.|_", "", make.names(out$vars_mi[[i]])) + } + has_sp_calls <- grepl_expr(regex_sp(all_sp_types()), terms_split[[i]]) + sp_calls <- sub("^I\\(", "(", terms_split[[i]][has_sp_calls]) + out$joint_call[[i]] <- paste0(sp_calls, collapse = " * ") + out$Ic[i] <- any(!has_sp_calls) + } + + # extract data frame to track all required index variables + uni_mi <- unique(data.frame( + var = unlist(out$vars_mi), + idx = unlist(out$idx_mi), + stringsAsFactors = FALSE + )) + uni_mi$idx2 <- rep(NA, nrow(uni_mi)) + for (i in seq_rows(uni_mi)) { + uni_mi_sub <- subset2(uni_mi, var = uni_mi$var[i]) + uni_mi$idx2[i] <- match(uni_mi$idx[i], na.omit(uni_mi_sub$idx)) + } + attr(out, "uni_mi") <- uni_mi + for (i in seq_rows(out)) { + for (j in seq_along(out$idx_mi[[i]])) { + sub <- subset2( + uni_mi, var = out$vars_mi[[i]][j], + idx = out$idx_mi[[i]][j] + ) + out$idx2_mi[[i]][j] <- sub$idx2 + } + } + + # extract information on covariates + not_one <- apply(mm, 2, function(x) any(x != 1)) + out$Ic <- cumsum(out$Ic | not_one) + out +} + +# extract names of monotonic simplex parameters +# @param spef output of tidy_spef +# @param use_id use the 'id' argument to construct simo labels? +# @return a character vector of length nrow(spef) +get_simo_labels <- function(spef, use_id = FALSE) { + out <- named_list(spef$term) + I <- which(lengths(spef$Imo) > 0) + for (i in I) { + # use the ID as label if specified + out[[i]] <- ifelse( + use_id & !is.na(spef$ids_mo[[i]]), spef$ids_mo[[i]], + paste0(spef$coef[i], seq_along(spef$Imo[[i]])) + ) + } + unlist(out) +} + +# standard errors of variables with missing values +get_sdy <- function(x, data = NULL) { + stopifnot(is.brmsterms(x)) + miform <- x$adforms[["mi"]] + sdy <- NULL + if (is.formula(miform)) { + mi <- eval_rhs(miform) + if (mi$vars$sdy != "NA") { + sdy <- eval2(mi$vars$sdy, data) + if (!is.null(sdy) && !is.numeric(sdy)) { + stop2("Measurement error should be numeric.") + } + if (isTRUE(any(sdy <= 0))) { + stop2("Measurement error should be positive.") + } + } + } + sdy +} + +# names of grouping variables used in measurement error terms +get_me_groups <- function(x) { + uni_me <- get_uni_me(x) + out <- lapply(uni_me, eval2) + out <- ulapply(out, "[[", "gr") + out[nzchar(out)] +} + +# get the design matrix of special effects terms +# @param formula a formula containing special effects terms +# @param data data.frame passed by the user +# @param types types of special terms to consider +# @param ... passed to get_model_matrix +# @details special terms will be evaluated to 1 so that columns +# containing not only ones are those with covariates +# @return design matrix of special effects terms and their covariates +sp_model_matrix <- function(formula, data, types = all_sp_types(), ...) { + attributes(data)$terms <- NULL + terms_split <- strsplit(all_terms(formula), split = ":") + terms_unique <- unique(unlist(terms_split)) + regex <- regex_sp(types) + terms_replace <- terms_unique[grepl_expr(regex, terms_unique)] + dummies <- paste0("dummy", seq_along(terms_replace), "__") + data[dummies] <- list(1) + terms_comb <- rep(NA, length(terms_split)) + # loop over terms and add dummy variables + for (i in seq_along(terms_split)) { + replace_i <- grepl_expr(regex, terms_split[[i]]) + terms_i_replace <- terms_split[[i]][replace_i] + dummies_i <- dummies[match(terms_i_replace, terms_replace)] + terms_split[[i]][replace_i] <- dummies_i + terms_comb[i] <- paste0(terms_split[[i]], collapse = ":") + } + new_formula <- str2formula(terms_comb) + attributes(new_formula) <- attributes(formula) + out <- get_model_matrix(new_formula, data, ...) + # recover original column names + colnames(out) <- rename(colnames(out), dummies, terms_replace) + out +} + +# formula of variables used in special effects terms +sp_fake_formula <- function(...) { + dots <- c(...) + out <- vector("list", length(dots)) + for (i in seq_along(dots)) { + tmp <- eval2(dots[[i]]) + out[[i]] <- all_vars(c(tmp$term, tmp$sdx, tmp$gr)) + } + str2formula(unique(unlist(out))) +} + +# extract an me variable +get_me_values <- function(term, data) { + term <- get_sp_term(term) + stopifnot(is.me_term(term)) + x <- as.vector(eval2(term$term, data)) + if (!is.numeric(x)) { + stop2("Noisy variables should be numeric.") + } + as.array(x) +} + +# extract the measurement error of an me term +get_me_noise <- function(term, data) { + term <- get_sp_term(term) + stopifnot(is.me_term(term)) + sdx <- as.vector(eval2(term$sdx, data)) + if (length(sdx) == 0L) { + stop2("Argument 'sdx' is missing in function 'me'.") + } else if (length(sdx) == 1L) { + sdx <- rep(sdx, nrow(data)) + } + if (!is.numeric(sdx)) { + stop2("Measurement error should be numeric.") + } + if (isTRUE(any(sdx <= 0))) { + stop2("Measurement error should be positive.") + } + as.array(sdx) +} + +# extract the grouping variable of an me term +get_me_group <- function(term, data) { + term <- get_sp_term(term) + stopifnot(is.me_term(term)) + as.array(eval2(term$gr, data)) +} + +# extract mo variables +get_mo_values <- function(term, data) { + term <- get_sp_term(term) + stopifnot(is.mo_term(term)) + x <- eval2(term$term, data) + if (is.ordered(x)) { + # counting starts at zero + x <- as.numeric(x) - 1 + } else if (all(is_wholenumber(x))) { + min_value <- attr(x, "min") + if (is.null(min_value)) { + min_value <- min(x) + } + x <- x - min_value + } else { + stop2( + "Monotonic predictors must be integers or ordered ", + "factors. Error occurred for variable '", term$term, "'." + ) + } + as.array(x) +} + +# prepare 'sp_term' objects +get_sp_term <- function(term) { + if (!is.sp_term(term)) { + term <- eval2(as_one_character(term)) + } + term +} + +# all effects which fall under the 'sp' category of brms +all_sp_types <- function() { + c("mo", "me", "mi") +} + +# classes used to set up special effects terms +is.sp_term <- function(x) { + inherits(x, "sp_term") +} + +is.mo_term <- function(x) { + inherits(x, "mo_term") +} + +is.me_term <- function(x) { + inherits(x, "me_term") +} + +is.mi_term <- function(x) { + inherits(x, "mi_term") +} diff -Nru r-cran-brms-2.16.3/R/ggplot-themes.R r-cran-brms-2.17.0/R/ggplot-themes.R --- r-cran-brms-2.16.3/R/ggplot-themes.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/ggplot-themes.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,91 +1,91 @@ -#' (Deprecated) Black Theme for \pkg{ggplot2} Graphics -#' -#' A black theme for ggplot graphics inspired by a blog post of Jon Lefcheck -#' (\url{https://jonlefcheck.net/2013/03/11/black-theme-for-ggplot2-2/}). -#' -#' @param base_size base font size -#' @param base_family base font family -#' -#' @return A \code{theme} object used in \pkg{ggplot2} graphics. -#' -#' @details When using \code{theme_black} in plots powered by the -#' \pkg{bayesplot} package such as \code{pp_check} or \code{stanplot}, -#' I recommend using the \code{"viridisC"} color scheme (see examples). -#' -#' @examples -#' \dontrun{ -#' # change default ggplot theme -#' ggplot2::theme_set(theme_black()) -#' -#' # change default bayesplot color scheme -#' bayesplot::color_scheme_set("viridisC") -#' -#' # fit a simple model -#' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), -#' data = epilepsy, family = poisson(), chains = 2) -#' summary(fit) -#' -#' # create various plots -#' plot(marginal_effects(fit), ask = FALSE) -#' pp_check(fit) -#' mcmc_plot(fit, type = "hex", variable = c("b_Intercept", "b_Trt1")) -#' } -#' -#' @export -theme_black = function(base_size = 12, base_family = "") { - warning2("'theme_black' is deprecated. Please use the 'ggdark' package ", - "for dark ggplot themes.") - theme_grey(base_size = base_size, base_family = base_family) %+replace% - theme( - # axis options - axis.line = element_blank(), - axis.text.x = element_text( - size = base_size * 0.8, color = "white", lineheight = 0.9 - ), - axis.text.y = element_text( - size = base_size * 0.8, color = "white", lineheight = 0.9 - ), - axis.ticks = element_line(color = "white", size = 0.2), - axis.title.x = element_text( - size = base_size, color = "white", margin = margin(10, 0, 0, 0) - ), - axis.title.y = element_text( - size = base_size, color = "white", angle = 90, - margin = margin(0, 10, 0, 0) - ), - axis.ticks.length = unit(0.3, "lines"), - # legend options - legend.background = element_rect(color = NA, fill = "black"), - legend.key = element_rect(color = "white", fill = "black"), - legend.key.size = unit(1.2, "lines"), - legend.key.height = NULL, - legend.key.width = NULL, - legend.text = element_text(size = base_size * 0.8, color = "white"), - legend.title = element_text( - size = base_size * 0.8, face = "bold", hjust = 0, color = "white" - ), - legend.position = "right", - legend.text.align = NULL, - legend.title.align = NULL, - legend.direction = "vertical", - legend.box = NULL, - # panel options - panel.background = element_rect(fill = "black", color = NA), - panel.border = element_rect(fill = NA, color = "white"), - panel.grid.major = element_line(color = "grey35"), - panel.grid.minor = element_line(color = "grey20"), - panel.spacing = unit(0.5, "lines"), - # facetting options - strip.background = element_rect(fill = "grey30", color = "grey10"), - strip.text.x = element_text( - size = base_size * 0.8, color = "white", margin = margin(3, 0, 4, 0) - ), - strip.text.y = element_text( - size = base_size * 0.8, color = "white", angle = -90 - ), - # plot options - plot.background = element_rect(color = "black", fill = "black"), - plot.title = element_text(size = base_size * 1.2, color = "white"), - plot.margin = unit(rep(1, 4), "lines") - ) -} +#' (Deprecated) Black Theme for \pkg{ggplot2} Graphics +#' +#' A black theme for ggplot graphics inspired by a blog post of Jon Lefcheck +#' (\url{https://jonlefcheck.net/2013/03/11/black-theme-for-ggplot2-2/}). +#' +#' @param base_size base font size +#' @param base_family base font family +#' +#' @return A \code{theme} object used in \pkg{ggplot2} graphics. +#' +#' @details When using \code{theme_black} in plots powered by the +#' \pkg{bayesplot} package such as \code{pp_check} or \code{stanplot}, +#' I recommend using the \code{"viridisC"} color scheme (see examples). +#' +#' @examples +#' \dontrun{ +#' # change default ggplot theme +#' ggplot2::theme_set(theme_black()) +#' +#' # change default bayesplot color scheme +#' bayesplot::color_scheme_set("viridisC") +#' +#' # fit a simple model +#' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), +#' data = epilepsy, family = poisson(), chains = 2) +#' summary(fit) +#' +#' # create various plots +#' plot(marginal_effects(fit), ask = FALSE) +#' pp_check(fit) +#' mcmc_plot(fit, type = "hex", variable = c("b_Intercept", "b_Trt1")) +#' } +#' +#' @export +theme_black = function(base_size = 12, base_family = "") { + warning2("'theme_black' is deprecated. Please use the 'ggdark' package ", + "for dark ggplot themes.") + theme_grey(base_size = base_size, base_family = base_family) %+replace% + theme( + # axis options + axis.line = element_blank(), + axis.text.x = element_text( + size = base_size * 0.8, color = "white", lineheight = 0.9 + ), + axis.text.y = element_text( + size = base_size * 0.8, color = "white", lineheight = 0.9 + ), + axis.ticks = element_line(color = "white", size = 0.2), + axis.title.x = element_text( + size = base_size, color = "white", margin = margin(10, 0, 0, 0) + ), + axis.title.y = element_text( + size = base_size, color = "white", angle = 90, + margin = margin(0, 10, 0, 0) + ), + axis.ticks.length = unit(0.3, "lines"), + # legend options + legend.background = element_rect(color = NA, fill = "black"), + legend.key = element_rect(color = "white", fill = "black"), + legend.key.size = unit(1.2, "lines"), + legend.key.height = NULL, + legend.key.width = NULL, + legend.text = element_text(size = base_size * 0.8, color = "white"), + legend.title = element_text( + size = base_size * 0.8, face = "bold", hjust = 0, color = "white" + ), + legend.position = "right", + legend.text.align = NULL, + legend.title.align = NULL, + legend.direction = "vertical", + legend.box = NULL, + # panel options + panel.background = element_rect(fill = "black", color = NA), + panel.border = element_rect(fill = NA, color = "white"), + panel.grid.major = element_line(color = "grey35"), + panel.grid.minor = element_line(color = "grey20"), + panel.spacing = unit(0.5, "lines"), + # facetting options + strip.background = element_rect(fill = "grey30", color = "grey10"), + strip.text.x = element_text( + size = base_size * 0.8, color = "white", margin = margin(3, 0, 4, 0) + ), + strip.text.y = element_text( + size = base_size * 0.8, color = "white", angle = -90 + ), + # plot options + plot.background = element_rect(color = "black", fill = "black"), + plot.title = element_text(size = base_size * 1.2, color = "white"), + plot.margin = unit(rep(1, 4), "lines") + ) +} diff -Nru r-cran-brms-2.16.3/R/hypothesis.R r-cran-brms-2.17.0/R/hypothesis.R --- r-cran-brms-2.16.3/R/hypothesis.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/hypothesis.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,586 +1,586 @@ -#' Non-Linear Hypothesis Testing -#' -#' Perform non-linear hypothesis testing for all model parameters. -#' -#' @param x An \code{R} object. If it is no \code{brmsfit} object, -#' it must be coercible to a \code{data.frame}. -#' In the latter case, the variables used in the \code{hypothesis} argument -#' need to correspond to column names of \code{x}, while the rows -#' are treated as representing posterior draws of the variables. -#' @param hypothesis A character vector specifying one or more -#' non-linear hypothesis concerning parameters of the model. -#' @param class A string specifying the class of parameters being tested. -#' Default is "b" for population-level effects. -#' Other typical options are "sd" or "cor". -#' If \code{class = NULL}, all parameters can be tested -#' against each other, but have to be specified with their full name -#' (see also \code{\link[brms:draws-index-brms]{variables}}) -#' @param group Name of a grouping factor to evaluate only -#' group-level effects parameters related to this grouping factor. -#' @param alpha The alpha-level of the tests (default is 0.05; -#' see 'Details' for more information). -#' @param robust If \code{FALSE} (the default) the mean is used as -#' the measure of central tendency and the standard deviation as -#' the measure of variability. If \code{TRUE}, the median and the -#' median absolute deviation (MAD) are applied instead. -#' @param scope Indicates where to look for the variables specified in -#' \code{hypothesis}. If \code{"standard"}, use the full parameter names -#' (subject to the restriction given by \code{class} and \code{group}). -#' If \code{"coef"} or \code{"ranef"}, compute the hypothesis for all levels -#' of the grouping factor given in \code{"group"}, based on the -#' output of \code{\link{coef.brmsfit}} and \code{\link{ranef.brmsfit}}, -#' respectively. -#' @param seed A single numeric value passed to \code{\link{set.seed}} -#' to make results reproducible. -#' @param ... Currently ignored. -#' -#' @details Among others, \code{hypothesis} computes an evidence ratio -#' (\code{Evid.Ratio}) for each hypothesis. For a one-sided hypothesis, this -#' is just the posterior probability (\code{Post.Prob}) under the hypothesis -#' against its alternative. That is, when the hypothesis is of the form -#' \code{a > b}, the evidence ratio is the ratio of the posterior probability -#' of \code{a > b} and the posterior probability of \code{a < b}. In this -#' example, values greater than one indicate that the evidence in favor of -#' \code{a > b} is larger than evidence in favor of \code{a < b}. For an -#' two-sided (point) hypothesis, the evidence ratio is a Bayes factor between -#' the hypothesis and its alternative computed via the Savage-Dickey density -#' ratio method. That is the posterior density at the point of interest -#' divided by the prior density at that point. Values greater than one -#' indicate that evidence in favor of the point hypothesis has increased after -#' seeing the data. In order to calculate this Bayes factor, all parameters -#' related to the hypothesis must have proper priors and argument -#' \code{sample_prior} of function \code{brm} must be set to \code{"yes"}. -#' Otherwise \code{Evid.Ratio} (and \code{Post.Prob}) will be \code{NA}. -#' Please note that, for technical reasons, we cannot sample from priors of -#' certain parameters classes. Most notably, these include overall intercept -#' parameters (prior class \code{"Intercept"}) as well as group-level -#' coefficients. When interpreting Bayes factors, make sure that your priors -#' are reasonable and carefully chosen, as the result will depend heavily on -#' the priors. In particular, avoid using default priors. -#' -#' The \code{Evid.Ratio} may sometimes be \code{0} or \code{Inf} implying very -#' small or large evidence, respectively, in favor of the tested hypothesis. -#' For one-sided hypotheses pairs, this basically means that all posterior -#' draws are on the same side of the value dividing the two hypotheses. In -#' that sense, instead of \code{0} or \code{Inf,} you may rather read it as -#' \code{Evid.Ratio} smaller \code{1 / S} or greater \code{S}, respectively, -#' where \code{S} denotes the number of posterior draws used in the -#' computations. -#' -#' The argument \code{alpha} specifies the size of the credible interval -#' (i.e., Bayesian confidence interval). For instance, if we tested a -#' two-sided hypothesis and set \code{alpha = 0.05} (5\%) an, the credible -#' interval will contain \code{1 - alpha = 0.95} (95\%) of the posterior -#' values. Hence, \code{alpha * 100}\% of the posterior values will -#' lie outside of the credible interval. Although this allows testing of -#' hypotheses in a similar manner as in the frequentist null-hypothesis -#' testing framework, we strongly argue against using arbitrary cutoffs (e.g., -#' \code{p < .05}) to determine the 'existence' of an effect. -#' -#' @return A \code{\link{brmshypothesis}} object. -#' -#' @seealso \code{\link{brmshypothesis}} -#' -#' @author Paul-Christian Buerkner \email{paul.buerkner@@gmail.com} -#' -#' @examples -#' \dontrun{ -#' ## define priors -#' prior <- c(set_prior("normal(0,2)", class = "b"), -#' set_prior("student_t(10,0,1)", class = "sigma"), -#' set_prior("student_t(10,0,1)", class = "sd")) -#' -#' ## fit a linear mixed effects models -#' fit <- brm(time ~ age + sex + disease + (1 + age|patient), -#' data = kidney, family = lognormal(), -#' prior = prior, sample_prior = "yes", -#' control = list(adapt_delta = 0.95)) -#' -#' ## perform two-sided hypothesis testing -#' (hyp1 <- hypothesis(fit, "sexfemale = age + diseasePKD")) -#' plot(hyp1) -#' hypothesis(fit, "exp(age) - 3 = 0", alpha = 0.01) -#' -#' ## perform one-sided hypothesis testing -#' hypothesis(fit, "diseasePKD + diseaseGN - 3 < 0") -#' -#' hypothesis(fit, "age < Intercept", -#' class = "sd", group = "patient") -#' -#' ## test the amount of random intercept variance on all variance -#' h <- paste("sd_patient__Intercept^2 / (sd_patient__Intercept^2 +", -#' "sd_patient__age^2 + sigma^2) = 0") -#' (hyp2 <- hypothesis(fit, h, class = NULL)) -#' plot(hyp2) -#' -#' ## test more than one hypothesis at once -#' h <- c("diseaseGN = diseaseAN", "2 * diseaseGN - diseasePKD = 0") -#' (hyp3 <- hypothesis(fit, h)) -#' plot(hyp3, ignore_prior = TRUE) -#' -#' ## compute hypotheses for all levels of a grouping factor -#' hypothesis(fit, "age = 0", scope = "coef", group = "patient") -#' -#' ## use the default method -#' dat <- as.data.frame(fit) -#' str(dat) -#' hypothesis(dat, "b_age > 0") -#' } -#' -#' @export -hypothesis.brmsfit <- function(x, hypothesis, class = "b", group = "", - scope = c("standard", "ranef", "coef"), - alpha = 0.05, robust = FALSE, seed = NULL, - ...) { - # use a seed as prior_draws.brmsfit randomly permutes draws - if (!is.null(seed)) { - set.seed(seed) - } - contains_draws(x) - x <- restructure(x) - group <- as_one_character(group) - scope <- match.arg(scope) - if (scope == "standard") { - if (!length(class)) { - class <- "" - } - class <- as_one_character(class) - if (nzchar(group)) { - class <- paste0(class, "_", group, "__") - } else if (nzchar(class)) { - class <- paste0(class, "_") - } - out <- .hypothesis( - x, hypothesis, class = class, alpha = alpha, - robust = robust, ... - ) - } else { - co <- do_call(scope, list(x, summary = FALSE)) - if (!group %in% names(co)) { - stop2("'group' should be one of ", collapse_comma(names(co))) - } - out <- hypothesis_coef( - co[[group]], hypothesis, alpha = alpha, - robust = robust, ... - ) - } - out -} - -#' @rdname hypothesis.brmsfit -#' @export -hypothesis <- function(x, ...) { - UseMethod("hypothesis") -} - -#' @rdname hypothesis.brmsfit -#' @export -hypothesis.default <- function(x, hypothesis, alpha = 0.05, - robust = FALSE, ...) { - x <- as.data.frame(x) - .hypothesis( - x, hypothesis, class = "", alpha = alpha, - robust = robust, ... - ) -} - -#' Descriptions of \code{brmshypothesis} Objects -#' -#' A \code{brmshypothesis} object contains posterior draws -#' as well as summary statistics of non-linear hypotheses as -#' returned by \code{\link{hypothesis}}. -#' -#' @name brmshypothesis -#' -#' @param ignore_prior A flag indicating if prior distributions -#' should also be plotted. Only used if priors were specified on -#' the relevant parameters. -#' @param digits Minimal number of significant digits, -#' see \code{\link[base:print.default]{print.default}}. -#' @param chars Maximum number of characters of each hypothesis -#' to print or plot. If \code{NULL}, print the full hypotheses. -#' Defaults to \code{20}. -#' @param colors Two values specifying the colors of the posterior -#' and prior density respectively. If \code{NULL} (the default) -#' colors are taken from the current color scheme of -#' the \pkg{bayesplot} package. -#' @param ... Currently ignored. -#' @inheritParams plot.brmsfit -#' -#' @details -#' The two most important elements of a \code{brmshypothesis} object are -#' \code{hypothesis}, which is a data.frame containing the summary estimates -#' of the hypotheses, and \code{samples}, which is a data.frame containing -#' the corresponding posterior draws. -#' -#' @seealso \code{\link{hypothesis}} -NULL - -# internal function to evaluate hypotheses -# @param x the primary object passed to the hypothesis method; -# needs to be a brmsfit object or coercible to a data.frame -# @param hypothesis vector of character strings containing the hypotheses -# @param class prefix of the parameters in the hypotheses -# @param alpha the 'alpha-level' as understood by frequentist statistics -# @return a 'brmshypothesis' object -.hypothesis <- function(x, hypothesis, class, alpha, robust, - combine = TRUE, ...) { - if (!is.character(hypothesis) || !length(hypothesis)) { - stop2("Argument 'hypothesis' must be a character vector.") - } - if (length(alpha) != 1L || alpha < 0 || alpha > 1) { - stop2("Argument 'alpha' must be a single value in [0,1].") - } - class <- as_one_character(class) - robust <- as_one_logical(robust) - out <- vector("list", length(hypothesis)) - for (i in seq_along(out)) { - out[[i]] <- eval_hypothesis( - hypothesis[i], x = x, class = class, - alpha = alpha, robust = robust, - name = names(hypothesis)[i] - ) - } - if (combine) { - out <- combine_hlist(out, class = class, alpha = alpha) - } - out -} - -# evaluate hypotheses for an arrary of ranefs or coefs -# seperaly for each grouping-factor level -hypothesis_coef <- function(x, hypothesis, alpha, ...) { - stopifnot(is.array(x), length(dim(x)) == 3L) - levels <- dimnames(x)[[2]] - coefs <- dimnames(x)[[3]] - x <- lapply(seq_along(levels), function(l) - structure(as.data.frame(x[, l, ]), names = coefs) - ) - out <- vector("list", length(levels)) - for (l in seq_along(levels)) { - out[[l]] <- .hypothesis( - x[[l]], hypothesis, class = "", - alpha = alpha, combine = FALSE, ... - ) - for (i in seq_along(out[[l]])) { - out[[l]][[i]]$summary$Group <- levels[l] - } - } - out <- unlist(out, recursive = FALSE) - out <- as.list(matrix(out, ncol = length(hypothesis), byrow = TRUE)) - out <- combine_hlist(out, class = "", alpha = alpha) - out$hypothesis$Group <- factor(out$hypothesis$Group, levels) - out$hypothesis <- move2start(out$hypothesis, "Group") - out -} - -# combine list of outputs of eval_hypothesis -# @param hlist list of evaluate hypothesis -# @return a 'brmshypothesis' object -combine_hlist <- function(hlist, class, alpha) { - stopifnot(is.list(hlist)) - hs <- do_call(rbind, lapply(hlist, function(h) h$summary)) - rownames(hs) <- NULL - samples <- lapply(hlist, function(h) h$samples) - samples <- as.data.frame(do_call(cbind, samples)) - prior_samples <- lapply(hlist, function(h) h$prior_samples) - prior_samples <- as.data.frame(do_call(cbind, prior_samples)) - names(samples) <- names(prior_samples) <- paste0("H", seq_along(hlist)) - class <- sub("_+$", "", class) - # TODO: rename 'samples' to 'draws' in brms 3.0 - out <- nlist(hypothesis = hs, samples, prior_samples, class, alpha) - structure(out, class = "brmshypothesis") -} - -# evaluate a single hypothesis based on the posterior draws -eval_hypothesis <- function(h, x, class, alpha, robust, name = NULL) { - stopifnot(length(h) == 1L && is.character(h)) - pars <- variables(x)[grepl(paste0("^", class), variables(x))] - # parse hypothesis string - h <- gsub("[ \t\r\n]", "", h) - sign <- get_matches("=|<|>", h) - lr <- get_matches("[^=<>]+", h) - if (length(sign) != 1L || length(lr) != 2L) { - stop2("Every hypothesis must be of the form 'left (= OR < OR >) right'.") - } - h <- paste0("(", lr[1], ")") - h <- paste0(h, ifelse(lr[2] != "0", paste0("-(", lr[2], ")"), "")) - varsH <- find_vars(h) - parsH <- paste0(class, varsH) - miss_pars <- setdiff(parsH, pars) - if (length(miss_pars)) { - miss_pars <- collapse_comma(miss_pars) - stop2("Some parameters cannot be found in the model: \n", miss_pars) - } - # rename hypothesis for correct evaluation - h_renamed <- rename(h, c(":", "[", "]", ","), c("___", ".", ".", "..")) - # get posterior and prior draws - pattern <- c(paste0("^", class), ":", "\\[", "\\]", ",") - repl <- c("", "___", ".", ".", "..") - samples <- as.data.frame(x, variable = parsH) - names(samples) <- rename(names(samples), pattern, repl, fixed = FALSE) - samples <- as.matrix(eval2(h_renamed, samples)) - prior_samples <- prior_draws(x, variable = parsH) - if (!is.null(prior_samples) && ncol(prior_samples) == length(varsH)) { - names(prior_samples) <- rename( - names(prior_samples), pattern, repl, fixed = FALSE - ) - prior_samples <- as.matrix(eval2(h_renamed, prior_samples)) - } else { - prior_samples <- NULL - } - # summarize hypothesis - wsign <- switch(sign, "=" = "equal", "<" = "less", ">" = "greater") - probs <- switch(sign, - "=" = c(alpha / 2, 1 - alpha / 2), - "<" = c(alpha, 1 - alpha), ">" = c(alpha, 1 - alpha) - ) - if (robust) { - measures <- c("median", "mad") - } else { - measures <- c("mean", "sd") - } - measures <- c(measures, "quantile", "evidence_ratio") - sm <- lapply( - measures, get_estimate, draws = samples, probs = probs, - wsign = wsign, prior_samples = prior_samples - ) - sm <- as.data.frame(matrix(unlist(sm), nrow = 1)) - names(sm) <- c("Estimate", "Est.Error", "CI.Lower", "CI.Upper", "Evid.Ratio") - sm$Post.Prob <- sm$Evid.Ratio / (1 + sm$Evid.Ratio) - if (is.infinite(sm$Evid.Ratio)) { - sm$Post.Prob <- 1 - } - if (sign == "=") { - sm$Star <- str_if(!(sm$CI.Lower <= 0 && 0 <= sm$CI.Upper), "*") - } else { - sm$Star <- str_if(sm$Post.Prob > 1 - alpha, "*") - } - if (!length(name) || !nzchar(name)) { - name <- paste(h, sign, "0") - } - sm$Hypothesis <- as_one_character(name) - sm <- move2start(sm, "Hypothesis") - if (is.null(prior_samples)) { - prior_samples <- as.matrix(rep(NA, nrow(samples))) - } - nlist(summary = sm, samples, prior_samples) -} - -# find all valid variable names in a string -# @param x a character string -# @param dot are dots allowed in variable names? -# @param brackets allow brackets at the end of variable names? -# @return all valid variable names within the string -# @note does not use the R parser itself to allow for double points, -# square brackets, and commas at the end of names -find_vars <- function(x, dot = TRUE, brackets = TRUE) { - x <- gsub("[[:space:]]", "", as_one_character(x)) - dot <- as_one_logical(dot) - brackets <- as_one_logical(brackets) - regex_all <- paste0( - "([^([:digit:]|[:punct:])]", if (dot) "|\\.", ")", - "[[:alnum:]_\\:", if (dot) "\\.", "]*", - if (brackets) "(\\[[^],]+(,[^],]+)*\\])?" - ) - pos_all <- gregexpr(regex_all, x)[[1]] - regex_fun <- paste0( - "([^([:digit:]|[:punct:])]", if (dot) "|\\.", ")", - "[[:alnum:]_", if (dot) "\\.", "]*\\(" - ) - pos_fun <- gregexpr(regex_fun, x)[[1]] - pos_decnum <- gregexpr("\\.[[:digit:]]+", x)[[1]] - keep <- !pos_all %in% c(pos_fun, pos_decnum) - pos_var <- pos_all[keep] - attr(pos_var, "match.length") <- attributes(pos_all)$match.length[keep] - if (length(pos_var)) { - out <- unique(unlist(regmatches(x, list(pos_var)))) - } else { - out <- character(0) - } - out -} - -#' Compute Density Ratios -#' -#' Compute the ratio of two densities at given points based on draws of the -#' corresponding distributions. -#' -#' @param x Vector of draws from the first distribution, usually the posterior -#' distribution of the quantity of interest. -#' @param y Optional vector of draws from the second distribution, usually the -#' prior distribution of the quantity of interest. If \code{NULL} (the -#' default), only the density of \code{x} will be evaluated. -#' @param point Numeric values at which to evaluate and compare the densities. -#' Defaults to \code{0}. -#' @param n Single numeric value. Influences the accuracy of the density -#' estimation. See \code{\link[stats:density]{density}} for details. -#' @param ... Further arguments passed to \code{\link[stats:density]{density}}. -#' -#' @return A vector of length equal to \code{length(point)}. If \code{y} is -#' provided, the density ratio of \code{x} against \code{y} is returned. Else, -#' only the density of \code{x} is returned. -#' -#' @details In order to achieve sufficient accuracy in the density estimation, -#' more draws than usual are required. That is you may need an effective -#' sample size of 10,000 or more to reliably estimate the densities. -#' -#' @examples -#' x <- rnorm(10000) -#' y <- rnorm(10000, mean = 1) -#' density_ratio(x, y, point = c(0, 1)) -#' -#' @export -density_ratio <- function(x, y = NULL, point = 0, n = 4096, ...) { - x <- as.numeric(x) - point <- as.numeric(point) - dots <- list(...) - dots <- dots[names(dots) %in% names(formals("density.default"))] - dots$n <- n - - eval_density <- function(x, point) { - # evaluate density of x at point - from <- min(x) - to <- max(x) - if (from > point) { - from <- point - sd(x) / 4 - } else if (to < point) { - to <- point + sd(x) / 4 - } - dens <- do_call(density, c(nlist(x, from, to), dots)) - return(spline(dens$x, dens$y, xout = point)$y) - } - - out <- ulapply(point, eval_density, x = x) - if (!is.null(y)) { - y <- as.numeric(y) - out <- out / ulapply(point, eval_density, x = y) - } - out -} - -# compute the evidence ratio between two disjunct hypotheses -# @param x posterior draws -# @param cut the cut point between the two hypotheses -# @param wsign direction of the hypothesis -# @param prior_samples optional prior draws for two-sided hypothesis -# @param ... optional arguments passed to density_ratio -# @return the evidence ratio of the two hypothesis -evidence_ratio <- function(x, cut = 0, wsign = c("equal", "less", "greater"), - prior_samples = NULL, ...) { - wsign <- match.arg(wsign) - if (wsign == "equal") { - if (is.null(prior_samples)) { - out <- NA - } else { - out <- density_ratio(x, prior_samples, point = cut, ...) - } - } else if (wsign == "less") { - out <- length(which(x < cut)) - out <- out / (length(x) - out) - } else if (wsign == "greater") { - out <- length(which(x > cut)) - out <- out / (length(x) - out) - } - out -} - -# round all numeric elements of a list-like object -round_numeric <- function(x, digits = 2) { - stopifnot(is.list(x)) - for (i in seq_along(x)) { - if (is.numeric(x[[i]])) { - x[[i]] <- round(x[[i]], digits = digits) - } - } - x -} - -#' @rdname brmshypothesis -#' @export -print.brmshypothesis <- function(x, digits = 2, chars = 20, ...) { - # make sure hypothesis names are not too long - x$hypothesis$Hypothesis <- limit_chars( - x$hypothesis$Hypothesis, chars = chars - ) - cat(paste0("Hypothesis Tests for class ", x$class, ":\n")) - x$hypothesis <- round_numeric(x$hypothesis, digits = digits) - print(x$hypothesis, quote = FALSE) - pone <- (1 - x$alpha * 2) * 100 - ptwo <- (1 - x$alpha) * 100 - cat(glue( - "---\n'CI': {pone}%-CI for one-sided and {ptwo}%-CI for two-sided hypotheses.\n", - "'*': For one-sided hypotheses, the posterior probability exceeds {ptwo}%;\n", - "for two-sided hypotheses, the value tested against lies outside the {ptwo}%-CI.\n", - "Posterior probabilities of point hypotheses assume equal prior probabilities.\n" - )) - invisible(x) -} - -#' @rdname brmshypothesis -#' @method plot brmshypothesis -#' @export -plot.brmshypothesis <- function(x, N = 5, ignore_prior = FALSE, - chars = 40, colors = NULL, - theme = NULL, ask = TRUE, - plot = TRUE, ...) { - dots <- list(...) - if (!is.data.frame(x$samples)) { - stop2("No posterior draws found.") - } - plot <- use_alias(plot, dots$do_plot) - if (is.null(colors)) { - colors <- bayesplot::color_scheme_get()[c(4, 2)] - colors <- unname(unlist(colors)) - } - if (length(colors) != 2L) { - stop2("Argument 'colors' must be of length 2.") - } - - .plot_fun <- function(samples) { - gg <- ggplot(samples, aes_string(x = "values")) + - facet_wrap("ind", ncol = 1, scales = "free") + - xlab("") + ylab("") + theme + - theme(axis.text.y = element_blank(), - axis.ticks.y = element_blank()) - if (ignore_prior) { - gg <- gg + - geom_density(alpha = 0.7, fill = colors[1], na.rm = TRUE) - } else { - gg <- gg + - geom_density(aes_string(fill = "Type"), alpha = 0.7, na.rm = TRUE) + - scale_fill_manual(values = colors) - } - return(gg) - } - - samples <- cbind(x$samples, Type = "Posterior") - if (!ignore_prior) { - prior_samples <- cbind(x$prior_samples, Type = "Prior") - samples <- rbind(samples, prior_samples) - } - if (plot) { - default_ask <- devAskNewPage() - on.exit(devAskNewPage(default_ask)) - devAskNewPage(ask = FALSE) - } - hyps <- limit_chars(x$hypothesis$Hypothesis, chars = chars) - names(samples)[seq_along(hyps)] <- hyps - nplots <- ceiling(length(hyps) / N) - plots <- vector(mode = "list", length = nplots) - for (i in seq_len(nplots)) { - rel_hyps <- hyps[((i - 1) * N + 1):min(i * N, length(hyps))] - sub_samples <- cbind( - utils::stack(samples[, rel_hyps, drop = FALSE]), - samples[, "Type", drop = FALSE] - ) - # make sure that parameters appear in the original order - sub_samples$ind <- with(sub_samples, factor(ind, levels = unique(ind))) - plots[[i]] <- .plot_fun(sub_samples) - if (plot) { - plot(plots[[i]]) - if (i == 1) devAskNewPage(ask = ask) - } - } - invisible(plots) -} +#' Non-Linear Hypothesis Testing +#' +#' Perform non-linear hypothesis testing for all model parameters. +#' +#' @param x An \code{R} object. If it is no \code{brmsfit} object, +#' it must be coercible to a \code{data.frame}. +#' In the latter case, the variables used in the \code{hypothesis} argument +#' need to correspond to column names of \code{x}, while the rows +#' are treated as representing posterior draws of the variables. +#' @param hypothesis A character vector specifying one or more +#' non-linear hypothesis concerning parameters of the model. +#' @param class A string specifying the class of parameters being tested. +#' Default is "b" for population-level effects. +#' Other typical options are "sd" or "cor". +#' If \code{class = NULL}, all parameters can be tested +#' against each other, but have to be specified with their full name +#' (see also \code{\link[brms:draws-index-brms]{variables}}) +#' @param group Name of a grouping factor to evaluate only +#' group-level effects parameters related to this grouping factor. +#' @param alpha The alpha-level of the tests (default is 0.05; +#' see 'Details' for more information). +#' @param robust If \code{FALSE} (the default) the mean is used as +#' the measure of central tendency and the standard deviation as +#' the measure of variability. If \code{TRUE}, the median and the +#' median absolute deviation (MAD) are applied instead. +#' @param scope Indicates where to look for the variables specified in +#' \code{hypothesis}. If \code{"standard"}, use the full parameter names +#' (subject to the restriction given by \code{class} and \code{group}). +#' If \code{"coef"} or \code{"ranef"}, compute the hypothesis for all levels +#' of the grouping factor given in \code{"group"}, based on the +#' output of \code{\link{coef.brmsfit}} and \code{\link{ranef.brmsfit}}, +#' respectively. +#' @param seed A single numeric value passed to \code{\link{set.seed}} +#' to make results reproducible. +#' @param ... Currently ignored. +#' +#' @details Among others, \code{hypothesis} computes an evidence ratio +#' (\code{Evid.Ratio}) for each hypothesis. For a one-sided hypothesis, this +#' is just the posterior probability (\code{Post.Prob}) under the hypothesis +#' against its alternative. That is, when the hypothesis is of the form +#' \code{a > b}, the evidence ratio is the ratio of the posterior probability +#' of \code{a > b} and the posterior probability of \code{a < b}. In this +#' example, values greater than one indicate that the evidence in favor of +#' \code{a > b} is larger than evidence in favor of \code{a < b}. For an +#' two-sided (point) hypothesis, the evidence ratio is a Bayes factor between +#' the hypothesis and its alternative computed via the Savage-Dickey density +#' ratio method. That is the posterior density at the point of interest +#' divided by the prior density at that point. Values greater than one +#' indicate that evidence in favor of the point hypothesis has increased after +#' seeing the data. In order to calculate this Bayes factor, all parameters +#' related to the hypothesis must have proper priors and argument +#' \code{sample_prior} of function \code{brm} must be set to \code{"yes"}. +#' Otherwise \code{Evid.Ratio} (and \code{Post.Prob}) will be \code{NA}. +#' Please note that, for technical reasons, we cannot sample from priors of +#' certain parameters classes. Most notably, these include overall intercept +#' parameters (prior class \code{"Intercept"}) as well as group-level +#' coefficients. When interpreting Bayes factors, make sure that your priors +#' are reasonable and carefully chosen, as the result will depend heavily on +#' the priors. In particular, avoid using default priors. +#' +#' The \code{Evid.Ratio} may sometimes be \code{0} or \code{Inf} implying very +#' small or large evidence, respectively, in favor of the tested hypothesis. +#' For one-sided hypotheses pairs, this basically means that all posterior +#' draws are on the same side of the value dividing the two hypotheses. In +#' that sense, instead of \code{0} or \code{Inf,} you may rather read it as +#' \code{Evid.Ratio} smaller \code{1 / S} or greater \code{S}, respectively, +#' where \code{S} denotes the number of posterior draws used in the +#' computations. +#' +#' The argument \code{alpha} specifies the size of the credible interval +#' (i.e., Bayesian confidence interval). For instance, if we tested a +#' two-sided hypothesis and set \code{alpha = 0.05} (5\%) an, the credible +#' interval will contain \code{1 - alpha = 0.95} (95\%) of the posterior +#' values. Hence, \code{alpha * 100}\% of the posterior values will +#' lie outside of the credible interval. Although this allows testing of +#' hypotheses in a similar manner as in the frequentist null-hypothesis +#' testing framework, we strongly argue against using arbitrary cutoffs (e.g., +#' \code{p < .05}) to determine the 'existence' of an effect. +#' +#' @return A \code{\link{brmshypothesis}} object. +#' +#' @seealso \code{\link{brmshypothesis}} +#' +#' @author Paul-Christian Buerkner \email{paul.buerkner@@gmail.com} +#' +#' @examples +#' \dontrun{ +#' ## define priors +#' prior <- c(set_prior("normal(0,2)", class = "b"), +#' set_prior("student_t(10,0,1)", class = "sigma"), +#' set_prior("student_t(10,0,1)", class = "sd")) +#' +#' ## fit a linear mixed effects models +#' fit <- brm(time ~ age + sex + disease + (1 + age|patient), +#' data = kidney, family = lognormal(), +#' prior = prior, sample_prior = "yes", +#' control = list(adapt_delta = 0.95)) +#' +#' ## perform two-sided hypothesis testing +#' (hyp1 <- hypothesis(fit, "sexfemale = age + diseasePKD")) +#' plot(hyp1) +#' hypothesis(fit, "exp(age) - 3 = 0", alpha = 0.01) +#' +#' ## perform one-sided hypothesis testing +#' hypothesis(fit, "diseasePKD + diseaseGN - 3 < 0") +#' +#' hypothesis(fit, "age < Intercept", +#' class = "sd", group = "patient") +#' +#' ## test the amount of random intercept variance on all variance +#' h <- paste("sd_patient__Intercept^2 / (sd_patient__Intercept^2 +", +#' "sd_patient__age^2 + sigma^2) = 0") +#' (hyp2 <- hypothesis(fit, h, class = NULL)) +#' plot(hyp2) +#' +#' ## test more than one hypothesis at once +#' h <- c("diseaseGN = diseaseAN", "2 * diseaseGN - diseasePKD = 0") +#' (hyp3 <- hypothesis(fit, h)) +#' plot(hyp3, ignore_prior = TRUE) +#' +#' ## compute hypotheses for all levels of a grouping factor +#' hypothesis(fit, "age = 0", scope = "coef", group = "patient") +#' +#' ## use the default method +#' dat <- as.data.frame(fit) +#' str(dat) +#' hypothesis(dat, "b_age > 0") +#' } +#' +#' @export +hypothesis.brmsfit <- function(x, hypothesis, class = "b", group = "", + scope = c("standard", "ranef", "coef"), + alpha = 0.05, robust = FALSE, seed = NULL, + ...) { + # use a seed as prior_draws.brmsfit randomly permutes draws + if (!is.null(seed)) { + set.seed(seed) + } + contains_draws(x) + x <- restructure(x) + group <- as_one_character(group) + scope <- match.arg(scope) + if (scope == "standard") { + if (!length(class)) { + class <- "" + } + class <- as_one_character(class) + if (nzchar(group)) { + class <- paste0(class, "_", group, "__") + } else if (nzchar(class)) { + class <- paste0(class, "_") + } + out <- .hypothesis( + x, hypothesis, class = class, alpha = alpha, + robust = robust, ... + ) + } else { + co <- do_call(scope, list(x, summary = FALSE)) + if (!group %in% names(co)) { + stop2("'group' should be one of ", collapse_comma(names(co))) + } + out <- hypothesis_coef( + co[[group]], hypothesis, alpha = alpha, + robust = robust, ... + ) + } + out +} + +#' @rdname hypothesis.brmsfit +#' @export +hypothesis <- function(x, ...) { + UseMethod("hypothesis") +} + +#' @rdname hypothesis.brmsfit +#' @export +hypothesis.default <- function(x, hypothesis, alpha = 0.05, + robust = FALSE, ...) { + x <- as.data.frame(x) + .hypothesis( + x, hypothesis, class = "", alpha = alpha, + robust = robust, ... + ) +} + +#' Descriptions of \code{brmshypothesis} Objects +#' +#' A \code{brmshypothesis} object contains posterior draws +#' as well as summary statistics of non-linear hypotheses as +#' returned by \code{\link{hypothesis}}. +#' +#' @name brmshypothesis +#' +#' @param ignore_prior A flag indicating if prior distributions +#' should also be plotted. Only used if priors were specified on +#' the relevant parameters. +#' @param digits Minimal number of significant digits, +#' see \code{\link[base:print.default]{print.default}}. +#' @param chars Maximum number of characters of each hypothesis +#' to print or plot. If \code{NULL}, print the full hypotheses. +#' Defaults to \code{20}. +#' @param colors Two values specifying the colors of the posterior +#' and prior density respectively. If \code{NULL} (the default) +#' colors are taken from the current color scheme of +#' the \pkg{bayesplot} package. +#' @param ... Currently ignored. +#' @inheritParams plot.brmsfit +#' +#' @details +#' The two most important elements of a \code{brmshypothesis} object are +#' \code{hypothesis}, which is a data.frame containing the summary estimates +#' of the hypotheses, and \code{samples}, which is a data.frame containing +#' the corresponding posterior draws. +#' +#' @seealso \code{\link{hypothesis}} +NULL + +# internal function to evaluate hypotheses +# @param x the primary object passed to the hypothesis method; +# needs to be a brmsfit object or coercible to a data.frame +# @param hypothesis vector of character strings containing the hypotheses +# @param class prefix of the parameters in the hypotheses +# @param alpha the 'alpha-level' as understood by frequentist statistics +# @return a 'brmshypothesis' object +.hypothesis <- function(x, hypothesis, class, alpha, robust, + combine = TRUE, ...) { + if (!is.character(hypothesis) || !length(hypothesis)) { + stop2("Argument 'hypothesis' must be a character vector.") + } + if (length(alpha) != 1L || alpha < 0 || alpha > 1) { + stop2("Argument 'alpha' must be a single value in [0,1].") + } + class <- as_one_character(class) + robust <- as_one_logical(robust) + out <- vector("list", length(hypothesis)) + for (i in seq_along(out)) { + out[[i]] <- eval_hypothesis( + hypothesis[i], x = x, class = class, + alpha = alpha, robust = robust, + name = names(hypothesis)[i] + ) + } + if (combine) { + out <- combine_hlist(out, class = class, alpha = alpha) + } + out +} + +# evaluate hypotheses for an arrary of ranefs or coefs +# seperaly for each grouping-factor level +hypothesis_coef <- function(x, hypothesis, alpha, ...) { + stopifnot(is.array(x), length(dim(x)) == 3L) + levels <- dimnames(x)[[2]] + coefs <- dimnames(x)[[3]] + x <- lapply(seq_along(levels), function(l) + structure(as.data.frame(x[, l, ]), names = coefs) + ) + out <- vector("list", length(levels)) + for (l in seq_along(levels)) { + out[[l]] <- .hypothesis( + x[[l]], hypothesis, class = "", + alpha = alpha, combine = FALSE, ... + ) + for (i in seq_along(out[[l]])) { + out[[l]][[i]]$summary$Group <- levels[l] + } + } + out <- unlist(out, recursive = FALSE) + out <- as.list(matrix(out, ncol = length(hypothesis), byrow = TRUE)) + out <- combine_hlist(out, class = "", alpha = alpha) + out$hypothesis$Group <- factor(out$hypothesis$Group, levels) + out$hypothesis <- move2start(out$hypothesis, "Group") + out +} + +# combine list of outputs of eval_hypothesis +# @param hlist list of evaluate hypothesis +# @return a 'brmshypothesis' object +combine_hlist <- function(hlist, class, alpha) { + stopifnot(is.list(hlist)) + hs <- do_call(rbind, lapply(hlist, function(h) h$summary)) + rownames(hs) <- NULL + samples <- lapply(hlist, function(h) h$samples) + samples <- as.data.frame(do_call(cbind, samples)) + prior_samples <- lapply(hlist, function(h) h$prior_samples) + prior_samples <- as.data.frame(do_call(cbind, prior_samples)) + names(samples) <- names(prior_samples) <- paste0("H", seq_along(hlist)) + class <- sub("_+$", "", class) + # TODO: rename 'samples' to 'draws' in brms 3.0 + out <- nlist(hypothesis = hs, samples, prior_samples, class, alpha) + structure(out, class = "brmshypothesis") +} + +# evaluate a single hypothesis based on the posterior draws +eval_hypothesis <- function(h, x, class, alpha, robust, name = NULL) { + stopifnot(length(h) == 1L && is.character(h)) + pars <- variables(x)[grepl(paste0("^", class), variables(x))] + # parse hypothesis string + h <- gsub("[ \t\r\n]", "", h) + sign <- get_matches("=|<|>", h) + lr <- get_matches("[^=<>]+", h) + if (length(sign) != 1L || length(lr) != 2L) { + stop2("Every hypothesis must be of the form 'left (= OR < OR >) right'.") + } + h <- paste0("(", lr[1], ")") + h <- paste0(h, ifelse(lr[2] != "0", paste0("-(", lr[2], ")"), "")) + varsH <- find_vars(h) + parsH <- paste0(class, varsH) + miss_pars <- setdiff(parsH, pars) + if (length(miss_pars)) { + miss_pars <- collapse_comma(miss_pars) + stop2("Some parameters cannot be found in the model: \n", miss_pars) + } + # rename hypothesis for correct evaluation + h_renamed <- rename(h, c(":", "[", "]", ","), c("___", ".", ".", "..")) + # get posterior and prior draws + pattern <- c(paste0("^", class), ":", "\\[", "\\]", ",") + repl <- c("", "___", ".", ".", "..") + samples <- as.data.frame(x, variable = parsH) + names(samples) <- rename(names(samples), pattern, repl, fixed = FALSE) + samples <- as.matrix(eval2(h_renamed, samples)) + prior_samples <- prior_draws(x, variable = parsH) + if (!is.null(prior_samples) && ncol(prior_samples) == length(varsH)) { + names(prior_samples) <- rename( + names(prior_samples), pattern, repl, fixed = FALSE + ) + prior_samples <- as.matrix(eval2(h_renamed, prior_samples)) + } else { + prior_samples <- NULL + } + # summarize hypothesis + wsign <- switch(sign, "=" = "equal", "<" = "less", ">" = "greater") + probs <- switch(sign, + "=" = c(alpha / 2, 1 - alpha / 2), + "<" = c(alpha, 1 - alpha), ">" = c(alpha, 1 - alpha) + ) + if (robust) { + measures <- c("median", "mad") + } else { + measures <- c("mean", "sd") + } + measures <- c(measures, "quantile", "evidence_ratio") + sm <- lapply( + measures, get_estimate, draws = samples, probs = probs, + wsign = wsign, prior_samples = prior_samples + ) + sm <- as.data.frame(matrix(unlist(sm), nrow = 1)) + names(sm) <- c("Estimate", "Est.Error", "CI.Lower", "CI.Upper", "Evid.Ratio") + sm$Post.Prob <- sm$Evid.Ratio / (1 + sm$Evid.Ratio) + if (is.infinite(sm$Evid.Ratio)) { + sm$Post.Prob <- 1 + } + if (sign == "=") { + sm$Star <- str_if(!(sm$CI.Lower <= 0 && 0 <= sm$CI.Upper), "*") + } else { + sm$Star <- str_if(sm$Post.Prob > 1 - alpha, "*") + } + if (!length(name) || !nzchar(name)) { + name <- paste(h, sign, "0") + } + sm$Hypothesis <- as_one_character(name) + sm <- move2start(sm, "Hypothesis") + if (is.null(prior_samples)) { + prior_samples <- as.matrix(rep(NA, nrow(samples))) + } + nlist(summary = sm, samples, prior_samples) +} + +# find all valid variable names in a string +# @param x a character string +# @param dot are dots allowed in variable names? +# @param brackets allow brackets at the end of variable names? +# @return all valid variable names within the string +# @note does not use the R parser itself to allow for double points, +# square brackets, and commas at the end of names +find_vars <- function(x, dot = TRUE, brackets = TRUE) { + x <- gsub("[[:space:]]", "", as_one_character(x)) + dot <- as_one_logical(dot) + brackets <- as_one_logical(brackets) + regex_all <- paste0( + "([^([:digit:]|[:punct:])]", if (dot) "|\\.", ")", + "[[:alnum:]_\\:", if (dot) "\\.", "]*", + if (brackets) "(\\[[^],]+(,[^],]+)*\\])?" + ) + pos_all <- gregexpr(regex_all, x)[[1]] + regex_fun <- paste0( + "([^([:digit:]|[:punct:])]", if (dot) "|\\.", ")", + "[[:alnum:]_", if (dot) "\\.", "]*\\(" + ) + pos_fun <- gregexpr(regex_fun, x)[[1]] + pos_decnum <- gregexpr("\\.[[:digit:]]+", x)[[1]] + keep <- !pos_all %in% c(pos_fun, pos_decnum) + pos_var <- pos_all[keep] + attr(pos_var, "match.length") <- attributes(pos_all)$match.length[keep] + if (length(pos_var)) { + out <- unique(unlist(regmatches(x, list(pos_var)))) + } else { + out <- character(0) + } + out +} + +#' Compute Density Ratios +#' +#' Compute the ratio of two densities at given points based on draws of the +#' corresponding distributions. +#' +#' @param x Vector of draws from the first distribution, usually the posterior +#' distribution of the quantity of interest. +#' @param y Optional vector of draws from the second distribution, usually the +#' prior distribution of the quantity of interest. If \code{NULL} (the +#' default), only the density of \code{x} will be evaluated. +#' @param point Numeric values at which to evaluate and compare the densities. +#' Defaults to \code{0}. +#' @param n Single numeric value. Influences the accuracy of the density +#' estimation. See \code{\link[stats:density]{density}} for details. +#' @param ... Further arguments passed to \code{\link[stats:density]{density}}. +#' +#' @return A vector of length equal to \code{length(point)}. If \code{y} is +#' provided, the density ratio of \code{x} against \code{y} is returned. Else, +#' only the density of \code{x} is returned. +#' +#' @details In order to achieve sufficient accuracy in the density estimation, +#' more draws than usual are required. That is you may need an effective +#' sample size of 10,000 or more to reliably estimate the densities. +#' +#' @examples +#' x <- rnorm(10000) +#' y <- rnorm(10000, mean = 1) +#' density_ratio(x, y, point = c(0, 1)) +#' +#' @export +density_ratio <- function(x, y = NULL, point = 0, n = 4096, ...) { + x <- as.numeric(x) + point <- as.numeric(point) + dots <- list(...) + dots <- dots[names(dots) %in% names(formals("density.default"))] + dots$n <- n + + eval_density <- function(x, point) { + # evaluate density of x at point + from <- min(x) + to <- max(x) + if (from > point) { + from <- point - sd(x) / 4 + } else if (to < point) { + to <- point + sd(x) / 4 + } + dens <- do_call(density, c(nlist(x, from, to), dots)) + return(spline(dens$x, dens$y, xout = point)$y) + } + + out <- ulapply(point, eval_density, x = x) + if (!is.null(y)) { + y <- as.numeric(y) + out <- out / ulapply(point, eval_density, x = y) + } + out +} + +# compute the evidence ratio between two disjunct hypotheses +# @param x posterior draws +# @param cut the cut point between the two hypotheses +# @param wsign direction of the hypothesis +# @param prior_samples optional prior draws for two-sided hypothesis +# @param ... optional arguments passed to density_ratio +# @return the evidence ratio of the two hypothesis +evidence_ratio <- function(x, cut = 0, wsign = c("equal", "less", "greater"), + prior_samples = NULL, ...) { + wsign <- match.arg(wsign) + if (wsign == "equal") { + if (is.null(prior_samples)) { + out <- NA + } else { + out <- density_ratio(x, prior_samples, point = cut, ...) + } + } else if (wsign == "less") { + out <- length(which(x < cut)) + out <- out / (length(x) - out) + } else if (wsign == "greater") { + out <- length(which(x > cut)) + out <- out / (length(x) - out) + } + out +} + +# round all numeric elements of a list-like object +round_numeric <- function(x, digits = 2) { + stopifnot(is.list(x)) + for (i in seq_along(x)) { + if (is.numeric(x[[i]])) { + x[[i]] <- round(x[[i]], digits = digits) + } + } + x +} + +#' @rdname brmshypothesis +#' @export +print.brmshypothesis <- function(x, digits = 2, chars = 20, ...) { + # make sure hypothesis names are not too long + x$hypothesis$Hypothesis <- limit_chars( + x$hypothesis$Hypothesis, chars = chars + ) + cat(paste0("Hypothesis Tests for class ", x$class, ":\n")) + x$hypothesis <- round_numeric(x$hypothesis, digits = digits) + print(x$hypothesis, quote = FALSE) + pone <- (1 - x$alpha * 2) * 100 + ptwo <- (1 - x$alpha) * 100 + cat(glue( + "---\n'CI': {pone}%-CI for one-sided and {ptwo}%-CI for two-sided hypotheses.\n", + "'*': For one-sided hypotheses, the posterior probability exceeds {ptwo}%;\n", + "for two-sided hypotheses, the value tested against lies outside the {ptwo}%-CI.\n", + "Posterior probabilities of point hypotheses assume equal prior probabilities.\n" + )) + invisible(x) +} + +#' @rdname brmshypothesis +#' @method plot brmshypothesis +#' @export +plot.brmshypothesis <- function(x, N = 5, ignore_prior = FALSE, + chars = 40, colors = NULL, + theme = NULL, ask = TRUE, + plot = TRUE, ...) { + dots <- list(...) + if (!is.data.frame(x$samples)) { + stop2("No posterior draws found.") + } + plot <- use_alias(plot, dots$do_plot) + if (is.null(colors)) { + colors <- bayesplot::color_scheme_get()[c(4, 2)] + colors <- unname(unlist(colors)) + } + if (length(colors) != 2L) { + stop2("Argument 'colors' must be of length 2.") + } + + .plot_fun <- function(samples) { + gg <- ggplot(samples, aes_string(x = "values")) + + facet_wrap("ind", ncol = 1, scales = "free") + + xlab("") + ylab("") + theme + + theme(axis.text.y = element_blank(), + axis.ticks.y = element_blank()) + if (ignore_prior) { + gg <- gg + + geom_density(alpha = 0.7, fill = colors[1], na.rm = TRUE) + } else { + gg <- gg + + geom_density(aes_string(fill = "Type"), alpha = 0.7, na.rm = TRUE) + + scale_fill_manual(values = colors) + } + return(gg) + } + + samples <- cbind(x$samples, Type = "Posterior") + if (!ignore_prior) { + prior_samples <- cbind(x$prior_samples, Type = "Prior") + samples <- rbind(samples, prior_samples) + } + if (plot) { + default_ask <- devAskNewPage() + on.exit(devAskNewPage(default_ask)) + devAskNewPage(ask = FALSE) + } + hyps <- limit_chars(x$hypothesis$Hypothesis, chars = chars) + names(samples)[seq_along(hyps)] <- hyps + nplots <- ceiling(length(hyps) / N) + plots <- vector(mode = "list", length = nplots) + for (i in seq_len(nplots)) { + rel_hyps <- hyps[((i - 1) * N + 1):min(i * N, length(hyps))] + sub_samples <- cbind( + utils::stack(samples[, rel_hyps, drop = FALSE]), + samples[, "Type", drop = FALSE] + ) + # make sure that parameters appear in the original order + sub_samples$ind <- with(sub_samples, factor(ind, levels = unique(ind))) + plots[[i]] <- .plot_fun(sub_samples) + if (plot) { + plot(plots[[i]]) + if (i == 1) devAskNewPage(ask = ask) + } + } + invisible(plots) +} diff -Nru r-cran-brms-2.16.3/R/kfold.R r-cran-brms-2.17.0/R/kfold.R --- r-cran-brms-2.16.3/R/kfold.R 2021-10-28 18:32:05.000000000 +0000 +++ r-cran-brms-2.17.0/R/kfold.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,11 +1,11 @@ #' K-Fold Cross-Validation -#' +#' #' Perform exact K-fold cross-validation by refitting the model \eqn{K} #' times each leaving out one-\eqn{K}th of the original data. #' Folds can be run in parallel using the \pkg{future} package. -#' +#' #' @aliases kfold -#' +#' #' @inheritParams loo.brmsfit #' @param K The number of subsets of equal (if possible) size #' into which the data will be partitioned for performing @@ -13,13 +13,13 @@ #' leaving out one of the \code{K} subsets. If \code{K} is equal to the total #' number of observations in the data then \eqn{K}-fold cross-validation is #' equivalent to exact leave-one-out cross-validation. -#' @param Ksub Optional number of subsets (of those subsets defined by \code{K}) -#' to be evaluated. If \code{NULL} (the default), \eqn{K}-fold cross-validation -#' will be performed on all subsets. If \code{Ksub} is a single integer, +#' @param Ksub Optional number of subsets (of those subsets defined by \code{K}) +#' to be evaluated. If \code{NULL} (the default), \eqn{K}-fold cross-validation +#' will be performed on all subsets. If \code{Ksub} is a single integer, #' \code{Ksub} subsets (out of all \code{K}) subsets will be randomly chosen. #' If \code{Ksub} consists of multiple integers or a one-dimensional array -#' (created via \code{as.array}) potentially of length one, the corresponding -#' subsets will be used. This argument is primarily useful, if evaluation of +#' (created via \code{as.array}) potentially of length one, the corresponding +#' subsets will be used. This argument is primarily useful, if evaluation of #' all subsets is infeasible for some reason. #' @param folds Determines how the subsets are being constructed. #' Possible values are \code{NULL} (the default), \code{"stratified"}, @@ -31,52 +31,55 @@ #' What exactly is done with this variable depends on argument \code{folds}. #' More information is provided in the 'Details' section. #' @param exact_loo Deprecated! Please use \code{folds = "loo"} instead. -#' @param save_fits If \code{TRUE}, a component \code{fits} is added to -#' the returned object to store the cross-validated \code{brmsfit} -#' objects and the indices of the omitted observations for each fold. +#' @param save_fits If \code{TRUE}, a component \code{fits} is added to +#' the returned object to store the cross-validated \code{brmsfit} +#' objects and the indices of the omitted observations for each fold. #' Defaults to \code{FALSE}. -#' -#' @return \code{kfold} returns an object that has a similar structure as the +#' @param future_args A list of further arguments passed to +#' \code{\link[future:future]{future}} for additional control over parallel +#' execution if activated. +#' +#' @return \code{kfold} returns an object that has a similar structure as the #' objects returned by the \code{loo} and \code{waic} methods and #' can be used with the same post-processing functions. -#' +#' #' @details The \code{kfold} function performs exact \eqn{K}-fold -#' cross-validation. First the data are partitioned into \eqn{K} folds -#' (i.e. subsets) of equal (or as close to equal as possible) size by default. -#' Then the model is refit \eqn{K} times, each time leaving out one of the -#' \code{K} subsets. If \eqn{K} is equal to the total number of observations -#' in the data then \eqn{K}-fold cross-validation is equivalent to exact -#' leave-one-out cross-validation (to which \code{loo} is an efficient -#' approximation). The \code{compare_ic} function is also compatible with +#' cross-validation. First the data are partitioned into \eqn{K} folds +#' (i.e. subsets) of equal (or as close to equal as possible) size by default. +#' Then the model is refit \eqn{K} times, each time leaving out one of the +#' \code{K} subsets. If \eqn{K} is equal to the total number of observations +#' in the data then \eqn{K}-fold cross-validation is equivalent to exact +#' leave-one-out cross-validation (to which \code{loo} is an efficient +#' approximation). The \code{compare_ic} function is also compatible with #' the objects returned by \code{kfold}. -#' -#' The subsets can be constructed in multiple different ways: +#' +#' The subsets can be constructed in multiple different ways: #' \itemize{ -#' \item If both \code{folds} and \code{group} are \code{NULL}, the subsets -#' are randomly chosen so that they have equal (or as close to equal as -#' possible) size. -#' \item If \code{folds} is \code{NULL} but \code{group} is specified, the -#' data is split up into subsets, each time omitting all observations of one -#' of the factor levels, while ignoring argument \code{K}. -#' \item If \code{folds = "stratified"} the subsets are stratified after +#' \item If both \code{folds} and \code{group} are \code{NULL}, the subsets +#' are randomly chosen so that they have equal (or as close to equal as +#' possible) size. +#' \item If \code{folds} is \code{NULL} but \code{group} is specified, the +#' data is split up into subsets, each time omitting all observations of one +#' of the factor levels, while ignoring argument \code{K}. +#' \item If \code{folds = "stratified"} the subsets are stratified after #' \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_stratified}}. #' \item If \code{folds = "grouped"} the subsets are split by #' \code{group} using \code{\link[loo:kfold-helpers]{loo::kfold_split_grouped}}. #' \item If \code{folds = "loo"} exact leave-one-out cross-validation #' will be performed and \code{K} will be ignored. Further, if \code{group} -#' is specified, all observations corresponding to the factor level of the -#' currently predicted single value are omitted. Thus, in this case, the +#' is specified, all observations corresponding to the factor level of the +#' currently predicted single value are omitted. Thus, in this case, the #' predicted values are only a subset of the omitted ones. -#' \item If \code{folds} is a numeric vector, it must contain one element per -#' observation in the data. Each element of the vector is an integer in -#' \code{1:K} indicating to which of the \code{K} folds the corresponding -#' observation belongs. There are some convenience functions available in -#' the \pkg{loo} package that create integer vectors to use for this purpose -#' (see the Examples section below and also the +#' \item If \code{folds} is a numeric vector, it must contain one element per +#' observation in the data. Each element of the vector is an integer in +#' \code{1:K} indicating to which of the \code{K} folds the corresponding +#' observation belongs. There are some convenience functions available in +#' the \pkg{loo} package that create integer vectors to use for this purpose +#' (see the Examples section below and also the #' \link[loo:kfold-helpers]{kfold-helpers} page). #' } -#' -#' @examples +#' +#' @examples #' \dontrun{ #' fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), #' data = epilepsy, family = poisson()) @@ -84,21 +87,22 @@ #' (loo1 <- loo(fit1)) #' # perform 10-fold cross validation #' (kfold1 <- kfold(fit1, chains = 1)) -#' +#' #' # use the future package for parallelization #' library(future) #' plan(multiprocess) #' kfold(fit1, chains = 1) -#' } -#' +#' } +#' #' @seealso \code{\link{loo}}, \code{\link{reloo}} -#' +#' #' @importFrom loo kfold #' @export kfold #' @export -kfold.brmsfit <- function(x, ..., K = 10, Ksub = NULL, folds = NULL, +kfold.brmsfit <- function(x, ..., K = 10, Ksub = NULL, folds = NULL, group = NULL, exact_loo = NULL, compare = TRUE, - resp = NULL, model_names = NULL, save_fits = FALSE) { + resp = NULL, model_names = NULL, save_fits = FALSE, + future_args = list()) { args <- split_dots(x, ..., model_names = model_names) use_stored <- ulapply(args$models, function(x) is_equal(x$kfold$K, K)) if (!is.null(exact_loo) && as_one_logical(exact_loo)) { @@ -106,8 +110,8 @@ folds <- "loo" } c(args) <- nlist( - criterion = "kfold", K, Ksub, folds, group, - compare, resp, save_fits, use_stored + criterion = "kfold", K, Ksub, folds, group, + compare, resp, save_fits, future_args, use_stored ) do_call(compute_loolist, args) } @@ -116,9 +120,9 @@ # @inheritParams kfold.brmsfit # @param model_name ignored but included to avoid being passed to '...' .kfold <- function(x, K, Ksub, folds, group, save_fits, - newdata, resp, model_name, + newdata, resp, model_name, future_args = list(), newdata2 = NULL, ...) { - stopifnot(is.brmsfit(x)) + stopifnot(is.brmsfit(x), is.list(future_args)) if (is.brmsfit_multiple(x)) { warn_brmsfit_multiple(x) class(x) <- "brmsfit" @@ -197,7 +201,7 @@ } Ksub <- sort(Ksub) } - + # split dots for use in log_lik and update dots <- list(...) ll_arg_names <- arg_names("log_lik") @@ -207,7 +211,7 @@ ll_args$combine <- TRUE up_args <- dots[setdiff(names(dots), ll_arg_names)] up_args$refresh <- 0 - + # function to be run inside future::future .kfold_k <- function(k) { if (fold_type == "loo" && !is.null(group)) { @@ -230,21 +234,22 @@ if (save_fits) out$fit <- fit return(out) } - + futures <- vector("list", length(Ksub)) lppds <- obs_order <- vector("list", length(Ksub)) if (save_fits) { fits <- array(list(), dim = c(length(Ksub), 3)) dimnames(fits) <- list(NULL, c("fit", "omitted", "predicted")) } - + x <- recompile_model(x) + future_args$FUN <- .kfold_k + future_args$seed <- TRUE for (k in Ksub) { ks <- match(k, Ksub) message("Fitting model ", k, " out of ", K) - futures[[ks]] <- future::future( - .kfold_k(k), packages = "brms", seed = TRUE - ) + future_args$args <- list(k) + futures[[ks]] <- do_call("futureCall", future_args, pkg = "future") } for (k in Ksub) { ks <- match(k, Ksub) @@ -255,7 +260,7 @@ obs_order[[ks]] <- tmp$predicted lppds[[ks]] <- tmp$lppds } - + lppds <- do_call(cbind, lppds) elpds <- apply(lppds, 2, log_mean_exp) # make sure elpds are put back in the right order @@ -285,52 +290,52 @@ } #' Predictions from K-Fold Cross-Validation -#' -#' Compute and evaluate predictions after performing K-fold -#' cross-validation via \code{\link{kfold}}. -#' +#' +#' Compute and evaluate predictions after performing K-fold +#' cross-validation via \code{\link{kfold}}. +#' #' @param x Object of class \code{'kfold'} computed by \code{\link{kfold}}. #' For \code{kfold_predict} to work, the fitted model objects need to have #' been stored via argument \code{save_fits} of \code{\link{kfold}}. #' @param method The method used to make predictions. Either \code{"predict"} #' or \code{"fitted"}. See \code{\link{predict.brmsfit}} for details. #' @inheritParams predict.brmsfit -#' +#' #' @return A \code{list} with two slots named \code{'y'} and \code{'yrep'}. #' Slot \code{y} contains the vector of observed responses. #' Slot \code{yrep} contains the matrix of predicted responses, #' with rows being posterior draws and columns being observations. -#' +#' #' @seealso \code{\link{kfold}} -#' -#' @examples +#' +#' @examples #' \dontrun{ #' fit <- brm(count ~ zBase * Trt + (1|patient), #' data = epilepsy, family = poisson()) -#' +#' #' # perform k-fold cross validation #' (kf <- kfold(fit, save_fits = TRUE, chains = 1)) -#' +#' #' # define a loss function #' rmse <- function(y, yrep) { #' yrep_mean <- colMeans(yrep) #' sqrt(mean((yrep_mean - y)^2)) #' } -#' +#' #' # predict responses and evaluate the loss #' kfp <- kfold_predict(kf) #' rmse(y = kfp$y, yrep = kfp$yrep) #' } -#' +#' #' @export -kfold_predict <- function(x, method = c("predict", "fitted"), +kfold_predict <- function(x, method = c("predict", "fitted"), resp = NULL, ...) { if (!inherits(x, "kfold")) { stop2("'x' must be a 'kfold' object.") } if (!all(c("fits", "data") %in% names(x))) { stop2( - "Slots 'fits' and 'data' are required. ", + "Slots 'fits' and 'data' are required. ", "Please run kfold with 'save_fits = TRUE'." ) } @@ -349,7 +354,7 @@ newdata <- x$data[predicted_k, , drop = FALSE] y[obs_names] <- get_y(fit_k, resp, newdata = newdata, ...) yrep[, obs_names] <- method( - fit_k, newdata = newdata, resp = resp, + fit_k, newdata = newdata, resp = resp, allow_new_levels = TRUE, summary = FALSE, ... ) } diff -Nru r-cran-brms-2.16.3/R/launch_shinystan.R r-cran-brms-2.17.0/R/launch_shinystan.R --- r-cran-brms-2.16.3/R/launch_shinystan.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/launch_shinystan.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,57 +1,59 @@ -#' Interface to \pkg{shinystan} -#' -#' Provide an interface to \pkg{shinystan} for models fitted with \pkg{brms} -#' -#' @aliases launch_shinystan -#' -#' @param object A fitted model object typically of class \code{brmsfit}. -#' @param rstudio Only relevant for RStudio users. -#' The default (\code{rstudio=FALSE}) is to launch the app -#' in the default web browser rather than RStudio's pop-up Viewer. -#' Users can change the default to \code{TRUE} -#' by setting the global option \cr \code{options(shinystan.rstudio = TRUE)}. -#' @param ... Optional arguments to pass to \code{\link[shiny:runApp]{runApp}} -#' -#' @return An S4 shinystan object -#' -#' @examples -#' \dontrun{ -#' fit <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler, family = "gaussian") -#' launch_shinystan(fit) -#' } -#' -#' @seealso \code{\link[shinystan:launch_shinystan]{launch_shinystan}} -#' -#' @method launch_shinystan brmsfit -#' @importFrom shinystan launch_shinystan -#' @export launch_shinystan -#' @export -launch_shinystan.brmsfit <- function( - object, rstudio = getOption("shinystan.rstudio"), ... -) { - contains_draws(object) - if (object$algorithm != "sampling") { - return(shinystan::launch_shinystan(object$fit, rstudio = rstudio, ...)) - } - draws <- as.array(object) - sampler_params <- rstan::get_sampler_params(object$fit, inc_warmup = FALSE) - control <- object$fit@stan_args[[1]]$control - if (is.null(control)) { - max_td <- 10 - } else { - max_td <- control$max_treedepth - if (is.null(max_td)) { - max_td <- 10 - } - } - sso <- shinystan::as.shinystan( - X = draws, - model_name = object$fit@model_name, - warmup = 0, - sampler_params = sampler_params, - max_treedepth = max_td, - algorithm = "NUTS" - ) - shinystan::launch_shinystan(sso, rstudio = rstudio, ...) -} +#' Interface to \pkg{shinystan} +#' +#' Provide an interface to \pkg{shinystan} for models fitted with \pkg{brms} +#' +#' @aliases launch_shinystan +#' +#' @param object A fitted model object typically of class \code{brmsfit}. +#' @param rstudio Only relevant for RStudio users. +#' The default (\code{rstudio=FALSE}) is to launch the app +#' in the default web browser rather than RStudio's pop-up Viewer. +#' Users can change the default to \code{TRUE} +#' by setting the global option \cr \code{options(shinystan.rstudio = TRUE)}. +#' @param ... Optional arguments to pass to \code{\link[shiny:runApp]{runApp}} +#' +#' @return An S4 shinystan object +#' +#' @examples +#' \dontrun{ +#' fit <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler, family = "gaussian") +#' launch_shinystan(fit) +#' } +#' +#' @seealso \code{\link[shinystan:launch_shinystan]{launch_shinystan}} +#' +#' @method launch_shinystan brmsfit +#' @importFrom shinystan launch_shinystan +#' @export launch_shinystan +#' @export +launch_shinystan.brmsfit <- function( + object, rstudio = getOption("shinystan.rstudio"), ... +) { + contains_draws(object) + if (object$algorithm != "sampling") { + return(shinystan::launch_shinystan(object$fit, rstudio = rstudio, ...)) + } + inc_warmup <- isTRUE(object$fit@sim$n_save[1] > niterations(object)) + draws <- as.array(object, inc_warmup = inc_warmup) + warmup <- if (inc_warmup) nwarmup(object) else 0 + sampler_params <- rstan::get_sampler_params(object$fit, inc_warmup = inc_warmup) + control <- object$fit@stan_args[[1]]$control + if (is.null(control)) { + max_td <- 10 + } else { + max_td <- control$max_treedepth + if (is.null(max_td)) { + max_td <- 10 + } + } + sso <- shinystan::as.shinystan( + X = draws, + model_name = object$fit@model_name, + warmup = warmup, + sampler_params = sampler_params, + max_treedepth = max_td, + algorithm = "NUTS" + ) + shinystan::launch_shinystan(sso, rstudio = rstudio, ...) +} diff -Nru r-cran-brms-2.16.3/R/log_lik.R r-cran-brms-2.17.0/R/log_lik.R --- r-cran-brms-2.16.3/R/log_lik.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/log_lik.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,1010 +1,1044 @@ -#' Compute the Pointwise Log-Likelihood -#' -#' @aliases log_lik logLik.brmsfit -#' -#' @param object A fitted model object of class \code{brmsfit}. -#' @inheritParams posterior_predict.brmsfit -#' @param combine Only relevant in multivariate models. -#' Indicates if the log-likelihoods of the submodels should -#' be combined per observation (i.e. added together; the default) -#' or if the log-likelihoods should be returned separately. -#' @param pointwise A flag indicating whether to compute the full -#' log-likelihood matrix at once (the default), or just return -#' the likelihood function along with all data and draws -#' required to compute the log-likelihood separately for each -#' observation. The latter option is rarely useful when -#' calling \code{log_lik} directly, but rather when computing -#' \code{\link{waic}} or \code{\link{loo}}. -#' @param add_point_estimate For internal use only. Ensures compatibility -#' with the \code{\link{loo_subsample}} method. -#' -#' @return Usually, an S x N matrix containing the pointwise log-likelihood -#' draws, where S is the number of draws and N is the number -#' of observations in the data. For multivariate models and if -#' \code{combine} is \code{FALSE}, an S x N x R array is returned, -#' where R is the number of response variables. -#' If \code{pointwise = TRUE}, the output is a function -#' with a \code{draws} attribute containing all relevant -#' data and posterior draws. -#' -#' @template details-newdata-na -#' @template details-allow_new_levels -#' -#' @aliases log_lik -#' @method log_lik brmsfit -#' @export -#' @export log_lik -#' @importFrom rstantools log_lik -log_lik.brmsfit <- function(object, newdata = NULL, re_formula = NULL, - resp = NULL, ndraws = NULL, draw_ids = NULL, - pointwise = FALSE, combine = TRUE, - add_point_estimate = FALSE, - cores = NULL, ...) { - pointwise <- as_one_logical(pointwise) - combine <- as_one_logical(combine) - add_point_estimate <- as_one_logical(add_point_estimate) - contains_draws(object) - object <- restructure(object) - prep <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = TRUE, ... - ) - if (add_point_estimate) { - # required for the loo_subsample method - # Computing a point estimate based on the full prep object is too - # difficult due to its highly nested structure. As an alternative, a second - # prep object is created from the point estimates of the draws directly. - attr(prep, "point_estimate") <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = TRUE, - point_estimate = "median", ... - ) - } - if (pointwise) { - stopifnot(combine) - log_lik <- log_lik_pointwise - # names need to be 'data' and 'draws' as per ?loo::loo.function - attr(log_lik, "data") <- data.frame(i = seq_len(choose_N(prep))) - attr(log_lik, "draws") <- prep - } else { - log_lik <- log_lik(prep, combine = combine, cores = cores) - if (anyNA(log_lik)) { - warning2( - "NAs were found in the log-likelihood. Possibly this is because ", - "some of your responses contain NAs. If you use 'mi' terms, try ", - "setting 'resp' to those response variables without missing values. ", - "Alternatively, use 'newdata' to predict only complete cases." - ) - } - } - log_lik -} - -#' @export -logLik.brmsfit <- function(object, newdata = NULL, re_formula = NULL, - resp = NULL, ndraws = NULL, draw_ids = NULL, - pointwise = FALSE, combine = TRUE, - cores = NULL, ...) { - cl <- match.call() - cl[[1]] <- quote(log_lik) - eval(cl, parent.frame()) -} - -#' @export -log_lik.mvbrmsprep <- function(object, combine = TRUE, ...) { - if (length(object$mvpars$rescor)) { - object$mvpars$Mu <- get_Mu(object) - object$mvpars$Sigma <- get_Sigma(object) - out <- log_lik.brmsprep(object, ...) - } else { - out <- lapply(object$resps, log_lik, ...) - if (combine) { - out <- Reduce("+", out) - } else { - along <- ifelse(length(out) > 1L, 3, 2) - out <- do_call(abind, c(out, along = along)) - } - } - out -} - -#' @export -log_lik.brmsprep <- function(object, cores = NULL, ...) { - cores <- validate_cores_post_processing(cores) - log_lik_fun <- paste0("log_lik_", object$family$fun) - log_lik_fun <- get(log_lik_fun, asNamespace("brms")) - if (is.customfamily(object$family)) { - # ensure that the method can be found during parallel execution - object$family$log_lik <- custom_family_method(object$family, "log_lik") - } - for (nlp in names(object$nlpars)) { - object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) - } - for (dp in names(object$dpars)) { - object$dpars[[dp]] <- get_dpar(object, dpar = dp) - } - N <- choose_N(object) - out <- plapply(seq_len(N), log_lik_fun, cores = cores, prep = object) - out <- do_call(cbind, out) - colnames(out) <- NULL - old_order <- object$old_order - sort <- isTRUE(ncol(out) != length(old_order)) - reorder_obs(out, old_order, sort = sort) -} - -# evaluate log_lik in a pointwise manner -# cannot be an S3 method since 'data_i' must be the first argument -# names must be 'data_i' and 'draws' as per ?loo::loo.function -log_lik_pointwise <- function(data_i, draws, ...) { - i <- data_i$i - if (is.mvbrmsprep(draws) && !length(draws$mvpars$rescor)) { - out <- lapply(draws$resps, log_lik_pointwise, i = i) - out <- Reduce("+", out) - } else { - log_lik_fun <- paste0("log_lik_", draws$family$fun) - log_lik_fun <- get(log_lik_fun, asNamespace("brms")) - out <- log_lik_fun(i, draws) - } - out -} - -# All log_lik_ functions have the same arguments structure -# @param i index of the observatio for which to compute log-lik values -# @param prep A named list returned by prepare_predictions containing -# all required data and posterior draws -# @return a vector of length prep$ndraws containing the pointwise -# log-likelihood for the ith observation -log_lik_gaussian <- function(i, prep) { - mu <- get_dpar(prep, "mu", i = i) - sigma <- get_dpar(prep, "sigma", i = i) - sigma <- add_sigma_se(sigma, prep, i = i) - args <- list(mean = mu, sd = sigma) - # log_lik_censor computes the conventional log_lik in case of no censoring - out <- log_lik_censor(dist = "norm", args = args, i = i, prep = prep) - out <- log_lik_truncate( - out, cdf = pnorm, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_student <- function(i, prep) { - nu <- get_dpar(prep, "nu", i = i) - mu <- get_dpar(prep, "mu", i = i) - sigma <- get_dpar(prep, "sigma", i = i) - sigma <- add_sigma_se(sigma, prep, i = i) - args <- list(df = nu, mu = mu, sigma = sigma) - out <- log_lik_censor( - dist = "student_t", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pstudent_t, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_lognormal <- function(i, prep) { - sigma <- get_dpar(prep, "sigma", i = i) - args <- list(meanlog = get_dpar(prep, "mu", i), sdlog = sigma) - out <- log_lik_censor(dist = "lnorm", args = args, i = i, prep = prep) - out <- log_lik_truncate( - out, cdf = plnorm, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_shifted_lognormal <- function(i, prep) { - sigma <- get_dpar(prep, "sigma", i = i) - ndt <- get_dpar(prep, "ndt", i = i) - args <- list(meanlog = get_dpar(prep, "mu", i), sdlog = sigma, shift = ndt) - out <- log_lik_censor("shifted_lnorm", args, i = i, prep = prep) - out <- log_lik_truncate(out, pshifted_lnorm, args, i = i, prep = prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_skew_normal <- function(i, prep) { - mu <- get_dpar(prep, "mu", i) - sigma <- get_dpar(prep, "sigma", i = i) - sigma <- add_sigma_se(sigma, prep, i = i) - alpha <- get_dpar(prep, "alpha", i = i) - args <- nlist(mu, sigma, alpha) - out <- log_lik_censor( - dist = "skew_normal", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pskew_normal, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_gaussian_mv <- function(i, prep) { - Mu <- get_Mu(prep, i = i) - Sigma <- get_Sigma(prep, i = i) - dmn <- function(s) { - dmulti_normal( - prep$data$Y[i, ], mu = Mu[s, ], - Sigma = Sigma[s, , ], log = TRUE - ) - } - out <- sapply(1:prep$ndraws, dmn) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_student_mv <- function(i, prep) { - nu <- get_dpar(prep, "nu", i = i) - Mu <- get_Mu(prep, i = i) - Sigma <- get_Sigma(prep, i = i) - dmst <- function(s) { - dmulti_student_t( - prep$data$Y[i, ], df = nu[s], mu = Mu[s, ], - Sigma = Sigma[s, , ], log = TRUE - ) - } - out <- sapply(1:prep$ndraws, dmst) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_gaussian_time <- function(i, prep) { - obs <- with(prep$ac, begin_tg[i]:end_tg[i]) - Y <- as.numeric(prep$data$Y[obs]) - mu <- as.matrix(get_dpar(prep, "mu", i = obs)) - Sigma <- get_cov_matrix_ac(prep, obs) - .log_lik <- function(s) { - C <- as.matrix(Sigma[s, , ]) - Cinv <- solve(C) - e <- Y - mu[s, ] - g <- solve(C, e) - cbar <- diag(Cinv) - yloo <- Y - g / cbar - sdloo <- sqrt(1 / cbar) - ll <- dnorm(Y, yloo, sdloo, log = TRUE) - return(as.numeric(ll)) - } - rblapply(seq_len(prep$ndraws), .log_lik) -} - -log_lik_student_time <- function(i, prep) { - obs <- with(prep$ac, begin_tg[i]:end_tg[i]) - Y <- as.numeric(prep$data$Y[obs]) - nu <- as.matrix(get_dpar(prep, "nu", i = obs)) - mu <- as.matrix(get_dpar(prep, "mu", i = obs)) - Sigma <- get_cov_matrix_ac(prep, obs) - .log_lik <- function(s) { - df <- nu[s, ] - C <- as.matrix(Sigma[s, , ]) - Cinv <- solve(C) - e <- Y - mu[s, ] - g <- solve(C, e) - cbar <- diag(Cinv) - yloo <- Y - g / cbar - sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, Cinv, e)) - dfloo <- df + nrow(Cinv) - 1 - ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) - return(as.numeric(ll)) - } - rblapply(seq_len(prep$ndraws), .log_lik) -} - -log_lik_gaussian_lagsar <- function(i, prep) { - mu <- get_dpar(prep, "mu") - sigma <- get_dpar(prep, "sigma") - Y <- as.numeric(prep$data$Y) - I <- diag(prep$nobs) - stopifnot(i == 1) - # see http://mc-stan.org/loo/articles/loo2-non-factorizable.html - .log_lik <- function(s) { - IB <- I - with(prep$ac, lagsar[s, ] * Msar) - Cinv <- t(IB) %*% IB / sigma[s]^2 - e <- Y - solve(IB, mu[s, ]) - g <- Cinv %*% e - cbar <- diag(Cinv) - yloo <- Y - g / cbar - sdloo <- sqrt(1 / cbar) - ll <- dnorm(Y, yloo, sdloo, log = TRUE) - return(as.numeric(ll)) - } - rblapply(seq_len(prep$ndraws), .log_lik) -} - -log_lik_student_lagsar <- function(i, prep) { - nu <- get_dpar(prep, "nu") - mu <- get_dpar(prep, "mu") - sigma <- get_dpar(prep, "sigma") - Y <- as.numeric(prep$data$Y) - I <- diag(prep$nobs) - stopifnot(i == 1) - # see http://mc-stan.org/loo/articles/loo2-non-factorizable.html - .log_lik <- function(s) { - df <- nu[s] - IB <- I - with(prep$ac, lagsar[s, ] * Msar) - Cinv <- t(IB) %*% IB / sigma[s]^2 - e <- Y - solve(IB, mu[s, ]) - g <- Cinv %*% e - cbar <- diag(Cinv) - yloo <- Y - g / cbar - sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, Cinv, e)) - dfloo <- df + nrow(Cinv) - 1 - ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) - return(as.numeric(ll)) - } - rblapply(seq_len(prep$ndraws), .log_lik) -} - -log_lik_gaussian_errorsar <- function(i, prep) { - stopifnot(i == 1) - mu <- get_dpar(prep, "mu") - sigma <- get_dpar(prep, "sigma") - Y <- as.numeric(prep$data$Y) - I <- diag(prep$nobs) - .log_lik <- function(s) { - IB <- I - with(prep$ac, errorsar[s, ] * Msar) - Cinv <- t(IB) %*% IB / sigma[s]^2 - e <- Y - mu[s, ] - g <- Cinv %*% e - cbar <- diag(Cinv) - yloo <- Y - g / cbar - sdloo <- sqrt(1 / cbar) - ll <- dnorm(Y, yloo, sdloo, log = TRUE) - return(as.numeric(ll)) - } - rblapply(seq_len(prep$ndraws), .log_lik) -} - -log_lik_student_errorsar <- function(i, prep) { - stopifnot(i == 1) - nu <- get_dpar(prep, "nu") - mu <- get_dpar(prep, "mu") - sigma <- get_dpar(prep, "sigma") - Y <- as.numeric(prep$data$Y) - I <- diag(prep$nobs) - .log_lik <- function(s) { - df <- nu[s] - IB <- I - with(prep$ac, errorsar[s, ] * Msar) - Cinv <- t(IB) %*% IB / sigma[s]^2 - e <- Y - mu[s, ] - g <- Cinv %*% e - cbar <- diag(Cinv) - yloo <- Y - g / cbar - sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, Cinv, e)) - dfloo <- df + nrow(Cinv) - 1 - ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) - return(as.numeric(ll)) - } - rblapply(seq_len(prep$ndraws), .log_lik) -} - -log_lik_gaussian_fcor <- function(i, prep) { - stopifnot(i == 1) - Y <- as.numeric(prep$data$Y) - mu <- get_dpar(prep, "mu") - Sigma <- get_cov_matrix_ac(prep) - .log_lik <- function(s) { - C <- as.matrix(Sigma[s, , ]) - Cinv <- solve(C) - e <- Y - mu[s, ] - g <- solve(C, e) - cbar <- diag(Cinv) - yloo <- Y - g / cbar - sdloo <- sqrt(1 / cbar) - ll <- dnorm(Y, yloo, sdloo, log = TRUE) - return(as.numeric(ll)) - } - rblapply(seq_len(prep$ndraws), .log_lik) -} - -log_lik_student_fcor <- function(i, prep) { - stopifnot(i == 1) - Y <- as.numeric(prep$data$Y) - nu <- get_dpar(prep, "nu") - mu <- get_dpar(prep, "mu") - Sigma <- get_cov_matrix_ac(prep) - .log_lik <- function(s) { - df <- nu[s] - C <- as.matrix(Sigma[s, , ]) - Cinv <- solve(C) - e <- Y - mu[s, ] - g <- solve(C, e) - cbar <- diag(Cinv) - yloo <- Y - g / cbar - sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, Cinv, e)) - dfloo <- df + nrow(Cinv) - 1 - ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) - return(as.numeric(ll)) - } - rblapply(seq_len(prep$ndraws), .log_lik) -} - -log_lik_binomial <- function(i, prep) { - trials <- prep$data$trials[i] - args <- list(size = trials, prob = get_dpar(prep, "mu", i)) - out <- log_lik_censor( - dist = "binom", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pbinom, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_bernoulli <- function(i, prep) { - args <- list(size = 1, prob = get_dpar(prep, "mu", i)) - out <- log_lik_censor( - dist = "binom", args = args, i = i, prep = prep - ) - # no truncation allowed - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_poisson <- function(i, prep) { - mu <- get_dpar(prep, "mu", i) - mu <- multiply_dpar_rate_denom(mu, prep, i = i) - args <- list(lambda = mu) - out <- log_lik_censor( - dist = "pois", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = ppois, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_negbinomial <- function(i, prep) { - mu <- get_dpar(prep, "mu", i) - mu <- multiply_dpar_rate_denom(mu, prep, i = i) - shape <- get_dpar(prep, "shape", i) - shape <- multiply_dpar_rate_denom(shape, prep, i = i) - args <- list(mu = mu, size = shape) - out <- log_lik_censor( - dist = "nbinom", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pnbinom, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_negbinomial2 <- function(i, prep) { - mu <- get_dpar(prep, "mu", i) - mu <- multiply_dpar_rate_denom(mu, prep, i = i) - sigma <- get_dpar(prep, "sigma", i) - shape <- multiply_dpar_rate_denom(1 / sigma, prep, i = i) - args <- list(mu = mu, size = shape) - out <- log_lik_censor( - dist = "nbinom", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pnbinom, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_geometric <- function(i, prep) { - mu <- get_dpar(prep, "mu", i) - mu <- multiply_dpar_rate_denom(mu, prep, i = i) - shape <- 1 - shape <- multiply_dpar_rate_denom(shape, prep, i = i) - args <- list(mu = mu, size = shape) - out <- log_lik_censor( - dist = "nbinom", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pnbinom, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_discrete_weibull <- function(i, prep) { - args <- list( - mu = get_dpar(prep, "mu", i), - shape = get_dpar(prep, "shape", i = i) - ) - out <- log_lik_censor( - dist = "discrete_weibull", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pdiscrete_weibull, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_com_poisson <- function(i, prep) { - args <- list( - mu = get_dpar(prep, "mu", i), - shape = get_dpar(prep, "shape", i = i) - ) - # no censoring or truncation allowed yet - out <- do_call(dcom_poisson, c(prep$data$Y[i], args, log = TRUE)) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_exponential <- function(i, prep) { - args <- list(rate = 1 / get_dpar(prep, "mu", i)) - out <- log_lik_censor(dist = "exp", args = args, i = i, prep = prep) - out <- log_lik_truncate( - out, cdf = pexp, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_gamma <- function(i, prep) { - shape <- get_dpar(prep, "shape", i = i) - scale <- get_dpar(prep, "mu", i) / shape - args <- nlist(shape, scale) - out <- log_lik_censor(dist = "gamma", args = args, i = i, prep = prep) - out <- log_lik_truncate( - out, cdf = pgamma, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_weibull <- function(i, prep) { - shape <- get_dpar(prep, "shape", i = i) - scale <- get_dpar(prep, "mu", i = i) / gamma(1 + 1 / shape) - args <- list(shape = shape, scale = scale) - out <- log_lik_censor( - dist = "weibull", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pweibull, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_frechet <- function(i, prep) { - nu <- get_dpar(prep, "nu", i = i) - scale <- get_dpar(prep, "mu", i = i) / gamma(1 - 1 / nu) - args <- list(scale = scale, shape = nu) - out <- log_lik_censor( - dist = "frechet", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pfrechet, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_gen_extreme_value <- function(i, prep) { - sigma <- get_dpar(prep, "sigma", i = i) - xi <- get_dpar(prep, "xi", i = i) - mu <- get_dpar(prep, "mu", i) - args <- nlist(mu, sigma, xi) - out <- log_lik_censor(dist = "gen_extreme_value", args = args, - i = i, prep = prep) - out <- log_lik_truncate(out, cdf = pgen_extreme_value, - args = args, i = i, prep = prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_inverse.gaussian <- function(i, prep) { - args <- list(mu = get_dpar(prep, "mu", i), - shape = get_dpar(prep, "shape", i = i)) - out <- log_lik_censor(dist = "inv_gaussian", args = args, - i = i, prep = prep) - out <- log_lik_truncate(out, cdf = pinv_gaussian, args = args, - i = i, prep = prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_exgaussian <- function(i, prep) { - args <- list(mu = get_dpar(prep, "mu", i), - sigma = get_dpar(prep, "sigma", i = i), - beta = get_dpar(prep, "beta", i = i)) - out <- log_lik_censor(dist = "exgaussian", args = args, - i = i, prep = prep) - out <- log_lik_truncate(out, cdf = pexgaussian, args = args, - i = i, prep = prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_wiener <- function(i, prep) { - args <- list( - delta = get_dpar(prep, "mu", i), - alpha = get_dpar(prep, "bs", i = i), - tau = get_dpar(prep, "ndt", i = i), - beta = get_dpar(prep, "bias", i = i), - resp = prep$data[["dec"]][i] - ) - out <- do_call(dwiener, c(prep$data$Y[i], args, log = TRUE)) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_beta <- function(i, prep) { - mu <- get_dpar(prep, "mu", i) - phi <- get_dpar(prep, "phi", i) - args <- list(shape1 = mu * phi, shape2 = (1 - mu) * phi) - out <- log_lik_censor(dist = "beta", args = args, i = i, prep = prep) - out <- log_lik_truncate( - out, cdf = pbeta, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_von_mises <- function(i, prep) { - args <- list( - mu = get_dpar(prep, "mu", i), - kappa = get_dpar(prep, "kappa", i = i) - ) - out <- log_lik_censor( - dist = "von_mises", args = args, i = i, prep = prep - ) - out <- log_lik_truncate( - out, cdf = pvon_mises, args = args, i = i, prep = prep - ) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_asym_laplace <- function(i, prep, ...) { - args <- list( - mu = get_dpar(prep, "mu", i), - sigma = get_dpar(prep, "sigma", i), - quantile = get_dpar(prep, "quantile", i) - ) - out <- log_lik_censor(dist = "asym_laplace", args, i, prep) - out <- log_lik_truncate(out, pasym_laplace, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_zero_inflated_asym_laplace <- function(i, prep, ...) { - args <- list( - mu = get_dpar(prep, "mu", i), - sigma = get_dpar(prep, "sigma", i), - quantile = get_dpar(prep, "quantile", i), - zi = get_dpar(prep, "zi", i) - ) - out <- log_lik_censor(dist = "zero_inflated_asym_laplace", args, i, prep) - out <- log_lik_truncate(out, pzero_inflated_asym_laplace, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_cox <- function(i, prep, ...) { - args <- list( - mu = get_dpar(prep, "mu", i), - bhaz = prep$bhaz$bhaz[, i], - cbhaz = prep$bhaz$cbhaz[, i] - ) - out <- log_lik_censor(dist = "cox", args = args, i = i, prep = prep) - out <- log_lik_truncate(out, cdf = pcox, args = args, i = i, prep = prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_hurdle_poisson <- function(i, prep) { - hu <- get_dpar(prep, "hu", i) - lambda <- get_dpar(prep, "mu", i) - args <- nlist(lambda, hu) - out <- log_lik_censor("hurdle_poisson", args, i, prep) - out <- log_lik_truncate(out, phurdle_poisson, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_hurdle_negbinomial <- function(i, prep) { - hu <- get_dpar(prep, "hu", i) - mu <- get_dpar(prep, "mu", i) - shape <- get_dpar(prep, "shape", i = i) - args <- nlist(mu, shape, hu) - out <- log_lik_censor("hurdle_negbinomial", args, i, prep) - out <- log_lik_truncate(out, phurdle_negbinomial, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_hurdle_gamma <- function(i, prep) { - hu <- get_dpar(prep, "hu", i) - shape <- get_dpar(prep, "shape", i = i) - scale <- get_dpar(prep, "mu", i) / shape - args <- nlist(shape, scale, hu) - out <- log_lik_censor("hurdle_gamma", args, i, prep) - out <- log_lik_truncate(out, phurdle_gamma, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_hurdle_lognormal <- function(i, prep) { - hu <- get_dpar(prep, "hu", i) - mu <- get_dpar(prep, "mu", i) - sigma <- get_dpar(prep, "sigma", i = i) - args <- nlist(mu, sigma, hu) - out <- log_lik_censor("hurdle_lognormal", args, i, prep) - out <- log_lik_truncate(out, phurdle_lognormal, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_zero_inflated_poisson <- function(i, prep) { - zi <- get_dpar(prep, "zi", i) - lambda <- get_dpar(prep, "mu", i) - args <- nlist(lambda, zi) - out <- log_lik_censor("zero_inflated_poisson", args, i, prep) - out <- log_lik_truncate(out, pzero_inflated_poisson, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_zero_inflated_negbinomial <- function(i, prep) { - zi <- get_dpar(prep, "zi", i) - mu <- get_dpar(prep, "mu", i) - shape <- get_dpar(prep, "shape", i = i) - args <- nlist(mu, shape, zi) - out <- log_lik_censor("zero_inflated_negbinomial", args, i, prep) - out <- log_lik_truncate(out, pzero_inflated_negbinomial, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_zero_inflated_binomial <- function(i, prep) { - trials <- prep$data$trials[i] - mu <- get_dpar(prep, "mu", i) - zi <- get_dpar(prep, "zi", i) - args <- list(size = trials, prob = mu, zi) - out <- log_lik_censor("zero_inflated_binomial", args, i, prep) - out <- log_lik_truncate(out, pzero_inflated_binomial, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_zero_inflated_beta <- function(i, prep) { - zi <- get_dpar(prep, "zi", i) - mu <- get_dpar(prep, "mu", i) - phi <- get_dpar(prep, "phi", i) - args <- nlist(shape1 = mu * phi, shape2 = (1 - mu) * phi, zi) - out <- log_lik_censor("zero_inflated_beta", args, i, prep) - out <- log_lik_truncate(out, pzero_inflated_beta, args, i, prep) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_zero_one_inflated_beta <- function(i, prep) { - zoi <- get_dpar(prep, "zoi", i) - coi <- get_dpar(prep, "coi", i) - if (prep$data$Y[i] %in% c(0, 1)) { - out <- dbinom(1, size = 1, prob = zoi, log = TRUE) + - dbinom(prep$data$Y[i], size = 1, prob = coi, log = TRUE) - } else { - phi <- get_dpar(prep, "phi", i) - mu <- get_dpar(prep, "mu", i) - args <- list(shape1 = mu * phi, shape2 = (1 - mu) * phi) - out <- dbinom(0, size = 1, prob = zoi, log = TRUE) + - do_call(dbeta, c(prep$data$Y[i], args, log = TRUE)) - } - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_categorical <- function(i, prep) { - stopifnot(prep$family$link == "logit") - eta <- cblapply(names(prep$dpars), get_dpar, prep = prep, i = i) - eta <- insert_refcat(eta, family = prep$family) - out <- dcategorical(prep$data$Y[i], eta = eta, log = TRUE) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_multinomial <- function(i, prep) { - stopifnot(prep$family$link == "logit") - eta <- cblapply(names(prep$dpars), get_dpar, prep = prep, i = i) - eta <- insert_refcat(eta, family = prep$family) - out <- dmultinomial(prep$data$Y[i, ], eta = eta, log = TRUE) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_dirichlet <- function(i, prep) { - stopifnot(prep$family$link == "logit") - mu_dpars <- str_subset(names(prep$dpars), "^mu") - eta <- cblapply(mu_dpars, get_dpar, prep = prep, i = i) - eta <- insert_refcat(eta, family = prep$family) - phi <- get_dpar(prep, "phi", i = i) - cats <- seq_len(prep$data$ncat) - alpha <- dcategorical(cats, eta = eta) * phi - out <- ddirichlet(prep$data$Y[i, ], alpha = alpha, log = TRUE) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_dirichlet2 <- function(i, prep) { - mu_dpars <- str_subset(names(prep$dpars), "^mu") - mu <- cblapply(mu_dpars, get_dpar, prep = prep, i = i) - out <- ddirichlet(prep$data$Y[i, ], alpha = mu, log = TRUE) - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_cumulative <- function(i, prep) { - disc <- get_dpar(prep, "disc", i = i) - mu <- get_dpar(prep, "mu", i = i) - thres <- subset_thres(prep, i) - nthres <- NCOL(thres) - eta <- disc * (thres - mu) - y <- prep$data$Y[i] - if (y == 1) { - out <- log(ilink(eta[, 1], prep$family$link)) - } else if (y == nthres + 1) { - out <- log(1 - ilink(eta[, y - 1], prep$family$link)) - } else { - out <- log( - ilink(eta[, y], prep$family$link) - - ilink(eta[, y - 1], prep$family$link) - ) - } - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_sratio <- function(i, prep) { - disc <- get_dpar(prep, "disc", i = i) - mu <- get_dpar(prep, "mu", i = i) - thres <- subset_thres(prep, i) - nthres <- NCOL(thres) - eta <- disc * (thres - mu) - y <- prep$data$Y[i] - q <- sapply(seq_len(min(y, nthres)), - function(k) 1 - ilink(eta[, k], prep$family$link) - ) - if (y == 1) { - out <- log(1 - q[, 1]) - } else if (y == 2) { - out <- log(1 - q[, 2]) + log(q[, 1]) - } else if (y == nthres + 1) { - out <- rowSums(log(q)) - } else { - out <- log(1 - q[, y]) + rowSums(log(q[, 1:(y - 1)])) - } - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_cratio <- function(i, prep) { - disc <- get_dpar(prep, "disc", i = i) - mu <- get_dpar(prep, "mu", i = i) - thres <- subset_thres(prep, i) - nthres <- NCOL(thres) - eta <- disc * (mu - thres) - y <- prep$data$Y[i] - q <- sapply(seq_len(min(y, nthres)), - function(k) ilink(eta[, k], prep$family$link) - ) - if (y == 1) { - out <- log(1 - q[, 1]) - } else if (y == 2) { - out <- log(1 - q[, 2]) + log(q[, 1]) - } else if (y == nthres + 1) { - out <- rowSums(log(q)) - } else { - out <- log(1 - q[, y]) + rowSums(log(q[, 1:(y - 1)])) - } - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_acat <- function(i, prep) { - disc <- get_dpar(prep, "disc", i = i) - mu <- get_dpar(prep, "mu", i = i) - thres <- subset_thres(prep, i) - nthres <- NCOL(thres) - eta <- disc * (mu - thres) - y <- prep$data$Y[i] - if (prep$family$link == "logit") { # more efficient calculation - q <- sapply(1:nthres, function(k) eta[, k]) - p <- cbind(rep(0, nrow(eta)), q[, 1], - matrix(0, nrow = nrow(eta), ncol = nthres - 1)) - if (nthres > 1L) { - p[, 3:(nthres + 1)] <- - sapply(3:(nthres + 1), function(k) rowSums(q[, 1:(k - 1)])) - } - out <- p[, y] - log(rowSums(exp(p))) - } else { - q <- sapply(1:nthres, function(k) - ilink(eta[, k], prep$family$link)) - p <- cbind(apply(1 - q[, 1:nthres], 1, prod), - matrix(0, nrow = nrow(eta), ncol = nthres)) - if (nthres > 1L) { - p[, 2:nthres] <- sapply(2:nthres, function(k) - apply(as.matrix(q[, 1:(k - 1)]), 1, prod) * - apply(as.matrix(1 - q[, k:nthres]), 1, prod)) - } - p[, nthres + 1] <- apply(q[, 1:nthres], 1, prod) - out <- log(p[, y]) - log(apply(p, 1, sum)) - } - log_lik_weight(out, i = i, prep = prep) -} - -log_lik_custom <- function(i, prep) { - custom_family_method(prep$family, "log_lik")(i, prep) -} - -log_lik_mixture <- function(i, prep) { - families <- family_names(prep$family) - theta <- get_theta(prep, i = i) - out <- array(NA, dim = dim(theta)) - for (j in seq_along(families)) { - log_lik_fun <- paste0("log_lik_", families[j]) - log_lik_fun <- get(log_lik_fun, asNamespace("brms")) - tmp_draws <- pseudo_prep_for_mixture(prep, j) - out[, j] <- exp(log(theta[, j]) + log_lik_fun(i, tmp_draws)) - } - if (isTRUE(prep[["pp_mixture"]])) { - out <- log(out) - log(rowSums(out)) - } else { - out <- log(rowSums(out)) - } - log_lik_weight(out, i = i, prep = prep) -} - -# ----------- log_lik helper-functions ----------- -# compute (possibly censored) log_lik values -# @param dist name of a distribution for which the functions -# d (pdf) and p (cdf) are available -# @param args additional arguments passed to pdf and cdf -# @param prep a brmsprep object -# @return vector of log_lik values -log_lik_censor <- function(dist, args, i, prep) { - pdf <- get(paste0("d", dist), mode = "function") - cdf <- get(paste0("p", dist), mode = "function") - y <- prep$data$Y[i] - cens <- prep$data$cens[i] - if (is.null(cens) || cens == 0) { - x <- do_call(pdf, c(y, args, log = TRUE)) - } else if (cens == 1) { - x <- do_call(cdf, c(y, args, lower.tail = FALSE, log.p = TRUE)) - } else if (cens == -1) { - x <- do_call(cdf, c(y, args, log.p = TRUE)) - } else if (cens == 2) { - rcens <- prep$data$rcens[i] - x <- log(do_call(cdf, c(rcens, args)) - do_call(cdf, c(y, args))) - } - x -} - -# adjust log_lik in truncated models -# @param x vector of log_lik values -# @param cdf a cumulative distribution function -# @param args arguments passed to cdf -# @param i observation number -# @param prep a brmsprep object -# @return vector of log_lik values -log_lik_truncate <- function(x, cdf, args, i, prep) { - lb <- prep$data$lb[i] - ub <- prep$data$ub[i] - if (!(is.null(lb) && is.null(ub))) { - if (is.null(lb)) lb <- -Inf - if (is.null(ub)) ub <- Inf - x - log(do_call(cdf, c(ub, args)) - do_call(cdf, c(lb, args))) - } - x -} - -# weight log_lik values according to defined weights -# @param x vector of log_lik values -# @param i observation number -# @param prep a brmsprep object -# @return vector of log_lik values -log_lik_weight <- function(x, i, prep) { - weight <- prep$data$weights[i] - if (!is.null(weight)) { - x <- x * weight - } - x -} - -# after some discussion with Aki Vehtari and Daniel Simpson, -# I disallowed computation of log-likelihood values for some models -# until pointwise solutions are implemented -stop_no_pw <- function() { - stop2("Cannot yet compute pointwise log-likelihood for this model ", - "because the observations are not conditionally independent.") -} - -# multiplicate factor for conditional student-t models -# see http://proceedings.mlr.press/v33/shah14.pdf -# note that brms parameterizes C instead of Cov(y) = df / (df - 2) * C -# @param df degrees of freedom parameter -# @param Cinv inverse of the full matrix -# @param e vector of error terms, that is, y - mu -student_t_cov_factor <- function(df, Cinv, e) { - beta1 <- ulapply(seq_rows(Cinv), student_t_beta1_i, Cinv, e) - (df + beta1) / (df + nrow(Cinv) - 1) -} - -# beta1 in equation (6) of http://proceedings.mlr.press/v33/shah14.pdf -# @param i observation index to exclude in the submatrix -# @param Cinv inverse of the full matrix -# @param e vector of error terms, that is, y - mu -# @param vector of length one -student_t_beta1_i <- function(i, Cinv, e) { - sub_Cinv_i <- sub_inverse_symmetric(Cinv, i) - t(e[-i]) %*% sub_Cinv_i %*% e[-i] -} - -# efficient submatrix inverse for a symmetric matrix -# see http://www.scielo.org.mx/pdf/cys/v20n2/1405-5546-cys-20-02-00251.pdf -# @param Cinv inverse of the full matrix -# @param i observation index to exclude in the submatrix -# @return inverse of the submatrix after removing observation i -sub_inverse_symmetric <- function(Cinv, i) { - csub <- Cinv[i, -i] - D <- outer(csub, csub) - Cinv[-i, -i] - D / Cinv[i, i] -} +#' Compute the Pointwise Log-Likelihood +#' +#' @aliases log_lik logLik.brmsfit +#' +#' @param object A fitted model object of class \code{brmsfit}. +#' @inheritParams posterior_predict.brmsfit +#' @param combine Only relevant in multivariate models. +#' Indicates if the log-likelihoods of the submodels should +#' be combined per observation (i.e. added together; the default) +#' or if the log-likelihoods should be returned separately. +#' @param pointwise A flag indicating whether to compute the full +#' log-likelihood matrix at once (the default), or just return +#' the likelihood function along with all data and draws +#' required to compute the log-likelihood separately for each +#' observation. The latter option is rarely useful when +#' calling \code{log_lik} directly, but rather when computing +#' \code{\link{waic}} or \code{\link{loo}}. +#' @param add_point_estimate For internal use only. Ensures compatibility +#' with the \code{\link{loo_subsample}} method. +#' +#' @return Usually, an S x N matrix containing the pointwise log-likelihood +#' draws, where S is the number of draws and N is the number +#' of observations in the data. For multivariate models and if +#' \code{combine} is \code{FALSE}, an S x N x R array is returned, +#' where R is the number of response variables. +#' If \code{pointwise = TRUE}, the output is a function +#' with a \code{draws} attribute containing all relevant +#' data and posterior draws. +#' +#' @template details-newdata-na +#' @template details-allow_new_levels +#' +#' @aliases log_lik +#' @method log_lik brmsfit +#' @export +#' @export log_lik +#' @importFrom rstantools log_lik +log_lik.brmsfit <- function(object, newdata = NULL, re_formula = NULL, + resp = NULL, ndraws = NULL, draw_ids = NULL, + pointwise = FALSE, combine = TRUE, + add_point_estimate = FALSE, + cores = NULL, ...) { + pointwise <- as_one_logical(pointwise) + combine <- as_one_logical(combine) + add_point_estimate <- as_one_logical(add_point_estimate) + contains_draws(object) + object <- restructure(object) + prep <- prepare_predictions( + object, newdata = newdata, re_formula = re_formula, resp = resp, + ndraws = ndraws, draw_ids = draw_ids, check_response = TRUE, ... + ) + if (add_point_estimate) { + # required for the loo_subsample method + # Computing a point estimate based on the full prep object is too + # difficult due to its highly nested structure. As an alternative, a second + # prep object is created from the point estimates of the draws directly. + attr(prep, "point_estimate") <- prepare_predictions( + object, newdata = newdata, re_formula = re_formula, resp = resp, + ndraws = ndraws, draw_ids = draw_ids, check_response = TRUE, + point_estimate = "median", ... + ) + } + if (pointwise) { + stopifnot(combine) + log_lik <- log_lik_pointwise + # names need to be 'data' and 'draws' as per ?loo::loo.function + attr(log_lik, "data") <- data.frame(i = seq_len(choose_N(prep))) + attr(log_lik, "draws") <- prep + } else { + log_lik <- log_lik(prep, combine = combine, cores = cores) + if (anyNA(log_lik)) { + warning2( + "NAs were found in the log-likelihood. Possibly this is because ", + "some of your responses contain NAs. If you use 'mi' terms, try ", + "setting 'resp' to those response variables without missing values. ", + "Alternatively, use 'newdata' to predict only complete cases." + ) + } + } + log_lik +} + +#' @export +logLik.brmsfit <- function(object, newdata = NULL, re_formula = NULL, + resp = NULL, ndraws = NULL, draw_ids = NULL, + pointwise = FALSE, combine = TRUE, + cores = NULL, ...) { + cl <- match.call() + cl[[1]] <- quote(log_lik) + eval(cl, parent.frame()) +} + +#' @export +log_lik.mvbrmsprep <- function(object, combine = TRUE, ...) { + if (length(object$mvpars$rescor)) { + object$mvpars$Mu <- get_Mu(object) + object$mvpars$Sigma <- get_Sigma(object) + out <- log_lik.brmsprep(object, ...) + } else { + out <- lapply(object$resps, log_lik, ...) + if (combine) { + out <- Reduce("+", out) + } else { + along <- ifelse(length(out) > 1L, 3, 2) + out <- do_call(abind, c(out, along = along)) + } + } + out +} + +#' @export +log_lik.brmsprep <- function(object, cores = NULL, ...) { + cores <- validate_cores_post_processing(cores) + log_lik_fun <- paste0("log_lik_", object$family$fun) + log_lik_fun <- get(log_lik_fun, asNamespace("brms")) + if (is.customfamily(object$family)) { + # ensure that the method can be found during parallel execution + object$family$log_lik <- custom_family_method(object$family, "log_lik") + } + for (nlp in names(object$nlpars)) { + object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) + } + for (dp in names(object$dpars)) { + object$dpars[[dp]] <- get_dpar(object, dpar = dp) + } + N <- choose_N(object) + out <- plapply(seq_len(N), log_lik_fun, cores = cores, prep = object) + out <- do_call(cbind, out) + colnames(out) <- NULL + old_order <- object$old_order + sort <- isTRUE(ncol(out) != length(old_order)) + reorder_obs(out, old_order, sort = sort) +} + +# evaluate log_lik in a pointwise manner +# cannot be an S3 method since 'data_i' must be the first argument +# names must be 'data_i' and 'draws' as per ?loo::loo.function +log_lik_pointwise <- function(data_i, draws, ...) { + i <- data_i$i + if (is.mvbrmsprep(draws) && !length(draws$mvpars$rescor)) { + out <- lapply(draws$resps, log_lik_pointwise, i = i) + out <- Reduce("+", out) + } else { + log_lik_fun <- paste0("log_lik_", draws$family$fun) + log_lik_fun <- get(log_lik_fun, asNamespace("brms")) + out <- log_lik_fun(i, draws) + } + out +} + +# All log_lik_ functions have the same arguments structure +# @param i index of the observatio for which to compute log-lik values +# @param prep A named list returned by prepare_predictions containing +# all required data and posterior draws +# @return a vector of length prep$ndraws containing the pointwise +# log-likelihood for the ith observation +log_lik_gaussian <- function(i, prep) { + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + sigma <- add_sigma_se(sigma, prep, i = i) + args <- list(mean = mu, sd = sigma) + # log_lik_censor computes the conventional log_lik in case of no censoring + out <- log_lik_censor(dist = "norm", args = args, i = i, prep = prep) + out <- log_lik_truncate( + out, cdf = pnorm, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_student <- function(i, prep) { + nu <- get_dpar(prep, "nu", i = i) + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + sigma <- add_sigma_se(sigma, prep, i = i) + args <- list(df = nu, mu = mu, sigma = sigma) + out <- log_lik_censor( + dist = "student_t", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pstudent_t, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_lognormal <- function(i, prep) { + sigma <- get_dpar(prep, "sigma", i = i) + args <- list(meanlog = get_dpar(prep, "mu", i), sdlog = sigma) + out <- log_lik_censor(dist = "lnorm", args = args, i = i, prep = prep) + out <- log_lik_truncate( + out, cdf = plnorm, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_shifted_lognormal <- function(i, prep) { + sigma <- get_dpar(prep, "sigma", i = i) + ndt <- get_dpar(prep, "ndt", i = i) + args <- list(meanlog = get_dpar(prep, "mu", i), sdlog = sigma, shift = ndt) + out <- log_lik_censor("shifted_lnorm", args, i = i, prep = prep) + out <- log_lik_truncate(out, pshifted_lnorm, args, i = i, prep = prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_skew_normal <- function(i, prep) { + mu <- get_dpar(prep, "mu", i) + sigma <- get_dpar(prep, "sigma", i = i) + sigma <- add_sigma_se(sigma, prep, i = i) + alpha <- get_dpar(prep, "alpha", i = i) + args <- nlist(mu, sigma, alpha) + out <- log_lik_censor( + dist = "skew_normal", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pskew_normal, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_gaussian_mv <- function(i, prep) { + Mu <- get_Mu(prep, i = i) + Sigma <- get_Sigma(prep, i = i) + dmn <- function(s) { + dmulti_normal( + prep$data$Y[i, ], mu = Mu[s, ], + Sigma = Sigma[s, , ], log = TRUE + ) + } + out <- sapply(1:prep$ndraws, dmn) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_student_mv <- function(i, prep) { + nu <- get_dpar(prep, "nu", i = i) + Mu <- get_Mu(prep, i = i) + Sigma <- get_Sigma(prep, i = i) + dmst <- function(s) { + dmulti_student_t( + prep$data$Y[i, ], df = nu[s], mu = Mu[s, ], + Sigma = Sigma[s, , ], log = TRUE + ) + } + out <- sapply(1:prep$ndraws, dmst) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_gaussian_time <- function(i, prep) { + obs <- with(prep$ac, begin_tg[i]:end_tg[i]) + Y <- as.numeric(prep$data$Y[obs]) + mu <- as.matrix(get_dpar(prep, "mu", i = obs)) + Sigma <- get_cov_matrix_ac(prep, obs) + .log_lik <- function(s) { + C <- as.matrix(Sigma[s, , ]) + Cinv <- solve(C) + e <- Y - mu[s, ] + g <- solve(C, e) + cbar <- diag(Cinv) + yloo <- Y - g / cbar + sdloo <- sqrt(1 / cbar) + ll <- dnorm(Y, yloo, sdloo, log = TRUE) + return(as.numeric(ll)) + } + rblapply(seq_len(prep$ndraws), .log_lik) +} + +log_lik_student_time <- function(i, prep) { + obs <- with(prep$ac, begin_tg[i]:end_tg[i]) + Y <- as.numeric(prep$data$Y[obs]) + nu <- as.matrix(get_dpar(prep, "nu", i = obs)) + mu <- as.matrix(get_dpar(prep, "mu", i = obs)) + Sigma <- get_cov_matrix_ac(prep, obs) + .log_lik <- function(s) { + df <- nu[s, ] + C <- as.matrix(Sigma[s, , ]) + Cinv <- solve(C) + e <- Y - mu[s, ] + g <- solve(C, e) + cbar <- diag(Cinv) + yloo <- Y - g / cbar + sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, Cinv, e)) + dfloo <- df + nrow(Cinv) - 1 + ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) + return(as.numeric(ll)) + } + rblapply(seq_len(prep$ndraws), .log_lik) +} + +log_lik_gaussian_lagsar <- function(i, prep) { + mu <- get_dpar(prep, "mu") + sigma <- get_dpar(prep, "sigma") + Y <- as.numeric(prep$data$Y) + I <- diag(prep$nobs) + stopifnot(i == 1) + # see http://mc-stan.org/loo/articles/loo2-non-factorizable.html + .log_lik <- function(s) { + IB <- I - with(prep$ac, lagsar[s, ] * Msar) + Cinv <- t(IB) %*% IB / sigma[s]^2 + e <- Y - solve(IB, mu[s, ]) + g <- Cinv %*% e + cbar <- diag(Cinv) + yloo <- Y - g / cbar + sdloo <- sqrt(1 / cbar) + ll <- dnorm(Y, yloo, sdloo, log = TRUE) + return(as.numeric(ll)) + } + rblapply(seq_len(prep$ndraws), .log_lik) +} + +log_lik_student_lagsar <- function(i, prep) { + nu <- get_dpar(prep, "nu") + mu <- get_dpar(prep, "mu") + sigma <- get_dpar(prep, "sigma") + Y <- as.numeric(prep$data$Y) + I <- diag(prep$nobs) + stopifnot(i == 1) + # see http://mc-stan.org/loo/articles/loo2-non-factorizable.html + .log_lik <- function(s) { + df <- nu[s] + IB <- I - with(prep$ac, lagsar[s, ] * Msar) + Cinv <- t(IB) %*% IB / sigma[s]^2 + e <- Y - solve(IB, mu[s, ]) + g <- Cinv %*% e + cbar <- diag(Cinv) + yloo <- Y - g / cbar + sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, Cinv, e)) + dfloo <- df + nrow(Cinv) - 1 + ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) + return(as.numeric(ll)) + } + rblapply(seq_len(prep$ndraws), .log_lik) +} + +log_lik_gaussian_errorsar <- function(i, prep) { + stopifnot(i == 1) + mu <- get_dpar(prep, "mu") + sigma <- get_dpar(prep, "sigma") + Y <- as.numeric(prep$data$Y) + I <- diag(prep$nobs) + .log_lik <- function(s) { + IB <- I - with(prep$ac, errorsar[s, ] * Msar) + Cinv <- t(IB) %*% IB / sigma[s]^2 + e <- Y - mu[s, ] + g <- Cinv %*% e + cbar <- diag(Cinv) + yloo <- Y - g / cbar + sdloo <- sqrt(1 / cbar) + ll <- dnorm(Y, yloo, sdloo, log = TRUE) + return(as.numeric(ll)) + } + rblapply(seq_len(prep$ndraws), .log_lik) +} + +log_lik_student_errorsar <- function(i, prep) { + stopifnot(i == 1) + nu <- get_dpar(prep, "nu") + mu <- get_dpar(prep, "mu") + sigma <- get_dpar(prep, "sigma") + Y <- as.numeric(prep$data$Y) + I <- diag(prep$nobs) + .log_lik <- function(s) { + df <- nu[s] + IB <- I - with(prep$ac, errorsar[s, ] * Msar) + Cinv <- t(IB) %*% IB / sigma[s]^2 + e <- Y - mu[s, ] + g <- Cinv %*% e + cbar <- diag(Cinv) + yloo <- Y - g / cbar + sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, Cinv, e)) + dfloo <- df + nrow(Cinv) - 1 + ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) + return(as.numeric(ll)) + } + rblapply(seq_len(prep$ndraws), .log_lik) +} + +log_lik_gaussian_fcor <- function(i, prep) { + stopifnot(i == 1) + Y <- as.numeric(prep$data$Y) + mu <- get_dpar(prep, "mu") + Sigma <- get_cov_matrix_ac(prep) + .log_lik <- function(s) { + C <- as.matrix(Sigma[s, , ]) + Cinv <- solve(C) + e <- Y - mu[s, ] + g <- solve(C, e) + cbar <- diag(Cinv) + yloo <- Y - g / cbar + sdloo <- sqrt(1 / cbar) + ll <- dnorm(Y, yloo, sdloo, log = TRUE) + return(as.numeric(ll)) + } + rblapply(seq_len(prep$ndraws), .log_lik) +} + +log_lik_student_fcor <- function(i, prep) { + stopifnot(i == 1) + Y <- as.numeric(prep$data$Y) + nu <- get_dpar(prep, "nu") + mu <- get_dpar(prep, "mu") + Sigma <- get_cov_matrix_ac(prep) + .log_lik <- function(s) { + df <- nu[s] + C <- as.matrix(Sigma[s, , ]) + Cinv <- solve(C) + e <- Y - mu[s, ] + g <- solve(C, e) + cbar <- diag(Cinv) + yloo <- Y - g / cbar + sdloo <- sqrt(1 / cbar * student_t_cov_factor(df, Cinv, e)) + dfloo <- df + nrow(Cinv) - 1 + ll <- dstudent_t(Y, dfloo, yloo, sdloo, log = TRUE) + return(as.numeric(ll)) + } + rblapply(seq_len(prep$ndraws), .log_lik) +} + +log_lik_binomial <- function(i, prep) { + trials <- prep$data$trials[i] + args <- list(size = trials, prob = get_dpar(prep, "mu", i)) + out <- log_lik_censor( + dist = "binom", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pbinom, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_bernoulli <- function(i, prep) { + args <- list(size = 1, prob = get_dpar(prep, "mu", i)) + out <- log_lik_censor( + dist = "binom", args = args, i = i, prep = prep + ) + # no truncation allowed + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_beta_binomial <- function(i, prep) { + trials <- prep$data$trials[i] + mu <- get_dpar(prep, "mu", i) + phi <- get_dpar(prep, "phi", i) + args <- nlist(size = trials, mu, phi) + out <- log_lik_censor("beta_binomial", args, i, prep) + out <- log_lik_truncate(out, pbeta_binomial, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_poisson <- function(i, prep) { + mu <- get_dpar(prep, "mu", i) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) + args <- list(lambda = mu) + out <- log_lik_censor( + dist = "pois", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = ppois, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_negbinomial <- function(i, prep) { + mu <- get_dpar(prep, "mu", i) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) + shape <- get_dpar(prep, "shape", i) + shape <- multiply_dpar_rate_denom(shape, prep, i = i) + args <- list(mu = mu, size = shape) + out <- log_lik_censor( + dist = "nbinom", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pnbinom, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_negbinomial2 <- function(i, prep) { + mu <- get_dpar(prep, "mu", i) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) + sigma <- get_dpar(prep, "sigma", i) + shape <- multiply_dpar_rate_denom(1 / sigma, prep, i = i) + args <- list(mu = mu, size = shape) + out <- log_lik_censor( + dist = "nbinom", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pnbinom, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_geometric <- function(i, prep) { + mu <- get_dpar(prep, "mu", i) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) + shape <- 1 + shape <- multiply_dpar_rate_denom(shape, prep, i = i) + args <- list(mu = mu, size = shape) + out <- log_lik_censor( + dist = "nbinom", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pnbinom, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_discrete_weibull <- function(i, prep) { + args <- list( + mu = get_dpar(prep, "mu", i), + shape = get_dpar(prep, "shape", i = i) + ) + out <- log_lik_censor( + dist = "discrete_weibull", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pdiscrete_weibull, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_com_poisson <- function(i, prep) { + args <- list( + mu = get_dpar(prep, "mu", i), + shape = get_dpar(prep, "shape", i = i) + ) + # no censoring or truncation allowed yet + out <- do_call(dcom_poisson, c(prep$data$Y[i], args, log = TRUE)) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_exponential <- function(i, prep) { + args <- list(rate = 1 / get_dpar(prep, "mu", i)) + out <- log_lik_censor(dist = "exp", args = args, i = i, prep = prep) + out <- log_lik_truncate( + out, cdf = pexp, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_gamma <- function(i, prep) { + shape <- get_dpar(prep, "shape", i = i) + scale <- get_dpar(prep, "mu", i) / shape + args <- nlist(shape, scale) + out <- log_lik_censor(dist = "gamma", args = args, i = i, prep = prep) + out <- log_lik_truncate( + out, cdf = pgamma, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_weibull <- function(i, prep) { + shape <- get_dpar(prep, "shape", i = i) + scale <- get_dpar(prep, "mu", i = i) / gamma(1 + 1 / shape) + args <- list(shape = shape, scale = scale) + out <- log_lik_censor( + dist = "weibull", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pweibull, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_frechet <- function(i, prep) { + nu <- get_dpar(prep, "nu", i = i) + scale <- get_dpar(prep, "mu", i = i) / gamma(1 - 1 / nu) + args <- list(scale = scale, shape = nu) + out <- log_lik_censor( + dist = "frechet", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pfrechet, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_gen_extreme_value <- function(i, prep) { + sigma <- get_dpar(prep, "sigma", i = i) + xi <- get_dpar(prep, "xi", i = i) + mu <- get_dpar(prep, "mu", i) + args <- nlist(mu, sigma, xi) + out <- log_lik_censor(dist = "gen_extreme_value", args = args, + i = i, prep = prep) + out <- log_lik_truncate(out, cdf = pgen_extreme_value, + args = args, i = i, prep = prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_inverse.gaussian <- function(i, prep) { + args <- list(mu = get_dpar(prep, "mu", i), + shape = get_dpar(prep, "shape", i = i)) + out <- log_lik_censor(dist = "inv_gaussian", args = args, + i = i, prep = prep) + out <- log_lik_truncate(out, cdf = pinv_gaussian, args = args, + i = i, prep = prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_exgaussian <- function(i, prep) { + args <- list(mu = get_dpar(prep, "mu", i), + sigma = get_dpar(prep, "sigma", i = i), + beta = get_dpar(prep, "beta", i = i)) + out <- log_lik_censor(dist = "exgaussian", args = args, + i = i, prep = prep) + out <- log_lik_truncate(out, cdf = pexgaussian, args = args, + i = i, prep = prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_wiener <- function(i, prep) { + args <- list( + delta = get_dpar(prep, "mu", i), + alpha = get_dpar(prep, "bs", i = i), + tau = get_dpar(prep, "ndt", i = i), + beta = get_dpar(prep, "bias", i = i), + resp = prep$data[["dec"]][i] + ) + out <- do_call(dwiener, c(prep$data$Y[i], args, log = TRUE)) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_beta <- function(i, prep) { + mu <- get_dpar(prep, "mu", i) + phi <- get_dpar(prep, "phi", i) + args <- list(shape1 = mu * phi, shape2 = (1 - mu) * phi) + out <- log_lik_censor(dist = "beta", args = args, i = i, prep = prep) + out <- log_lik_truncate( + out, cdf = pbeta, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_von_mises <- function(i, prep) { + args <- list( + mu = get_dpar(prep, "mu", i), + kappa = get_dpar(prep, "kappa", i = i) + ) + out <- log_lik_censor( + dist = "von_mises", args = args, i = i, prep = prep + ) + out <- log_lik_truncate( + out, cdf = pvon_mises, args = args, i = i, prep = prep + ) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_asym_laplace <- function(i, prep, ...) { + args <- list( + mu = get_dpar(prep, "mu", i), + sigma = get_dpar(prep, "sigma", i), + quantile = get_dpar(prep, "quantile", i) + ) + out <- log_lik_censor(dist = "asym_laplace", args, i, prep) + out <- log_lik_truncate(out, pasym_laplace, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_zero_inflated_asym_laplace <- function(i, prep, ...) { + args <- list( + mu = get_dpar(prep, "mu", i), + sigma = get_dpar(prep, "sigma", i), + quantile = get_dpar(prep, "quantile", i), + zi = get_dpar(prep, "zi", i) + ) + out <- log_lik_censor(dist = "zero_inflated_asym_laplace", args, i, prep) + out <- log_lik_truncate(out, pzero_inflated_asym_laplace, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_cox <- function(i, prep, ...) { + args <- list( + mu = get_dpar(prep, "mu", i), + bhaz = prep$bhaz$bhaz[, i], + cbhaz = prep$bhaz$cbhaz[, i] + ) + out <- log_lik_censor(dist = "cox", args = args, i = i, prep = prep) + out <- log_lik_truncate(out, cdf = pcox, args = args, i = i, prep = prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_hurdle_poisson <- function(i, prep) { + hu <- get_dpar(prep, "hu", i) + lambda <- get_dpar(prep, "mu", i) + args <- nlist(lambda, hu) + out <- log_lik_censor("hurdle_poisson", args, i, prep) + out <- log_lik_truncate(out, phurdle_poisson, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_hurdle_negbinomial <- function(i, prep) { + hu <- get_dpar(prep, "hu", i) + mu <- get_dpar(prep, "mu", i) + shape <- get_dpar(prep, "shape", i = i) + args <- nlist(mu, shape, hu) + out <- log_lik_censor("hurdle_negbinomial", args, i, prep) + out <- log_lik_truncate(out, phurdle_negbinomial, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_hurdle_gamma <- function(i, prep) { + hu <- get_dpar(prep, "hu", i) + shape <- get_dpar(prep, "shape", i = i) + scale <- get_dpar(prep, "mu", i) / shape + args <- nlist(shape, scale, hu) + out <- log_lik_censor("hurdle_gamma", args, i, prep) + out <- log_lik_truncate(out, phurdle_gamma, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_hurdle_lognormal <- function(i, prep) { + hu <- get_dpar(prep, "hu", i) + mu <- get_dpar(prep, "mu", i) + sigma <- get_dpar(prep, "sigma", i = i) + args <- nlist(mu, sigma, hu) + out <- log_lik_censor("hurdle_lognormal", args, i, prep) + out <- log_lik_truncate(out, phurdle_lognormal, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_zero_inflated_poisson <- function(i, prep) { + zi <- get_dpar(prep, "zi", i) + lambda <- get_dpar(prep, "mu", i) + args <- nlist(lambda, zi) + out <- log_lik_censor("zero_inflated_poisson", args, i, prep) + out <- log_lik_truncate(out, pzero_inflated_poisson, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_zero_inflated_negbinomial <- function(i, prep) { + zi <- get_dpar(prep, "zi", i) + mu <- get_dpar(prep, "mu", i) + shape <- get_dpar(prep, "shape", i = i) + args <- nlist(mu, shape, zi) + out <- log_lik_censor("zero_inflated_negbinomial", args, i, prep) + out <- log_lik_truncate(out, pzero_inflated_negbinomial, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_zero_inflated_binomial <- function(i, prep) { + trials <- prep$data$trials[i] + mu <- get_dpar(prep, "mu", i) + zi <- get_dpar(prep, "zi", i) + args <- list(size = trials, prob = mu, zi = zi) + out <- log_lik_censor("zero_inflated_binomial", args, i, prep) + out <- log_lik_truncate(out, pzero_inflated_binomial, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_zero_inflated_beta_binomial <- function(i, prep) { + trials <- prep$data$trials[i] + mu <- get_dpar(prep, "mu", i) + phi <- get_dpar(prep, "phi", i) + zi <- get_dpar(prep, "zi", i) + args <- nlist(size = trials, mu, phi, zi) + out <- log_lik_censor("zero_inflated_beta_binomial", args, i, prep) + out <- log_lik_truncate(out, pzero_inflated_beta_binomial, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_zero_inflated_beta <- function(i, prep) { + zi <- get_dpar(prep, "zi", i) + mu <- get_dpar(prep, "mu", i) + phi <- get_dpar(prep, "phi", i) + args <- nlist(shape1 = mu * phi, shape2 = (1 - mu) * phi, zi) + out <- log_lik_censor("zero_inflated_beta", args, i, prep) + out <- log_lik_truncate(out, pzero_inflated_beta, args, i, prep) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_zero_one_inflated_beta <- function(i, prep) { + zoi <- get_dpar(prep, "zoi", i) + coi <- get_dpar(prep, "coi", i) + if (prep$data$Y[i] %in% c(0, 1)) { + out <- dbinom(1, size = 1, prob = zoi, log = TRUE) + + dbinom(prep$data$Y[i], size = 1, prob = coi, log = TRUE) + } else { + phi <- get_dpar(prep, "phi", i) + mu <- get_dpar(prep, "mu", i) + args <- list(shape1 = mu * phi, shape2 = (1 - mu) * phi) + out <- dbinom(0, size = 1, prob = zoi, log = TRUE) + + do_call(dbeta, c(prep$data$Y[i], args, log = TRUE)) + } + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_categorical <- function(i, prep) { + stopifnot(prep$family$link == "logit") + eta <- get_Mu(prep, i = i) + eta <- insert_refcat(eta, refcat = prep$refcat) + out <- dcategorical(prep$data$Y[i], eta = eta, log = TRUE) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_multinomial <- function(i, prep) { + stopifnot(prep$family$link == "logit") + eta <- get_Mu(prep, i = i) + eta <- insert_refcat(eta, refcat = prep$refcat) + out <- dmultinomial(prep$data$Y[i, ], eta = eta, log = TRUE) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_dirichlet <- function(i, prep) { + stopifnot(prep$family$link == "logit") + eta <- get_Mu(prep, i = i) + eta <- insert_refcat(eta, refcat = prep$refcat) + phi <- get_dpar(prep, "phi", i = i) + cats <- seq_len(prep$data$ncat) + alpha <- dcategorical(cats, eta = eta) * phi + out <- ddirichlet(prep$data$Y[i, ], alpha = alpha, log = TRUE) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_dirichlet2 <- function(i, prep) { + mu <- get_Mu(prep, i = i) + out <- ddirichlet(prep$data$Y[i, ], alpha = mu, log = TRUE) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_logistic_normal <- function(i, prep, ...) { + mu <- get_Mu(prep, i = i) + Sigma <- get_Sigma(prep, i = i, cor_name = "lncor") + dlmn <- function(s) { + dlogistic_normal( + prep$data$Y[i, ], mu = mu[s, ], Sigma = Sigma[s, , ], + refcat = prep$refcat, log = TRUE + ) + } + out <- sapply(1:prep$ndraws, dlmn) + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_cumulative <- function(i, prep) { + disc <- get_dpar(prep, "disc", i = i) + mu <- get_dpar(prep, "mu", i = i) + thres <- subset_thres(prep, i) + nthres <- NCOL(thres) + eta <- disc * (thres - mu) + y <- prep$data$Y[i] + if (y == 1L) { + out <- log_cdf(eta[, 1L], prep$family$link) + } else if (y == nthres + 1L) { + out <- log_ccdf(eta[, y - 1L], prep$family$link) + } else { + out <- log_diff_exp( + log_cdf(eta[, y], prep$family$link), + log_cdf(eta[, y - 1L], prep$family$link) + ) + } + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_sratio <- function(i, prep) { + disc <- get_dpar(prep, "disc", i = i) + mu <- get_dpar(prep, "mu", i = i) + thres <- subset_thres(prep, i) + nthres <- NCOL(thres) + eta <- disc * (thres - mu) + y <- prep$data$Y[i] + q <- sapply(seq_len(min(y, nthres)), + function(k) log_ccdf(eta[, k], prep$family$link) + ) + if (y == 1L) { + out <- log1m_exp(q[, 1L]) + } else if (y == 2L) { + out <- log1m_exp(q[, 2L]) + q[, 1L] + } else if (y == nthres + 1L) { + out <- rowSums(q) + } else { + out <- log1m_exp(q[, y]) + rowSums(q[, 1L:(y - 1L)]) + } + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_cratio <- function(i, prep) { + disc <- get_dpar(prep, "disc", i = i) + mu <- get_dpar(prep, "mu", i = i) + thres <- subset_thres(prep, i) + nthres <- NCOL(thres) + eta <- disc * (mu - thres) + y <- prep$data$Y[i] + q <- sapply(seq_len(min(y, nthres)), + function(k) log_cdf(eta[, k], prep$family$link) + ) + if (y == 1L) { + out <- log1m_exp(q[, 1L]) + } else if (y == 2L) { + out <- log1m_exp(q[, 2L]) + q[, 1L] + } else if (y == nthres + 1L) { + out <- rowSums(q) + } else { + out <- log1m_exp(q[, y]) + rowSums(q[, 1L:(y - 1L)]) + } + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_acat <- function(i, prep) { + disc <- get_dpar(prep, "disc", i = i) + mu <- get_dpar(prep, "mu", i = i) + thres <- subset_thres(prep, i) + nthres <- NCOL(thres) + eta <- disc * (mu - thres) + y <- prep$data$Y[i] + # TODO: check if computation can be made more numerically stable + if (prep$family$link == "logit") { + # more efficient computation for logit link + q <- sapply(1:nthres, function(k) eta[, k]) + p <- cbind(rep(0, nrow(eta)), q[, 1], + matrix(0, nrow = nrow(eta), ncol = nthres - 1)) + if (nthres > 1L) { + p[, 3:(nthres + 1)] <- + sapply(3:(nthres + 1), function(k) rowSums(q[, 1:(k - 1)])) + } + out <- p[, y] - log(rowSums(exp(p))) + } else { + q <- sapply(1:nthres, function(k) + inv_link(eta[, k], prep$family$link)) + p <- cbind(apply(1 - q[, 1:nthres], 1, prod), + matrix(0, nrow = nrow(eta), ncol = nthres)) + if (nthres > 1L) { + p[, 2:nthres] <- sapply(2:nthres, function(k) + apply(as.matrix(q[, 1:(k - 1)]), 1, prod) * + apply(as.matrix(1 - q[, k:nthres]), 1, prod)) + } + p[, nthres + 1] <- apply(q[, 1:nthres], 1, prod) + out <- log(p[, y]) - log(apply(p, 1, sum)) + } + log_lik_weight(out, i = i, prep = prep) +} + +log_lik_custom <- function(i, prep) { + custom_family_method(prep$family, "log_lik")(i, prep) +} + +log_lik_mixture <- function(i, prep) { + families <- family_names(prep$family) + theta <- get_theta(prep, i = i) + out <- array(NA, dim = dim(theta)) + for (j in seq_along(families)) { + log_lik_fun <- paste0("log_lik_", families[j]) + log_lik_fun <- get(log_lik_fun, asNamespace("brms")) + tmp_draws <- pseudo_prep_for_mixture(prep, j) + out[, j] <- exp(log(theta[, j]) + log_lik_fun(i, tmp_draws)) + } + if (isTRUE(prep[["pp_mixture"]])) { + out <- log(out) - log(rowSums(out)) + } else { + out <- log(rowSums(out)) + } + log_lik_weight(out, i = i, prep = prep) +} + +# ----------- log_lik helper-functions ----------- +# compute (possibly censored) log_lik values +# @param dist name of a distribution for which the functions +# d (pdf) and p (cdf) are available +# @param args additional arguments passed to pdf and cdf +# @param prep a brmsprep object +# @return vector of log_lik values +log_lik_censor <- function(dist, args, i, prep) { + pdf <- get(paste0("d", dist), mode = "function") + cdf <- get(paste0("p", dist), mode = "function") + y <- prep$data$Y[i] + cens <- prep$data$cens[i] + if (is.null(cens) || cens == 0) { + x <- do_call(pdf, c(y, args, log = TRUE)) + } else if (cens == 1) { + x <- do_call(cdf, c(y, args, lower.tail = FALSE, log.p = TRUE)) + } else if (cens == -1) { + x <- do_call(cdf, c(y, args, log.p = TRUE)) + } else if (cens == 2) { + rcens <- prep$data$rcens[i] + x <- log(do_call(cdf, c(rcens, args)) - do_call(cdf, c(y, args))) + } + x +} + +# adjust log_lik in truncated models +# @param x vector of log_lik values +# @param cdf a cumulative distribution function +# @param args arguments passed to cdf +# @param i observation number +# @param prep a brmsprep object +# @return vector of log_lik values +log_lik_truncate <- function(x, cdf, args, i, prep) { + lb <- prep$data$lb[i] + ub <- prep$data$ub[i] + if (!(is.null(lb) && is.null(ub))) { + if (is.null(lb)) lb <- -Inf + if (is.null(ub)) ub <- Inf + x - log(do_call(cdf, c(ub, args)) - do_call(cdf, c(lb, args))) + } + x +} + +# weight log_lik values according to defined weights +# @param x vector of log_lik values +# @param i observation number +# @param prep a brmsprep object +# @return vector of log_lik values +log_lik_weight <- function(x, i, prep) { + weight <- prep$data$weights[i] + if (!is.null(weight)) { + x <- x * weight + } + x +} + +# after some discussion with Aki Vehtari and Daniel Simpson, +# I disallowed computation of log-likelihood values for some models +# until pointwise solutions are implemented +stop_no_pw <- function() { + stop2("Cannot yet compute pointwise log-likelihood for this model ", + "because the observations are not conditionally independent.") +} + +# multiplicate factor for conditional student-t models +# see http://proceedings.mlr.press/v33/shah14.pdf +# note that brms parameterizes C instead of Cov(y) = df / (df - 2) * C +# @param df degrees of freedom parameter +# @param Cinv inverse of the full matrix +# @param e vector of error terms, that is, y - mu +student_t_cov_factor <- function(df, Cinv, e) { + beta1 <- ulapply(seq_rows(Cinv), student_t_beta1_i, Cinv, e) + (df + beta1) / (df + nrow(Cinv) - 1) +} + +# beta1 in equation (6) of http://proceedings.mlr.press/v33/shah14.pdf +# @param i observation index to exclude in the submatrix +# @param Cinv inverse of the full matrix +# @param e vector of error terms, that is, y - mu +# @param vector of length one +student_t_beta1_i <- function(i, Cinv, e) { + sub_Cinv_i <- sub_inverse_symmetric(Cinv, i) + t(e[-i]) %*% sub_Cinv_i %*% e[-i] +} + +# efficient submatrix inverse for a symmetric matrix +# see http://www.scielo.org.mx/pdf/cys/v20n2/1405-5546-cys-20-02-00251.pdf +# @param Cinv inverse of the full matrix +# @param i observation index to exclude in the submatrix +# @return inverse of the submatrix after removing observation i +sub_inverse_symmetric <- function(Cinv, i) { + csub <- Cinv[i, -i] + D <- outer(csub, csub) + Cinv[-i, -i] - D / Cinv[i, i] +} diff -Nru r-cran-brms-2.16.3/R/loo_moment_match.R r-cran-brms-2.17.0/R/loo_moment_match.R --- r-cran-brms-2.16.3/R/loo_moment_match.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/loo_moment_match.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,205 +1,205 @@ -#' Moment matching for efficient approximate leave-one-out cross-validation -#' -#' Moment matching for efficient approximate leave-one-out cross-validation -#' (LOO-CV). See \code{\link[loo:loo_moment_match]{loo_moment_match}} -#' for more details. -#' -#' @aliases loo_moment_match -#' -#' @inheritParams predict.brmsfit -#' @param x An object of class \code{brmsfit}. -#' @param loo An object of class \code{loo} originally created from \code{x}. -#' @param k_threshold The threshold at which Pareto \eqn{k} -#' estimates are treated as problematic. Defaults to \code{0.7}. -#' See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} -#' for more details. -#' @param check Logical; If \code{TRUE} (the default), some checks -#' check are performed if the \code{loo} object was generated -#' from the \code{brmsfit} object passed to argument \code{fit}. -#' @param ... Further arguments passed to the underlying methods. -#' Additional arguments initially passed to \code{\link{loo}}, -#' for example, \code{newdata} or \code{resp} need to be passed -#' again to \code{loo_moment_match} in order for the latter -#' to work correctly. -#' @return An updated object of class \code{loo}. -#' -#' @details The moment matching algorithm requires draws of all variables -#' defined in Stan's \code{parameters} block to be saved. Otherwise -#' \code{loo_moment_match} cannot be computed. Thus, please set -#' \code{save_pars = save_pars(all = TRUE)} in the call to \code{\link{brm}}, -#' if you are planning to apply \code{loo_moment_match} to your models. -#' -#' @references -#' Paananen, T., Piironen, J., Buerkner, P.-C., Vehtari, A. (2021). -#' Implicitly Adaptive Importance Sampling. Statistics and Computing. -#' -#' @examples -#' \dontrun{ -#' fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), -#' data = epilepsy, family = poisson(), -#' save_pars = save_pars(all = TRUE)) -#' -#' # throws warning about some pareto k estimates being too high -#' (loo1 <- loo(fit1)) -#' (mmloo1 <- loo_moment_match(fit1, loo = loo1)) -#' } -#' -#' @importFrom loo loo_moment_match -#' @export loo_moment_match -#' @export -loo_moment_match.brmsfit <- function(x, loo, k_threshold = 0.7, newdata = NULL, - resp = NULL, check = TRUE, ...) { - stopifnot(is.loo(loo), is.brmsfit(x)) - if (is.null(newdata)) { - newdata <- model.frame(x) - } else { - newdata <- as.data.frame(newdata) - } - check <- as_one_logical(check) - if (check) { - yhash_loo <- attr(loo, "yhash") - yhash_fit <- hash_response(x, newdata = newdata) - if (!is_equal(yhash_loo, yhash_fit)) { - stop2( - "Response values used in 'loo' and 'x' do not match. ", - "If this is a false positive, please set 'check' to FALSE." - ) - } - } - # otherwise loo_moment_match might not work in a new R session - x <- update_misc_env(x) - out <- try(loo::loo_moment_match.default( - x, loo = loo, - post_draws = as.matrix, - log_lik_i = .log_lik_i, - unconstrain_pars = .unconstrain_pars, - log_prob_upars = .log_prob_upars, - log_lik_i_upars = .log_lik_i_upars, - k_threshold = k_threshold, - newdata = newdata, - resp = resp, ... - )) - if (is(out, "try-error")) { - stop2( - "Moment matching failed. Perhaps you did not set ", - "'save_pars = save_pars(all = TRUE)' when fitting your model?" - ) - } - out -} - -# compute a vector of log-likelihood values for the ith observation -.log_lik_i <- function(x, i, newdata, ...) { - as.vector(log_lik(x, newdata = newdata[i, , drop = FALSE], ...)) -} - -# transform parameters to the unconstrained space -.unconstrain_pars <- function(x, pars, ...) { - unconstrain_pars_stanfit(x$fit, pars = pars, ...) -} - -# compute log_prob for each posterior draws on the unconstrained space -.log_prob_upars <- function(x, upars, ...) { - x <- update_misc_env(x, only_windows = TRUE) - log_prob_upars_stanfit(x$fit, upars = upars, ...) -} - -# transform parameters to the constraint space -.update_pars <- function(x, upars, ...) { - # list with one element per posterior draw - pars <- apply(upars, 1, .constrain_pars, x = x) - # select required parameters only - pars <- lapply(pars, "[", x$fit@sim$pars_oi_old) - # transform draws - ndraws <- length(pars) - pars <- unlist(pars) - npars <- length(pars) / ndraws - dim(pars) <- c(npars, ndraws) - # add dummy 'lp__' draws - pars <- rbind(pars, rep(0, ndraws)) - # bring draws into the right structure - new_draws <- named_list(x$fit@sim$fnames_oi_old, list(numeric(ndraws))) - if (length(new_draws) != nrow(pars)) { - stop2("Updating parameters in `loo_moment_match.brmsfit' failed. ", - "Please report a bug at https://github.com/paul-buerkner/brms.") - } - for (i in seq_len(npars)) { - new_draws[[i]] <- pars[i, ] - } - # create new sim object to overwrite x$fit@sim - x$fit@sim <- list( - samples = list(new_draws), - iter = ndraws, - thin = 1, - warmup = 0, - chains = 1, - n_save = ndraws, - warmup2 = 0, - permutation = list(seq_len(ndraws)), - pars_oi = x$fit@sim$pars_oi_old, - dims_oi = x$fit@sim$dims_oi_old, - fnames_oi = x$fit@sim$fnames_oi_old, - n_flatnames = length(x$fit@sim$fnames_oi_old) - ) - x$fit@stan_args <- list( - list(chain_id = 1, iter = ndraws, thin = 1, warmup = 0) - ) - rename_pars(x) -} - -# wrapper around rstan::constrain_pars -# ensures that the right posterior draws are excluded -.constrain_pars <- function(upars, x) { - out <- rstan::constrain_pars(upars, object = x$fit) - out[x$exclude] <- NULL - out -} - -# compute log_lik values based on the unconstrained parameters -.log_lik_i_upars <- function(x, upars, i, ndraws = NULL, - draw_ids = NULL, ...) { - # do not pass draw_ids or ndraws further to avoid subsetting twice - x <- update_misc_env(x, only_windows = TRUE) - x <- .update_pars(x, upars = upars, ...) - .log_lik_i(x, i = i, ...) -} - -# -------- will be imported from rstan at some point ------- -# transform parameters to the unconstraint space -unconstrain_pars_stanfit <- function(x, pars, ...) { - skeleton <- .create_skeleton(x@sim$pars_oi, x@par_dims[x@sim$pars_oi]) - upars <- apply(pars, 1, FUN = function(theta) { - rstan::unconstrain_pars(x, pars = .rstan_relist(theta, skeleton)) - }) - # for one parameter models - if (is.null(dim(upars))) { - dim(upars) <- c(1, length(upars)) - } - t(upars) -} - -# compute log_prob for each posterior draws on the unconstrained space -log_prob_upars_stanfit <- function(x, upars, ...) { - apply(upars, 1, rstan::log_prob, object = x, - adjust_transform = TRUE, gradient = FALSE) -} - -# create a named list of draws for use with rstan methods -.rstan_relist <- function (x, skeleton) { - out <- utils::relist(x, skeleton) - for (i in seq_along(skeleton)) { - dim(out[[i]]) <- dim(skeleton[[i]]) - } - out -} - -# rstan helper function to get dims of parameters right -.create_skeleton <- function (pars, dims) { - out <- lapply(seq_along(pars), function(i) { - len_dims <- length(dims[[i]]) - if (len_dims < 1) return(0) - return(array(0, dim = dims[[i]])) - }) - names(out) <- pars - out -} +#' Moment matching for efficient approximate leave-one-out cross-validation +#' +#' Moment matching for efficient approximate leave-one-out cross-validation +#' (LOO-CV). See \code{\link[loo:loo_moment_match]{loo_moment_match}} +#' for more details. +#' +#' @aliases loo_moment_match +#' +#' @inheritParams predict.brmsfit +#' @param x An object of class \code{brmsfit}. +#' @param loo An object of class \code{loo} originally created from \code{x}. +#' @param k_threshold The threshold at which Pareto \eqn{k} +#' estimates are treated as problematic. Defaults to \code{0.7}. +#' See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} +#' for more details. +#' @param check Logical; If \code{TRUE} (the default), some checks +#' check are performed if the \code{loo} object was generated +#' from the \code{brmsfit} object passed to argument \code{fit}. +#' @param ... Further arguments passed to the underlying methods. +#' Additional arguments initially passed to \code{\link{loo}}, +#' for example, \code{newdata} or \code{resp} need to be passed +#' again to \code{loo_moment_match} in order for the latter +#' to work correctly. +#' @return An updated object of class \code{loo}. +#' +#' @details The moment matching algorithm requires draws of all variables +#' defined in Stan's \code{parameters} block to be saved. Otherwise +#' \code{loo_moment_match} cannot be computed. Thus, please set +#' \code{save_pars = save_pars(all = TRUE)} in the call to \code{\link{brm}}, +#' if you are planning to apply \code{loo_moment_match} to your models. +#' +#' @references +#' Paananen, T., Piironen, J., Buerkner, P.-C., Vehtari, A. (2021). +#' Implicitly Adaptive Importance Sampling. Statistics and Computing. +#' +#' @examples +#' \dontrun{ +#' fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), +#' data = epilepsy, family = poisson(), +#' save_pars = save_pars(all = TRUE)) +#' +#' # throws warning about some pareto k estimates being too high +#' (loo1 <- loo(fit1)) +#' (mmloo1 <- loo_moment_match(fit1, loo = loo1)) +#' } +#' +#' @importFrom loo loo_moment_match +#' @export loo_moment_match +#' @export +loo_moment_match.brmsfit <- function(x, loo, k_threshold = 0.7, newdata = NULL, + resp = NULL, check = TRUE, ...) { + stopifnot(is.loo(loo), is.brmsfit(x)) + if (is.null(newdata)) { + newdata <- model.frame(x) + } else { + newdata <- as.data.frame(newdata) + } + check <- as_one_logical(check) + if (check) { + yhash_loo <- attr(loo, "yhash") + yhash_fit <- hash_response(x, newdata = newdata) + if (!is_equal(yhash_loo, yhash_fit)) { + stop2( + "Response values used in 'loo' and 'x' do not match. ", + "If this is a false positive, please set 'check' to FALSE." + ) + } + } + # otherwise loo_moment_match might not work in a new R session + x <- update_misc_env(x) + out <- try(loo::loo_moment_match.default( + x, loo = loo, + post_draws = as.matrix, + log_lik_i = .log_lik_i, + unconstrain_pars = .unconstrain_pars, + log_prob_upars = .log_prob_upars, + log_lik_i_upars = .log_lik_i_upars, + k_threshold = k_threshold, + newdata = newdata, + resp = resp, ... + )) + if (is(out, "try-error")) { + stop2( + "Moment matching failed. Perhaps you did not set ", + "'save_pars = save_pars(all = TRUE)' when fitting your model?" + ) + } + out +} + +# compute a vector of log-likelihood values for the ith observation +.log_lik_i <- function(x, i, newdata, ...) { + as.vector(log_lik(x, newdata = newdata[i, , drop = FALSE], ...)) +} + +# transform parameters to the unconstrained space +.unconstrain_pars <- function(x, pars, ...) { + unconstrain_pars_stanfit(x$fit, pars = pars, ...) +} + +# compute log_prob for each posterior draws on the unconstrained space +.log_prob_upars <- function(x, upars, ...) { + x <- update_misc_env(x, only_windows = TRUE) + log_prob_upars_stanfit(x$fit, upars = upars, ...) +} + +# transform parameters to the constraint space +.update_pars <- function(x, upars, ...) { + # list with one element per posterior draw + pars <- apply(upars, 1, .constrain_pars, x = x) + # select required parameters only + pars <- lapply(pars, "[", x$fit@sim$pars_oi_old) + # transform draws + ndraws <- length(pars) + pars <- unlist(pars) + npars <- length(pars) / ndraws + dim(pars) <- c(npars, ndraws) + # add dummy 'lp__' draws + pars <- rbind(pars, rep(0, ndraws)) + # bring draws into the right structure + new_draws <- named_list(x$fit@sim$fnames_oi_old, list(numeric(ndraws))) + if (length(new_draws) != nrow(pars)) { + stop2("Updating parameters in `loo_moment_match.brmsfit' failed. ", + "Please report a bug at https://github.com/paul-buerkner/brms.") + } + for (i in seq_len(npars)) { + new_draws[[i]] <- pars[i, ] + } + # create new sim object to overwrite x$fit@sim + x$fit@sim <- list( + samples = list(new_draws), + iter = ndraws, + thin = 1, + warmup = 0, + chains = 1, + n_save = ndraws, + warmup2 = 0, + permutation = list(seq_len(ndraws)), + pars_oi = x$fit@sim$pars_oi_old, + dims_oi = x$fit@sim$dims_oi_old, + fnames_oi = x$fit@sim$fnames_oi_old, + n_flatnames = length(x$fit@sim$fnames_oi_old) + ) + x$fit@stan_args <- list( + list(chain_id = 1, iter = ndraws, thin = 1, warmup = 0) + ) + rename_pars(x) +} + +# wrapper around rstan::constrain_pars +# ensures that the right posterior draws are excluded +.constrain_pars <- function(upars, x) { + out <- rstan::constrain_pars(upars, object = x$fit) + out[x$exclude] <- NULL + out +} + +# compute log_lik values based on the unconstrained parameters +.log_lik_i_upars <- function(x, upars, i, ndraws = NULL, + draw_ids = NULL, ...) { + # do not pass draw_ids or ndraws further to avoid subsetting twice + x <- update_misc_env(x, only_windows = TRUE) + x <- .update_pars(x, upars = upars, ...) + .log_lik_i(x, i = i, ...) +} + +# -------- will be imported from rstan at some point ------- +# transform parameters to the unconstraint space +unconstrain_pars_stanfit <- function(x, pars, ...) { + skeleton <- .create_skeleton(x@sim$pars_oi, x@par_dims[x@sim$pars_oi]) + upars <- apply(pars, 1, FUN = function(theta) { + rstan::unconstrain_pars(x, pars = .rstan_relist(theta, skeleton)) + }) + # for one parameter models + if (is.null(dim(upars))) { + dim(upars) <- c(1, length(upars)) + } + t(upars) +} + +# compute log_prob for each posterior draws on the unconstrained space +log_prob_upars_stanfit <- function(x, upars, ...) { + apply(upars, 1, rstan::log_prob, object = x, + adjust_transform = TRUE, gradient = FALSE) +} + +# create a named list of draws for use with rstan methods +.rstan_relist <- function (x, skeleton) { + out <- utils::relist(x, skeleton) + for (i in seq_along(skeleton)) { + dim(out[[i]]) <- dim(skeleton[[i]]) + } + out +} + +# rstan helper function to get dims of parameters right +.create_skeleton <- function (pars, dims) { + out <- lapply(seq_along(pars), function(i) { + len_dims <- length(dims[[i]]) + if (len_dims < 1) return(0) + return(array(0, dim = dims[[i]])) + }) + names(out) <- pars + out +} diff -Nru r-cran-brms-2.16.3/R/loo_predict.R r-cran-brms-2.17.0/R/loo_predict.R --- r-cran-brms-2.16.3/R/loo_predict.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/loo_predict.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,224 +1,224 @@ -#' Compute Weighted Expectations Using LOO -#' -#' These functions are wrappers around the \code{\link[loo]{E_loo}} -#' function of the \pkg{loo} package. -#' -#' @aliases loo_predict loo_linpred loo_predictive_interval -#' -#' @param object An object of class \code{brmsfit}. -#' @param type The statistic to be computed on the results. -#' Can by either \code{"mean"} (default), \code{"var"}, or -#' \code{"quantile"}. -#' @param probs A vector of quantiles to compute. -#' Only used if \code{type = quantile}. -#' @param prob For \code{loo_predictive_interval}, a scalar in \eqn{(0,1)} -#' indicating the desired probability mass to include in the intervals. The -#' default is \code{prob = 0.9} (\eqn{90}\% intervals). -#' @param psis_object An optional object returned by \code{\link[loo]{psis}}. -#' If \code{psis_object} is missing then \code{\link[loo]{psis}} is executed -#' internally, which may be time consuming for models fit to very large datasets. -#' @param ... Optional arguments passed to the underlying methods that is -#' \code{\link[brms:log_lik.brmsfit]{log_lik}}, as well as -#' \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}} or -#' \code{\link[brms:posterior_linpred.brmsfit]{posterior_linpred}}. -#' @inheritParams posterior_predict.brmsfit -#' -#' @return \code{loo_predict} and \code{loo_linpred} return a vector with one -#' element per observation. The only exception is if \code{type = "quantile"} -#' and \code{length(probs) >= 2}, in which case a separate vector for each -#' element of \code{probs} is computed and they are returned in a matrix with -#' \code{length(probs)} rows and one column per observation. -#' -#' \code{loo_predictive_interval} returns a matrix with one row per -#' observation and two columns. -#' \code{loo_predictive_interval(..., prob = p)} is equivalent to -#' \code{loo_predict(..., type = "quantile", probs = c(a, 1-a))} with -#' \code{a = (1 - p)/2}, except it transposes the result and adds informative -#' column names. -#' -#' @examples -#' \dontrun{ -#' ## data from help("lm") -#' ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14) -#' trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69) -#' d <- data.frame( -#' weight = c(ctl, trt), -#' group = gl(2, 10, 20, labels = c("Ctl", "Trt")) -#' ) -#' fit <- brm(weight ~ group, data = d) -#' loo_predictive_interval(fit, prob = 0.8) -#' -#' ## optionally log-weights can be pre-computed and reused -#' psis <- loo::psis(-log_lik(fit), cores = 2) -#' loo_predictive_interval(fit, prob = 0.8, psis_object = psis) -#' loo_predict(fit, type = "var", psis_object = psis) -#' } -#' -#' @method loo_predict brmsfit -#' @importFrom rstantools loo_predict -#' @export loo_predict -#' @export -loo_predict.brmsfit <- function(object, type = c("mean", "var", "quantile"), - probs = 0.5, psis_object = NULL, resp = NULL, - ...) { - type <- match.arg(type) - stopifnot_resp(object, resp) - if (is.null(psis_object)) { - message("Running PSIS to compute weights") - psis_object <- compute_loo(object, criterion = "psis", resp = resp, ...) - } - preds <- posterior_predict(object, resp = resp, ...) - loo::E_loo(preds, psis_object, type = type, probs = probs)$value -} - -#' @rdname loo_predict.brmsfit -#' @method loo_linpred brmsfit -#' @importFrom rstantools loo_linpred -#' @export loo_linpred -#' @export -loo_linpred.brmsfit <- function(object, type = c("mean", "var", "quantile"), - probs = 0.5, psis_object = NULL, resp = NULL, - ...) { - type <- match.arg(type) - stopifnot_resp(object, resp) - family <- family(object, resp = resp) - if (is_ordinal(family) || is_categorical(family)) { - stop2("Method 'loo_linpred' is not implemented ", - "for categorical or ordinal models") - } - if (is.null(psis_object)) { - message("Running PSIS to compute weights") - psis_object <- compute_loo(object, criterion = "psis", resp = resp, ...) - } - preds <- posterior_linpred(object, resp = resp, ...) - loo::E_loo(preds, psis_object, type = type, probs = probs)$value -} - -#' @rdname loo_predict.brmsfit -#' @method loo_predictive_interval brmsfit -#' @importFrom rstantools loo_predictive_interval -#' @export loo_predictive_interval -#' @export -loo_predictive_interval.brmsfit <- function(object, prob = 0.9, - psis_object = NULL, ...) { - if (length(prob) != 1L) { - stop2("Argument 'prob' should be of length 1.") - } - alpha <- (1 - prob) / 2 - probs <- c(alpha, 1 - alpha) - labs <- paste0(100 * probs, "%") - intervals <- loo_predict( - object, type = "quantile", probs = probs, - psis_object = psis_object, ... - ) - rownames(intervals) <- labs - t(intervals) -} - -#' Compute a LOO-adjusted R-squared for regression models -#' -#' @aliases loo_R2 -#' -#' @inheritParams bayes_R2.brmsfit -#' @param ... Further arguments passed to -#' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}} and -#' \code{\link[brms:log_lik.brmsfit]{log_lik}}, -#' which are used in the computation of the R-squared values. -#' -#' @return If \code{summary = TRUE}, an M x C matrix is returned -#' (M = number of response variables and c = \code{length(probs) + 2}) -#' containing summary statistics of the LOO-adjusted R-squared values. -#' If \code{summary = FALSE}, the posterior draws of the LOO-adjusted -#' R-squared values are returned in an S x M matrix (S is the number of draws). -#' -#' @examples -#' \dontrun{ -#' fit <- brm(mpg ~ wt + cyl, data = mtcars) -#' summary(fit) -#' loo_R2(fit) -#' -#' # compute R2 with new data -#' nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) -#' loo_R2(fit, newdata = nd) -#' } -#' -#' @method loo_R2 brmsfit -#' @importFrom rstantools loo_R2 -#' @export loo_R2 -#' @export -loo_R2.brmsfit <- function(object, resp = NULL, summary = TRUE, - robust = FALSE, probs = c(0.025, 0.975), ...) { - contains_draws(object) - object <- restructure(object) - resp <- validate_resp(resp, object) - summary <- as_one_logical(summary) - # check for precomputed values - R2 <- get_criterion(object, "loo_R2") - if (is.matrix(R2)) { - # assumes unsummarized 'loo_R2' as ensured by 'add_criterion' - take <- colnames(R2) %in% paste0("R2", resp) - R2 <- R2[, take, drop = FALSE] - if (summary) { - R2 <- posterior_summary(R2, probs = probs, robust = robust) - } - return(R2) - } - family <- family(object, resp = resp) - if (conv_cats_dpars(family)) { - stop2("'loo_R2' is not defined for unordered categorical models.") - } - if (is_ordinal(family)) { - warning2( - "Predictions are treated as continuous variables in ", - "'loo_R2' which is likely invalid for ordinal families." - ) - } - args_y <- list(object, warn = TRUE, ...) - args_ypred <- list(object, sort = TRUE, ...) - R2 <- named_list(paste0("R2", resp)) - for (i in seq_along(R2)) { - # assumes expectations of different responses to be independent - args_ypred$resp <- args_y$resp <- resp[i] - y <- do_call(get_y, args_y) - ypred <- do_call(posterior_epred, args_ypred) - ll <- do_call(log_lik, args_ypred) - r_eff <- r_eff_log_lik(ll, object) - if (is_ordinal(family(object, resp = resp[i]))) { - ypred <- ordinal_probs_continuous(ypred) - } - R2[[i]] <- .loo_R2(y, ypred, ll, r_eff) - } - R2 <- do_call(cbind, R2) - colnames(R2) <- paste0("R2", resp) - if (summary) { - R2 <- posterior_summary(R2, probs = probs, robust = robust) - } - R2 -} - -# internal function of loo_R2.brmsfit -# see http://discourse.mc-stan.org/t/stan-summary-r2-or-adjusted-r2/4308/4 -# and https://github.com/stan-dev/rstanarm/blob/master/R/bayes_R2.R -.loo_R2 <- function(y, ypred, ll, r_eff) { - psis_object <- loo::psis(log_ratios = -ll, r_eff = r_eff) - ypredloo <- loo::E_loo(ypred, psis_object, log_ratios = -ll)$value - err_loo <- ypredloo - y - - # simulated dirichlet weights - S <- nrow(ypred) - N <- ncol(ypred) - exp_draws <- matrix(rexp(S * N, rate = 1), nrow = S, ncol = N) - weights <- exp_draws / rowSums(exp_draws) - - var_y <- (N / (N - 1)) * - (rowSums(sweep(weights, 2, y^2, FUN = "*")) - - rowSums(sweep(weights, 2, y, FUN = "*"))^2) - var_err_loo <- (N / (N - 1)) * - (rowSums(sweep(weights, 2, err_loo^2, FUN = "*")) - - rowSums(sweep(weights, 2, err_loo, FUN = "*")^2)) - - out <- unname(1 - var_err_loo / var_y) - out[out < -1] <- -1 - out[out > 1] <- 1 - as.matrix(out) -} +#' Compute Weighted Expectations Using LOO +#' +#' These functions are wrappers around the \code{\link[loo]{E_loo}} +#' function of the \pkg{loo} package. +#' +#' @aliases loo_predict loo_linpred loo_predictive_interval +#' +#' @param object An object of class \code{brmsfit}. +#' @param type The statistic to be computed on the results. +#' Can by either \code{"mean"} (default), \code{"var"}, or +#' \code{"quantile"}. +#' @param probs A vector of quantiles to compute. +#' Only used if \code{type = quantile}. +#' @param prob For \code{loo_predictive_interval}, a scalar in \eqn{(0,1)} +#' indicating the desired probability mass to include in the intervals. The +#' default is \code{prob = 0.9} (\eqn{90}\% intervals). +#' @param psis_object An optional object returned by \code{\link[loo]{psis}}. +#' If \code{psis_object} is missing then \code{\link[loo]{psis}} is executed +#' internally, which may be time consuming for models fit to very large datasets. +#' @param ... Optional arguments passed to the underlying methods that is +#' \code{\link[brms:log_lik.brmsfit]{log_lik}}, as well as +#' \code{\link[brms:posterior_predict.brmsfit]{posterior_predict}} or +#' \code{\link[brms:posterior_linpred.brmsfit]{posterior_linpred}}. +#' @inheritParams posterior_predict.brmsfit +#' +#' @return \code{loo_predict} and \code{loo_linpred} return a vector with one +#' element per observation. The only exception is if \code{type = "quantile"} +#' and \code{length(probs) >= 2}, in which case a separate vector for each +#' element of \code{probs} is computed and they are returned in a matrix with +#' \code{length(probs)} rows and one column per observation. +#' +#' \code{loo_predictive_interval} returns a matrix with one row per +#' observation and two columns. +#' \code{loo_predictive_interval(..., prob = p)} is equivalent to +#' \code{loo_predict(..., type = "quantile", probs = c(a, 1-a))} with +#' \code{a = (1 - p)/2}, except it transposes the result and adds informative +#' column names. +#' +#' @examples +#' \dontrun{ +#' ## data from help("lm") +#' ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14) +#' trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69) +#' d <- data.frame( +#' weight = c(ctl, trt), +#' group = gl(2, 10, 20, labels = c("Ctl", "Trt")) +#' ) +#' fit <- brm(weight ~ group, data = d) +#' loo_predictive_interval(fit, prob = 0.8) +#' +#' ## optionally log-weights can be pre-computed and reused +#' psis <- loo::psis(-log_lik(fit), cores = 2) +#' loo_predictive_interval(fit, prob = 0.8, psis_object = psis) +#' loo_predict(fit, type = "var", psis_object = psis) +#' } +#' +#' @method loo_predict brmsfit +#' @importFrom rstantools loo_predict +#' @export loo_predict +#' @export +loo_predict.brmsfit <- function(object, type = c("mean", "var", "quantile"), + probs = 0.5, psis_object = NULL, resp = NULL, + ...) { + type <- match.arg(type) + stopifnot_resp(object, resp) + if (is.null(psis_object)) { + message("Running PSIS to compute weights") + psis_object <- compute_loo(object, criterion = "psis", resp = resp, ...) + } + preds <- posterior_predict(object, resp = resp, ...) + loo::E_loo(preds, psis_object, type = type, probs = probs)$value +} + +#' @rdname loo_predict.brmsfit +#' @method loo_linpred brmsfit +#' @importFrom rstantools loo_linpred +#' @export loo_linpred +#' @export +loo_linpred.brmsfit <- function(object, type = c("mean", "var", "quantile"), + probs = 0.5, psis_object = NULL, resp = NULL, + ...) { + type <- match.arg(type) + stopifnot_resp(object, resp) + family <- family(object, resp = resp) + if (is_ordinal(family) || is_categorical(family)) { + stop2("Method 'loo_linpred' is not implemented ", + "for categorical or ordinal models") + } + if (is.null(psis_object)) { + message("Running PSIS to compute weights") + psis_object <- compute_loo(object, criterion = "psis", resp = resp, ...) + } + preds <- posterior_linpred(object, resp = resp, ...) + loo::E_loo(preds, psis_object, type = type, probs = probs)$value +} + +#' @rdname loo_predict.brmsfit +#' @method loo_predictive_interval brmsfit +#' @importFrom rstantools loo_predictive_interval +#' @export loo_predictive_interval +#' @export +loo_predictive_interval.brmsfit <- function(object, prob = 0.9, + psis_object = NULL, ...) { + if (length(prob) != 1L) { + stop2("Argument 'prob' should be of length 1.") + } + alpha <- (1 - prob) / 2 + probs <- c(alpha, 1 - alpha) + labs <- paste0(100 * probs, "%") + intervals <- loo_predict( + object, type = "quantile", probs = probs, + psis_object = psis_object, ... + ) + rownames(intervals) <- labs + t(intervals) +} + +#' Compute a LOO-adjusted R-squared for regression models +#' +#' @aliases loo_R2 +#' +#' @inheritParams bayes_R2.brmsfit +#' @param ... Further arguments passed to +#' \code{\link[brms:posterior_epred.brmsfit]{posterior_epred}} and +#' \code{\link[brms:log_lik.brmsfit]{log_lik}}, +#' which are used in the computation of the R-squared values. +#' +#' @return If \code{summary = TRUE}, an M x C matrix is returned +#' (M = number of response variables and c = \code{length(probs) + 2}) +#' containing summary statistics of the LOO-adjusted R-squared values. +#' If \code{summary = FALSE}, the posterior draws of the LOO-adjusted +#' R-squared values are returned in an S x M matrix (S is the number of draws). +#' +#' @examples +#' \dontrun{ +#' fit <- brm(mpg ~ wt + cyl, data = mtcars) +#' summary(fit) +#' loo_R2(fit) +#' +#' # compute R2 with new data +#' nd <- data.frame(mpg = c(10, 20, 30), wt = c(4, 3, 2), cyl = c(8, 6, 4)) +#' loo_R2(fit, newdata = nd) +#' } +#' +#' @method loo_R2 brmsfit +#' @importFrom rstantools loo_R2 +#' @export loo_R2 +#' @export +loo_R2.brmsfit <- function(object, resp = NULL, summary = TRUE, + robust = FALSE, probs = c(0.025, 0.975), ...) { + contains_draws(object) + object <- restructure(object) + resp <- validate_resp(resp, object) + summary <- as_one_logical(summary) + # check for precomputed values + R2 <- get_criterion(object, "loo_R2") + if (is.matrix(R2)) { + # assumes unsummarized 'loo_R2' as ensured by 'add_criterion' + take <- colnames(R2) %in% paste0("R2", resp) + R2 <- R2[, take, drop = FALSE] + if (summary) { + R2 <- posterior_summary(R2, probs = probs, robust = robust) + } + return(R2) + } + family <- family(object, resp = resp) + if (conv_cats_dpars(family)) { + stop2("'loo_R2' is not defined for unordered categorical models.") + } + if (is_ordinal(family)) { + warning2( + "Predictions are treated as continuous variables in ", + "'loo_R2' which is likely invalid for ordinal families." + ) + } + args_y <- list(object, warn = TRUE, ...) + args_ypred <- list(object, sort = TRUE, ...) + R2 <- named_list(paste0("R2", resp)) + for (i in seq_along(R2)) { + # assumes expectations of different responses to be independent + args_ypred$resp <- args_y$resp <- resp[i] + y <- do_call(get_y, args_y) + ypred <- do_call(posterior_epred, args_ypred) + ll <- do_call(log_lik, args_ypred) + r_eff <- r_eff_log_lik(ll, object) + if (is_ordinal(family(object, resp = resp[i]))) { + ypred <- ordinal_probs_continuous(ypred) + } + R2[[i]] <- .loo_R2(y, ypred, ll, r_eff) + } + R2 <- do_call(cbind, R2) + colnames(R2) <- paste0("R2", resp) + if (summary) { + R2 <- posterior_summary(R2, probs = probs, robust = robust) + } + R2 +} + +# internal function of loo_R2.brmsfit +# see http://discourse.mc-stan.org/t/stan-summary-r2-or-adjusted-r2/4308/4 +# and https://github.com/stan-dev/rstanarm/blob/master/R/bayes_R2.R +.loo_R2 <- function(y, ypred, ll, r_eff) { + psis_object <- loo::psis(log_ratios = -ll, r_eff = r_eff) + ypredloo <- loo::E_loo(ypred, psis_object, log_ratios = -ll)$value + err_loo <- ypredloo - y + + # simulated dirichlet weights + S <- nrow(ypred) + N <- ncol(ypred) + exp_draws <- matrix(rexp(S * N, rate = 1), nrow = S, ncol = N) + weights <- exp_draws / rowSums(exp_draws) + + var_y <- (N / (N - 1)) * + (rowSums(sweep(weights, 2, y^2, FUN = "*")) - + rowSums(sweep(weights, 2, y, FUN = "*"))^2) + var_err_loo <- (N / (N - 1)) * + (rowSums(sweep(weights, 2, err_loo^2, FUN = "*")) - + rowSums(sweep(weights, 2, err_loo, FUN = "*")^2)) + + out <- unname(1 - var_err_loo / var_y) + out[out < -1] <- -1 + out[out > 1] <- 1 + as.matrix(out) +} diff -Nru r-cran-brms-2.16.3/R/loo.R r-cran-brms-2.17.0/R/loo.R --- r-cran-brms-2.16.3/R/loo.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/loo.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,936 +1,938 @@ -#' Efficient approximate leave-one-out cross-validation (LOO) -#' -#' Perform approximate leave-one-out cross-validation based -#' on the posterior likelihood using the \pkg{loo} package. -#' For more details see \code{\link[loo:loo]{loo}}. -#' -#' @aliases loo LOO LOO.brmsfit -#' -#' @param x A \code{brmsfit} object. -#' @param ... More \code{brmsfit} objects or further arguments -#' passed to the underlying post-processing functions. -#' In particular, see \code{\link{prepare_predictions}} for further -#' supported arguments. -#' @param compare A flag indicating if the information criteria -#' of the models should be compared to each other -#' via \code{\link{loo_compare}}. -#' @param pointwise A flag indicating whether to compute the full -#' log-likelihood matrix at once or separately for each observation. -#' The latter approach is usually considerably slower but -#' requires much less working memory. Accordingly, if one runs -#' into memory issues, \code{pointwise = TRUE} is the way to go. -#' @param moment_match Logical; Indicate whether \code{\link{loo_moment_match}} -#' should be applied on problematic observations. Defaults to \code{FALSE}. -#' For most models, moment matching will only work if you have set -#' \code{save_pars = save_pars(all = TRUE)} when fitting the model with -#' \code{\link{brm}}. See \code{\link{loo_moment_match.brmsfit}} for more -#' details. -#' @param reloo Logical; Indicate whether \code{\link{reloo}} -#' should be applied on problematic observations. Defaults to \code{FALSE}. -#' @param k_threshold The threshold at which pareto \eqn{k} -#' estimates are treated as problematic. Defaults to \code{0.7}. -#' Only used if argument \code{reloo} is \code{TRUE}. -#' See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} for more details. -#' @param save_psis Should the \code{"psis"} object created internally be saved -#' in the returned object? For more details see \code{\link[loo:loo]{loo}}. -#' @param moment_match_args Optional \code{list} of additional arguments passed to -#' \code{\link{loo_moment_match}}. -#' @param reloo_args Optional \code{list} of additional arguments passed to -#' \code{\link{reloo}}. -#' @param model_names If \code{NULL} (the default) will use model names -#' derived from deparsing the call. Otherwise will use the passed -#' values as model names. -#' @inheritParams predict.brmsfit -#' -#' @details See \code{\link{loo_compare}} for details on model comparisons. -#' For \code{brmsfit} objects, \code{LOO} is an alias of \code{loo}. -#' Use method \code{\link{add_criterion}} to store -#' information criteria in the fitted model object for later usage. -#' -#' @return If just one object is provided, an object of class \code{loo}. -#' If multiple objects are provided, an object of class \code{loolist}. -#' -#' @examples -#' \dontrun{ -#' # model with population-level effects only -#' fit1 <- brm(rating ~ treat + period + carry, -#' data = inhaler) -#' (loo1 <- loo(fit1)) -#' -#' # model with an additional varying intercept for subjects -#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler) -#' (loo2 <- loo(fit2)) -#' -#' # compare both models -#' loo_compare(loo1, loo2) -#' } -#' -#' @references -#' Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model -#' evaluation using leave-one-out cross-validation and WAIC. In Statistics -#' and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. -#' -#' Gelman, A., Hwang, J., & Vehtari, A. (2014). -#' Understanding predictive information criteria for Bayesian models. -#' Statistics and Computing, 24, 997-1016. -#' -#' Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation -#' and widely applicable information criterion in singular learning theory. -#' The Journal of Machine Learning Research, 11, 3571-3594. -#' -#' @importFrom loo loo is.loo -#' @export loo -#' @export -loo.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, - pointwise = FALSE, moment_match = FALSE, - reloo = FALSE, k_threshold = 0.7, save_psis = FALSE, - moment_match_args = list(), reloo_args = list(), - model_names = NULL) { - args <- split_dots(x, ..., model_names = model_names) - c(args) <- nlist( - criterion = "loo", pointwise, compare, - resp, k_threshold, save_psis, moment_match, - reloo, moment_match_args, reloo_args - ) - do_call(compute_loolist, args) -} - -#' @export -LOO.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, - pointwise = FALSE, moment_match = FALSE, - reloo = FALSE, k_threshold = 0.7, save_psis = FALSE, - moment_match_args = list(), reloo_args = list(), - model_names = NULL) { - cl <- match.call() - cl[[1]] <- quote(loo) - eval(cl, parent.frame()) -} - -#' @export -LOO <- function(x, ...) { - UseMethod("LOO") -} - -#' Widely Applicable Information Criterion (WAIC) -#' -#' Compute the widely applicable information criterion (WAIC) -#' based on the posterior likelihood using the \pkg{loo} package. -#' For more details see \code{\link[loo:waic]{waic}}. -#' -#' @aliases waic WAIC WAIC.brmsfit -#' -#' @inheritParams loo.brmsfit -#' -#' @details See \code{\link{loo_compare}} for details on model comparisons. -#' For \code{brmsfit} objects, \code{WAIC} is an alias of \code{waic}. -#' Use method \code{\link[brms:add_criterion]{add_criterion}} to store -#' information criteria in the fitted model object for later usage. -#' -#' @return If just one object is provided, an object of class \code{loo}. -#' If multiple objects are provided, an object of class \code{loolist}. -#' -#' @examples -#' \dontrun{ -#' # model with population-level effects only -#' fit1 <- brm(rating ~ treat + period + carry, -#' data = inhaler) -#' (waic1 <- waic(fit1)) -#' -#' # model with an additional varying intercept for subjects -#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler) -#' (waic2 <- waic(fit2)) -#' -#' # compare both models -#' loo_compare(waic1, waic2) -#' } -#' -#' @references -#' Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model -#' evaluation using leave-one-out cross-validation and WAIC. In Statistics -#' and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. -#' -#' Gelman, A., Hwang, J., & Vehtari, A. (2014). -#' Understanding predictive information criteria for Bayesian models. -#' Statistics and Computing, 24, 997-1016. -#' -#' Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation -#' and widely applicable information criterion in singular learning theory. -#' The Journal of Machine Learning Research, 11, 3571-3594. -#' -#' @importFrom loo waic -#' @export waic -#' @export -waic.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, - pointwise = FALSE, model_names = NULL) { - args <- split_dots(x, ..., model_names = model_names) - c(args) <- nlist(criterion = "waic", pointwise, compare, resp) - do_call(compute_loolist, args) -} - -#' @export -WAIC.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, - pointwise = FALSE, model_names = NULL) { - cl <- match.call() - cl[[1]] <- quote(waic) - eval(cl, parent.frame()) -} - -#' @export -WAIC <- function(x, ...) { - UseMethod("WAIC") -} - -# helper function used to create (lists of) 'loo' objects -# @param models list of brmsfit objects -# @param criterion name of the criterion to compute -# @param use_stored use precomputed criterion objects if possible? -# @param compare compare models using 'loo_compare'? -# @param ... more arguments passed to compute_loo -# @return If length(models) > 1 an object of class 'loolist' -# If length(models) == 1 an object of class 'loo' -compute_loolist <- function(models, criterion, use_stored = TRUE, - compare = TRUE, ...) { - criterion <- match.arg(criterion, loo_criteria()) - args <- nlist(criterion, ...) - for (i in seq_along(models)) { - models[[i]] <- restructure(models[[i]]) - } - if (length(models) > 1L) { - if (!match_nobs(models)) { - stop2("Models have different number of observations.") - } - if (length(use_stored) == 1L) { - use_stored <- rep(use_stored, length(models)) - } - out <- list(loos = named_list(names(models))) - for (i in seq_along(models)) { - args$x <- models[[i]] - args$model_name <- names(models)[i] - args$use_stored <- use_stored[i] - out$loos[[i]] <- do_call(compute_loo, args) - } - compare <- as_one_logical(compare) - if (compare) { - out$diffs <- loo_compare(out$loos) - # for backwards compatibility; remove in brms 3.0 - out$ic_diffs__ <- SW(compare_ic(x = out$loos))$ic_diffs__ - } - class(out) <- "loolist" - } else { - args$x <- models[[1]] - args$model_name <- names(models) - args$use_stored <- use_stored - out <- do_call(compute_loo, args) - } - out -} - -# compute model fit criteria using the 'loo' package -# @param x an object of class brmsfit -# @param criterion the criterion to be computed -# @param newdata optional data.frame of new data -# @param resp optional names of the predicted response variables -# @param model_name original variable name of object 'x' -# @param use_stored use precomputed criterion objects if possible? -# @param ... passed to the individual methods -# @return an object of class 'loo' -compute_loo <- function(x, criterion, newdata = NULL, resp = NULL, - model_name = "", use_stored = TRUE, ...) { - criterion <- match.arg(criterion, loo_criteria()) - model_name <- as_one_character(model_name) - use_stored <- as_one_logical(use_stored) - out <- get_criterion(x, criterion) - if (!(use_stored && is.loo(out))) { - args <- nlist(x, newdata, resp, model_name, ...) - out <- do_call(paste0(".", criterion), args) - attr(out, "yhash") <- hash_response(x, newdata = newdata, resp = resp) - } - attr(out, "model_name") <- model_name - out -} - -# possible criteria to evaluate via the loo package -loo_criteria <- function() { - c("loo", "waic", "psis", "kfold", "loo_subsample") -} - -# compute 'loo' criterion using the 'loo' package -.loo <- function(x, pointwise, k_threshold, moment_match, reloo, - moment_match_args, reloo_args, newdata, - resp, model_name, save_psis, ...) { - loo_args <- prepare_loo_args( - x, newdata = newdata, resp = resp, - pointwise = pointwise, save_psis = save_psis, - ... - ) - out <- SW(do_call("loo", loo_args, pkg = "loo")) - if (moment_match) { - c(moment_match_args) <- nlist( - x, loo = out, newdata, resp, - k_threshold, check = FALSE, ... - ) - out <- do_call("loo_moment_match", moment_match_args) - } - if (reloo) { - c(reloo_args) <- nlist( - x, loo = out, newdata, resp, - k_threshold, check = FALSE, ... - ) - out <- do_call("reloo", reloo_args) - } - recommend_loo_options(out, k_threshold, moment_match, model_name) - out -} - -# compute 'waic' criterion using the 'loo' package -# @param model_name ignored but included to avoid being passed to '...' -.waic <- function(x, pointwise, newdata, resp, model_name, ...) { - loo_args <- prepare_loo_args( - x, newdata = newdata, resp = resp, - pointwise = pointwise, ... - ) - do_call("waic", loo_args, pkg = "loo") -} - -# compute 'psis' criterion using the 'loo' package -# @param model_name ignored but included to avoid being passed to '...' -.psis <- function(x, newdata, resp, model_name, ...) { - loo_args <- prepare_loo_args( - x, newdata = newdata, resp = resp, - pointwise = FALSE, ... - ) - loo_args$log_ratios <- -loo_args$x - loo_args$x <- NULL - do_call("psis", loo_args, pkg = "loo") -} - -# prepare arguments passed to the methods of the `loo` package -prepare_loo_args <- function(x, newdata, resp, pointwise, ...) { - pointwise <- as_one_logical(pointwise) - loo_args <- list(...) - ll_args <- nlist(object = x, newdata, resp, pointwise, ...) - loo_args$x <- do_call(log_lik, ll_args) - if (pointwise) { - loo_args$draws <- attr(loo_args$x, "draws") - loo_args$data <- attr(loo_args$x, "data") - } - # compute pointwise relative efficiencies - r_eff_args <- loo_args - r_eff_args$fit <- x - loo_args$r_eff <- do_call(r_eff_log_lik, r_eff_args) - loo_args -} - -#' Model comparison with the \pkg{loo} package -#' -#' For more details see \code{\link[loo:loo_compare]{loo_compare}}. -#' -#' @aliases loo_compare -#' -#' @inheritParams loo.brmsfit -#' @param ... More \code{brmsfit} objects. -#' @param criterion The name of the criterion to be extracted -#' from \code{brmsfit} objects. -#' -#' @details All \code{brmsfit} objects should contain precomputed -#' criterion objects. See \code{\link{add_criterion}} for more help. -#' -#' @return An object of class "\code{compare.loo}". -#' -#' @examples -#' \dontrun{ -#' # model with population-level effects only -#' fit1 <- brm(rating ~ treat + period + carry, -#' data = inhaler) -#' fit1 <- add_criterion(fit1, "waic") -#' -#' # model with an additional varying intercept for subjects -#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler) -#' fit2 <- add_criterion(fit2, "waic") -#' -#' # compare both models -#' loo_compare(fit1, fit2, criterion = "waic") -#' } -#' -#' @importFrom loo loo_compare -#' @export loo_compare -#' @export -loo_compare.brmsfit <- function(x, ..., criterion = c("loo", "waic", "kfold"), - model_names = NULL) { - criterion <- match.arg(criterion) - models <- split_dots(x, ..., model_names = model_names, other = FALSE) - loos <- named_list(names(models)) - for (i in seq_along(models)) { - models[[i]] <- restructure(models[[i]]) - loos[[i]] <- get_criterion(models[[i]], criterion) - if (is.null(loos[[i]])) { - stop2( - "Model '", names(models)[i], "' does not contain a precomputed '", - criterion, "' criterion. See ?loo_compare.brmsfit for help." - ) - } - } - loo_compare(loos) -} - -#' Model averaging via stacking or pseudo-BMA weighting. -#' -#' Compute model weights for \code{brmsfit} objects via stacking -#' or pseudo-BMA weighting. For more details, see -#' \code{\link[loo:loo_model_weights]{loo::loo_model_weights}}. -#' -#' @aliases loo_model_weights -#' -#' @inheritParams loo.brmsfit -#' -#' @return A named vector of model weights. -#' -#' @examples -#' \dontrun{ -#' # model with population-level effects only -#' fit1 <- brm(rating ~ treat + period + carry, -#' data = inhaler, family = "gaussian") -#' # model with an additional varying intercept for subjects -#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler, family = "gaussian") -#' loo_model_weights(fit1, fit2) -#' } -#' -#' @method loo_model_weights brmsfit -#' @importFrom loo loo_model_weights -#' @export loo_model_weights -#' @export -loo_model_weights.brmsfit <- function(x, ..., model_names = NULL) { - args <- split_dots(x, ..., model_names = model_names) - models <- args$models - args$models <- NULL - log_lik_list <- lapply(models, function(x) - do_call(log_lik, c(list(x), args)) - ) - args$x <- log_lik_list - args$r_eff_list <- mapply( - r_eff_log_lik, log_lik_list, - fit = models, SIMPLIFY = FALSE - ) - out <- do_call(loo::loo_model_weights, args) - names(out) <- names(models) - out -} - -#' Add model fit criteria to model objects -#' -#' @param x An \R object typically of class \code{brmsfit}. -#' @param criterion Names of model fit criteria -#' to compute. Currently supported are \code{"loo"}, -#' \code{"waic"}, \code{"kfold"}, \code{"loo_subsample"}, -#' \code{"bayes_R2"} (Bayesian R-squared), -#' \code{"loo_R2"} (LOO-adjusted R-squared), and -#' \code{"marglik"} (log marginal likelihood). -#' @param model_name Optional name of the model. If \code{NULL} -#' (the default) the name is taken from the call to \code{x}. -#' @param overwrite Logical; Indicates if already stored fit -#' indices should be overwritten. Defaults to \code{FALSE}. -#' @param file Either \code{NULL} or a character string. In the latter case, the -#' fitted model object including the newly added criterion values is saved via -#' \code{\link{saveRDS}} in a file named after the string supplied in -#' \code{file}. The \code{.rds} extension is added automatically. If \code{x} -#' was already stored in a file before, the file name will be reused -#' automatically (with a message) unless overwritten by \code{file}. In any -#' case, \code{file} only applies if new criteria were actually added via -#' \code{add_criterion} or if \code{force_save} was set to \code{TRUE}. -#' @param force_save Logical; only relevant if \code{file} is specified and -#' ignored otherwise. If \code{TRUE}, the fitted model object will be saved -#' regardless of whether new criteria were added via \code{add_criterion}. -#' @param ... Further arguments passed to the underlying -#' functions computing the model fit criteria. -#' -#' @return An object of the same class as \code{x}, but -#' with model fit criteria added for later usage. -#' -#' @details Functions \code{add_loo} and \code{add_waic} are aliases of -#' \code{add_criterion} with fixed values for the \code{criterion} argument. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ Trt, data = epilepsy) -#' # add both LOO and WAIC at once -#' fit <- add_criterion(fit, c("loo", "waic")) -#' print(fit$criteria$loo) -#' print(fit$criteria$waic) -#' } -#' -#' @export -add_criterion <- function(x, ...) { - UseMethod("add_criterion") -} - -#' @rdname add_criterion -#' @export -add_criterion.brmsfit <- function(x, criterion, model_name = NULL, - overwrite = FALSE, file = NULL, - force_save = FALSE, ...) { - if (!is.null(model_name)) { - model_name <- as_one_character(model_name) - } else { - model_name <- deparse_combine(substitute(x)) - } - criterion <- unique(as.character(criterion)) - if (any(criterion == "R2")) { - # deprecated as of version 2.10.4 - warning2("Criterion 'R2' is deprecated. Please use 'bayes_R2' instead.") - criterion[criterion == "R2"] <- "bayes_R2" - } - loo_options <- c("loo", "waic", "kfold", "loo_subsample") - options <- c(loo_options, "bayes_R2", "loo_R2", "marglik") - if (!length(criterion) || !all(criterion %in% options)) { - stop2("Argument 'criterion' should be a subset of ", - collapse_comma(options)) - } - auto_save <- FALSE - if (!is.null(file)) { - file <- paste0(as_one_character(file), ".rds") - } else { - file <- x$file - if (!is.null(file)) auto_save <- TRUE - } - force_save <- as_one_logical(force_save) - overwrite <- as_one_logical(overwrite) - if (overwrite) { - # recompute all criteria - new_criteria <- criterion - } else { - # only computed criteria not already stored - new_criteria <- criterion[ulapply(x$criteria[criterion], is.null)] - } - args <- list(x, ...) - for (fun in intersect(new_criteria, loo_options)) { - args$model_names <- model_name - x$criteria[[fun]] <- do_call(fun, args) - } - if ("bayes_R2" %in% new_criteria) { - args$summary <- FALSE - x$criteria$bayes_R2 <- do_call(bayes_R2, args) - } - if ("loo_R2" %in% new_criteria) { - args$summary <- FALSE - x$criteria$loo_R2 <- do_call(loo_R2, args) - } - if ("marglik" %in% new_criteria) { - x$criteria$marglik <- do_call(bridge_sampler, args) - } - if (!is.null(file) && (force_save || length(new_criteria))) { - if (auto_save) { - message("Automatically saving the model object in '", file, "'") - } - x$file <- file - saveRDS(x, file = file) - } - x -} - -# extract a recomputed model fit criterion -get_criterion <- function(x, criterion) { - stopifnot(is.brmsfit(x)) - criterion <- as_one_character(criterion) - x$criteria[[criterion]] -} - -# create a hash based on the response of a model -hash_response <- function(x, newdata = NULL, resp = NULL, ...) { - require_package("digest") - stopifnot(is.brmsfit(x)) - sdata <- standata( - x, newdata = newdata, re_formula = NA, internal = TRUE, - check_response = TRUE, only_response = TRUE - ) - add_funs <- lsp("brms", what = "exports", pattern = "^resp_") - regex <- c("Y", sub("^resp_", "", add_funs)) - regex <- outer(regex, escape_all(usc(resp)), FUN = paste0) - regex <- paste0("(", as.vector(regex), ")", collapse = "|") - regex <- paste0("^(", regex, ")(_|$)") - out <- sdata[grepl(regex, names(sdata))] - out <- as.matrix(as.data.frame(rmNULL(out))) - out <- p(out, attr(sdata, "old_order")) - # see issue #642 - attributes(out) <- NULL - digest::sha1(x = out, ...) -} - -# compare the response parts of multiple brmsfit objects -# @param models A list of brmsfit objects -# @param ... passed to hash_response -# @return TRUE if the response parts of all models match and FALSE otherwise -match_response <- function(models, ...) { - if (length(models) <= 1L) { - out <- TRUE - } else { - yhash <- lapply(models, hash_response, ...) - yhash_check <- ulapply(yhash, is_equal, yhash[[1]]) - if (all(yhash_check)) { - out <- TRUE - } else { - out <- FALSE - } - } - out -} - -# compare number of observations of multipe models -# @param models A list of brmsfit objects -# @param ... currently ignored -# @return TRUE if the number of rows match -match_nobs <- function(models, ...) { - if (length(models) <= 1L) { - out <- TRUE - } else { - nobs <- lapply(models, nobs) - nobs_check <- ulapply(nobs, is_equal, nobs[[1]]) - if (all(nobs_check)) { - out <- TRUE - } else { - out <- FALSE - } - } - out -} - -# validate models passed to loo and related methods -# @param models list of fitted model objects -# @param model_names names specified by the user -# @param sub_names names inferred by substitute() -validate_models <- function(models, model_names, sub_names) { - stopifnot(is.list(models)) - model_names <- as.character(model_names) - if (!length(model_names)) { - model_names <- as.character(sub_names) - } - if (length(model_names) != length(models)) { - stop2("Number of model names is not equal to the number of models.") - } - names(models) <- model_names - for (i in seq_along(models)) { - if (!is.brmsfit(models[[i]])) { - stop2("Object '", names(models)[i], "' is not of class 'brmsfit'.") - } - } - models -} - -# recommend options if approximate loo fails for some observations -# @param moment_match has moment matching already been performed? -recommend_loo_options <- function(loo, k_threshold, moment_match = FALSE, - model_name = "") { - if (isTRUE(nzchar(model_name))) { - model_name <- paste0(" in model '", model_name, "'") - } else { - model_name <- "" - } - n <- length(loo::pareto_k_ids(loo, threshold = k_threshold)) - if (!moment_match && n > 0) { - warning2( - "Found ", n, " observations with a pareto_k > ", k_threshold, - model_name, ". It is recommended to set 'moment_match = TRUE' in order ", - "to perform moment matching for problematic observations. " - ) - out <- "loo_moment_match" - } else if (n > 0 && n <= 10) { - warning2( - "Found ", n, " observations with a pareto_k > ", k_threshold, - model_name, ". It is recommended to set 'reloo = TRUE' in order to ", - "calculate the ELPD without the assumption that these observations " , - "are negligible. This will refit the model ", n, " times to compute ", - "the ELPDs for the problematic observations directly." - ) - out <- "reloo" - } else if (n > 10) { - warning2( - "Found ", n, " observations with a pareto_k > ", k_threshold, - model_name, ". With this many problematic observations, it may be more ", - "appropriate to use 'kfold' with argument 'K = 10' to perform ", - "10-fold cross-validation rather than LOO." - ) - out <- "kfold" - } else { - out <- "loo" - } - invisible(out) -} - -# helper function to compute relative efficiences -# @param x matrix of posterior draws -# @param fit a brmsfit object to extract metadata from -# @param allow_na allow NA values in the output? -# @return a numeric vector of length NCOL(x) -r_eff_helper <- function(x, chain_id, allow_na = TRUE, ...) { - out <- loo::relative_eff(x, chain_id = chain_id, ...) - if (!allow_na && anyNA(out)) { - # avoid error in loo if some but not all r_effs are NA - out <- rep(1, length(out)) - warning2( - "Ignoring relative efficiencies as some were NA. ", - "See argument 'r_eff' in ?loo::loo for more details." - ) - } - out -} - -# wrapper around r_eff_helper to compute efficiency -# of likelihood draws based on log-likelihood draws -r_eff_log_lik <- function(x, ...) { - UseMethod("r_eff_log_lik") -} - -#' @export -r_eff_log_lik.matrix <- function(x, fit, allow_na = FALSE, ...) { - if (is.brmsfit_multiple(fit)) { - # due to stacking of chains from multiple models - # efficiency computations will likely be incorrect - # assume relative efficiency of 1 for now - return(rep(1, ncol(x))) - } - chain_id <- get_chain_id(nrow(x), fit) - r_eff_helper(exp(x), chain_id = chain_id, allow_na = allow_na, ...) -} - -#' @export -r_eff_log_lik.function <- function(x, fit, draws, allow_na = FALSE, ...) { - if (is.brmsfit_multiple(fit)) { - # due to stacking of chains from multiple models - # efficiency computations will likely be incorrect - # assume relative efficiency of 1 for now - return(rep(1, draws$nobs)) - } - lik_fun <- function(data_i, draws, ...) { - exp(x(data_i, draws, ...)) - } - chain_id <- get_chain_id(draws$ndraws, fit) - r_eff_helper( - lik_fun, chain_id = chain_id, draws = draws, - allow_na = allow_na, ... - ) -} - -# get chain IDs per posterior draw -get_chain_id <- function(ndraws, fit) { - if (ndraws != ndraws(fit)) { - # don't know the chain IDs of a subset of draws - chain_id <- rep(1L, ndraws) - } else { - nchains <- fit$fit@sim$chains - chain_id <- rep(seq_len(nchains), each = ndraws / nchains) - } - chain_id -} - -# print the output of a list of loo objects -#' @export -print.loolist <- function(x, digits = 1, ...) { - model_names <- loo::find_model_names(x$loos) - for (i in seq_along(x$loos)) { - cat(paste0("Output of model '", model_names[i], "':\n")) - print(x$loos[[i]], digits = digits, ...) - cat("\n") - } - if (!is.null(x$diffs)) { - cat("Model comparisons:\n") - print(x$diffs, digits = digits, ...) - } - invisible(x) -} - -# ---------- deprecated functions ---------- -#' @rdname add_ic -#' @export -add_loo <- function(x, model_name = NULL, ...) { - warning2("'add_loo' is deprecated. Please use 'add_criterion' instead.") - if (!is.null(model_name)) { - model_name <- as_one_character(model_name) - } else { - model_name <- deparse_combine(substitute(x)) - } - add_criterion(x, criterion = "loo", model_name = model_name, ...) -} - -#' @rdname add_ic -#' @export -add_waic <- function(x, model_name = NULL, ...) { - warning2("'add_waic' is deprecated. Please use 'add_criterion' instead.") - if (!is.null(model_name)) { - model_name <- as_one_character(model_name) - } else { - model_name <- deparse_combine(substitute(x)) - } - add_criterion(x, criterion = "waic", model_name = model_name, ...) -} - -#' Add model fit criteria to model objects -#' -#' Deprecated aliases of \code{\link{add_criterion}}. -#' -#' @inheritParams add_criterion -#' @param ic,value Names of model fit criteria -#' to compute. Currently supported are \code{"loo"}, -#' \code{"waic"}, \code{"kfold"}, \code{"R2"} (R-squared), and -#' \code{"marglik"} (log marginal likelihood). -#' -#' @return An object of the same class as \code{x}, but -#' with model fit criteria added for later usage. -#' Previously computed criterion objects will be overwritten. -#' -#' @export -add_ic <- function(x, ...) { - UseMethod("add_ic") -} - -#' @rdname add_ic -#' @export -add_ic.brmsfit <- function(x, ic = "loo", model_name = NULL, ...) { - warning2("'add_ic' is deprecated. Please use 'add_criterion' instead.") - if (!is.null(model_name)) { - model_name <- as_one_character(model_name) - } else { - model_name <- deparse_combine(substitute(x)) - } - add_criterion(x, criterion = ic, model_name = model_name, ...) -} - -#' @rdname add_ic -#' @export -'add_ic<-' <- function(x, ..., value) { - add_ic(x, ic = value, ...) -} - -#' Compare Information Criteria of Different Models -#' -#' Compare information criteria of different models fitted -#' with \code{\link{waic}} or \code{\link{loo}}. -#' Deprecated and will be removed in the future. Please use -#' \code{\link{loo_compare}} instead. -#' -#' @param ... At least two objects returned by -#' \code{\link{waic}} or \code{\link{loo}}. -#' Alternatively, \code{brmsfit} objects with information -#' criteria precomputed via \code{\link{add_ic}} -#' may be passed, as well. -#' @param x A \code{list} containing the same types of objects as -#' can be passed via \code{...}. -#' @param ic The name of the information criterion to be extracted -#' from \code{brmsfit} objects. Ignored if information -#' criterion objects are only passed directly. -#' -#' @return An object of class \code{iclist}. -#' -#' @details See \code{\link{loo_compare}} for the recommended way -#' of comparing models with the \pkg{loo} package. -#' -#' @seealso -#' \code{\link{loo}}, -#' \code{\link{loo_compare}} -#' \code{\link{add_criterion}} -#' -#' @examples -#' \dontrun{ -#' # model with population-level effects only -#' fit1 <- brm(rating ~ treat + period + carry, -#' data = inhaler) -#' waic1 <- waic(fit1) -#' -#' # model with an additional varying intercept for subjects -#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler) -#' waic2 <- waic(fit2) -#' -#' # compare both models -#' compare_ic(waic1, waic2) -#' } -#' -#' @export -compare_ic <- function(..., x = NULL, ic = c("loo", "waic", "kfold")) { - # will be removed in brms 3.0 - warning2( - "'compare_ic' is deprecated and will be removed ", - "in the future. Please use 'loo_compare' instead." - ) - ic <- match.arg(ic) - if (!(is.null(x) || is.list(x))) { - stop2("Argument 'x' should be a list.") - } - x$ic_diffs__ <- NULL - x <- c(list(...), x) - for (i in seq_along(x)) { - # extract precomputed values from brmsfit objects - if (is.brmsfit(x[[i]]) && !is.null(x[[i]][[ic]])) { - x[[i]] <- x[[i]][[ic]] - } - } - if (!all(sapply(x, inherits, "loo"))) { - stop2("All inputs should have class 'loo' ", - "or contain precomputed 'loo' objects.") - } - if (length(x) < 2L) { - stop2("Expecting at least two objects.") - } - ics <- unname(sapply(x, function(y) rownames(y$estimates)[3])) - if (!all(ics %in% ics[1])) { - stop2("All inputs should be from the same criterion.") - } - yhash <- lapply(x, attr, which = "yhash") - yhash_check <- ulapply(yhash, is_equal, yhash[[1]]) - if (!all(yhash_check)) { - warning2( - "Model comparisons are likely invalid as the response ", - "values of at least two models do not match." - ) - } - names(x) <- loo::find_model_names(x) - n_models <- length(x) - ic_diffs <- matrix(0, nrow = n_models * (n_models - 1) / 2, ncol = 2) - rnames <- rep("", nrow(ic_diffs)) - # pairwise comparision to get differences in ICs and their SEs - n <- 1 - for (i in seq_len(n_models - 1)) { - for (j in (i + 1):n_models) { - tmp <- SW(loo::compare(x[[j]], x[[i]])) - ic_diffs[n, ] <- c(-2 * tmp[["elpd_diff"]], 2 * tmp[["se"]]) - rnames[n] <- paste(names(x)[i], "-", names(x)[j]) - n <- n + 1 - } - } - rownames(ic_diffs) <- rnames - colnames(ic_diffs) <- c(toupper(ics[1]), "SE") - x$ic_diffs__ <- ic_diffs - class(x) <- "iclist" - x -} - -# print the output of LOO and WAIC with multiple models -# deprecated as of brms > 2.5.0 and will be removed in brms 3.0 -#' @export -print.iclist <- function(x, digits = 2, ...) { - m <- x - m$ic_diffs__ <- NULL - if (length(m)) { - ic <- rownames(m[[1]]$estimates)[3] - mat <- matrix(0, nrow = length(m), ncol = 2) - dimnames(mat) <- list(names(m), c(toupper(ic), "SE")) - for (i in seq_along(m)) { - mat[i, ] <- m[[i]]$estimates[3, ] - } - } else { - mat <- ic <- NULL - } - ic_diffs <- x$ic_diffs__ - if (is.matrix(attr(x, "compare"))) { - # deprecated as of brms 1.4.0 - ic_diffs <- attr(x, "compare") - } - if (is.matrix(ic_diffs)) { - # models were compared using the compare_ic function - mat <- rbind(mat, ic_diffs) - } - print(round(mat, digits = digits), na.print = "") - invisible(x) -} +#' Efficient approximate leave-one-out cross-validation (LOO) +#' +#' Perform approximate leave-one-out cross-validation based +#' on the posterior likelihood using the \pkg{loo} package. +#' For more details see \code{\link[loo:loo]{loo}}. +#' +#' @aliases loo LOO LOO.brmsfit +#' +#' @param x A \code{brmsfit} object. +#' @param ... More \code{brmsfit} objects or further arguments +#' passed to the underlying post-processing functions. +#' In particular, see \code{\link{prepare_predictions}} for further +#' supported arguments. +#' @param compare A flag indicating if the information criteria +#' of the models should be compared to each other +#' via \code{\link{loo_compare}}. +#' @param pointwise A flag indicating whether to compute the full +#' log-likelihood matrix at once or separately for each observation. +#' The latter approach is usually considerably slower but +#' requires much less working memory. Accordingly, if one runs +#' into memory issues, \code{pointwise = TRUE} is the way to go. +#' @param moment_match Logical; Indicate whether \code{\link{loo_moment_match}} +#' should be applied on problematic observations. Defaults to \code{FALSE}. +#' For most models, moment matching will only work if you have set +#' \code{save_pars = save_pars(all = TRUE)} when fitting the model with +#' \code{\link{brm}}. See \code{\link{loo_moment_match.brmsfit}} for more +#' details. +#' @param reloo Logical; Indicate whether \code{\link{reloo}} +#' should be applied on problematic observations. Defaults to \code{FALSE}. +#' @param k_threshold The threshold at which pareto \eqn{k} +#' estimates are treated as problematic. Defaults to \code{0.7}. +#' Only used if argument \code{reloo} is \code{TRUE}. +#' See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} for more details. +#' @param save_psis Should the \code{"psis"} object created internally be saved +#' in the returned object? For more details see \code{\link[loo:loo]{loo}}. +#' @param moment_match_args Optional \code{list} of additional arguments passed to +#' \code{\link{loo_moment_match}}. +#' @param reloo_args Optional \code{list} of additional arguments passed to +#' \code{\link{reloo}}. +#' @param model_names If \code{NULL} (the default) will use model names +#' derived from deparsing the call. Otherwise will use the passed +#' values as model names. +#' @inheritParams predict.brmsfit +#' +#' @details See \code{\link{loo_compare}} for details on model comparisons. +#' For \code{brmsfit} objects, \code{LOO} is an alias of \code{loo}. +#' Use method \code{\link{add_criterion}} to store +#' information criteria in the fitted model object for later usage. +#' +#' @return If just one object is provided, an object of class \code{loo}. +#' If multiple objects are provided, an object of class \code{loolist}. +#' +#' @examples +#' \dontrun{ +#' # model with population-level effects only +#' fit1 <- brm(rating ~ treat + period + carry, +#' data = inhaler) +#' (loo1 <- loo(fit1)) +#' +#' # model with an additional varying intercept for subjects +#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler) +#' (loo2 <- loo(fit2)) +#' +#' # compare both models +#' loo_compare(loo1, loo2) +#' } +#' +#' @references +#' Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model +#' evaluation using leave-one-out cross-validation and WAIC. In Statistics +#' and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. +#' +#' Gelman, A., Hwang, J., & Vehtari, A. (2014). +#' Understanding predictive information criteria for Bayesian models. +#' Statistics and Computing, 24, 997-1016. +#' +#' Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation +#' and widely applicable information criterion in singular learning theory. +#' The Journal of Machine Learning Research, 11, 3571-3594. +#' +#' @importFrom loo loo is.loo +#' @export loo +#' @export +loo.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, + pointwise = FALSE, moment_match = FALSE, + reloo = FALSE, k_threshold = 0.7, save_psis = FALSE, + moment_match_args = list(), reloo_args = list(), + model_names = NULL) { + args <- split_dots(x, ..., model_names = model_names) + c(args) <- nlist( + criterion = "loo", pointwise, compare, + resp, k_threshold, save_psis, moment_match, + reloo, moment_match_args, reloo_args + ) + do_call(compute_loolist, args) +} + +#' @export +LOO.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, + pointwise = FALSE, moment_match = FALSE, + reloo = FALSE, k_threshold = 0.7, save_psis = FALSE, + moment_match_args = list(), reloo_args = list(), + model_names = NULL) { + cl <- match.call() + cl[[1]] <- quote(loo) + eval(cl, parent.frame()) +} + +#' @export +LOO <- function(x, ...) { + UseMethod("LOO") +} + +#' Widely Applicable Information Criterion (WAIC) +#' +#' Compute the widely applicable information criterion (WAIC) +#' based on the posterior likelihood using the \pkg{loo} package. +#' For more details see \code{\link[loo:waic]{waic}}. +#' +#' @aliases waic WAIC WAIC.brmsfit +#' +#' @inheritParams loo.brmsfit +#' +#' @details See \code{\link{loo_compare}} for details on model comparisons. +#' For \code{brmsfit} objects, \code{WAIC} is an alias of \code{waic}. +#' Use method \code{\link[brms:add_criterion]{add_criterion}} to store +#' information criteria in the fitted model object for later usage. +#' +#' @return If just one object is provided, an object of class \code{loo}. +#' If multiple objects are provided, an object of class \code{loolist}. +#' +#' @examples +#' \dontrun{ +#' # model with population-level effects only +#' fit1 <- brm(rating ~ treat + period + carry, +#' data = inhaler) +#' (waic1 <- waic(fit1)) +#' +#' # model with an additional varying intercept for subjects +#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler) +#' (waic2 <- waic(fit2)) +#' +#' # compare both models +#' loo_compare(waic1, waic2) +#' } +#' +#' @references +#' Vehtari, A., Gelman, A., & Gabry J. (2016). Practical Bayesian model +#' evaluation using leave-one-out cross-validation and WAIC. In Statistics +#' and Computing, doi:10.1007/s11222-016-9696-4. arXiv preprint arXiv:1507.04544. +#' +#' Gelman, A., Hwang, J., & Vehtari, A. (2014). +#' Understanding predictive information criteria for Bayesian models. +#' Statistics and Computing, 24, 997-1016. +#' +#' Watanabe, S. (2010). Asymptotic equivalence of Bayes cross validation +#' and widely applicable information criterion in singular learning theory. +#' The Journal of Machine Learning Research, 11, 3571-3594. +#' +#' @importFrom loo waic +#' @export waic +#' @export +waic.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, + pointwise = FALSE, model_names = NULL) { + args <- split_dots(x, ..., model_names = model_names) + c(args) <- nlist(criterion = "waic", pointwise, compare, resp) + do_call(compute_loolist, args) +} + +#' @export +WAIC.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, + pointwise = FALSE, model_names = NULL) { + cl <- match.call() + cl[[1]] <- quote(waic) + eval(cl, parent.frame()) +} + +#' @export +WAIC <- function(x, ...) { + UseMethod("WAIC") +} + +# helper function used to create (lists of) 'loo' objects +# @param models list of brmsfit objects +# @param criterion name of the criterion to compute +# @param use_stored use precomputed criterion objects if possible? +# @param compare compare models using 'loo_compare'? +# @param ... more arguments passed to compute_loo +# @return If length(models) > 1 an object of class 'loolist' +# If length(models) == 1 an object of class 'loo' +compute_loolist <- function(models, criterion, use_stored = TRUE, + compare = TRUE, ...) { + criterion <- match.arg(criterion, loo_criteria()) + args <- nlist(criterion, ...) + for (i in seq_along(models)) { + models[[i]] <- restructure(models[[i]]) + } + if (length(models) > 1L) { + if (!match_nobs(models)) { + stop2("Models have different number of observations.") + } + if (length(use_stored) == 1L) { + use_stored <- rep(use_stored, length(models)) + } + out <- list(loos = named_list(names(models))) + for (i in seq_along(models)) { + args$x <- models[[i]] + args$model_name <- names(models)[i] + args$use_stored <- use_stored[i] + out$loos[[i]] <- do_call(compute_loo, args) + } + compare <- as_one_logical(compare) + if (compare) { + out$diffs <- loo_compare(out$loos) + # for backwards compatibility; remove in brms 3.0 + out$ic_diffs__ <- SW(compare_ic(x = out$loos))$ic_diffs__ + } + class(out) <- "loolist" + } else { + args$x <- models[[1]] + args$model_name <- names(models) + args$use_stored <- use_stored + out <- do_call(compute_loo, args) + } + out +} + +# compute model fit criteria using the 'loo' package +# @param x an object of class brmsfit +# @param criterion the criterion to be computed +# @param newdata optional data.frame of new data +# @param resp optional names of the predicted response variables +# @param model_name original variable name of object 'x' +# @param use_stored use precomputed criterion objects if possible? +# @param ... passed to the individual methods +# @return an object of class 'loo' +compute_loo <- function(x, criterion, newdata = NULL, resp = NULL, + model_name = "", use_stored = TRUE, ...) { + criterion <- match.arg(criterion, loo_criteria()) + model_name <- as_one_character(model_name) + use_stored <- as_one_logical(use_stored) + out <- get_criterion(x, criterion) + if (!(use_stored && is.loo(out))) { + args <- nlist(x, newdata, resp, model_name, ...) + out <- do_call(paste0(".", criterion), args) + attr(out, "yhash") <- hash_response(x, newdata = newdata, resp = resp) + } + attr(out, "model_name") <- model_name + out +} + +# possible criteria to evaluate via the loo package +loo_criteria <- function() { + c("loo", "waic", "psis", "kfold", "loo_subsample") +} + +# compute 'loo' criterion using the 'loo' package +.loo <- function(x, pointwise, k_threshold, moment_match, reloo, + moment_match_args, reloo_args, newdata, + resp, model_name, save_psis, ...) { + loo_args <- prepare_loo_args( + x, newdata = newdata, resp = resp, + pointwise = pointwise, save_psis = save_psis, + ... + ) + out <- SW(do_call("loo", loo_args, pkg = "loo")) + if (moment_match) { + c(moment_match_args) <- nlist( + x, loo = out, newdata, resp, + k_threshold, check = FALSE, ... + ) + out <- do_call("loo_moment_match", moment_match_args) + } + if (reloo) { + c(reloo_args) <- nlist( + x, loo = out, newdata, resp, + k_threshold, check = FALSE, ... + ) + out <- do_call("reloo", reloo_args) + } + recommend_loo_options(out, k_threshold, moment_match, model_name) + out +} + +# compute 'waic' criterion using the 'loo' package +# @param model_name ignored but included to avoid being passed to '...' +.waic <- function(x, pointwise, newdata, resp, model_name, ...) { + loo_args <- prepare_loo_args( + x, newdata = newdata, resp = resp, + pointwise = pointwise, ... + ) + do_call("waic", loo_args, pkg = "loo") +} + +# compute 'psis' criterion using the 'loo' package +# @param model_name ignored but included to avoid being passed to '...' +.psis <- function(x, newdata, resp, model_name, ...) { + loo_args <- prepare_loo_args( + x, newdata = newdata, resp = resp, + pointwise = FALSE, ... + ) + loo_args$log_ratios <- -loo_args$x + loo_args$x <- NULL + do_call("psis", loo_args, pkg = "loo") +} + +# prepare arguments passed to the methods of the `loo` package +prepare_loo_args <- function(x, newdata, resp, pointwise, ...) { + pointwise <- as_one_logical(pointwise) + loo_args <- list(...) + ll_args <- nlist(object = x, newdata, resp, pointwise, ...) + loo_args$x <- do_call(log_lik, ll_args) + if (pointwise) { + loo_args$draws <- attr(loo_args$x, "draws") + loo_args$data <- attr(loo_args$x, "data") + } + # compute pointwise relative efficiencies + r_eff_args <- loo_args + r_eff_args$fit <- x + loo_args$r_eff <- do_call(r_eff_log_lik, r_eff_args) + loo_args +} + +#' Model comparison with the \pkg{loo} package +#' +#' For more details see \code{\link[loo:loo_compare]{loo_compare}}. +#' +#' @aliases loo_compare +#' +#' @inheritParams loo.brmsfit +#' @param ... More \code{brmsfit} objects. +#' @param criterion The name of the criterion to be extracted +#' from \code{brmsfit} objects. +#' +#' @details All \code{brmsfit} objects should contain precomputed +#' criterion objects. See \code{\link{add_criterion}} for more help. +#' +#' @return An object of class "\code{compare.loo}". +#' +#' @examples +#' \dontrun{ +#' # model with population-level effects only +#' fit1 <- brm(rating ~ treat + period + carry, +#' data = inhaler) +#' fit1 <- add_criterion(fit1, "waic") +#' +#' # model with an additional varying intercept for subjects +#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler) +#' fit2 <- add_criterion(fit2, "waic") +#' +#' # compare both models +#' loo_compare(fit1, fit2, criterion = "waic") +#' } +#' +#' @importFrom loo loo_compare +#' @export loo_compare +#' @export +loo_compare.brmsfit <- function(x, ..., criterion = c("loo", "waic", "kfold"), + model_names = NULL) { + criterion <- match.arg(criterion) + models <- split_dots(x, ..., model_names = model_names, other = FALSE) + loos <- named_list(names(models)) + for (i in seq_along(models)) { + models[[i]] <- restructure(models[[i]]) + loos[[i]] <- get_criterion(models[[i]], criterion) + if (is.null(loos[[i]])) { + stop2( + "Model '", names(models)[i], "' does not contain a precomputed '", + criterion, "' criterion. See ?loo_compare.brmsfit for help." + ) + } + } + loo_compare(loos) +} + +#' Model averaging via stacking or pseudo-BMA weighting. +#' +#' Compute model weights for \code{brmsfit} objects via stacking +#' or pseudo-BMA weighting. For more details, see +#' \code{\link[loo:loo_model_weights]{loo::loo_model_weights}}. +#' +#' @aliases loo_model_weights +#' +#' @inheritParams loo.brmsfit +#' +#' @return A named vector of model weights. +#' +#' @examples +#' \dontrun{ +#' # model with population-level effects only +#' fit1 <- brm(rating ~ treat + period + carry, +#' data = inhaler, family = "gaussian") +#' # model with an additional varying intercept for subjects +#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler, family = "gaussian") +#' loo_model_weights(fit1, fit2) +#' } +#' +#' @method loo_model_weights brmsfit +#' @importFrom loo loo_model_weights +#' @export loo_model_weights +#' @export +loo_model_weights.brmsfit <- function(x, ..., model_names = NULL) { + args <- split_dots(x, ..., model_names = model_names) + models <- args$models + args$models <- NULL + log_lik_list <- lapply(models, function(x) + do_call(log_lik, c(list(x), args)) + ) + args$x <- log_lik_list + args$r_eff_list <- mapply( + r_eff_log_lik, log_lik_list, + fit = models, SIMPLIFY = FALSE + ) + out <- do_call(loo::loo_model_weights, args) + names(out) <- names(models) + out +} + +#' Add model fit criteria to model objects +#' +#' @param x An \R object typically of class \code{brmsfit}. +#' @param criterion Names of model fit criteria +#' to compute. Currently supported are \code{"loo"}, +#' \code{"waic"}, \code{"kfold"}, \code{"loo_subsample"}, +#' \code{"bayes_R2"} (Bayesian R-squared), +#' \code{"loo_R2"} (LOO-adjusted R-squared), and +#' \code{"marglik"} (log marginal likelihood). +#' @param model_name Optional name of the model. If \code{NULL} +#' (the default) the name is taken from the call to \code{x}. +#' @param overwrite Logical; Indicates if already stored fit +#' indices should be overwritten. Defaults to \code{FALSE}. +#' @param file Either \code{NULL} or a character string. In the latter case, the +#' fitted model object including the newly added criterion values is saved via +#' \code{\link{saveRDS}} in a file named after the string supplied in +#' \code{file}. The \code{.rds} extension is added automatically. If \code{x} +#' was already stored in a file before, the file name will be reused +#' automatically (with a message) unless overwritten by \code{file}. In any +#' case, \code{file} only applies if new criteria were actually added via +#' \code{add_criterion} or if \code{force_save} was set to \code{TRUE}. +#' @param force_save Logical; only relevant if \code{file} is specified and +#' ignored otherwise. If \code{TRUE}, the fitted model object will be saved +#' regardless of whether new criteria were added via \code{add_criterion}. +#' @param ... Further arguments passed to the underlying +#' functions computing the model fit criteria. +#' +#' @return An object of the same class as \code{x}, but +#' with model fit criteria added for later usage. +#' +#' @details Functions \code{add_loo} and \code{add_waic} are aliases of +#' \code{add_criterion} with fixed values for the \code{criterion} argument. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ Trt, data = epilepsy) +#' # add both LOO and WAIC at once +#' fit <- add_criterion(fit, c("loo", "waic")) +#' print(fit$criteria$loo) +#' print(fit$criteria$waic) +#' } +#' +#' @export +add_criterion <- function(x, ...) { + UseMethod("add_criterion") +} + +#' @rdname add_criterion +#' @export +add_criterion.brmsfit <- function(x, criterion, model_name = NULL, + overwrite = FALSE, file = NULL, + force_save = FALSE, ...) { + if (!is.null(model_name)) { + model_name <- as_one_character(model_name) + } else { + model_name <- deparse_combine(substitute(x)) + } + criterion <- unique(as.character(criterion)) + if (any(criterion == "R2")) { + # deprecated as of version 2.10.4 + warning2("Criterion 'R2' is deprecated. Please use 'bayes_R2' instead.") + criterion[criterion == "R2"] <- "bayes_R2" + } + loo_options <- c("loo", "waic", "kfold", "loo_subsample") + options <- c(loo_options, "bayes_R2", "loo_R2", "marglik") + if (!length(criterion) || !all(criterion %in% options)) { + stop2("Argument 'criterion' should be a subset of ", + collapse_comma(options)) + } + auto_save <- FALSE + if (!is.null(file)) { + file <- paste0(as_one_character(file), ".rds") + } else { + file <- x$file + if (!is.null(file)) auto_save <- TRUE + } + force_save <- as_one_logical(force_save) + overwrite <- as_one_logical(overwrite) + if (overwrite) { + # recompute all criteria + new_criteria <- criterion + } else { + # only computed criteria not already stored + new_criteria <- criterion[ulapply(x$criteria[criterion], is.null)] + } + # remove all criteria that are to be recomputed + x$criteria[new_criteria] <- NULL + args <- list(x, ...) + for (fun in intersect(new_criteria, loo_options)) { + args$model_names <- model_name + x$criteria[[fun]] <- do_call(fun, args) + } + if ("bayes_R2" %in% new_criteria) { + args$summary <- FALSE + x$criteria$bayes_R2 <- do_call(bayes_R2, args) + } + if ("loo_R2" %in% new_criteria) { + args$summary <- FALSE + x$criteria$loo_R2 <- do_call(loo_R2, args) + } + if ("marglik" %in% new_criteria) { + x$criteria$marglik <- do_call(bridge_sampler, args) + } + if (!is.null(file) && (force_save || length(new_criteria))) { + if (auto_save) { + message("Automatically saving the model object in '", file, "'") + } + x$file <- file + saveRDS(x, file = file) + } + x +} + +# extract a recomputed model fit criterion +get_criterion <- function(x, criterion) { + stopifnot(is.brmsfit(x)) + criterion <- as_one_character(criterion) + x$criteria[[criterion]] +} + +# create a hash based on the response of a model +hash_response <- function(x, newdata = NULL, resp = NULL, ...) { + require_package("digest") + stopifnot(is.brmsfit(x)) + sdata <- standata( + x, newdata = newdata, re_formula = NA, internal = TRUE, + check_response = TRUE, only_response = TRUE + ) + add_funs <- lsp("brms", what = "exports", pattern = "^resp_") + regex <- c("Y", sub("^resp_", "", add_funs)) + regex <- outer(regex, escape_all(usc(resp)), FUN = paste0) + regex <- paste0("(", as.vector(regex), ")", collapse = "|") + regex <- paste0("^(", regex, ")(_|$)") + out <- sdata[grepl(regex, names(sdata))] + out <- as.matrix(as.data.frame(rmNULL(out))) + out <- p(out, attr(sdata, "old_order")) + # see issue #642 + attributes(out) <- NULL + digest::sha1(x = out, ...) +} + +# compare the response parts of multiple brmsfit objects +# @param models A list of brmsfit objects +# @param ... passed to hash_response +# @return TRUE if the response parts of all models match and FALSE otherwise +match_response <- function(models, ...) { + if (length(models) <= 1L) { + out <- TRUE + } else { + yhash <- lapply(models, hash_response, ...) + yhash_check <- ulapply(yhash, is_equal, yhash[[1]]) + if (all(yhash_check)) { + out <- TRUE + } else { + out <- FALSE + } + } + out +} + +# compare number of observations of multipe models +# @param models A list of brmsfit objects +# @param ... currently ignored +# @return TRUE if the number of rows match +match_nobs <- function(models, ...) { + if (length(models) <= 1L) { + out <- TRUE + } else { + nobs <- lapply(models, nobs) + nobs_check <- ulapply(nobs, is_equal, nobs[[1]]) + if (all(nobs_check)) { + out <- TRUE + } else { + out <- FALSE + } + } + out +} + +# validate models passed to loo and related methods +# @param models list of fitted model objects +# @param model_names names specified by the user +# @param sub_names names inferred by substitute() +validate_models <- function(models, model_names, sub_names) { + stopifnot(is.list(models)) + model_names <- as.character(model_names) + if (!length(model_names)) { + model_names <- as.character(sub_names) + } + if (length(model_names) != length(models)) { + stop2("Number of model names is not equal to the number of models.") + } + names(models) <- model_names + for (i in seq_along(models)) { + if (!is.brmsfit(models[[i]])) { + stop2("Object '", names(models)[i], "' is not of class 'brmsfit'.") + } + } + models +} + +# recommend options if approximate loo fails for some observations +# @param moment_match has moment matching already been performed? +recommend_loo_options <- function(loo, k_threshold, moment_match = FALSE, + model_name = "") { + if (isTRUE(nzchar(model_name))) { + model_name <- paste0(" in model '", model_name, "'") + } else { + model_name <- "" + } + n <- length(loo::pareto_k_ids(loo, threshold = k_threshold)) + if (!moment_match && n > 0) { + warning2( + "Found ", n, " observations with a pareto_k > ", k_threshold, + model_name, ". It is recommended to set 'moment_match = TRUE' in order ", + "to perform moment matching for problematic observations. " + ) + out <- "loo_moment_match" + } else if (n > 0 && n <= 10) { + warning2( + "Found ", n, " observations with a pareto_k > ", k_threshold, + model_name, ". It is recommended to set 'reloo = TRUE' in order to ", + "calculate the ELPD without the assumption that these observations " , + "are negligible. This will refit the model ", n, " times to compute ", + "the ELPDs for the problematic observations directly." + ) + out <- "reloo" + } else if (n > 10) { + warning2( + "Found ", n, " observations with a pareto_k > ", k_threshold, + model_name, ". With this many problematic observations, it may be more ", + "appropriate to use 'kfold' with argument 'K = 10' to perform ", + "10-fold cross-validation rather than LOO." + ) + out <- "kfold" + } else { + out <- "loo" + } + invisible(out) +} + +# helper function to compute relative efficiences +# @param x matrix of posterior draws +# @param fit a brmsfit object to extract metadata from +# @param allow_na allow NA values in the output? +# @return a numeric vector of length NCOL(x) +r_eff_helper <- function(x, chain_id, allow_na = TRUE, ...) { + out <- loo::relative_eff(x, chain_id = chain_id, ...) + if (!allow_na && anyNA(out)) { + # avoid error in loo if some but not all r_effs are NA + out <- rep(1, length(out)) + warning2( + "Ignoring relative efficiencies as some were NA. ", + "See argument 'r_eff' in ?loo::loo for more details." + ) + } + out +} + +# wrapper around r_eff_helper to compute efficiency +# of likelihood draws based on log-likelihood draws +r_eff_log_lik <- function(x, ...) { + UseMethod("r_eff_log_lik") +} + +#' @export +r_eff_log_lik.matrix <- function(x, fit, allow_na = FALSE, ...) { + if (is.brmsfit_multiple(fit)) { + # due to stacking of chains from multiple models + # efficiency computations will likely be incorrect + # assume relative efficiency of 1 for now + return(rep(1, ncol(x))) + } + chain_id <- get_chain_id(nrow(x), fit) + r_eff_helper(exp(x), chain_id = chain_id, allow_na = allow_na, ...) +} + +#' @export +r_eff_log_lik.function <- function(x, fit, draws, allow_na = FALSE, ...) { + if (is.brmsfit_multiple(fit)) { + # due to stacking of chains from multiple models + # efficiency computations will likely be incorrect + # assume relative efficiency of 1 for now + return(rep(1, draws$nobs)) + } + lik_fun <- function(data_i, draws, ...) { + exp(x(data_i, draws, ...)) + } + chain_id <- get_chain_id(draws$ndraws, fit) + r_eff_helper( + lik_fun, chain_id = chain_id, draws = draws, + allow_na = allow_na, ... + ) +} + +# get chain IDs per posterior draw +get_chain_id <- function(ndraws, fit) { + if (ndraws != ndraws(fit)) { + # don't know the chain IDs of a subset of draws + chain_id <- rep(1L, ndraws) + } else { + nchains <- fit$fit@sim$chains + chain_id <- rep(seq_len(nchains), each = ndraws / nchains) + } + chain_id +} + +# print the output of a list of loo objects +#' @export +print.loolist <- function(x, digits = 1, ...) { + model_names <- loo::find_model_names(x$loos) + for (i in seq_along(x$loos)) { + cat(paste0("Output of model '", model_names[i], "':\n")) + print(x$loos[[i]], digits = digits, ...) + cat("\n") + } + if (!is.null(x$diffs)) { + cat("Model comparisons:\n") + print(x$diffs, digits = digits, ...) + } + invisible(x) +} + +# ---------- deprecated functions ---------- +#' @rdname add_ic +#' @export +add_loo <- function(x, model_name = NULL, ...) { + warning2("'add_loo' is deprecated. Please use 'add_criterion' instead.") + if (!is.null(model_name)) { + model_name <- as_one_character(model_name) + } else { + model_name <- deparse_combine(substitute(x)) + } + add_criterion(x, criterion = "loo", model_name = model_name, ...) +} + +#' @rdname add_ic +#' @export +add_waic <- function(x, model_name = NULL, ...) { + warning2("'add_waic' is deprecated. Please use 'add_criterion' instead.") + if (!is.null(model_name)) { + model_name <- as_one_character(model_name) + } else { + model_name <- deparse_combine(substitute(x)) + } + add_criterion(x, criterion = "waic", model_name = model_name, ...) +} + +#' Add model fit criteria to model objects +#' +#' Deprecated aliases of \code{\link{add_criterion}}. +#' +#' @inheritParams add_criterion +#' @param ic,value Names of model fit criteria +#' to compute. Currently supported are \code{"loo"}, +#' \code{"waic"}, \code{"kfold"}, \code{"R2"} (R-squared), and +#' \code{"marglik"} (log marginal likelihood). +#' +#' @return An object of the same class as \code{x}, but +#' with model fit criteria added for later usage. +#' Previously computed criterion objects will be overwritten. +#' +#' @export +add_ic <- function(x, ...) { + UseMethod("add_ic") +} + +#' @rdname add_ic +#' @export +add_ic.brmsfit <- function(x, ic = "loo", model_name = NULL, ...) { + warning2("'add_ic' is deprecated. Please use 'add_criterion' instead.") + if (!is.null(model_name)) { + model_name <- as_one_character(model_name) + } else { + model_name <- deparse_combine(substitute(x)) + } + add_criterion(x, criterion = ic, model_name = model_name, ...) +} + +#' @rdname add_ic +#' @export +'add_ic<-' <- function(x, ..., value) { + add_ic(x, ic = value, ...) +} + +#' Compare Information Criteria of Different Models +#' +#' Compare information criteria of different models fitted +#' with \code{\link{waic}} or \code{\link{loo}}. +#' Deprecated and will be removed in the future. Please use +#' \code{\link{loo_compare}} instead. +#' +#' @param ... At least two objects returned by +#' \code{\link{waic}} or \code{\link{loo}}. +#' Alternatively, \code{brmsfit} objects with information +#' criteria precomputed via \code{\link{add_ic}} +#' may be passed, as well. +#' @param x A \code{list} containing the same types of objects as +#' can be passed via \code{...}. +#' @param ic The name of the information criterion to be extracted +#' from \code{brmsfit} objects. Ignored if information +#' criterion objects are only passed directly. +#' +#' @return An object of class \code{iclist}. +#' +#' @details See \code{\link{loo_compare}} for the recommended way +#' of comparing models with the \pkg{loo} package. +#' +#' @seealso +#' \code{\link{loo}}, +#' \code{\link{loo_compare}} +#' \code{\link{add_criterion}} +#' +#' @examples +#' \dontrun{ +#' # model with population-level effects only +#' fit1 <- brm(rating ~ treat + period + carry, +#' data = inhaler) +#' waic1 <- waic(fit1) +#' +#' # model with an additional varying intercept for subjects +#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler) +#' waic2 <- waic(fit2) +#' +#' # compare both models +#' compare_ic(waic1, waic2) +#' } +#' +#' @export +compare_ic <- function(..., x = NULL, ic = c("loo", "waic", "kfold")) { + # will be removed in brms 3.0 + warning2( + "'compare_ic' is deprecated and will be removed ", + "in the future. Please use 'loo_compare' instead." + ) + ic <- match.arg(ic) + if (!(is.null(x) || is.list(x))) { + stop2("Argument 'x' should be a list.") + } + x$ic_diffs__ <- NULL + x <- c(list(...), x) + for (i in seq_along(x)) { + # extract precomputed values from brmsfit objects + if (is.brmsfit(x[[i]]) && !is.null(x[[i]][[ic]])) { + x[[i]] <- x[[i]][[ic]] + } + } + if (!all(sapply(x, inherits, "loo"))) { + stop2("All inputs should have class 'loo' ", + "or contain precomputed 'loo' objects.") + } + if (length(x) < 2L) { + stop2("Expecting at least two objects.") + } + ics <- unname(sapply(x, function(y) rownames(y$estimates)[3])) + if (!all(ics %in% ics[1])) { + stop2("All inputs should be from the same criterion.") + } + yhash <- lapply(x, attr, which = "yhash") + yhash_check <- ulapply(yhash, is_equal, yhash[[1]]) + if (!all(yhash_check)) { + warning2( + "Model comparisons are likely invalid as the response ", + "values of at least two models do not match." + ) + } + names(x) <- loo::find_model_names(x) + n_models <- length(x) + ic_diffs <- matrix(0, nrow = n_models * (n_models - 1) / 2, ncol = 2) + rnames <- rep("", nrow(ic_diffs)) + # pairwise comparision to get differences in ICs and their SEs + n <- 1 + for (i in seq_len(n_models - 1)) { + for (j in (i + 1):n_models) { + tmp <- SW(loo::compare(x[[j]], x[[i]])) + ic_diffs[n, ] <- c(-2 * tmp[["elpd_diff"]], 2 * tmp[["se"]]) + rnames[n] <- paste(names(x)[i], "-", names(x)[j]) + n <- n + 1 + } + } + rownames(ic_diffs) <- rnames + colnames(ic_diffs) <- c(toupper(ics[1]), "SE") + x$ic_diffs__ <- ic_diffs + class(x) <- "iclist" + x +} + +# print the output of LOO and WAIC with multiple models +# deprecated as of brms > 2.5.0 and will be removed in brms 3.0 +#' @export +print.iclist <- function(x, digits = 2, ...) { + m <- x + m$ic_diffs__ <- NULL + if (length(m)) { + ic <- rownames(m[[1]]$estimates)[3] + mat <- matrix(0, nrow = length(m), ncol = 2) + dimnames(mat) <- list(names(m), c(toupper(ic), "SE")) + for (i in seq_along(m)) { + mat[i, ] <- m[[i]]$estimates[3, ] + } + } else { + mat <- ic <- NULL + } + ic_diffs <- x$ic_diffs__ + if (is.matrix(attr(x, "compare"))) { + # deprecated as of brms 1.4.0 + ic_diffs <- attr(x, "compare") + } + if (is.matrix(ic_diffs)) { + # models were compared using the compare_ic function + mat <- rbind(mat, ic_diffs) + } + print(round(mat, digits = digits), na.print = "") + invisible(x) +} diff -Nru r-cran-brms-2.16.3/R/loo_subsample.R r-cran-brms-2.17.0/R/loo_subsample.R --- r-cran-brms-2.16.3/R/loo_subsample.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/loo_subsample.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,90 +1,90 @@ -#' Efficient approximate leave-one-out cross-validation (LOO) using subsampling -#' -#' @aliases loo_subsample -#' -#' @inheritParams loo.brmsfit -#' -#' @details More details can be found on -#' \code{\link[loo:loo_subsample]{loo_subsample}}. -#' -#' @examples -#' \dontrun{ -#' # model with population-level effects only -#' fit1 <- brm(rating ~ treat + period + carry, -#' data = inhaler) -#' (loo1 <- loo_subsample(fit1)) -#' -#' # model with an additional varying intercept for subjects -#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler) -#' (loo2 <- loo_subsample(fit2)) -#' -#' # compare both models -#' loo_compare(loo1, loo2) -#' } -#' -#' @importFrom loo loo_subsample -#' @export loo_subsample -#' @export -loo_subsample.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, - model_names = NULL) { - args <- split_dots(x, ..., model_names = model_names) - c(args) <- nlist( - criterion = "loo_subsample", compare, resp, - add_point_estimate = TRUE - ) - do_call(compute_loolist, args) -} - -# compute 'loo_subsample' criterion using the 'loo' package -# @param model_name ignored but included to avoid being passed to '...' -.loo_subsample <- function(x, newdata, resp, model_name, ...) { - loo_args <- prepare_loo_args( - x, newdata = newdata, resp = resp, - pointwise = TRUE, ... - ) - do_call("loo_subsample", loo_args, pkg = "loo") -} - -# methods required in loo_subsample -#' @importFrom loo .ndraws -#' @export -.ndraws.brmsprep <- function(x) { - x$ndraws -} - -#' @export -.ndraws.mvbrmsprep <- function(x) { - x$ndraws -} - -#' @importFrom loo .thin_draws -#' @export -.thin_draws.brmsprep <- function(draws, loo_approximation_draws) { - # brmsprep objects are too complex to implement a post-hoc subsetting method - if (length(loo_approximation_draws)) { - stop2("'loo_approximation_draws' is not supported for brmsfit objects.") - } - draws -} - -#' @export -.thin_draws.mvbrmsprep <- function(draws, loo_approximation_draws) { - if (length(loo_approximation_draws)) { - stop2("'loo_approximation_draws' is not supported for brmsfit objects.") - } - draws -} - -#' @importFrom loo .compute_point_estimate -#' @export -.compute_point_estimate.brmsprep <- function(draws) { - # point estimates are stored in the form of an attribute rather - # than computed on the fly due to the complexity of brmsprep objects - attr(draws, "point_estimate") -} - -#' @export -.compute_point_estimate.mvbrmsprep <- function(draws) { - attr(draws, "point_estimate") -} +#' Efficient approximate leave-one-out cross-validation (LOO) using subsampling +#' +#' @aliases loo_subsample +#' +#' @inheritParams loo.brmsfit +#' +#' @details More details can be found on +#' \code{\link[loo:loo_subsample]{loo_subsample}}. +#' +#' @examples +#' \dontrun{ +#' # model with population-level effects only +#' fit1 <- brm(rating ~ treat + period + carry, +#' data = inhaler) +#' (loo1 <- loo_subsample(fit1)) +#' +#' # model with an additional varying intercept for subjects +#' fit2 <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler) +#' (loo2 <- loo_subsample(fit2)) +#' +#' # compare both models +#' loo_compare(loo1, loo2) +#' } +#' +#' @importFrom loo loo_subsample +#' @export loo_subsample +#' @export +loo_subsample.brmsfit <- function(x, ..., compare = TRUE, resp = NULL, + model_names = NULL) { + args <- split_dots(x, ..., model_names = model_names) + c(args) <- nlist( + criterion = "loo_subsample", compare, resp, + add_point_estimate = TRUE + ) + do_call(compute_loolist, args) +} + +# compute 'loo_subsample' criterion using the 'loo' package +# @param model_name ignored but included to avoid being passed to '...' +.loo_subsample <- function(x, newdata, resp, model_name, ...) { + loo_args <- prepare_loo_args( + x, newdata = newdata, resp = resp, + pointwise = TRUE, ... + ) + do_call("loo_subsample", loo_args, pkg = "loo") +} + +# methods required in loo_subsample +#' @importFrom loo .ndraws +#' @export +.ndraws.brmsprep <- function(x) { + x$ndraws +} + +#' @export +.ndraws.mvbrmsprep <- function(x) { + x$ndraws +} + +#' @importFrom loo .thin_draws +#' @export +.thin_draws.brmsprep <- function(draws, loo_approximation_draws) { + # brmsprep objects are too complex to implement a post-hoc subsetting method + if (length(loo_approximation_draws)) { + stop2("'loo_approximation_draws' is not supported for brmsfit objects.") + } + draws +} + +#' @export +.thin_draws.mvbrmsprep <- function(draws, loo_approximation_draws) { + if (length(loo_approximation_draws)) { + stop2("'loo_approximation_draws' is not supported for brmsfit objects.") + } + draws +} + +#' @importFrom loo .compute_point_estimate +#' @export +.compute_point_estimate.brmsprep <- function(draws) { + # point estimates are stored in the form of an attribute rather + # than computed on the fly due to the complexity of brmsprep objects + attr(draws, "point_estimate") +} + +#' @export +.compute_point_estimate.mvbrmsprep <- function(draws) { + attr(draws, "point_estimate") +} diff -Nru r-cran-brms-2.16.3/R/lsp.R r-cran-brms-2.17.0/R/lsp.R --- r-cran-brms-2.16.3/R/lsp.R 2021-02-10 15:31:39.000000000 +0000 +++ r-cran-brms-2.17.0/R/lsp.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,44 +1,44 @@ -# find all namespace entries of a package, which are of -# a particular type for instance all exported objects -# retrieved from https://github.com/raredd/rawr -# @param package the package name -# @param what type of the objects to retrieve ("all" for all objects) -# @param pattern regex that must be matches by the object names -# @return a character vector of object names -lsp <- function(package, what = "all", pattern = ".*") { - if (!is.character(substitute(package))) - package <- deparse(substitute(package)) - ns <- asNamespace(package) - - ## base package does not have NAMESPACE - if (isBaseNamespace(ns)) { - res <- ls(.BaseNamespaceEnv, all.names = TRUE) - return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) - } else { - ## for non base packages - if (exists('.__NAMESPACE__.', envir = ns, inherits = FALSE)) { - wh <- get('.__NAMESPACE__.', inherits = FALSE, - envir = asNamespace(package, base.OK = FALSE)) - what <- if (missing(what)) 'all' - else if ('?' %in% what) return(ls(wh)) - else ls(wh)[pmatch(what[1], ls(wh))] - if (!is.null(what) && !any(what %in% c('all', ls(wh)))) - stop('\'what\' should be one of ', - paste0(shQuote(ls(wh)), collapse = ', '), - ', or \'all\'', domain = NA) - res <- sapply(ls(wh), function(x) getNamespaceInfo(ns, x)) - res <- rapply(res, ls, classes = 'environment', - how = 'replace', all.names = TRUE) - if (is.null(what)) - return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) - if (what %in% 'all') { - res <- ls(getNamespace(package), all.names = TRUE) - return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) - } - if (any(what %in% ls(wh))) { - res <- res[[what]] - return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) - } - } else stop(sprintf('no NAMESPACE file found for package %s', package)) - } -} +# find all namespace entries of a package, which are of +# a particular type for instance all exported objects +# retrieved from https://github.com/raredd/rawr +# @param package the package name +# @param what type of the objects to retrieve ("all" for all objects) +# @param pattern regex that must be matches by the object names +# @return a character vector of object names +lsp <- function(package, what = "all", pattern = ".*") { + if (!is.character(substitute(package))) + package <- deparse(substitute(package)) + ns <- asNamespace(package) + + ## base package does not have NAMESPACE + if (isBaseNamespace(ns)) { + res <- ls(.BaseNamespaceEnv, all.names = TRUE) + return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) + } else { + ## for non base packages + if (exists('.__NAMESPACE__.', envir = ns, inherits = FALSE)) { + wh <- get('.__NAMESPACE__.', inherits = FALSE, + envir = asNamespace(package, base.OK = FALSE)) + what <- if (missing(what)) 'all' + else if ('?' %in% what) return(ls(wh)) + else ls(wh)[pmatch(what[1], ls(wh))] + if (!is.null(what) && !any(what %in% c('all', ls(wh)))) + stop('\'what\' should be one of ', + paste0(shQuote(ls(wh)), collapse = ', '), + ', or \'all\'', domain = NA) + res <- sapply(ls(wh), function(x) getNamespaceInfo(ns, x)) + res <- rapply(res, ls, classes = 'environment', + how = 'replace', all.names = TRUE) + if (is.null(what)) + return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) + if (what %in% 'all') { + res <- ls(getNamespace(package), all.names = TRUE) + return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) + } + if (any(what %in% ls(wh))) { + res <- res[[what]] + return(res[grep(pattern, res, perl = TRUE, ignore.case = TRUE)]) + } + } else stop(sprintf('no NAMESPACE file found for package %s', package)) + } +} diff -Nru r-cran-brms-2.16.3/R/make_stancode.R r-cran-brms-2.17.0/R/make_stancode.R --- r-cran-brms-2.16.3/R/make_stancode.R 2021-10-29 06:53:30.000000000 +0000 +++ r-cran-brms-2.17.0/R/make_stancode.R 2022-04-09 09:06:50.000000000 +0000 @@ -1,46 +1,46 @@ #' Stan Code for \pkg{brms} Models -#' +#' #' Generate Stan code for \pkg{brms} models -#' +#' #' @inheritParams brm #' @param ... Other arguments for internal usage only. -#' -#' @return A character string containing the fully commented \pkg{Stan} code +#' +#' @return A character string containing the fully commented \pkg{Stan} code #' to fit a \pkg{brms} model. -#' -#' @examples -#' make_stancode(rating ~ treat + period + carry + (1|subject), +#' +#' @examples +#' make_stancode(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = "cumulative") -#' +#' #' make_stancode(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = "poisson") #' #' @export -make_stancode <- function(formula, data, family = gaussian(), +make_stancode <- function(formula, data, family = gaussian(), prior = NULL, autocor = NULL, data2 = NULL, - cov_ranef = NULL, sparse = NULL, - sample_prior = "no", stanvars = NULL, - stan_funs = NULL, knots = NULL, - threads = NULL, + cov_ranef = NULL, sparse = NULL, + sample_prior = "no", stanvars = NULL, + stan_funs = NULL, knots = NULL, + threads = getOption("brms.threads", NULL), normalize = getOption("brms.normalize", TRUE), save_model = NULL, ...) { - + if (is.brmsfit(formula)) { stop2("Use 'stancode' to extract Stan code from 'brmsfit' objects.") } formula <- validate_formula( - formula, data = data, family = family, + formula, data = data, family = family, autocor = autocor, sparse = sparse, cov_ranef = cov_ranef ) bterms <- brmsterms(formula) data2 <- validate_data2( - data2, bterms = bterms, + data2, bterms = bterms, get_data2_autocor(formula), get_data2_cov_ranef(formula) ) data <- validate_data( - data, bterms = bterms, + data, bterms = bterms, data2 = data2, knots = knots ) prior <- .validate_prior( @@ -49,23 +49,23 @@ ) stanvars <- validate_stanvars(stanvars, stan_funs = stan_funs) threads <- validate_threads(threads) - + .make_stancode( - bterms, data = data, prior = prior, + bterms, data = data, prior = prior, stanvars = stanvars, threads = threads, normalize = normalize, save_model = save_model, ... - ) + ) } # internal work function of 'make_stancode' # @param parse parse the Stan model for automatic syntax checking # @param backend name of the backend used for parsing # @param silent silence parsing messages -.make_stancode <- function(bterms, data, prior, stanvars, - threads = threading(), +.make_stancode <- function(bterms, data, prior, stanvars, + threads = threading(), normalize = getOption("brms.normalize", TRUE), - parse = getOption("brms.parse_stancode", FALSE), + parse = getOption("brms.parse_stancode", FALSE), backend = getOption("brms.backend", "rstan"), silent = TRUE, save_model = NULL, ...) { normalize <- as_one_logical(normalize) @@ -88,7 +88,7 @@ scode_global_defs <- stan_global_defs( bterms, prior = prior, ranef = ranef, threads = threads ) - + # extend Stan's likelihood part if (use_threading(threads)) { # threading is activated @@ -119,11 +119,11 @@ partial_log_lik <- gsub(" target \\+=", " ptarget +=", partial_log_lik) partial_log_lik <- paste0( "// compute partial sums of the log-likelihood\n", - "real partial_log_lik_lpmf", resp, "(int[] seq", resp, + "real partial_log_lik", resp, "_lpmf(int[] seq", resp, ", int start, int end", pll_args$typed, ") {\n", " real ptarget = 0;\n", " int N = end - start + 1;\n", - partial_log_lik, + partial_log_lik, " return ptarget;\n", "}\n" ) @@ -131,7 +131,7 @@ scode_predictor[[i]][["partial_log_lik"]] <- partial_log_lik static <- str_if(threads$static, "_static") scode_predictor[[i]][["model_lik"]] <- paste0( - " target += reduce_sum", static, "(partial_log_lik_lpmf", resp, + " target += reduce_sum", static, "(partial_log_lik", resp, "_lpmf", ", seq", resp, ", grainsize", pll_args$plain, ");\n" ) str_add(scode_predictor[[i]][["tdata_def"]]) <- glue( @@ -145,8 +145,8 @@ scode_predictor[["model_no_pll_comp_mvjoin"]], scode_predictor[["model_lik"]] ) - str_add(scode_predictor[["data"]]) <- - " int grainsize; // grainsize for threading\n" + str_add(scode_predictor[["data"]]) <- + " int grainsize; // grainsize for threading\n" } else { # threading is not activated scode_predictor <- collapse_lists(ls = scode_predictor) @@ -169,17 +169,16 @@ collapse_stanvars(stanvars, "likelihood", "end") ) } - scode_predictor[["model_lik"]] <- + scode_predictor[["model_lik"]] <- wsp_per_line(scode_predictor[["model_lik"]], 2) - - # get priors for all parameters in the model - scode_prior <- paste0( - scode_predictor[["prior"]], - scode_ranef[["prior"]], - scode_Xme[["prior"]], - stan_unchecked_prior(prior) + + # get all priors added to 'lprior' + scode_tpar_prior <- paste0( + scode_predictor[["tpar_prior"]], + scode_ranef[["tpar_prior"]], + scode_Xme[["tpar_prior"]] ) - + # generate functions block scode_functions <- paste0( "// generated with brms ", utils::packageVersion("brms"), "\n", @@ -189,7 +188,7 @@ scode_predictor[["partial_log_lik"]], "}\n" ) - + # generate data block scode_data <- paste0( "data {\n", @@ -201,7 +200,7 @@ collapse_stanvars(stanvars, "data"), "}\n" ) - + # generate transformed parameters block scode_transformed_data <- paste0( "transformed data {\n", @@ -212,7 +211,7 @@ collapse_stanvars(stanvars, "tdata", "end"), "}\n" ) - + # generate parameters block scode_parameters <- paste0( scode_predictor[["par"]], @@ -221,7 +220,7 @@ ) # prepare additional sampling from priors scode_rngprior <- stan_rngprior( - prior = scode_prior, + tpar_prior = scode_tpar_prior, par_declars = scode_parameters, gen_quantities = scode_predictor[["gen_def"]], prior_special = attr(prior, "special"), @@ -234,36 +233,47 @@ collapse_stanvars(stanvars, "parameters"), "}\n" ) - + # generate transformed parameters block + scode_lprior_def <- " real lprior = 0; // prior contributions to the log posterior\n" scode_transformed_parameters <- paste0( "transformed parameters {\n", scode_predictor[["tpar_def"]], scode_ranef[["tpar_def"]], scode_Xme[["tpar_def"]], + str_if(normalize, scode_lprior_def), collapse_stanvars(stanvars, "tparameters", "start"), - scode_predictor[["tpar_prior"]], - scode_ranef[["tpar_prior"]], - scode_Xme[["tpar_prior"]], + scode_predictor[["tpar_prior_const"]], + scode_ranef[["tpar_prior_const"]], + scode_Xme[["tpar_prior_const"]], scode_predictor[["tpar_comp"]], scode_predictor[["tpar_reg_prior"]], scode_ranef[["tpar_comp"]], scode_Xme[["tpar_comp"]], + # lprior cannot contain _lupdf functions in transformed parameters + # as discussed on github.com/stan-dev/stan/issues/3094 + str_if(normalize, scode_tpar_prior), collapse_stanvars(stanvars, "tparameters", "end"), "}\n" ) - + # combine likelihood with prior part not_const <- str_if(!normalize, " not") scode_model <- paste0( "model {\n", + str_if(!normalize, scode_lprior_def), collapse_stanvars(stanvars, "model", "start"), " // likelihood", not_const, " including constants\n", " if (!prior_only) {\n", scode_predictor[["model_lik"]], - " }\n", + " }\n", " // priors", not_const, " including constants\n", - scode_prior, + str_if(!normalize, scode_tpar_prior), + " target += lprior;\n", + scode_predictor[["model_prior"]], + scode_ranef[["model_prior"]], + scode_Xme[["model_prior"]], + stan_unchecked_prior(prior), collapse_stanvars(stanvars, "model", "end"), "}\n" ) @@ -285,18 +295,25 @@ # combine all elements into a complete Stan model scode <- paste0( scode_functions, - scode_data, - scode_transformed_data, + scode_data, + scode_transformed_data, scode_parameters, scode_transformed_parameters, scode_model, scode_generated_quantities ) - + scode <- expand_include_statements(scode) if (parse) { scode <- parse_model(scode, backend, silent = silent) } + if (backend == "cmdstanr") { + if (requireNamespace("cmdstanr", quietly = TRUE) && + cmdstanr::cmdstan_version() >= "2.29.0") { + tmp_file <- cmdstanr::write_stan_file(scode) + scode <- .canonicalize_stan_model(tmp_file, overwrite_file = FALSE) + } + } if (is.character(save_model)) { cat(scode, file = save_model) } @@ -307,15 +324,15 @@ #' @export print.brmsmodel <- function(x, ...) { cat(x) - invisible(x) + invisible(x) } #' Extract Stan model code -#' +#' #' Extract Stan code that was used to specify the model. -#' +#' #' @aliases stancode.brmsfit -#' +#' #' @param object An object of class \code{brmsfit}. #' @param version Logical; indicates if the first line containing #' the \pkg{brms} version number should be included. @@ -326,14 +343,15 @@ #' to be \code{TRUE} by other arguments. #' @param threads Controls whether the Stan code should be threaded. #' See \code{\link{threading}} for details. +#' @param backend Controls the Stan backend. See \code{\link{brm}} for details. #' @param ... Further arguments passed to \code{\link{make_stancode}} if the #' Stan code is regenerated. -#' +#' #' @return Stan model code for further processing. -#' +#' #' @export -stancode.brmsfit <- function(object, version = TRUE, regenerate = NULL, - threads = NULL, ...) { +stancode.brmsfit <- function(object, version = TRUE, regenerate = NULL, + threads = NULL, backend = NULL, ...) { if (is.null(regenerate)) { # determine whether regenerating the Stan code is required regenerate <- FALSE @@ -347,6 +365,14 @@ } object$threads <- threads } + if ("backend" %in% names(cl)) { + backend <- match.arg(backend, backend_choices()) + # older Stan versions do not support array syntax + if (require_old_stan_syntax(object, backend, "2.29.0")) { + regenerate <- TRUE + } + object$backend <- backend + } } regenerate <- as_one_logical(regenerate) if (regenerate) { @@ -359,6 +385,7 @@ stanvars = object$stanvars, sample_prior = get_sample_prior(object$prior), threads = object$threads, + backend = object$backend, ... ) } else { @@ -366,7 +393,7 @@ out <- object$model } if (!version) { - out <- sub("^[^\n]+[[:digit:]]\\.[^\n]+\n", "", out) + out <- sub("^[^\n]+[[:digit:]]\\.[^\n]+\n", "", out) } out } @@ -418,3 +445,15 @@ x <- gsub("[[:space:]]+"," ", x) trimws(x) } + +# check if the currently installed Stan version requires older syntax +# than the Stan version with which the model was initially fitted +require_old_stan_syntax <- function(object, backend, version) { + stopifnot(is.brmsfit(object)) + isTRUE( + (object$backend == "rstan" && object$version$rstan >= version || + object$backend == "cmdstanr" && object$version$cmdstan >= version) && + (backend == "rstan" && utils::packageVersion("rstan") < version || + backend == "cmdstanr" && cmdstanr::cmdstan_version() < version) + ) +} diff -Nru r-cran-brms-2.16.3/R/make_standata.R r-cran-brms-2.17.0/R/make_standata.R --- r-cran-brms-2.16.3/R/make_standata.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/make_standata.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,303 +1,304 @@ -#' Data for \pkg{brms} Models -#' -#' Generate data for \pkg{brms} models to be passed to \pkg{Stan} -#' -#' @inheritParams brm -#' @param ... Other arguments for internal use. -#' -#' @return A named list of objects containing the required data -#' to fit a \pkg{brms} model with \pkg{Stan}. -#' -#' @author Paul-Christian Buerkner \email{paul.buerkner@@gmail.com} -#' -#' @examples -#' sdata1 <- make_standata(rating ~ treat + period + carry + (1|subject), -#' data = inhaler, family = "cumulative") -#' str(sdata1) -#' -#' sdata2 <- make_standata(count ~ zAge + zBase * Trt + (1|patient), -#' data = epilepsy, family = "poisson") -#' str(sdata2) -#' -#' @export -make_standata <- function(formula, data, family = gaussian(), prior = NULL, - autocor = NULL, data2 = NULL, cov_ranef = NULL, - sample_prior = "no", stanvars = NULL, - threads = NULL, knots = NULL, ...) { - - if (is.brmsfit(formula)) { - stop2("Use 'standata' to extract Stan data from 'brmsfit' objects.") - } - formula <- validate_formula( - formula, data = data, family = family, - autocor = autocor, cov_ranef = cov_ranef - ) - bterms <- brmsterms(formula) - data2 <- validate_data2( - data2, bterms = bterms, - get_data2_autocor(formula), - get_data2_cov_ranef(formula) - ) - data <- validate_data( - data, bterms = bterms, - knots = knots, data2 = data2 - ) - prior <- .validate_prior( - prior, bterms = bterms, data = data, - sample_prior = sample_prior, - require_nlpar_prior = FALSE - ) - stanvars <- validate_stanvars(stanvars) - threads <- validate_threads(threads) - .make_standata( - bterms, data = data, prior = prior, - data2 = data2, stanvars = stanvars, - threads = threads, ... - ) -} - -# internal work function of 'make_stancode' -# @param check_response check validity of the response? -# @param only_response extract data related to the response only? -# @param internal prepare Stan data for use in post-processing methods? -# @param basis original Stan data as prepared by 'standata_basis' -# @param ... currently ignored -# @return names list of data passed to Stan -.make_standata <- function(bterms, data, prior, stanvars, data2, - threads = threading(), check_response = TRUE, - only_response = FALSE, internal = FALSE, - basis = NULL, ...) { - - check_response <- as_one_logical(check_response) - only_response <- as_one_logical(only_response) - internal <- as_one_logical(internal) - # order data for use in autocorrelation models - data <- order_data(data, bterms = bterms) - out <- data_response( - bterms, data, check_response = check_response, - internal = internal, basis = basis - ) - if (!only_response) { - ranef <- tidy_ranef(bterms, data, old_levels = basis$levels) - meef <- tidy_meef(bterms, data, old_levels = basis$levels) - index <- tidy_index(bterms, data) - c(out) <- data_predictor( - bterms, data = data, prior = prior, data2 = data2, - ranef = ranef, index = index, basis = basis - ) - c(out) <- data_gr_global(ranef, data2 = data2) - c(out) <- data_Xme(meef, data = data) - } - out$prior_only <- as.integer(is_prior_only(prior)) - if (use_threading(threads)) { - out$grainsize <- threads$grainsize - if (is.null(out$grainsize)) { - out$grainsize <- ceiling(out$N / (2 * threads$threads)) - out$grainsize <- max(100, out$grainsize) - } - } - if (is.stanvars(stanvars)) { - stanvars <- subset_stanvars(stanvars, block = "data") - inv_names <- intersect(names(stanvars), names(out)) - if (length(inv_names)) { - stop2("Cannot overwrite existing variables: ", - collapse_comma(inv_names)) - } - out[names(stanvars)] <- lapply(stanvars, "[[", "sdata") - } - if (internal) { - # allows to recover the original order of the data - attr(out, "old_order") <- attr(data, "old_order") - # ensures current grouping levels are known in post-processing - ranef_new <- tidy_ranef(bterms, data) - meef_new <- tidy_meef(bterms, data) - attr(out, "levels") <- get_levels(ranef_new, meef_new) - } - structure(out, class = c("standata", "list")) -} - -#' Extract data passed to Stan -#' -#' Extract all data that was used by Stan to fit the model. -#' -#' @aliases standata.brmsfit -#' -#' @param object An object of class \code{brmsfit}. -#' @param ... More arguments passed to \code{\link{make_standata}} -#' and \code{\link{validate_newdata}}. -#' @inheritParams prepare_predictions -#' -#' @return A named list containing the data originally passed to Stan. -#' -#' @export -standata.brmsfit <- function(object, newdata = NULL, re_formula = NULL, - newdata2 = NULL, new_objects = NULL, - incl_autocor = TRUE, ...) { - - object <- restructure(object) - # allows functions to fall back to old default behavior - # which was used when originally fitting the model - options(.brmsfit_version = object$version$brms) - on.exit(options(.brmsfit_version = NULL)) - - object <- exclude_terms(object, incl_autocor = incl_autocor) - formula <- update_re_terms(object$formula, re_formula) - bterms <- brmsterms(formula) - - newdata2 <- use_alias(newdata2, new_objects) - data2 <- current_data2(object, newdata2) - data <- current_data( - object, newdata, newdata2 = data2, - re_formula = re_formula, ... - ) - stanvars <- add_newdata_stanvars(object$stanvars, data2) - - basis <- NULL - if (!is.null(newdata)) { - # 'basis' contains information from original Stan data - # required to correctly predict from new data - basis <- standata_basis(bterms, data = object$data) - } - .make_standata( - bterms, data = data, prior = object$prior, - data2 = data2, stanvars = stanvars, - threads = object$threads, basis = basis, ... - ) -} - -#' @rdname standata.brmsfit -#' @export -standata <- function(object, ...) { - UseMethod("standata") -} - -# prepare basis data required for correct predictions from new data -standata_basis <- function(x, data, ...) { - UseMethod("standata_basis") -} - -#' @export -standata_basis.default <- function(x, data, ...) { - list() -} - -#' @export -standata_basis.mvbrmsterms <- function(x, data, ...) { - out <- list() - for (r in names(x$terms)) { - out$resps[[r]] <- standata_basis(x$terms[[r]], data, ...) - } - out$levels <- get_levels(tidy_meef(x, data), tidy_ranef(x, data)) - out -} - -#' @export -standata_basis.brmsterms <- function(x, data, ...) { - out <- list() - data <- subset_data(data, x) - for (dp in names(x$dpars)) { - out$dpars[[dp]] <- standata_basis(x$dpars[[dp]], data, ...) - } - for (nlp in names(x$nlpars)) { - out$nlpars[[nlp]] <- standata_basis(x$nlpars[[nlp]], data, ...) - } - # old levels are required to select the right indices for new levels - out$levels <- get_levels(tidy_meef(x, data), tidy_ranef(x, data)) - if (has_trials(x$family)) { - # trials should not be computed based on new data - datr <- data_response(x, data, check_response = FALSE, internal = TRUE) - # partially match via $ to be independent of the response suffix - out$trials <- datr$trials - } - if (is_binary(x$family) || is_categorical(x$family)) { - y <- model.response(model.frame(x$respform, data, na.action = na.pass)) - out$resp_levels <- levels(as.factor(y)) - } - out -} - -#' @export -standata_basis.btnl <- function(x, data, ...) { - list() -} - -#' @export -standata_basis.btl <- function(x, data, ...) { - out <- list() - out$sm <- standata_basis_sm(x, data, ...) - out$gp <- standata_basis_gp(x, data, ...) - out$sp <- standata_basis_sp(x, data, ...) - out$ac <- standata_basis_ac(x, data, ...) - out$bhaz <- standata_basis_bhaz(x, data, ...) - out -} - -# prepare basis data related to smooth terms -standata_basis_sm <- function(x, data, ...) { - stopifnot(is.btl(x)) - smterms <- all_terms(x[["sm"]]) - out <- named_list(smterms) - if (length(smterms)) { - knots <- get_knots(data) - data <- rm_attr(data, "terms") - # the spline penalty has changed in 2.8.7 (#646) - diagonal.penalty <- !require_old_default("2.8.7") - gam_args <- list( - data = data, knots = knots, - absorb.cons = TRUE, modCon = 3, - diagonal.penalty = diagonal.penalty - ) - for (i in seq_along(smterms)) { - sc_args <- c(list(eval2(smterms[i])), gam_args) - out[[i]] <- do_call(smoothCon, sc_args) - } - } - out -} - -# prepare basis data related to gaussian processes -standata_basis_gp <- function(x, data, ...) { - stopifnot(is.btl(x)) - out <- data_gp(x, data, internal = TRUE) - out <- out[grepl("^((Xgp)|(dmax)|(cmeans))", names(out))] - out -} - -# prepare basis data related to special terms -standata_basis_sp <- function(x, data, ...) { - stopifnot(is.btl(x)) - out <- list() - if (length(attr(x$sp, "uni_mo"))) { - # do it like data_sp() - spef <- tidy_spef(x, data) - Xmo <- lapply(unlist(spef$calls_mo), get_mo_values, data = data) - out$Jmo <- as.array(ulapply(Xmo, max)) - } - out -} - -# prepare basis data related to autocorrelation structures -standata_basis_ac <- function(x, data, ...) { - out <- list() - if (has_ac_class(x, "car")) { - gr <- get_ac_vars(x, "gr", class = "car") - stopifnot(length(gr) <= 1L) - if (isTRUE(nzchar(gr))) { - out$locations <- levels(factor(get(gr, data))) - } else { - out$locations <- NA - } - } - out -} - -# prepare basis data for baseline hazards of the cox model -standata_basis_bhaz <- function(x, data, ...) { - out <- list() - if (is_cox(x$family)) { - # compute basis matrix of the baseline hazard for the Cox model - y <- model.response(model.frame(x$respform, data, na.action = na.pass)) - out$basis_matrix <- bhaz_basis_matrix(y, args = x$family$bhaz) - } - out -} +#' Data for \pkg{brms} Models +#' +#' Generate data for \pkg{brms} models to be passed to \pkg{Stan} +#' +#' @inheritParams brm +#' @param ... Other arguments for internal use. +#' +#' @return A named list of objects containing the required data +#' to fit a \pkg{brms} model with \pkg{Stan}. +#' +#' @author Paul-Christian Buerkner \email{paul.buerkner@@gmail.com} +#' +#' @examples +#' sdata1 <- make_standata(rating ~ treat + period + carry + (1|subject), +#' data = inhaler, family = "cumulative") +#' str(sdata1) +#' +#' sdata2 <- make_standata(count ~ zAge + zBase * Trt + (1|patient), +#' data = epilepsy, family = "poisson") +#' str(sdata2) +#' +#' @export +make_standata <- function(formula, data, family = gaussian(), prior = NULL, + autocor = NULL, data2 = NULL, cov_ranef = NULL, + sample_prior = "no", stanvars = NULL, + threads = getOption("brms.threads", NULL), + knots = NULL, ...) { + + if (is.brmsfit(formula)) { + stop2("Use 'standata' to extract Stan data from 'brmsfit' objects.") + } + formula <- validate_formula( + formula, data = data, family = family, + autocor = autocor, cov_ranef = cov_ranef + ) + bterms <- brmsterms(formula) + data2 <- validate_data2( + data2, bterms = bterms, + get_data2_autocor(formula), + get_data2_cov_ranef(formula) + ) + data <- validate_data( + data, bterms = bterms, + knots = knots, data2 = data2 + ) + prior <- .validate_prior( + prior, bterms = bterms, data = data, + sample_prior = sample_prior, + require_nlpar_prior = FALSE + ) + stanvars <- validate_stanvars(stanvars) + threads <- validate_threads(threads) + .make_standata( + bterms, data = data, prior = prior, + data2 = data2, stanvars = stanvars, + threads = threads, ... + ) +} + +# internal work function of 'make_stancode' +# @param check_response check validity of the response? +# @param only_response extract data related to the response only? +# @param internal prepare Stan data for use in post-processing methods? +# @param basis original Stan data as prepared by 'standata_basis' +# @param ... currently ignored +# @return names list of data passed to Stan +.make_standata <- function(bterms, data, prior, stanvars, data2, + threads = threading(), check_response = TRUE, + only_response = FALSE, internal = FALSE, + basis = NULL, ...) { + + check_response <- as_one_logical(check_response) + only_response <- as_one_logical(only_response) + internal <- as_one_logical(internal) + # order data for use in autocorrelation models + data <- order_data(data, bterms = bterms) + out <- data_response( + bterms, data, check_response = check_response, + internal = internal, basis = basis + ) + if (!only_response) { + ranef <- tidy_ranef(bterms, data, old_levels = basis$levels) + meef <- tidy_meef(bterms, data, old_levels = basis$levels) + index <- tidy_index(bterms, data) + c(out) <- data_predictor( + bterms, data = data, prior = prior, data2 = data2, + ranef = ranef, index = index, basis = basis + ) + c(out) <- data_gr_global(ranef, data2 = data2) + c(out) <- data_Xme(meef, data = data) + } + out$prior_only <- as.integer(is_prior_only(prior)) + if (use_threading(threads)) { + out$grainsize <- threads$grainsize + if (is.null(out$grainsize)) { + out$grainsize <- ceiling(out$N / (2 * threads$threads)) + out$grainsize <- max(100, out$grainsize) + } + } + if (is.stanvars(stanvars)) { + stanvars <- subset_stanvars(stanvars, block = "data") + inv_names <- intersect(names(stanvars), names(out)) + if (length(inv_names)) { + stop2("Cannot overwrite existing variables: ", + collapse_comma(inv_names)) + } + out[names(stanvars)] <- lapply(stanvars, "[[", "sdata") + } + if (internal) { + # allows to recover the original order of the data + attr(out, "old_order") <- attr(data, "old_order") + # ensures current grouping levels are known in post-processing + ranef_new <- tidy_ranef(bterms, data) + meef_new <- tidy_meef(bterms, data) + attr(out, "levels") <- get_levels(ranef_new, meef_new) + } + structure(out, class = c("standata", "list")) +} + +#' Extract data passed to Stan +#' +#' Extract all data that was used by Stan to fit the model. +#' +#' @aliases standata.brmsfit +#' +#' @param object An object of class \code{brmsfit}. +#' @param ... More arguments passed to \code{\link{make_standata}} +#' and \code{\link{validate_newdata}}. +#' @inheritParams prepare_predictions +#' +#' @return A named list containing the data originally passed to Stan. +#' +#' @export +standata.brmsfit <- function(object, newdata = NULL, re_formula = NULL, + newdata2 = NULL, new_objects = NULL, + incl_autocor = TRUE, ...) { + + object <- restructure(object) + # allows functions to fall back to old default behavior + # which was used when originally fitting the model + options(.brmsfit_version = object$version$brms) + on.exit(options(.brmsfit_version = NULL)) + + object <- exclude_terms(object, incl_autocor = incl_autocor) + formula <- update_re_terms(object$formula, re_formula) + bterms <- brmsterms(formula) + + newdata2 <- use_alias(newdata2, new_objects) + data2 <- current_data2(object, newdata2) + data <- current_data( + object, newdata, newdata2 = data2, + re_formula = re_formula, ... + ) + stanvars <- add_newdata_stanvars(object$stanvars, data2) + + basis <- NULL + if (!is.null(newdata)) { + # 'basis' contains information from original Stan data + # required to correctly predict from new data + basis <- standata_basis(bterms, data = object$data) + } + .make_standata( + bterms, data = data, prior = object$prior, + data2 = data2, stanvars = stanvars, + threads = object$threads, basis = basis, ... + ) +} + +#' @rdname standata.brmsfit +#' @export +standata <- function(object, ...) { + UseMethod("standata") +} + +# prepare basis data required for correct predictions from new data +standata_basis <- function(x, data, ...) { + UseMethod("standata_basis") +} + +#' @export +standata_basis.default <- function(x, data, ...) { + list() +} + +#' @export +standata_basis.mvbrmsterms <- function(x, data, ...) { + out <- list() + for (r in names(x$terms)) { + out$resps[[r]] <- standata_basis(x$terms[[r]], data, ...) + } + out$levels <- get_levels(tidy_meef(x, data), tidy_ranef(x, data)) + out +} + +#' @export +standata_basis.brmsterms <- function(x, data, ...) { + out <- list() + data <- subset_data(data, x) + for (dp in names(x$dpars)) { + out$dpars[[dp]] <- standata_basis(x$dpars[[dp]], data, ...) + } + for (nlp in names(x$nlpars)) { + out$nlpars[[nlp]] <- standata_basis(x$nlpars[[nlp]], data, ...) + } + # old levels are required to select the right indices for new levels + out$levels <- get_levels(tidy_meef(x, data), tidy_ranef(x, data)) + if (has_trials(x$family)) { + # trials should not be computed based on new data + datr <- data_response(x, data, check_response = FALSE, internal = TRUE) + # partially match via $ to be independent of the response suffix + out$trials <- datr$trials + } + if (is_binary(x$family) || is_categorical(x$family)) { + y <- model.response(model.frame(x$respform, data, na.action = na.pass)) + out$resp_levels <- levels(as.factor(y)) + } + out +} + +#' @export +standata_basis.btnl <- function(x, data, ...) { + list() +} + +#' @export +standata_basis.btl <- function(x, data, ...) { + out <- list() + out$sm <- standata_basis_sm(x, data, ...) + out$gp <- standata_basis_gp(x, data, ...) + out$sp <- standata_basis_sp(x, data, ...) + out$ac <- standata_basis_ac(x, data, ...) + out$bhaz <- standata_basis_bhaz(x, data, ...) + out +} + +# prepare basis data related to smooth terms +standata_basis_sm <- function(x, data, ...) { + stopifnot(is.btl(x)) + smterms <- all_terms(x[["sm"]]) + out <- named_list(smterms) + if (length(smterms)) { + knots <- get_knots(data) + data <- rm_attr(data, "terms") + # the spline penalty has changed in 2.8.7 (#646) + diagonal.penalty <- !require_old_default("2.8.7") + gam_args <- list( + data = data, knots = knots, + absorb.cons = TRUE, modCon = 3, + diagonal.penalty = diagonal.penalty + ) + for (i in seq_along(smterms)) { + sc_args <- c(list(eval2(smterms[i])), gam_args) + out[[i]] <- do_call(smoothCon, sc_args) + } + } + out +} + +# prepare basis data related to gaussian processes +standata_basis_gp <- function(x, data, ...) { + stopifnot(is.btl(x)) + out <- data_gp(x, data, internal = TRUE) + out <- out[grepl("^((Xgp)|(dmax)|(cmeans))", names(out))] + out +} + +# prepare basis data related to special terms +standata_basis_sp <- function(x, data, ...) { + stopifnot(is.btl(x)) + out <- list() + if (length(attr(x$sp, "uni_mo"))) { + # do it like data_sp() + spef <- tidy_spef(x, data) + Xmo <- lapply(unlist(spef$calls_mo), get_mo_values, data = data) + out$Jmo <- as.array(ulapply(Xmo, max)) + } + out +} + +# prepare basis data related to autocorrelation structures +standata_basis_ac <- function(x, data, ...) { + out <- list() + if (has_ac_class(x, "car")) { + gr <- get_ac_vars(x, "gr", class = "car") + stopifnot(length(gr) <= 1L) + if (isTRUE(nzchar(gr))) { + out$locations <- extract_levels(get(gr, data)) + } else { + out$locations <- NA + } + } + out +} + +# prepare basis data for baseline hazards of the cox model +standata_basis_bhaz <- function(x, data, ...) { + out <- list() + if (is_cox(x$family)) { + # compute basis matrix of the baseline hazard for the Cox model + y <- model.response(model.frame(x$respform, data, na.action = na.pass)) + out$basis_matrix <- bhaz_basis_matrix(y, args = x$family$bhaz) + } + out +} diff -Nru r-cran-brms-2.16.3/R/misc.R r-cran-brms-2.17.0/R/misc.R --- r-cran-brms-2.16.3/R/misc.R 2021-09-09 16:19:51.000000000 +0000 +++ r-cran-brms-2.17.0/R/misc.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,1113 +1,1118 @@ -# type-stable indexing of vector and matrix type objects -# @param x an R object typically a vector or matrix -# @param i optional index; if NULL, x is returned unchanged -# @param row indicating if rows or cols should be indexed -# only relevant if x has two or three dimensions -p <- function(x, i = NULL, row = TRUE) { - # TODO: replace by "slice" - if (isTRUE(length(dim(x)) > 3L)) { - stop2("'p' can only handle objects up to 3 dimensions.") - } - if (!length(i)) { - out <- x - } else if (length(dim(x)) == 2L) { - if (row) { - out <- x[i, , drop = FALSE] - } else { - out <- x[, i, drop = FALSE] - } - } else if (length(dim(x)) == 3L) { - if (row) { - out <- x[i, , , drop = FALSE] - } else { - out <- x[, i, , drop = FALSE] - } - } else { - out <- x[i] - } - out -} - -# extract parts of an object with selective dropping of dimensions -# @param x,...,drop same as in x[..., drop] -# @drop_dim: Optional numeric or logical vector controlling -# which dimensions to drop. Will overwrite argument 'drop'. -extract <- function(x, ..., drop = FALSE, drop_dim = NULL) { - if (!length(dim(x))) { - return(x[...]) - } - if (length(drop_dim)) { - drop <- FALSE - } else { - drop <- as_one_logical(drop) - } - out <- x[..., drop = drop] - if (drop || !length(drop_dim) || any(dim(out) == 0L)) { - return(out) - } - if (is.numeric(drop_dim)) { - drop_dim <- seq_along(dim(x)) %in% drop_dim - } - if (!is.logical(drop_dim)) { - stop2("'drop_dim' needs to be logical or numeric.") - } - keep <- dim(out) > 1L | !drop_dim - new_dim <- dim(out)[keep] - if (length(new_dim) == 1L) { - # use vectors instead of 1D arrays - new_dim <- NULL - } - dim(out) <- new_dim - out -} - -# extract slices of one array dimension without dropping other dimensions -# @param x an array -# @param dim dimension from which to take the slice -# @param i slice index -# @param drop Logical (length 1) indicating whether to drop dimension `dim`. -slice <- function(x, dim, i, drop = TRUE) { - ndim <- length(dim(x)) - commas1 <- collapse(rep(", ", dim - 1)) - commas2 <- collapse(rep(", ", ndim - dim)) - drop_dim <- ifelse(drop, ", drop_dim = dim", "") - expr <- paste0("extract(x, ", commas1, "i", commas2, drop_dim, ")") - eval2(expr) -} - -# slice out columns without dropping other dimensions -# @param x an array; a vector or 1D array is treated as already sliced -# @param i column index -slice_col <- function(x, i) { - if (length(dim(x)) < 2L) { - # a vector or 1D array is treated as already sliced - return(x) - } - slice(x, 2, i) -} - -seq_rows <- function(x) { - seq_len(NROW(x)) -} - -seq_cols <- function(x) { - seq_len(NCOL(x)) -} - -seq_dim <- function(x, dim) { - dim <- as_one_numeric(dim) - if (dim == 1) { - len <- NROW(x) - } else if (dim == 2) { - len <- NCOL(x) - } else { - len <- dim(x)[dim] - } - if (length(len) == 1L && !isNA(len)) { - out <- seq_len(len) - } else { - out <- integer(0) - } - out -} - -# match rows in x with rows in y -match_rows <- function(x, y, ...) { - x <- as.data.frame(x) - y <- as.data.frame(y) - x <- do.call("paste", c(x, sep = "\r")) - y <- do.call("paste", c(y, sep = "\r")) - match(x, y, ...) -} - -# find elements of 'x' matching sub-elements passed via 'ls' and '...' -find_elements <- function(x, ..., ls = list(), fun = '%in%') { - x <- as.list(x) - if (!length(x)) { - return(logical(0)) - } - out <- rep(TRUE, length(x)) - ls <- c(ls, list(...)) - if (!length(ls)) { - return(out) - } - if (is.null(names(ls))) { - stop("Argument 'ls' must be named.") - } - for (name in names(ls)) { - tmp <- lapply(x, "[[", name) - out <- out & do_call(fun, list(tmp, ls[[name]])) - } - out -} - -# find rows of 'x' matching columns passed via 'ls' and '...' -# similar to 'find_elements' but for matrix like objects -find_rows <- function(x, ..., ls = list(), fun = '%in%') { - x <- as.data.frame(x) - if (!nrow(x)) { - return(logical(0)) - } - out <- rep(TRUE, nrow(x)) - ls <- c(ls, list(...)) - if (!length(ls)) { - return(out) - } - if (is.null(names(ls))) { - stop("Argument 'ls' must be named.") - } - for (name in names(ls)) { - out <- out & do_call(fun, list(x[[name]], ls[[name]])) - } - out -} - -# subset 'x' using arguments passed via 'ls' and '...' -subset2 <- function(x, ..., ls = list(), fun = '%in%') { - x[find_rows(x, ..., ls = ls, fun = fun), , drop = FALSE] -} - -# convert array to list of elements with reduced dimension -# @param x an arrary of dimension d -# @return a list of arrays of dimension d-1 -array2list <- function(x) { - if (is.null(dim(x))) { - return(as.list(x)) - } - ndim <- length(dim(x)) - out <- list(length = dim(x)[ndim]) - ind <- collapse(rep(",", ndim - 1)) - for (i in seq_len(dim(x)[ndim])) { - out[[i]] <- eval2(paste0("x[", ind, i, "]")) - if (length(dim(x)) > 2) { - # avoid accidental dropping of other dimensions - dim(out[[i]]) <- dim(x)[-ndim] - } - } - names(out) <- dimnames(x)[[ndim]] - out -} - -# move elements to the start of a named object -move2start <- function(x, first) { - x[c(first, setdiff(names(x), first))] -} - -# wrapper around replicate but without simplifying -repl <- function(expr, n) { - replicate(n, expr, simplify = FALSE) -} - -# find the first element in A that is greater than target -# @param A a matrix -# @param target a vector of length nrow(A) -# @param i column of A being checked first -# @return a vector of the same length as target containing the -# column ids where A[,i] was first greater than target -first_greater <- function(A, target, i = 1) { - ifelse(target <= A[, i] | ncol(A) == i, i, first_greater(A, target, i + 1)) -} - -# check if an object is NULL -isNULL <- function(x) { - is.null(x) || ifelse(is.vector(x), all(sapply(x, is.null)), FALSE) -} - -# recursively removes NULL entries from an object -rmNULL <- function(x, recursive = TRUE) { - x <- Filter(Negate(isNULL), x) - if (recursive) { - x <- lapply(x, function(x) if (is.list(x)) rmNULL(x) else x) - } - x -} - -# find the first argument that is not NULL -first_not_null <- function(...) { - dots <- list(...) - out <- NULL - i <- 1L - while (isNULL(out) && i <= length(dots)) { - if (!isNULL(dots[[i]])) { - out <- dots[[i]] - } - i <- i + 1L - } - out -} - -isNA <- function(x) { - length(x) == 1L && is.na(x) -} - -is_equal <- function(x, y, check.attributes = FALSE, ...) { - isTRUE(all.equal(x, y, check.attributes = check.attributes, ...)) -} - -# check if 'x' will behave like a factor in design matrices -is_like_factor <- function(x) { - is.factor(x) || is.character(x) || is.logical(x) -} - -# as.factor but allows to pass levels -as_factor <- function(x, levels = NULL) { - if (is.null(levels)) { - out <- as.factor(x) - } else { - out <- factor(x, levels = levels) - } - out -} - -# coerce 'x' to a single logical value -as_one_logical <- function(x, allow_na = FALSE) { - s <- substitute(x) - x <- as.logical(x) - if (length(x) != 1L || anyNA(x) && !allow_na) { - s <- deparse_combine(s, max_char = 100L) - stop2("Cannot coerce '", s, "' to a single logical value.") - } - x -} - -# coerce 'x' to a single integer value -as_one_integer <- function(x, allow_na = FALSE) { - s <- substitute(x) - x <- SW(as.integer(x)) - if (length(x) != 1L || anyNA(x) && !allow_na) { - s <- deparse_combine(s, max_char = 100L) - stop2("Cannot coerce '", s, "' to a single integer value.") - } - x -} - -# coerce 'x' to a single numeric value -as_one_numeric <- function(x, allow_na = FALSE) { - s <- substitute(x) - x <- SW(as.numeric(x)) - if (length(x) != 1L || anyNA(x) && !allow_na) { - s <- deparse_combine(s, max_char = 100L) - stop2("Cannot coerce '", s, "' to a single numeric value.") - } - x -} - -# coerce 'x' to a single character string -as_one_character <- function(x, allow_na = FALSE) { - s <- substitute(x) - x <- as.character(x) - if (length(x) != 1L || anyNA(x) && !allow_na) { - s <- deparse_combine(s, max_char = 100L) - stop2("Cannot coerce '", s, "' to a single character value.") - } - x -} - -# coerce 'x' to a single character variable name -as_one_variable <- function(x, allow_na = TRUE) { - x <- as_one_character(x) - if (x == "NA" && allow_na) { - return(x) - } - if (!nzchar(x) || !is_equal(x, all_vars(x))) { - stop2("Cannot coerce '", x, "' to a single variable name.") - } - x -} - -has_rows <- function(x) { - isTRUE(nrow(x) > 0L) -} - -has_cols <- function(x) { - isTRUE(ncol(x) > 0L) -} - -# expand arguments to the same length -# @param ... arguments to expand -# @param length optional expansion length -# otherwise taken to be the largest supplied length -# @return a data.frame with one variable per element in '...' -expand <- function(..., dots = list(), length = NULL) { - dots <- c(dots, list(...)) - max_dim <- NULL - if (is.null(length)) { - lengths <- lengths(dots) - length <- max(lengths) - max_dim <- dim(dots[[match(length, lengths)]]) - } - out <- as.data.frame(lapply(dots, rep, length.out = length)) - structure(out, max_dim = max_dim) -} - -# structure but ignore NULL -structure_not_null <- function(.Data, ...) { - if (!is.null(.Data)) { - .Data <- structure(.Data, ...) - } - .Data -} - -# remove specified attributes -rm_attr <- function(x, attr) { - attributes(x)[attr] <- NULL - x -} - -# unidimensional subsetting while keeping attributes -subset_keep_attr <- function(x, y) { - att <- attributes(x) - x <- x[y] - att$names <- names(x) - attributes(x) <- att - x -} - -'%||%' <- function(x, y) { - if (is.null(x)) x <- y - x -} - -# check if 'x' is a whole number (integer) -is_wholenumber <- function(x, tol = .Machine$double.eps) { - if (is.numeric(x)) { - out <- abs(x - round(x)) < tol - } else { - out <- rep(FALSE, length(x)) - } - dim(out) <- dim(x) - out -} - -# helper function to check symmetry of a matrix -is_symmetric <- function(x, tol = sqrt(.Machine$double.eps)) { - isSymmetric(x, tol = tol, check.attributes = FALSE) -} - -# unlist lapply output -ulapply <- function(X, FUN, ..., recursive = TRUE, use.names = TRUE) { - unlist(lapply(X, FUN, ...), recursive, use.names) -} - -# rbind lapply output -rblapply <- function(X, FUN, ...) { - do.call(rbind, lapply(X, FUN, ...)) -} - -# cbind lapply output -cblapply <- function(X, FUN, ...) { - do.call(cbind, lapply(X, FUN, ...)) -} - -# parallel lapply sensitive to the operating system -plapply <- function(X, FUN, cores = 1, ...) { - if (cores == 1) { - out <- lapply(X, FUN, ...) - } else { - if (!os_is_windows()) { - out <- parallel::mclapply(X = X, FUN = FUN, mc.cores = cores, ...) - } else { - cl <- parallel::makePSOCKcluster(cores) - on.exit(parallel::stopCluster(cl)) - out <- parallel::parLapply(cl = cl, X = X, fun = FUN, ...) - } - } - out -} - -# check if the operating system is Windows -os_is_windows <- function() { - isTRUE(Sys.info()[['sysname']] == "Windows") -} - -# find variables in a character string or expression -all_vars <- function(expr, ...) { - if (is.character(expr)) { - expr <- str2expression(expr) - } - all.vars(expr, ...) -} - -# reimplemented for older R versions -# see ?parse in R 3.6 or higher -str2expression <- function(x) { - parse(text = x, keep.source = FALSE) -} - -# reimplemented for older R versions -# see ?parse in R 3.6 or higher -str2lang <- function(x) { - str2expression(x)[[1]] -} - -# append list(...) to x -lc <- function(x, ...) { - dots <- rmNULL(list(...), recursive = FALSE) - c(x, dots) -} - -'c<-' <- function(x, value) { - c(x, value) -} - -'lc<-' <- function(x, value) { - lc(x, value) -} - -collapse <- function(..., sep = "") { - paste(..., sep = sep, collapse = "") -} - -collapse_comma <- function(...) { - paste0("'", ..., "'", collapse = ", ") -} - -# add characters to an existing string -'str_add<-' <- function(x, start = FALSE, value) { - if (start) paste0(value, x) else paste0(x, value) -} - -# add list of characters to an existing list -'str_add_list<-' <- function(x, start = FALSE, value) { - stopifnot(is.list(x), is.list(value)) - out <- if (start) list(value, x) else list(x, value) - collapse_lists(ls = out) -} - -# type-stable if clause for strings with default else output -str_if <- function(cond, yes, no = "") { - cond <- as_one_logical(cond) - if (cond) as.character(yes) else as.character(no) -} - -# select elements which match a regex pattern -str_subset <- function(x, pattern, ...) { - x[grepl(pattern, x, ...)] -} - -# similar to glue::glue but specialized for generating Stan code -glue <- function(..., sep = "", collapse = NULL, envir = parent.frame(), - open = "{", close = "}", na = "NA") { - dots <- list(...) - dots <- dots[lengths(dots) > 0L] - args <- list( - .x = NULL, .sep = sep, .envir = envir, .open = open, - .close = close, .na = na, .trim = FALSE, - .transformer = zero_length_transformer - ) - out <- do.call(glue::glue_data, c(dots, args)) - if (!is.null(collapse)) { - collapse <- as_one_character(collapse) - out <- paste0(out, collapse = collapse) - } - out -} - -# used in 'glue' to handle zero-length inputs -zero_length_transformer <- function(text, envir) { - out <- glue::identity_transformer(text, envir) - if (!length(out)) { - out <- "" - } - out -} - -# collapse strings evaluated with glue -cglue <- function(..., envir = parent.frame()) { - glue(..., envir = envir, collapse = "") -} - -# check if a certain package is installed -# @param package package name -# @param version optional minimal version number to require -require_package <- function(package, version = NULL) { - if (!requireNamespace(package, quietly = TRUE)) { - stop2("Please install the '", package, "' package.") - } - if (!is.null(version)) { - version <- as.package_version(version) - if (utils::packageVersion(package) < version) { - stop2("Please install package '", package, - "' version ", version, " or higher.") - } - } - invisible(TRUE) -} - -# rename specified patterns in a character vector -# @param x a character vector to be renamed -# @param pattern the regular expressions in x to be replaced -# @param replacement the replacements -# @param fixed same as for 'gsub' -# @param check_dup: logical; check for duplications in x after renaming -# @param ... passed to 'gsub' -# @return renamed character vector of the same length as x -rename <- function(x, pattern = NULL, replacement = NULL, - fixed = TRUE, check_dup = FALSE, ...) { - pattern <- as.character(pattern) - replacement <- as.character(replacement) - if (!length(pattern) && !length(replacement)) { - # default renaming to avoid special characters in coeffcient names - pattern <- c( - " ", "(", ")", "[", "]", ",", "\"", "'", - "?", "+", "-", "*", "/", "^", "=" - ) - replacement <- c(rep("", 9), "P", "M", "MU", "D", "E", "EQ") - } - if (length(replacement) == 1L) { - replacement <- rep(replacement, length(pattern)) - } - stopifnot(length(pattern) == length(replacement)) - # avoid zero-length pattern error - has_chars <- nzchar(pattern) - pattern <- pattern[has_chars] - replacement <- replacement[has_chars] - out <- x - for (i in seq_along(pattern)) { - out <- gsub(pattern[i], replacement[i], out, fixed = fixed, ...) - } - dup <- duplicated(out) - if (check_dup && any(dup)) { - dup <- x[out %in% out[dup]] - stop2("Internal renaming led to duplicated names. \n", - "Occured for: ", collapse_comma(dup)) - } - out -} - -# collapse strings having the same name in different lists -# @param ... named lists -# @param ls a list of named lists -# @param a named list containing the collapsed strings -collapse_lists <- function(..., ls = list()) { - ls <- c(list(...), ls) - elements <- unique(unlist(lapply(ls, names))) - args <- c(FUN = collapse, lapply(ls, "[", elements), SIMPLIFY = FALSE) - out <- do.call(mapply, args) - names(out) <- elements - out -} - -# create a named list using object names -nlist <- function(...) { - m <- match.call() - dots <- list(...) - no_names <- is.null(names(dots)) - has_name <- if (no_names) FALSE else nzchar(names(dots)) - if (all(has_name)) return(dots) - nms <- as.character(m)[-1] - if (no_names) { - names(dots) <- nms - } else { - names(dots)[!has_name] <- nms[!has_name] - } - dots -} - -# initialize a named list -# @param names names of the elements -# @param values optional values of the elements -named_list <- function(names, values = NULL) { - if (!is.null(values)) { - if (length(values) <= 1L) { - values <- replicate(length(names), values) - } - values <- as.list(values) - stopifnot(length(values) == length(names)) - } else { - values <- vector("list", length(names)) - } - setNames(values, names) -} - -# is an object named? -is_named <- function(x) { - names <- names(x) - if (is.null(names)) { - return(FALSE) - } - if (any(!nzchar(names) | is.na(names))) { - return(FALSE) - } - TRUE -} - -#' Execute a Function Call -#' -#' Execute a function call similar to \code{\link{do.call}}, but without -#' deparsing function arguments. For large number of arguments (i.e., more -#' than a few thousand) this function currently is somewhat inefficient -#' and should be used with care in this case. -#' -#' @param what Either a function or a non-empty character string naming the -#' function to be called. -#' @param args A list of arguments to the function call. The names attribute of -#' \code{args} gives the argument names. -#' @param pkg Optional name of the package in which to search for the -#' function if \code{what} is a character string. -#' @param envir An environment within which to evaluate the call. -#' -#' @return The result of the (evaluated) function call. -#' -#' @keywords internal -#' @export -do_call <- function(what, args, pkg = NULL, envir = parent.frame()) { - call <- "" - if (length(args)) { - if (!is.list(args)) { - stop2("'args' must be a list.") - } - fun_args <- names(args) - if (is.null(fun_args)) { - fun_args <- rep("", length(args)) - } else { - nzc <- nzchar(fun_args) - fun_args[nzc] <- paste0("`", fun_args[nzc], "` = ") - } - names(args) <- paste0(".x", seq_along(args)) - call <- paste0(fun_args, names(args), collapse = ",") - } else { - args <- list() - } - if (is.function(what)) { - args$.fun <- what - what <- ".fun" - } else { - what <- paste0("`", as_one_character(what), "`") - if (!is.null(pkg)) { - what <- paste0(as_one_character(pkg), "::", what) - } - } - call <- paste0(what, "(", call, ")") - eval2(call, envir = args, enclos = envir) -} - -# create an empty data frame -empty_data_frame <- function() { - as.data.frame(matrix(nrow = 0, ncol = 0)) -} - -# replace elements in x with elements in value -# @param x named list-like object -# @param value another named list-like object -# @param dont_replace names of elements that cannot be replaced -'replace_args<-' <- function(x, dont_replace = NULL, value) { - value_name <- deparse_combine(substitute(value), max_char = 100L) - value <- as.list(value) - if (length(value) && is.null(names(value))) { - stop2("Argument '", value_name, "' must be named.") - } - invalid <- names(value)[names(value) %in% dont_replace] - if (length(invalid)) { - invalid <- collapse_comma(invalid) - stop2("Argument(s) ", invalid, " cannot be replaced.") - } - x[names(value)] <- value - x -} - -# deparse 'x' if it is no string -deparse_no_string <- function(x) { - if (!is.character(x)) { - x <- deparse_combine(x) - } - x -} - -# combine deparse lines into one string -deparse_combine <- function(x, max_char = NULL) { - out <- collapse(deparse(x)) - if (isTRUE(max_char > 0)) { - out <- substr(out, 1L, max_char) - } - out -} - -# like 'eval' but parses characters before evaluation -eval2 <- function(expr, envir = parent.frame(), ...) { - if (is.character(expr)) { - expr <- str2expression(expr) - } - eval(expr, envir, ...) -} - -# evaluate an expression without printing output or messages -# @param expr expression to be evaluated -# @param type type of output to be suppressed (see ?sink) -# @param try wrap evaluation of expr in 'try' and -# not suppress outputs if evaluation fails? -# @param silent actually evaluate silently? -eval_silent <- function(expr, type = "output", try = FALSE, - silent = TRUE, ...) { - try <- as_one_logical(try) - silent <- as_one_logical(silent) - type <- match.arg(type, c("output", "message")) - expr <- substitute(expr) - envir <- parent.frame() - if (silent) { - if (try && type == "message") { - try_out <- try(utils::capture.output( - out <- eval(expr, envir), type = type, ... - )) - if (is(try_out, "try-error")) { - # try again without suppressing error messages - out <- eval(expr, envir) - } - } else { - utils::capture.output(out <- eval(expr, envir), type = type, ...) - } - } else { - out <- eval(expr, envir) - } - out -} - -# find the name that 'x' had in a specific environment -substitute_name <- function(x, envir = parent.frame(), nchar = 50) { - out <- substitute(x) - out <- eval2(paste0("substitute(", out, ")"), envir = envir) - if (missing(out)) { - return(NULL) - } - substr(collapse(deparse(out)), 1, nchar) -} - -# recursive sorting of dependencies -# @param x named list of dependencies per element -# @param sorted already sorted element names -# @return a vector of sorted element names -sort_dependencies <- function(x, sorted = NULL) { - if (!length(x)) { - return(NULL) - } - if (length(names(x)) != length(x)) { - stop2("Argument 'x' must be named.") - } - take <- !ulapply(x, function(dep) any(!dep %in% sorted)) - new <- setdiff(names(x)[take], sorted) - out <- union(sorted, new) - if (length(new)) { - out <- union(out, sort_dependencies(x, sorted = out)) - } else if (!all(names(x) %in% out)) { - stop2("Cannot handle circular dependency structures.") - } - out -} - -stop2 <- function(...) { - stop(..., call. = FALSE) -} - -warning2 <- function(...) { - warning(..., call. = FALSE) -} - -# get first occurrence of 'x' in '...' objects -# @param x The name of the required element -# @param ... named R objects that may contain 'x' -get_arg <- function(x, ...) { - dots <- list(...) - i <- 1 - out <- NULL - while (i <= length(dots) && is.null(out)) { - if (!is.null(dots[[i]][[x]])) { - out <- dots[[i]][[x]] - } else { - i <- i + 1 - } - } - out -} - -SW <- function(expr) { - base::suppressWarnings(expr) -} - -# get pattern matches in text as vector -# @param simplify return an atomic vector of matches? -# @param first only return the first match in each string? -# @return character vector containing matches -get_matches <- function(pattern, text, simplify = TRUE, - first = FALSE, ...) { - x <- regmatches(text, gregexpr(pattern, text, ...)) - if (first) { - x <- lapply(x, function(t) if (length(t)) t[1] else t) - } - if (simplify) { - if (first) { - x <- lapply(x, function(t) if (length(t)) t else "") - } - x <- unlist(x) - } - x -} - -# find matches in the parse tree of an expression -# @param pattern pattern to be matched -# @param expr expression to be searched in -# @return character vector containing matches -get_matches_expr <- function(pattern, expr, ...) { - if (is.character(expr)) { - expr <- str2expression(expr) - } - out <- NULL - for (i in seq_along(expr)) { - sexpr <- try(expr[[i]], silent = TRUE) - if (!is(sexpr, "try-error")) { - sexpr_char <- deparse_combine(sexpr) - out <- c(out, get_matches(pattern, sexpr_char, ...)) - } - if (is.call(sexpr) || is.expression(sexpr)) { - out <- c(out, get_matches_expr(pattern, sexpr, ...)) - } - } - unique(out) -} - -# like 'grepl' but handles (parse trees of) expressions -grepl_expr <- function(pattern, expr, ...) { - as.logical(ulapply(expr, function(e) - length(get_matches_expr(pattern, e, ...)) > 0L)) -} - -# combine character vectors into a joint regular 'or' expression -# @param x a character vector -# @param escape escape all special characters in 'x'? -regex_or <- function(x, escape = FALSE) { - if (escape) { - x <- escape_all(x) - } - paste0("(", paste0("(", x, ")", collapse = "|"), ")") -} - -# escape dots in character strings -escape_dot <- function(x) { - gsub(".", "\\.", x, fixed = TRUE) -} - -# escape all special characters in character strings -escape_all <- function(x) { - specials <- c(".", "*", "+", "?", "^", "$", "(", ")", "[", "]", "|") - for (s in specials) { - x <- gsub(s, paste0("\\", s), x, fixed = TRUE) - } - x -} - -# add an underscore to non-empty character strings -# @param x a character vector -# @param pos position of the underscore -usc <- function(x, pos = c("prefix", "suffix")) { - pos <- match.arg(pos) - x <- as.character(x) - if (!length(x)) x <- "" - if (pos == "prefix") { - x <- ifelse(nzchar(x), paste0("_", x), "") - } else { - x <- ifelse(nzchar(x), paste0(x, "_"), "") - } - x -} - -# round using the largest remainder method -round_largest_remainder <- function(x) { - x <- as.numeric(x) - total <- round(sum(x)) - out <- floor(x) - diff <- x - out - J <- order(diff, decreasing = TRUE) - I <- seq_len(total - floor(sum(out))) - out[J[I]] <- out[J[I]] + 1 - out -} - -# add leading and trailing white spaces -# @param x object accepted by paste -# @param nsp number of white spaces to add -wsp <- function(x = "", nsp = 1) { - sp <- collapse(rep(" ", nsp)) - if (length(x)) { - out <- ifelse(nzchar(x), paste0(sp, x, sp), sp) - } else { - out <- NULL - } - out -} - -# add white space per line the the strings -# @param x object accepted by paste -# @param nsp number of white spaces to add -wsp_per_line <- function(x, nsp) { - sp <- collapse(rep(" ", nsp)) - x <- paste0(sp, x) - x <- gsub("\\n(?=.+)", paste0("\n", sp), x, perl = TRUE) - x -} - -# remove whitespaces in character strings -rm_wsp <- function(x) { - out <- gsub("[ \t\r\n]+", "", x, perl = TRUE) - dim(out) <- dim(x) - out -} - -# trim whitespaces in character strings -trim_wsp <- function(x) { - out <- gsub("[ \t\r\n]+", " ", x, perl = TRUE) - dim(out) <- dim(x) - out -} - -# limit the number of characters of a vector -# @param x a character vector -# @param chars maximum number of characters to show -# @param lsuffix number of characters to keep at the end of the strings -# @return possible truncated character vector -limit_chars <- function(x, chars = NULL, lsuffix = 4) { - stopifnot(is.character(x)) - if (!is.null(chars)) { - chars_x <- nchar(x) - lsuffix - suffix <- substr(x, chars_x + 1, chars_x + lsuffix) - x <- substr(x, 1, chars_x) - x <- ifelse(chars_x <= chars, x, paste0(substr(x, 1, chars - 3), "...")) - x <- paste0(x, suffix) - } - x -} - -# ensure that deprecated arguments still work -# @param arg input to the new argument -# @param alias input to the deprecated argument -# @param default the default value of alias -# @param warn should a warning be printed if alias is specified? -use_alias <- function(arg, alias = NULL, default = NULL, warn = TRUE) { - arg_name <- Reduce(paste, deparse(substitute(arg))) - alias_name <- Reduce(paste, deparse(substitute(alias))) - if (!is_equal(alias, default)) { - arg <- alias - if (grepl("^dots\\$", alias_name)) { - alias_name <- gsub("^dots\\$", "", alias_name) - } else if (grepl("^dots\\[\\[", alias_name)) { - alias_name <- gsub("^dots\\[\\[\"|\"\\]\\]$", "", alias_name) - } - if (warn) { - warning2("Argument '", alias_name, "' is deprecated. ", - "Please use argument '", arg_name, "' instead.") - } - } - arg -} - -warn_deprecated <- function(new, old = as.character(sys.call(sys.parent()))[1]) { - msg <- paste0("Function '", old, "' is deprecated.") - if (!missing(new)) { - msg <- paste0(msg, " Please use '", new, "' instead.") - } - warning2(msg) - invisible(NULL) -} - -# check if verbose mode is activated -is_verbose <- function() { - as_one_logical(getOption("brms.verbose", FALSE)) -} - -viridis6 <- function() { - c("#440154", "#414487", "#2A788E", "#22A884", "#7AD151", "#FDE725") -} - -expect_match2 <- function(object, regexp, ..., all = TRUE) { - testthat::expect_match(object, regexp, fixed = TRUE, ..., all = all) -} - -# Copied from package 'vctrs' (more precisely: -# , version -# 0.3.8.9001; identical to the code from version 0.3.8), as offered on the help -# page for vctrs::s3_register() (version 0.3.8): -s3_register_cp <- function(generic, class, method = NULL) { - stopifnot(is.character(generic), length(generic) == 1) - stopifnot(is.character(class), length(class) == 1) - - pieces <- strsplit(generic, "::")[[1]] - stopifnot(length(pieces) == 2) - package <- pieces[[1]] - generic <- pieces[[2]] - - caller <- parent.frame() - - get_method_env <- function() { - top <- topenv(caller) - if (isNamespace(top)) { - asNamespace(environmentName(top)) - } else { - caller - } - } - get_method <- function(method, env) { - if (is.null(method)) { - get(paste0(generic, ".", class), envir = get_method_env()) - } else { - method - } - } - - register <- function(...) { - envir <- asNamespace(package) - - # Refresh the method each time, it might have been updated by - # `devtools::load_all()` - method_fn <- get_method(method) - stopifnot(is.function(method_fn)) - - - # Only register if generic can be accessed - if (exists(generic, envir)) { - registerS3method(generic, class, method_fn, envir = envir) - } else if (identical(Sys.getenv("NOT_CRAN"), "true")) { - warning(sprintf( - "Can't find generic `%s` in package %s to register S3 method.", - generic, - package - )) - } - } - - # Always register hook in case package is later unloaded & reloaded - setHook(packageEvent(package, "onLoad"), register) - - # Avoid registration failures during loading (pkgload or regular) - if (isNamespaceLoaded(package)) { - register() - } - - invisible() -} - -# startup messages for brms -.onAttach <- function(libname, pkgname) { - version <- utils::packageVersion("brms") - packageStartupMessage( - "Loading 'brms' package (version ", version, "). Useful instructions\n", - "can be found by typing help('brms'). A more detailed introduction\n", - "to the package is available through vignette('brms_overview')." - ) - invisible(NULL) -} - -# code to execute when loading brms -.onLoad <- function(libname, pkgname) { - # ensure compatibility with older R versions - backports::import(pkgname) - # dynamically register the 'recover_data' and 'emm_basis' - # methods needed by 'emmeans', if that package is installed - if (requireNamespace("emmeans", quietly = TRUE) && - utils::packageVersion("emmeans") >= "1.4.0") { - emmeans::.emm_register("brmsfit", pkgname) - } - # dynamically register the 'get_refmodel.brmsfit' method for the - # 'get_refmodel' generic from 'projpred', if that package is installed - if (requireNamespace("projpred", quietly = TRUE)) { - s3_register_cp("projpred::get_refmodel", "brmsfit") - } - invisible(NULL) -} +# type-stable indexing of vector and matrix type objects +# @param x an R object typically a vector or matrix +# @param i optional index; if NULL, x is returned unchanged +# @param row indicating if rows or cols should be indexed +# only relevant if x has two or three dimensions +p <- function(x, i = NULL, row = TRUE) { + # TODO: replace by "slice" + if (isTRUE(length(dim(x)) > 3L)) { + stop2("'p' can only handle objects up to 3 dimensions.") + } + if (!length(i)) { + out <- x + } else if (length(dim(x)) == 2L) { + if (row) { + out <- x[i, , drop = FALSE] + } else { + out <- x[, i, drop = FALSE] + } + } else if (length(dim(x)) == 3L) { + if (row) { + out <- x[i, , , drop = FALSE] + } else { + out <- x[, i, , drop = FALSE] + } + } else { + out <- x[i] + } + out +} + +# extract parts of an object with selective dropping of dimensions +# @param x,...,drop same as in x[..., drop] +# @drop_dim: Optional numeric or logical vector controlling +# which dimensions to drop. Will overwrite argument 'drop'. +extract <- function(x, ..., drop = FALSE, drop_dim = NULL) { + if (!length(dim(x))) { + return(x[...]) + } + if (length(drop_dim)) { + drop <- FALSE + } else { + drop <- as_one_logical(drop) + } + out <- x[..., drop = drop] + if (drop || !length(drop_dim) || any(dim(out) == 0L)) { + return(out) + } + if (is.numeric(drop_dim)) { + drop_dim <- seq_along(dim(x)) %in% drop_dim + } + if (!is.logical(drop_dim)) { + stop2("'drop_dim' needs to be logical or numeric.") + } + keep <- dim(out) > 1L | !drop_dim + new_dim <- dim(out)[keep] + if (length(new_dim) == 1L) { + # use vectors instead of 1D arrays + new_dim <- NULL + } + dim(out) <- new_dim + out +} + +# extract slices of one array dimension without dropping other dimensions +# @param x an array +# @param dim dimension from which to take the slice +# @param i slice index +# @param drop Logical (length 1) indicating whether to drop dimension `dim`. +slice <- function(x, dim, i, drop = TRUE) { + ndim <- length(dim(x)) + commas1 <- collapse(rep(", ", dim - 1)) + commas2 <- collapse(rep(", ", ndim - dim)) + drop_dim <- ifelse(drop, ", drop_dim = dim", "") + expr <- paste0("extract(x, ", commas1, "i", commas2, drop_dim, ")") + eval2(expr) +} + +# slice out columns without dropping other dimensions +# @param x an array; a vector or 1D array is treated as already sliced +# @param i column index +slice_col <- function(x, i) { + if (length(dim(x)) < 2L) { + # a vector or 1D array is treated as already sliced + return(x) + } + slice(x, 2, i) +} + +seq_rows <- function(x) { + seq_len(NROW(x)) +} + +seq_cols <- function(x) { + seq_len(NCOL(x)) +} + +seq_dim <- function(x, dim) { + dim <- as_one_numeric(dim) + if (dim == 1) { + len <- NROW(x) + } else if (dim == 2) { + len <- NCOL(x) + } else { + len <- dim(x)[dim] + } + if (length(len) == 1L && !isNA(len)) { + out <- seq_len(len) + } else { + out <- integer(0) + } + out +} + +# match rows in x with rows in y +match_rows <- function(x, y, ...) { + x <- as.data.frame(x) + y <- as.data.frame(y) + x <- do.call("paste", c(x, sep = "\r")) + y <- do.call("paste", c(y, sep = "\r")) + match(x, y, ...) +} + +# find elements of 'x' matching sub-elements passed via 'ls' and '...' +find_elements <- function(x, ..., ls = list(), fun = '%in%') { + x <- as.list(x) + if (!length(x)) { + return(logical(0)) + } + out <- rep(TRUE, length(x)) + ls <- c(ls, list(...)) + if (!length(ls)) { + return(out) + } + if (is.null(names(ls))) { + stop("Argument 'ls' must be named.") + } + for (name in names(ls)) { + tmp <- lapply(x, "[[", name) + out <- out & do_call(fun, list(tmp, ls[[name]])) + } + out +} + +# find rows of 'x' matching columns passed via 'ls' and '...' +# similar to 'find_elements' but for matrix like objects +find_rows <- function(x, ..., ls = list(), fun = '%in%') { + x <- as.data.frame(x) + if (!nrow(x)) { + return(logical(0)) + } + out <- rep(TRUE, nrow(x)) + ls <- c(ls, list(...)) + if (!length(ls)) { + return(out) + } + if (is.null(names(ls))) { + stop("Argument 'ls' must be named.") + } + for (name in names(ls)) { + out <- out & do_call(fun, list(x[[name]], ls[[name]])) + } + out +} + +# subset 'x' using arguments passed via 'ls' and '...' +subset2 <- function(x, ..., ls = list(), fun = '%in%') { + x[find_rows(x, ..., ls = ls, fun = fun), , drop = FALSE] +} + +# convert array to list of elements with reduced dimension +# @param x an arrary of dimension d +# @return a list of arrays of dimension d-1 +array2list <- function(x) { + if (is.null(dim(x))) { + return(as.list(x)) + } + ndim <- length(dim(x)) + out <- list(length = dim(x)[ndim]) + ind <- collapse(rep(",", ndim - 1)) + for (i in seq_len(dim(x)[ndim])) { + out[[i]] <- eval2(paste0("x[", ind, i, "]")) + if (length(dim(x)) > 2) { + # avoid accidental dropping of other dimensions + dim(out[[i]]) <- dim(x)[-ndim] + } + } + names(out) <- dimnames(x)[[ndim]] + out +} + +# move elements to the start of a named object +move2start <- function(x, first) { + x[c(first, setdiff(names(x), first))] +} + +# move elements to the end of a named object +move2end <- function(x, last) { + x[c(setdiff(names(x), last), last)] +} + +# wrapper around replicate but without simplifying +repl <- function(expr, n) { + replicate(n, expr, simplify = FALSE) +} + +# find the first element in A that is greater than target +# @param A a matrix +# @param target a vector of length nrow(A) +# @param i column of A being checked first +# @return a vector of the same length as target containing the +# column ids where A[,i] was first greater than target +first_greater <- function(A, target, i = 1) { + ifelse(target <= A[, i] | ncol(A) == i, i, first_greater(A, target, i + 1)) +} + +# check if an object is NULL +isNULL <- function(x) { + is.null(x) || ifelse(is.vector(x), all(sapply(x, is.null)), FALSE) +} + +# recursively removes NULL entries from an object +rmNULL <- function(x, recursive = TRUE) { + x <- Filter(Negate(isNULL), x) + if (recursive) { + x <- lapply(x, function(x) if (is.list(x)) rmNULL(x) else x) + } + x +} + +# find the first argument that is not NULL +first_not_null <- function(...) { + dots <- list(...) + out <- NULL + i <- 1L + while (isNULL(out) && i <= length(dots)) { + if (!isNULL(dots[[i]])) { + out <- dots[[i]] + } + i <- i + 1L + } + out +} + +isNA <- function(x) { + length(x) == 1L && is.na(x) +} + +is_equal <- function(x, y, check.attributes = FALSE, ...) { + isTRUE(all.equal(x, y, check.attributes = check.attributes, ...)) +} + +# check if 'x' will behave like a factor in design matrices +is_like_factor <- function(x) { + is.factor(x) || is.character(x) || is.logical(x) +} + +# as.factor but allows to pass levels +as_factor <- function(x, levels = NULL) { + if (is.null(levels)) { + out <- as.factor(x) + } else { + out <- factor(x, levels = levels) + } + out +} + +# coerce 'x' to a single logical value +as_one_logical <- function(x, allow_na = FALSE) { + s <- substitute(x) + x <- as.logical(x) + if (length(x) != 1L || anyNA(x) && !allow_na) { + s <- deparse_combine(s, max_char = 100L) + stop2("Cannot coerce '", s, "' to a single logical value.") + } + x +} + +# coerce 'x' to a single integer value +as_one_integer <- function(x, allow_na = FALSE) { + s <- substitute(x) + x <- SW(as.integer(x)) + if (length(x) != 1L || anyNA(x) && !allow_na) { + s <- deparse_combine(s, max_char = 100L) + stop2("Cannot coerce '", s, "' to a single integer value.") + } + x +} + +# coerce 'x' to a single numeric value +as_one_numeric <- function(x, allow_na = FALSE) { + s <- substitute(x) + x <- SW(as.numeric(x)) + if (length(x) != 1L || anyNA(x) && !allow_na) { + s <- deparse_combine(s, max_char = 100L) + stop2("Cannot coerce '", s, "' to a single numeric value.") + } + x +} + +# coerce 'x' to a single character string +as_one_character <- function(x, allow_na = FALSE) { + s <- substitute(x) + x <- as.character(x) + if (length(x) != 1L || anyNA(x) && !allow_na) { + s <- deparse_combine(s, max_char = 100L) + stop2("Cannot coerce '", s, "' to a single character value.") + } + x +} + +# coerce 'x' to a single character variable name +as_one_variable <- function(x, allow_na = TRUE) { + x <- as_one_character(x) + if (x == "NA" && allow_na) { + return(x) + } + if (!nzchar(x) || !is_equal(x, all_vars(x))) { + stop2("Cannot coerce '", x, "' to a single variable name.") + } + x +} + +has_rows <- function(x) { + isTRUE(nrow(x) > 0L) +} + +has_cols <- function(x) { + isTRUE(ncol(x) > 0L) +} + +# expand arguments to the same length +# @param ... arguments to expand +# @param length optional expansion length +# otherwise taken to be the largest supplied length +# @return a data.frame with one variable per element in '...' +expand <- function(..., dots = list(), length = NULL) { + dots <- c(dots, list(...)) + max_dim <- NULL + if (is.null(length)) { + lengths <- lengths(dots) + length <- max(lengths) + max_dim <- dim(dots[[match(length, lengths)]]) + } + out <- as.data.frame(lapply(dots, rep, length.out = length)) + structure(out, max_dim = max_dim) +} + +# structure but ignore NULL +structure_not_null <- function(.Data, ...) { + if (!is.null(.Data)) { + .Data <- structure(.Data, ...) + } + .Data +} + +# remove specified attributes +rm_attr <- function(x, attr) { + attributes(x)[attr] <- NULL + x +} + +# unidimensional subsetting while keeping attributes +subset_keep_attr <- function(x, y) { + att <- attributes(x) + x <- x[y] + att$names <- names(x) + attributes(x) <- att + x +} + +'%||%' <- function(x, y) { + if (is.null(x)) x <- y + x +} + +# check if 'x' is a whole number (integer) +is_wholenumber <- function(x, tol = .Machine$double.eps) { + if (is.numeric(x)) { + out <- abs(x - round(x)) < tol + } else { + out <- rep(FALSE, length(x)) + } + dim(out) <- dim(x) + out +} + +# helper function to check symmetry of a matrix +is_symmetric <- function(x, tol = sqrt(.Machine$double.eps)) { + isSymmetric(x, tol = tol, check.attributes = FALSE) +} + +# unlist lapply output +ulapply <- function(X, FUN, ..., recursive = TRUE, use.names = TRUE) { + unlist(lapply(X, FUN, ...), recursive, use.names) +} + +# rbind lapply output +rblapply <- function(X, FUN, ...) { + do.call(rbind, lapply(X, FUN, ...)) +} + +# cbind lapply output +cblapply <- function(X, FUN, ...) { + do.call(cbind, lapply(X, FUN, ...)) +} + +# parallel lapply sensitive to the operating system +plapply <- function(X, FUN, cores = 1, ...) { + if (cores == 1) { + out <- lapply(X, FUN, ...) + } else { + if (!os_is_windows()) { + out <- parallel::mclapply(X = X, FUN = FUN, mc.cores = cores, ...) + } else { + cl <- parallel::makePSOCKcluster(cores) + on.exit(parallel::stopCluster(cl)) + out <- parallel::parLapply(cl = cl, X = X, fun = FUN, ...) + } + } + out +} + +# check if the operating system is Windows +os_is_windows <- function() { + isTRUE(Sys.info()[['sysname']] == "Windows") +} + +# find variables in a character string or expression +all_vars <- function(expr, ...) { + if (is.character(expr)) { + expr <- str2expression(expr) + } + all.vars(expr, ...) +} + +# reimplemented for older R versions +# see ?parse in R 3.6 or higher +str2expression <- function(x) { + parse(text = x, keep.source = FALSE) +} + +# reimplemented for older R versions +# see ?parse in R 3.6 or higher +str2lang <- function(x) { + str2expression(x)[[1]] +} + +# append list(...) to x +lc <- function(x, ...) { + dots <- rmNULL(list(...), recursive = FALSE) + c(x, dots) +} + +'c<-' <- function(x, value) { + c(x, value) +} + +'lc<-' <- function(x, value) { + lc(x, value) +} + +collapse <- function(..., sep = "") { + paste(..., sep = sep, collapse = "") +} + +collapse_comma <- function(...) { + paste0("'", ..., "'", collapse = ", ") +} + +# add characters to an existing string +'str_add<-' <- function(x, start = FALSE, value) { + if (start) paste0(value, x) else paste0(x, value) +} + +# add list of characters to an existing list +'str_add_list<-' <- function(x, start = FALSE, value) { + stopifnot(is.list(x), is.list(value)) + out <- if (start) list(value, x) else list(x, value) + collapse_lists(ls = out) +} + +# type-stable if clause for strings with default else output +str_if <- function(cond, yes, no = "") { + cond <- as_one_logical(cond) + if (cond) as.character(yes) else as.character(no) +} + +# select elements which match a regex pattern +str_subset <- function(x, pattern, ...) { + x[grepl(pattern, x, ...)] +} + +# similar to glue::glue but specialized for generating Stan code +glue <- function(..., sep = "", collapse = NULL, envir = parent.frame(), + open = "{", close = "}", na = "NA") { + dots <- list(...) + dots <- dots[lengths(dots) > 0L] + args <- list( + .x = NULL, .sep = sep, .envir = envir, .open = open, + .close = close, .na = na, .trim = FALSE, + .transformer = zero_length_transformer + ) + out <- do.call(glue::glue_data, c(dots, args)) + if (!is.null(collapse)) { + collapse <- as_one_character(collapse) + out <- paste0(out, collapse = collapse) + } + out +} + +# used in 'glue' to handle zero-length inputs +zero_length_transformer <- function(text, envir) { + out <- glue::identity_transformer(text, envir) + if (!length(out)) { + out <- "" + } + out +} + +# collapse strings evaluated with glue +cglue <- function(..., envir = parent.frame()) { + glue(..., envir = envir, collapse = "") +} + +# check if a certain package is installed +# @param package package name +# @param version optional minimal version number to require +require_package <- function(package, version = NULL) { + if (!requireNamespace(package, quietly = TRUE)) { + stop2("Please install the '", package, "' package.") + } + if (!is.null(version)) { + version <- as.package_version(version) + if (utils::packageVersion(package) < version) { + stop2("Please install package '", package, + "' version ", version, " or higher.") + } + } + invisible(TRUE) +} + +# rename specified patterns in a character vector +# @param x a character vector to be renamed +# @param pattern the regular expressions in x to be replaced +# @param replacement the replacements +# @param fixed same as for 'gsub' +# @param check_dup: logical; check for duplications in x after renaming +# @param ... passed to 'gsub' +# @return renamed character vector of the same length as x +rename <- function(x, pattern = NULL, replacement = NULL, + fixed = TRUE, check_dup = FALSE, ...) { + pattern <- as.character(pattern) + replacement <- as.character(replacement) + if (!length(pattern) && !length(replacement)) { + # default renaming to avoid special characters in coeffcient names + pattern <- c( + " ", "(", ")", "[", "]", ",", "\"", "'", + "?", "+", "-", "*", "/", "^", "=" + ) + replacement <- c(rep("", 9), "P", "M", "MU", "D", "E", "EQ") + } + if (length(replacement) == 1L) { + replacement <- rep(replacement, length(pattern)) + } + stopifnot(length(pattern) == length(replacement)) + # avoid zero-length pattern error + has_chars <- nzchar(pattern) + pattern <- pattern[has_chars] + replacement <- replacement[has_chars] + out <- x + for (i in seq_along(pattern)) { + out <- gsub(pattern[i], replacement[i], out, fixed = fixed, ...) + } + dup <- duplicated(out) + if (check_dup && any(dup)) { + dup <- x[out %in% out[dup]] + stop2("Internal renaming led to duplicated names. \n", + "Occured for: ", collapse_comma(dup)) + } + out +} + +# collapse strings having the same name in different lists +# @param ... named lists +# @param ls a list of named lists +# @param a named list containing the collapsed strings +collapse_lists <- function(..., ls = list()) { + ls <- c(list(...), ls) + elements <- unique(unlist(lapply(ls, names))) + args <- c(FUN = collapse, lapply(ls, "[", elements), SIMPLIFY = FALSE) + out <- do.call(mapply, args) + names(out) <- elements + out +} + +# create a named list using object names +nlist <- function(...) { + m <- match.call() + dots <- list(...) + no_names <- is.null(names(dots)) + has_name <- if (no_names) FALSE else nzchar(names(dots)) + if (all(has_name)) return(dots) + nms <- as.character(m)[-1] + if (no_names) { + names(dots) <- nms + } else { + names(dots)[!has_name] <- nms[!has_name] + } + dots +} + +# initialize a named list +# @param names names of the elements +# @param values optional values of the elements +named_list <- function(names, values = NULL) { + if (!is.null(values)) { + if (length(values) <= 1L) { + values <- replicate(length(names), values) + } + values <- as.list(values) + stopifnot(length(values) == length(names)) + } else { + values <- vector("list", length(names)) + } + setNames(values, names) +} + +# is an object named? +is_named <- function(x) { + names <- names(x) + if (is.null(names)) { + return(FALSE) + } + if (any(!nzchar(names) | is.na(names))) { + return(FALSE) + } + TRUE +} + +#' Execute a Function Call +#' +#' Execute a function call similar to \code{\link{do.call}}, but without +#' deparsing function arguments. For large number of arguments (i.e., more +#' than a few thousand) this function currently is somewhat inefficient +#' and should be used with care in this case. +#' +#' @param what Either a function or a non-empty character string naming the +#' function to be called. +#' @param args A list of arguments to the function call. The names attribute of +#' \code{args} gives the argument names. +#' @param pkg Optional name of the package in which to search for the +#' function if \code{what} is a character string. +#' @param envir An environment within which to evaluate the call. +#' +#' @return The result of the (evaluated) function call. +#' +#' @keywords internal +#' @export +do_call <- function(what, args, pkg = NULL, envir = parent.frame()) { + call <- "" + if (length(args)) { + if (!is.list(args)) { + stop2("'args' must be a list.") + } + fun_args <- names(args) + if (is.null(fun_args)) { + fun_args <- rep("", length(args)) + } else { + nzc <- nzchar(fun_args) + fun_args[nzc] <- paste0("`", fun_args[nzc], "` = ") + } + names(args) <- paste0(".x", seq_along(args)) + call <- paste0(fun_args, names(args), collapse = ",") + } else { + args <- list() + } + if (is.function(what)) { + args$.fun <- what + what <- ".fun" + } else { + what <- paste0("`", as_one_character(what), "`") + if (!is.null(pkg)) { + what <- paste0(as_one_character(pkg), "::", what) + } + } + call <- paste0(what, "(", call, ")") + eval2(call, envir = args, enclos = envir) +} + +# create an empty data frame +empty_data_frame <- function() { + as.data.frame(matrix(nrow = 0, ncol = 0)) +} + +# replace elements in x with elements in value +# @param x named list-like object +# @param value another named list-like object +# @param dont_replace names of elements that cannot be replaced +'replace_args<-' <- function(x, dont_replace = NULL, value) { + value_name <- deparse_combine(substitute(value), max_char = 100L) + value <- as.list(value) + if (length(value) && is.null(names(value))) { + stop2("Argument '", value_name, "' must be named.") + } + invalid <- names(value)[names(value) %in% dont_replace] + if (length(invalid)) { + invalid <- collapse_comma(invalid) + stop2("Argument(s) ", invalid, " cannot be replaced.") + } + x[names(value)] <- value + x +} + +# deparse 'x' if it is no string +deparse_no_string <- function(x) { + if (!is.character(x)) { + x <- deparse_combine(x) + } + x +} + +# combine deparse lines into one string +deparse_combine <- function(x, max_char = NULL) { + out <- collapse(deparse(x)) + if (isTRUE(max_char > 0)) { + out <- substr(out, 1L, max_char) + } + out +} + +# like 'eval' but parses characters before evaluation +eval2 <- function(expr, envir = parent.frame(), ...) { + if (is.character(expr)) { + expr <- str2expression(expr) + } + eval(expr, envir, ...) +} + +# evaluate an expression without printing output or messages +# @param expr expression to be evaluated +# @param type type of output to be suppressed (see ?sink) +# @param try wrap evaluation of expr in 'try' and +# not suppress outputs if evaluation fails? +# @param silent actually evaluate silently? +eval_silent <- function(expr, type = "output", try = FALSE, + silent = TRUE, ...) { + try <- as_one_logical(try) + silent <- as_one_logical(silent) + type <- match.arg(type, c("output", "message")) + expr <- substitute(expr) + envir <- parent.frame() + if (silent) { + if (try && type == "message") { + try_out <- try(utils::capture.output( + out <- eval(expr, envir), type = type, ... + )) + if (is(try_out, "try-error")) { + # try again without suppressing error messages + out <- eval(expr, envir) + } + } else { + utils::capture.output(out <- eval(expr, envir), type = type, ...) + } + } else { + out <- eval(expr, envir) + } + out +} + +# find the name that 'x' had in a specific environment +substitute_name <- function(x, envir = parent.frame(), nchar = 50) { + out <- substitute(x) + out <- eval2(paste0("substitute(", out, ")"), envir = envir) + if (missing(out)) { + return(NULL) + } + substr(collapse(deparse(out)), 1, nchar) +} + +# recursive sorting of dependencies +# @param x named list of dependencies per element +# @param sorted already sorted element names +# @return a vector of sorted element names +sort_dependencies <- function(x, sorted = NULL) { + if (!length(x)) { + return(NULL) + } + if (length(names(x)) != length(x)) { + stop2("Argument 'x' must be named.") + } + take <- !ulapply(x, function(dep) any(!dep %in% sorted)) + new <- setdiff(names(x)[take], sorted) + out <- union(sorted, new) + if (length(new)) { + out <- union(out, sort_dependencies(x, sorted = out)) + } else if (!all(names(x) %in% out)) { + stop2("Cannot handle circular dependency structures.") + } + out +} + +stop2 <- function(...) { + stop(..., call. = FALSE) +} + +warning2 <- function(...) { + warning(..., call. = FALSE) +} + +# get first occurrence of 'x' in '...' objects +# @param x The name of the required element +# @param ... named R objects that may contain 'x' +get_arg <- function(x, ...) { + dots <- list(...) + i <- 1 + out <- NULL + while (i <= length(dots) && is.null(out)) { + if (!is.null(dots[[i]][[x]])) { + out <- dots[[i]][[x]] + } else { + i <- i + 1 + } + } + out +} + +SW <- function(expr) { + base::suppressWarnings(expr) +} + +# get pattern matches in text as vector +# @param simplify return an atomic vector of matches? +# @param first only return the first match in each string? +# @return character vector containing matches +get_matches <- function(pattern, text, simplify = TRUE, + first = FALSE, ...) { + x <- regmatches(text, gregexpr(pattern, text, ...)) + if (first) { + x <- lapply(x, function(t) if (length(t)) t[1] else t) + } + if (simplify) { + if (first) { + x <- lapply(x, function(t) if (length(t)) t else "") + } + x <- unlist(x) + } + x +} + +# find matches in the parse tree of an expression +# @param pattern pattern to be matched +# @param expr expression to be searched in +# @return character vector containing matches +get_matches_expr <- function(pattern, expr, ...) { + if (is.character(expr)) { + expr <- str2expression(expr) + } + out <- NULL + for (i in seq_along(expr)) { + sexpr <- try(expr[[i]], silent = TRUE) + if (!is(sexpr, "try-error")) { + sexpr_char <- deparse_combine(sexpr) + out <- c(out, get_matches(pattern, sexpr_char, ...)) + } + if (is.call(sexpr) || is.expression(sexpr)) { + out <- c(out, get_matches_expr(pattern, sexpr, ...)) + } + } + unique(out) +} + +# like 'grepl' but handles (parse trees of) expressions +grepl_expr <- function(pattern, expr, ...) { + as.logical(ulapply(expr, function(e) + length(get_matches_expr(pattern, e, ...)) > 0L)) +} + +# combine character vectors into a joint regular 'or' expression +# @param x a character vector +# @param escape escape all special characters in 'x'? +regex_or <- function(x, escape = FALSE) { + if (escape) { + x <- escape_all(x) + } + paste0("(", paste0("(", x, ")", collapse = "|"), ")") +} + +# escape dots in character strings +escape_dot <- function(x) { + gsub(".", "\\.", x, fixed = TRUE) +} + +# escape all special characters in character strings +escape_all <- function(x) { + specials <- c(".", "*", "+", "?", "^", "$", "(", ")", "[", "]", "|") + for (s in specials) { + x <- gsub(s, paste0("\\", s), x, fixed = TRUE) + } + x +} + +# add an underscore to non-empty character strings +# @param x a character vector +# @param pos position of the underscore +usc <- function(x, pos = c("prefix", "suffix")) { + pos <- match.arg(pos) + x <- as.character(x) + if (!length(x)) x <- "" + if (pos == "prefix") { + x <- ifelse(nzchar(x), paste0("_", x), "") + } else { + x <- ifelse(nzchar(x), paste0(x, "_"), "") + } + x +} + +# round using the largest remainder method +round_largest_remainder <- function(x) { + x <- as.numeric(x) + total <- round(sum(x)) + out <- floor(x) + diff <- x - out + J <- order(diff, decreasing = TRUE) + I <- seq_len(total - floor(sum(out))) + out[J[I]] <- out[J[I]] + 1 + out +} + +# add leading and trailing white spaces +# @param x object accepted by paste +# @param nsp number of white spaces to add +wsp <- function(x = "", nsp = 1) { + sp <- collapse(rep(" ", nsp)) + if (length(x)) { + out <- ifelse(nzchar(x), paste0(sp, x, sp), sp) + } else { + out <- NULL + } + out +} + +# add white space per line the the strings +# @param x object accepted by paste +# @param nsp number of white spaces to add +wsp_per_line <- function(x, nsp) { + sp <- collapse(rep(" ", nsp)) + x <- paste0(sp, x) + x <- gsub("\\n(?=.+)", paste0("\n", sp), x, perl = TRUE) + x +} + +# remove whitespaces in character strings +rm_wsp <- function(x) { + out <- gsub("[ \t\r\n]+", "", x, perl = TRUE) + dim(out) <- dim(x) + out +} + +# trim whitespaces in character strings +trim_wsp <- function(x) { + out <- gsub("[ \t\r\n]+", " ", x, perl = TRUE) + dim(out) <- dim(x) + out +} + +# limit the number of characters of a vector +# @param x a character vector +# @param chars maximum number of characters to show +# @param lsuffix number of characters to keep at the end of the strings +# @return possible truncated character vector +limit_chars <- function(x, chars = NULL, lsuffix = 4) { + stopifnot(is.character(x)) + if (!is.null(chars)) { + chars_x <- nchar(x) - lsuffix + suffix <- substr(x, chars_x + 1, chars_x + lsuffix) + x <- substr(x, 1, chars_x) + x <- ifelse(chars_x <= chars, x, paste0(substr(x, 1, chars - 3), "...")) + x <- paste0(x, suffix) + } + x +} + +# ensure that deprecated arguments still work +# @param arg input to the new argument +# @param alias input to the deprecated argument +# @param default the default value of alias +# @param warn should a warning be printed if alias is specified? +use_alias <- function(arg, alias = NULL, default = NULL, warn = TRUE) { + arg_name <- Reduce(paste, deparse(substitute(arg))) + alias_name <- Reduce(paste, deparse(substitute(alias))) + if (!is_equal(alias, default)) { + arg <- alias + if (grepl("^dots\\$", alias_name)) { + alias_name <- gsub("^dots\\$", "", alias_name) + } else if (grepl("^dots\\[\\[", alias_name)) { + alias_name <- gsub("^dots\\[\\[\"|\"\\]\\]$", "", alias_name) + } + if (warn) { + warning2("Argument '", alias_name, "' is deprecated. ", + "Please use argument '", arg_name, "' instead.") + } + } + arg +} + +warn_deprecated <- function(new, old = as.character(sys.call(sys.parent()))[1]) { + msg <- paste0("Function '", old, "' is deprecated.") + if (!missing(new)) { + msg <- paste0(msg, " Please use '", new, "' instead.") + } + warning2(msg) + invisible(NULL) +} + +# check if verbose mode is activated +is_verbose <- function() { + as_one_logical(getOption("brms.verbose", FALSE)) +} + +viridis6 <- function() { + c("#440154", "#414487", "#2A788E", "#22A884", "#7AD151", "#FDE725") +} + +expect_match2 <- function(object, regexp, ..., all = TRUE) { + testthat::expect_match(object, regexp, fixed = TRUE, ..., all = all) +} + +# Copied from package 'vctrs' (more precisely: +# , version +# 0.3.8.9001; identical to the code from version 0.3.8), as offered on the help +# page for vctrs::s3_register() (version 0.3.8): +s3_register_cp <- function(generic, class, method = NULL) { + stopifnot(is.character(generic), length(generic) == 1) + stopifnot(is.character(class), length(class) == 1) + + pieces <- strsplit(generic, "::")[[1]] + stopifnot(length(pieces) == 2) + package <- pieces[[1]] + generic <- pieces[[2]] + + caller <- parent.frame() + + get_method_env <- function() { + top <- topenv(caller) + if (isNamespace(top)) { + asNamespace(environmentName(top)) + } else { + caller + } + } + get_method <- function(method, env) { + if (is.null(method)) { + get(paste0(generic, ".", class), envir = get_method_env()) + } else { + method + } + } + + register <- function(...) { + envir <- asNamespace(package) + + # Refresh the method each time, it might have been updated by + # `devtools::load_all()` + method_fn <- get_method(method) + stopifnot(is.function(method_fn)) + + + # Only register if generic can be accessed + if (exists(generic, envir)) { + registerS3method(generic, class, method_fn, envir = envir) + } else if (identical(Sys.getenv("NOT_CRAN"), "true")) { + warning(sprintf( + "Can't find generic `%s` in package %s to register S3 method.", + generic, + package + )) + } + } + + # Always register hook in case package is later unloaded & reloaded + setHook(packageEvent(package, "onLoad"), register) + + # Avoid registration failures during loading (pkgload or regular) + if (isNamespaceLoaded(package)) { + register() + } + + invisible() +} + +# startup messages for brms +.onAttach <- function(libname, pkgname) { + version <- utils::packageVersion("brms") + packageStartupMessage( + "Loading 'brms' package (version ", version, "). Useful instructions\n", + "can be found by typing help('brms'). A more detailed introduction\n", + "to the package is available through vignette('brms_overview')." + ) + invisible(NULL) +} + +# code to execute when loading brms +.onLoad <- function(libname, pkgname) { + # ensure compatibility with older R versions + backports::import(pkgname) + # dynamically register the 'recover_data' and 'emm_basis' + # methods needed by 'emmeans', if that package is installed + if (requireNamespace("emmeans", quietly = TRUE) && + utils::packageVersion("emmeans") >= "1.4.0") { + emmeans::.emm_register("brmsfit", pkgname) + } + # dynamically register the 'get_refmodel.brmsfit' method for the + # 'get_refmodel' generic from 'projpred', if that package is installed + if (requireNamespace("projpred", quietly = TRUE)) { + s3_register_cp("projpred::get_refmodel", "brmsfit") + } + invisible(NULL) +} diff -Nru r-cran-brms-2.16.3/R/model_weights.R r-cran-brms-2.17.0/R/model_weights.R --- r-cran-brms-2.16.3/R/model_weights.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/model_weights.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,345 +1,345 @@ -#' Model Weighting Methods -#' -#' Compute model weights in various ways, for instance, via -#' stacking of posterior predictive distributions, Akaike weights, -#' or marginal likelihoods. -#' -#' @inheritParams loo.brmsfit -#' @param weights Name of the criterion to compute weights from. Should be one -#' of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current -#' default), or \code{"bma"}, \code{"pseudobma"}, For the former three -#' options, Akaike weights will be computed based on the information criterion -#' values returned by the respective methods. For \code{"stacking"} and -#' \code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to -#' obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be -#' used to compute Bayesian model averaging weights based on log marginal -#' likelihood values (make sure to specify reasonable priors in this case). -#' For some methods, \code{weights} may also be a numeric vector of -#' pre-specified weights. -#' -#' @return A numeric vector of weights for the models. -#' -#' @examples -#' \dontrun{ -#' # model with 'treat' as predictor -#' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) -#' summary(fit1) -#' -#' # model without 'treat' as predictor -#' fit2 <- brm(rating ~ period + carry, data = inhaler) -#' summary(fit2) -#' -#' # obtain Akaike weights based on the WAIC -#' model_weights(fit1, fit2, weights = "waic") -#' } -#' -#' @export -model_weights.brmsfit <- function(x, ..., weights = "stacking", - model_names = NULL) { - weights <- validate_weights_method(weights) - args <- split_dots(x, ..., model_names = model_names) - models <- args$models - args$models <- NULL - model_names <- names(models) - if (weights %in% c("loo", "waic", "kfold")) { - # Akaike weights based on information criteria - ics <- rep(NA, length(models)) - for (i in seq_along(ics)) { - args$x <- models[[i]] - args$model_names <- names(models)[i] - ics[i] <- SW(do_call(weights, args))$estimates[3, 1] - } - ic_diffs <- ics - min(ics) - out <- exp(-ic_diffs / 2) - } else if (weights %in% c("stacking", "pseudobma")) { - args <- c(unname(models), args) - args$method <- weights - out <- do_call("loo_model_weights", args) - } else if (weights %in% "bma") { - args <- c(unname(models), args) - out <- do_call("post_prob", args) - } - out <- as.numeric(out) - out <- out / sum(out) - names(out) <- model_names - out -} - -#' @rdname model_weights.brmsfit -#' @export -model_weights <- function(x, ...) { - UseMethod("model_weights") -} - -# validate name of the applied weighting method -validate_weights_method <- function(method) { - method <- as_one_character(method) - method <- tolower(method) - if (method == "loo2") { - warning2("Weight method 'loo2' is deprecated. Use 'stacking' instead.") - method <- "stacking" - } - if (method == "marglik") { - warning2("Weight method 'marglik' is deprecated. Use 'bma' instead.") - method <- "bma" - } - options <- c("loo", "waic", "kfold", "stacking", "pseudobma", "bma") - match.arg(method, options) -} - -#' Posterior predictive draws averaged across models -#' -#' Compute posterior predictive draws averaged across models. -#' Weighting can be done in various ways, for instance using -#' Akaike weights based on information criteria or -#' marginal likelihoods. -#' -#' @inheritParams model_weights.brmsfit -#' @param method Method used to obtain predictions to average over. Should be -#' one of \code{"posterior_predict"} (default), \code{"posterior_epred"}, -#' \code{"posterior_linpred"} or \code{"predictive_error"}. -#' @param control Optional \code{list} of further arguments -#' passed to the function specified in \code{weights}. -#' @param ndraws Total number of posterior draws to use. -#' @param nsamples Deprecated alias of \code{ndraws}. -#' @param seed A single numeric value passed to \code{\link{set.seed}} -#' to make results reproducible. -#' @param summary Should summary statistics -#' (i.e. means, sds, and 95\% intervals) be returned -#' instead of the raw values? Default is \code{TRUE}. -#' @param robust If \code{FALSE} (the default) the mean is used as -#' the measure of central tendency and the standard deviation as -#' the measure of variability. If \code{TRUE}, the median and the -#' median absolute deviation (MAD) are applied instead. -#' Only used if \code{summary} is \code{TRUE}. -#' @param probs The percentiles to be computed by the \code{quantile} -#' function. Only used if \code{summary} is \code{TRUE}. -#' -#' @return Same as the output of the method specified -#' in argument \code{method}. -#' -#' @details Weights are computed with the \code{\link{model_weights}} method. -#' -#' @seealso \code{\link{model_weights}}, \code{\link{posterior_average}} -#' -#' @examples -#' \dontrun{ -#' # model with 'treat' as predictor -#' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) -#' summary(fit1) -#' -#' # model without 'treat' as predictor -#' fit2 <- brm(rating ~ period + carry, data = inhaler) -#' summary(fit2) -#' -#' # compute model-averaged predicted values -#' (df <- unique(inhaler[, c("treat", "period", "carry")])) -#' pp_average(fit1, fit2, newdata = df) -#' -#' # compute model-averaged fitted values -#' pp_average(fit1, fit2, method = "fitted", newdata = df) -#' } -#' -#' @export -pp_average.brmsfit <- function( - x, ..., weights = "stacking", method = "posterior_predict", - ndraws = NULL, nsamples = NULL, summary = TRUE, probs = c(0.025, 0.975), - robust = FALSE, model_names = NULL, control = list(), seed = NULL -) { - if (!is.null(seed)) { - set.seed(seed) - } - method <- validate_pp_method(method) - ndraws <- use_alias(ndraws, nsamples) - if (any(c("draw_ids", "subset") %in% names(list(...)))) { - stop2("Cannot use argument 'draw_ids' in pp_average.") - } - args <- split_dots(x, ..., model_names = model_names) - args$summary <- FALSE - models <- args$models - args$models <- NULL - if (!match_response(models)) { - stop2("Can only average models predicting the same response.") - } - if (is.null(ndraws)) { - ndraws <- ndraws(models[[1]]) - } - ndraws <- as_one_integer(ndraws) - weights <- validate_weights(weights, models, control) - ndraws <- round_largest_remainder(weights * ndraws) - names(weights) <- names(ndraws) <- names(models) - out <- named_list(names(models)) - for (i in seq_along(out)) { - if (ndraws[i] > 0) { - args$object <- models[[i]] - args$ndraws <- ndraws[i] - out[[i]] <- do_call(method, args) - } - } - out <- do_call(rbind, out) - if (summary) { - out <- posterior_summary(out, probs = probs, robust = robust) - } - attr(out, "weights") <- weights - attr(out, "ndraws") <- ndraws - out -} - -#' @rdname pp_average.brmsfit -#' @export -pp_average <- function(x, ...) { - UseMethod("pp_average") -} - -# validate weights passed to model averaging functions -# see pp_average.brmsfit for more documentation -validate_weights <- function(weights, models, control = list()) { - if (!is.numeric(weights)) { - weight_args <- c(unname(models), control) - weight_args$weights <- weights - weights <- do_call(model_weights, weight_args) - } else { - if (length(weights) != length(models)) { - stop2("If numeric, 'weights' must have the same length ", - "as the number of models.") - } - if (any(weights < 0)) { - stop2("If numeric, 'weights' must be positive.") - } - } - weights / sum(weights) -} - -#' Posterior draws of parameters averaged across models -#' -#' Extract posterior draws of parameters averaged across models. -#' Weighting can be done in various ways, for instance using -#' Akaike weights based on information criteria or -#' marginal likelihoods. -#' -#' @inheritParams pp_average.brmsfit -#' @param variable Names of variables (parameters) for which to average across -#' models. Only those variables can be averaged that appear in every model. -#' Defaults to all overlapping variables. -#' @param pars Deprecated alias of \code{variable}. -#' @param missing An optional numeric value or a named list of numeric values -#' to use if a model does not contain a variable for which posterior draws -#' should be averaged. Defaults to \code{NULL}, in which case only those -#' variables can be averaged that are present in all of the models. -#' -#' @return A \code{data.frame} of posterior draws. -#' -#' @details Weights are computed with the \code{\link{model_weights}} method. -#' -#' @seealso \code{\link{model_weights}}, \code{\link{pp_average}} -#' -#' @examples -#' \dontrun{ -#' # model with 'treat' as predictor -#' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) -#' summary(fit1) -#' -#' # model without 'treat' as predictor -#' fit2 <- brm(rating ~ period + carry, data = inhaler) -#' summary(fit2) -#' -#' # compute model-averaged posteriors of overlapping parameters -#' posterior_average(fit1, fit2, weights = "waic") -#' } -#' -#' @export -posterior_average.brmsfit <- function( - x, ..., variable = NULL, pars = NULL, weights = "stacking", ndraws = NULL, - nsamples = NULL, missing = NULL, model_names = NULL, control = list(), - seed = NULL -) { - if (!is.null(seed)) { - set.seed(seed) - } - variable <- use_alias(variable, pars) - ndraws <- use_alias(ndraws, nsamples) - models <- split_dots(x, ..., model_names = model_names, other = FALSE) - vars_list <- lapply(models, variables) - all_vars <- unique(unlist(vars_list)) - if (is.null(missing)) { - common_vars <- lapply(vars_list, function(x) all_vars %in% x) - common_vars <- all_vars[Reduce("&", common_vars)] - if (is.null(variable)) { - variable <- setdiff(common_vars, "lp__") - } - variable <- as.character(variable) - inv_vars <- setdiff(variable, common_vars) - if (length(inv_vars)) { - inv_vars <- collapse_comma(inv_vars) - stop2( - "Parameters ", inv_vars, " cannot be found in all ", - "of the models. Consider using argument 'missing'." - ) - } - } else { - if (is.null(variable)) { - variable <- setdiff(all_vars, "lp__") - } - variable <- as.character(variable) - inv_vars <- setdiff(variable, all_vars) - if (length(inv_vars)) { - inv_vars <- collapse_comma(inv_vars) - stop2("Parameters ", inv_vars, " cannot be found in any of the models.") - } - if (is.list(missing)) { - all_miss_vars <- unique(ulapply( - models, function(m) setdiff(variable, variables(m)) - )) - inv_vars <- setdiff(all_miss_vars, names(missing)) - if (length(inv_vars)) { - stop2("Argument 'missing' has no value for parameters ", - collapse_comma(inv_vars), ".") - } - missing <- lapply(missing, as_one_numeric, allow_na = TRUE) - } else { - missing <- as_one_numeric(missing, allow_na = TRUE) - missing <- named_list(variable, missing) - } - } - if (is.null(ndraws)) { - ndraws <- ndraws(models[[1]]) - } - ndraws <- as_one_integer(ndraws) - weights <- validate_weights(weights, models, control) - ndraws <- round_largest_remainder(weights * ndraws) - names(weights) <- names(ndraws) <- names(models) - out <- named_list(names(models)) - for (i in seq_along(out)) { - if (ndraws[i] > 0) { - draw <- sample(seq_len(ndraws(models[[i]])), ndraws[i]) - draw <- sort(draw) - found_vars <- intersect(variable, variables(models[[i]])) - if (length(found_vars)) { - out[[i]] <- as.data.frame( - models[[i]], variable = found_vars, draw = draw - ) - } else { - out[[i]] <- as.data.frame(matrix( - numeric(0), nrow = ndraws[i], ncol = 0 - )) - } - if (!is.null(missing)) { - miss_vars <- setdiff(variable, names(out[[i]])) - if (length(miss_vars)) { - out[[i]][miss_vars] <- missing[miss_vars] - } - } - } - } - out <- do_call(rbind, out) - rownames(out) <- NULL - attr(out, "weights") <- weights - attr(out, "ndraws") <- ndraws - out -} - -#' @rdname posterior_average.brmsfit -#' @export -posterior_average <- function(x, ...) { - UseMethod("posterior_average") -} +#' Model Weighting Methods +#' +#' Compute model weights in various ways, for instance, via +#' stacking of posterior predictive distributions, Akaike weights, +#' or marginal likelihoods. +#' +#' @inheritParams loo.brmsfit +#' @param weights Name of the criterion to compute weights from. Should be one +#' of \code{"loo"}, \code{"waic"}, \code{"kfold"}, \code{"stacking"} (current +#' default), or \code{"bma"}, \code{"pseudobma"}, For the former three +#' options, Akaike weights will be computed based on the information criterion +#' values returned by the respective methods. For \code{"stacking"} and +#' \code{"pseudobma"}, method \code{\link{loo_model_weights}} will be used to +#' obtain weights. For \code{"bma"}, method \code{\link{post_prob}} will be +#' used to compute Bayesian model averaging weights based on log marginal +#' likelihood values (make sure to specify reasonable priors in this case). +#' For some methods, \code{weights} may also be a numeric vector of +#' pre-specified weights. +#' +#' @return A numeric vector of weights for the models. +#' +#' @examples +#' \dontrun{ +#' # model with 'treat' as predictor +#' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) +#' summary(fit1) +#' +#' # model without 'treat' as predictor +#' fit2 <- brm(rating ~ period + carry, data = inhaler) +#' summary(fit2) +#' +#' # obtain Akaike weights based on the WAIC +#' model_weights(fit1, fit2, weights = "waic") +#' } +#' +#' @export +model_weights.brmsfit <- function(x, ..., weights = "stacking", + model_names = NULL) { + weights <- validate_weights_method(weights) + args <- split_dots(x, ..., model_names = model_names) + models <- args$models + args$models <- NULL + model_names <- names(models) + if (weights %in% c("loo", "waic", "kfold")) { + # Akaike weights based on information criteria + ics <- rep(NA, length(models)) + for (i in seq_along(ics)) { + args$x <- models[[i]] + args$model_names <- names(models)[i] + ics[i] <- SW(do_call(weights, args))$estimates[3, 1] + } + ic_diffs <- ics - min(ics) + out <- exp(-ic_diffs / 2) + } else if (weights %in% c("stacking", "pseudobma")) { + args <- c(unname(models), args) + args$method <- weights + out <- do_call("loo_model_weights", args) + } else if (weights %in% "bma") { + args <- c(unname(models), args) + out <- do_call("post_prob", args) + } + out <- as.numeric(out) + out <- out / sum(out) + names(out) <- model_names + out +} + +#' @rdname model_weights.brmsfit +#' @export +model_weights <- function(x, ...) { + UseMethod("model_weights") +} + +# validate name of the applied weighting method +validate_weights_method <- function(method) { + method <- as_one_character(method) + method <- tolower(method) + if (method == "loo2") { + warning2("Weight method 'loo2' is deprecated. Use 'stacking' instead.") + method <- "stacking" + } + if (method == "marglik") { + warning2("Weight method 'marglik' is deprecated. Use 'bma' instead.") + method <- "bma" + } + options <- c("loo", "waic", "kfold", "stacking", "pseudobma", "bma") + match.arg(method, options) +} + +#' Posterior predictive draws averaged across models +#' +#' Compute posterior predictive draws averaged across models. +#' Weighting can be done in various ways, for instance using +#' Akaike weights based on information criteria or +#' marginal likelihoods. +#' +#' @inheritParams model_weights.brmsfit +#' @param method Method used to obtain predictions to average over. Should be +#' one of \code{"posterior_predict"} (default), \code{"posterior_epred"}, +#' \code{"posterior_linpred"} or \code{"predictive_error"}. +#' @param control Optional \code{list} of further arguments +#' passed to the function specified in \code{weights}. +#' @param ndraws Total number of posterior draws to use. +#' @param nsamples Deprecated alias of \code{ndraws}. +#' @param seed A single numeric value passed to \code{\link{set.seed}} +#' to make results reproducible. +#' @param summary Should summary statistics +#' (i.e. means, sds, and 95\% intervals) be returned +#' instead of the raw values? Default is \code{TRUE}. +#' @param robust If \code{FALSE} (the default) the mean is used as +#' the measure of central tendency and the standard deviation as +#' the measure of variability. If \code{TRUE}, the median and the +#' median absolute deviation (MAD) are applied instead. +#' Only used if \code{summary} is \code{TRUE}. +#' @param probs The percentiles to be computed by the \code{quantile} +#' function. Only used if \code{summary} is \code{TRUE}. +#' +#' @return Same as the output of the method specified +#' in argument \code{method}. +#' +#' @details Weights are computed with the \code{\link{model_weights}} method. +#' +#' @seealso \code{\link{model_weights}}, \code{\link{posterior_average}} +#' +#' @examples +#' \dontrun{ +#' # model with 'treat' as predictor +#' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) +#' summary(fit1) +#' +#' # model without 'treat' as predictor +#' fit2 <- brm(rating ~ period + carry, data = inhaler) +#' summary(fit2) +#' +#' # compute model-averaged predicted values +#' (df <- unique(inhaler[, c("treat", "period", "carry")])) +#' pp_average(fit1, fit2, newdata = df) +#' +#' # compute model-averaged fitted values +#' pp_average(fit1, fit2, method = "fitted", newdata = df) +#' } +#' +#' @export +pp_average.brmsfit <- function( + x, ..., weights = "stacking", method = "posterior_predict", + ndraws = NULL, nsamples = NULL, summary = TRUE, probs = c(0.025, 0.975), + robust = FALSE, model_names = NULL, control = list(), seed = NULL +) { + if (!is.null(seed)) { + set.seed(seed) + } + method <- validate_pp_method(method) + ndraws <- use_alias(ndraws, nsamples) + if (any(c("draw_ids", "subset") %in% names(list(...)))) { + stop2("Cannot use argument 'draw_ids' in pp_average.") + } + args <- split_dots(x, ..., model_names = model_names) + args$summary <- FALSE + models <- args$models + args$models <- NULL + if (!match_response(models)) { + stop2("Can only average models predicting the same response.") + } + if (is.null(ndraws)) { + ndraws <- ndraws(models[[1]]) + } + ndraws <- as_one_integer(ndraws) + weights <- validate_weights(weights, models, control) + ndraws <- round_largest_remainder(weights * ndraws) + names(weights) <- names(ndraws) <- names(models) + out <- named_list(names(models)) + for (i in seq_along(out)) { + if (ndraws[i] > 0) { + args$object <- models[[i]] + args$ndraws <- ndraws[i] + out[[i]] <- do_call(method, args) + } + } + out <- do_call(rbind, out) + if (summary) { + out <- posterior_summary(out, probs = probs, robust = robust) + } + attr(out, "weights") <- weights + attr(out, "ndraws") <- ndraws + out +} + +#' @rdname pp_average.brmsfit +#' @export +pp_average <- function(x, ...) { + UseMethod("pp_average") +} + +# validate weights passed to model averaging functions +# see pp_average.brmsfit for more documentation +validate_weights <- function(weights, models, control = list()) { + if (!is.numeric(weights)) { + weight_args <- c(unname(models), control) + weight_args$weights <- weights + weights <- do_call(model_weights, weight_args) + } else { + if (length(weights) != length(models)) { + stop2("If numeric, 'weights' must have the same length ", + "as the number of models.") + } + if (any(weights < 0)) { + stop2("If numeric, 'weights' must be positive.") + } + } + weights / sum(weights) +} + +#' Posterior draws of parameters averaged across models +#' +#' Extract posterior draws of parameters averaged across models. +#' Weighting can be done in various ways, for instance using +#' Akaike weights based on information criteria or +#' marginal likelihoods. +#' +#' @inheritParams pp_average.brmsfit +#' @param variable Names of variables (parameters) for which to average across +#' models. Only those variables can be averaged that appear in every model. +#' Defaults to all overlapping variables. +#' @param pars Deprecated alias of \code{variable}. +#' @param missing An optional numeric value or a named list of numeric values +#' to use if a model does not contain a variable for which posterior draws +#' should be averaged. Defaults to \code{NULL}, in which case only those +#' variables can be averaged that are present in all of the models. +#' +#' @return A \code{data.frame} of posterior draws. +#' +#' @details Weights are computed with the \code{\link{model_weights}} method. +#' +#' @seealso \code{\link{model_weights}}, \code{\link{pp_average}} +#' +#' @examples +#' \dontrun{ +#' # model with 'treat' as predictor +#' fit1 <- brm(rating ~ treat + period + carry, data = inhaler) +#' summary(fit1) +#' +#' # model without 'treat' as predictor +#' fit2 <- brm(rating ~ period + carry, data = inhaler) +#' summary(fit2) +#' +#' # compute model-averaged posteriors of overlapping parameters +#' posterior_average(fit1, fit2, weights = "waic") +#' } +#' +#' @export +posterior_average.brmsfit <- function( + x, ..., variable = NULL, pars = NULL, weights = "stacking", ndraws = NULL, + nsamples = NULL, missing = NULL, model_names = NULL, control = list(), + seed = NULL +) { + if (!is.null(seed)) { + set.seed(seed) + } + variable <- use_alias(variable, pars) + ndraws <- use_alias(ndraws, nsamples) + models <- split_dots(x, ..., model_names = model_names, other = FALSE) + vars_list <- lapply(models, variables) + all_vars <- unique(unlist(vars_list)) + if (is.null(missing)) { + common_vars <- lapply(vars_list, function(x) all_vars %in% x) + common_vars <- all_vars[Reduce("&", common_vars)] + if (is.null(variable)) { + variable <- setdiff(common_vars, "lp__") + } + variable <- as.character(variable) + inv_vars <- setdiff(variable, common_vars) + if (length(inv_vars)) { + inv_vars <- collapse_comma(inv_vars) + stop2( + "Parameters ", inv_vars, " cannot be found in all ", + "of the models. Consider using argument 'missing'." + ) + } + } else { + if (is.null(variable)) { + variable <- setdiff(all_vars, "lp__") + } + variable <- as.character(variable) + inv_vars <- setdiff(variable, all_vars) + if (length(inv_vars)) { + inv_vars <- collapse_comma(inv_vars) + stop2("Parameters ", inv_vars, " cannot be found in any of the models.") + } + if (is.list(missing)) { + all_miss_vars <- unique(ulapply( + models, function(m) setdiff(variable, variables(m)) + )) + inv_vars <- setdiff(all_miss_vars, names(missing)) + if (length(inv_vars)) { + stop2("Argument 'missing' has no value for parameters ", + collapse_comma(inv_vars), ".") + } + missing <- lapply(missing, as_one_numeric, allow_na = TRUE) + } else { + missing <- as_one_numeric(missing, allow_na = TRUE) + missing <- named_list(variable, missing) + } + } + if (is.null(ndraws)) { + ndraws <- ndraws(models[[1]]) + } + ndraws <- as_one_integer(ndraws) + weights <- validate_weights(weights, models, control) + ndraws <- round_largest_remainder(weights * ndraws) + names(weights) <- names(ndraws) <- names(models) + out <- named_list(names(models)) + for (i in seq_along(out)) { + if (ndraws[i] > 0) { + draw <- sample(seq_len(ndraws(models[[i]])), ndraws[i]) + draw <- sort(draw) + found_vars <- intersect(variable, variables(models[[i]])) + if (length(found_vars)) { + out[[i]] <- as.data.frame( + models[[i]], variable = found_vars, draw = draw + ) + } else { + out[[i]] <- as.data.frame(matrix( + numeric(0), nrow = ndraws[i], ncol = 0 + )) + } + if (!is.null(missing)) { + miss_vars <- setdiff(variable, names(out[[i]])) + if (length(miss_vars)) { + out[[i]][miss_vars] <- missing[miss_vars] + } + } + } + } + out <- do_call(rbind, out) + rownames(out) <- NULL + attr(out, "weights") <- weights + attr(out, "ndraws") <- ndraws + out +} + +#' @rdname posterior_average.brmsfit +#' @export +posterior_average <- function(x, ...) { + UseMethod("posterior_average") +} diff -Nru r-cran-brms-2.16.3/R/numeric-helpers.R r-cran-brms-2.17.0/R/numeric-helpers.R --- r-cran-brms-2.16.3/R/numeric-helpers.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/numeric-helpers.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,203 +1,226 @@ -# Most of the functions below have equivalents in Stan. Defining them in R is -# necessary to evaluate non-linear formulas containing these functions. - -logit <- function(p) { - log(p / (1 - p)) -} - -inv_logit <- function(x) { - 1 / (1 + exp(-x)) -} - -cloglog <- function(x) { - log(-log(1 - x)) -} - -inv_cloglog <- function(x) { - 1 - exp(-exp(x)) -} - -Phi <- function(x) { - pnorm(x) -} - -# incomplete gamma funcion -incgamma <- function(a, x) { - pgamma(x, shape = a) * gamma(a) -} - -square <- function(x) { - x^2 -} - -cbrt <- function(x) { - x^(1/3) -} - -exp2 <- function(x) { - 2^x -} - -pow <- function(x, y) { - x^y -} - -inv <- function(x) { - 1/x -} - -inv_sqrt <- function(x) { - 1/sqrt(x) -} - -inv_square <- function(x) { - 1/x^2 -} - -hypot <- function(x, y) { - stopifnot(all(x >= 0)) - stopifnot(all(y >= 0)) - sqrt(x^2 + y^2) -} - -log1m <- function(x) { - log(1 - x) -} - -step <- function(x) { - ifelse(x > 0, 1, 0) -} - -#' Logarithm with a minus one offset. -#' -#' Computes \code{log(x - 1)}. -#' -#' @param x A numeric or complex vector. -#' @param base A positive or complex number: the base with respect to which -#' logarithms are computed. Defaults to \emph{e} = \code{exp(1)}. -#' -#' @export -logm1 <- function(x, base = exp(1)) { - log(x - 1, base = base) -} - -#' Exponential function plus one. -#' -#' Computes \code{exp(x) + 1}. -#' -#' @param x A numeric or complex vector. -#' -#' @export -expp1 <- function(x) { - exp(x) + 1 -} - -#' Scaled logit-link -#' -#' Computes \code{logit((x - lb) / (ub - lb))} -#' -#' @param x A numeric or complex vector. -#' @param lb Lower bound defaulting to \code{0}. -#' @param ub Upper bound defaulting to \code{1}. -#' -#' @return A numeric or complex vector. -#' -#' @export -logit_scaled <- function(x, lb = 0, ub = 1) { - logit((x - lb) / (ub - lb)) -} - -#' Scaled inverse logit-link -#' -#' Computes \code{inv_logit(x) * (ub - lb) + lb} -#' -#' @param x A numeric or complex vector. -#' @param lb Lower bound defaulting to \code{0}. -#' @param ub Upper bound defaulting to \code{1}. -#' -#' @return A numeric or complex vector between \code{lb} and \code{ub}. -#' -#' @export -inv_logit_scaled <- function(x, lb = 0, ub = 1) { - inv_logit(x) * (ub - lb) + lb -} - -multiply_log <- function(x, y) { - ifelse(x == y & x == 0, 0, x * log(y)) -} - -log1p_exp <- function(x) { - log(1 + exp(x)) -} - -log1m_exp <- function(x) { - ifelse(x < 0, log(1 - exp(x)), NaN) -} - -log_diff_exp <- function(x, y) { - stopifnot(length(x) == length(y)) - ifelse(x > y, log(exp(x) - exp(y)), NaN) -} - -log_sum_exp <- function(x, y) { - max <- pmax(x, y) - max + log(exp(x - max) + exp(y - max)) -} - -log_mean_exp <- function(x) { - max_x <- max(x) - max_x + log(sum(exp(x - max_x))) - log(length(x)) -} - -expm1 <- function(x) { - exp(x) - 1 -} - -log_expm1 <- function(x) { - log(expm1(x)) -} - -log_inv_logit <- function(x) { - log(inv_logit(x)) -} - -log1m_inv_logit <- function(x) { - log(1 - inv_logit(x)) -} - -scale_unit <- function(x, lb = min(x), ub = max(x)) { - (x - lb) / (ub - lb) -} - -fabs <- function(x) { - abs(x) -} - -softmax <- function(x) { - ndim <- length(dim(x)) - if (ndim <= 1) { - x <- matrix(x, nrow = 1) - ndim <- length(dim(x)) - } - x <- exp(x) - dim_noncat <- dim(x)[-ndim] - marg_noncat <- seq_along(dim(x))[-ndim] - catsum <- array(apply(x, marg_noncat, sum), dim = dim_noncat) - sweep(x, marg_noncat, catsum, "/") -} - -log_softmax <- function(x) { - ndim <- length(dim(x)) - if (ndim <= 1) { - x <- matrix(x, nrow = 1) - ndim <- length(dim(x)) - } - dim_noncat <- dim(x)[-ndim] - marg_noncat <- seq_along(dim(x))[-ndim] - catsum <- log(array(apply(exp(x), marg_noncat, sum), dim = dim_noncat)) - sweep(x, marg_noncat, catsum, "-") -} - -inv_odds <- function(x) { - x / (1 + x) -} +# Most of the functions below have equivalents in Stan. Defining them in R is +# necessary to evaluate non-linear formulas containing these functions. + +logit <- function(p) { + log(p) - log1p(-p) +} + +inv_logit <- function(x) { + 1 / (1 + exp(-x)) +} + +cloglog <- function(x) { + log(-log1p(-x)) +} + +inv_cloglog <- function(x) { + 1 - exp(-exp(x)) +} + +Phi <- function(x) { + pnorm(x) +} + +# incomplete gamma funcion +incgamma <- function(a, x) { + pgamma(x, shape = a) * gamma(a) +} + +square <- function(x) { + x^2 +} + +cbrt <- function(x) { + x^(1/3) +} + +exp2 <- function(x) { + 2^x +} + +pow <- function(x, y) { + x^y +} + +inv <- function(x) { + 1/x +} + +inv_sqrt <- function(x) { + 1/sqrt(x) +} + +inv_square <- function(x) { + 1/x^2 +} + +hypot <- function(x, y) { + stopifnot(all(x >= 0)) + stopifnot(all(y >= 0)) + sqrt(x^2 + y^2) +} + +log1m <- function(x) { + log(1 - x) +} + +step <- function(x) { + ifelse(x > 0, 1, 0) +} + +#' Logarithm with a minus one offset. +#' +#' Computes \code{log(x - 1)}. +#' +#' @param x A numeric or complex vector. +#' @param base A positive or complex number: the base with respect to which +#' logarithms are computed. Defaults to \emph{e} = \code{exp(1)}. +#' +#' @export +logm1 <- function(x, base = exp(1)) { + log(x - 1, base = base) +} + +#' Exponential function plus one. +#' +#' Computes \code{exp(x) + 1}. +#' +#' @param x A numeric or complex vector. +#' +#' @export +expp1 <- function(x) { + exp(x) + 1 +} + +#' Scaled logit-link +#' +#' Computes \code{logit((x - lb) / (ub - lb))} +#' +#' @param x A numeric or complex vector. +#' @param lb Lower bound defaulting to \code{0}. +#' @param ub Upper bound defaulting to \code{1}. +#' +#' @return A numeric or complex vector. +#' +#' @export +logit_scaled <- function(x, lb = 0, ub = 1) { + logit((x - lb) / (ub - lb)) +} + +#' Scaled inverse logit-link +#' +#' Computes \code{inv_logit(x) * (ub - lb) + lb} +#' +#' @param x A numeric or complex vector. +#' @param lb Lower bound defaulting to \code{0}. +#' @param ub Upper bound defaulting to \code{1}. +#' +#' @return A numeric or complex vector between \code{lb} and \code{ub}. +#' +#' @export +inv_logit_scaled <- function(x, lb = 0, ub = 1) { + inv_logit(x) * (ub - lb) + lb +} + +multiply_log <- function(x, y) { + ifelse(x == y & x == 0, 0, x * log(y)) +} + +log1p_exp <- function(x) { + # approaches identity(x) for x -> Inf + out <- log1p(exp(x)) + ifelse(out < Inf, out, x) +} + +log1m_exp <- function(x) { + ifelse(x < 0, log1p(-exp(x)), NaN) +} + +log_diff_exp <- function(x, y) { + stopifnot(length(x) == length(y)) + ifelse(x > y, log(exp(x) - exp(y)), NaN) +} + +log_sum_exp <- function(x, y) { + max <- pmax(x, y) + max + log(exp(x - max) + exp(y - max)) +} + +log_mean_exp <- function(x) { + max_x <- max(x) + max_x + log(sum(exp(x - max_x))) - log(length(x)) +} + +log_expm1 <- function(x) { + # approaches identity(x) for x -> Inf + out <- log(expm1(x)) + ifelse(out < Inf, out, x) +} + +log_inv_logit <- function(x) { + log(inv_logit(x)) +} + +log1m_inv_logit <- function(x) { + log(1 - inv_logit(x)) +} + +scale_unit <- function(x, lb = min(x), ub = max(x)) { + (x - lb) / (ub - lb) +} + +fabs <- function(x) { + abs(x) +} + +softmax <- function(x) { + ndim <- length(dim(x)) + if (ndim <= 1) { + x <- matrix(x, nrow = 1) + ndim <- length(dim(x)) + } + x <- exp(x) + dim_noncat <- dim(x)[-ndim] + marg_noncat <- seq_along(dim(x))[-ndim] + catsum <- array(apply(x, marg_noncat, sum), dim = dim_noncat) + sweep(x, marg_noncat, catsum, "/") +} + +log_softmax <- function(x) { + ndim <- length(dim(x)) + if (ndim <= 1) { + x <- matrix(x, nrow = 1) + ndim <- length(dim(x)) + } + dim_noncat <- dim(x)[-ndim] + marg_noncat <- seq_along(dim(x))[-ndim] + catsum <- log(array(apply(exp(x), marg_noncat, sum), dim = dim_noncat)) + sweep(x, marg_noncat, catsum, "-") +} + +inv_odds <- function(x) { + x / (1 + x) +} + +# inspired by logit but with softplus instead of log +softit <- function(x) { + log_expm1(x / (1 - x)) +} + +# inspired by inv_logit but with softplus instead of exp +inv_softit <- function(x) { + y <- log1p_exp(x) + y / (1 + y) +} + +# inspired by inv_logit but with softplus instead of exp +log_inv_softit <- function(x) { + y <- log1p_exp(x) + log(y) - log1p(y) +} + +# inspired by inv_logit but with softplus instead of exp +log1m_inv_softit <- function(x) { + y <- log1p_exp(x) + -log1p(y) +} diff -Nru r-cran-brms-2.16.3/R/plot.R r-cran-brms-2.17.0/R/plot.R --- r-cran-brms-2.16.3/R/plot.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/plot.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,284 +1,284 @@ -#' Trace and Density Plots for MCMC Draws -#' -#' @param x An object of class \code{brmsfit}. -#' @param pars Deprecated alias of \code{variable}. -#' Names of the parameters to plot, as given by a -#' character vector or a regular expression. -#' @param variable Names of the variables (parameters) to plot, as given by a -#' character vector or a regular expression (if \code{regex = TRUE}). By -#' default, a hopefully not too large selection of variables is plotted. -#' @param combo A character vector with at least two elements. -#' Each element of \code{combo} corresponds to a column in the resulting -#' graphic and should be the name of one of the available -#' \code{\link[bayesplot:MCMC-overview]{MCMC}} functions -#' (omitting the \code{mcmc_} prefix). -#' @param N The number of parameters plotted per page. -#' @param theme A \code{\link[ggplot2:theme]{theme}} object -#' modifying the appearance of the plots. -#' For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} -#' and \code{\link[bayesplot:theme_default]{theme_default}}. -#' @param regex Logical; Indicates whether \code{variable} should -#' be treated as regular expressions. Defaults to \code{FALSE}. -#' @param fixed (Deprecated) Indicates whether parameter names -#' should be matched exactly (\code{TRUE}) or treated as -#' regular expressions (\code{FALSE}). Default is \code{FALSE} -#' and only works with argument \code{pars}. -#' @param plot Logical; indicates if plots should be -#' plotted directly in the active graphic device. -#' Defaults to \code{TRUE}. -#' @param ask Logical; indicates if the user is prompted -#' before a new page is plotted. -#' Only used if \code{plot} is \code{TRUE}. -#' @param newpage Logical; indicates if the first set of plots -#' should be plotted to a new page. -#' Only used if \code{plot} is \code{TRUE}. -#' @param ... Further arguments passed to -#' \code{\link[bayesplot:MCMC-combos]{mcmc_combo}}. -#' -#' @return An invisible list of -#' \code{\link[gtable:gtable]{gtable}} objects. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt -#' + (1|patient) + (1|visit), -#' data = epilepsy, family = "poisson") -#' plot(fit) -#' ## plot population-level effects only -#' plot(fit, variable = "^b_", regex = TRUE) -#' } -#' -#' @method plot brmsfit -#' @import ggplot2 -#' @importFrom graphics plot -#' @importFrom grDevices devAskNewPage -#' @export -plot.brmsfit <- function(x, pars = NA, combo = c("dens", "trace"), - N = 5, variable = NULL, regex = FALSE, fixed = FALSE, - theme = NULL, plot = TRUE, ask = TRUE, - newpage = TRUE, ...) { - contains_draws(x) - if (!is_wholenumber(N) || N < 1) { - stop2("Argument 'N' must be a positive integer.") - } - variable <- use_variable_alias(variable, x, pars, fixed = fixed) - if (is.null(variable)) { - variable <- default_plot_variables(x) - regex <- TRUE - } - draws <- as.array(x, variable = variable, regex = regex) - variables <- dimnames(draws)[[3]] - if (!length(variables)) { - stop2("No valid variables selected.") - } - - if (plot) { - default_ask <- devAskNewPage() - on.exit(devAskNewPage(default_ask)) - devAskNewPage(ask = FALSE) - } - n_plots <- ceiling(length(variables) / N) - plots <- vector(mode = "list", length = n_plots) - for (i in seq_len(n_plots)) { - sub_vars <- variables[((i - 1) * N + 1):min(i * N, length(variables))] - sub_draws <- draws[, , sub_vars, drop = FALSE] - plots[[i]] <- bayesplot::mcmc_combo( - sub_draws, combo = combo, gg_theme = theme, ... - ) - if (plot) { - plot(plots[[i]], newpage = newpage || i > 1) - if (i == 1) { - devAskNewPage(ask = ask) - } - } - } - invisible(plots) -} - -# list all parameter classes to be included in plots by default -default_plot_variables <- function(family) { - c(fixef_pars(), "^sd_", "^cor_", "^sigma_", "^rescor_", - paste0("^", valid_dpars(family), "$"), "^delta$", - "^theta", "^ar", "^ma", "^arr", "^sderr", "^lagsar", "^errorsar", - "^car", "^sdcar", "^sds_", "^sdgp_", "^lscale_") -} - -#' MCMC Plots Implemented in \pkg{bayesplot} -#' -#' Convenient way to call MCMC plotting functions -#' implemented in the \pkg{bayesplot} package. -#' -#' @aliases stanplot stanplot.brmsfit -#' -#' @inheritParams plot.brmsfit -#' @param object An \R object typically of class \code{brmsfit} -#' @param type The type of the plot. -#' Supported types are (as names) \code{hist}, \code{dens}, -#' \code{hist_by_chain}, \code{dens_overlay}, -#' \code{violin}, \code{intervals}, \code{areas}, \code{acf}, -#' \code{acf_bar},\code{trace}, \code{trace_highlight}, \code{scatter}, -#' \code{rhat}, \code{rhat_hist}, \code{neff}, \code{neff_hist} -#' \code{nuts_acceptance}, \code{nuts_divergence}, -#' \code{nuts_stepsize}, \code{nuts_treedepth}, and \code{nuts_energy}. -#' For an overview on the various plot types see -#' \code{\link[bayesplot:MCMC-overview]{MCMC-overview}}. -#' @param ... Additional arguments passed to the plotting functions. -#' See \code{\link[bayesplot:MCMC-overview]{MCMC-overview}} for -#' more details. -#' -#' @return A \code{\link[ggplot2:ggplot]{ggplot}} object -#' that can be further customized using the \pkg{ggplot2} package. -#' -#' @details -#' Also consider using the \pkg{shinystan} package available via -#' method \code{\link{launch_shinystan}} in \pkg{brms} for flexible -#' and interactive visual analysis. -#' -#' @examples -#' \dontrun{ -#' model <- brm(count ~ zAge + zBase * Trt + (1|patient), -#' data = epilepsy, family = "poisson") -#' -#' # plot posterior intervals -#' mcmc_plot(model) -#' -#' # only show population-level effects in the plots -#' mcmc_plot(model, variable = "^b_", regex = TRUE) -#' -#' # show histograms of the posterior distributions -#' mcmc_plot(model, type = "hist") -#' -#' # plot some diagnostics of the sampler -#' mcmc_plot(model, type = "neff") -#' mcmc_plot(model, type = "rhat") -#' -#' # plot some diagnostics specific to the NUTS sampler -#' mcmc_plot(model, type = "nuts_acceptance") -#' mcmc_plot(model, type = "nuts_divergence") -#' } -#' -#' @export -mcmc_plot.brmsfit <- function(object, pars = NA, type = "intervals", - variable = NULL, regex = FALSE, - fixed = FALSE, ...) { - contains_draws(object) - object <- restructure(object) - type <- as_one_character(type) - variable <- use_variable_alias(variable, object, pars, fixed = fixed) - if (is.null(variable)) { - variable <- default_plot_variables(object) - regex <- TRUE - } - valid_types <- as.character(bayesplot::available_mcmc("")) - valid_types <- sub("^mcmc_", "", valid_types) - if (!type %in% valid_types) { - stop2("Invalid plot type. Valid plot types are: \n", - collapse_comma(valid_types)) - } - mcmc_fun <- get(paste0("mcmc_", type), asNamespace("bayesplot")) - mcmc_arg_names <- names(formals(mcmc_fun)) - mcmc_args <- list(...) - if ("x" %in% mcmc_arg_names) { - if (grepl("^nuts_", type)) { - # x refers to a molten data.frame of NUTS parameters - mcmc_args$x <- nuts_params(object) - } else { - # x refers to a data.frame of draws - draws <- as.array(object, variable = variable, regex = regex) - if (!length(draws)) { - stop2("No valid parameters selected.") - } - sel_variables <- dimnames(draws)[[3]] - if (type %in% c("scatter", "hex") && length(sel_variables) != 2L) { - stop2("Exactly 2 parameters must be selected for this type.", - "\nParameters selected: ", collapse_comma(sel_variables)) - } - mcmc_args$x <- draws - } - } - if ("lp" %in% mcmc_arg_names) { - mcmc_args$lp <- log_posterior(object) - } - use_nuts <- isTRUE(object$algorithm == "sampling") - if ("np" %in% mcmc_arg_names && use_nuts) { - mcmc_args$np <- nuts_params(object) - } - interval_type <- type %in% c("intervals", "areas") - if ("rhat" %in% mcmc_arg_names && !interval_type) { - mcmc_args$rhat <- rhat(object) - } - if ("ratio" %in% mcmc_arg_names) { - mcmc_args$ratio <- neff_ratio(object) - } - do_call(mcmc_fun, mcmc_args) -} - -#' @rdname mcmc_plot.brmsfit -#' @export -mcmc_plot <- function(object, ...) { - UseMethod("mcmc_plot") -} - -# 'stanplot' has been deprecated in brms 2.10.6; remove in brms 3.0 -#' @export -stanplot <- function(object, ...) { - UseMethod("stanplot") -} - -#' @export -stanplot.brmsfit <- function(object, ...) { - warning2("Method 'stanplot' is deprecated. Please use 'mcmc_plot' instead.") - mcmc_plot.brmsfit(object, ...) -} - -#' Create a matrix of output plots from a \code{brmsfit} object -#' -#' A \code{\link[graphics:pairs]{pairs}} -#' method that is customized for MCMC output. -#' -#' @param x An object of class \code{brmsfit} -#' @inheritParams plot.brmsfit -#' @param ... Further arguments to be passed to -#' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. -#' -#' @details For a detailed description see -#' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt -#' + (1|patient) + (1|visit), -#' data = epilepsy, family = "poisson") -#' pairs(fit, variable = variables(fit)[1:3]) -#' pairs(fit, variable = "^sd_", regex = TRUE) -#' } -#' -#' @export -pairs.brmsfit <- function(x, pars = NA, variable = NULL, regex = FALSE, - fixed = FALSE, ...) { - variable <- use_variable_alias(variable, x, pars, fixed = fixed) - if (is.null(variable)) { - variable <- default_plot_variables(x) - regex <- TRUE - } - draws <- as.array(x, variable = variable, regex = regex) - bayesplot::mcmc_pairs(draws, ...) -} - -#' Default \pkg{bayesplot} Theme for \pkg{ggplot2} Graphics -#' -#' This theme is imported from the \pkg{bayesplot} package. -#' See \code{\link[bayesplot:theme_default]{theme_default}} -#' for a complete documentation. -#' -#' @name theme_default -#' -#' @param base_size base font size -#' @param base_family base font family -#' -#' @return A \code{theme} object used in \pkg{ggplot2} graphics. -#' -#' @importFrom bayesplot theme_default -#' @export theme_default -NULL - +#' Trace and Density Plots for MCMC Draws +#' +#' @param x An object of class \code{brmsfit}. +#' @param pars Deprecated alias of \code{variable}. +#' Names of the parameters to plot, as given by a +#' character vector or a regular expression. +#' @param variable Names of the variables (parameters) to plot, as given by a +#' character vector or a regular expression (if \code{regex = TRUE}). By +#' default, a hopefully not too large selection of variables is plotted. +#' @param combo A character vector with at least two elements. +#' Each element of \code{combo} corresponds to a column in the resulting +#' graphic and should be the name of one of the available +#' \code{\link[bayesplot:MCMC-overview]{MCMC}} functions +#' (omitting the \code{mcmc_} prefix). +#' @param N The number of parameters plotted per page. +#' @param theme A \code{\link[ggplot2:theme]{theme}} object +#' modifying the appearance of the plots. +#' For some basic themes see \code{\link[ggplot2:ggtheme]{ggtheme}} +#' and \code{\link[bayesplot:theme_default]{theme_default}}. +#' @param regex Logical; Indicates whether \code{variable} should +#' be treated as regular expressions. Defaults to \code{FALSE}. +#' @param fixed (Deprecated) Indicates whether parameter names +#' should be matched exactly (\code{TRUE}) or treated as +#' regular expressions (\code{FALSE}). Default is \code{FALSE} +#' and only works with argument \code{pars}. +#' @param plot Logical; indicates if plots should be +#' plotted directly in the active graphic device. +#' Defaults to \code{TRUE}. +#' @param ask Logical; indicates if the user is prompted +#' before a new page is plotted. +#' Only used if \code{plot} is \code{TRUE}. +#' @param newpage Logical; indicates if the first set of plots +#' should be plotted to a new page. +#' Only used if \code{plot} is \code{TRUE}. +#' @param ... Further arguments passed to +#' \code{\link[bayesplot:MCMC-combos]{mcmc_combo}}. +#' +#' @return An invisible list of +#' \code{\link[gtable:gtable]{gtable}} objects. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt +#' + (1|patient) + (1|visit), +#' data = epilepsy, family = "poisson") +#' plot(fit) +#' ## plot population-level effects only +#' plot(fit, variable = "^b_", regex = TRUE) +#' } +#' +#' @method plot brmsfit +#' @import ggplot2 +#' @importFrom graphics plot +#' @importFrom grDevices devAskNewPage +#' @export +plot.brmsfit <- function(x, pars = NA, combo = c("dens", "trace"), + N = 5, variable = NULL, regex = FALSE, fixed = FALSE, + theme = NULL, plot = TRUE, ask = TRUE, + newpage = TRUE, ...) { + contains_draws(x) + if (!is_wholenumber(N) || N < 1) { + stop2("Argument 'N' must be a positive integer.") + } + variable <- use_variable_alias(variable, x, pars, fixed = fixed) + if (is.null(variable)) { + variable <- default_plot_variables(x) + regex <- TRUE + } + draws <- as.array(x, variable = variable, regex = regex) + variables <- dimnames(draws)[[3]] + if (!length(variables)) { + stop2("No valid variables selected.") + } + + if (plot) { + default_ask <- devAskNewPage() + on.exit(devAskNewPage(default_ask)) + devAskNewPage(ask = FALSE) + } + n_plots <- ceiling(length(variables) / N) + plots <- vector(mode = "list", length = n_plots) + for (i in seq_len(n_plots)) { + sub_vars <- variables[((i - 1) * N + 1):min(i * N, length(variables))] + sub_draws <- draws[, , sub_vars, drop = FALSE] + plots[[i]] <- bayesplot::mcmc_combo( + sub_draws, combo = combo, gg_theme = theme, ... + ) + if (plot) { + plot(plots[[i]], newpage = newpage || i > 1) + if (i == 1) { + devAskNewPage(ask = ask) + } + } + } + invisible(plots) +} + +# list all parameter classes to be included in plots by default +default_plot_variables <- function(family) { + c(fixef_pars(), "^sd_", "^cor_", "^sigma_", "^rescor_", + paste0("^", valid_dpars(family), "$"), "^delta$", + "^theta", "^ar", "^ma", "^arr", "^sderr", "^lagsar", "^errorsar", + "^car", "^sdcar", "^sds_", "^sdgp_", "^lscale_") +} + +#' MCMC Plots Implemented in \pkg{bayesplot} +#' +#' Convenient way to call MCMC plotting functions +#' implemented in the \pkg{bayesplot} package. +#' +#' @aliases stanplot stanplot.brmsfit +#' +#' @inheritParams plot.brmsfit +#' @param object An \R object typically of class \code{brmsfit} +#' @param type The type of the plot. +#' Supported types are (as names) \code{hist}, \code{dens}, +#' \code{hist_by_chain}, \code{dens_overlay}, +#' \code{violin}, \code{intervals}, \code{areas}, \code{acf}, +#' \code{acf_bar},\code{trace}, \code{trace_highlight}, \code{scatter}, +#' \code{rhat}, \code{rhat_hist}, \code{neff}, \code{neff_hist} +#' \code{nuts_acceptance}, \code{nuts_divergence}, +#' \code{nuts_stepsize}, \code{nuts_treedepth}, and \code{nuts_energy}. +#' For an overview on the various plot types see +#' \code{\link[bayesplot:MCMC-overview]{MCMC-overview}}. +#' @param ... Additional arguments passed to the plotting functions. +#' See \code{\link[bayesplot:MCMC-overview]{MCMC-overview}} for +#' more details. +#' +#' @return A \code{\link[ggplot2:ggplot]{ggplot}} object +#' that can be further customized using the \pkg{ggplot2} package. +#' +#' @details +#' Also consider using the \pkg{shinystan} package available via +#' method \code{\link{launch_shinystan}} in \pkg{brms} for flexible +#' and interactive visual analysis. +#' +#' @examples +#' \dontrun{ +#' model <- brm(count ~ zAge + zBase * Trt + (1|patient), +#' data = epilepsy, family = "poisson") +#' +#' # plot posterior intervals +#' mcmc_plot(model) +#' +#' # only show population-level effects in the plots +#' mcmc_plot(model, variable = "^b_", regex = TRUE) +#' +#' # show histograms of the posterior distributions +#' mcmc_plot(model, type = "hist") +#' +#' # plot some diagnostics of the sampler +#' mcmc_plot(model, type = "neff") +#' mcmc_plot(model, type = "rhat") +#' +#' # plot some diagnostics specific to the NUTS sampler +#' mcmc_plot(model, type = "nuts_acceptance") +#' mcmc_plot(model, type = "nuts_divergence") +#' } +#' +#' @export +mcmc_plot.brmsfit <- function(object, pars = NA, type = "intervals", + variable = NULL, regex = FALSE, + fixed = FALSE, ...) { + contains_draws(object) + object <- restructure(object) + type <- as_one_character(type) + variable <- use_variable_alias(variable, object, pars, fixed = fixed) + if (is.null(variable)) { + variable <- default_plot_variables(object) + regex <- TRUE + } + valid_types <- as.character(bayesplot::available_mcmc("")) + valid_types <- sub("^mcmc_", "", valid_types) + if (!type %in% valid_types) { + stop2("Invalid plot type. Valid plot types are: \n", + collapse_comma(valid_types)) + } + mcmc_fun <- get(paste0("mcmc_", type), asNamespace("bayesplot")) + mcmc_arg_names <- names(formals(mcmc_fun)) + mcmc_args <- list(...) + if ("x" %in% mcmc_arg_names) { + if (grepl("^nuts_", type)) { + # x refers to a molten data.frame of NUTS parameters + mcmc_args$x <- nuts_params(object) + } else { + # x refers to a data.frame of draws + draws <- as.array(object, variable = variable, regex = regex) + if (!length(draws)) { + stop2("No valid parameters selected.") + } + sel_variables <- dimnames(draws)[[3]] + if (type %in% c("scatter", "hex") && length(sel_variables) != 2L) { + stop2("Exactly 2 parameters must be selected for this type.", + "\nParameters selected: ", collapse_comma(sel_variables)) + } + mcmc_args$x <- draws + } + } + if ("lp" %in% mcmc_arg_names) { + mcmc_args$lp <- log_posterior(object) + } + use_nuts <- isTRUE(object$algorithm == "sampling") + if ("np" %in% mcmc_arg_names && use_nuts) { + mcmc_args$np <- nuts_params(object) + } + interval_type <- type %in% c("intervals", "areas") + if ("rhat" %in% mcmc_arg_names && !interval_type) { + mcmc_args$rhat <- rhat(object) + } + if ("ratio" %in% mcmc_arg_names) { + mcmc_args$ratio <- neff_ratio(object) + } + do_call(mcmc_fun, mcmc_args) +} + +#' @rdname mcmc_plot.brmsfit +#' @export +mcmc_plot <- function(object, ...) { + UseMethod("mcmc_plot") +} + +# 'stanplot' has been deprecated in brms 2.10.6; remove in brms 3.0 +#' @export +stanplot <- function(object, ...) { + UseMethod("stanplot") +} + +#' @export +stanplot.brmsfit <- function(object, ...) { + warning2("Method 'stanplot' is deprecated. Please use 'mcmc_plot' instead.") + mcmc_plot.brmsfit(object, ...) +} + +#' Create a matrix of output plots from a \code{brmsfit} object +#' +#' A \code{\link[graphics:pairs]{pairs}} +#' method that is customized for MCMC output. +#' +#' @param x An object of class \code{brmsfit} +#' @inheritParams plot.brmsfit +#' @param ... Further arguments to be passed to +#' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. +#' +#' @details For a detailed description see +#' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt +#' + (1|patient) + (1|visit), +#' data = epilepsy, family = "poisson") +#' pairs(fit, variable = variables(fit)[1:3]) +#' pairs(fit, variable = "^sd_", regex = TRUE) +#' } +#' +#' @export +pairs.brmsfit <- function(x, pars = NA, variable = NULL, regex = FALSE, + fixed = FALSE, ...) { + variable <- use_variable_alias(variable, x, pars, fixed = fixed) + if (is.null(variable)) { + variable <- default_plot_variables(x) + regex <- TRUE + } + draws <- as.array(x, variable = variable, regex = regex) + bayesplot::mcmc_pairs(draws, ...) +} + +#' Default \pkg{bayesplot} Theme for \pkg{ggplot2} Graphics +#' +#' This theme is imported from the \pkg{bayesplot} package. +#' See \code{\link[bayesplot:theme_default]{theme_default}} +#' for a complete documentation. +#' +#' @name theme_default +#' +#' @param base_size base font size +#' @param base_family base font family +#' +#' @return A \code{theme} object used in \pkg{ggplot2} graphics. +#' +#' @importFrom bayesplot theme_default +#' @export theme_default +NULL + diff -Nru r-cran-brms-2.16.3/R/posterior_epred.R r-cran-brms-2.17.0/R/posterior_epred.R --- r-cran-brms-2.16.3/R/posterior_epred.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/posterior_epred.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,843 +1,858 @@ -#' Expected Values of the Posterior Predictive Distribution -#' -#' Compute posterior draws of the expected value/mean of the posterior -#' predictive distribution. Can be performed for the data used to fit the model -#' (posterior predictive checks) or for new data. By definition, these -#' predictions have smaller variance than the posterior predictions performed by -#' the \code{\link{posterior_predict.brmsfit}} method. This is because only the -#' uncertainty in the mean is incorporated in the draws computed by -#' \code{posterior_epred} while any residual error is ignored. However, the -#' estimated means of both methods averaged across draws should be very -#' similar. -#' -#' @aliases pp_expect -#' -#' @inheritParams posterior_predict.brmsfit -#' @param dpar Optional name of a predicted distributional parameter. -#' If specified, expected predictions of this parameters are returned. -#' @param nlpar Optional name of a predicted non-linear parameter. -#' If specified, expected predictions of this parameters are returned. -#' -#' @return An \code{array} of predicted \emph{mean} response values. For -#' categorical and ordinal models, the output is an S x N x C array. -#' Otherwise, the output is an S x N matrix, where S is the number of -#' posterior draws, N is the number of observations, and C is the number of -#' categories. In multivariate models, an additional dimension is added to the -#' output which indexes along the different response variables. -#' -#' @template details-newdata-na -#' @template details-allow_new_levels -#' -#' @examples -#' \dontrun{ -#' ## fit a model -#' fit <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler) -#' -#' ## compute expected predictions -#' ppe <- posterior_epred(fit) -#' str(ppe) -#' } -#' -#' @aliases posterior_epred -#' @method posterior_epred brmsfit -#' @importFrom rstantools posterior_epred -#' @export posterior_epred -#' @export -posterior_epred.brmsfit <- function(object, newdata = NULL, re_formula = NULL, - re.form = NULL, resp = NULL, dpar = NULL, - nlpar = NULL, ndraws = NULL, draw_ids = NULL, - sort = FALSE, ...) { - cl <- match.call() - if ("re.form" %in% names(cl)) { - re_formula <- re.form - } - contains_draws(object) - object <- restructure(object) - prep <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... - ) - posterior_epred( - prep, dpar = dpar, nlpar = nlpar, sort = sort, - scale = "response", summary = FALSE - ) -} - -#' @export -posterior_epred.mvbrmsprep <- function(object, ...) { - out <- lapply(object$resps, posterior_epred, ...) - along <- ifelse(length(out) > 1L, 3, 2) - do_call(abind, c(out, along = along)) -} - -#' @export -posterior_epred.brmsprep <- function(object, dpar, nlpar, sort, - scale = "response", incl_thres = NULL, - summary = FALSE, robust = FALSE, - probs = c(0.025, 0.975), ...) { - summary <- as_one_logical(summary) - dpars <- names(object$dpars) - nlpars <- names(object$nlpars) - if (length(dpar)) { - # predict a distributional parameter - dpar <- as_one_character(dpar) - if (!dpar %in% dpars) { - stop2("Invalid argument 'dpar'. Valid distributional ", - "parameters are: ", collapse_comma(dpars)) - } - if (length(nlpar)) { - stop2("Cannot use 'dpar' and 'nlpar' at the same time.") - } - predicted <- is.bprepl(object$dpars[[dpar]]) || - is.bprepnl(object$dpars[[dpar]]) - if (predicted) { - # parameter varies across observations - if (scale == "linear") { - object$dpars[[dpar]]$family$link <- "identity" - } - if (is_ordinal(object$family)) { - object$dpars[[dpar]]$cs <- NULL - object$family <- object$dpars[[dpar]]$family <- - .dpar_family(link = object$dpars[[dpar]]$family$link) - } - if (dpar_class(dpar) == "theta" && scale == "response") { - ap_id <- as.numeric(dpar_id(dpar)) - out <- get_theta(object)[, , ap_id, drop = FALSE] - dim(out) <- dim(out)[c(1, 2)] - } else { - out <- get_dpar(object, dpar = dpar, ilink = TRUE) - } - } else { - # parameter is constant across observations - out <- object$dpars[[dpar]] - out <- matrix(out, nrow = object$ndraws, ncol = object$nobs) - } - } else if (length(nlpar)) { - # predict a non-linear parameter - nlpar <- as_one_character(nlpar) - if (!nlpar %in% nlpars) { - stop2("Invalid argument 'nlpar'. Valid non-linear ", - "parameters are: ", collapse_comma(nlpars)) - } - out <- get_nlpar(object, nlpar = nlpar) - } else { - # no dpar or nlpar specified - incl_thres <- as_one_logical(incl_thres %||% FALSE) - incl_thres <- incl_thres && is_ordinal(object$family) && scale == "linear" - if (incl_thres) { - # extract linear predictor array with thresholds etc. included - if (is.mixfamily(object$family)) { - stop2("'incl_thres' is not supported for mixture models.") - } - object$family$link <- "identity" - } - if (scale == "response" || incl_thres) { - # predict the mean of the response distribution - for (nlp in nlpars) { - object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) - } - for (dp in dpars) { - object$dpars[[dp]] <- get_dpar(object, dpar = dp) - } - if (is_trunc(object)) { - out <- posterior_epred_trunc(object) - } else { - posterior_epred_fun <- paste0("posterior_epred_", object$family$family) - posterior_epred_fun <- get(posterior_epred_fun, asNamespace("brms")) - out <- posterior_epred_fun(object) - } - } else { - # return results on the linear scale - # extract all 'mu' parameters - if (conv_cats_dpars(object$family)) { - out <- dpars[grepl("^mu", dpars)] - } else { - out <- dpars[dpar_class(dpars) %in% "mu"] - } - if (length(out) == 1L) { - out <- get_dpar(object, dpar = out, ilink = FALSE) - } else { - # multiple mu parameters in categorical or mixture models - out <- lapply(out, get_dpar, prep = object, ilink = FALSE) - out <- abind::abind(out, along = 3) - } - } - } - if (is.null(dim(out))) { - out <- as.matrix(out) - } - colnames(out) <- NULL - out <- reorder_obs(out, object$old_order, sort = sort) - if (scale == "response" && is_polytomous(object$family) && - length(dim(out)) == 3L && dim(out)[3] == length(object$cats)) { - # for ordinal models with varying thresholds, dim[3] may not match cats - dimnames(out)[[3]] <- object$cats - } - if (summary) { - # only for compatibility with the 'fitted' method - out <- posterior_summary(out, probs = probs, robust = robust) - if (is_polytomous(object$family) && length(dim(out)) == 3L) { - if (scale == "linear") { - dimnames(out)[[3]] <- paste0("eta", seq_dim(out, 3)) - } else { - dimnames(out)[[3]] <- paste0("P(Y = ", dimnames(out)[[3]], ")") - } - } - } - out -} - -#' Expected Values of the Posterior Predictive Distribution -#' -#' This method is an alias of \code{\link{posterior_epred.brmsfit}} -#' with additional arguments for obtaining summaries of the computed draws. -#' -#' @inheritParams posterior_epred.brmsfit -#' @param object An object of class \code{brmsfit}. -#' @param scale Either \code{"response"} or \code{"linear"}. -#' If \code{"response"}, results are returned on the scale -#' of the response variable. If \code{"linear"}, -#' results are returned on the scale of the linear predictor term, -#' that is without applying the inverse link function or -#' other transformations. -#' @param summary Should summary statistics be returned -#' instead of the raw values? Default is \code{TRUE}.. -#' @param robust If \code{FALSE} (the default) the mean is used as -#' the measure of central tendency and the standard deviation as -#' the measure of variability. If \code{TRUE}, the median and the -#' median absolute deviation (MAD) are applied instead. -#' Only used if \code{summary} is \code{TRUE}. -#' @param probs The percentiles to be computed by the \code{quantile} -#' function. Only used if \code{summary} is \code{TRUE}. -#' -#' @return An \code{array} of predicted \emph{mean} response values. -#' If \code{summary = FALSE} the output resembles those of -#' \code{\link{posterior_epred.brmsfit}}. -#' -#' If \code{summary = TRUE} the output depends on the family: For categorical -#' and ordinal families, the output is an N x E x C array, where N is the -#' number of observations, E is the number of summary statistics, and C is the -#' number of categories. For all other families, the output is an N x E -#' matrix. The number of summary statistics E is equal to \code{2 + -#' length(probs)}: The \code{Estimate} column contains point estimates (either -#' mean or median depending on argument \code{robust}), while the -#' \code{Est.Error} column contains uncertainty estimates (either standard -#' deviation or median absolute deviation depending on argument -#' \code{robust}). The remaining columns starting with \code{Q} contain -#' quantile estimates as specified via argument \code{probs}. -#' -#' In multivariate models, an additional dimension is added to the output -#' which indexes along the different response variables. -#' -#' @seealso \code{\link{posterior_epred.brmsfit}} -#' -#' @examples -#' \dontrun{ -#' ## fit a model -#' fit <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler) -#' -#' ## compute expected predictions -#' fitted_values <- fitted(fit) -#' head(fitted_values) -#' -#' ## plot expected predictions against actual response -#' dat <- as.data.frame(cbind(Y = standata(fit)$Y, fitted_values)) -#' ggplot(dat) + geom_point(aes(x = Estimate, y = Y)) -#' } -#' -#' @export -fitted.brmsfit <- function(object, newdata = NULL, re_formula = NULL, - scale = c("response", "linear"), - resp = NULL, dpar = NULL, nlpar = NULL, - ndraws = NULL, draw_ids = NULL, sort = FALSE, - summary = TRUE, robust = FALSE, - probs = c(0.025, 0.975), ...) { - scale <- match.arg(scale) - summary <- as_one_logical(summary) - contains_draws(object) - object <- restructure(object) - prep <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... - ) - posterior_epred( - prep, dpar = dpar, nlpar = nlpar, sort = sort, scale = scale, - summary = summary, robust = robust, probs = probs - ) -} - -#' Posterior Draws of the Linear Predictor -#' -#' Compute posterior draws of the linear predictor, that is draws before -#' applying any link functions or other transformations. Can be performed for -#' the data used to fit the model (posterior predictive checks) or for new data. -#' -#' @inheritParams posterior_epred.brmsfit -#' @param object An object of class \code{brmsfit}. -#' @param transform Logical; if \code{FALSE} -#' (the default), draws of the linear predictor are returned. -#' If \code{TRUE}, draws of transformed linear predictor, -#' that is, after applying the link function are returned. -#' @param dpar Name of a predicted distributional parameter -#' for which draws are to be returned. By default, draws -#' of the main distributional parameter(s) \code{"mu"} are returned. -#' @param incl_thres Logical; only relevant for ordinal models when -#' \code{transform} is \code{FALSE}, and ignored otherwise. Shall the -#' thresholds and category-specific effects be included in the linear -#' predictor? For backwards compatibility, the default is to not include them. -#' -#' @seealso \code{\link{posterior_epred.brmsfit}} -#' -#' @examples -#' \dontrun{ -#' ## fit a model -#' fit <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler) -#' -#' ## extract linear predictor values -#' pl <- posterior_linpred(fit) -#' str(pl) -#' } -#' -#' @aliases posterior_linpred -#' @method posterior_linpred brmsfit -#' @importFrom rstantools posterior_linpred -#' @export -#' @export posterior_linpred -posterior_linpred.brmsfit <- function( - object, transform = FALSE, newdata = NULL, re_formula = NULL, - re.form = NULL, resp = NULL, dpar = NULL, nlpar = NULL, - incl_thres = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... -) { - cl <- match.call() - if ("re.form" %in% names(cl)) { - re_formula <- re.form - } - scale <- "linear" - transform <- as_one_logical(transform) - if (transform) { - scale <- "response" - # if transform, return inv-link draws of only a single - # distributional or non-linear parameter for consistency - # of brms and rstanarm - if (is.null(dpar) && is.null(nlpar)) { - dpar <- "mu" - } - } - contains_draws(object) - object <- restructure(object) - prep <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... - ) - posterior_epred( - prep, dpar = dpar, nlpar = nlpar, sort = sort, - scale = scale, incl_thres = incl_thres, summary = FALSE - ) -} - -# ------------------- family specific posterior_epred methods --------------------- -# All posterior_epred_ functions have the same arguments structure -# @param prep A named list returned by prepare_predictions containing -# all required data and draws -# @return transformed linear predictor representing the mean -# of the posterior predictive distribution -posterior_epred_gaussian <- function(prep) { - if (!is.null(prep$ac$lagsar)) { - prep$dpars$mu <- posterior_epred_lagsar(prep) - } - prep$dpars$mu -} - -posterior_epred_student <- function(prep) { - if (!is.null(prep$ac$lagsar)) { - prep$dpars$mu <- posterior_epred_lagsar(prep) - } - prep$dpars$mu -} - -posterior_epred_skew_normal <- function(prep) { - prep$dpars$mu -} - -posterior_epred_lognormal <- function(prep) { - with(prep$dpars, exp(mu + sigma^2 / 2)) -} - -posterior_epred_shifted_lognormal <- function(prep) { - with(prep$dpars, exp(mu + sigma^2 / 2) + ndt) -} - -posterior_epred_binomial <- function(prep) { - trials <- data2draws(prep$data$trials, dim_mu(prep)) - prep$dpars$mu * trials -} - -posterior_epred_bernoulli <- function(prep) { - prep$dpars$mu -} - -posterior_epred_poisson <- function(prep) { - multiply_dpar_rate_denom(prep$dpars$mu, prep) -} - -posterior_epred_negbinomial <- function(prep) { - multiply_dpar_rate_denom(prep$dpars$mu, prep) -} - -posterior_epred_negbinomial2 <- function(prep) { - multiply_dpar_rate_denom(prep$dpars$mu, prep) -} - -posterior_epred_geometric <- function(prep) { - multiply_dpar_rate_denom(prep$dpars$mu, prep) -} - -posterior_epred_discrete_weibull <- function(prep) { - mean_discrete_weibull(prep$dpars$mu, prep$dpars$shape) -} - -posterior_epred_com_poisson <- function(prep) { - mean_com_poisson(prep$dpars$mu, prep$dpars$shape) -} - -posterior_epred_exponential <- function(prep) { - prep$dpars$mu -} - -posterior_epred_gamma <- function(prep) { - prep$dpars$mu -} - -posterior_epred_weibull <- function(prep) { - prep$dpars$mu -} - -posterior_epred_frechet <- function(prep) { - prep$dpars$mu -} - -posterior_epred_gen_extreme_value <- function(prep) { - with(prep$dpars, mu + sigma * (gamma(1 - xi) - 1) / xi) -} - -posterior_epred_inverse.gaussian <- function(prep) { - prep$dpars$mu -} - -posterior_epred_exgaussian <- function(prep) { - prep$dpars$mu -} - -posterior_epred_wiener <- function(prep) { - # mu is the drift rate - with(prep$dpars, - ndt - bias / mu + bs / mu * - (exp(-2 * mu * bias) - 1) / (exp(-2 * mu * bs) - 1) - ) -} - -posterior_epred_beta <- function(prep) { - prep$dpars$mu -} - -posterior_epred_von_mises <- function(prep) { - prep$dpars$mu -} - -posterior_epred_asym_laplace <- function(prep) { - with(prep$dpars, - mu + sigma * (1 - 2 * quantile) / (quantile * (1 - quantile)) - ) -} - -posterior_epred_zero_inflated_asym_laplace <- function(prep) { - posterior_epred_asym_laplace(prep) * (1 - prep$dpars$zi) -} - -posterior_epred_cox <- function(prep) { - stop2("Cannot compute expected values of the posterior predictive ", - "distribution for family 'cox'.") -} - -posterior_epred_hurdle_poisson <- function(prep) { - with(prep$dpars, mu / (1 - exp(-mu)) * (1 - hu)) -} - -posterior_epred_hurdle_negbinomial <- function(prep) { - with(prep$dpars, mu / (1 - (shape / (mu + shape))^shape) * (1 - hu)) -} - -posterior_epred_hurdle_gamma <- function(prep) { - with(prep$dpars, mu * (1 - hu)) -} - -posterior_epred_hurdle_lognormal <- function(prep) { - with(prep$dpars, exp(mu + sigma^2 / 2) * (1 - hu)) -} - -posterior_epred_zero_inflated_poisson <- function(prep) { - with(prep$dpars, mu * (1 - zi)) -} - -posterior_epred_zero_inflated_negbinomial <- function(prep) { - with(prep$dpars, mu * (1 - zi)) -} - -posterior_epred_zero_inflated_binomial <- function(prep) { - trials <- data2draws(prep$data$trials, dim_mu(prep)) - prep$dpars$mu * trials * (1 - prep$dpars$zi) -} - -posterior_epred_zero_inflated_beta <- function(prep) { - with(prep$dpars, mu * (1 - zi)) -} - -posterior_epred_zero_one_inflated_beta <- function(prep) { - with(prep$dpars, zoi * coi + mu * (1 - zoi)) -} - -posterior_epred_categorical <- function(prep) { - get_probs <- function(i) { - eta <- insert_refcat(slice_col(eta, i), family = prep$family) - dcategorical(cats, eta = eta) - } - eta <- abind(prep$dpars, along = 3) - cats <- seq_len(prep$data$ncat) - out <- abind(lapply(seq_cols(eta), get_probs), along = 3) - out <- aperm(out, perm = c(1, 3, 2)) - dimnames(out)[[3]] <- prep$cats - out -} - -posterior_epred_multinomial <- function(prep) { - get_counts <- function(i) { - eta <- insert_refcat(slice_col(eta, i), family = prep$family) - dcategorical(cats, eta = eta) * trials[i] - } - eta <- abind(prep$dpars, along = 3) - cats <- seq_len(prep$data$ncat) - trials <- prep$data$trials - out <- abind(lapply(seq_cols(eta), get_counts), along = 3) - out <- aperm(out, perm = c(1, 3, 2)) - dimnames(out)[[3]] <- prep$cats - out -} - -posterior_epred_dirichlet <- function(prep) { - get_probs <- function(i) { - eta <- insert_refcat(slice_col(eta, i), family = prep$family) - dcategorical(cats, eta = eta) - } - eta <- prep$dpars[grepl("^mu", names(prep$dpars))] - eta <- abind(eta, along = 3) - cats <- seq_len(prep$data$ncat) - out <- abind(lapply(seq_cols(eta), get_probs), along = 3) - out <- aperm(out, perm = c(1, 3, 2)) - dimnames(out)[[3]] <- prep$cats - out -} - -posterior_epred_dirichlet2 <- function(prep) { - mu <- prep$dpars[grepl("^mu", names(prep$dpars))] - mu <- abind(mu, along = 3) - sums_mu <- apply(mu, 1:2, sum) - cats <- seq_len(prep$data$ncat) - for (i in cats) { - mu[, , i] <- mu[, , i] / sums_mu - } - dimnames(mu)[[3]] <- prep$cats - mu -} - -posterior_epred_cumulative <- function(prep) { - posterior_epred_ordinal(prep) -} - -posterior_epred_sratio <- function(prep) { - posterior_epred_ordinal(prep) -} - -posterior_epred_cratio <- function(prep) { - posterior_epred_ordinal(prep) -} - -posterior_epred_acat <- function(prep) { - posterior_epred_ordinal(prep) -} - -posterior_epred_custom <- function(prep) { - custom_family_method(prep$family, "posterior_epred")(prep) -} - -posterior_epred_mixture <- function(prep) { - families <- family_names(prep$family) - prep$dpars$theta <- get_theta(prep) - out <- 0 - for (j in seq_along(families)) { - posterior_epred_fun <- paste0("posterior_epred_", families[j]) - posterior_epred_fun <- get(posterior_epred_fun, asNamespace("brms")) - tmp_prep <- pseudo_prep_for_mixture(prep, j) - if (length(dim(prep$dpars$theta)) == 3L) { - theta <- prep$dpars$theta[, , j] - } else { - theta <- prep$dpars$theta[, j] - } - out <- out + theta * posterior_epred_fun(tmp_prep) - } - out -} - -# ------ posterior_epred helper functions ------ -# compute 'posterior_epred' for ordinal models -posterior_epred_ordinal <- function(prep) { - dens <- get(paste0("d", prep$family$family), mode = "function") - # the linear scale has one column less than the response scale - adjust <- ifelse(prep$family$link == "identity", 0, 1) - ncat_max <- max(prep$data$nthres) + adjust - nact_min <- min(prep$data$nthres) + adjust - init_mat <- matrix(ifelse(prep$family$link == "identity", NA, 0), - nrow = prep$ndraws, - ncol = ncat_max - nact_min) - args <- list(link = prep$family$link) - out <- vector("list", prep$nobs) - for (i in seq_along(out)) { - args_i <- args - args_i$eta <- slice_col(prep$dpars$mu, i) - args_i$disc <- slice_col(prep$dpars$disc, i) - args_i$thres <- subset_thres(prep, i) - ncat_i <- NCOL(args_i$thres) + adjust - args_i$x <- seq_len(ncat_i) - out[[i]] <- do_call(dens, args_i) - if (ncat_i < ncat_max) { - sel <- seq_len(ncat_max - ncat_i) - out[[i]] <- cbind(out[[i]], init_mat[, sel]) - } - } - out <- abind(out, along = 3) - out <- aperm(out, perm = c(1, 3, 2)) - dimnames(out)[[3]] <- seq_len(ncat_max) - out -} - -# compute 'posterior_epred' for lagsar models -posterior_epred_lagsar <- function(prep) { - stopifnot(!is.null(prep$ac$lagsar)) - I <- diag(prep$nobs) - .posterior_epred <- function(s) { - IB <- I - with(prep$ac, lagsar[s, ] * Msar) - as.numeric(solve(IB, prep$dpars$mu[s, ])) - } - out <- rblapply(seq_len(prep$ndraws), .posterior_epred) - rownames(out) <- NULL - out -} - -# expand data to dimension appropriate for -# vectorized multiplication with posterior draws -data2draws <- function(x, dim) { - stopifnot(length(dim) == 2L, length(x) %in% c(1, dim[2])) - matrix(x, nrow = dim[1], ncol = dim[2], byrow = TRUE) -} - -# expected dimension of the main parameter 'mu' -dim_mu <- function(prep) { - c(prep$ndraws, prep$nobs) -} - -# is the model truncated? -is_trunc <- function(prep) { - stopifnot(is.brmsprep(prep)) - any(prep$data[["lb"]] > -Inf) || any(prep$data[["ub"]] < Inf) -} - -# prepares data required for truncation and calles the -# family specific truncation function for posterior_epred values -posterior_epred_trunc <- function(prep) { - stopifnot(is_trunc(prep)) - lb <- data2draws(prep$data[["lb"]], dim_mu(prep)) - ub <- data2draws(prep$data[["ub"]], dim_mu(prep)) - posterior_epred_trunc_fun <- paste0("posterior_epred_trunc_", prep$family$family) - posterior_epred_trunc_fun <- try( - get(posterior_epred_trunc_fun, asNamespace("brms")), - silent = TRUE - ) - if (is(posterior_epred_trunc_fun, "try-error")) { - stop2("posterior_epred values on the respone scale not yet implemented ", - "for truncated '", prep$family$family, "' models.") - } - trunc_args <- nlist(prep, lb, ub) - do_call(posterior_epred_trunc_fun, trunc_args) -} - -# ----- family specific truncation functions ----- -# @param prep output of 'prepare_predictions' -# @param lb lower truncation bound -# @param ub upper truncation bound -# @return draws of the truncated mean parameter -posterior_epred_trunc_gaussian <- function(prep, lb, ub) { - zlb <- (lb - prep$dpars$mu) / prep$dpars$sigma - zub <- (ub - prep$dpars$mu) / prep$dpars$sigma - # truncated mean of standard normal; see Wikipedia - trunc_zmean <- (dnorm(zlb) - dnorm(zub)) / (pnorm(zub) - pnorm(zlb)) - prep$dpars$mu + trunc_zmean * prep$dpars$sigma -} - -posterior_epred_trunc_student <- function(prep, lb, ub) { - zlb <- with(prep$dpars, (lb - mu) / sigma) - zub <- with(prep$dpars, (ub - mu) / sigma) - nu <- prep$dpars$nu - # see Kim 2008: Moments of truncated Student-t distribution - G1 <- gamma((nu - 1) / 2) * nu^(nu / 2) / - (2 * (pt(zub, df = nu) - pt(zlb, df = nu)) - * gamma(nu / 2) * gamma(0.5)) - A <- (nu + zlb^2) ^ (-(nu - 1) / 2) - B <- (nu + zub^2) ^ (-(nu - 1) / 2) - trunc_zmean <- G1 * (A - B) - prep$dpars$mu + trunc_zmean * prep$dpars$sigma -} - -posterior_epred_trunc_lognormal <- function(prep, lb, ub) { - lb <- ifelse(lb < 0, 0, lb) - m1 <- with(prep$dpars, - exp(mu + sigma^2 / 2) * - (pnorm((log(ub) - mu) / sigma - sigma) - - pnorm((log(lb) - mu) / sigma - sigma)) - ) - with(prep$dpars, - m1 / (plnorm(ub, meanlog = mu, sdlog = sigma) - - plnorm(lb, meanlog = mu, sdlog = sigma)) - ) -} - -posterior_epred_trunc_gamma <- function(prep, lb, ub) { - lb <- ifelse(lb < 0, 0, lb) - prep$dpars$scale <- prep$dpars$mu / prep$dpars$shape - # see Jawitz 2004: Moments of truncated continuous univariate distributions - m1 <- with(prep$dpars, - scale / gamma(shape) * - (incgamma(1 + shape, ub / scale) - - incgamma(1 + shape, lb / scale)) - ) - with(prep$dpars, - m1 / (pgamma(ub, shape, scale = scale) - - pgamma(lb, shape, scale = scale)) - ) -} - -posterior_epred_trunc_exponential <- function(prep, lb, ub) { - lb <- ifelse(lb < 0, 0, lb) - inv_mu <- 1 / prep$dpars$mu - # see Jawitz 2004: Moments of truncated continuous univariate distributions - m1 <- with(prep$dpars, mu * (incgamma(2, ub / mu) - incgamma(2, lb / mu))) - m1 / (pexp(ub, rate = inv_mu) - pexp(lb, rate = inv_mu)) -} - -posterior_epred_trunc_weibull <- function(prep, lb, ub) { - lb <- ifelse(lb < 0, 0, lb) - prep$dpars$a <- 1 + 1 / prep$dpars$shape - prep$dpars$scale <- with(prep$dpars, mu / gamma(a)) - # see Jawitz 2004: Moments of truncated continuous univariate distributions - m1 <- with(prep$dpars, - scale * (incgamma(a, (ub / scale)^shape) - - incgamma(a, (lb / scale)^shape)) - ) - with(prep$dpars, - m1 / (pweibull(ub, shape, scale = scale) - - pweibull(lb, shape, scale = scale)) - ) -} - -posterior_epred_trunc_binomial <- function(prep, lb, ub) { - lb <- ifelse(lb < -1, -1, lb) - max_value <- max(prep$data$trials) - ub <- ifelse(ub > max_value, max_value, ub) - trials <- prep$data$trials - if (length(trials) > 1) { - trials <- data2draws(trials, dim_mu(prep)) - } - args <- list(size = trials, prob = prep$dpars$mu) - posterior_epred_trunc_discrete(dist = "binom", args = args, lb = lb, ub = ub) -} - -posterior_epred_trunc_poisson <- function(prep, lb, ub) { - lb <- ifelse(lb < -1, -1, lb) - mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) - max_value <- 3 * max(mu) - ub <- ifelse(ub > max_value, max_value, ub) - args <- list(lambda = mu) - posterior_epred_trunc_discrete(dist = "pois", args = args, lb = lb, ub = ub) -} - -posterior_epred_trunc_negbinomial <- function(prep, lb, ub) { - lb <- ifelse(lb < -1, -1, lb) - mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) - max_value <- 3 * max(mu) - ub <- ifelse(ub > max_value, max_value, ub) - shape <- multiply_dpar_rate_denom(prep$dpars$shape, prep) - args <- list(mu = mu, size = shape) - posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) -} - -posterior_epred_trunc_negbinomial2 <- function(prep, lb, ub) { - lb <- ifelse(lb < -1, -1, lb) - mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) - max_value <- 3 * max(mu) - ub <- ifelse(ub > max_value, max_value, ub) - shape <- multiply_dpar_rate_denom(1 / prep$dpars$sigma, prep) - args <- list(mu = mu, size = shape) - posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) -} - -posterior_epred_trunc_geometric <- function(prep, lb, ub) { - lb <- ifelse(lb < -1, -1, lb) - mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) - max_value <- 3 * max(mu) - ub <- ifelse(ub > max_value, max_value, ub) - shape <- multiply_dpar_rate_denom(1, prep) - args <- list(mu = mu, size = shape) - posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) -} - -# posterior_epred values for truncated discrete distributions -posterior_epred_trunc_discrete <- function(dist, args, lb, ub) { - stopifnot(is.matrix(lb), is.matrix(ub)) - message( - "Computing posterior_epred values for truncated ", - "discrete models may take a while." - ) - pdf <- get(paste0("d", dist), mode = "function") - cdf <- get(paste0("p", dist), mode = "function") - mean_kernel <- function(x, args) { - # just x * density(x) - x * do_call(pdf, c(x, args)) - } - if (any(is.infinite(c(lb, ub)))) { - stop("lb and ub must be finite") - } - # simplify lb and ub back to vector format - vec_lb <- lb[1, ] - vec_ub <- ub[1, ] - min_lb <- min(vec_lb) - # array of dimension S x N x length((lb+1):ub) - mk <- lapply((min_lb + 1):max(vec_ub), mean_kernel, args = args) - mk <- do_call(abind, c(mk, along = 3)) - m1 <- vector("list", ncol(mk)) - for (n in seq_along(m1)) { - # summarize only over non-truncated values for this observation - J <- (vec_lb[n] - min_lb + 1):(vec_ub[n] - min_lb) - m1[[n]] <- rowSums(mk[, n, ][, J, drop = FALSE]) - } - rm(mk) - m1 <- do.call(cbind, m1) - m1 / (do.call(cdf, c(list(ub), args)) - do.call(cdf, c(list(lb), args))) -} - -#' @export -pp_expect <- function(object, ...) { - warning2("Method 'pp_expect' is deprecated. ", - "Please use 'posterior_epred' instead.") - UseMethod("posterior_epred") -} +#' Expected Values of the Posterior Predictive Distribution +#' +#' Compute posterior draws of the expected value/mean of the posterior +#' predictive distribution. Can be performed for the data used to fit the model +#' (posterior predictive checks) or for new data. By definition, these +#' predictions have smaller variance than the posterior predictions performed by +#' the \code{\link{posterior_predict.brmsfit}} method. This is because only the +#' uncertainty in the mean is incorporated in the draws computed by +#' \code{posterior_epred} while any residual error is ignored. However, the +#' estimated means of both methods averaged across draws should be very +#' similar. +#' +#' @aliases pp_expect +#' +#' @inheritParams posterior_predict.brmsfit +#' @param dpar Optional name of a predicted distributional parameter. +#' If specified, expected predictions of this parameters are returned. +#' @param nlpar Optional name of a predicted non-linear parameter. +#' If specified, expected predictions of this parameters are returned. +#' +#' @return An \code{array} of predicted \emph{mean} response values. For +#' categorical and ordinal models, the output is an S x N x C array. +#' Otherwise, the output is an S x N matrix, where S is the number of +#' posterior draws, N is the number of observations, and C is the number of +#' categories. In multivariate models, an additional dimension is added to the +#' output which indexes along the different response variables. +#' +#' @template details-newdata-na +#' @template details-allow_new_levels +#' +#' @examples +#' \dontrun{ +#' ## fit a model +#' fit <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler) +#' +#' ## compute expected predictions +#' ppe <- posterior_epred(fit) +#' str(ppe) +#' } +#' +#' @aliases posterior_epred +#' @method posterior_epred brmsfit +#' @importFrom rstantools posterior_epred +#' @export posterior_epred +#' @export +posterior_epred.brmsfit <- function(object, newdata = NULL, re_formula = NULL, + re.form = NULL, resp = NULL, dpar = NULL, + nlpar = NULL, ndraws = NULL, draw_ids = NULL, + sort = FALSE, ...) { + cl <- match.call() + if ("re.form" %in% names(cl)) { + re_formula <- re.form + } + contains_draws(object) + object <- restructure(object) + prep <- prepare_predictions( + object, newdata = newdata, re_formula = re_formula, resp = resp, + ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... + ) + posterior_epred( + prep, dpar = dpar, nlpar = nlpar, sort = sort, + scale = "response", summary = FALSE + ) +} + +#' @export +posterior_epred.mvbrmsprep <- function(object, ...) { + out <- lapply(object$resps, posterior_epred, ...) + along <- ifelse(length(out) > 1L, 3, 2) + do_call(abind, c(out, along = along)) +} + +#' @export +posterior_epred.brmsprep <- function(object, dpar, nlpar, sort, + scale = "response", incl_thres = NULL, + summary = FALSE, robust = FALSE, + probs = c(0.025, 0.975), ...) { + summary <- as_one_logical(summary) + dpars <- names(object$dpars) + nlpars <- names(object$nlpars) + if (length(dpar)) { + # predict a distributional parameter + dpar <- as_one_character(dpar) + if (!dpar %in% dpars) { + stop2("Invalid argument 'dpar'. Valid distributional ", + "parameters are: ", collapse_comma(dpars)) + } + if (length(nlpar)) { + stop2("Cannot use 'dpar' and 'nlpar' at the same time.") + } + predicted <- is.bprepl(object$dpars[[dpar]]) || + is.bprepnl(object$dpars[[dpar]]) + if (predicted) { + # parameter varies across observations + if (scale == "linear") { + object$dpars[[dpar]]$family$link <- "identity" + } + if (is_ordinal(object$family)) { + object$dpars[[dpar]]$cs <- NULL + object$family <- object$dpars[[dpar]]$family <- + .dpar_family(link = object$dpars[[dpar]]$family$link) + } + if (dpar_class(dpar) == "theta" && scale == "response") { + ap_id <- as.numeric(dpar_id(dpar)) + out <- get_theta(object)[, , ap_id, drop = FALSE] + dim(out) <- dim(out)[c(1, 2)] + } else { + out <- get_dpar(object, dpar = dpar, inv_link = TRUE) + } + } else { + # parameter is constant across observations + out <- object$dpars[[dpar]] + out <- matrix(out, nrow = object$ndraws, ncol = object$nobs) + } + } else if (length(nlpar)) { + # predict a non-linear parameter + nlpar <- as_one_character(nlpar) + if (!nlpar %in% nlpars) { + stop2("Invalid argument 'nlpar'. Valid non-linear ", + "parameters are: ", collapse_comma(nlpars)) + } + out <- get_nlpar(object, nlpar = nlpar) + } else { + # no dpar or nlpar specified + incl_thres <- as_one_logical(incl_thres %||% FALSE) + incl_thres <- incl_thres && is_ordinal(object$family) && scale == "linear" + if (incl_thres) { + # extract linear predictor array with thresholds etc. included + if (is.mixfamily(object$family)) { + stop2("'incl_thres' is not supported for mixture models.") + } + object$family$link <- "identity" + } + if (scale == "response" || incl_thres) { + # predict the mean of the response distribution + for (nlp in nlpars) { + object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) + } + for (dp in dpars) { + object$dpars[[dp]] <- get_dpar(object, dpar = dp) + } + if (is_trunc(object)) { + out <- posterior_epred_trunc(object) + } else { + posterior_epred_fun <- paste0("posterior_epred_", object$family$family) + posterior_epred_fun <- get(posterior_epred_fun, asNamespace("brms")) + out <- posterior_epred_fun(object) + } + } else { + # return results on the linear scale + # extract all 'mu' parameters + if (conv_cats_dpars(object$family)) { + out <- dpars[grepl("^mu", dpars)] + } else { + out <- dpars[dpar_class(dpars) %in% "mu"] + } + if (length(out) == 1L) { + out <- get_dpar(object, dpar = out, inv_link = FALSE) + } else { + # multiple mu parameters in categorical or mixture models + out <- lapply(out, get_dpar, prep = object, inv_link = FALSE) + out <- abind::abind(out, along = 3) + } + } + } + if (is.null(dim(out))) { + out <- as.matrix(out) + } + colnames(out) <- NULL + out <- reorder_obs(out, object$old_order, sort = sort) + if (scale == "response" && is_polytomous(object$family) && + length(dim(out)) == 3L && dim(out)[3] == length(object$cats)) { + # for ordinal models with varying thresholds, dim[3] may not match cats + dimnames(out)[[3]] <- object$cats + } + if (summary) { + # only for compatibility with the 'fitted' method + out <- posterior_summary(out, probs = probs, robust = robust) + if (is_polytomous(object$family) && length(dim(out)) == 3L) { + if (scale == "linear") { + dimnames(out)[[3]] <- paste0("eta", seq_dim(out, 3)) + } else { + dimnames(out)[[3]] <- paste0("P(Y = ", dimnames(out)[[3]], ")") + } + } + } + out +} + +#' Expected Values of the Posterior Predictive Distribution +#' +#' This method is an alias of \code{\link{posterior_epred.brmsfit}} +#' with additional arguments for obtaining summaries of the computed draws. +#' +#' @inheritParams posterior_epred.brmsfit +#' @param object An object of class \code{brmsfit}. +#' @param scale Either \code{"response"} or \code{"linear"}. +#' If \code{"response"}, results are returned on the scale +#' of the response variable. If \code{"linear"}, +#' results are returned on the scale of the linear predictor term, +#' that is without applying the inverse link function or +#' other transformations. +#' @param summary Should summary statistics be returned +#' instead of the raw values? Default is \code{TRUE}.. +#' @param robust If \code{FALSE} (the default) the mean is used as +#' the measure of central tendency and the standard deviation as +#' the measure of variability. If \code{TRUE}, the median and the +#' median absolute deviation (MAD) are applied instead. +#' Only used if \code{summary} is \code{TRUE}. +#' @param probs The percentiles to be computed by the \code{quantile} +#' function. Only used if \code{summary} is \code{TRUE}. +#' +#' @return An \code{array} of predicted \emph{mean} response values. +#' If \code{summary = FALSE} the output resembles those of +#' \code{\link{posterior_epred.brmsfit}}. +#' +#' If \code{summary = TRUE} the output depends on the family: For categorical +#' and ordinal families, the output is an N x E x C array, where N is the +#' number of observations, E is the number of summary statistics, and C is the +#' number of categories. For all other families, the output is an N x E +#' matrix. The number of summary statistics E is equal to \code{2 + +#' length(probs)}: The \code{Estimate} column contains point estimates (either +#' mean or median depending on argument \code{robust}), while the +#' \code{Est.Error} column contains uncertainty estimates (either standard +#' deviation or median absolute deviation depending on argument +#' \code{robust}). The remaining columns starting with \code{Q} contain +#' quantile estimates as specified via argument \code{probs}. +#' +#' In multivariate models, an additional dimension is added to the output +#' which indexes along the different response variables. +#' +#' @seealso \code{\link{posterior_epred.brmsfit}} +#' +#' @examples +#' \dontrun{ +#' ## fit a model +#' fit <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler) +#' +#' ## compute expected predictions +#' fitted_values <- fitted(fit) +#' head(fitted_values) +#' +#' ## plot expected predictions against actual response +#' dat <- as.data.frame(cbind(Y = standata(fit)$Y, fitted_values)) +#' ggplot(dat) + geom_point(aes(x = Estimate, y = Y)) +#' } +#' +#' @export +fitted.brmsfit <- function(object, newdata = NULL, re_formula = NULL, + scale = c("response", "linear"), + resp = NULL, dpar = NULL, nlpar = NULL, + ndraws = NULL, draw_ids = NULL, sort = FALSE, + summary = TRUE, robust = FALSE, + probs = c(0.025, 0.975), ...) { + scale <- match.arg(scale) + summary <- as_one_logical(summary) + contains_draws(object) + object <- restructure(object) + prep <- prepare_predictions( + object, newdata = newdata, re_formula = re_formula, resp = resp, + ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... + ) + posterior_epred( + prep, dpar = dpar, nlpar = nlpar, sort = sort, scale = scale, + summary = summary, robust = robust, probs = probs + ) +} + +#' Posterior Draws of the Linear Predictor +#' +#' Compute posterior draws of the linear predictor, that is draws before +#' applying any link functions or other transformations. Can be performed for +#' the data used to fit the model (posterior predictive checks) or for new data. +#' +#' @inheritParams posterior_epred.brmsfit +#' @param object An object of class \code{brmsfit}. +#' @param transform Logical; if \code{FALSE} +#' (the default), draws of the linear predictor are returned. +#' If \code{TRUE}, draws of transformed linear predictor, +#' that is, after applying the link function are returned. +#' @param dpar Name of a predicted distributional parameter +#' for which draws are to be returned. By default, draws +#' of the main distributional parameter(s) \code{"mu"} are returned. +#' @param incl_thres Logical; only relevant for ordinal models when +#' \code{transform} is \code{FALSE}, and ignored otherwise. Shall the +#' thresholds and category-specific effects be included in the linear +#' predictor? For backwards compatibility, the default is to not include them. +#' +#' @seealso \code{\link{posterior_epred.brmsfit}} +#' +#' @examples +#' \dontrun{ +#' ## fit a model +#' fit <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler) +#' +#' ## extract linear predictor values +#' pl <- posterior_linpred(fit) +#' str(pl) +#' } +#' +#' @aliases posterior_linpred +#' @method posterior_linpred brmsfit +#' @importFrom rstantools posterior_linpred +#' @export +#' @export posterior_linpred +posterior_linpred.brmsfit <- function( + object, transform = FALSE, newdata = NULL, re_formula = NULL, + re.form = NULL, resp = NULL, dpar = NULL, nlpar = NULL, + incl_thres = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... +) { + cl <- match.call() + if ("re.form" %in% names(cl)) { + re_formula <- re.form + } + scale <- "linear" + transform <- as_one_logical(transform) + if (transform) { + scale <- "response" + # if transform, return inv-link draws of only a single + # distributional or non-linear parameter for consistency + # of brms and rstanarm + if (is.null(dpar) && is.null(nlpar)) { + dpar <- "mu" + } + } + contains_draws(object) + object <- restructure(object) + prep <- prepare_predictions( + object, newdata = newdata, re_formula = re_formula, resp = resp, + ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... + ) + posterior_epred( + prep, dpar = dpar, nlpar = nlpar, sort = sort, + scale = scale, incl_thres = incl_thres, summary = FALSE + ) +} + +# ------------------- family specific posterior_epred methods --------------------- +# All posterior_epred_ functions have the same arguments structure +# @param prep A named list returned by prepare_predictions containing +# all required data and draws +# @return transformed linear predictor representing the mean +# of the posterior predictive distribution +posterior_epred_gaussian <- function(prep) { + if (!is.null(prep$ac$lagsar)) { + prep$dpars$mu <- posterior_epred_lagsar(prep) + } + prep$dpars$mu +} + +posterior_epred_student <- function(prep) { + if (!is.null(prep$ac$lagsar)) { + prep$dpars$mu <- posterior_epred_lagsar(prep) + } + prep$dpars$mu +} + +posterior_epred_skew_normal <- function(prep) { + prep$dpars$mu +} + +posterior_epred_lognormal <- function(prep) { + with(prep$dpars, exp(mu + sigma^2 / 2)) +} + +posterior_epred_shifted_lognormal <- function(prep) { + with(prep$dpars, exp(mu + sigma^2 / 2) + ndt) +} + +posterior_epred_binomial <- function(prep) { + trials <- data2draws(prep$data$trials, dim_mu(prep)) + prep$dpars$mu * trials +} + +posterior_epred_beta_binomial <- function(prep) { + # beta part included in mu + trials <- data2draws(prep$data$trials, dim_mu(prep)) + prep$dpars$mu * trials +} + +posterior_epred_bernoulli <- function(prep) { + prep$dpars$mu +} + +posterior_epred_poisson <- function(prep) { + multiply_dpar_rate_denom(prep$dpars$mu, prep) +} + +posterior_epred_negbinomial <- function(prep) { + multiply_dpar_rate_denom(prep$dpars$mu, prep) +} + +posterior_epred_negbinomial2 <- function(prep) { + multiply_dpar_rate_denom(prep$dpars$mu, prep) +} + +posterior_epred_geometric <- function(prep) { + multiply_dpar_rate_denom(prep$dpars$mu, prep) +} + +posterior_epred_discrete_weibull <- function(prep) { + mean_discrete_weibull(prep$dpars$mu, prep$dpars$shape) +} + +posterior_epred_com_poisson <- function(prep) { + mean_com_poisson(prep$dpars$mu, prep$dpars$shape) +} + +posterior_epred_exponential <- function(prep) { + prep$dpars$mu +} + +posterior_epred_gamma <- function(prep) { + prep$dpars$mu +} + +posterior_epred_weibull <- function(prep) { + prep$dpars$mu +} + +posterior_epred_frechet <- function(prep) { + prep$dpars$mu +} + +posterior_epred_gen_extreme_value <- function(prep) { + with(prep$dpars, mu + sigma * (gamma(1 - xi) - 1) / xi) +} + +posterior_epred_inverse.gaussian <- function(prep) { + prep$dpars$mu +} + +posterior_epred_exgaussian <- function(prep) { + prep$dpars$mu +} + +posterior_epred_wiener <- function(prep) { + # mu is the drift rate + with(prep$dpars, + ndt - bias / mu + bs / mu * + (exp(-2 * mu * bias) - 1) / (exp(-2 * mu * bs) - 1) + ) +} + +posterior_epred_beta <- function(prep) { + prep$dpars$mu +} + +posterior_epred_von_mises <- function(prep) { + prep$dpars$mu +} + +posterior_epred_asym_laplace <- function(prep) { + with(prep$dpars, + mu + sigma * (1 - 2 * quantile) / (quantile * (1 - quantile)) + ) +} + +posterior_epred_zero_inflated_asym_laplace <- function(prep) { + posterior_epred_asym_laplace(prep) * (1 - prep$dpars$zi) +} + +posterior_epred_cox <- function(prep) { + stop2("Cannot compute expected values of the posterior predictive ", + "distribution for family 'cox'.") +} + +posterior_epred_hurdle_poisson <- function(prep) { + with(prep$dpars, mu / (1 - exp(-mu)) * (1 - hu)) +} + +posterior_epred_hurdle_negbinomial <- function(prep) { + with(prep$dpars, mu / (1 - (shape / (mu + shape))^shape) * (1 - hu)) +} + +posterior_epred_hurdle_gamma <- function(prep) { + with(prep$dpars, mu * (1 - hu)) +} + +posterior_epred_hurdle_lognormal <- function(prep) { + with(prep$dpars, exp(mu + sigma^2 / 2) * (1 - hu)) +} + +posterior_epred_zero_inflated_poisson <- function(prep) { + with(prep$dpars, mu * (1 - zi)) +} + +posterior_epred_zero_inflated_negbinomial <- function(prep) { + with(prep$dpars, mu * (1 - zi)) +} + +posterior_epred_zero_inflated_binomial <- function(prep) { + trials <- data2draws(prep$data$trials, dim_mu(prep)) + prep$dpars$mu * trials * (1 - prep$dpars$zi) +} + +posterior_epred_zero_inflated_beta_binomial <- function(prep) { + # same as zero_inflated_binom as beta part is included in mu + trials <- data2draws(prep$data$trials, dim_mu(prep)) + prep$dpars$mu * trials * (1 - prep$dpars$zi) +} + +posterior_epred_zero_inflated_beta <- function(prep) { + with(prep$dpars, mu * (1 - zi)) +} + +posterior_epred_zero_one_inflated_beta <- function(prep) { + with(prep$dpars, zoi * coi + mu * (1 - zoi)) +} + +posterior_epred_categorical <- function(prep) { + get_probs <- function(i) { + eta <- insert_refcat(slice_col(eta, i), refcat = prep$refcat) + dcategorical(cats, eta = eta) + } + eta <- get_Mu(prep) + cats <- seq_len(prep$data$ncat) + out <- abind(lapply(seq_cols(eta), get_probs), along = 3) + out <- aperm(out, perm = c(1, 3, 2)) + dimnames(out)[[3]] <- prep$cats + out +} + +posterior_epred_multinomial <- function(prep) { + get_counts <- function(i) { + eta <- insert_refcat(slice_col(eta, i), refcat = prep$refcat) + dcategorical(cats, eta = eta) * trials[i] + } + eta <- get_Mu(prep) + cats <- seq_len(prep$data$ncat) + trials <- prep$data$trials + out <- abind(lapply(seq_cols(eta), get_counts), along = 3) + out <- aperm(out, perm = c(1, 3, 2)) + dimnames(out)[[3]] <- prep$cats + out +} + +posterior_epred_dirichlet <- function(prep) { + get_probs <- function(i) { + eta <- insert_refcat(slice_col(eta, i), refcat = prep$refcat) + dcategorical(cats, eta = eta) + } + eta <- get_Mu(prep) + cats <- seq_len(prep$data$ncat) + out <- abind(lapply(seq_cols(eta), get_probs), along = 3) + out <- aperm(out, perm = c(1, 3, 2)) + dimnames(out)[[3]] <- prep$cats + out +} + +posterior_epred_dirichlet2 <- function(prep) { + mu <- get_Mu(prep) + sums_mu <- apply(mu, 1:2, sum) + cats <- seq_len(prep$data$ncat) + for (i in cats) { + mu[, , i] <- mu[, , i] / sums_mu + } + dimnames(mu)[[3]] <- prep$cats + mu +} + +posterior_epred_logistic_normal <- function(prep) { + stop2("Cannot compute expected values of the posterior predictive ", + "distribution for family 'logistic_normal'.") +} + +posterior_epred_cumulative <- function(prep) { + posterior_epred_ordinal(prep) +} + +posterior_epred_sratio <- function(prep) { + posterior_epred_ordinal(prep) +} + +posterior_epred_cratio <- function(prep) { + posterior_epred_ordinal(prep) +} + +posterior_epred_acat <- function(prep) { + posterior_epred_ordinal(prep) +} + +posterior_epred_custom <- function(prep) { + custom_family_method(prep$family, "posterior_epred")(prep) +} + +posterior_epred_mixture <- function(prep) { + families <- family_names(prep$family) + prep$dpars$theta <- get_theta(prep) + out <- 0 + for (j in seq_along(families)) { + posterior_epred_fun <- paste0("posterior_epred_", families[j]) + posterior_epred_fun <- get(posterior_epred_fun, asNamespace("brms")) + tmp_prep <- pseudo_prep_for_mixture(prep, j) + if (length(dim(prep$dpars$theta)) == 3L) { + theta <- prep$dpars$theta[, , j] + } else { + theta <- prep$dpars$theta[, j] + } + out <- out + theta * posterior_epred_fun(tmp_prep) + } + out +} + +# ------ posterior_epred helper functions ------ +# compute 'posterior_epred' for ordinal models +posterior_epred_ordinal <- function(prep) { + dens <- get(paste0("d", prep$family$family), mode = "function") + # the linear scale has one column less than the response scale + adjust <- ifelse(prep$family$link == "identity", 0, 1) + ncat_max <- max(prep$data$nthres) + adjust + nact_min <- min(prep$data$nthres) + adjust + init_mat <- matrix(ifelse(prep$family$link == "identity", NA, 0), + nrow = prep$ndraws, + ncol = ncat_max - nact_min) + args <- list(link = prep$family$link) + out <- vector("list", prep$nobs) + for (i in seq_along(out)) { + args_i <- args + args_i$eta <- slice_col(prep$dpars$mu, i) + args_i$disc <- slice_col(prep$dpars$disc, i) + args_i$thres <- subset_thres(prep, i) + ncat_i <- NCOL(args_i$thres) + adjust + args_i$x <- seq_len(ncat_i) + out[[i]] <- do_call(dens, args_i) + if (ncat_i < ncat_max) { + sel <- seq_len(ncat_max - ncat_i) + out[[i]] <- cbind(out[[i]], init_mat[, sel]) + } + } + out <- abind(out, along = 3) + out <- aperm(out, perm = c(1, 3, 2)) + dimnames(out)[[3]] <- seq_len(ncat_max) + out +} + +# compute 'posterior_epred' for lagsar models +posterior_epred_lagsar <- function(prep) { + stopifnot(!is.null(prep$ac$lagsar)) + I <- diag(prep$nobs) + .posterior_epred <- function(s) { + IB <- I - with(prep$ac, lagsar[s, ] * Msar) + as.numeric(solve(IB, prep$dpars$mu[s, ])) + } + out <- rblapply(seq_len(prep$ndraws), .posterior_epred) + rownames(out) <- NULL + out +} + +# expand data to dimension appropriate for +# vectorized multiplication with posterior draws +data2draws <- function(x, dim) { + stopifnot(length(dim) == 2L, length(x) %in% c(1, dim[2])) + matrix(x, nrow = dim[1], ncol = dim[2], byrow = TRUE) +} + +# expected dimension of the main parameter 'mu' +dim_mu <- function(prep) { + c(prep$ndraws, prep$nobs) +} + +# is the model truncated? +is_trunc <- function(prep) { + stopifnot(is.brmsprep(prep)) + any(prep$data[["lb"]] > -Inf) || any(prep$data[["ub"]] < Inf) +} + +# prepares data required for truncation and calles the +# family specific truncation function for posterior_epred values +posterior_epred_trunc <- function(prep) { + stopifnot(is_trunc(prep)) + lb <- data2draws(prep$data[["lb"]], dim_mu(prep)) + ub <- data2draws(prep$data[["ub"]], dim_mu(prep)) + posterior_epred_trunc_fun <- paste0("posterior_epred_trunc_", prep$family$family) + posterior_epred_trunc_fun <- try( + get(posterior_epred_trunc_fun, asNamespace("brms")), + silent = TRUE + ) + if (is(posterior_epred_trunc_fun, "try-error")) { + stop2("posterior_epred values on the respone scale not yet implemented ", + "for truncated '", prep$family$family, "' models.") + } + trunc_args <- nlist(prep, lb, ub) + do_call(posterior_epred_trunc_fun, trunc_args) +} + +# ----- family specific truncation functions ----- +# @param prep output of 'prepare_predictions' +# @param lb lower truncation bound +# @param ub upper truncation bound +# @return draws of the truncated mean parameter +posterior_epred_trunc_gaussian <- function(prep, lb, ub) { + zlb <- (lb - prep$dpars$mu) / prep$dpars$sigma + zub <- (ub - prep$dpars$mu) / prep$dpars$sigma + # truncated mean of standard normal; see Wikipedia + trunc_zmean <- (dnorm(zlb) - dnorm(zub)) / (pnorm(zub) - pnorm(zlb)) + prep$dpars$mu + trunc_zmean * prep$dpars$sigma +} + +posterior_epred_trunc_student <- function(prep, lb, ub) { + zlb <- with(prep$dpars, (lb - mu) / sigma) + zub <- with(prep$dpars, (ub - mu) / sigma) + nu <- prep$dpars$nu + # see Kim 2008: Moments of truncated Student-t distribution + G1 <- gamma((nu - 1) / 2) * nu^(nu / 2) / + (2 * (pt(zub, df = nu) - pt(zlb, df = nu)) + * gamma(nu / 2) * gamma(0.5)) + A <- (nu + zlb^2) ^ (-(nu - 1) / 2) + B <- (nu + zub^2) ^ (-(nu - 1) / 2) + trunc_zmean <- G1 * (A - B) + prep$dpars$mu + trunc_zmean * prep$dpars$sigma +} + +posterior_epred_trunc_lognormal <- function(prep, lb, ub) { + lb <- ifelse(lb < 0, 0, lb) + m1 <- with(prep$dpars, + exp(mu + sigma^2 / 2) * + (pnorm((log(ub) - mu) / sigma - sigma) - + pnorm((log(lb) - mu) / sigma - sigma)) + ) + with(prep$dpars, + m1 / (plnorm(ub, meanlog = mu, sdlog = sigma) - + plnorm(lb, meanlog = mu, sdlog = sigma)) + ) +} + +posterior_epred_trunc_gamma <- function(prep, lb, ub) { + lb <- ifelse(lb < 0, 0, lb) + prep$dpars$scale <- prep$dpars$mu / prep$dpars$shape + # see Jawitz 2004: Moments of truncated continuous univariate distributions + m1 <- with(prep$dpars, + scale / gamma(shape) * + (incgamma(1 + shape, ub / scale) - + incgamma(1 + shape, lb / scale)) + ) + with(prep$dpars, + m1 / (pgamma(ub, shape, scale = scale) - + pgamma(lb, shape, scale = scale)) + ) +} + +posterior_epred_trunc_exponential <- function(prep, lb, ub) { + lb <- ifelse(lb < 0, 0, lb) + inv_mu <- 1 / prep$dpars$mu + # see Jawitz 2004: Moments of truncated continuous univariate distributions + m1 <- with(prep$dpars, mu * (incgamma(2, ub / mu) - incgamma(2, lb / mu))) + m1 / (pexp(ub, rate = inv_mu) - pexp(lb, rate = inv_mu)) +} + +posterior_epred_trunc_weibull <- function(prep, lb, ub) { + lb <- ifelse(lb < 0, 0, lb) + prep$dpars$a <- 1 + 1 / prep$dpars$shape + prep$dpars$scale <- with(prep$dpars, mu / gamma(a)) + # see Jawitz 2004: Moments of truncated continuous univariate distributions + m1 <- with(prep$dpars, + scale * (incgamma(a, (ub / scale)^shape) - + incgamma(a, (lb / scale)^shape)) + ) + with(prep$dpars, + m1 / (pweibull(ub, shape, scale = scale) - + pweibull(lb, shape, scale = scale)) + ) +} + +posterior_epred_trunc_binomial <- function(prep, lb, ub) { + lb <- ifelse(lb < -1, -1, lb) + max_value <- max(prep$data$trials) + ub <- ifelse(ub > max_value, max_value, ub) + trials <- prep$data$trials + if (length(trials) > 1) { + trials <- data2draws(trials, dim_mu(prep)) + } + args <- list(size = trials, prob = prep$dpars$mu) + posterior_epred_trunc_discrete(dist = "binom", args = args, lb = lb, ub = ub) +} + +posterior_epred_trunc_poisson <- function(prep, lb, ub) { + lb <- ifelse(lb < -1, -1, lb) + mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) + max_value <- 3 * max(mu) + ub <- ifelse(ub > max_value, max_value, ub) + args <- list(lambda = mu) + posterior_epred_trunc_discrete(dist = "pois", args = args, lb = lb, ub = ub) +} + +posterior_epred_trunc_negbinomial <- function(prep, lb, ub) { + lb <- ifelse(lb < -1, -1, lb) + mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) + max_value <- 3 * max(mu) + ub <- ifelse(ub > max_value, max_value, ub) + shape <- multiply_dpar_rate_denom(prep$dpars$shape, prep) + args <- list(mu = mu, size = shape) + posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) +} + +posterior_epred_trunc_negbinomial2 <- function(prep, lb, ub) { + lb <- ifelse(lb < -1, -1, lb) + mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) + max_value <- 3 * max(mu) + ub <- ifelse(ub > max_value, max_value, ub) + shape <- multiply_dpar_rate_denom(1 / prep$dpars$sigma, prep) + args <- list(mu = mu, size = shape) + posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) +} + +posterior_epred_trunc_geometric <- function(prep, lb, ub) { + lb <- ifelse(lb < -1, -1, lb) + mu <- multiply_dpar_rate_denom(prep$dpars$mu, prep) + max_value <- 3 * max(mu) + ub <- ifelse(ub > max_value, max_value, ub) + shape <- multiply_dpar_rate_denom(1, prep) + args <- list(mu = mu, size = shape) + posterior_epred_trunc_discrete(dist = "nbinom", args = args, lb = lb, ub = ub) +} + +# posterior_epred values for truncated discrete distributions +posterior_epred_trunc_discrete <- function(dist, args, lb, ub) { + stopifnot(is.matrix(lb), is.matrix(ub)) + message( + "Computing posterior_epred values for truncated ", + "discrete models may take a while." + ) + pdf <- get(paste0("d", dist), mode = "function") + cdf <- get(paste0("p", dist), mode = "function") + mean_kernel <- function(x, args) { + # just x * density(x) + x * do_call(pdf, c(x, args)) + } + if (any(is.infinite(c(lb, ub)))) { + stop("lb and ub must be finite") + } + # simplify lb and ub back to vector format + vec_lb <- lb[1, ] + vec_ub <- ub[1, ] + min_lb <- min(vec_lb) + # array of dimension S x N x length((lb+1):ub) + mk <- lapply((min_lb + 1):max(vec_ub), mean_kernel, args = args) + mk <- do_call(abind, c(mk, along = 3)) + m1 <- vector("list", ncol(mk)) + for (n in seq_along(m1)) { + # summarize only over non-truncated values for this observation + J <- (vec_lb[n] - min_lb + 1):(vec_ub[n] - min_lb) + m1[[n]] <- rowSums(mk[, n, ][, J, drop = FALSE]) + } + rm(mk) + m1 <- do.call(cbind, m1) + m1 / (do.call(cdf, c(list(ub), args)) - do.call(cdf, c(list(lb), args))) +} + +#' @export +pp_expect <- function(object, ...) { + warning2("Method 'pp_expect' is deprecated. ", + "Please use 'posterior_epred' instead.") + UseMethod("posterior_epred") +} diff -Nru r-cran-brms-2.16.3/R/posterior_predict.R r-cran-brms-2.17.0/R/posterior_predict.R --- r-cran-brms-2.16.3/R/posterior_predict.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/posterior_predict.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,1022 +1,1054 @@ -#' Draws from the Posterior Predictive Distribution -#' -#' Compute posterior draws of the posterior predictive distribution. Can be -#' performed for the data used to fit the model (posterior predictive checks) or -#' for new data. By definition, these draws have higher variance than draws -#' of the means of the posterior predictive distribution computed by -#' \code{\link{posterior_epred.brmsfit}}. This is because the residual error -#' is incorporated in \code{posterior_predict}. However, the estimated means of -#' both methods averaged across draws should be very similar. -#' -#' @inheritParams prepare_predictions -#' @param object An object of class \code{brmsfit}. -#' @param re.form Alias of \code{re_formula}. -#' @param transform (Deprecated) A function or a character string naming -#' a function to be applied on the predicted responses -#' before summary statistics are computed. -#' @param negative_rt Only relevant for Wiener diffusion models. -#' A flag indicating whether response times of responses -#' on the lower boundary should be returned as negative values. -#' This allows to distinguish responses on the upper and -#' lower boundary. Defaults to \code{FALSE}. -#' @param sort Logical. Only relevant for time series models. -#' Indicating whether to return predicted values in the original -#' order (\code{FALSE}; default) or in the order of the -#' time series (\code{TRUE}). -#' @param ntrys Parameter used in rejection sampling -#' for truncated discrete models only -#' (defaults to \code{5}). See Details for more information. -#' @param cores Number of cores (defaults to \code{1}). On non-Windows systems, -#' this argument can be set globally via the \code{mc.cores} option. -#' @param ... Further arguments passed to \code{\link{prepare_predictions}} -#' that control several aspects of data validation and prediction. -#' -#' @return An \code{array} of predicted response values. In univariate models, -#' the output is as an S x N matrix, where S is the number of posterior -#' draws and N is the number of observations. In multivariate models, an -#' additional dimension is added to the output which indexes along the -#' different response variables. -#' -#' @template details-newdata-na -#' @template details-allow_new_levels -#' @details For truncated discrete models only: In the absence of any general -#' algorithm to sample from truncated discrete distributions, rejection -#' sampling is applied in this special case. This means that values are -#' sampled until a value lies within the defined truncation boundaries. In -#' practice, this procedure may be rather slow (especially in \R). Thus, we -#' try to do approximate rejection sampling by sampling each value -#' \code{ntrys} times and then select a valid value. If all values are -#' invalid, the closest boundary is used, instead. If there are more than a -#' few of these pathological cases, a warning will occur suggesting to -#' increase argument \code{ntrys}. -#' -#' @examples -#' \dontrun{ -#' ## fit a model -#' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), -#' data = kidney, family = "exponential", inits = "0") -#' -#' ## predicted responses -#' pp <- posterior_predict(fit) -#' str(pp) -#' -#' ## predicted responses excluding the group-level effect of age -#' pp <- posterior_predict(fit, re_formula = ~ (1 | patient)) -#' str(pp) -#' -#' ## predicted responses of patient 1 for new data -#' newdata <- data.frame( -#' sex = factor(c("male", "female")), -#' age = c(20, 50), -#' patient = c(1, 1) -#' ) -#' pp <- posterior_predict(fit, newdata = newdata) -#' str(pp) -#' } -#' -#' @aliases posterior_predict -#' @method posterior_predict brmsfit -#' @importFrom rstantools posterior_predict -#' @export -#' @export posterior_predict -posterior_predict.brmsfit <- function( - object, newdata = NULL, re_formula = NULL, re.form = NULL, - transform = NULL, resp = NULL, negative_rt = FALSE, - ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, - cores = NULL, ... -) { - cl <- match.call() - if ("re.form" %in% names(cl)) { - re_formula <- re.form - } - contains_draws(object) - object <- restructure(object) - prep <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... - ) - posterior_predict( - prep, transform = transform, sort = sort, ntrys = ntrys, - negative_rt = negative_rt, cores = cores, summary = FALSE - ) -} - -#' @export -posterior_predict.mvbrmsprep <- function(object, ...) { - if (length(object$mvpars$rescor)) { - object$mvpars$Mu <- get_Mu(object) - object$mvpars$Sigma <- get_Sigma(object) - out <- posterior_predict.brmsprep(object, ...) - } else { - out <- lapply(object$resps, posterior_predict, ...) - along <- ifelse(length(out) > 1L, 3, 2) - out <- do_call(abind, c(out, along = along)) - } - out -} - -#' @export -posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, - summary = FALSE, robust = FALSE, - probs = c(0.025, 0.975), - cores = NULL, ...) { - summary <- as_one_logical(summary) - cores <- validate_cores_post_processing(cores) - if (is.customfamily(object$family)) { - # ensure that the method can be found during parallel execution - object$family$posterior_predict <- - custom_family_method(object$family, "posterior_predict") - } - for (nlp in names(object$nlpars)) { - object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) - } - for (dp in names(object$dpars)) { - object$dpars[[dp]] <- get_dpar(object, dpar = dp) - } - pp_fun <- paste0("posterior_predict_", object$family$fun) - pp_fun <- get(pp_fun, asNamespace("brms")) - N <- choose_N(object) - out <- plapply(seq_len(N), pp_fun, cores = cores, prep = object, ...) - if (grepl("_mv$", object$family$fun)) { - out <- do_call(abind, c(out, along = 3)) - out <- aperm(out, perm = c(1, 3, 2)) - dimnames(out)[[3]] <- names(object$resps) - } else if (has_multicol(object$family)) { - out <- do_call(abind, c(out, along = 3)) - out <- aperm(out, perm = c(1, 3, 2)) - dimnames(out)[[3]] <- object$cats - } else { - out <- do_call(cbind, out) - } - colnames(out) <- rownames(out) <- NULL - if (use_int(object$family)) { - out <- check_discrete_trunc_bounds( - out, lb = object$data$lb, ub = object$data$ub - ) - } - out <- reorder_obs(out, object$old_order, sort = sort) - # transform predicted response draws before summarizing them - if (!is.null(transform)) { - # deprecated as of brms 2.12.3 - warning2("Argument 'transform' is deprecated ", - "and will be removed in the future.") - out <- do_call(transform, list(out)) - } - attr(out, "levels") <- object$cats - if (summary) { - # only for compatibility with the 'predict' method - if (is_ordinal(object$family)) { - levels <- seq_len(max(object$data$nthres) + 1) - out <- posterior_table(out, levels = levels) - } else if (is_categorical(object$family)) { - levels <- seq_len(object$data$ncat) - out <- posterior_table(out, levels = levels) - } else { - out <- posterior_summary(out, probs = probs, robust = robust) - } - } - out -} - -#' Draws from the Posterior Predictive Distribution -#' -#' This method is an alias of \code{\link{posterior_predict.brmsfit}} -#' with additional arguments for obtaining summaries of the computed draws. -#' -#' @inheritParams posterior_predict.brmsfit -#' @param summary Should summary statistics be returned -#' instead of the raw values? Default is \code{TRUE}. -#' @param robust If \code{FALSE} (the default) the mean is used as -#' the measure of central tendency and the standard deviation as -#' the measure of variability. If \code{TRUE}, the median and the -#' median absolute deviation (MAD) are applied instead. -#' Only used if \code{summary} is \code{TRUE}. -#' @param probs The percentiles to be computed by the \code{quantile} -#' function. Only used if \code{summary} is \code{TRUE}. -#' -#' @return An \code{array} of predicted response values. -#' If \code{summary = FALSE} the output resembles those of -#' \code{\link{posterior_predict.brmsfit}}. -#' -#' If \code{summary = TRUE} the output depends on the family: For categorical -#' and ordinal families, the output is an N x C matrix, where N is the number -#' of observations, C is the number of categories, and the values are -#' predicted category probabilities. For all other families, the output is a N -#' x E matrix where E = \code{2 + length(probs)} is the number of summary -#' statistics: The \code{Estimate} column contains point estimates (either -#' mean or median depending on argument \code{robust}), while the -#' \code{Est.Error} column contains uncertainty estimates (either standard -#' deviation or median absolute deviation depending on argument -#' \code{robust}). The remaining columns starting with \code{Q} contain -#' quantile estimates as specified via argument \code{probs}. -#' -#' @seealso \code{\link{posterior_predict.brmsfit}} -#' -#' @examples -#' \dontrun{ -#' ## fit a model -#' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), -#' data = kidney, family = "exponential", inits = "0") -#' -#' ## predicted responses -#' pp <- predict(fit) -#' head(pp) -#' -#' ## predicted responses excluding the group-level effect of age -#' pp <- predict(fit, re_formula = ~ (1 | patient)) -#' head(pp) -#' -#' ## predicted responses of patient 1 for new data -#' newdata <- data.frame( -#' sex = factor(c("male", "female")), -#' age = c(20, 50), -#' patient = c(1, 1) -#' ) -#' predict(fit, newdata = newdata) -#' } -#' -#' @export -predict.brmsfit <- function(object, newdata = NULL, re_formula = NULL, - transform = NULL, resp = NULL, - negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, - sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, - robust = FALSE, probs = c(0.025, 0.975), ...) { - contains_draws(object) - object <- restructure(object) - prep <- prepare_predictions( - object, newdata = newdata, re_formula = re_formula, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... - ) - posterior_predict( - prep, transform = transform, ntrys = ntrys, negative_rt = negative_rt, - sort = sort, cores = cores, summary = summary, robust = robust, - probs = probs - ) -} - -#' Predictive Intervals -#' -#' Compute intervals from the posterior predictive distribution. -#' -#' @aliases predictive_interval -#' -#' @param object An \R object of class \code{brmsfit}. -#' @param prob A number p (0 < p < 1) indicating the desired probability mass to -#' include in the intervals. Defaults to \code{0.9}. -#' @param ... Further arguments passed to \code{\link{posterior_predict}}. -#' -#' @return A matrix with 2 columns for the lower and upper bounds of the -#' intervals, respectively, and as many rows as observations being predicted. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zBase, data = epilepsy, family = poisson()) -#' predictive_interval(fit) -#' } -#' -#' @importFrom rstantools predictive_interval -#' @export predictive_interval -#' @export -predictive_interval.brmsfit <- function(object, prob = 0.9, ...) { - out <- posterior_predict(object, ...) - predictive_interval(out, prob = prob) -} - -# validate method name to obtain posterior predictions -# @param method name of the method -# @return validated name of the method -validate_pp_method <- function(method) { - method <- as_one_character(method) - if (method %in% c("posterior_predict", "predict", "pp")) { - method <- "posterior_predict" - } else if (method %in% c("posterior_epred", "fitted", "pp_expect")) { - method <- "posterior_epred" - } else if (method %in% c("posterior_linpred")) { - method <- "posterior_linpred" - } else if (method %in% c("predictive_error", "residuals")) { - method <- "predictive_error" - } else { - stop2("Posterior predictive method '", method, "' it not supported.") - } - method -} - -# ------------------- family specific posterior_predict methods --------------------- -# All posterior_predict_ functions have the same arguments structure -# @param i index of the observatio for which to compute pp values -# @param prep A named list returned by prepare_predictions containing -# all required data and posterior draws -# @param ... ignored arguments -# @param A vector of length prep$ndraws containing draws -# from the posterior predictive distribution -posterior_predict_gaussian <- function(i, prep, ntrys = 5, ...) { - mu <- get_dpar(prep, "mu", i = i) - sigma <- get_dpar(prep, "sigma", i = i) - sigma <- add_sigma_se(sigma, prep, i = i) - rcontinuous( - n = prep$ndraws, dist = "norm", - mean = mu, sd = sigma, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_student <- function(i, prep, ntrys = 5, ...) { - nu <- get_dpar(prep, "nu", i = i) - mu <- get_dpar(prep, "mu", i = i) - sigma <- get_dpar(prep, "sigma", i = i) - sigma <- add_sigma_se(sigma, prep, i = i) - rcontinuous( - n = prep$ndraws, dist = "student_t", - df = nu, mu = mu, sigma = sigma, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_lognormal <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "lnorm", - meanlog = get_dpar(prep, "mu", i = i), - sdlog = get_dpar(prep, "sigma", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_shifted_lognormal <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "shifted_lnorm", - meanlog = get_dpar(prep, "mu", i = i), - sdlog = get_dpar(prep, "sigma", i = i), - shift = get_dpar(prep, "ndt", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_skew_normal <- function(i, prep, ntrys = 5, ...) { - mu <- get_dpar(prep, "mu", i = i) - sigma <- get_dpar(prep, "sigma", i = i) - sigma <- add_sigma_se(sigma, prep, i = i) - alpha <- get_dpar(prep, "alpha", i = i) - rcontinuous( - n = prep$ndraws, dist = "skew_normal", - mu = mu, sigma = sigma, alpha = alpha, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_gaussian_mv <- function(i, prep, ...) { - Mu <- get_Mu(prep, i = i) - Sigma <- get_Sigma(prep, i = i) - .predict <- function(s) { - rmulti_normal(1, mu = Mu[s, ], Sigma = Sigma[s, , ]) - } - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_student_mv <- function(i, prep, ...) { - nu <- get_dpar(prep, "nu", i = i) - Mu <- get_Mu(prep, i = i) - Sigma <- get_Sigma(prep, i = i) - .predict <- function(s) { - rmulti_student_t(1, df = nu[s], mu = Mu[s, ], Sigma = Sigma[s, , ]) - } - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_gaussian_time <- function(i, prep, ...) { - obs <- with(prep$ac, begin_tg[i]:end_tg[i]) - mu <- as.matrix(get_dpar(prep, "mu", i = obs)) - Sigma <- get_cov_matrix_ac(prep, obs) - .predict <- function(s) { - rmulti_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ]) - } - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_student_time <- function(i, prep, ...) { - obs <- with(prep$ac, begin_tg[i]:end_tg[i]) - nu <- as.matrix(get_dpar(prep, "nu", i = obs)) - mu <- as.matrix(get_dpar(prep, "mu", i = obs)) - Sigma <- get_cov_matrix_ac(prep, obs) - .predict <- function(s) { - rmulti_student_t(1, df = nu[s, ], mu = mu[s, ], Sigma = Sigma[s, , ]) - } - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_gaussian_lagsar <- function(i, prep, ...) { - stopifnot(i == 1) - .predict <- function(s) { - M_new <- with(prep, diag(nobs) - ac$lagsar[s] * ac$Msar) - mu <- as.numeric(solve(M_new) %*% mu[s, ]) - Sigma <- solve(crossprod(M_new)) * sigma[s]^2 - rmulti_normal(1, mu = mu, Sigma = Sigma) - } - mu <- get_dpar(prep, "mu") - sigma <- get_dpar(prep, "sigma") - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_student_lagsar <- function(i, prep, ...) { - stopifnot(i == 1) - .predict <- function(s) { - M_new <- with(prep, diag(nobs) - ac$lagsar[s] * ac$Msar) - mu <- as.numeric(solve(M_new) %*% mu[s, ]) - Sigma <- solve(crossprod(M_new)) * sigma[s]^2 - rmulti_student_t(1, df = nu[s], mu = mu, Sigma = Sigma) - } - mu <- get_dpar(prep, "mu") - sigma <- get_dpar(prep, "sigma") - nu <- get_dpar(prep, "nu") - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_gaussian_errorsar <- function(i, prep, ...) { - stopifnot(i == 1) - .predict <- function(s) { - M_new <- with(prep, diag(nobs) - ac$errorsar[s] * ac$Msar) - Sigma <- solve(crossprod(M_new)) * sigma[s]^2 - rmulti_normal(1, mu = mu[s, ], Sigma = Sigma) - } - mu <- get_dpar(prep, "mu") - sigma <- get_dpar(prep, "sigma") - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_student_errorsar <- function(i, prep, ...) { - stopifnot(i == 1) - .predict <- function(s) { - M_new <- with(prep, diag(nobs) - ac$errorsar[s] * ac$Msar) - Sigma <- solve(crossprod(M_new)) * sigma[s]^2 - rmulti_student_t(1, df = nu[s], mu = mu[s, ], Sigma = Sigma) - } - mu <- get_dpar(prep, "mu") - sigma <- get_dpar(prep, "sigma") - nu <- get_dpar(prep, "nu") - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_gaussian_fcor <- function(i, prep, ...) { - stopifnot(i == 1) - mu <- as.matrix(get_dpar(prep, "mu")) - Sigma <- get_cov_matrix_ac(prep) - .predict <- function(s) { - rmulti_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ]) - } - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_student_fcor <- function(i, prep, ...) { - stopifnot(i == 1) - nu <- as.matrix(get_dpar(prep, "nu")) - mu <- as.matrix(get_dpar(prep, "mu")) - Sigma <- get_cov_matrix_ac(prep) - .predict <- function(s) { - rmulti_student_t(1, df = nu[s, ], mu = mu[s, ], Sigma = Sigma[s, , ]) - } - rblapply(seq_len(prep$ndraws), .predict) -} - -posterior_predict_binomial <- function(i, prep, ntrys = 5, ...) { - rdiscrete( - n = prep$ndraws, dist = "binom", - size = prep$data$trials[i], - prob = get_dpar(prep, "mu", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_bernoulli <- function(i, prep, ...) { - mu <- get_dpar(prep, "mu", i = i) - rbinom(length(mu), size = 1, prob = mu) -} - -posterior_predict_poisson <- function(i, prep, ntrys = 5, ...) { - mu <- get_dpar(prep, "mu", i) - mu <- multiply_dpar_rate_denom(mu, prep, i = i) - rdiscrete( - n = prep$ndraws, dist = "pois", lambda = mu, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_negbinomial <- function(i, prep, ntrys = 5, ...) { - mu <- get_dpar(prep, "mu", i) - mu <- multiply_dpar_rate_denom(mu, prep, i = i) - shape <- get_dpar(prep, "shape", i) - shape <- multiply_dpar_rate_denom(shape, prep, i = i) - rdiscrete( - n = prep$ndraws, dist = "nbinom", - mu = mu, size = shape, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_negbinomial2 <- function(i, prep, ntrys = 5, ...) { - mu <- get_dpar(prep, "mu", i) - mu <- multiply_dpar_rate_denom(mu, prep, i = i) - sigma <- get_dpar(prep, "sigma", i) - shape <- multiply_dpar_rate_denom(1 / sigma, prep, i = i) - rdiscrete( - n = prep$ndraws, dist = "nbinom", - mu = mu, size = shape, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_geometric <- function(i, prep, ntrys = 5, ...) { - mu <- get_dpar(prep, "mu", i) - mu <- multiply_dpar_rate_denom(mu, prep, i = i) - shape <- 1 - shape <- multiply_dpar_rate_denom(shape, prep, i = i) - rdiscrete( - n = prep$ndraws, dist = "nbinom", - mu = mu, size = shape, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_discrete_weibull <- function(i, prep, ntrys = 5, ...) { - rdiscrete( - n = prep$ndraws, dist = "discrete_weibull", - mu = get_dpar(prep, "mu", i = i), - shape = get_dpar(prep, "shape", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_com_poisson <- function(i, prep, ntrys = 5, ...) { - rdiscrete( - n = prep$ndraws, dist = "com_poisson", - mu = get_dpar(prep, "mu", i = i), - shape = get_dpar(prep, "shape", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_exponential <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "exp", - rate = 1 / get_dpar(prep, "mu", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_gamma <- function(i, prep, ntrys = 5, ...) { - shape <- get_dpar(prep, "shape", i = i) - scale <- get_dpar(prep, "mu", i = i) / shape - rcontinuous( - n = prep$ndraws, dist = "gamma", - shape = shape, scale = scale, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_weibull <- function(i, prep, ntrys = 5, ...) { - shape <- get_dpar(prep, "shape", i = i) - scale <- get_dpar(prep, "mu", i = i) / gamma(1 + 1 / shape) - rcontinuous( - n = prep$ndraws, dist = "weibull", - shape = shape, scale = scale, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_frechet <- function(i, prep, ntrys = 5, ...) { - nu <- get_dpar(prep, "nu", i = i) - scale <- get_dpar(prep, "mu", i = i) / gamma(1 - 1 / nu) - rcontinuous( - n = prep$ndraws, dist = "frechet", - scale = scale, shape = nu, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_gen_extreme_value <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "gen_extreme_value", - sigma = get_dpar(prep, "sigma", i = i), - xi = get_dpar(prep, "xi", i = i), - mu = get_dpar(prep, "mu", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_inverse.gaussian <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "inv_gaussian", - mu = get_dpar(prep, "mu", i = i), - shape = get_dpar(prep, "shape", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_exgaussian <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "exgaussian", - mu = get_dpar(prep, "mu", i = i), - sigma = get_dpar(prep, "sigma", i = i), - beta = get_dpar(prep, "beta", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_wiener <- function(i, prep, negative_rt = FALSE, ntrys = 5, - ...) { - out <- rcontinuous( - n = 1, dist = "wiener", - delta = get_dpar(prep, "mu", i = i), - alpha = get_dpar(prep, "bs", i = i), - tau = get_dpar(prep, "ndt", i = i), - beta = get_dpar(prep, "bias", i = i), - types = if (negative_rt) c("q", "resp") else "q", - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) - if (negative_rt) { - # code lower bound responses as negative RTs - out <- out[["q"]] * ifelse(out[["resp"]], 1, -1) - } - out -} - -posterior_predict_beta <- function(i, prep, ntrys = 5, ...) { - mu <- get_dpar(prep, "mu", i = i) - phi <- get_dpar(prep, "phi", i = i) - rcontinuous( - n = prep$ndraws, dist = "beta", - shape1 = mu * phi, shape2 = (1 - mu) * phi, - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_von_mises <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "von_mises", - mu = get_dpar(prep, "mu", i = i), - kappa = get_dpar(prep, "kappa", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_asym_laplace <- function(i, prep, ntrys = 5, ...) { - rcontinuous( - n = prep$ndraws, dist = "asym_laplace", - mu = get_dpar(prep, "mu", i = i), - sigma = get_dpar(prep, "sigma", i = i), - quantile = get_dpar(prep, "quantile", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) -} - -posterior_predict_zero_inflated_asym_laplace <- function(i, prep, ntrys = 5, - ...) { - zi <- get_dpar(prep, "zi", i = i) - tmp <- runif(prep$ndraws, 0, 1) - ifelse( - tmp < zi, 0, - rcontinuous( - n = prep$ndraws, dist = "asym_laplace", - mu = get_dpar(prep, "mu", i = i), - sigma = get_dpar(prep, "sigma", i = i), - quantile = get_dpar(prep, "quantile", i = i), - lb = prep$data$lb[i], ub = prep$data$ub[i], - ntrys = ntrys - ) - ) -} - -posterior_predict_cox <- function(i, prep, ...) { - stop2("Cannot sample from the posterior predictive ", - "distribution for family 'cox'.") -} - -posterior_predict_hurdle_poisson <- function(i, prep, ...) { - # theta is the bernoulli hurdle parameter - theta <- get_dpar(prep, "hu", i = i) - lambda <- get_dpar(prep, "mu", i = i) - ndraws <- prep$ndraws - # compare with theta to incorporate the hurdle process - hu <- runif(ndraws, 0, 1) - # sample from a truncated poisson distribution - # by adjusting lambda and adding 1 - t = -log(1 - runif(ndraws) * (1 - exp(-lambda))) - ifelse(hu < theta, 0, rpois(ndraws, lambda = lambda - t) + 1) -} - -posterior_predict_hurdle_negbinomial <- function(i, prep, ...) { - # theta is the bernoulli hurdle parameter - theta <- get_dpar(prep, "hu", i = i) - mu <- get_dpar(prep, "mu", i = i) - ndraws <- prep$ndraws - # compare with theta to incorporate the hurdle process - hu <- runif(ndraws, 0, 1) - # sample from an approximate(!) truncated negbinomial distribution - # by adjusting mu and adding 1 - t = -log(1 - runif(ndraws) * (1 - exp(-mu))) - shape <- get_dpar(prep, "shape", i = i) - ifelse(hu < theta, 0, rnbinom(ndraws, mu = mu - t, size = shape) + 1) -} - -posterior_predict_hurdle_gamma <- function(i, prep, ...) { - # theta is the bernoulli hurdle parameter - theta <- get_dpar(prep, "hu", i = i) - shape <- get_dpar(prep, "shape", i = i) - scale <- get_dpar(prep, "mu", i = i) / shape - ndraws <- prep$ndraws - # compare with theta to incorporate the hurdle process - hu <- runif(ndraws, 0, 1) - ifelse(hu < theta, 0, rgamma(ndraws, shape = shape, scale = scale)) -} - -posterior_predict_hurdle_lognormal <- function(i, prep, ...) { - # theta is the bernoulli hurdle parameter - theta <- get_dpar(prep, "hu", i = i) - mu <- get_dpar(prep, "mu", i = i) - sigma <- get_dpar(prep, "sigma", i = i) - ndraws <- prep$ndraws - # compare with theta to incorporate the hurdle process - hu <- runif(ndraws, 0, 1) - ifelse(hu < theta, 0, rlnorm(ndraws, meanlog = mu, sdlog = sigma)) -} - -posterior_predict_zero_inflated_beta <- function(i, prep, ...) { - # theta is the bernoulli hurdle parameter - theta <- get_dpar(prep, "zi", i = i) - mu <- get_dpar(prep, "mu", i = i) - phi <- get_dpar(prep, "phi", i = i) - # compare with theta to incorporate the hurdle process - hu <- runif(prep$ndraws, 0, 1) - ifelse( - hu < theta, 0, - rbeta(prep$ndraws, shape1 = mu * phi, shape2 = (1 - mu) * phi) - ) -} - -posterior_predict_zero_one_inflated_beta <- function(i, prep, ...) { - zoi <- get_dpar(prep, "zoi", i) - coi <- get_dpar(prep, "coi", i) - mu <- get_dpar(prep, "mu", i = i) - phi <- get_dpar(prep, "phi", i = i) - hu <- runif(prep$ndraws, 0, 1) - one_or_zero <- runif(prep$ndraws, 0, 1) - ifelse(hu < zoi, - ifelse(one_or_zero < coi, 1, 0), - rbeta(prep$ndraws, shape1 = mu * phi, shape2 = (1 - mu) * phi) - ) -} - -posterior_predict_zero_inflated_poisson <- function(i, prep, ...) { - # theta is the bernoulli zero-inflation parameter - theta <- get_dpar(prep, "zi", i = i) - lambda <- get_dpar(prep, "mu", i = i) - ndraws <- prep$ndraws - # compare with theta to incorporate the zero-inflation process - zi <- runif(ndraws, 0, 1) - ifelse(zi < theta, 0, rpois(ndraws, lambda = lambda)) -} - -posterior_predict_zero_inflated_negbinomial <- function(i, prep, ...) { - # theta is the bernoulli zero-inflation parameter - theta <- get_dpar(prep, "zi", i = i) - mu <- get_dpar(prep, "mu", i = i) - shape <- get_dpar(prep, "shape", i = i) - ndraws <- prep$ndraws - # compare with theta to incorporate the zero-inflation process - zi <- runif(ndraws, 0, 1) - ifelse(zi < theta, 0, rnbinom(ndraws, mu = mu, size = shape)) -} - -posterior_predict_zero_inflated_binomial <- function(i, prep, ...) { - # theta is the bernoulii zero-inflation parameter - theta <- get_dpar(prep, "zi", i = i) - trials <- prep$data$trials[i] - prob <- get_dpar(prep, "mu", i = i) - ndraws <- prep$ndraws - # compare with theta to incorporate the zero-inflation process - zi <- runif(ndraws, 0, 1) - ifelse(zi < theta, 0, rbinom(ndraws, size = trials, prob = prob)) -} - -posterior_predict_categorical <- function(i, prep, ...) { - eta <- cblapply(names(prep$dpars), get_dpar, prep = prep, i = i) - eta <- insert_refcat(eta, family = prep$family) - p <- pcategorical(seq_len(prep$data$ncat), eta = eta) - first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) -} - -posterior_predict_multinomial <- function(i, prep, ...) { - eta <- cblapply(names(prep$dpars), get_dpar, prep = prep, i = i) - eta <- insert_refcat(eta, family = prep$family) - p <- dcategorical(seq_len(prep$data$ncat), eta = eta) - size <- prep$data$trials[i] - out <- lapply(seq_rows(p), function(s) t(rmultinom(1, size, p[s, ]))) - do_call(rbind, out) -} - -posterior_predict_dirichlet <- function(i, prep, ...) { - mu_dpars <- str_subset(names(prep$dpars), "^mu") - eta <- cblapply(mu_dpars, get_dpar, prep = prep, i = i) - eta <- insert_refcat(eta, family = prep$family) - phi <- get_dpar(prep, "phi", i = i) - cats <- seq_len(prep$data$ncat) - alpha <- dcategorical(cats, eta = eta) * phi - rdirichlet(prep$ndraws, alpha = alpha) -} - -posterior_predict_dirichlet2 <- function(i, prep, ...) { - mu_dpars <- str_subset(names(prep$dpars), "^mu") - mu <- cblapply(mu_dpars, get_dpar, prep = prep, i = i) - rdirichlet(prep$ndraws, alpha = mu) -} - -posterior_predict_cumulative <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep) -} - -posterior_predict_sratio <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep) -} - -posterior_predict_cratio <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep) -} - -posterior_predict_acat <- function(i, prep, ...) { - posterior_predict_ordinal(i = i, prep = prep) -} - -posterior_predict_ordinal <- function(i, prep, ...) { - thres <- subset_thres(prep, i) - nthres <- NCOL(thres) - p <- pordinal( - seq_len(nthres + 1), - eta = get_dpar(prep, "mu", i = i), - disc = get_dpar(prep, "disc", i = i), - thres = thres, - family = prep$family$family, - link = prep$family$link - ) - first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) -} - -posterior_predict_custom <- function(i, prep, ...) { - custom_family_method(prep$family, "posterior_predict")(i, prep, ...) -} - -posterior_predict_mixture <- function(i, prep, ...) { - families <- family_names(prep$family) - theta <- get_theta(prep, i = i) - smix <- sample_mixture_ids(theta) - out <- rep(NA, prep$ndraws) - for (j in seq_along(families)) { - draw_ids <- which(smix == j) - if (length(draw_ids)) { - pp_fun <- paste0("posterior_predict_", families[j]) - pp_fun <- get(pp_fun, asNamespace("brms")) - tmp_prep <- pseudo_prep_for_mixture(prep, j, draw_ids) - out[draw_ids] <- pp_fun(i, tmp_prep, ...) - } - } - out -} - -# ------------ predict helper-functions ---------------------- -# random numbers from (possibly truncated) continuous distributions -# @param n number of random values to generate -# @param dist name of a distribution for which the functions -# p, q, and r are available -# @param ... additional arguments passed to the distribution functions -# @param ntrys number of trys in rejection sampling for truncated models -# @return vector of random values prep from the distribution -rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { - args <- list(...) - if (is.null(lb) && is.null(ub)) { - # sample as usual - rdist <- paste0("r", dist) - out <- do_call(rdist, c(list(n), args)) - } else { - # sample from truncated distribution - pdist <- paste0("p", dist) - qdist <- paste0("q", dist) - if (!exists(pdist, mode = "function") || !exists(qdist, mode = "function")) { - # use rejection sampling as CDF or quantile function are not available - out <- rdiscrete(n, dist, ..., lb = lb, ub = ub, ntrys = ntrys) - } else { - if (is.null(lb)) lb <- -Inf - if (is.null(ub)) ub <- Inf - plb <- do_call(pdist, c(list(lb), args)) - pub <- do_call(pdist, c(list(ub), args)) - out <- runif(n, min = plb, max = pub) - out <- do_call(qdist, c(list(out), args)) - # infinite values may be caused by numerical imprecision - out[out %in% c(-Inf, Inf)] <- NA - } - } - out -} - -# random numbers from (possibly truncated) discrete distributions -# currently rejection sampling is used for truncated distributions -# @param n number of random values to generate -# @param dist name of a distribution for which the functions -# p, q, and r are available -# @param ... additional arguments passed to the distribution functions -# @param lb optional lower truncation bound -# @param ub optional upper truncation bound -# @param ntrys number of trys in rejection sampling for truncated models -# @return a vector of random values draws from the distribution -rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { - args <- list(...) - rdist <- paste0("r", dist) - if (is.null(lb) && is.null(ub)) { - # sample as usual - out <- do_call(rdist, c(list(n), args)) - } else { - # sample from truncated distribution via rejection sampling - if (is.null(lb)) lb <- -Inf - if (is.null(ub)) ub <- Inf - out <- vector("list", ntrys) - for (i in seq_along(out)) { - # loop of the trys to prevent a mismatch between 'n' - # and length of the parameter vectors passed as arguments - out[[i]] <- as.vector(do_call(rdist, c(list(n), args))) - } - out <- do_call(cbind, out) - out <- apply(out, 1, extract_valid_sample, lb = lb, ub = ub) - } - out -} - -# sample from the IDs of the mixture components -sample_mixture_ids <- function(theta) { - stopifnot(is.matrix(theta)) - mix_comp <- seq_cols(theta) - ulapply(seq_rows(theta), function(s) - sample(mix_comp, 1, prob = theta[s, ]) - ) -} - -# extract the first valid predicted value per Stan sample per observation -# @param x draws to be check against truncation boundaries -# @param lb vector of lower bounds -# @param ub vector of upper bound -# @return a valid truncated sample or else the closest boundary -extract_valid_sample <- function(x, lb, ub) { - valid <- match(TRUE, x >= lb & x <= ub) - if (is.na(valid)) { - # no valid truncated value found - # set sample to lb or ub - # 1e-10 is only to identify the invalid draws later on - out <- ifelse(max(x) < lb, lb - 1e-10, ub + 1e-10) - } else { - out <- x[valid] - } - out -} - -# check for invalid predictions of truncated discrete models -# @param x matrix of predicted values -# @param lb optional lower truncation bound -# @param ub optional upper truncation bound -# @param thres threshold (in %) of invalid values at which to warn the user -# @return rounded values of 'x' -check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { - if (is.null(lb) && is.null(ub)) { - return(x) - } - if (is.null(lb)) lb <- -Inf - if (is.null(ub)) ub <- Inf - thres <- as_one_numeric(thres) - # ensure correct comparison with vector bounds - y <- as.vector(t(x)) - pct_invalid <- mean(y < lb | y > ub, na.rm = TRUE) - if (pct_invalid >= thres) { - warning2( - round(pct_invalid * 100), "% of all predicted values ", - "were invalid. Increasing argument 'ntrys' may help." - ) - } - round(x) -} +#' Draws from the Posterior Predictive Distribution +#' +#' Compute posterior draws of the posterior predictive distribution. Can be +#' performed for the data used to fit the model (posterior predictive checks) or +#' for new data. By definition, these draws have higher variance than draws +#' of the means of the posterior predictive distribution computed by +#' \code{\link{posterior_epred.brmsfit}}. This is because the residual error +#' is incorporated in \code{posterior_predict}. However, the estimated means of +#' both methods averaged across draws should be very similar. +#' +#' @inheritParams prepare_predictions +#' @param object An object of class \code{brmsfit}. +#' @param re.form Alias of \code{re_formula}. +#' @param transform (Deprecated) A function or a character string naming +#' a function to be applied on the predicted responses +#' before summary statistics are computed. +#' @param negative_rt Only relevant for Wiener diffusion models. +#' A flag indicating whether response times of responses +#' on the lower boundary should be returned as negative values. +#' This allows to distinguish responses on the upper and +#' lower boundary. Defaults to \code{FALSE}. +#' @param sort Logical. Only relevant for time series models. +#' Indicating whether to return predicted values in the original +#' order (\code{FALSE}; default) or in the order of the +#' time series (\code{TRUE}). +#' @param ntrys Parameter used in rejection sampling +#' for truncated discrete models only +#' (defaults to \code{5}). See Details for more information. +#' @param cores Number of cores (defaults to \code{1}). On non-Windows systems, +#' this argument can be set globally via the \code{mc.cores} option. +#' @param ... Further arguments passed to \code{\link{prepare_predictions}} +#' that control several aspects of data validation and prediction. +#' +#' @return An \code{array} of predicted response values. In univariate models, +#' the output is as an S x N matrix, where S is the number of posterior +#' draws and N is the number of observations. In multivariate models, an +#' additional dimension is added to the output which indexes along the +#' different response variables. +#' +#' @template details-newdata-na +#' @template details-allow_new_levels +#' @details For truncated discrete models only: In the absence of any general +#' algorithm to sample from truncated discrete distributions, rejection +#' sampling is applied in this special case. This means that values are +#' sampled until a value lies within the defined truncation boundaries. In +#' practice, this procedure may be rather slow (especially in \R). Thus, we +#' try to do approximate rejection sampling by sampling each value +#' \code{ntrys} times and then select a valid value. If all values are +#' invalid, the closest boundary is used, instead. If there are more than a +#' few of these pathological cases, a warning will occur suggesting to +#' increase argument \code{ntrys}. +#' +#' @examples +#' \dontrun{ +#' ## fit a model +#' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), +#' data = kidney, family = "exponential", init = "0") +#' +#' ## predicted responses +#' pp <- posterior_predict(fit) +#' str(pp) +#' +#' ## predicted responses excluding the group-level effect of age +#' pp <- posterior_predict(fit, re_formula = ~ (1 | patient)) +#' str(pp) +#' +#' ## predicted responses of patient 1 for new data +#' newdata <- data.frame( +#' sex = factor(c("male", "female")), +#' age = c(20, 50), +#' patient = c(1, 1) +#' ) +#' pp <- posterior_predict(fit, newdata = newdata) +#' str(pp) +#' } +#' +#' @aliases posterior_predict +#' @method posterior_predict brmsfit +#' @importFrom rstantools posterior_predict +#' @export +#' @export posterior_predict +posterior_predict.brmsfit <- function( + object, newdata = NULL, re_formula = NULL, re.form = NULL, + transform = NULL, resp = NULL, negative_rt = FALSE, + ndraws = NULL, draw_ids = NULL, sort = FALSE, ntrys = 5, + cores = NULL, ... +) { + cl <- match.call() + if ("re.form" %in% names(cl)) { + re_formula <- re.form + } + contains_draws(object) + object <- restructure(object) + prep <- prepare_predictions( + object, newdata = newdata, re_formula = re_formula, resp = resp, + ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... + ) + posterior_predict( + prep, transform = transform, sort = sort, ntrys = ntrys, + negative_rt = negative_rt, cores = cores, summary = FALSE + ) +} + +#' @export +posterior_predict.mvbrmsprep <- function(object, ...) { + if (length(object$mvpars$rescor)) { + object$mvpars$Mu <- get_Mu(object) + object$mvpars$Sigma <- get_Sigma(object) + out <- posterior_predict.brmsprep(object, ...) + } else { + out <- lapply(object$resps, posterior_predict, ...) + along <- ifelse(length(out) > 1L, 3, 2) + out <- do_call(abind, c(out, along = along)) + } + out +} + +#' @export +posterior_predict.brmsprep <- function(object, transform = NULL, sort = FALSE, + summary = FALSE, robust = FALSE, + probs = c(0.025, 0.975), + cores = NULL, ...) { + summary <- as_one_logical(summary) + cores <- validate_cores_post_processing(cores) + if (is.customfamily(object$family)) { + # ensure that the method can be found during parallel execution + object$family$posterior_predict <- + custom_family_method(object$family, "posterior_predict") + } + for (nlp in names(object$nlpars)) { + object$nlpars[[nlp]] <- get_nlpar(object, nlpar = nlp) + } + for (dp in names(object$dpars)) { + object$dpars[[dp]] <- get_dpar(object, dpar = dp) + } + pp_fun <- paste0("posterior_predict_", object$family$fun) + pp_fun <- get(pp_fun, asNamespace("brms")) + N <- choose_N(object) + out <- plapply(seq_len(N), pp_fun, cores = cores, prep = object, ...) + if (grepl("_mv$", object$family$fun)) { + out <- do_call(abind, c(out, along = 3)) + out <- aperm(out, perm = c(1, 3, 2)) + dimnames(out)[[3]] <- names(object$resps) + } else if (has_multicol(object$family)) { + out <- do_call(abind, c(out, along = 3)) + out <- aperm(out, perm = c(1, 3, 2)) + dimnames(out)[[3]] <- object$cats + } else { + out <- do_call(cbind, out) + } + colnames(out) <- rownames(out) <- NULL + if (use_int(object$family)) { + out <- check_discrete_trunc_bounds( + out, lb = object$data$lb, ub = object$data$ub + ) + } + out <- reorder_obs(out, object$old_order, sort = sort) + # transform predicted response draws before summarizing them + if (!is.null(transform)) { + # deprecated as of brms 2.12.3 + warning2("Argument 'transform' is deprecated ", + "and will be removed in the future.") + out <- do_call(transform, list(out)) + } + attr(out, "levels") <- object$cats + if (summary) { + # only for compatibility with the 'predict' method + if (is_ordinal(object$family)) { + levels <- seq_len(max(object$data$nthres) + 1) + out <- posterior_table(out, levels = levels) + } else if (is_categorical(object$family)) { + levels <- seq_len(object$data$ncat) + out <- posterior_table(out, levels = levels) + } else { + out <- posterior_summary(out, probs = probs, robust = robust) + } + } + out +} + +#' Draws from the Posterior Predictive Distribution +#' +#' This method is an alias of \code{\link{posterior_predict.brmsfit}} +#' with additional arguments for obtaining summaries of the computed draws. +#' +#' @inheritParams posterior_predict.brmsfit +#' @param summary Should summary statistics be returned +#' instead of the raw values? Default is \code{TRUE}. +#' @param robust If \code{FALSE} (the default) the mean is used as +#' the measure of central tendency and the standard deviation as +#' the measure of variability. If \code{TRUE}, the median and the +#' median absolute deviation (MAD) are applied instead. +#' Only used if \code{summary} is \code{TRUE}. +#' @param probs The percentiles to be computed by the \code{quantile} +#' function. Only used if \code{summary} is \code{TRUE}. +#' +#' @return An \code{array} of predicted response values. +#' If \code{summary = FALSE} the output resembles those of +#' \code{\link{posterior_predict.brmsfit}}. +#' +#' If \code{summary = TRUE} the output depends on the family: For categorical +#' and ordinal families, the output is an N x C matrix, where N is the number +#' of observations, C is the number of categories, and the values are +#' predicted category probabilities. For all other families, the output is a N +#' x E matrix where E = \code{2 + length(probs)} is the number of summary +#' statistics: The \code{Estimate} column contains point estimates (either +#' mean or median depending on argument \code{robust}), while the +#' \code{Est.Error} column contains uncertainty estimates (either standard +#' deviation or median absolute deviation depending on argument +#' \code{robust}). The remaining columns starting with \code{Q} contain +#' quantile estimates as specified via argument \code{probs}. +#' +#' @seealso \code{\link{posterior_predict.brmsfit}} +#' +#' @examples +#' \dontrun{ +#' ## fit a model +#' fit <- brm(time | cens(censored) ~ age + sex + (1 + age || patient), +#' data = kidney, family = "exponential", init = "0") +#' +#' ## predicted responses +#' pp <- predict(fit) +#' head(pp) +#' +#' ## predicted responses excluding the group-level effect of age +#' pp <- predict(fit, re_formula = ~ (1 | patient)) +#' head(pp) +#' +#' ## predicted responses of patient 1 for new data +#' newdata <- data.frame( +#' sex = factor(c("male", "female")), +#' age = c(20, 50), +#' patient = c(1, 1) +#' ) +#' predict(fit, newdata = newdata) +#' } +#' +#' @export +predict.brmsfit <- function(object, newdata = NULL, re_formula = NULL, + transform = NULL, resp = NULL, + negative_rt = FALSE, ndraws = NULL, draw_ids = NULL, + sort = FALSE, ntrys = 5, cores = NULL, summary = TRUE, + robust = FALSE, probs = c(0.025, 0.975), ...) { + contains_draws(object) + object <- restructure(object) + prep <- prepare_predictions( + object, newdata = newdata, re_formula = re_formula, resp = resp, + ndraws = ndraws, draw_ids = draw_ids, check_response = FALSE, ... + ) + posterior_predict( + prep, transform = transform, ntrys = ntrys, negative_rt = negative_rt, + sort = sort, cores = cores, summary = summary, robust = robust, + probs = probs + ) +} + +#' Predictive Intervals +#' +#' Compute intervals from the posterior predictive distribution. +#' +#' @aliases predictive_interval +#' +#' @param object An \R object of class \code{brmsfit}. +#' @param prob A number p (0 < p < 1) indicating the desired probability mass to +#' include in the intervals. Defaults to \code{0.9}. +#' @param ... Further arguments passed to \code{\link{posterior_predict}}. +#' +#' @return A matrix with 2 columns for the lower and upper bounds of the +#' intervals, respectively, and as many rows as observations being predicted. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zBase, data = epilepsy, family = poisson()) +#' predictive_interval(fit) +#' } +#' +#' @importFrom rstantools predictive_interval +#' @export predictive_interval +#' @export +predictive_interval.brmsfit <- function(object, prob = 0.9, ...) { + out <- posterior_predict(object, ...) + predictive_interval(out, prob = prob) +} + +# validate method name to obtain posterior predictions +# @param method name of the method +# @return validated name of the method +validate_pp_method <- function(method) { + method <- as_one_character(method) + if (method %in% c("posterior_predict", "predict", "pp")) { + method <- "posterior_predict" + } else if (method %in% c("posterior_epred", "fitted", "pp_expect")) { + method <- "posterior_epred" + } else if (method %in% c("posterior_linpred")) { + method <- "posterior_linpred" + } else if (method %in% c("predictive_error", "residuals")) { + method <- "predictive_error" + } else { + stop2("Posterior predictive method '", method, "' it not supported.") + } + method +} + +# ------------------- family specific posterior_predict methods --------------------- +# All posterior_predict_ functions have the same arguments structure +# @param i index of the observatio for which to compute pp values +# @param prep A named list returned by prepare_predictions containing +# all required data and posterior draws +# @param ... ignored arguments +# @param A vector of length prep$ndraws containing draws +# from the posterior predictive distribution +posterior_predict_gaussian <- function(i, prep, ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + sigma <- add_sigma_se(sigma, prep, i = i) + rcontinuous( + n = prep$ndraws, dist = "norm", + mean = mu, sd = sigma, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_student <- function(i, prep, ntrys = 5, ...) { + nu <- get_dpar(prep, "nu", i = i) + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + sigma <- add_sigma_se(sigma, prep, i = i) + rcontinuous( + n = prep$ndraws, dist = "student_t", + df = nu, mu = mu, sigma = sigma, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_lognormal <- function(i, prep, ntrys = 5, ...) { + rcontinuous( + n = prep$ndraws, dist = "lnorm", + meanlog = get_dpar(prep, "mu", i = i), + sdlog = get_dpar(prep, "sigma", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_shifted_lognormal <- function(i, prep, ntrys = 5, ...) { + rcontinuous( + n = prep$ndraws, dist = "shifted_lnorm", + meanlog = get_dpar(prep, "mu", i = i), + sdlog = get_dpar(prep, "sigma", i = i), + shift = get_dpar(prep, "ndt", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_skew_normal <- function(i, prep, ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + sigma <- add_sigma_se(sigma, prep, i = i) + alpha <- get_dpar(prep, "alpha", i = i) + rcontinuous( + n = prep$ndraws, dist = "skew_normal", + mu = mu, sigma = sigma, alpha = alpha, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_gaussian_mv <- function(i, prep, ...) { + Mu <- get_Mu(prep, i = i) + Sigma <- get_Sigma(prep, i = i) + .predict <- function(s) { + rmulti_normal(1, mu = Mu[s, ], Sigma = Sigma[s, , ]) + } + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_student_mv <- function(i, prep, ...) { + nu <- get_dpar(prep, "nu", i = i) + Mu <- get_Mu(prep, i = i) + Sigma <- get_Sigma(prep, i = i) + .predict <- function(s) { + rmulti_student_t(1, df = nu[s], mu = Mu[s, ], Sigma = Sigma[s, , ]) + } + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_gaussian_time <- function(i, prep, ...) { + obs <- with(prep$ac, begin_tg[i]:end_tg[i]) + mu <- as.matrix(get_dpar(prep, "mu", i = obs)) + Sigma <- get_cov_matrix_ac(prep, obs) + .predict <- function(s) { + rmulti_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ]) + } + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_student_time <- function(i, prep, ...) { + obs <- with(prep$ac, begin_tg[i]:end_tg[i]) + nu <- as.matrix(get_dpar(prep, "nu", i = obs)) + mu <- as.matrix(get_dpar(prep, "mu", i = obs)) + Sigma <- get_cov_matrix_ac(prep, obs) + .predict <- function(s) { + rmulti_student_t(1, df = nu[s, ], mu = mu[s, ], Sigma = Sigma[s, , ]) + } + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_gaussian_lagsar <- function(i, prep, ...) { + stopifnot(i == 1) + .predict <- function(s) { + M_new <- with(prep, diag(nobs) - ac$lagsar[s] * ac$Msar) + mu <- as.numeric(solve(M_new) %*% mu[s, ]) + Sigma <- solve(crossprod(M_new)) * sigma[s]^2 + rmulti_normal(1, mu = mu, Sigma = Sigma) + } + mu <- get_dpar(prep, "mu") + sigma <- get_dpar(prep, "sigma") + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_student_lagsar <- function(i, prep, ...) { + stopifnot(i == 1) + .predict <- function(s) { + M_new <- with(prep, diag(nobs) - ac$lagsar[s] * ac$Msar) + mu <- as.numeric(solve(M_new) %*% mu[s, ]) + Sigma <- solve(crossprod(M_new)) * sigma[s]^2 + rmulti_student_t(1, df = nu[s], mu = mu, Sigma = Sigma) + } + mu <- get_dpar(prep, "mu") + sigma <- get_dpar(prep, "sigma") + nu <- get_dpar(prep, "nu") + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_gaussian_errorsar <- function(i, prep, ...) { + stopifnot(i == 1) + .predict <- function(s) { + M_new <- with(prep, diag(nobs) - ac$errorsar[s] * ac$Msar) + Sigma <- solve(crossprod(M_new)) * sigma[s]^2 + rmulti_normal(1, mu = mu[s, ], Sigma = Sigma) + } + mu <- get_dpar(prep, "mu") + sigma <- get_dpar(prep, "sigma") + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_student_errorsar <- function(i, prep, ...) { + stopifnot(i == 1) + .predict <- function(s) { + M_new <- with(prep, diag(nobs) - ac$errorsar[s] * ac$Msar) + Sigma <- solve(crossprod(M_new)) * sigma[s]^2 + rmulti_student_t(1, df = nu[s], mu = mu[s, ], Sigma = Sigma) + } + mu <- get_dpar(prep, "mu") + sigma <- get_dpar(prep, "sigma") + nu <- get_dpar(prep, "nu") + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_gaussian_fcor <- function(i, prep, ...) { + stopifnot(i == 1) + mu <- as.matrix(get_dpar(prep, "mu")) + Sigma <- get_cov_matrix_ac(prep) + .predict <- function(s) { + rmulti_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ]) + } + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_student_fcor <- function(i, prep, ...) { + stopifnot(i == 1) + nu <- as.matrix(get_dpar(prep, "nu")) + mu <- as.matrix(get_dpar(prep, "mu")) + Sigma <- get_cov_matrix_ac(prep) + .predict <- function(s) { + rmulti_student_t(1, df = nu[s, ], mu = mu[s, ], Sigma = Sigma[s, , ]) + } + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_binomial <- function(i, prep, ntrys = 5, ...) { + rdiscrete( + n = prep$ndraws, dist = "binom", + size = prep$data$trials[i], + prob = get_dpar(prep, "mu", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_beta_binomial <- function(i, prep, ntrys = 5, ...) { + rdiscrete( + n = prep$ndraws, dist = "beta_binomial", + size = prep$data$trials[i], + mu = get_dpar(prep, "mu", i = i), + phi = get_dpar(prep, "phi", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_bernoulli <- function(i, prep, ...) { + mu <- get_dpar(prep, "mu", i = i) + rbinom(length(mu), size = 1, prob = mu) +} + +posterior_predict_poisson <- function(i, prep, ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) + rdiscrete( + n = prep$ndraws, dist = "pois", lambda = mu, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_negbinomial <- function(i, prep, ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) + shape <- get_dpar(prep, "shape", i) + shape <- multiply_dpar_rate_denom(shape, prep, i = i) + rdiscrete( + n = prep$ndraws, dist = "nbinom", + mu = mu, size = shape, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_negbinomial2 <- function(i, prep, ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) + sigma <- get_dpar(prep, "sigma", i) + shape <- multiply_dpar_rate_denom(1 / sigma, prep, i = i) + rdiscrete( + n = prep$ndraws, dist = "nbinom", + mu = mu, size = shape, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_geometric <- function(i, prep, ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i) + mu <- multiply_dpar_rate_denom(mu, prep, i = i) + shape <- 1 + shape <- multiply_dpar_rate_denom(shape, prep, i = i) + rdiscrete( + n = prep$ndraws, dist = "nbinom", + mu = mu, size = shape, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_discrete_weibull <- function(i, prep, ntrys = 5, ...) { + rdiscrete( + n = prep$ndraws, dist = "discrete_weibull", + mu = get_dpar(prep, "mu", i = i), + shape = get_dpar(prep, "shape", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_com_poisson <- function(i, prep, ntrys = 5, ...) { + rdiscrete( + n = prep$ndraws, dist = "com_poisson", + mu = get_dpar(prep, "mu", i = i), + shape = get_dpar(prep, "shape", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_exponential <- function(i, prep, ntrys = 5, ...) { + rcontinuous( + n = prep$ndraws, dist = "exp", + rate = 1 / get_dpar(prep, "mu", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_gamma <- function(i, prep, ntrys = 5, ...) { + shape <- get_dpar(prep, "shape", i = i) + scale <- get_dpar(prep, "mu", i = i) / shape + rcontinuous( + n = prep$ndraws, dist = "gamma", + shape = shape, scale = scale, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_weibull <- function(i, prep, ntrys = 5, ...) { + shape <- get_dpar(prep, "shape", i = i) + scale <- get_dpar(prep, "mu", i = i) / gamma(1 + 1 / shape) + rcontinuous( + n = prep$ndraws, dist = "weibull", + shape = shape, scale = scale, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_frechet <- function(i, prep, ntrys = 5, ...) { + nu <- get_dpar(prep, "nu", i = i) + scale <- get_dpar(prep, "mu", i = i) / gamma(1 - 1 / nu) + rcontinuous( + n = prep$ndraws, dist = "frechet", + scale = scale, shape = nu, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_gen_extreme_value <- function(i, prep, ntrys = 5, ...) { + rcontinuous( + n = prep$ndraws, dist = "gen_extreme_value", + sigma = get_dpar(prep, "sigma", i = i), + xi = get_dpar(prep, "xi", i = i), + mu = get_dpar(prep, "mu", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_inverse.gaussian <- function(i, prep, ntrys = 5, ...) { + rcontinuous( + n = prep$ndraws, dist = "inv_gaussian", + mu = get_dpar(prep, "mu", i = i), + shape = get_dpar(prep, "shape", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_exgaussian <- function(i, prep, ntrys = 5, ...) { + rcontinuous( + n = prep$ndraws, dist = "exgaussian", + mu = get_dpar(prep, "mu", i = i), + sigma = get_dpar(prep, "sigma", i = i), + beta = get_dpar(prep, "beta", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_wiener <- function(i, prep, negative_rt = FALSE, ntrys = 5, + ...) { + out <- rcontinuous( + n = 1, dist = "wiener", + delta = get_dpar(prep, "mu", i = i), + alpha = get_dpar(prep, "bs", i = i), + tau = get_dpar(prep, "ndt", i = i), + beta = get_dpar(prep, "bias", i = i), + types = if (negative_rt) c("q", "resp") else "q", + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) + if (negative_rt) { + # code lower bound responses as negative RTs + out <- out[["q"]] * ifelse(out[["resp"]], 1, -1) + } + out +} + +posterior_predict_beta <- function(i, prep, ntrys = 5, ...) { + mu <- get_dpar(prep, "mu", i = i) + phi <- get_dpar(prep, "phi", i = i) + rcontinuous( + n = prep$ndraws, dist = "beta", + shape1 = mu * phi, shape2 = (1 - mu) * phi, + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_von_mises <- function(i, prep, ntrys = 5, ...) { + rcontinuous( + n = prep$ndraws, dist = "von_mises", + mu = get_dpar(prep, "mu", i = i), + kappa = get_dpar(prep, "kappa", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_asym_laplace <- function(i, prep, ntrys = 5, ...) { + rcontinuous( + n = prep$ndraws, dist = "asym_laplace", + mu = get_dpar(prep, "mu", i = i), + sigma = get_dpar(prep, "sigma", i = i), + quantile = get_dpar(prep, "quantile", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) +} + +posterior_predict_zero_inflated_asym_laplace <- function(i, prep, ntrys = 5, + ...) { + zi <- get_dpar(prep, "zi", i = i) + tmp <- runif(prep$ndraws, 0, 1) + ifelse( + tmp < zi, 0, + rcontinuous( + n = prep$ndraws, dist = "asym_laplace", + mu = get_dpar(prep, "mu", i = i), + sigma = get_dpar(prep, "sigma", i = i), + quantile = get_dpar(prep, "quantile", i = i), + lb = prep$data$lb[i], ub = prep$data$ub[i], + ntrys = ntrys + ) + ) +} + +posterior_predict_cox <- function(i, prep, ...) { + stop2("Cannot sample from the posterior predictive ", + "distribution for family 'cox'.") +} + +posterior_predict_hurdle_poisson <- function(i, prep, ...) { + # theta is the bernoulli hurdle parameter + theta <- get_dpar(prep, "hu", i = i) + lambda <- get_dpar(prep, "mu", i = i) + ndraws <- prep$ndraws + # compare with theta to incorporate the hurdle process + hu <- runif(ndraws, 0, 1) + # sample from a truncated poisson distribution + # by adjusting lambda and adding 1 + t = -log(1 - runif(ndraws) * (1 - exp(-lambda))) + ifelse(hu < theta, 0, rpois(ndraws, lambda = lambda - t) + 1) +} + +posterior_predict_hurdle_negbinomial <- function(i, prep, ...) { + # theta is the bernoulli hurdle parameter + theta <- get_dpar(prep, "hu", i = i) + mu <- get_dpar(prep, "mu", i = i) + ndraws <- prep$ndraws + # compare with theta to incorporate the hurdle process + hu <- runif(ndraws, 0, 1) + # sample from an approximate(!) truncated negbinomial distribution + # by adjusting mu and adding 1 + t = -log(1 - runif(ndraws) * (1 - exp(-mu))) + shape <- get_dpar(prep, "shape", i = i) + ifelse(hu < theta, 0, rnbinom(ndraws, mu = mu - t, size = shape) + 1) +} + +posterior_predict_hurdle_gamma <- function(i, prep, ...) { + # theta is the bernoulli hurdle parameter + theta <- get_dpar(prep, "hu", i = i) + shape <- get_dpar(prep, "shape", i = i) + scale <- get_dpar(prep, "mu", i = i) / shape + ndraws <- prep$ndraws + # compare with theta to incorporate the hurdle process + hu <- runif(ndraws, 0, 1) + ifelse(hu < theta, 0, rgamma(ndraws, shape = shape, scale = scale)) +} + +posterior_predict_hurdle_lognormal <- function(i, prep, ...) { + # theta is the bernoulli hurdle parameter + theta <- get_dpar(prep, "hu", i = i) + mu <- get_dpar(prep, "mu", i = i) + sigma <- get_dpar(prep, "sigma", i = i) + ndraws <- prep$ndraws + # compare with theta to incorporate the hurdle process + hu <- runif(ndraws, 0, 1) + ifelse(hu < theta, 0, rlnorm(ndraws, meanlog = mu, sdlog = sigma)) +} + +posterior_predict_zero_inflated_beta <- function(i, prep, ...) { + # theta is the bernoulli hurdle parameter + theta <- get_dpar(prep, "zi", i = i) + mu <- get_dpar(prep, "mu", i = i) + phi <- get_dpar(prep, "phi", i = i) + # compare with theta to incorporate the hurdle process + hu <- runif(prep$ndraws, 0, 1) + ifelse( + hu < theta, 0, + rbeta(prep$ndraws, shape1 = mu * phi, shape2 = (1 - mu) * phi) + ) +} + +posterior_predict_zero_one_inflated_beta <- function(i, prep, ...) { + zoi <- get_dpar(prep, "zoi", i) + coi <- get_dpar(prep, "coi", i) + mu <- get_dpar(prep, "mu", i = i) + phi <- get_dpar(prep, "phi", i = i) + hu <- runif(prep$ndraws, 0, 1) + one_or_zero <- runif(prep$ndraws, 0, 1) + ifelse(hu < zoi, + ifelse(one_or_zero < coi, 1, 0), + rbeta(prep$ndraws, shape1 = mu * phi, shape2 = (1 - mu) * phi) + ) +} + +posterior_predict_zero_inflated_poisson <- function(i, prep, ...) { + # theta is the bernoulli zero-inflation parameter + theta <- get_dpar(prep, "zi", i = i) + lambda <- get_dpar(prep, "mu", i = i) + ndraws <- prep$ndraws + # compare with theta to incorporate the zero-inflation process + zi <- runif(ndraws, 0, 1) + ifelse(zi < theta, 0, rpois(ndraws, lambda = lambda)) +} + +posterior_predict_zero_inflated_negbinomial <- function(i, prep, ...) { + # theta is the bernoulli zero-inflation parameter + theta <- get_dpar(prep, "zi", i = i) + mu <- get_dpar(prep, "mu", i = i) + shape <- get_dpar(prep, "shape", i = i) + ndraws <- prep$ndraws + # compare with theta to incorporate the zero-inflation process + zi <- runif(ndraws, 0, 1) + ifelse(zi < theta, 0, rnbinom(ndraws, mu = mu, size = shape)) +} + +posterior_predict_zero_inflated_binomial <- function(i, prep, ...) { + # theta is the bernoulli zero-inflation parameter + theta <- get_dpar(prep, "zi", i = i) + trials <- prep$data$trials[i] + prob <- get_dpar(prep, "mu", i = i) + ndraws <- prep$ndraws + # compare with theta to incorporate the zero-inflation process + zi <- runif(ndraws, 0, 1) + ifelse(zi < theta, 0, rbinom(ndraws, size = trials, prob = prob)) +} + +posterior_predict_zero_inflated_beta_binomial <- function(i, prep, ...) { + # theta is the bernoulli zero-inflation parameter + theta <- get_dpar(prep, "zi", i = i) + trials <- prep$data$trials[i] + mu <- get_dpar(prep, "mu", i = i) + phi <- get_dpar(prep, "phi", i = i) + ndraws <- prep$ndraws + draws <- rbeta_binomial(ndraws, size = trials, mu = mu, phi = phi) + # compare with theta to incorporate the zero-inflation process + zi <- runif(ndraws, 0, 1) + draws[zi < theta] <- 0 + draws +} + +posterior_predict_categorical <- function(i, prep, ...) { + eta <- get_Mu(prep, i = i) + eta <- insert_refcat(eta, refcat = prep$refcat) + p <- pcategorical(seq_len(prep$data$ncat), eta = eta) + first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) +} + +posterior_predict_multinomial <- function(i, prep, ...) { + eta <- get_Mu(prep, i = i) + eta <- insert_refcat(eta, refcat = prep$refcat) + p <- dcategorical(seq_len(prep$data$ncat), eta = eta) + size <- prep$data$trials[i] + rblapply(seq_rows(p), function(s) t(rmultinom(1, size, p[s, ]))) +} + +posterior_predict_dirichlet <- function(i, prep, ...) { + eta <- get_Mu(prep, i = i) + eta <- insert_refcat(eta, refcat = prep$refcat) + phi <- get_dpar(prep, "phi", i = i) + cats <- seq_len(prep$data$ncat) + alpha <- dcategorical(cats, eta = eta) * phi + rdirichlet(prep$ndraws, alpha = alpha) +} + +posterior_predict_dirichlet2 <- function(i, prep, ...) { + mu <- get_Mu(prep, i = i) + rdirichlet(prep$ndraws, alpha = mu) +} + +posterior_predict_logistic_normal <- function(i, prep, ...) { + mu <- get_Mu(prep, i = i) + Sigma <- get_Sigma(prep, i = i, cor_name = "lncor") + .predict <- function(s) { + rlogistic_normal(1, mu = mu[s, ], Sigma = Sigma[s, , ], + refcat = prep$refcat) + } + rblapply(seq_len(prep$ndraws), .predict) +} + +posterior_predict_cumulative <- function(i, prep, ...) { + posterior_predict_ordinal(i = i, prep = prep) +} + +posterior_predict_sratio <- function(i, prep, ...) { + posterior_predict_ordinal(i = i, prep = prep) +} + +posterior_predict_cratio <- function(i, prep, ...) { + posterior_predict_ordinal(i = i, prep = prep) +} + +posterior_predict_acat <- function(i, prep, ...) { + posterior_predict_ordinal(i = i, prep = prep) +} + +posterior_predict_ordinal <- function(i, prep, ...) { + thres <- subset_thres(prep, i) + nthres <- NCOL(thres) + p <- pordinal( + seq_len(nthres + 1), + eta = get_dpar(prep, "mu", i = i), + disc = get_dpar(prep, "disc", i = i), + thres = thres, + family = prep$family$family, + link = prep$family$link + ) + first_greater(p, target = runif(prep$ndraws, min = 0, max = 1)) +} + +posterior_predict_custom <- function(i, prep, ...) { + custom_family_method(prep$family, "posterior_predict")(i, prep, ...) +} + +posterior_predict_mixture <- function(i, prep, ...) { + families <- family_names(prep$family) + theta <- get_theta(prep, i = i) + smix <- sample_mixture_ids(theta) + out <- rep(NA, prep$ndraws) + for (j in seq_along(families)) { + draw_ids <- which(smix == j) + if (length(draw_ids)) { + pp_fun <- paste0("posterior_predict_", families[j]) + pp_fun <- get(pp_fun, asNamespace("brms")) + tmp_prep <- pseudo_prep_for_mixture(prep, j, draw_ids) + out[draw_ids] <- pp_fun(i, tmp_prep, ...) + } + } + out +} + +# ------------ predict helper-functions ---------------------- +# random numbers from (possibly truncated) continuous distributions +# @param n number of random values to generate +# @param dist name of a distribution for which the functions +# p, q, and r are available +# @param ... additional arguments passed to the distribution functions +# @param ntrys number of trys in rejection sampling for truncated models +# @return vector of random values prep from the distribution +rcontinuous <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { + args <- list(...) + if (is.null(lb) && is.null(ub)) { + # sample as usual + rdist <- paste0("r", dist) + out <- do_call(rdist, c(list(n), args)) + } else { + # sample from truncated distribution + pdist <- paste0("p", dist) + qdist <- paste0("q", dist) + if (!exists(pdist, mode = "function") || !exists(qdist, mode = "function")) { + # use rejection sampling as CDF or quantile function are not available + out <- rdiscrete(n, dist, ..., lb = lb, ub = ub, ntrys = ntrys) + } else { + if (is.null(lb)) lb <- -Inf + if (is.null(ub)) ub <- Inf + plb <- do_call(pdist, c(list(lb), args)) + pub <- do_call(pdist, c(list(ub), args)) + out <- runif(n, min = plb, max = pub) + out <- do_call(qdist, c(list(out), args)) + # infinite values may be caused by numerical imprecision + out[out %in% c(-Inf, Inf)] <- NA + } + } + out +} + +# random numbers from (possibly truncated) discrete distributions +# currently rejection sampling is used for truncated distributions +# @param n number of random values to generate +# @param dist name of a distribution for which the functions +# p, q, and r are available +# @param ... additional arguments passed to the distribution functions +# @param lb optional lower truncation bound +# @param ub optional upper truncation bound +# @param ntrys number of trys in rejection sampling for truncated models +# @return a vector of random values draws from the distribution +rdiscrete <- function(n, dist, ..., lb = NULL, ub = NULL, ntrys = 5) { + args <- list(...) + rdist <- paste0("r", dist) + if (is.null(lb) && is.null(ub)) { + # sample as usual + out <- do_call(rdist, c(list(n), args)) + } else { + # sample from truncated distribution via rejection sampling + if (is.null(lb)) lb <- -Inf + if (is.null(ub)) ub <- Inf + out <- vector("list", ntrys) + for (i in seq_along(out)) { + # loop of the trys to prevent a mismatch between 'n' + # and length of the parameter vectors passed as arguments + out[[i]] <- as.vector(do_call(rdist, c(list(n), args))) + } + out <- do_call(cbind, out) + out <- apply(out, 1, extract_valid_sample, lb = lb, ub = ub) + } + out +} + +# sample from the IDs of the mixture components +sample_mixture_ids <- function(theta) { + stopifnot(is.matrix(theta)) + mix_comp <- seq_cols(theta) + ulapply(seq_rows(theta), function(s) + sample(mix_comp, 1, prob = theta[s, ]) + ) +} + +# extract the first valid predicted value per Stan sample per observation +# @param x draws to be check against truncation boundaries +# @param lb vector of lower bounds +# @param ub vector of upper bound +# @return a valid truncated sample or else the closest boundary +extract_valid_sample <- function(x, lb, ub) { + valid <- match(TRUE, x >= lb & x <= ub) + if (is.na(valid)) { + # no valid truncated value found + # set sample to lb or ub + # 1e-10 is only to identify the invalid draws later on + out <- ifelse(max(x) < lb, lb - 1e-10, ub + 1e-10) + } else { + out <- x[valid] + } + out +} + +# check for invalid predictions of truncated discrete models +# @param x matrix of predicted values +# @param lb optional lower truncation bound +# @param ub optional upper truncation bound +# @param thres threshold (in %) of invalid values at which to warn the user +# @return rounded values of 'x' +check_discrete_trunc_bounds <- function(x, lb = NULL, ub = NULL, thres = 0.01) { + if (is.null(lb) && is.null(ub)) { + return(x) + } + if (is.null(lb)) lb <- -Inf + if (is.null(ub)) ub <- Inf + thres <- as_one_numeric(thres) + # ensure correct comparison with vector bounds + y <- as.vector(t(x)) + pct_invalid <- mean(y < lb | y > ub, na.rm = TRUE) + if (pct_invalid >= thres) { + warning2( + round(pct_invalid * 100), "% of all predicted values ", + "were invalid. Increasing argument 'ntrys' may help." + ) + } + round(x) +} diff -Nru r-cran-brms-2.16.3/R/posterior.R r-cran-brms-2.17.0/R/posterior.R --- r-cran-brms-2.16.3/R/posterior.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/posterior.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,312 +1,312 @@ -#' Index \code{brmsfit} objects -#' -#' @aliases variables nvariables niterations nchains ndraws -#' -#' Index variables, iterations, chains, and draws. -#' -#' @param x A \code{brmsfit} object or another \R object for which -#' the methods are defined. -#' @param ... Arguments passed to individual methods (if applicable). -#' -#' @name draws-index-brms -NULL - -#' @rdname draws-index-brms -#' @importFrom posterior variables -#' @method variables brmsfit -#' @export -#' @export variables -variables.brmsfit <- function(x, ...) { - # TODO: simplify once rstan and cmdstanr support these methods - out <- dimnames(x$fit) - if (is.list(out)) { - out <- out$parameters - } - out -} - -#' @method variables data.frame -variables.data.frame <- function(x, ...) { - names(x) -} - -#' @rdname draws-index-brms -#' @importFrom posterior nvariables -#' @method nvariables brmsfit -#' @export -#' @export nvariables -nvariables.brmsfit <- function(x, ...) { - length(variables(x, ...)) -} - -#' @rdname draws-index-brms -#' @importFrom posterior niterations -#' @method niterations brmsfit -#' @export -#' @export niterations -niterations.brmsfit <- function(x) { - if (!is.stanfit(x$fit)) return(0) - niterations <- x$fit@sim$n_save[1] %||% 0 - niterations - nwarmup(x) -} - -#' @rdname draws-index-brms -#' @importFrom posterior nchains -#' @method nchains brmsfit -#' @export -#' @export nchains -nchains.brmsfit <- function(x) { - if (!is.stanfit(x$fit)) return(0) - x$fit@sim$chains %||% 0 -} - -#' @rdname draws-index-brms -#' @importFrom posterior ndraws -#' @method ndraws brmsfit -#' @export -#' @export ndraws -ndraws.brmsfit <- function(x) { - niterations(x) * nchains(x) -} - -nwarmup <- function(x) { - if (!is.stanfit(x$fit)) return(0) - x$fit@sim$warmup2[1] %||% 0 -} - -nthin <- function(x) { - if (!is.stanfit(x$fit)) return(1) - x$fit@sim$thin %||% 1 -} - -#' Transform \code{brmsfit} to \code{draws} objects -#' -#' Transform a \code{brmsfit} object to a format supported by the -#' \pkg{posterior} package. -#' -#' @aliases as_draws as_draws_matrix as_draws_array as_draws_df -#' @aliases as_draws_rvars as_draws_list -#' -#' @param x A \code{brmsfit} object or another \R object for which -#' the methods are defined. -#' @param variable A character vector providing the variables to extract. -#' By default, all variables are extracted. -#' @param regex Logical; Should variable should be treated as a (vector of) -#' regular expressions? Any variable in \code{x} matching at least one of the -#' regular expressions will be selected. Defaults to \code{FALSE}. -#' @param inc_warmup Should warmup draws be included? Defaults to \code{FALSE}. -#' @param ... Arguments passed to individual methods (if applicable). -#' -#' @details To subset iterations, chains, or draws, use the -#' \code{\link[posterior:subset_draws]{subset_draws}} method after -#' transforming the \code{brmsfit} to a \code{draws} object. -#' -#' @seealso \code{\link[posterior:draws]{draws}} -#' \code{\link[posterior:subset_draws]{subset_draws}} -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), -#' data = epilepsy, family = poisson()) -#' -#' # extract posterior draws in an array format -#' (draws_fit <- as_draws_array(fit)) -#' posterior::summarize_draws(draws_fit) -#' -#' # extract only certain variables -#' as_draws_array(fit, variable = "r_patient") -#' as_draws_array(fit, variable = "^b_", regex = TRUE) -#' -#' # extract posterior draws in a random variables format -#' as_draws_rvars(fit) -#' } -#' -#' @name draws-brms -NULL - -#' @rdname draws-brms -#' @importFrom posterior as_draws -#' @method as_draws brmsfit -#' @export -#' @export as_draws -as_draws.brmsfit <- function(x, variable = NULL, regex = FALSE, - inc_warmup = FALSE, ...) { - # draws_list is the fastest format to convert to at the moment - as_draws_list( - x, variable = variable, regex = regex, - inc_warmup = inc_warmup, ... - ) -} - -#' @rdname draws-brms -#' @importFrom posterior as_draws_matrix -#' @method as_draws_matrix brmsfit -#' @export -#' @export as_draws_matrix -as_draws_matrix.brmsfit <- function(x, variable = NULL, regex = FALSE, - inc_warmup = FALSE, ...) { - as_draws_matrix(as_draws_list( - x, variable = variable, regex = regex, - inc_warmup = inc_warmup, ... - )) -} - -#' @rdname draws-brms -#' @importFrom posterior as_draws_array -#' @method as_draws_array brmsfit -#' @export -#' @export as_draws_array -as_draws_array.brmsfit <- function(x, variable = NULL, regex = FALSE, - inc_warmup = FALSE, ...) { - as_draws_array(as_draws_list( - x, variable = variable, regex = regex, - inc_warmup = inc_warmup, ... - )) -} - -#' @rdname draws-brms -#' @importFrom posterior as_draws_df -#' @method as_draws_df brmsfit -#' @export -#' @export as_draws_df -as_draws_df.brmsfit <- function(x, variable = NULL, regex = FALSE, - inc_warmup = FALSE, ...) { - as_draws_df(as_draws_list( - x, variable = variable, regex = regex, - inc_warmup = inc_warmup, ... - )) -} - -#' @rdname draws-brms -#' @importFrom posterior as_draws_list -#' @method as_draws_list brmsfit -#' @export -#' @export as_draws_list -as_draws_list.brmsfit <- function(x, variable = NULL, regex = FALSE, - inc_warmup = FALSE, ...) { - .as_draws_list( - x$fit, variable = variable, regex = regex, - inc_warmup = inc_warmup, ... - ) -} - -#' @rdname draws-brms -#' @importFrom posterior as_draws_rvars -#' @method as_draws_rvars brmsfit -#' @export -#' @export as_draws_rvars -as_draws_rvars.brmsfit <- function(x, variable = NULL, regex = FALSE, - inc_warmup = FALSE, ...) { - as_draws_rvars(as_draws_list( - x, variable = variable, regex = regex, - inc_warmup = inc_warmup, ... - )) -} - -# in stanfit objects draws are stored in a draws_list-like format -# so converting from there will be most efficient -# may be removed once rstan supports posterior natively -.as_draws_list <- function(x, variable = NULL, regex = FALSE, - inc_warmup = FALSE, ...) { - stopifnot(is.stanfit(x)) - inc_warmup <- as_one_logical(inc_warmup) - if (!length(x@sim$samples)) { - stop2("The model does not contain posterior draws.") - } - out <- as_draws_list(x@sim$samples) - # first subset variables then remove warmup as removing warmup - # will take a lot of time when extracting many variables - out <- subset_draws(out, variable = variable, regex = regex) - if (!inc_warmup) { - nwarmup <- x@sim$warmup2[1] %||% 0 - warmup_ids <- seq_len(nwarmup) - iteration_ids <- posterior::iteration_ids(out) - if (length(warmup_ids)) { - iteration_ids <- iteration_ids[-warmup_ids] - } - out <- subset_draws(out, iteration = iteration_ids) - } - out -} - -#' Extract Posterior Draws -#' -#' Extract posterior draws in conventional formats -#' as data.frames, matrices, or arrays. -#' -#' @inheritParams as_draws.brmsfit -#' @param pars Deprecated alias of \code{variable}. For reasons of backwards -#' compatibility, \code{pars} is interpreted as a vector of regular -#' expressions by default unless \code{fixed = TRUE} is specified. -#' @param draw The draw indices to be select. Subsetting draw indices will lead -#' to an automatic merging of chains. -#' @param subset Deprecated alias of \code{draw}. -#' @param row.names,optional Unused and only added for consistency with -#' the \code{\link[base:as.data.frame]{as.data.frame}} generic. -#' @param ... Further arguments to be passed to the corresponding -#' \code{\link[brms:draws-brms]{as_draws_*}} methods as well as to -#' \code{\link[posterior:subset_draws]{subset_draws}}. -#' -#' @return A data.frame, matrix, or array containing the posterior draws. -#' -#' @seealso \code{\link[brms:draws-brms]{as_draws}}, -#' \code{\link[posterior:subset_draws]{subset_draws}} -#' -#' @export -as.data.frame.brmsfit <- function(x, row.names = NULL, optional = TRUE, - pars = NA, variable = NULL, draw = NULL, - subset = NULL, ...) { - variable <- use_variable_alias(variable, x, pars = pars, ...) - draw <- use_alias(draw, subset) - out <- as_draws_df(x, variable = variable, ...) - out <- suppressMessages(subset_draws(out, draw = draw, ...)) - unclass_draws(out) -} - -#' @rdname as.data.frame.brmsfit -#' @export -as.matrix.brmsfit <- function(x, pars = NA, variable = NULL, - draw = NULL, subset = NULL, ...) { - variable <- use_variable_alias(variable, x, pars = pars, ...) - draw <- use_alias(draw, subset) - out <- as_draws_matrix(x, variable = variable, ...) - out <- suppressMessages(subset_draws(out, draw = draw, ...)) - unclass_draws(out) -} - -#' @rdname as.data.frame.brmsfit -#' @export -as.array.brmsfit <- function(x, pars = NA, variable = NULL, - draw = NULL, subset = NULL, ...) { - variable <- use_variable_alias(variable, x, pars = pars, ...) - draw <- use_alias(draw, subset) - out <- as_draws_array(x, variable = variable, ...) - out <- suppressMessages(subset_draws(out, draw = draw, ...)) - unclass_draws(out) -} - -# use the deprecated 'pars' alias to 'variable' -use_variable_alias <- function(variable, object, pars = NA, ...) { - if (!anyNA(pars)) { - warning2("Argument 'pars' is deprecated. Please use 'variable' instead.") - variable <- extract_pars(pars, variables(object), ...) - } - variable -} - -# remove the posterior draws format classes from objects -unclass_draws <- function(x, ...) { - UseMethod("unclass_draws") -} - -#' @export -unclass_draws.default <- function(x, ...) { - unclass(x) -} - -#' @export -unclass_draws.draws_df <- function(x, ...) { - x <- as.data.frame(x) - x$.chain <- x$.iteration <- x$.draw <- NULL - x -} +#' Index \code{brmsfit} objects +#' +#' @aliases variables nvariables niterations nchains ndraws +#' +#' Index variables, iterations, chains, and draws. +#' +#' @param x A \code{brmsfit} object or another \R object for which +#' the methods are defined. +#' @param ... Arguments passed to individual methods (if applicable). +#' +#' @name draws-index-brms +NULL + +#' @rdname draws-index-brms +#' @importFrom posterior variables +#' @method variables brmsfit +#' @export +#' @export variables +variables.brmsfit <- function(x, ...) { + # TODO: simplify once rstan and cmdstanr support these methods + out <- dimnames(x$fit) + if (is.list(out)) { + out <- out$parameters + } + out +} + +#' @method variables data.frame +variables.data.frame <- function(x, ...) { + names(x) +} + +#' @rdname draws-index-brms +#' @importFrom posterior nvariables +#' @method nvariables brmsfit +#' @export +#' @export nvariables +nvariables.brmsfit <- function(x, ...) { + length(variables(x, ...)) +} + +#' @rdname draws-index-brms +#' @importFrom posterior niterations +#' @method niterations brmsfit +#' @export +#' @export niterations +niterations.brmsfit <- function(x) { + if (!is.stanfit(x$fit)) return(0) + niterations <- x$fit@sim$n_save[1] %||% 0 + niterations - nwarmup(x) +} + +#' @rdname draws-index-brms +#' @importFrom posterior nchains +#' @method nchains brmsfit +#' @export +#' @export nchains +nchains.brmsfit <- function(x) { + if (!is.stanfit(x$fit)) return(0) + x$fit@sim$chains %||% 0 +} + +#' @rdname draws-index-brms +#' @importFrom posterior ndraws +#' @method ndraws brmsfit +#' @export +#' @export ndraws +ndraws.brmsfit <- function(x) { + niterations(x) * nchains(x) +} + +nwarmup <- function(x) { + if (!is.stanfit(x$fit)) return(0) + x$fit@sim$warmup2[1] %||% 0 +} + +nthin <- function(x) { + if (!is.stanfit(x$fit)) return(1) + x$fit@sim$thin %||% 1 +} + +#' Transform \code{brmsfit} to \code{draws} objects +#' +#' Transform a \code{brmsfit} object to a format supported by the +#' \pkg{posterior} package. +#' +#' @aliases as_draws as_draws_matrix as_draws_array as_draws_df +#' @aliases as_draws_rvars as_draws_list +#' +#' @param x A \code{brmsfit} object or another \R object for which +#' the methods are defined. +#' @param variable A character vector providing the variables to extract. +#' By default, all variables are extracted. +#' @param regex Logical; Should variable should be treated as a (vector of) +#' regular expressions? Any variable in \code{x} matching at least one of the +#' regular expressions will be selected. Defaults to \code{FALSE}. +#' @param inc_warmup Should warmup draws be included? Defaults to \code{FALSE}. +#' @param ... Arguments passed to individual methods (if applicable). +#' +#' @details To subset iterations, chains, or draws, use the +#' \code{\link[posterior:subset_draws]{subset_draws}} method after +#' transforming the \code{brmsfit} to a \code{draws} object. +#' +#' @seealso \code{\link[posterior:draws]{draws}} +#' \code{\link[posterior:subset_draws]{subset_draws}} +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt + (1|patient), +#' data = epilepsy, family = poisson()) +#' +#' # extract posterior draws in an array format +#' (draws_fit <- as_draws_array(fit)) +#' posterior::summarize_draws(draws_fit) +#' +#' # extract only certain variables +#' as_draws_array(fit, variable = "r_patient") +#' as_draws_array(fit, variable = "^b_", regex = TRUE) +#' +#' # extract posterior draws in a random variables format +#' as_draws_rvars(fit) +#' } +#' +#' @name draws-brms +NULL + +#' @rdname draws-brms +#' @importFrom posterior as_draws +#' @method as_draws brmsfit +#' @export +#' @export as_draws +as_draws.brmsfit <- function(x, variable = NULL, regex = FALSE, + inc_warmup = FALSE, ...) { + # draws_list is the fastest format to convert to at the moment + as_draws_list( + x, variable = variable, regex = regex, + inc_warmup = inc_warmup, ... + ) +} + +#' @rdname draws-brms +#' @importFrom posterior as_draws_matrix +#' @method as_draws_matrix brmsfit +#' @export +#' @export as_draws_matrix +as_draws_matrix.brmsfit <- function(x, variable = NULL, regex = FALSE, + inc_warmup = FALSE, ...) { + as_draws_matrix(as_draws_list( + x, variable = variable, regex = regex, + inc_warmup = inc_warmup, ... + )) +} + +#' @rdname draws-brms +#' @importFrom posterior as_draws_array +#' @method as_draws_array brmsfit +#' @export +#' @export as_draws_array +as_draws_array.brmsfit <- function(x, variable = NULL, regex = FALSE, + inc_warmup = FALSE, ...) { + as_draws_array(as_draws_list( + x, variable = variable, regex = regex, + inc_warmup = inc_warmup, ... + )) +} + +#' @rdname draws-brms +#' @importFrom posterior as_draws_df +#' @method as_draws_df brmsfit +#' @export +#' @export as_draws_df +as_draws_df.brmsfit <- function(x, variable = NULL, regex = FALSE, + inc_warmup = FALSE, ...) { + as_draws_df(as_draws_list( + x, variable = variable, regex = regex, + inc_warmup = inc_warmup, ... + )) +} + +#' @rdname draws-brms +#' @importFrom posterior as_draws_list +#' @method as_draws_list brmsfit +#' @export +#' @export as_draws_list +as_draws_list.brmsfit <- function(x, variable = NULL, regex = FALSE, + inc_warmup = FALSE, ...) { + .as_draws_list( + x$fit, variable = variable, regex = regex, + inc_warmup = inc_warmup, ... + ) +} + +#' @rdname draws-brms +#' @importFrom posterior as_draws_rvars +#' @method as_draws_rvars brmsfit +#' @export +#' @export as_draws_rvars +as_draws_rvars.brmsfit <- function(x, variable = NULL, regex = FALSE, + inc_warmup = FALSE, ...) { + as_draws_rvars(as_draws_list( + x, variable = variable, regex = regex, + inc_warmup = inc_warmup, ... + )) +} + +# in stanfit objects draws are stored in a draws_list-like format +# so converting from there will be most efficient +# may be removed once rstan supports posterior natively +.as_draws_list <- function(x, variable = NULL, regex = FALSE, + inc_warmup = FALSE, ...) { + stopifnot(is.stanfit(x)) + inc_warmup <- as_one_logical(inc_warmup) + if (!length(x@sim$samples)) { + stop2("The model does not contain posterior draws.") + } + out <- as_draws_list(x@sim$samples) + # first subset variables then remove warmup as removing warmup + # will take a lot of time when extracting many variables + out <- subset_draws(out, variable = variable, regex = regex) + if (!inc_warmup) { + nwarmup <- x@sim$warmup2[1] %||% 0 + warmup_ids <- seq_len(nwarmup) + iteration_ids <- posterior::iteration_ids(out) + if (length(warmup_ids)) { + iteration_ids <- iteration_ids[-warmup_ids] + } + out <- subset_draws(out, iteration = iteration_ids) + } + out +} + +#' Extract Posterior Draws +#' +#' Extract posterior draws in conventional formats +#' as data.frames, matrices, or arrays. +#' +#' @inheritParams as_draws.brmsfit +#' @param pars Deprecated alias of \code{variable}. For reasons of backwards +#' compatibility, \code{pars} is interpreted as a vector of regular +#' expressions by default unless \code{fixed = TRUE} is specified. +#' @param draw The draw indices to be select. Subsetting draw indices will lead +#' to an automatic merging of chains. +#' @param subset Deprecated alias of \code{draw}. +#' @param row.names,optional Unused and only added for consistency with +#' the \code{\link[base:as.data.frame]{as.data.frame}} generic. +#' @param ... Further arguments to be passed to the corresponding +#' \code{\link[brms:draws-brms]{as_draws_*}} methods as well as to +#' \code{\link[posterior:subset_draws]{subset_draws}}. +#' +#' @return A data.frame, matrix, or array containing the posterior draws. +#' +#' @seealso \code{\link[brms:draws-brms]{as_draws}}, +#' \code{\link[posterior:subset_draws]{subset_draws}} +#' +#' @export +as.data.frame.brmsfit <- function(x, row.names = NULL, optional = TRUE, + pars = NA, variable = NULL, draw = NULL, + subset = NULL, ...) { + variable <- use_variable_alias(variable, x, pars = pars, ...) + draw <- use_alias(draw, subset) + out <- as_draws_df(x, variable = variable, ...) + out <- suppressMessages(subset_draws(out, draw = draw, ...)) + unclass_draws(out) +} + +#' @rdname as.data.frame.brmsfit +#' @export +as.matrix.brmsfit <- function(x, pars = NA, variable = NULL, + draw = NULL, subset = NULL, ...) { + variable <- use_variable_alias(variable, x, pars = pars, ...) + draw <- use_alias(draw, subset) + out <- as_draws_matrix(x, variable = variable, ...) + out <- suppressMessages(subset_draws(out, draw = draw, ...)) + unclass_draws(out) +} + +#' @rdname as.data.frame.brmsfit +#' @export +as.array.brmsfit <- function(x, pars = NA, variable = NULL, + draw = NULL, subset = NULL, ...) { + variable <- use_variable_alias(variable, x, pars = pars, ...) + draw <- use_alias(draw, subset) + out <- as_draws_array(x, variable = variable, ...) + out <- suppressMessages(subset_draws(out, draw = draw, ...)) + unclass_draws(out) +} + +# use the deprecated 'pars' alias to 'variable' +use_variable_alias <- function(variable, object, pars = NA, ...) { + if (!anyNA(pars)) { + warning2("Argument 'pars' is deprecated. Please use 'variable' instead.") + variable <- extract_pars(pars, variables(object), ...) + } + variable +} + +# remove the posterior draws format classes from objects +unclass_draws <- function(x, ...) { + UseMethod("unclass_draws") +} + +#' @export +unclass_draws.default <- function(x, ...) { + unclass(x) +} + +#' @export +unclass_draws.draws_df <- function(x, ...) { + x <- as.data.frame(x) + x$.chain <- x$.iteration <- x$.draw <- NULL + x +} diff -Nru r-cran-brms-2.16.3/R/posterior_samples.R r-cran-brms-2.17.0/R/posterior_samples.R --- r-cran-brms-2.16.3/R/posterior_samples.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/posterior_samples.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,248 +1,248 @@ -#' (Deprecated) Extract Posterior Samples -#' -#' Extract posterior samples of specified parameters. The -#' \code{posterior_samples} method is deprecated. We recommend using the more -#' modern and consistent \code{\link[brms:draws-brms]{as_draws_*}} extractor -#' functions of the \pkg{posterior} package instead. -#' -#' @param x An \code{R} object typically of class \code{brmsfit} -#' @param pars Names of parameters for which posterior samples -#' should be returned, as given by a character vector or regular expressions. -#' By default, all posterior samples of all parameters are extracted. -#' @param fixed Indicates whether parameter names -#' should be matched exactly (\code{TRUE}) or treated as -#' regular expressions (\code{FALSE}). Default is \code{FALSE}. -#' @param add_chain A flag indicating if the returned \code{data.frame} -#' should contain two additional columns. The \code{chain} column -#' indicates the chain in which each sample was generated, the \code{iter} -#' column indicates the iteration number within each chain. -#' @param subset A numeric vector indicating the rows -#' (i.e., posterior samples) to be returned. -#' If \code{NULL} (the default), all posterior samples are returned. -#' @param as.matrix Should the output be a \code{matrix} -#' instead of a \code{data.frame}? Defaults to \code{FALSE}. -#' @param as.array Should the output be an \code{array} -#' instead of a \code{data.frame}? Defaults to \code{FALSE}. -#' @param ... Arguments passed to individual methods (if applicable). -#' -#' @return A data.frame (matrix or array) containing the posterior samples. -#' -#' @seealso \code{\link[brms:draws-brms]{as_draws}}, -#' \code{\link[brms:as.data.frame.brmsfit]{as.data.frame}} -#' -#' @examples -#' \dontrun{ -#' fit <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler, family = "cumulative") -#' -#' # extract posterior samples of population-level effects -#' samples1 <- posterior_samples(fit, pars = "^b") -#' head(samples1) -#' -#' # extract posterior samples of group-level standard deviations -#' samples2 <- posterior_samples(fit, pars = "^sd_") -#' head(samples2) -#' } -#' -#' @export -posterior_samples.brmsfit <- function(x, pars = NA, fixed = FALSE, - add_chain = FALSE, subset = NULL, - as.matrix = FALSE, as.array = FALSE, - ...) { - if (as.matrix && as.array) { - stop2("Cannot use 'as.matrix' and 'as.array' at the same time.") - } - if (add_chain && as.array) { - stop2("Cannot use 'add_chain' and 'as.array' at the same time.") - } - contains_draws(x) - pars <- extract_pars(pars, variables(x), fixed = fixed, ...) - - # get basic information on the samples - iter <- x$fit@sim$iter - warmup <- x$fit@sim$warmup - thin <- x$fit@sim$thin - chains <- x$fit@sim$chains - final_iter <- ceiling((iter - warmup) / thin) - samples_taken <- seq(warmup + 1, iter, thin) - - samples <- NULL - if (length(pars)) { - if (as.matrix) { - samples <- as.matrix(x$fit, pars = pars) - } else if (as.array) { - samples <- as.array(x$fit, pars = pars) - } else { - samples <- as.data.frame(x$fit, pars = pars) - } - if (add_chain) { - # name the column 'chain' not 'chains' (#32) - samples <- cbind(samples, - chain = factor(rep(1:chains, each = final_iter)), - iter = rep(samples_taken, chains) - ) - } - if (!is.null(subset)) { - if (as.array) { - samples <- samples[subset, , , drop = FALSE] - } else { - samples <- samples[subset, , drop = FALSE] - } - } - } - samples -} - -#' @rdname posterior_samples.brmsfit -#' @export -posterior_samples <- function(x, pars = NA, ...) { - warning2("Method 'posterior_samples' is deprecated. ", - "Please see ?as_draws for recommended alternatives.") - UseMethod("posterior_samples") -} - -#' @export -posterior_samples.default <- function(x, pars = NA, fixed = FALSE, ...) { - x <- as.data.frame(x) - if (!anyNA(pars)) { - pars <- extract_pars(pars, all_pars = names(x), fixed = fixed, ...) - x <- x[, pars, drop = FALSE] - } - if (!ncol(x)) { - x <- NULL - } - x -} - -#' Extract Parameter Names -#' -#' Extract all parameter names of a given model. -#' -#' @aliases parnames.brmsfit -#' -#' @param x An \R object -#' @param ... Further arguments passed to or from other methods. -#' -#' @return A character vector containing the parameter names of the model. -#' -#' @export -parnames <- function(x, ...) { - warning2("'parnames' is deprecated. Please use 'variables' instead.") - UseMethod("parnames") -} - -#' @export -parnames.default <- function(x, ...) { - names(x) -} - -#' @export -parnames.brmsfit <- function(x, ...) { - out <- dimnames(x$fit) - if (is.list(out)) { - out <- out$parameters - } - out -} - -# extract all valid parameter names that match pars -# @param pars A character vector or regular expression -# @param all_pars all parameter names of the fitted model -# @param fixed should parameter names be matched exactly? -# @param exact_match deprecated alias of fixed -# @param na_value: what should be returned if pars is NA? -# @param ... Further arguments to be passed to grepl -# @return A character vector of parameter names -extract_pars <- function(pars, all_pars, fixed = FALSE, - exact_match = FALSE, - na_value = all_pars, ...) { - if (!(anyNA(pars) || is.character(pars))) { - stop2("Argument 'pars' must be NA or a character vector.") - } - fixed <- check_deprecated_fixed(fixed, exact_match) - if (!anyNA(pars)) { - fixed <- as_one_logical(fixed) - if (fixed) { - out <- intersect(pars, all_pars) - } else { - out <- vector("list", length(pars)) - for (i in seq_along(pars)) { - out[[i]] <- all_pars[grepl(pars[i], all_pars, ...)] - } - out <- unique(unlist(out)) - } - } else { - out <- na_value - } - out -} - -# check deprecated alias of argument 'fixed' -check_deprecated_fixed <- function(fixed, exact_match) { - if (!isFALSE(exact_match)) { - # deprecated as of brms 2.10.6; remove in brms 3.0 - warning2("Argument 'exact_match' is deprecated. ", - "Please use 'fixed' instead.") - fixed <- exact_match - } - fixed -} - -#' Extract posterior samples for use with the \pkg{coda} package -#' -#' @aliases as.mcmc -#' -#' @inheritParams posterior_samples.brmsfit -#' @param ... currently unused -#' @param combine_chains Indicates whether chains should be combined. -#' @param inc_warmup Indicates if the warmup samples should be included. -#' Default is \code{FALSE}. Warmup samples are used to tune the -#' parameters of the sampling algorithm and should not be analyzed. -#' -#' @return If \code{combine_chains = TRUE} an \code{mcmc} object is returned. -#' If \code{combine_chains = FALSE} an \code{mcmc.list} object is returned. -#' -#' @method as.mcmc brmsfit -#' @export -#' @export as.mcmc -#' @importFrom coda as.mcmc -as.mcmc.brmsfit <- function(x, pars = NA, fixed = FALSE, - combine_chains = FALSE, inc_warmup = FALSE, - ...) { - warning2("as.mcmc.brmsfit is deprecated and will eventually be removed.") - contains_draws(x) - pars <- extract_pars(pars, all_pars = variables(x), fixed = fixed, ...) - combine_chains <- as_one_logical(combine_chains) - inc_warmup <- as_one_logical(inc_warmup) - if (combine_chains) { - if (inc_warmup) { - stop2("Cannot include warmup samples when 'combine_chains' is TRUE.") - } - out <- as.matrix(x$fit, pars) - ndraws <- nrow(out) - end <- x$fit@sim$iter * x$fit@sim$chains - thin <- x$fit@sim$thin - start <- end - (ndraws - 1) * thin - mcpar <- c(start, end, thin) - attr(out, "mcpar") <- mcpar - class(out) <- "mcmc" - } else { - thin <- x$fit@sim$thin - if (inc_warmup && thin >= 2) { - stop2("Cannot include warmup samples when 'thin' >= 2.") - } - ps <- rstan::extract(x$fit, pars, permuted = FALSE, inc_warmup = inc_warmup) - ndraws <- dim(ps)[1] - end <- x$fit@sim$iter - start <- end - (ndraws - 1) * thin - mcpar <- c(start, end, thin) - out <- vector("list", length = dim(ps)[2]) - for (i in seq_along(out)) { - out[[i]] <- ps[, i, ] - attr(out[[i]], "mcpar") <- mcpar - class(out[[i]]) <- "mcmc" - } - class(out) <- "mcmc.list" - } - out -} +#' (Deprecated) Extract Posterior Samples +#' +#' Extract posterior samples of specified parameters. The +#' \code{posterior_samples} method is deprecated. We recommend using the more +#' modern and consistent \code{\link[brms:draws-brms]{as_draws_*}} extractor +#' functions of the \pkg{posterior} package instead. +#' +#' @param x An \code{R} object typically of class \code{brmsfit} +#' @param pars Names of parameters for which posterior samples +#' should be returned, as given by a character vector or regular expressions. +#' By default, all posterior samples of all parameters are extracted. +#' @param fixed Indicates whether parameter names +#' should be matched exactly (\code{TRUE}) or treated as +#' regular expressions (\code{FALSE}). Default is \code{FALSE}. +#' @param add_chain A flag indicating if the returned \code{data.frame} +#' should contain two additional columns. The \code{chain} column +#' indicates the chain in which each sample was generated, the \code{iter} +#' column indicates the iteration number within each chain. +#' @param subset A numeric vector indicating the rows +#' (i.e., posterior samples) to be returned. +#' If \code{NULL} (the default), all posterior samples are returned. +#' @param as.matrix Should the output be a \code{matrix} +#' instead of a \code{data.frame}? Defaults to \code{FALSE}. +#' @param as.array Should the output be an \code{array} +#' instead of a \code{data.frame}? Defaults to \code{FALSE}. +#' @param ... Arguments passed to individual methods (if applicable). +#' +#' @return A data.frame (matrix or array) containing the posterior samples. +#' +#' @seealso \code{\link[brms:draws-brms]{as_draws}}, +#' \code{\link[brms:as.data.frame.brmsfit]{as.data.frame}} +#' +#' @examples +#' \dontrun{ +#' fit <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler, family = "cumulative") +#' +#' # extract posterior samples of population-level effects +#' samples1 <- posterior_samples(fit, pars = "^b") +#' head(samples1) +#' +#' # extract posterior samples of group-level standard deviations +#' samples2 <- posterior_samples(fit, pars = "^sd_") +#' head(samples2) +#' } +#' +#' @export +posterior_samples.brmsfit <- function(x, pars = NA, fixed = FALSE, + add_chain = FALSE, subset = NULL, + as.matrix = FALSE, as.array = FALSE, + ...) { + if (as.matrix && as.array) { + stop2("Cannot use 'as.matrix' and 'as.array' at the same time.") + } + if (add_chain && as.array) { + stop2("Cannot use 'add_chain' and 'as.array' at the same time.") + } + contains_draws(x) + pars <- extract_pars(pars, variables(x), fixed = fixed, ...) + + # get basic information on the samples + iter <- x$fit@sim$iter + warmup <- x$fit@sim$warmup + thin <- x$fit@sim$thin + chains <- x$fit@sim$chains + final_iter <- ceiling((iter - warmup) / thin) + samples_taken <- seq(warmup + 1, iter, thin) + + samples <- NULL + if (length(pars)) { + if (as.matrix) { + samples <- as.matrix(x$fit, pars = pars) + } else if (as.array) { + samples <- as.array(x$fit, pars = pars) + } else { + samples <- as.data.frame(x$fit, pars = pars) + } + if (add_chain) { + # name the column 'chain' not 'chains' (#32) + samples <- cbind(samples, + chain = factor(rep(1:chains, each = final_iter)), + iter = rep(samples_taken, chains) + ) + } + if (!is.null(subset)) { + if (as.array) { + samples <- samples[subset, , , drop = FALSE] + } else { + samples <- samples[subset, , drop = FALSE] + } + } + } + samples +} + +#' @rdname posterior_samples.brmsfit +#' @export +posterior_samples <- function(x, pars = NA, ...) { + warning2("Method 'posterior_samples' is deprecated. ", + "Please see ?as_draws for recommended alternatives.") + UseMethod("posterior_samples") +} + +#' @export +posterior_samples.default <- function(x, pars = NA, fixed = FALSE, ...) { + x <- as.data.frame(x) + if (!anyNA(pars)) { + pars <- extract_pars(pars, all_pars = names(x), fixed = fixed, ...) + x <- x[, pars, drop = FALSE] + } + if (!ncol(x)) { + x <- NULL + } + x +} + +#' Extract Parameter Names +#' +#' Extract all parameter names of a given model. +#' +#' @aliases parnames.brmsfit +#' +#' @param x An \R object +#' @param ... Further arguments passed to or from other methods. +#' +#' @return A character vector containing the parameter names of the model. +#' +#' @export +parnames <- function(x, ...) { + warning2("'parnames' is deprecated. Please use 'variables' instead.") + UseMethod("parnames") +} + +#' @export +parnames.default <- function(x, ...) { + names(x) +} + +#' @export +parnames.brmsfit <- function(x, ...) { + out <- dimnames(x$fit) + if (is.list(out)) { + out <- out$parameters + } + out +} + +# extract all valid parameter names that match pars +# @param pars A character vector or regular expression +# @param all_pars all parameter names of the fitted model +# @param fixed should parameter names be matched exactly? +# @param exact_match deprecated alias of fixed +# @param na_value: what should be returned if pars is NA? +# @param ... Further arguments to be passed to grepl +# @return A character vector of parameter names +extract_pars <- function(pars, all_pars, fixed = FALSE, + exact_match = FALSE, + na_value = all_pars, ...) { + if (!(anyNA(pars) || is.character(pars))) { + stop2("Argument 'pars' must be NA or a character vector.") + } + fixed <- check_deprecated_fixed(fixed, exact_match) + if (!anyNA(pars)) { + fixed <- as_one_logical(fixed) + if (fixed) { + out <- intersect(pars, all_pars) + } else { + out <- vector("list", length(pars)) + for (i in seq_along(pars)) { + out[[i]] <- all_pars[grepl(pars[i], all_pars, ...)] + } + out <- unique(unlist(out)) + } + } else { + out <- na_value + } + out +} + +# check deprecated alias of argument 'fixed' +check_deprecated_fixed <- function(fixed, exact_match) { + if (!isFALSE(exact_match)) { + # deprecated as of brms 2.10.6; remove in brms 3.0 + warning2("Argument 'exact_match' is deprecated. ", + "Please use 'fixed' instead.") + fixed <- exact_match + } + fixed +} + +#' Extract posterior samples for use with the \pkg{coda} package +#' +#' @aliases as.mcmc +#' +#' @inheritParams posterior_samples.brmsfit +#' @param ... currently unused +#' @param combine_chains Indicates whether chains should be combined. +#' @param inc_warmup Indicates if the warmup samples should be included. +#' Default is \code{FALSE}. Warmup samples are used to tune the +#' parameters of the sampling algorithm and should not be analyzed. +#' +#' @return If \code{combine_chains = TRUE} an \code{mcmc} object is returned. +#' If \code{combine_chains = FALSE} an \code{mcmc.list} object is returned. +#' +#' @method as.mcmc brmsfit +#' @export +#' @export as.mcmc +#' @importFrom coda as.mcmc +as.mcmc.brmsfit <- function(x, pars = NA, fixed = FALSE, + combine_chains = FALSE, inc_warmup = FALSE, + ...) { + warning2("as.mcmc.brmsfit is deprecated and will eventually be removed.") + contains_draws(x) + pars <- extract_pars(pars, all_pars = variables(x), fixed = fixed, ...) + combine_chains <- as_one_logical(combine_chains) + inc_warmup <- as_one_logical(inc_warmup) + if (combine_chains) { + if (inc_warmup) { + stop2("Cannot include warmup samples when 'combine_chains' is TRUE.") + } + out <- as.matrix(x$fit, pars) + ndraws <- nrow(out) + end <- x$fit@sim$iter * x$fit@sim$chains + thin <- x$fit@sim$thin + start <- end - (ndraws - 1) * thin + mcpar <- c(start, end, thin) + attr(out, "mcpar") <- mcpar + class(out) <- "mcmc" + } else { + thin <- x$fit@sim$thin + if (inc_warmup && thin >= 2) { + stop2("Cannot include warmup samples when 'thin' >= 2.") + } + ps <- rstan::extract(x$fit, pars, permuted = FALSE, inc_warmup = inc_warmup) + ndraws <- dim(ps)[1] + end <- x$fit@sim$iter + start <- end - (ndraws - 1) * thin + mcpar <- c(start, end, thin) + out <- vector("list", length = dim(ps)[2]) + for (i in seq_along(out)) { + out[[i]] <- ps[, i, ] + attr(out[[i]], "mcpar") <- mcpar + class(out[[i]]) <- "mcmc" + } + class(out) <- "mcmc.list" + } + out +} diff -Nru r-cran-brms-2.16.3/R/posterior_smooths.R r-cran-brms-2.17.0/R/posterior_smooths.R --- r-cran-brms-2.16.3/R/posterior_smooths.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/posterior_smooths.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,115 +1,115 @@ -#' Posterior Predictions of Smooth Terms -#' -#' Compute posterior predictions of smooth \code{s} and \code{t2} terms of -#' models fitted with \pkg{brms}. -#' -#' @inheritParams posterior_epred.brmsfit -#' @param smooth Name of a single smooth term for which predictions should -#' be computed. -#' @param newdata An optional \code{data.frame} for which to evaluate -#' predictions. If \code{NULL} (default), the original data of the model is -#' used. Only those variables appearing in the chosen \code{smooth} term are -#' required. -#' @param ... Currently ignored. -#' -#' @return An S x N matrix, where S is the number of -#' posterior draws and N is the number of observations. -#' -#' @examples -#' \dontrun{ -#' set.seed(0) -#' dat <- mgcv::gamSim(1, n = 200, scale = 2) -#' fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) -#' summary(fit) -#' -#' newdata <- data.frame(x2 = seq(0, 1, 10)) -#' str(posterior_smooths(fit, smooth = "s(x2)", newdata = newdata)) -#' } -#' -#' @export -posterior_smooths.brmsfit <- function(object, smooth, newdata = NULL, - resp = NULL, dpar = NULL, nlpar = NULL, - ndraws = NULL, draw_ids = NULL, ...) { - resp <- validate_resp(resp, object, multiple = FALSE) - bterms <- brmsterms(exclude_terms(object$formula, smooths_only = TRUE)) - if (!is.null(resp)) { - stopifnot(is.mvbrmsterms(bterms)) - bterms <- bterms$terms[[resp]] - } - if (!is.null(nlpar)) { - if (length(dpar)) { - stop2("Cannot use 'dpar' and 'nlpar' at the same time.") - } - nlpar <- as_one_character(nlpar) - nlpars <- names(bterms$nlpars) - if (!nlpar %in% nlpars) { - stop2("Invalid argument 'nlpar'. Valid non-linear ", - "parameters are: ", collapse_comma(nlpars)) - } - bterms <- bterms$nlpars[[nlpar]] - } else { - dpar <- dpar %||% "mu" - dpar <- as_one_character(dpar) - dpars <- names(bterms$dpars) - if (!dpar %in% dpars) { - stop2("Invalid argument 'dpar'. Valid distributional ", - "parameters are: ", collapse_comma(dpars)) - } - bterms <- bterms$dpars[[dpar]] - } - posterior_smooths( - bterms, fit = object, smooth = smooth, newdata = newdata, - ndraws = ndraws, draw_ids = draw_ids, ... - ) -} - -#' @export -posterior_smooths.btl <- function(object, fit, smooth, newdata = NULL, - ndraws = NULL, draw_ids = NULL, - nsamples = NULL, subset = NULL, ...) { - smooth <- rm_wsp(as_one_character(smooth)) - ndraws <- use_alias(ndraws, nsamples) - draw_ids <- use_alias(draw_ids, subset) - smef <- tidy_smef(object, fit$data) - smef$term <- rm_wsp(smef$term) - smterms <- unique(smef$term) - if (!smooth %in% smterms) { - stop2("Term '", smooth, "' cannot be found. Available ", - "smooth terms are: ", collapse_comma(smterms)) - } - # find relevant variables - sub_smef <- subset2(smef, term = smooth) - covars <- all_vars(sub_smef$covars[[1]]) - byvars <- all_vars(sub_smef$byvars[[1]]) - req_vars <- c(covars, byvars) - # prepare predictions for splines - sdata <- standata( - fit, newdata, re_formula = NA, internal = TRUE, - check_response = FALSE, req_vars = req_vars - ) - draw_ids <- validate_draw_ids(fit, draw_ids, ndraws) - draws <- as_draws_matrix(fit) - draws <- suppressMessages(subset_draws(draws, draw = draw_ids)) - prep_args <- nlist(x = object, draws, sdata, data = fit$data) - prep <- do_call(prepare_predictions, prep_args) - # select subset of smooth parameters and design matrices - i <- which(smterms %in% smooth)[1] - J <- which(smef$termnum == i) - scs <- unlist(attr(prep$sm$fe$Xs, "smcols")[J]) - prep$sm$fe$Xs <- prep$sm$fe$Xs[, scs, drop = FALSE] - prep$sm$fe$bs <- prep$sm$fe$bs[, scs, drop = FALSE] - prep$sm$re <- prep$sm$re[J] - prep$family <- brmsfamily("gaussian") - predictor(prep, i = NULL) -} - -#' @export -posterior_smooths.btnl <- function(object, ...) { - stop2("Non-linear formulas do not contain smooth terms.") -} - -#' @rdname posterior_smooths.brmsfit -#' @export -posterior_smooths <- function(object, ...) { - UseMethod("posterior_smooths") -} +#' Posterior Predictions of Smooth Terms +#' +#' Compute posterior predictions of smooth \code{s} and \code{t2} terms of +#' models fitted with \pkg{brms}. +#' +#' @inheritParams posterior_epred.brmsfit +#' @param smooth Name of a single smooth term for which predictions should +#' be computed. +#' @param newdata An optional \code{data.frame} for which to evaluate +#' predictions. If \code{NULL} (default), the original data of the model is +#' used. Only those variables appearing in the chosen \code{smooth} term are +#' required. +#' @param ... Currently ignored. +#' +#' @return An S x N matrix, where S is the number of +#' posterior draws and N is the number of observations. +#' +#' @examples +#' \dontrun{ +#' set.seed(0) +#' dat <- mgcv::gamSim(1, n = 200, scale = 2) +#' fit <- brm(y ~ s(x0) + s(x1) + s(x2) + s(x3), data = dat) +#' summary(fit) +#' +#' newdata <- data.frame(x2 = seq(0, 1, 10)) +#' str(posterior_smooths(fit, smooth = "s(x2)", newdata = newdata)) +#' } +#' +#' @export +posterior_smooths.brmsfit <- function(object, smooth, newdata = NULL, + resp = NULL, dpar = NULL, nlpar = NULL, + ndraws = NULL, draw_ids = NULL, ...) { + resp <- validate_resp(resp, object, multiple = FALSE) + bterms <- brmsterms(exclude_terms(object$formula, smooths_only = TRUE)) + if (!is.null(resp)) { + stopifnot(is.mvbrmsterms(bterms)) + bterms <- bterms$terms[[resp]] + } + if (!is.null(nlpar)) { + if (length(dpar)) { + stop2("Cannot use 'dpar' and 'nlpar' at the same time.") + } + nlpar <- as_one_character(nlpar) + nlpars <- names(bterms$nlpars) + if (!nlpar %in% nlpars) { + stop2("Invalid argument 'nlpar'. Valid non-linear ", + "parameters are: ", collapse_comma(nlpars)) + } + bterms <- bterms$nlpars[[nlpar]] + } else { + dpar <- dpar %||% "mu" + dpar <- as_one_character(dpar) + dpars <- names(bterms$dpars) + if (!dpar %in% dpars) { + stop2("Invalid argument 'dpar'. Valid distributional ", + "parameters are: ", collapse_comma(dpars)) + } + bterms <- bterms$dpars[[dpar]] + } + posterior_smooths( + bterms, fit = object, smooth = smooth, newdata = newdata, + ndraws = ndraws, draw_ids = draw_ids, ... + ) +} + +#' @export +posterior_smooths.btl <- function(object, fit, smooth, newdata = NULL, + ndraws = NULL, draw_ids = NULL, + nsamples = NULL, subset = NULL, ...) { + smooth <- rm_wsp(as_one_character(smooth)) + ndraws <- use_alias(ndraws, nsamples) + draw_ids <- use_alias(draw_ids, subset) + smef <- tidy_smef(object, fit$data) + smef$term <- rm_wsp(smef$term) + smterms <- unique(smef$term) + if (!smooth %in% smterms) { + stop2("Term '", smooth, "' cannot be found. Available ", + "smooth terms are: ", collapse_comma(smterms)) + } + # find relevant variables + sub_smef <- subset2(smef, term = smooth) + covars <- all_vars(sub_smef$covars[[1]]) + byvars <- all_vars(sub_smef$byvars[[1]]) + req_vars <- c(covars, byvars) + # prepare predictions for splines + sdata <- standata( + fit, newdata, re_formula = NA, internal = TRUE, + check_response = FALSE, req_vars = req_vars + ) + draw_ids <- validate_draw_ids(fit, draw_ids, ndraws) + draws <- as_draws_matrix(fit) + draws <- suppressMessages(subset_draws(draws, draw = draw_ids)) + prep_args <- nlist(x = object, draws, sdata, data = fit$data) + prep <- do_call(prepare_predictions, prep_args) + # select subset of smooth parameters and design matrices + i <- which(smterms %in% smooth)[1] + J <- which(smef$termnum == i) + scs <- unlist(attr(prep$sm$fe$Xs, "smcols")[J]) + prep$sm$fe$Xs <- prep$sm$fe$Xs[, scs, drop = FALSE] + prep$sm$fe$bs <- prep$sm$fe$bs[, scs, drop = FALSE] + prep$sm$re <- prep$sm$re[J] + prep$family <- brmsfamily("gaussian") + predictor(prep, i = NULL) +} + +#' @export +posterior_smooths.btnl <- function(object, ...) { + stop2("Non-linear formulas do not contain smooth terms.") +} + +#' @rdname posterior_smooths.brmsfit +#' @export +posterior_smooths <- function(object, ...) { + UseMethod("posterior_smooths") +} diff -Nru r-cran-brms-2.16.3/R/pp_check.R r-cran-brms-2.17.0/R/pp_check.R --- r-cran-brms-2.16.3/R/pp_check.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/pp_check.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,188 +1,230 @@ -#' Posterior Predictive Checks for \code{brmsfit} Objects -#' -#' Perform posterior predictive checks with the help -#' of the \pkg{bayesplot} package. -#' -#' @aliases pp_check -#' -#' @param object An object of class \code{brmsfit}. -#' @param type Type of the ppc plot as given by a character string. -#' See \code{\link[bayesplot:PPC-overview]{PPC}} for an overview -#' of currently supported types. You may also use an invalid -#' type (e.g. \code{type = "xyz"}) to get a list of supported -#' types in the resulting error message. -#' @param ndraws Positive integer indicating how many -#' posterior draws should be used. -#' If \code{NULL} all draws are used. If not specified, -#' the number of posterior draws is chosen automatically. -#' Ignored if \code{draw_ids} is not \code{NULL}. -#' @param group Optional name of a factor variable in the model -#' by which to stratify the ppc plot. This argument is required for -#' ppc \code{*_grouped} types and ignored otherwise. -#' @param x Optional name of a variable in the model. -#' Only used for ppc types having an \code{x} argument -#' and ignored otherwise. -#' @param ... Further arguments passed to \code{\link{predict.brmsfit}} -#' as well as to the PPC function specified in \code{type}. -#' @inheritParams prepare_predictions.brmsfit -#' -#' @return A ggplot object that can be further -#' customized using the \pkg{ggplot2} package. -#' -#' @details For a detailed explanation of each of the ppc functions, -#' see the \code{\link[bayesplot:PPC-overview]{PPC}} -#' documentation of the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} -#' package. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt -#' + (1|patient) + (1|obs), -#' data = epilepsy, family = poisson()) -#' -#' pp_check(fit) # shows dens_overlay plot by default -#' pp_check(fit, type = "error_hist", ndraws = 11) -#' pp_check(fit, type = "scatter_avg", ndraws = 100) -#' pp_check(fit, type = "stat_2d") -#' pp_check(fit, type = "rootogram") -#' pp_check(fit, type = "loo_pit") -#' -#' ## get an overview of all valid types -#' pp_check(fit, type = "xyz") -#' } -#' -#' @importFrom bayesplot pp_check -#' @export pp_check -#' @export -pp_check.brmsfit <- function(object, type, ndraws = NULL, nsamples = NULL, - group = NULL, x = NULL, newdata = NULL, - resp = NULL, draw_ids = NULL, subset = NULL, ...) { - dots <- list(...) - if (missing(type)) { - type <- "dens_overlay" - } - type <- as_one_character(type) - if (!is.null(group)) { - group <- as_one_character(group) - } - if (!is.null(x)) { - x <- as_one_character(x) - } - ndraws_given <- any(c("ndraws", "nsamples") %in% names(match.call())) - ndraws <- use_alias(ndraws, nsamples) - draw_ids <- use_alias(draw_ids, subset) - resp <- validate_resp(resp, object, multiple = FALSE) - valid_types <- as.character(bayesplot::available_ppc("")) - valid_types <- sub("^ppc_", "", valid_types) - if (!type %in% valid_types) { - stop2("Type '", type, "' is not a valid ppc type. ", - "Valid types are:\n", collapse_comma(valid_types)) - } - ppc_fun <- get(paste0("ppc_", type), asNamespace("bayesplot")) - - object <- restructure(object) - stopifnot_resp(object, resp) - family <- family(object, resp = resp) - if (has_multicol(family)) { - stop2("'pp_check' is not implemented for this family.") - } - valid_vars <- names(model.frame(object)) - if ("group" %in% names(formals(ppc_fun))) { - if (is.null(group)) { - stop2("Argument 'group' is required for ppc type '", type, "'.") - } - if (!group %in% valid_vars) { - stop2("Variable '", group, "' could not be found in the data.") - } - } - if ("x" %in% names(formals(ppc_fun))) { - if (!is.null(x) && !x %in% valid_vars) { - stop2("Variable '", x, "' could not be found in the data.") - } - } - if (type == "error_binned") { - if (is_polytomous(family)) { - stop2("Type '", type, "' is not available for polytomous models.") - } - method <- "posterior_epred" - } else { - method <- "posterior_predict" - } - if (!ndraws_given) { - aps_types <- c( - "error_scatter_avg", "error_scatter_avg_vs_x", - "intervals", "intervals_grouped", "loo_pit", - "loo_intervals", "loo_ribbon", "ribbon", - "ribbon_grouped", "rootogram", "scatter_avg", - "scatter_avg_grouped", "stat", "stat_2d", - "stat_freqpoly_grouped", "stat_grouped", - "violin_grouped" - ) - if (!is.null(draw_ids)) { - ndraws <- NULL - } else if (type %in% aps_types) { - ndraws <- NULL - message("Using all posterior draws for ppc type '", - type, "' by default.") - } else { - ndraws <- 10 - message("Using 10 posterior draws for ppc type '", - type, "' by default.") - } - } - - y <- get_y(object, resp = resp, newdata = newdata, ...) - draw_ids <- validate_draw_ids(object, draw_ids, ndraws) - pred_args <- list( - object, newdata = newdata, resp = resp, - draw_ids = draw_ids, ... - ) - yrep <- do_call(method, pred_args) - - if (anyNA(y)) { - warning2("NA responses are not shown in 'pp_check'.") - take <- !is.na(y) - y <- y[take] - yrep <- yrep[, take, drop = FALSE] - } - - data <- current_data( - object, newdata = newdata, resp = resp, - re_formula = NA, check_response = TRUE, ... - ) - # censored responses are misleading when displayed in pp_check - bterms <- brmsterms(object$formula) - cens <- get_cens(bterms, data, resp = resp) - if (!is.null(cens)) { - warning2("Censored responses are not shown in 'pp_check'.") - take <- !cens - if (!any(take)) { - stop2("No non-censored responses found.") - } - y <- y[take] - yrep <- yrep[, take, drop = FALSE] - } - # most ... arguments are ment for the prediction function - for_pred <- names(dots) %in% names(formals(prepare_predictions.brmsfit)) - ppc_args <- c(list(y, yrep), dots[!for_pred]) - if ("psis_object" %in% setdiff(names(formals(ppc_fun)), names(ppc_args))) { - ppc_args$psis_object <- do_call( - compute_loo, c(pred_args, criterion = "psis") - ) - } - if ("lw" %in% setdiff(names(formals(ppc_fun)), names(ppc_args))) { - ppc_args$lw <- weights( - do_call(compute_loo, c(pred_args, criterion = "psis")) - ) - } - if (!is.null(group)) { - ppc_args$group <- data[[group]] - } - if (!is.null(x)) { - ppc_args$x <- data[[x]] - if (!is_like_factor(ppc_args$x)) { - ppc_args$x <- as.numeric(ppc_args$x) - } - } - do_call(ppc_fun, ppc_args) -} +#' Posterior Predictive Checks for \code{brmsfit} Objects +#' +#' Perform posterior predictive checks with the help +#' of the \pkg{bayesplot} package. +#' +#' @aliases pp_check +#' +#' @param object An object of class \code{brmsfit}. +#' @param type Type of the ppc plot as given by a character string. +#' See \code{\link[bayesplot:PPC-overview]{PPC}} for an overview +#' of currently supported types. You may also use an invalid +#' type (e.g. \code{type = "xyz"}) to get a list of supported +#' types in the resulting error message. +#' @param ndraws Positive integer indicating how many +#' posterior draws should be used. +#' If \code{NULL} all draws are used. If not specified, +#' the number of posterior draws is chosen automatically. +#' Ignored if \code{draw_ids} is not \code{NULL}. +#' @param prefix The prefix of the \pkg{bayesplot} function to be applied. +#' Either `"ppc"` (posterior predictive check; the default) +#' or `"ppd"` (posterior predictive distribution), the latter being the same +#' as the former except that the observed data is not shown for `"ppd"`. +#' @param group Optional name of a factor variable in the model +#' by which to stratify the ppc plot. This argument is required for +#' ppc \code{*_grouped} types and ignored otherwise. +#' @param x Optional name of a variable in the model. +#' Only used for ppc types having an \code{x} argument +#' and ignored otherwise. +#' @param ... Further arguments passed to \code{\link{predict.brmsfit}} +#' as well as to the PPC function specified in \code{type}. +#' @inheritParams prepare_predictions.brmsfit +#' +#' @return A ggplot object that can be further +#' customized using the \pkg{ggplot2} package. +#' +#' @details For a detailed explanation of each of the ppc functions, +#' see the \code{\link[bayesplot:PPC-overview]{PPC}} +#' documentation of the \pkg{\link[bayesplot:bayesplot-package]{bayesplot}} +#' package. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt +#' + (1|patient) + (1|obs), +#' data = epilepsy, family = poisson()) +#' +#' pp_check(fit) # shows dens_overlay plot by default +#' pp_check(fit, type = "error_hist", ndraws = 11) +#' pp_check(fit, type = "scatter_avg", ndraws = 100) +#' pp_check(fit, type = "stat_2d") +#' pp_check(fit, type = "rootogram") +#' pp_check(fit, type = "loo_pit") +#' +#' ## get an overview of all valid types +#' pp_check(fit, type = "xyz") +#' +#' ## get a plot without the observed data +#' pp_check(fit, prefix = "ppd") +#' } +#' +#' @importFrom bayesplot pp_check +#' @export pp_check +#' @export +pp_check.brmsfit <- function(object, type, ndraws = NULL, prefix = c("ppc", "ppd"), + group = NULL, x = NULL, newdata = NULL, resp = NULL, + draw_ids = NULL, nsamples = NULL, subset = NULL, ...) { + dots <- list(...) + if (missing(type)) { + type <- "dens_overlay" + } + type <- as_one_character(type) + prefix <- match.arg(prefix) + if (!is.null(group)) { + group <- as_one_character(group) + } + if (!is.null(x)) { + x <- as_one_character(x) + } + ndraws_given <- any(c("ndraws", "nsamples") %in% names(match.call())) + ndraws <- use_alias(ndraws, nsamples) + draw_ids <- use_alias(draw_ids, subset) + resp <- validate_resp(resp, object, multiple = FALSE) + if (prefix == "ppc") { + # no type checking for prefix 'ppd' yet + valid_types <- as.character(bayesplot::available_ppc("")) + valid_types <- sub("^ppc_", "", valid_types) + if (!type %in% valid_types) { + stop2("Type '", type, "' is not a valid ppc type. ", + "Valid types are:\n", collapse_comma(valid_types)) + } + } + ppc_fun <- get(paste0(prefix, "_", type), asNamespace("bayesplot")) + + object <- restructure(object) + stopifnot_resp(object, resp) + family <- family(object, resp = resp) + if (has_multicol(family)) { + stop2("'pp_check' is not implemented for this family.") + } + valid_vars <- names(model.frame(object)) + if ("group" %in% names(formals(ppc_fun))) { + if (is.null(group)) { + stop2("Argument 'group' is required for ppc type '", type, "'.") + } + if (!group %in% valid_vars) { + stop2("Variable '", group, "' could not be found in the data.") + } + } + if ("x" %in% names(formals(ppc_fun))) { + if (!is.null(x) && !x %in% valid_vars) { + stop2("Variable '", x, "' could not be found in the data.") + } + } + if (type == "error_binned") { + if (is_polytomous(family)) { + stop2("Type '", type, "' is not available for polytomous models.") + } + method <- "posterior_epred" + } else { + method <- "posterior_predict" + } + if (!ndraws_given) { + aps_types <- c( + "error_scatter_avg", "error_scatter_avg_vs_x", + "intervals", "intervals_grouped", "loo_pit", + "loo_intervals", "loo_ribbon", "ribbon", + "ribbon_grouped", "rootogram", "scatter_avg", + "scatter_avg_grouped", "stat", "stat_2d", + "stat_freqpoly_grouped", "stat_grouped", + "violin_grouped" + ) + if (!is.null(draw_ids)) { + ndraws <- NULL + } else if (type %in% aps_types) { + ndraws <- NULL + message("Using all posterior draws for ppc type '", + type, "' by default.") + } else { + ndraws <- 10 + message("Using 10 posterior draws for ppc type '", + type, "' by default.") + } + } + + y <- NULL + if (prefix == "ppc") { + # y is ignored in prefix 'ppd' plots + y <- get_y(object, resp = resp, newdata = newdata, ...) + } + draw_ids <- validate_draw_ids(object, draw_ids, ndraws) + pred_args <- list( + object, newdata = newdata, resp = resp, + draw_ids = draw_ids, ... + ) + yrep <- do_call(method, pred_args) + + if (anyNA(y)) { + warning2("NA responses are not shown in 'pp_check'.") + take <- !is.na(y) + y <- y[take] + yrep <- yrep[, take, drop = FALSE] + } + + data <- current_data( + object, newdata = newdata, resp = resp, + re_formula = NA, check_response = TRUE, ... + ) + + # prepare plotting arguments + ppc_args <- list() + if (prefix == "ppc") { + ppc_args$y <- y + ppc_args$yrep <- yrep + } else if (prefix == "ppd") { + ppc_args$ypred <- yrep + } + if (!is.null(group)) { + ppc_args$group <- data[[group]] + } + if (!is.null(x)) { + ppc_args$x <- data[[x]] + if (!is_like_factor(ppc_args$x)) { + ppc_args$x <- as.numeric(ppc_args$x) + } + } + if ("psis_object" %in% setdiff(names(formals(ppc_fun)), names(ppc_args))) { + ppc_args$psis_object <- do_call( + compute_loo, c(pred_args, criterion = "psis") + ) + } + if ("lw" %in% setdiff(names(formals(ppc_fun)), names(ppc_args))) { + ppc_args$lw <- weights( + do_call(compute_loo, c(pred_args, criterion = "psis")) + ) + } + + # censored responses are misleading when displayed in pp_check + bterms <- brmsterms(object$formula) + cens <- get_cens(bterms, data, resp = resp) + if (!is.null(cens) & type != 'km_overlay') { + warning2("Censored responses are not shown in 'pp_check'.") + take <- !cens + if (!any(take)) { + stop2("No non-censored responses found.") + } + ppc_args$y <- ppc_args$y[take] + ppc_args$yrep <- ppc_args$yrep[, take, drop = FALSE] + if (!is.null(ppc_args$group)) { + ppc_args$group <- ppc_args$group[take] + } + if (!is.null(ppc_args$x)) { + ppc_args$x <- ppc_args$x[take] + } + if (!is.null(ppc_args$psis_object)) { + # tidier to re-compute with subset + psis_args <- c(pred_args, criterion = "psis") + psis_args$newdata <- data[take, ] + ppc_args$psis_object <- do_call(compute_loo, psis_args) + } + if (!is.null(ppc_args$lw)) { + ppc_args$lw <- ppc_args$lw[,take] + } + } + + # most ... arguments are meant for the prediction function + for_pred <- names(dots) %in% names(formals(prepare_predictions.brmsfit)) + ppc_args <- c(ppc_args, dots[!for_pred]) + + do_call(ppc_fun, ppc_args) +} diff -Nru r-cran-brms-2.16.3/R/pp_mixture.R r-cran-brms-2.17.0/R/pp_mixture.R --- r-cran-brms-2.16.3/R/pp_mixture.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/pp_mixture.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,114 +1,114 @@ -#' Posterior Probabilities of Mixture Component Memberships -#' -#' Compute the posterior probabilities of mixture component -#' memberships for each observation including uncertainty -#' estimates. -#' -#' @inheritParams predict.brmsfit -#' @param x An \R object usually of class \code{brmsfit}. -#' @param log Logical; Indicates whether to return -#' probabilities on the log-scale. -#' -#' @return -#' If \code{summary = TRUE}, an N x E x K array, -#' where N is the number of observations, K is the number -#' of mixture components, and E is equal to \code{length(probs) + 2}. -#' If \code{summary = FALSE}, an S x N x K array, where -#' S is the number of posterior draws. -#' -#' @details -#' The returned probabilities can be written as -#' \eqn{P(Kn = k | Yn)}, that is the posterior probability -#' that observation n originates from component k. -#' They are computed using Bayes' Theorem -#' \deqn{P(Kn = k | Yn) = P(Yn | Kn = k) P(Kn = k) / P(Yn),} -#' where \eqn{P(Yn | Kn = k)} is the (posterior) likelihood -#' of observation n for component k, \eqn{P(Kn = k)} is -#' the (posterior) mixing probability of component k -#' (i.e. parameter \code{theta}), and -#' \deqn{P(Yn) = \sum (k=1,...,K) P(Yn | Kn = k) P(Kn = k)} -#' is a normalizing constant. -#' -#' @examples -#' \dontrun{ -#' ## simulate some data -#' set.seed(1234) -#' dat <- data.frame( -#' y = c(rnorm(100), rnorm(50, 2)), -#' x = rnorm(150) -#' ) -#' ## fit a simple normal mixture model -#' mix <- mixture(gaussian, nmix = 2) -#' prior <- c( -#' prior(normal(0, 5), Intercept, nlpar = mu1), -#' prior(normal(0, 5), Intercept, nlpar = mu2), -#' prior(dirichlet(2, 2), theta) -#' ) -#' fit1 <- brm(bf(y ~ x), dat, family = mix, -#' prior = prior, chains = 2, inits = 0) -#' summary(fit1) -#' -#' ## compute the membership probabilities -#' ppm <- pp_mixture(fit1) -#' str(ppm) -#' -#' ## extract point estimates for each observation -#' head(ppm[, 1, ]) -#' -#' ## classify every observation according to -#' ## the most likely component -#' apply(ppm[, 1, ], 1, which.max) -#' } -#' -#' @export -pp_mixture.brmsfit <- function(x, newdata = NULL, re_formula = NULL, - resp = NULL, ndraws = NULL, draw_ids = NULL, - log = FALSE, summary = TRUE, robust = FALSE, - probs = c(0.025, 0.975), ...) { - stopifnot_resp(x, resp) - log <- as_one_logical(log) - contains_draws(x) - x <- restructure(x) - if (is_mv(x)) { - resp <- validate_resp(resp, x$formula$responses, multiple = FALSE) - family <- x$family[[resp]] - } else { - family <- x$family - } - if (!is.mixfamily(family)) { - stop2("Method 'pp_mixture' can only be applied to mixture models.") - } - prep <- prepare_predictions( - x, newdata = newdata, re_formula = re_formula, resp = resp, - draw_ids = draw_ids, ndraws = ndraws, check_response = TRUE, ... - ) - stopifnot(is.brmsprep(prep)) - prep$pp_mixture <- TRUE - for (dp in names(prep$dpars)) { - prep$dpars[[dp]] <- get_dpar(prep, dpar = dp) - } - N <- choose_N(prep) - out <- lapply(seq_len(N), log_lik_mixture, prep = prep) - out <- abind(out, along = 3) - out <- aperm(out, c(1, 3, 2)) - old_order <- prep$old_order - sort <- isTRUE(ncol(out) != length(old_order)) - out <- reorder_obs(out, old_order, sort = sort) - if (!log) { - out <- exp(out) - } - if (summary) { - out <- posterior_summary(out, probs = probs, robust = robust) - dimnames(out) <- list( - seq_len(nrow(out)), colnames(out), - paste0("P(K = ", seq_len(dim(out)[3]), " | Y)") - ) - } - out -} - -#' @rdname pp_mixture.brmsfit -#' @export -pp_mixture <- function(x, ...) { - UseMethod("pp_mixture") -} +#' Posterior Probabilities of Mixture Component Memberships +#' +#' Compute the posterior probabilities of mixture component +#' memberships for each observation including uncertainty +#' estimates. +#' +#' @inheritParams predict.brmsfit +#' @param x An \R object usually of class \code{brmsfit}. +#' @param log Logical; Indicates whether to return +#' probabilities on the log-scale. +#' +#' @return +#' If \code{summary = TRUE}, an N x E x K array, +#' where N is the number of observations, K is the number +#' of mixture components, and E is equal to \code{length(probs) + 2}. +#' If \code{summary = FALSE}, an S x N x K array, where +#' S is the number of posterior draws. +#' +#' @details +#' The returned probabilities can be written as +#' \eqn{P(Kn = k | Yn)}, that is the posterior probability +#' that observation n originates from component k. +#' They are computed using Bayes' Theorem +#' \deqn{P(Kn = k | Yn) = P(Yn | Kn = k) P(Kn = k) / P(Yn),} +#' where \eqn{P(Yn | Kn = k)} is the (posterior) likelihood +#' of observation n for component k, \eqn{P(Kn = k)} is +#' the (posterior) mixing probability of component k +#' (i.e. parameter \code{theta}), and +#' \deqn{P(Yn) = \sum (k=1,...,K) P(Yn | Kn = k) P(Kn = k)} +#' is a normalizing constant. +#' +#' @examples +#' \dontrun{ +#' ## simulate some data +#' set.seed(1234) +#' dat <- data.frame( +#' y = c(rnorm(100), rnorm(50, 2)), +#' x = rnorm(150) +#' ) +#' ## fit a simple normal mixture model +#' mix <- mixture(gaussian, nmix = 2) +#' prior <- c( +#' prior(normal(0, 5), Intercept, nlpar = mu1), +#' prior(normal(0, 5), Intercept, nlpar = mu2), +#' prior(dirichlet(2, 2), theta) +#' ) +#' fit1 <- brm(bf(y ~ x), dat, family = mix, +#' prior = prior, chains = 2, init = 0) +#' summary(fit1) +#' +#' ## compute the membership probabilities +#' ppm <- pp_mixture(fit1) +#' str(ppm) +#' +#' ## extract point estimates for each observation +#' head(ppm[, 1, ]) +#' +#' ## classify every observation according to +#' ## the most likely component +#' apply(ppm[, 1, ], 1, which.max) +#' } +#' +#' @export +pp_mixture.brmsfit <- function(x, newdata = NULL, re_formula = NULL, + resp = NULL, ndraws = NULL, draw_ids = NULL, + log = FALSE, summary = TRUE, robust = FALSE, + probs = c(0.025, 0.975), ...) { + stopifnot_resp(x, resp) + log <- as_one_logical(log) + contains_draws(x) + x <- restructure(x) + if (is_mv(x)) { + resp <- validate_resp(resp, x$formula$responses, multiple = FALSE) + family <- x$family[[resp]] + } else { + family <- x$family + } + if (!is.mixfamily(family)) { + stop2("Method 'pp_mixture' can only be applied to mixture models.") + } + prep <- prepare_predictions( + x, newdata = newdata, re_formula = re_formula, resp = resp, + draw_ids = draw_ids, ndraws = ndraws, check_response = TRUE, ... + ) + stopifnot(is.brmsprep(prep)) + prep$pp_mixture <- TRUE + for (dp in names(prep$dpars)) { + prep$dpars[[dp]] <- get_dpar(prep, dpar = dp) + } + N <- choose_N(prep) + out <- lapply(seq_len(N), log_lik_mixture, prep = prep) + out <- abind(out, along = 3) + out <- aperm(out, c(1, 3, 2)) + old_order <- prep$old_order + sort <- isTRUE(ncol(out) != length(old_order)) + out <- reorder_obs(out, old_order, sort = sort) + if (!log) { + out <- exp(out) + } + if (summary) { + out <- posterior_summary(out, probs = probs, robust = robust) + dimnames(out) <- list( + seq_len(nrow(out)), colnames(out), + paste0("P(K = ", seq_len(dim(out)[3]), " | Y)") + ) + } + out +} + +#' @rdname pp_mixture.brmsfit +#' @export +pp_mixture <- function(x, ...) { + UseMethod("pp_mixture") +} diff -Nru r-cran-brms-2.16.3/R/predictive_error.R r-cran-brms-2.17.0/R/predictive_error.R --- r-cran-brms-2.16.3/R/predictive_error.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/predictive_error.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,159 +1,159 @@ -#' Posterior Draws of Predictive Errors -#' -#' Compute posterior draws of predictive errors, that is, observed minus -#' predicted responses. Can be performed for the data used to fit the model -#' (posterior predictive checks) or for new data. -#' -#' @inheritParams posterior_predict.brmsfit -#' -#' @return An S x N \code{array} of predictive error draws, where S is the -#' number of posterior draws and N is the number of observations. -#' -#' @examples -#' \dontrun{ -#' ## fit a model -#' fit <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler, cores = 2) -#' -#' ## extract predictive errors -#' pe <- predictive_error(fit) -#' str(pe) -#' } -#' -#' @aliases predictive_error -#' @method predictive_error brmsfit -#' @importFrom rstantools predictive_error -#' @export -#' @export predictive_error -predictive_error.brmsfit <- function( - object, newdata = NULL, re_formula = NULL, re.form = NULL, - resp = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... -) { - cl <- match.call() - if ("re.form" %in% names(cl)) { - re_formula <- re.form - } - .predictive_error( - object, newdata = newdata, re_formula = re_formula, - method = "posterior_predict", type = "ordinary", resp = resp, - ndraws = ndraws, draw_ids = draw_ids, sort = sort, ... - ) -} - -#' Posterior Draws of Residuals/Predictive Errors -#' -#' This method is an alias of \code{\link{predictive_error.brmsfit}} -#' with additional arguments for obtaining summaries of the computed draws. -#' -#' @inheritParams predictive_error.brmsfit -#' @param method Method use to obtain predictions. Either -#' \code{"posterior_epred"} (the default) or \code{"posterior_predict"}. -#' Using \code{"posterior_predict"} is recommended -#' but \code{"posterior_epred"} is the current default for -#' reasons of backwards compatibility. -#' @param type The type of the residuals, -#' either \code{"ordinary"} or \code{"pearson"}. -#' More information is provided under 'Details'. -#' @param summary Should summary statistics be returned -#' instead of the raw values? Default is \code{TRUE}.. -#' @param robust If \code{FALSE} (the default) the mean is used as -#' the measure of central tendency and the standard deviation as -#' the measure of variability. If \code{TRUE}, the median and the -#' median absolute deviation (MAD) are applied instead. -#' Only used if \code{summary} is \code{TRUE}. -#' @param probs The percentiles to be computed by the \code{quantile} -#' function. Only used if \code{summary} is \code{TRUE}. -#' -#' @return An \code{array} of predictive error/residual draws. If -#' \code{summary = FALSE} the output resembles those of -#' \code{\link{predictive_error.brmsfit}}. If \code{summary = TRUE} the output -#' is an N x E matrix, where N is the number of observations and E denotes -#' the summary statistics computed from the draws. -#' -#' @details Residuals of type \code{'ordinary'} are of the form \eqn{R = Y - -#' Yrep}, where \eqn{Y} is the observed and \eqn{Yrep} is the predicted response. -#' Residuals of type \code{pearson} are of the form \eqn{R = (Y - Yrep) / -#' SD(Yrep)}, where \eqn{SD(Yrep)} is an estimate of the standard deviation of -#' \eqn{Yrep}. -#' -#' @examples -#' \dontrun{ -#' ## fit a model -#' fit <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler, cores = 2) -#' -#' ## extract residuals/predictive errors -#' res <- residuals(fit) -#' head(res) -#' } -#' -#' @export -residuals.brmsfit <- function(object, newdata = NULL, re_formula = NULL, - method = "posterior_epred", - type = c("ordinary", "pearson"), - resp = NULL, ndraws = NULL, - draw_ids = NULL, sort = FALSE, - summary = TRUE, robust = FALSE, - probs = c(0.025, 0.975), ...) { - summary <- as_one_logical(summary) - out <- .predictive_error( - object, newdata = newdata, re_formula = re_formula, - method = method, type = type, resp = resp, - ndraws = ndraws, draw_ids = draw_ids, sort = sort, ... - ) - if (summary) { - out <- posterior_summary(out, probs = probs, robust = robust) - } - out -} - -# internal function doing the work for predictive_error.brmsfit -.predictive_error <- function(object, newdata, re_formula, method, type, - resp, ndraws, draw_ids, sort, nsamples = NULL, - subset = NULL, ...) { - contains_draws(object) - object <- restructure(object) - method <- validate_pp_method(method) - type <- match.arg(type, c("ordinary", "pearson")) - resp <- validate_resp(resp, object) - family <- family(object, resp = resp) - if (is_polytomous(family)) { - stop2("Predictive errors are not defined for ordinal or categorical models.") - } - ndraws <- use_alias(ndraws, nsamples) - draw_ids <- use_alias(draw_ids, subset) - draw_ids <- validate_draw_ids(object, draw_ids, ndraws) - pred_args <- nlist( - object, newdata, re_formula, resp, draw_ids, - summary = FALSE, sort = sort, ... - ) - yrep <- do_call(method, pred_args) - y <- get_y(object, resp, newdata = newdata, sort = sort, warn = TRUE, ...) - if (length(dim(yrep)) == 3L) { - # multivariate model - y <- lapply(seq_cols(y), function(i) y[, i]) - y <- lapply(y, data2draws, dim = dim(yrep)[1:2]) - y <- abind(y, along = 3) - dimnames(y)[[3]] <- dimnames(yrep)[[3]] - } else { - y <- data2draws(y, dim = dim(yrep)) - } - out <- y - yrep - remove(y, yrep) - if (type == "pearson") { - # deprecated as of brms 2.10.6 - warning2("Type 'pearson' is deprecated and will be removed in the future.") - # get predicted standard deviation for each observation - pred_args$summary <- TRUE - pred <- do_call("predict", pred_args) - if (length(dim(pred)) == 3L) { - sd_pred <- array2list(pred[, 2, ]) - sd_pred <- lapply(sd_pred, data2draws, dim = dim(out)[1:2]) - sd_pred <- abind(sd_pred, along = 3) - } else { - sd_pred <- data2draws(pred[, 2], dim = dim(out)) - } - out <- out / sd_pred - } - out -} +#' Posterior Draws of Predictive Errors +#' +#' Compute posterior draws of predictive errors, that is, observed minus +#' predicted responses. Can be performed for the data used to fit the model +#' (posterior predictive checks) or for new data. +#' +#' @inheritParams posterior_predict.brmsfit +#' +#' @return An S x N \code{array} of predictive error draws, where S is the +#' number of posterior draws and N is the number of observations. +#' +#' @examples +#' \dontrun{ +#' ## fit a model +#' fit <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler, cores = 2) +#' +#' ## extract predictive errors +#' pe <- predictive_error(fit) +#' str(pe) +#' } +#' +#' @aliases predictive_error +#' @method predictive_error brmsfit +#' @importFrom rstantools predictive_error +#' @export +#' @export predictive_error +predictive_error.brmsfit <- function( + object, newdata = NULL, re_formula = NULL, re.form = NULL, + resp = NULL, ndraws = NULL, draw_ids = NULL, sort = FALSE, ... +) { + cl <- match.call() + if ("re.form" %in% names(cl)) { + re_formula <- re.form + } + .predictive_error( + object, newdata = newdata, re_formula = re_formula, + method = "posterior_predict", type = "ordinary", resp = resp, + ndraws = ndraws, draw_ids = draw_ids, sort = sort, ... + ) +} + +#' Posterior Draws of Residuals/Predictive Errors +#' +#' This method is an alias of \code{\link{predictive_error.brmsfit}} +#' with additional arguments for obtaining summaries of the computed draws. +#' +#' @inheritParams predictive_error.brmsfit +#' @param method Method use to obtain predictions. Either +#' \code{"posterior_epred"} (the default) or \code{"posterior_predict"}. +#' Using \code{"posterior_predict"} is recommended +#' but \code{"posterior_epred"} is the current default for +#' reasons of backwards compatibility. +#' @param type The type of the residuals, +#' either \code{"ordinary"} or \code{"pearson"}. +#' More information is provided under 'Details'. +#' @param summary Should summary statistics be returned +#' instead of the raw values? Default is \code{TRUE}.. +#' @param robust If \code{FALSE} (the default) the mean is used as +#' the measure of central tendency and the standard deviation as +#' the measure of variability. If \code{TRUE}, the median and the +#' median absolute deviation (MAD) are applied instead. +#' Only used if \code{summary} is \code{TRUE}. +#' @param probs The percentiles to be computed by the \code{quantile} +#' function. Only used if \code{summary} is \code{TRUE}. +#' +#' @return An \code{array} of predictive error/residual draws. If +#' \code{summary = FALSE} the output resembles those of +#' \code{\link{predictive_error.brmsfit}}. If \code{summary = TRUE} the output +#' is an N x E matrix, where N is the number of observations and E denotes +#' the summary statistics computed from the draws. +#' +#' @details Residuals of type \code{'ordinary'} are of the form \eqn{R = Y - +#' Yrep}, where \eqn{Y} is the observed and \eqn{Yrep} is the predicted response. +#' Residuals of type \code{pearson} are of the form \eqn{R = (Y - Yrep) / +#' SD(Yrep)}, where \eqn{SD(Yrep)} is an estimate of the standard deviation of +#' \eqn{Yrep}. +#' +#' @examples +#' \dontrun{ +#' ## fit a model +#' fit <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler, cores = 2) +#' +#' ## extract residuals/predictive errors +#' res <- residuals(fit) +#' head(res) +#' } +#' +#' @export +residuals.brmsfit <- function(object, newdata = NULL, re_formula = NULL, + method = "posterior_epred", + type = c("ordinary", "pearson"), + resp = NULL, ndraws = NULL, + draw_ids = NULL, sort = FALSE, + summary = TRUE, robust = FALSE, + probs = c(0.025, 0.975), ...) { + summary <- as_one_logical(summary) + out <- .predictive_error( + object, newdata = newdata, re_formula = re_formula, + method = method, type = type, resp = resp, + ndraws = ndraws, draw_ids = draw_ids, sort = sort, ... + ) + if (summary) { + out <- posterior_summary(out, probs = probs, robust = robust) + } + out +} + +# internal function doing the work for predictive_error.brmsfit +.predictive_error <- function(object, newdata, re_formula, method, type, + resp, ndraws, draw_ids, sort, nsamples = NULL, + subset = NULL, ...) { + contains_draws(object) + object <- restructure(object) + method <- validate_pp_method(method) + type <- match.arg(type, c("ordinary", "pearson")) + resp <- validate_resp(resp, object) + family <- family(object, resp = resp) + if (is_polytomous(family)) { + stop2("Predictive errors are not defined for ordinal or categorical models.") + } + ndraws <- use_alias(ndraws, nsamples) + draw_ids <- use_alias(draw_ids, subset) + draw_ids <- validate_draw_ids(object, draw_ids, ndraws) + pred_args <- nlist( + object, newdata, re_formula, resp, draw_ids, + summary = FALSE, sort = sort, ... + ) + yrep <- do_call(method, pred_args) + y <- get_y(object, resp, newdata = newdata, sort = sort, warn = TRUE, ...) + if (length(dim(yrep)) == 3L) { + # multivariate model + y <- lapply(seq_cols(y), function(i) y[, i]) + y <- lapply(y, data2draws, dim = dim(yrep)[1:2]) + y <- abind(y, along = 3) + dimnames(y)[[3]] <- dimnames(yrep)[[3]] + } else { + y <- data2draws(y, dim = dim(yrep)) + } + out <- y - yrep + remove(y, yrep) + if (type == "pearson") { + # deprecated as of brms 2.10.6 + warning2("Type 'pearson' is deprecated and will be removed in the future.") + # get predicted standard deviation for each observation + pred_args$summary <- TRUE + pred <- do_call("predict", pred_args) + if (length(dim(pred)) == 3L) { + sd_pred <- array2list(pred[, 2, ]) + sd_pred <- lapply(sd_pred, data2draws, dim = dim(out)[1:2]) + sd_pred <- abind(sd_pred, along = 3) + } else { + sd_pred <- data2draws(pred[, 2], dim = dim(out)) + } + out <- out / sd_pred + } + out +} diff -Nru r-cran-brms-2.16.3/R/predictor.R r-cran-brms-2.17.0/R/predictor.R --- r-cran-brms-2.16.3/R/predictor.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/predictor.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,524 +1,524 @@ -# compute predictor terms -predictor <- function(prep, ...) { - UseMethod("predictor") -} - -# compute linear/additive predictor terms -# @param prep a list generated by prepare_predictions containing -# all required data and posterior draws -# @param i An optional vector indicating the observation(s) -# for which to compute eta. If NULL, eta is computed -# for all all observations at once. -# @param fprep Optional full brmsprep object of the model. -# Currently only needed in non-linear models or for -# predicting new data in models with autocorrelation. -# @return Usually an S x N matrix where S is the number of draws -# and N is the number of observations or length of i if specified. -#' @export -predictor.bprepl <- function(prep, i = NULL, fprep = NULL, ...) { - nobs <- ifelse(!is.null(i), length(i), prep$nobs) - eta <- matrix(0, nrow = prep$ndraws, ncol = nobs) + - predictor_fe(prep, i) + - predictor_re(prep, i) + - predictor_sp(prep, i) + - predictor_sm(prep, i) + - predictor_gp(prep, i) + - predictor_offset(prep, i, nobs) - # some autocorrelation structures depend on eta - eta <- predictor_ac(eta, prep, i, fprep = fprep) - # intentionally last as it may return 3D arrays - eta <- predictor_cs(eta, prep, i) - unname(eta) -} - -# compute non-linear predictor terms -# @param prep a list generated by prepare_predictions containing -# all required data and posterior draws -# @param i An optional vector indicating the observation(s) -# for which to compute eta. If NULL, eta is computed -# for all all observations at once. -# @param ... further arguments passed to predictor.bprepl -# @return Usually an S x N matrix where S is the number of draws -# and N is the number of observations or length of i if specified. -#' @export -predictor.bprepnl <- function(prep, i = NULL, fprep = NULL, ...) { - stopifnot(!is.null(fprep)) - nlpars <- prep$used_nlpars - covars <- names(prep$C) - args <- named_list(c(nlpars, covars)) - for (nlp in nlpars) { - args[[nlp]] <- get_nlpar(fprep, nlpar = nlp, i = i, ...) - } - for (cov in covars) { - args[[cov]] <- p(prep$C[[cov]], i, row = FALSE) - } - dim_eta <- dim(rmNULL(args)[[1]]) - # evaluate non-linear predictor - if (!prep$loop) { - # cannot reasonably vectorize over posterior draws - # when 'nlform' must be evaluated jointly across observations - # and hence 'loop' had been set to FALSE - for (i in seq_along(args)) { - args[[i]] <- split(args[[i]], row(args[[i]])) - } - .fun <- function(...) eval(prep$nlform, list(...)) - eta <- try( - t(do_call(mapply, c(list(FUN = .fun, SIMPLIFY = "array"), args))), - silent = TRUE - ) - } else { - # assumes fully vectorized version of 'nlform' - eta <- try(eval(prep$nlform, args), silent = TRUE) - } - if (is(eta, "try-error")) { - if (grepl("could not find function", eta)) { - eta <- rename(eta, "Error in eval(expr, envir, enclos) : ", "") - vectorize <- str_if(prep$loop, ", vectorize = TRUE") - message( - eta, " Most likely this is because you used a Stan ", - "function in the non-linear model formula that ", - "is not defined in R. If this is a user-defined function, ", - "please run 'expose_functions(.", vectorize, ")' ", - "on your fitted model and try again." - ) - } else { - eta <- rename(eta, "^Error :", "", fixed = FALSE) - stop2(eta) - } - } - dim(eta) <- dim_eta - unname(eta) -} - -# compute eta for overall effects -predictor_fe <- function(prep, i) { - fe <- prep[["fe"]] - if (!isTRUE(ncol(fe[["X"]]) > 0)) { - return(0) - } - eta <- try(.predictor_fe(X = p(fe[["X"]], i), b = fe[["b"]])) - if (is(eta, "try-error")) { - stop2( - "Something went wrong (see the error message above). ", - "Perhaps you transformed numeric variables ", - "to factors or vice versa within the model formula? ", - "If yes, please convert your variables beforehand. ", - "Or did you set a predictor variable to NA?" - ) - } - eta -} - -# workhorse function of predictor_fe -# @param X fixed effects design matrix -# @param b draws of fixed effects coeffients -.predictor_fe <- function(X, b) { - stopifnot(is.matrix(X)) - stopifnot(is.matrix(b)) - tcrossprod(b, X) -} - -# compute eta for varying effects -predictor_re <- function(prep, i) { - eta <- 0 - re <- prep[["re"]] - group <- names(re[["r"]]) - for (g in group) { - eta_g <- try(.predictor_re(Z = p(re[["Z"]][[g]], i), r = re[["r"]][[g]])) - if (is(eta_g, "try-error")) { - stop2( - "Something went wrong (see the error message above). ", - "Perhaps you transformed numeric variables ", - "to factors or vice versa within the model formula? ", - "If yes, please convert your variables beforehand. ", - "Or did you use a grouping factor also for a different purpose? ", - "If yes, please make sure that its factor levels are correct ", - "also in the new data you may have provided." - ) - } - eta <- eta + eta_g - } - eta -} - -# workhorse function of predictor_re -# @param Z sparse random effects design matrix -# @param r random effects draws -# @return linear predictor for random effects -.predictor_re <- function(Z, r) { - Matrix::as.matrix(Matrix::tcrossprod(r, Z)) -} - -# compute eta for special effects terms -predictor_sp <- function(prep, i) { - eta <- 0 - sp <- prep[["sp"]] - if (!length(sp)) { - return(eta) - } - eval_list <- list() - for (j in seq_along(sp[["simo"]])) { - eval_list[[paste0("Xmo_", j)]] <- p(sp[["Xmo"]][[j]], i) - eval_list[[paste0("simo_", j)]] <- sp[["simo"]][[j]] - } - for (j in seq_along(sp[["Xme"]])) { - eval_list[[paste0("Xme_", j)]] <- p(sp[["Xme"]][[j]], i, row = FALSE) - } - for (j in seq_along(sp[["Yl"]])) { - eval_list[[names(sp[["Yl"]])[j]]] <- p(sp[["Yl"]][[j]], i, row = FALSE) - } - for (j in seq_along(sp[["idxl"]])) { - eval_list[[names(sp[["idxl"]])[j]]] <- p(sp[["idxl"]][[j]], i, row = FALSE) - } - for (j in seq_along(sp[["Csp"]])) { - eval_list[[paste0("Csp_", j)]] <- p(sp[["Csp"]][[j]], i, row = FALSE) - } - re <- prep[["re"]] - coef <- colnames(sp[["bsp"]]) - for (j in seq_along(coef)) { - # prepare special group-level effects - rsp <- named_list(names(re[["rsp"]][[coef[j]]])) - for (g in names(rsp)) { - rsp[[g]] <- .predictor_re( - Z = p(re[["Zsp"]][[g]], i), - r = re[["rsp"]][[coef[j]]][[g]] - ) - } - eta <- eta + .predictor_sp( - eval_list, call = sp[["calls"]][[j]], - b = sp[["bsp"]][, j], - r = Reduce("+", rsp) - ) - } - eta -} - -# workhorse function of predictor_sp -# @param call expression for evaluation of special effects -# @param eval_list list containing variables for 'call' -# @param b special effects coefficients draws -# @param r matrix with special effects group-level draws -.predictor_sp <- function(eval_list, call, b, r = NULL) { - b <- as.vector(b) - if (is.null(r)) r <- 0 - (b + r) * eval(call, eval_list) -} - -# R implementation of the user defined Stan function 'mo' -# @param simplex posterior draws of a simplex parameter vector -# @param X variable modeled as monotonic -.mo <- function(simplex, X) { - stopifnot(is.matrix(simplex), is.atomic(X)) - D <- NCOL(simplex) - simplex <- cbind(0, simplex) - for (i in seq_cols(simplex)[-1]) { - # compute the cumulative representation of the simplex - simplex[, i] <- simplex[, i] + simplex[, i - 1] - } - D * simplex[, X + 1] -} - -# compute eta for smooth terms -predictor_sm <- function(prep, i) { - eta <- 0 - if (!length(prep[["sm"]])) { - return(eta) - } - fe <- prep[["sm"]]$fe - if (length(fe)) { - eta <- eta + .predictor_fe(X = p(fe$Xs, i), b = fe$bs) - } - re <- prep[["sm"]]$re - for (k in seq_along(re)) { - for (j in seq_along(re[[k]]$s)) { - Zs <- p(re[[k]]$Zs[[j]], i) - s <- re[[k]]$s[[j]] - eta <- eta + .predictor_fe(X = Zs, b = s) - } - } - eta -} - -# compute eta for gaussian processes -predictor_gp <- function(prep, i) { - if (!length(prep[["gp"]])) { - return(0) - } - if (!is.null(i)) { - stop2("Pointwise evaluation is not supported for Gaussian processes.") - } - eta <- matrix(0, nrow = prep$ndraws, ncol = prep$nobs) - for (k in seq_along(prep[["gp"]])) { - gp <- prep[["gp"]][[k]] - if (isTRUE(attr(gp, "byfac"))) { - # categorical 'by' variable - for (j in seq_along(gp)) { - if (length(gp[[j]][["Igp"]])) { - eta[, gp[[j]][["Igp"]]] <- .predictor_gp(gp[[j]]) - } - } - } else { - eta <- eta + .predictor_gp(gp) - } - } - eta -} - -# workhorse function of predictor_gp -# @param gp a list returned by '.prepare_predictions_gp' -# @return A S x N matrix to be added to the linear predictor -# @note does not work with pointwise evaluation -.predictor_gp <- function(gp) { - if (is.null(gp[["slambda"]])) { - # predictions for exact GPs - ndraws <- length(gp[["sdgp"]]) - eta <- as.list(rep(NA, ndraws)) - if (!is.null(gp[["x_new"]])) { - for (i in seq_along(eta)) { - eta[[i]] <- with(gp, .predictor_gp_new( - x_new = x_new, yL = yL[i, ], x = x, - sdgp = sdgp[i], lscale = lscale[i, ], nug = nug - )) - } - } else { - for (i in seq_along(eta)) { - eta[[i]] <- with(gp, .predictor_gp_old( - x = x, sdgp = sdgp[i], lscale = lscale[i, ], - zgp = zgp[i, ], nug = nug - )) - } - } - eta <- do_call(rbind, eta) - } else { - # predictions for approximate GPs - eta <- with(gp, .predictor_gpa( - x = x, sdgp = sdgp, lscale = lscale, - zgp = zgp, slambda = slambda - )) - } - if (!is.null(gp[["Jgp"]])) { - eta <- eta[, gp[["Jgp"]], drop = FALSE] - } - if (!is.null(gp[["Cgp"]])) { - eta <- eta * data2draws(gp[["Cgp"]], dim = dim(eta)) - } - eta -} - -# make exact GP predictions for old data points -# vectorized over posterior draws -# @param x old predictor values -# @param sdgp sample of parameter sdgp -# @param lscale sample of parameter lscale -# @param zgp draws of parameter vector zgp -# @param nug very small positive value to ensure numerical stability -.predictor_gp_old <- function(x, sdgp, lscale, zgp, nug) { - Sigma <- cov_exp_quad(x, sdgp = sdgp, lscale = lscale) - lx <- nrow(x) - Sigma <- Sigma + diag(rep(nug, lx), lx, lx) - L_Sigma <- try_nug(t(chol(Sigma)), nug = nug) - as.numeric(L_Sigma %*% zgp) -} - -# make exact GP predictions for new data points -# vectorized over posterior draws -# @param x_new new predictor values -# @param yL linear predictor of the old data -# @param x old predictor values -# @param sdgp sample of parameter sdgp -# @param lscale sample of parameter lscale -# @param nug very small positive value to ensure numerical stability -.predictor_gp_new <- function(x_new, yL, x, sdgp, lscale, nug) { - Sigma <- cov_exp_quad(x, sdgp = sdgp, lscale = lscale) - lx <- nrow(x) - lx_new <- nrow(x_new) - Sigma <- Sigma + diag(rep(nug, lx), lx, lx) - L_Sigma <- try_nug(t(chol(Sigma)), nug = nug) - L_Sigma_inverse <- solve(L_Sigma) - K_div_yL <- L_Sigma_inverse %*% yL - K_div_yL <- t(t(K_div_yL) %*% L_Sigma_inverse) - k_x_x_new <- cov_exp_quad(x, x_new, sdgp = sdgp, lscale = lscale) - mu_yL_new <- as.numeric(t(k_x_x_new) %*% K_div_yL) - v_new <- L_Sigma_inverse %*% k_x_x_new - cov_yL_new <- cov_exp_quad(x_new, sdgp = sdgp, lscale = lscale) - - t(v_new) %*% v_new + diag(rep(nug, lx_new), lx_new, lx_new) - yL_new <- try_nug( - rmulti_normal(1, mu = mu_yL_new, Sigma = cov_yL_new), - nug = nug - ) - return(yL_new) -} - -# make predictions for approximate GPs -# vectorized over posterior draws -# @param x matrix of evaluated eigenfunctions of the cov matrix -# @param sdgp sample of parameter sdgp -# @param lscale sample of parameter lscale -# @param zgp draws of parameter vector zgp -# @param slambda vector of eigenvalues of the cov matrix -# @note no need to differentiate between old and new data points -.predictor_gpa <- function(x, sdgp, lscale, zgp, slambda) { - spd <- sqrt(spd_cov_exp_quad(slambda, sdgp, lscale)) - (spd * zgp) %*% t(x) -} - -# compute eta for category specific effects -# @param predictor matrix of other additive terms -# @return 3D predictor array in the presence of 'cs' effects -# otherwise return 'eta' unchanged -predictor_cs <- function(eta, prep, i) { - cs <- prep[["cs"]] - re <- prep[["re"]] - if (!length(cs[["bcs"]]) && !length(re[["rcs"]])) { - return(eta) - } - nthres <- cs[["nthres"]] - rcs <- NULL - if (!is.null(re[["rcs"]])) { - groups <- names(re[["rcs"]]) - rcs <- vector("list", nthres) - for (k in seq_along(rcs)) { - rcs[[k]] <- named_list(groups) - for (g in groups) { - rcs[[k]][[g]] <- .predictor_re( - Z = p(re[["Zcs"]][[g]], i), - r = re[["rcs"]][[g]][[k]] - ) - } - rcs[[k]] <- Reduce("+", rcs[[k]]) - } - } - .predictor_cs( - eta, X = p(cs[["Xcs"]], i), - b = cs[["bcs"]], nthres = nthres, r = rcs - ) -} - -# workhorse function of predictor_cs -# @param X category specific design matrix -# @param b category specific effects draws -# @param nthres number of thresholds -# @param eta linear predictor matrix -# @param r list of draws of cs group-level effects -# @return 3D predictor array including category specific effects -.predictor_cs <- function(eta, X, b, nthres, r = NULL) { - stopifnot(is.null(X) && is.null(b) || is.matrix(X) && is.matrix(b)) - nthres <- max(nthres) - eta <- predictor_expand(eta, nthres) - if (!is.null(X)) { - I <- seq(1, (nthres) * ncol(X), nthres) - 1 - X <- t(X) - } - for (k in seq_len(nthres)) { - if (!is.null(X)) { - eta[, , k] <- eta[, , k] + b[, I + k, drop = FALSE] %*% X - } - if (!is.null(r[[k]])) { - eta[, , k] <- eta[, , k] + r[[k]] - } - } - eta -} - -# expand dimension of the predictor matrix to a 3D array -predictor_expand <- function(eta, nthres) { - if (length(dim(eta)) == 2L) { - eta <- array(eta, dim = c(dim(eta), nthres)) - } - eta -} - -predictor_offset <- function(prep, i, nobs) { - if (is.null(prep$offset)) { - return(0) - } - eta <- rep(p(prep$offset, i), prep$ndraws) - matrix(eta, ncol = nobs, byrow = TRUE) -} - -# compute eta for autocorrelation structures -# @note eta has to be passed to this function in -# order for ARMA structures to work correctly -predictor_ac <- function(eta, prep, i, fprep = NULL) { - if (has_ac_class(prep$ac$acef, "arma")) { - if (!is.null(prep$ac$err)) { - # ARMA correlations via latent residuals - eta <- eta + p(prep$ac$err, i, row = FALSE) - } else { - # ARMA correlations via explicit natural residuals - if (!is.null(i)) { - stop2("Pointwise evaluation is not possible for ARMA models.") - } - eta <- .predictor_arma( - eta, ar = prep$ac$ar, ma = prep$ac$ma, - Y = prep$ac$Y, J_lag = prep$ac$J_lag, - fprep = fprep - ) - } - } - if (has_ac_class(prep$ac$acef, "car")) { - eta <- eta + .predictor_re(Z = p(prep$ac$Zcar, i), r = prep$ac$rcar) - } - eta -} - -# add ARMA effects to a predictor matrix -# @param eta linear predictor matrix -# @param ar optional autoregressive draws -# @param ma optional moving average draws -# @param Y vector of response values -# @param J_lag autocorrelation lag for each observation -# @return linear predictor matrix updated by ARMA effects -.predictor_arma <- function(eta, ar = NULL, ma = NULL, Y = NULL, J_lag = NULL, - fprep = NULL) { - if (is.null(ar) && is.null(ma)) { - return(eta) - } - if (anyNA(Y)) { - # predicting Y will be necessary at some point - stopifnot(is.brmsprep(fprep) || is.mvbrmsprep(fprep)) - pp_fun <- paste0("posterior_predict_", fprep$family$fun) - pp_fun <- get(pp_fun, asNamespace("brms")) - } - S <- nrow(eta) - N <- length(Y) - max_lag <- max(J_lag, 1) - Kar <- ifelse(is.null(ar), 0, ncol(ar)) - Kma <- ifelse(is.null(ma), 0, ncol(ma)) - # relevant if time-series are shorter than the ARMA orders - take_ar <- seq_len(min(Kar, max_lag)) - take_ma <- seq_len(min(Kma, max_lag)) - ar <- ar[, take_ar, drop = FALSE] - ma <- ma[, take_ma, drop = FALSE] - Err <- array(0, dim = c(S, max_lag, max_lag + 1)) - err <- zero_mat <- matrix(0, nrow = S, ncol = max_lag) - zero_vec <- rep(0, S) - for (n in seq_len(N)) { - if (Kma) { - eta[, n] <- eta[, n] + rowSums(ma * Err[, take_ma, max_lag]) - } - eta_before_ar <- eta[, n] - if (Kar) { - eta[, n] <- eta[, n] + rowSums(ar * Err[, take_ar, max_lag]) - } - # AR terms need to be included in the predictions of y if missing - # the prediction code thus differs from the structure of the Stan code - y <- Y[n] - if (is.na(y)) { - # y was not observed and has to be predicted - fprep$dpars$mu <- eta - y <- pp_fun(n, fprep) - } - # errors in AR models need to be computed before adding AR terms - err[, max_lag] <- y - eta_before_ar - if (J_lag[n] > 0) { - # store residuals of former observations - I <- seq_len(J_lag[n]) - Err[, I, max_lag + 1] <- err[, max_lag + 1 - I] - } - # keep the size of 'err' and 'Err' as small as possible - Err <- abind(Err[, , -1, drop = FALSE], zero_mat) - err <- cbind(err[, -1, drop = FALSE], zero_vec) - } - eta -} +# compute predictor terms +predictor <- function(prep, ...) { + UseMethod("predictor") +} + +# compute linear/additive predictor terms +# @param prep a list generated by prepare_predictions containing +# all required data and posterior draws +# @param i An optional vector indicating the observation(s) +# for which to compute eta. If NULL, eta is computed +# for all all observations at once. +# @param fprep Optional full brmsprep object of the model. +# Currently only needed in non-linear models or for +# predicting new data in models with autocorrelation. +# @return Usually an S x N matrix where S is the number of draws +# and N is the number of observations or length of i if specified. +#' @export +predictor.bprepl <- function(prep, i = NULL, fprep = NULL, ...) { + nobs <- ifelse(!is.null(i), length(i), prep$nobs) + eta <- matrix(0, nrow = prep$ndraws, ncol = nobs) + + predictor_fe(prep, i) + + predictor_re(prep, i) + + predictor_sp(prep, i) + + predictor_sm(prep, i) + + predictor_gp(prep, i) + + predictor_offset(prep, i, nobs) + # some autocorrelation structures depend on eta + eta <- predictor_ac(eta, prep, i, fprep = fprep) + # intentionally last as it may return 3D arrays + eta <- predictor_cs(eta, prep, i) + unname(eta) +} + +# compute non-linear predictor terms +# @param prep a list generated by prepare_predictions containing +# all required data and posterior draws +# @param i An optional vector indicating the observation(s) +# for which to compute eta. If NULL, eta is computed +# for all all observations at once. +# @param ... further arguments passed to predictor.bprepl +# @return Usually an S x N matrix where S is the number of draws +# and N is the number of observations or length of i if specified. +#' @export +predictor.bprepnl <- function(prep, i = NULL, fprep = NULL, ...) { + stopifnot(!is.null(fprep)) + nlpars <- prep$used_nlpars + covars <- names(prep$C) + args <- named_list(c(nlpars, covars)) + for (nlp in nlpars) { + args[[nlp]] <- get_nlpar(fprep, nlpar = nlp, i = i, ...) + } + for (cov in covars) { + args[[cov]] <- p(prep$C[[cov]], i, row = FALSE) + } + dim_eta <- dim(rmNULL(args)[[1]]) + # evaluate non-linear predictor + if (!prep$loop) { + # cannot reasonably vectorize over posterior draws + # when 'nlform' must be evaluated jointly across observations + # and hence 'loop' had been set to FALSE + for (i in seq_along(args)) { + args[[i]] <- split(args[[i]], row(args[[i]])) + } + .fun <- function(...) eval(prep$nlform, list(...)) + eta <- try( + t(do_call(mapply, c(list(FUN = .fun, SIMPLIFY = "array"), args))), + silent = TRUE + ) + } else { + # assumes fully vectorized version of 'nlform' + eta <- try(eval(prep$nlform, args), silent = TRUE) + } + if (is(eta, "try-error")) { + if (grepl("could not find function", eta)) { + eta <- rename(eta, "Error in eval(expr, envir, enclos) : ", "") + vectorize <- str_if(prep$loop, ", vectorize = TRUE") + message( + eta, " Most likely this is because you used a Stan ", + "function in the non-linear model formula that ", + "is not defined in R. If this is a user-defined function, ", + "please run 'expose_functions(.", vectorize, ")' ", + "on your fitted model and try again." + ) + } else { + eta <- rename(eta, "^Error :", "", fixed = FALSE) + stop2(eta) + } + } + dim(eta) <- dim_eta + unname(eta) +} + +# compute eta for overall effects +predictor_fe <- function(prep, i) { + fe <- prep[["fe"]] + if (!isTRUE(ncol(fe[["X"]]) > 0)) { + return(0) + } + eta <- try(.predictor_fe(X = p(fe[["X"]], i), b = fe[["b"]])) + if (is(eta, "try-error")) { + stop2( + "Something went wrong (see the error message above). ", + "Perhaps you transformed numeric variables ", + "to factors or vice versa within the model formula? ", + "If yes, please convert your variables beforehand. ", + "Or did you set a predictor variable to NA?" + ) + } + eta +} + +# workhorse function of predictor_fe +# @param X fixed effects design matrix +# @param b draws of fixed effects coeffients +.predictor_fe <- function(X, b) { + stopifnot(is.matrix(X)) + stopifnot(is.matrix(b)) + tcrossprod(b, X) +} + +# compute eta for varying effects +predictor_re <- function(prep, i) { + eta <- 0 + re <- prep[["re"]] + group <- names(re[["r"]]) + for (g in group) { + eta_g <- try(.predictor_re(Z = p(re[["Z"]][[g]], i), r = re[["r"]][[g]])) + if (is(eta_g, "try-error")) { + stop2( + "Something went wrong (see the error message above). ", + "Perhaps you transformed numeric variables ", + "to factors or vice versa within the model formula? ", + "If yes, please convert your variables beforehand. ", + "Or did you use a grouping factor also for a different purpose? ", + "If yes, please make sure that its factor levels are correct ", + "also in the new data you may have provided." + ) + } + eta <- eta + eta_g + } + eta +} + +# workhorse function of predictor_re +# @param Z sparse random effects design matrix +# @param r random effects draws +# @return linear predictor for random effects +.predictor_re <- function(Z, r) { + Matrix::as.matrix(Matrix::tcrossprod(r, Z)) +} + +# compute eta for special effects terms +predictor_sp <- function(prep, i) { + eta <- 0 + sp <- prep[["sp"]] + if (!length(sp)) { + return(eta) + } + eval_list <- list() + for (j in seq_along(sp[["simo"]])) { + eval_list[[paste0("Xmo_", j)]] <- p(sp[["Xmo"]][[j]], i) + eval_list[[paste0("simo_", j)]] <- sp[["simo"]][[j]] + } + for (j in seq_along(sp[["Xme"]])) { + eval_list[[paste0("Xme_", j)]] <- p(sp[["Xme"]][[j]], i, row = FALSE) + } + for (j in seq_along(sp[["Yl"]])) { + eval_list[[names(sp[["Yl"]])[j]]] <- p(sp[["Yl"]][[j]], i, row = FALSE) + } + for (j in seq_along(sp[["idxl"]])) { + eval_list[[names(sp[["idxl"]])[j]]] <- p(sp[["idxl"]][[j]], i, row = FALSE) + } + for (j in seq_along(sp[["Csp"]])) { + eval_list[[paste0("Csp_", j)]] <- p(sp[["Csp"]][[j]], i, row = FALSE) + } + re <- prep[["re"]] + coef <- colnames(sp[["bsp"]]) + for (j in seq_along(coef)) { + # prepare special group-level effects + rsp <- named_list(names(re[["rsp"]][[coef[j]]])) + for (g in names(rsp)) { + rsp[[g]] <- .predictor_re( + Z = p(re[["Zsp"]][[g]], i), + r = re[["rsp"]][[coef[j]]][[g]] + ) + } + eta <- eta + .predictor_sp( + eval_list, call = sp[["calls"]][[j]], + b = sp[["bsp"]][, j], + r = Reduce("+", rsp) + ) + } + eta +} + +# workhorse function of predictor_sp +# @param call expression for evaluation of special effects +# @param eval_list list containing variables for 'call' +# @param b special effects coefficients draws +# @param r matrix with special effects group-level draws +.predictor_sp <- function(eval_list, call, b, r = NULL) { + b <- as.vector(b) + if (is.null(r)) r <- 0 + (b + r) * eval(call, eval_list) +} + +# R implementation of the user defined Stan function 'mo' +# @param simplex posterior draws of a simplex parameter vector +# @param X variable modeled as monotonic +.mo <- function(simplex, X) { + stopifnot(is.matrix(simplex), is.atomic(X)) + D <- NCOL(simplex) + simplex <- cbind(0, simplex) + for (i in seq_cols(simplex)[-1]) { + # compute the cumulative representation of the simplex + simplex[, i] <- simplex[, i] + simplex[, i - 1] + } + D * simplex[, X + 1] +} + +# compute eta for smooth terms +predictor_sm <- function(prep, i) { + eta <- 0 + if (!length(prep[["sm"]])) { + return(eta) + } + fe <- prep[["sm"]]$fe + if (length(fe)) { + eta <- eta + .predictor_fe(X = p(fe$Xs, i), b = fe$bs) + } + re <- prep[["sm"]]$re + for (k in seq_along(re)) { + for (j in seq_along(re[[k]]$s)) { + Zs <- p(re[[k]]$Zs[[j]], i) + s <- re[[k]]$s[[j]] + eta <- eta + .predictor_fe(X = Zs, b = s) + } + } + eta +} + +# compute eta for gaussian processes +predictor_gp <- function(prep, i) { + if (!length(prep[["gp"]])) { + return(0) + } + if (!is.null(i)) { + stop2("Pointwise evaluation is not supported for Gaussian processes.") + } + eta <- matrix(0, nrow = prep$ndraws, ncol = prep$nobs) + for (k in seq_along(prep[["gp"]])) { + gp <- prep[["gp"]][[k]] + if (isTRUE(attr(gp, "byfac"))) { + # categorical 'by' variable + for (j in seq_along(gp)) { + if (length(gp[[j]][["Igp"]])) { + eta[, gp[[j]][["Igp"]]] <- .predictor_gp(gp[[j]]) + } + } + } else { + eta <- eta + .predictor_gp(gp) + } + } + eta +} + +# workhorse function of predictor_gp +# @param gp a list returned by '.prepare_predictions_gp' +# @return A S x N matrix to be added to the linear predictor +# @note does not work with pointwise evaluation +.predictor_gp <- function(gp) { + if (is.null(gp[["slambda"]])) { + # predictions for exact GPs + ndraws <- length(gp[["sdgp"]]) + eta <- as.list(rep(NA, ndraws)) + if (!is.null(gp[["x_new"]])) { + for (i in seq_along(eta)) { + eta[[i]] <- with(gp, .predictor_gp_new( + x_new = x_new, yL = yL[i, ], x = x, + sdgp = sdgp[i], lscale = lscale[i, ], nug = nug + )) + } + } else { + for (i in seq_along(eta)) { + eta[[i]] <- with(gp, .predictor_gp_old( + x = x, sdgp = sdgp[i], lscale = lscale[i, ], + zgp = zgp[i, ], nug = nug + )) + } + } + eta <- do_call(rbind, eta) + } else { + # predictions for approximate GPs + eta <- with(gp, .predictor_gpa( + x = x, sdgp = sdgp, lscale = lscale, + zgp = zgp, slambda = slambda + )) + } + if (!is.null(gp[["Jgp"]])) { + eta <- eta[, gp[["Jgp"]], drop = FALSE] + } + if (!is.null(gp[["Cgp"]])) { + eta <- eta * data2draws(gp[["Cgp"]], dim = dim(eta)) + } + eta +} + +# make exact GP predictions for old data points +# vectorized over posterior draws +# @param x old predictor values +# @param sdgp sample of parameter sdgp +# @param lscale sample of parameter lscale +# @param zgp draws of parameter vector zgp +# @param nug very small positive value to ensure numerical stability +.predictor_gp_old <- function(x, sdgp, lscale, zgp, nug) { + Sigma <- cov_exp_quad(x, sdgp = sdgp, lscale = lscale) + lx <- nrow(x) + Sigma <- Sigma + diag(rep(nug, lx), lx, lx) + L_Sigma <- try_nug(t(chol(Sigma)), nug = nug) + as.numeric(L_Sigma %*% zgp) +} + +# make exact GP predictions for new data points +# vectorized over posterior draws +# @param x_new new predictor values +# @param yL linear predictor of the old data +# @param x old predictor values +# @param sdgp sample of parameter sdgp +# @param lscale sample of parameter lscale +# @param nug very small positive value to ensure numerical stability +.predictor_gp_new <- function(x_new, yL, x, sdgp, lscale, nug) { + Sigma <- cov_exp_quad(x, sdgp = sdgp, lscale = lscale) + lx <- nrow(x) + lx_new <- nrow(x_new) + Sigma <- Sigma + diag(rep(nug, lx), lx, lx) + L_Sigma <- try_nug(t(chol(Sigma)), nug = nug) + L_Sigma_inverse <- solve(L_Sigma) + K_div_yL <- L_Sigma_inverse %*% yL + K_div_yL <- t(t(K_div_yL) %*% L_Sigma_inverse) + k_x_x_new <- cov_exp_quad(x, x_new, sdgp = sdgp, lscale = lscale) + mu_yL_new <- as.numeric(t(k_x_x_new) %*% K_div_yL) + v_new <- L_Sigma_inverse %*% k_x_x_new + cov_yL_new <- cov_exp_quad(x_new, sdgp = sdgp, lscale = lscale) - + t(v_new) %*% v_new + diag(rep(nug, lx_new), lx_new, lx_new) + yL_new <- try_nug( + rmulti_normal(1, mu = mu_yL_new, Sigma = cov_yL_new), + nug = nug + ) + return(yL_new) +} + +# make predictions for approximate GPs +# vectorized over posterior draws +# @param x matrix of evaluated eigenfunctions of the cov matrix +# @param sdgp sample of parameter sdgp +# @param lscale sample of parameter lscale +# @param zgp draws of parameter vector zgp +# @param slambda vector of eigenvalues of the cov matrix +# @note no need to differentiate between old and new data points +.predictor_gpa <- function(x, sdgp, lscale, zgp, slambda) { + spd <- sqrt(spd_cov_exp_quad(slambda, sdgp, lscale)) + (spd * zgp) %*% t(x) +} + +# compute eta for category specific effects +# @param predictor matrix of other additive terms +# @return 3D predictor array in the presence of 'cs' effects +# otherwise return 'eta' unchanged +predictor_cs <- function(eta, prep, i) { + cs <- prep[["cs"]] + re <- prep[["re"]] + if (!length(cs[["bcs"]]) && !length(re[["rcs"]])) { + return(eta) + } + nthres <- cs[["nthres"]] + rcs <- NULL + if (!is.null(re[["rcs"]])) { + groups <- names(re[["rcs"]]) + rcs <- vector("list", nthres) + for (k in seq_along(rcs)) { + rcs[[k]] <- named_list(groups) + for (g in groups) { + rcs[[k]][[g]] <- .predictor_re( + Z = p(re[["Zcs"]][[g]], i), + r = re[["rcs"]][[g]][[k]] + ) + } + rcs[[k]] <- Reduce("+", rcs[[k]]) + } + } + .predictor_cs( + eta, X = p(cs[["Xcs"]], i), + b = cs[["bcs"]], nthres = nthres, r = rcs + ) +} + +# workhorse function of predictor_cs +# @param X category specific design matrix +# @param b category specific effects draws +# @param nthres number of thresholds +# @param eta linear predictor matrix +# @param r list of draws of cs group-level effects +# @return 3D predictor array including category specific effects +.predictor_cs <- function(eta, X, b, nthres, r = NULL) { + stopifnot(is.null(X) && is.null(b) || is.matrix(X) && is.matrix(b)) + nthres <- max(nthres) + eta <- predictor_expand(eta, nthres) + if (!is.null(X)) { + I <- seq(1, (nthres) * ncol(X), nthres) - 1 + X <- t(X) + } + for (k in seq_len(nthres)) { + if (!is.null(X)) { + eta[, , k] <- eta[, , k] + b[, I + k, drop = FALSE] %*% X + } + if (!is.null(r[[k]])) { + eta[, , k] <- eta[, , k] + r[[k]] + } + } + eta +} + +# expand dimension of the predictor matrix to a 3D array +predictor_expand <- function(eta, nthres) { + if (length(dim(eta)) == 2L) { + eta <- array(eta, dim = c(dim(eta), nthres)) + } + eta +} + +predictor_offset <- function(prep, i, nobs) { + if (is.null(prep$offset)) { + return(0) + } + eta <- rep(p(prep$offset, i), prep$ndraws) + matrix(eta, ncol = nobs, byrow = TRUE) +} + +# compute eta for autocorrelation structures +# @note eta has to be passed to this function in +# order for ARMA structures to work correctly +predictor_ac <- function(eta, prep, i, fprep = NULL) { + if (has_ac_class(prep$ac$acef, "arma")) { + if (!is.null(prep$ac$err)) { + # ARMA correlations via latent residuals + eta <- eta + p(prep$ac$err, i, row = FALSE) + } else { + # ARMA correlations via explicit natural residuals + if (!is.null(i)) { + stop2("Pointwise evaluation is not possible for ARMA models.") + } + eta <- .predictor_arma( + eta, ar = prep$ac$ar, ma = prep$ac$ma, + Y = prep$ac$Y, J_lag = prep$ac$J_lag, + fprep = fprep + ) + } + } + if (has_ac_class(prep$ac$acef, "car")) { + eta <- eta + .predictor_re(Z = p(prep$ac$Zcar, i), r = prep$ac$rcar) + } + eta +} + +# add ARMA effects to a predictor matrix +# @param eta linear predictor matrix +# @param ar optional autoregressive draws +# @param ma optional moving average draws +# @param Y vector of response values +# @param J_lag autocorrelation lag for each observation +# @return linear predictor matrix updated by ARMA effects +.predictor_arma <- function(eta, ar = NULL, ma = NULL, Y = NULL, J_lag = NULL, + fprep = NULL) { + if (is.null(ar) && is.null(ma)) { + return(eta) + } + if (anyNA(Y)) { + # predicting Y will be necessary at some point + stopifnot(is.brmsprep(fprep) || is.mvbrmsprep(fprep)) + pp_fun <- paste0("posterior_predict_", fprep$family$fun) + pp_fun <- get(pp_fun, asNamespace("brms")) + } + S <- nrow(eta) + N <- length(Y) + max_lag <- max(J_lag, 1) + Kar <- ifelse(is.null(ar), 0, ncol(ar)) + Kma <- ifelse(is.null(ma), 0, ncol(ma)) + # relevant if time-series are shorter than the ARMA orders + take_ar <- seq_len(min(Kar, max_lag)) + take_ma <- seq_len(min(Kma, max_lag)) + ar <- ar[, take_ar, drop = FALSE] + ma <- ma[, take_ma, drop = FALSE] + Err <- array(0, dim = c(S, max_lag, max_lag + 1)) + err <- zero_mat <- matrix(0, nrow = S, ncol = max_lag) + zero_vec <- rep(0, S) + for (n in seq_len(N)) { + if (Kma) { + eta[, n] <- eta[, n] + rowSums(ma * Err[, take_ma, max_lag]) + } + eta_before_ar <- eta[, n] + if (Kar) { + eta[, n] <- eta[, n] + rowSums(ar * Err[, take_ar, max_lag]) + } + # AR terms need to be included in the predictions of y if missing + # the prediction code thus differs from the structure of the Stan code + y <- Y[n] + if (is.na(y)) { + # y was not observed and has to be predicted + fprep$dpars$mu <- eta + y <- pp_fun(n, fprep) + } + # errors in AR models need to be computed before adding AR terms + err[, max_lag] <- y - eta_before_ar + if (J_lag[n] > 0) { + # store residuals of former observations + I <- seq_len(J_lag[n]) + Err[, I, max_lag + 1] <- err[, max_lag + 1 - I] + } + # keep the size of 'err' and 'Err' as small as possible + Err <- abind(Err[, , -1, drop = FALSE], zero_mat) + err <- cbind(err[, -1, drop = FALSE], zero_vec) + } + eta +} diff -Nru r-cran-brms-2.16.3/R/prepare_predictions.R r-cran-brms-2.17.0/R/prepare_predictions.R --- r-cran-brms-2.16.3/R/prepare_predictions.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/prepare_predictions.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,1214 +1,1219 @@ -#' @export -#' @rdname prepare_predictions -prepare_predictions.brmsfit <- function( - x, newdata = NULL, re_formula = NULL, - allow_new_levels = FALSE, sample_new_levels = "uncertainty", - incl_autocor = TRUE, oos = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, - nsamples = NULL, subset = NULL, nug = NULL, smooths_only = FALSE, - offset = TRUE, newdata2 = NULL, new_objects = NULL, point_estimate = NULL, - ... -) { - - x <- restructure(x) - # allows functions to fall back to old default behavior - # which was used when originally fitting the model - options(.brmsfit_version = x$version$brms) - on.exit(options(.brmsfit_version = NULL)) - - snl_options <- c("uncertainty", "gaussian", "old_levels") - sample_new_levels <- match.arg(sample_new_levels, snl_options) - ndraws <- use_alias(ndraws, nsamples) - draw_ids <- use_alias(draw_ids, subset) - warn_brmsfit_multiple(x, newdata = newdata) - newdata2 <- use_alias(newdata2, new_objects) - x <- exclude_terms( - x, incl_autocor = incl_autocor, - offset = offset, smooths_only = smooths_only - ) - resp <- validate_resp(resp, x) - draw_ids <- validate_draw_ids(x, draw_ids, ndraws) - draws <- as_draws_matrix(x) - draws <- suppressMessages(subset_draws(draws, draw = draw_ids)) - draws <- point_draws(draws, point_estimate) - - new_formula <- update_re_terms(x$formula, re_formula) - bterms <- brmsterms(new_formula) - ranef <- tidy_ranef(bterms, x$data) - meef <- tidy_meef(bterms, x$data) - new <- !is.null(newdata) - sdata <- standata( - x, newdata = newdata, re_formula = re_formula, - newdata2 = newdata2, resp = resp, - allow_new_levels = allow_new_levels, - internal = TRUE, ... - ) - prep_ranef <- prepare_predictions_ranef( - ranef = ranef, draws = draws, sdata = sdata, - resp = resp, old_ranef = x$ranef, - sample_new_levels = sample_new_levels, - ) - prepare_predictions( - bterms, draws = draws, sdata = sdata, data = x$data, - prep_ranef = prep_ranef, meef = meef, resp = resp, - sample_new_levels = sample_new_levels, nug = nug, - new = new, oos = oos, stanvars = x$stanvars - ) -} - -prepare_predictions.mvbrmsterms <- function(x, draws, sdata, resp = NULL, ...) { - resp <- validate_resp(resp, x$responses) - if (length(resp) > 1) { - if (has_subset(x)) { - stop2("Argument 'resp' must be a single variable name ", - "for models using addition argument 'draw_ids'.") - } - out <- list(ndraws = nrow(draws), nobs = sdata$N) - out$resps <- named_list(resp) - out$old_order <- attr(sdata, "old_order") - for (r in resp) { - out$resps[[r]] <- prepare_predictions( - x$terms[[r]], draws = draws, sdata = sdata, ... - ) - } - if (x$rescor) { - out$family <- out$resps[[1]]$family - out$family$fun <- paste0(out$family$family, "_mv") - rescor <- get_cornames(resp, type = "rescor", brackets = FALSE) - out$mvpars$rescor <- prepare_draws(draws, rescor) - if (out$family$family == "student") { - # store in out$dpars so that get_dpar can be called on nu - out$dpars$nu <- as.vector(prepare_draws(draws, "nu")) - } - out$data$N <- out$resps[[1]]$data$N - out$data$weights <- out$resps[[1]]$data$weights - Y <- lapply(out$resps, function(x) x$data$Y) - out$data$Y <- do_call(cbind, Y) - } - out <- structure(out, class = "mvbrmsprep") - } else { - out <- prepare_predictions( - x$terms[[resp]], draws = draws, sdata = sdata, ... - ) - } - out -} - -#' @export -prepare_predictions.brmsterms <- function(x, draws, sdata, data, ...) { - data <- subset_data(data, x) - ndraws <- nrow(draws) - nobs <- sdata[[paste0("N", usc(x$resp))]] - resp <- usc(combine_prefix(x)) - out <- nlist(ndraws, nobs, resp = x$resp) - out$family <- prepare_family(x) - out$old_order <- attr(sdata, "old_order") - valid_dpars <- valid_dpars(x) - out$dpars <- named_list(valid_dpars) - for (dp in valid_dpars) { - dp_regex <- paste0("^", dp, resp, "$") - if (is.btl(x$dpars[[dp]]) || is.btnl(x$dpars[[dp]])) { - out$dpars[[dp]] <- prepare_predictions( - x$dpars[[dp]], draws = draws, - sdata = sdata, data = data, ... - ) - } else if (any(grepl(dp_regex, colnames(draws)))) { - out$dpars[[dp]] <- - as.vector(prepare_draws(draws, dp_regex, regex = TRUE)) - } else if (is.numeric(x$fdpars[[dp]]$value)) { - # fixed dpars are stored as regular draws as of brms 2.12.9 - # so this manual extraction is only required for older models - out$dpars[[dp]] <- x$fdpars[[dp]]$value - } - } - out$nlpars <- named_list(names(x$nlpars)) - for (nlp in names(x$nlpars)) { - out$nlpars[[nlp]] <- prepare_predictions( - x$nlpars[[nlp]], draws = draws, - sdata = sdata, data = data, ... - ) - } - if (is.mixfamily(x$family)) { - families <- family_names(x$family) - thetas <- paste0("theta", seq_along(families)) - if (any(ulapply(out$dpars[thetas], is.list))) { - # theta was predicted - missing_id <- which(ulapply(out$dpars[thetas], is.null)) - out$dpars[[paste0("theta", missing_id)]] <- structure( - data2draws(0, c(ndraws, nobs)), predicted = TRUE - ) - } else { - # theta was not predicted - out$dpars$theta <- do_call(cbind, out$dpars[thetas]) - out$dpars[thetas] <- NULL - if (nrow(out$dpars$theta) == 1L) { - dim <- c(nrow(draws), ncol(out$dpars$theta)) - out$dpars$theta <- data2draws(out$dpars$theta, dim = dim) - } - } - } - if (is_ordinal(x$family)) { - # it is better to handle ordinal thresholds outside the - # main predictor term in particular for use in custom families - if (is.mixfamily(x$family)) { - mu_pars <- str_subset(names(x$dpars), "^mu[[:digit:]]+") - for (mu in mu_pars) { - out$thres[[mu]] <- - prepare_predictions_thres(x$dpars[[mu]], draws, sdata, ...) - } - } else { - out$thres <- prepare_predictions_thres(x$dpars$mu, draws, sdata, ...) - } - } - if (is_cox(x$family)) { - # prepare baseline hazard functions for the Cox model - if (is.mixfamily(x$family)) { - mu_pars <- str_subset(names(x$dpars), "^mu[[:digit:]]+") - for (mu in mu_pars) { - out$bhaz[[mu]] <- prepare_predictions_bhaz( - x$dpars[[mu]], draws, sdata, ... - ) - } - } else { - out$bhaz <- prepare_predictions_bhaz(x$dpars$mu, draws, sdata, ...) - } - } - # response category names for categorical and ordinal models - out$cats <- get_cats(x) - # only include those autocor draws on the top-level - # of the output which imply covariance matrices on natural residuals - out$ac <- prepare_predictions_ac(x$dpars$mu, draws, sdata, nat_cov = TRUE, ...) - out$data <- prepare_predictions_data(x, sdata = sdata, data = data, ...) - structure(out, class = "brmsprep") -} - -#' @export -prepare_predictions.btnl <- function(x, draws, sdata, ...) { - out <- list( - family = x$family, nlform = x$formula[[2]], - ndraws = nrow(draws), - nobs = sdata[[paste0("N", usc(x$resp))]], - used_nlpars = x$used_nlpars, - loop = x$loop - ) - class(out) <- "bprepnl" - p <- usc(combine_prefix(x)) - covars <- all.vars(x$covars) - dim <- c(out$ndraws, out$nobs) - for (i in seq_along(covars)) { - cvalues <- sdata[[paste0("C", p, "_", i)]] - out$C[[covars[i]]] <- data2draws(cvalues, dim = dim) - } - out -} - -#' @export -prepare_predictions.btl <- function(x, draws, sdata, ...) { - ndraws <- nrow(draws) - nobs <- sdata[[paste0("N", usc(x$resp))]] - out <- nlist(family = x$family, ndraws, nobs) - class(out) <- "bprepl" - out$fe <- prepare_predictions_fe(x, draws, sdata, ...) - out$sp <- prepare_predictions_sp(x, draws, sdata, ...) - out$cs <- prepare_predictions_cs(x, draws, sdata, ...) - out$sm <- prepare_predictions_sm(x, draws, sdata, ...) - out$gp <- prepare_predictions_gp(x, draws, sdata, ...) - out$re <- prepare_predictions_re(x, sdata, ...) - out$ac <- prepare_predictions_ac(x, draws, sdata, nat_cov = FALSE, ...) - out$offset <- prepare_predictions_offset(x, sdata, ...) - out -} - -# prepare predictions of ordinary population-level effects -prepare_predictions_fe <- function(bterms, draws, sdata, ...) { - out <- list() - if (is.null(bterms[["fe"]])) { - return(out) - } - p <- usc(combine_prefix(bterms)) - X <- sdata[[paste0("X", p)]] - fixef <- colnames(X) - if (length(fixef)) { - out$X <- X - b_pars <- paste0("b", p, "_", fixef) - out$b <- prepare_draws(draws, b_pars) - } - out -} - -# prepare predictions of special effects terms -prepare_predictions_sp <- function(bterms, draws, sdata, data, - meef = empty_meef(), new = FALSE, ...) { - out <- list() - spef <- tidy_spef(bterms, data) - if (!nrow(spef)) { - return(out) - } - p <- usc(combine_prefix(bterms)) - resp <- usc(bterms$resp) - # prepare calls evaluated in sp_predictor - out$calls <- vector("list", nrow(spef)) - for (i in seq_along(out$calls)) { - call <- spef$joint_call[[i]] - if (!is.null(spef$calls_mo[[i]])) { - new_mo <- paste0(".mo(simo_", spef$Imo[[i]], ", Xmo_", spef$Imo[[i]], ")") - call <- rename(call, spef$calls_mo[[i]], new_mo) - } - if (!is.null(spef$calls_me[[i]])) { - new_me <- paste0("Xme_", seq_along(meef$term)) - call <- rename(call, meef$term, new_me) - } - if (!is.null(spef$calls_mi[[i]])) { - is_na_idx <- is.na(spef$idx2_mi[[i]]) - idx_mi <- paste0("idxl", p, "_", spef$vars_mi[[i]], "_", spef$idx2_mi[[i]]) - idx_mi <- ifelse(is_na_idx, "", paste0("[, ", idx_mi, "]")) - new_mi <- paste0("Yl_", spef$vars_mi[[i]], idx_mi) - call <- rename(call, spef$calls_mi[[i]], new_mi) - } - if (spef$Ic[i] > 0) { - str_add(call) <- paste0(" * Csp_", spef$Ic[i]) - } - out$calls[[i]] <- parse(text = paste0(call)) - } - # extract general data and parameters for special effects - bsp_pars <- paste0("bsp", p, "_", spef$coef) - out$bsp <- prepare_draws(draws, bsp_pars) - colnames(out$bsp) <- spef$coef - # prepare predictions specific to monotonic effects - simo_coef <- get_simo_labels(spef) - Jmo <- sdata[[paste0("Jmo", p)]] - out$simo <- out$Xmo <- named_list(simo_coef) - for (i in seq_along(simo_coef)) { - J <- seq_len(Jmo[i]) - simo_par <- paste0("simo", p, "_", simo_coef[i], "[", J, "]") - out$simo[[i]] <- prepare_draws(draws, simo_par) - out$Xmo[[i]] <- sdata[[paste0("Xmo", p, "_", i)]] - } - # prepare predictions specific to noise-free effects - warn_me <- FALSE - if (nrow(meef)) { - save_mevars <- any(grepl("^Xme_", colnames(draws))) - warn_me <- warn_me || !new && !save_mevars - out$Xme <- named_list(meef$coef) - Xme_regex <- paste0("^Xme_", escape_all(meef$coef), "\\[") - Xn <- sdata[paste0("Xn_", seq_rows(meef))] - noise <- sdata[paste0("noise_", seq_rows(meef))] - groups <- unique(meef$grname) - for (i in seq_along(groups)) { - g <- groups[i] - K <- which(meef$grname %in% g) - if (nzchar(g)) { - Jme <- sdata[[paste0("Jme_", i)]] - } - if (!new && save_mevars) { - # extract original draws of latent variables - for (k in K) { - out$Xme[[k]] <- prepare_draws(draws, Xme_regex[k], regex = TRUE) - } - } else { - # sample new values of latent variables - if (nzchar(g)) { - # TODO: reuse existing levels in predictions? - # represent all indices between 1 and length(unique(Jme)) - Jme <- as.numeric(factor(Jme)) - me_dim <- c(nrow(out$bsp), max(Jme)) - } else { - me_dim <- c(nrow(out$bsp), sdata$N) - } - for (k in K) { - dXn <- data2draws(Xn[[k]], me_dim) - dnoise <- data2draws(noise[[k]], me_dim) - out$Xme[[k]] <- array(rnorm(prod(me_dim), dXn, dnoise), me_dim) - remove(dXn, dnoise) - } - } - if (nzchar(g)) { - for (k in K) { - out$Xme[[k]] <- out$Xme[[k]][, Jme, drop = FALSE] - } - } - } - } - # prepare predictions specific to missing value variables - dim <- c(nrow(out$bsp), sdata[[paste0("N", resp)]]) - vars_mi <- unique(unlist(spef$vars_mi)) - if (length(vars_mi)) { - # we know at this point that the model is multivariate - Yl_names <- paste0("Yl_", vars_mi) - out$Yl <- named_list(Yl_names) - for (i in seq_along(out$Yl)) { - vmi <- vars_mi[i] - dim_y <- c(nrow(out$bsp), sdata[[paste0("N_", vmi)]]) - Y <- data2draws(sdata[[paste0("Y_", vmi)]], dim_y) - sdy <- sdata[[paste0("noise_", vmi)]] - if (is.null(sdy)) { - # missings only - out$Yl[[i]] <- Y - if (!new) { - Ymi_regex <- paste0("^Ymi_", escape_all(vmi), "\\[") - Ymi <- prepare_draws(draws, Ymi_regex, regex = TRUE) - Jmi <- sdata[[paste0("Jmi_", vmi)]] - out$Yl[[i]][, Jmi] <- Ymi - } - } else { - # measurement-error in the response - save_mevars <- any(grepl("^Yl_", colnames(draws))) - if (save_mevars && !new) { - Ymi_regex <- paste0("^Yl_", escape_all(vmi), "\\[") - out$Yl[[i]] <- prepare_draws(draws, Ymi_regex, regex = TRUE) - } else { - warn_me <- warn_me || !new - sdy <- data2draws(sdy, dim) - out$Yl[[i]] <- rcontinuous( - n = prod(dim), dist = "norm", - mean = Y, sd = sdy, - lb = sdata[[paste0("lbmi_", vmi)]], - ub = sdata[[paste0("ubmi_", vmi)]] - ) - out$Yl[[i]] <- array(out$Yl[[i]], dim_y) - } - } - } - # extract index variables belonging to mi terms - uni_mi <- na.omit(attr(spef, "uni_mi")) - idxl_vars <- paste0("idxl", p, "_", uni_mi$var, "_", uni_mi$idx2) - out$idxl <- sdata[idxl_vars] - } - if (warn_me) { - warning2( - "Noise-free latent variables were not saved. ", - "You can control saving those variables via 'save_pars()'. ", - "Treating original data as if it was new data as a workaround." - ) - } - # prepare covariates - ncovars <- max(spef$Ic) - out$Csp <- vector("list", ncovars) - for (i in seq_len(ncovars)) { - out$Csp[[i]] <- sdata[[paste0("Csp", p, "_", i)]] - out$Csp[[i]] <- data2draws(out$Csp[[i]], dim = dim) - } - out -} - -# prepare predictions of category specific effects -prepare_predictions_cs <- function(bterms, draws, sdata, data, ...) { - out <- list() - if (!is_ordinal(bterms$family)) { - return(out) - } - resp <- usc(bterms$resp) - out$nthres <- sdata[[paste0("nthres", resp)]] - csef <- colnames(get_model_matrix(bterms$cs, data)) - if (length(csef)) { - p <- usc(combine_prefix(bterms)) - cs_pars <- paste0("^bcs", p, "_", escape_all(csef), "\\[") - out$bcs <- prepare_draws(draws, cs_pars, regex = TRUE) - out$Xcs <- sdata[[paste0("Xcs", p)]] - } - out -} - -# prepare predictions of smooth terms -prepare_predictions_sm <- function(bterms, draws, sdata, data, ...) { - out <- list() - smef <- tidy_smef(bterms, data) - if (!NROW(smef)) { - return(out) - } - p <- usc(combine_prefix(bterms)) - Xs_names <- attr(smef, "Xs_names") - if (length(Xs_names)) { - out$fe$Xs <- sdata[[paste0("Xs", p)]] - # allow for "b_" prefix for compatibility with version <= 2.5.0 - bspars <- paste0("^bs?", p, "_", escape_all(Xs_names), "$") - out$fe$bs <- prepare_draws(draws, bspars, regex = TRUE) - } - out$re <- named_list(smef$label) - for (i in seq_rows(smef)) { - sm <- list() - for (j in seq_len(smef$nbases[i])) { - sm$Zs[[j]] <- sdata[[paste0("Zs", p, "_", i, "_", j)]] - spars <- paste0("^s", p, "_", smef$label[i], "_", j, "\\[") - sm$s[[j]] <- prepare_draws(draws, spars, regex = TRUE) - } - out$re[[i]] <- sm - } - out -} - -# prepare predictions for Gaussian processes -# @param new is new data used? -# @param nug small numeric value to avoid numerical problems in GPs -prepare_predictions_gp <- function(bterms, draws, sdata, data, - new = FALSE, nug = NULL, ...) { - gpef <- tidy_gpef(bterms, data) - if (!nrow(gpef)) { - return(list()) - } - p <- usc(combine_prefix(bterms)) - if (is.null(nug)) { - # nug for old data must be the same as in the Stan code as even tiny - # differences (e.g., 1e-12 vs. 1e-11) will matter for larger lscales - nug <- ifelse(new, 1e-8, 1e-12) - } - out <- named_list(gpef$label) - for (i in seq_along(out)) { - cons <- gpef$cons[[i]] - if (length(cons)) { - gp <- named_list(cons) - for (j in seq_along(cons)) { - gp[[j]] <- .prepare_predictions_gp( - gpef, draws = draws, sdata = sdata, - nug = nug, new = new, byj = j, p = p, i = i - ) - } - attr(gp, "byfac") <- TRUE - } else { - gp <- .prepare_predictions_gp( - gpef, draws = draws, sdata = sdata, - nug = nug, new = new, p = p, i = i - ) - } - out[[i]] <- gp - } - out -} - -# prepare predictions for Gaussian processes -# @param gpef output of tidy_gpef -# @param p prefix created by combine_prefix() -# @param i indiex of the Gaussian process -# @param byj index for the contrast of a categorical 'by' variable -# @return a list to be evaluated by .predictor_gp() -.prepare_predictions_gp <- function(gpef, draws, sdata, nug, - new, p, i, byj = NULL) { - sfx1 <- escape_all(gpef$sfx1[[i]]) - sfx2 <- escape_all(gpef$sfx2[[i]]) - if (is.null(byj)) { - lvl <- "" - } else { - lvl <- gpef$bylevels[[i]][byj] - sfx1 <- sfx1[byj] - sfx2 <- sfx2[byj, ] - } - j <- usc(byj) - pi <- paste0(p, "_", i) - gp <- list() - sdgp <- paste0("^sdgp", p, "_", sfx1, "$") - gp$sdgp <- as.vector(prepare_draws(draws, sdgp, regex = TRUE)) - lscale <- paste0("^lscale", p, "_", sfx2, "$") - gp$lscale <- prepare_draws(draws, lscale, regex = TRUE) - zgp_regex <- paste0("^zgp", p, "_", sfx1, "\\[") - gp$zgp <- prepare_draws(draws, zgp_regex, regex = TRUE) - Xgp_name <- paste0("Xgp", pi, j) - Igp_name <- paste0("Igp", pi, j) - Jgp_name <- paste0("Jgp", pi, j) - if (new && isNA(gpef$k[i])) { - # in exact GPs old covariate values are required for predictions - gp$x <- sdata[[paste0(Xgp_name, "_old")]] - # nug for old data must be the same as in the Stan code as even tiny - # differences (e.g., 1e-12 vs. 1e-11) will matter for larger lscales - gp$nug <- 1e-12 - # computing GPs for new data requires the old GP terms - gp$yL <- .predictor_gp(gp) - gp$x_new <- sdata[[Xgp_name]] - gp$Igp <- sdata[[Igp_name]] - } else { - gp$x <- sdata[[Xgp_name]] - gp$Igp <- sdata[[Igp_name]] - if (!isNA(gpef$k[i])) { - gp$slambda <- sdata[[paste0("slambda", pi, j)]] - } - } - gp$Jgp <- sdata[[Jgp_name]] - # possible factor from 'by' variable - gp$Cgp <- sdata[[paste0("Cgp", pi, j)]] - gp$nug <- nug - gp -} - -# prepare predictions for all group level effects -# needs to be separate from 'prepare_predictions_re' to take correlations -# across responses and distributional parameters into account (#779) -# @param ranef output of 'tidy_ranef' based on the new formula and old data -# @param old_ranef same as 'ranef' but based on the original formula -# @return a named list with one element per group containing posterior draws -# of levels used in the data as well as additional meta-data -prepare_predictions_ranef <- function(ranef, draws, sdata, old_ranef, resp = NULL, - sample_new_levels = "uncertainty", ...) { - if (!nrow(ranef)) { - return(list()) - } - # ensures subsetting 'ranef' by 'resp' works correctly - resp <- resp %||% "" - groups <- unique(ranef$group) - out <- named_list(groups, list()) - for (g in groups) { - # prepare general variables related to group g - ranef_g <- subset2(ranef, group = g) - old_ranef_g <- subset2(old_ranef, group = g) - used_levels <- attr(sdata, "levels")[[g]] - old_levels <- attr(old_ranef, "levels")[[g]] - nlevels <- length(old_levels) - nranef <- nrow(ranef_g) - # prepare draws of group-level effects - rpars <- paste0("^r_", g, "(__.+)?\\[") - rdraws <- prepare_draws(draws, rpars, regex = TRUE) - if (!length(rdraws)) { - stop2( - "Group-level coefficients of group '", g, "' not found. ", - "You can control saving those coefficients via 'save_pars()'." - ) - } - # only prepare predictions of effects specified in the new formula - cols_match <- c("coef", "resp", "dpar", "nlpar") - used_rpars <- which(find_rows(old_ranef_g, ls = ranef_g[cols_match])) - used_rpars <- outer(seq_len(nlevels), (used_rpars - 1) * nlevels, "+") - used_rpars <- as.vector(used_rpars) - rdraws <- rdraws[, used_rpars, drop = FALSE] - rdraws <- column_to_row_major_order(rdraws, nranef) - # prepare data required for indexing parameters - gtype <- ranef_g$gtype[1] - resp_g <- intersect(ranef_g$resp, resp)[1] - # any valid ID works here as J and W are independent of the ID - id <- subset2(ranef_g, resp = resp)$id[1] - idresp <- paste0(id, usc(resp_g)) - if (gtype == "mm") { - ngf <- length(ranef_g$gcall[[1]]$groups) - gf <- sdata[paste0("J_", idresp, "_", seq_len(ngf))] - weights <- sdata[paste0("W_", idresp, "_", seq_len(ngf))] - } else { - gf <- sdata[paste0("J_", idresp)] - weights <- list(rep(1, length(gf[[1]]))) - } - # generate draws for new levels - args_new_rdraws <- nlist( - ranef = ranef_g, gf, used_levels, old_levels, - rdraws = rdraws, draws, sample_new_levels - ) - new_rdraws <- do_call(get_new_rdraws, args_new_rdraws) - max_level <- attr(new_rdraws, "max_level") - gf <- attr(new_rdraws, "gf") - rdraws <- cbind(rdraws, new_rdraws) - # keep only those levels actually used in the current data - levels <- unique(unlist(gf)) - rdraws <- subset_levels(rdraws, levels, nranef) - # store all information required in 'prepare_predictions_re' - out[[g]]$ranef <- ranef_g - out[[g]]$rdraws <- rdraws - out[[g]]$levels <- levels - out[[g]]$nranef <- nranef - out[[g]]$max_level <- max_level - out[[g]]$gf <- gf - out[[g]]$weights <- weights - } - out -} - -# prepare predictions of group-level effects -# @param prep_ranef a named list with one element per group containing -# posterior draws of levels as well as additional meta-data -prepare_predictions_re <- function(bterms, sdata, prep_ranef = list(), - sample_new_levels = "uncertainty", ...) { - out <- list() - if (!length(prep_ranef)) { - return(out) - } - px <- check_prefix(bterms) - p <- usc(combine_prefix(px)) - ranef_px <- lapply(prep_ranef, "[[", "ranef") - ranef_px <- do_call(rbind, ranef_px) - ranef_px <- subset2(ranef_px, ls = px) - if (!NROW(ranef_px)) { - return(out) - } - groups <- unique(ranef_px$group) - # assigning S4 objects requires initialisation of list elements - out[c("Z", "Zsp", "Zcs")] <- list(named_list(groups)) - for (g in groups) { - # extract variables specific to group 'g' - ranef_g <- prep_ranef[[g]]$ranef - ranef_g_px <- subset2(ranef_g, ls = px) - rdraws <- prep_ranef[[g]]$rdraws - nranef <- prep_ranef[[g]]$nranef - levels <- prep_ranef[[g]]$levels - max_level <- prep_ranef[[g]]$max_level - gf <- prep_ranef[[g]]$gf - weights <- prep_ranef[[g]]$weights - # TODO: define 'select' according to parameter names not by position - # store draws and corresponding data in the output - # special group-level terms (mo, me, mi) - ranef_g_px_sp <- subset2(ranef_g_px, type = "sp") - if (nrow(ranef_g_px_sp)) { - Z <- matrix(1, length(gf[[1]])) - out[["Zsp"]][[g]] <- prepare_Z(Z, gf, max_level, weights) - for (co in ranef_g_px_sp$coef) { - # select from all varying effects of that group - select <- find_rows(ranef_g, ls = px) & - ranef_g$coef == co & ranef_g$type == "sp" - select <- which(select) - select <- select + nranef * (seq_along(levels) - 1) - out[["rsp"]][[co]][[g]] <- rdraws[, select, drop = FALSE] - } - } - # category specific group-level terms - ranef_g_px_cs <- subset2(ranef_g_px, type = "cs") - if (nrow(ranef_g_px_cs)) { - # all categories share the same Z matrix - ranef_g_px_cs_1 <- ranef_g_px_cs[grepl("\\[1\\]$", ranef_g_px_cs$coef), ] - Znames <- paste0("Z_", ranef_g_px_cs_1$id, p, "_", ranef_g_px_cs_1$cn) - Z <- do_call(cbind, sdata[Znames]) - out[["Zcs"]][[g]] <- prepare_Z(Z, gf, max_level, weights) - for (i in seq_len(sdata$nthres)) { - index <- paste0("\\[", i, "\\]$") - # select from all varying effects of that group - select <- find_rows(ranef_g, ls = px) & - grepl(index, ranef_g$coef) & ranef_g$type == "cs" - select <- which(select) - select <- as.vector(outer(select, nranef * (seq_along(levels) - 1), "+")) - out[["rcs"]][[g]][[i]] <- rdraws[, select, drop = FALSE] - } - } - # basic group-level terms - ranef_g_px_basic <- subset2(ranef_g_px, type = c("", "mmc")) - if (nrow(ranef_g_px_basic)) { - Znames <- paste0("Z_", ranef_g_px_basic$id, p, "_", ranef_g_px_basic$cn) - if (ranef_g_px_basic$gtype[1] == "mm") { - ng <- length(ranef_g_px_basic$gcall[[1]]$groups) - Z <- vector("list", ng) - for (k in seq_len(ng)) { - Z[[k]] <- do_call(cbind, sdata[paste0(Znames, "_", k)]) - } - } else { - Z <- do_call(cbind, sdata[Znames]) - } - out[["Z"]][[g]] <- prepare_Z(Z, gf, max_level, weights) - # select from all varying effects of that group - select <- find_rows(ranef_g, ls = px) & ranef_g$type %in% c("", "mmc") - select <- which(select) - select <- as.vector(outer(select, nranef * (seq_along(levels) - 1), "+")) - out[["r"]][[g]] <- rdraws[, select, drop = FALSE] - } - } - out -} - -# prepare predictions of autocorrelation parameters -# @param nat_cov extract terms for covariance matrices of natural residuals? -prepare_predictions_ac <- function(bterms, draws, sdata, oos = NULL, - nat_cov = FALSE, new = FALSE, ...) { - out <- list() - nat_cov <- as_one_logical(nat_cov) - acef <- tidy_acef(bterms) - acef <- subset2(acef, nat_cov = nat_cov) - if (!NROW(acef)) { - return(out) - } - out$acef <- acef - p <- usc(combine_prefix(bterms)) - out$N_tg <- sdata[[paste0("N_tg", p)]] - if (has_ac_class(acef, "arma")) { - acef_arma <- subset2(acef, class = "arma") - out$Y <- sdata[[paste0("Y", p)]] - if (!is.null(oos)) { - if (any(oos > length(out$Y))) { - stop2("'oos' should not contain integers larger than N.") - } - # .predictor_arma has special behavior for NA responses - out$Y[oos] <- NA - } - out$J_lag <- sdata[[paste0("J_lag", p)]] - if (acef_arma$p > 0) { - ar_regex <- paste0("^ar", p, "\\[") - out$ar <- prepare_draws(draws, ar_regex, regex = TRUE) - } - if (acef_arma$q > 0) { - ma_regex <- paste0("^ma", p, "\\[") - out$ma <- prepare_draws(draws, ma_regex, regex = TRUE) - } - } - if (has_ac_class(acef, "cosy")) { - cosy_regex <- paste0("^cosy", p, "$") - out$cosy <- prepare_draws(draws, cosy_regex, regex = TRUE) - } - if (use_ac_cov_time(acef)) { - # prepare predictions for the covariance structures of time-series models - out$begin_tg <- sdata[[paste0("begin_tg", p)]] - out$end_tg <- sdata[[paste0("end_tg", p)]] - } - if (has_ac_latent_residuals(bterms)) { - err_regex <- paste0("^err", p, "\\[") - has_err <- any(grepl(err_regex, colnames(draws))) - if (has_err && !new) { - out$err <- prepare_draws(draws, err_regex, regex = TRUE) - } else { - if (!use_ac_cov_time(acef)) { - stop2("Cannot predict new latent residuals ", - "when using cov = FALSE in autocor terms.") - } - # need to sample correlated residuals - out$err <- matrix(nrow = nrow(draws), ncol = length(out$Y)) - sderr_regex <- paste0("^sderr", p, "$") - out$sderr <- prepare_draws(draws, sderr_regex, regex = TRUE) - for (i in seq_len(out$N_tg)) { - obs <- with(out, begin_tg[i]:end_tg[i]) - zeros <- rep(0, length(obs)) - cov <- get_cov_matrix_ac(list(ac = out), obs, latent = TRUE) - .err <- function(s) rmulti_normal(1, zeros, Sigma = cov[s, , ]) - out$err[, obs] <- rblapply(seq_rows(draws), .err) - } - } - } - if (has_ac_class(acef, "sar")) { - lagsar_regex <- paste0("^lagsar", p, "$") - errorsar_regex <- paste0("^errorsar", p, "$") - out$lagsar <- prepare_draws(draws, lagsar_regex, regex = TRUE) - out$errorsar <- prepare_draws(draws, errorsar_regex, regex = TRUE) - out$Msar <- sdata[[paste0("Msar", p)]] - } - if (has_ac_class(acef, "car")) { - acef_car <- subset2(acef, class = "car") - if (new && acef_car$gr == "NA") { - stop2("Without a grouping factor, CAR models cannot handle newdata.") - } - gcar <- sdata[[paste0("Jloc", p)]] - Zcar <- matrix(rep(1, length(gcar))) - out$Zcar <- prepare_Z(Zcar, list(gcar)) - rcar_regex <- paste0("^rcar", p, "\\[") - rcar <- prepare_draws(draws, rcar_regex, regex = TRUE) - rcar <- rcar[, unique(gcar), drop = FALSE] - out$rcar <- rcar - } - if (has_ac_class(acef, "fcor")) { - out$Mfcor <- sdata[[paste0("Mfcor", p)]] - } - out -} - -prepare_predictions_offset <- function(bterms, sdata, ...) { - p <- usc(combine_prefix(bterms)) - sdata[[paste0("offsets", p)]] -} - -# prepare predictions of ordinal thresholds -prepare_predictions_thres <- function(bterms, draws, sdata, ...) { - out <- list() - if (!is_ordinal(bterms$family)) { - return(out) - } - resp <- usc(bterms$resp) - out$nthres <- sdata[[paste0("nthres", resp)]] - out$Jthres <- sdata[[paste0("Jthres", resp)]] - p <- usc(combine_prefix(bterms)) - thres_regex <- paste0("^b", p, "_Intercept\\[") - out$thres <- prepare_draws(draws, thres_regex, regex = TRUE) - out -} - -# prepare predictions of baseline functions for the cox model -prepare_predictions_bhaz <- function(bterms, draws, sdata, ...) { - if (!is_cox(bterms$family)) { - return(NULL) - } - out <- list() - p <- usc(combine_prefix(bterms)) - sbhaz_regex <- paste0("^sbhaz", p) - sbhaz <- prepare_draws(draws, sbhaz_regex, regex = TRUE) - Zbhaz <- sdata[[paste0("Zbhaz", p)]] - out$bhaz <- tcrossprod(sbhaz, Zbhaz) - Zcbhaz <- sdata[[paste0("Zcbhaz", p)]] - out$cbhaz <- tcrossprod(sbhaz, Zcbhaz) - out -} - -# extract data mainly related to the response variable -prepare_predictions_data <- function(bterms, sdata, data, stanvars = NULL, ...) { - resp <- usc(combine_prefix(bterms)) - vars <- c( - "Y", "trials", "ncat", "nthres", "se", "weights", - "denom", "dec", "cens", "rcens", "lb", "ub" - ) - vars <- paste0(vars, resp) - vars <- intersect(vars, names(sdata)) - # variables of variable length need to be handled via regular expression - escaped_resp <- escape_all(resp) - vl_vars <- c("vreal", "vint") - vl_vars <- regex_or(vl_vars) - vl_vars <- paste0("^", vl_vars, "[[:digit:]]+", escaped_resp, "$") - vl_vars <- str_subset(names(sdata), vl_vars) - vars <- union(vars, vl_vars) - out <- sdata[vars] - # remove resp suffix from names to simplify post-processing - names(out) <- sub(paste0(escaped_resp, "$"), "", names(out)) - if (length(stanvars)) { - stopifnot(is.stanvars(stanvars)) - out[names(stanvars)] <- sdata[names(stanvars)] - } - out -} - -# choose number of observations to be used in post-processing methods -choose_N <- function(prep) { - stopifnot(is.brmsprep(prep) || is.mvbrmsprep(prep)) - if (!is.null(prep$ac$N_tg)) prep$ac$N_tg else prep$nobs -} - -# create pseudo brmsprep objects for components of mixture models -# @param comp the mixture component number -# @param draw_ids see predict_mixture -pseudo_prep_for_mixture <- function(prep, comp, draw_ids = NULL) { - stopifnot(is.brmsprep(prep), is.mixfamily(prep$family)) - if (!is.null(draw_ids)) { - ndraws <- length(draw_ids) - } else { - ndraws <- prep$ndraws - } - out <- list( - family = prep$family$mix[[comp]], ndraws = ndraws, - nobs = prep$nobs, data = prep$data - ) - out$family$fun <- out$family$family - for (dp in valid_dpars(out$family)) { - out$dpars[[dp]] <- prep$dpars[[paste0(dp, comp)]] - if (length(draw_ids) && length(out$dpars[[dp]]) > 1L) { - out$dpars[[dp]] <- p(out$dpars[[dp]], draw_ids, row = TRUE) - } - } - if (is_ordinal(out$family)) { - out$thres <- prep$thres[[paste0("mu", comp)]] - } - if (is_cox(out$family)) { - out$bhaz <- prep$bhaz[[paste0("mu", comp)]] - } - # weighting should happen after computing the mixture - out$data$weights <- NULL - structure(out, class = "brmsprep") -} - -# take relevant cols of a matrix of group-level terms -# if only a subset of levels is provided (for newdata) -# @param x a matrix typically draws of r or Z design matrices -# draws need to be stored in row major order -# @param levels grouping factor levels to keep -# @param nranef number of group-level effects -subset_levels <- function(x, levels, nranef) { - take_levels <- ulapply(levels, - function(l) ((l - 1) * nranef + 1):(l * nranef) - ) - x[, take_levels, drop = FALSE] -} - -# transform x from column to row major order -# rows represent levels and columns represent effects -# @param x a matrix of draws of group-level parameters -# @param nranef number of group-level effects -column_to_row_major_order <- function(x, nranef) { - nlevels <- ncol(x) / nranef - sort_levels <- ulapply(seq_len(nlevels), - function(l) seq(l, ncol(x), by = nlevels) - ) - x[, sort_levels, drop = FALSE] -} - -# prepare group-level design matrices for use in 'predictor' -# @param Z (list of) matrices to be prepared -# @param gf (list of) vectors containing grouping factor values -# @param weights optional (list of) weights of the same length as gf -# @param max_level maximal level of 'gf' -# @return a sparse matrix representation of Z -prepare_Z <- function(Z, gf, max_level = NULL, weights = NULL) { - if (!is.list(Z)) { - Z <- list(Z) - } - if (!is.list(gf)) { - gf <- list(gf) - } - if (is.null(weights)) { - weights <- rep(1, length(gf[[1]])) - } - if (!is.list(weights)) { - weights <- list(weights) - } - if (is.null(max_level)) { - max_level <- max(unlist(gf)) - } - levels <- unique(unlist(gf)) - nranef <- ncol(Z[[1]]) - Z <- mapply( - expand_matrix, A = Z, x = gf, weights = weights, - MoreArgs = nlist(max_level) - ) - Z <- Reduce("+", Z) - subset_levels(Z, levels, nranef) -} - -# expand a matrix into a sparse matrix of higher dimension -# @param A matrix to be expanded -# @param x levels to expand the matrix -# @param max_level maximal number of levels that x can take on -# @param weights weights to apply to rows of A before expanding -# @param a sparse matrix of dimension nrow(A) x (ncol(A) * max_level) -expand_matrix <- function(A, x, max_level = max(x), weights = 1) { - stopifnot(is.matrix(A)) - stopifnot(length(x) == nrow(A)) - stopifnot(all(is_wholenumber(x) & x > 0)) - stopifnot(length(weights) %in% c(1, nrow(A), prod(dim(A)))) - A <- A * as.vector(weights) - K <- ncol(A) - i <- rep(seq_along(x), each = K) - make_j <- function(n, K, x) K * (x[n] - 1) + 1:K - j <- ulapply(seq_along(x), make_j, K = K, x = x) - Matrix::sparseMatrix( - i = i, j = j, x = as.vector(t(A)), - dims = c(nrow(A), ncol(A) * max_level) - ) -} - -# generate draws for new group levels -# @param ranef 'ranef_frame' object of only a single grouping variable -# @param gf list of vectors of level indices in the current data -# @param rdraws matrix of group-level draws in row major order -# @param used_levels names of levels used in the current data -# @param old_levels names of levels used in the original data -# @param sample_new_levels specifies the way in which new draws are generated -# @param draws optional matrix of draws from all model parameters -# @return a matrix of draws for new group levels -get_new_rdraws <- function(ranef, gf, rdraws, used_levels, old_levels, - sample_new_levels, draws = NULL) { - snl_options <- c("uncertainty", "gaussian", "old_levels") - sample_new_levels <- match.arg(sample_new_levels, snl_options) - g <- unique(ranef$group) - stopifnot(length(g) == 1L) - stopifnot(is.list(gf)) - used_by_per_level <- attr(used_levels, "by") - old_by_per_level <- attr(old_levels, "by") - new_levels <- setdiff(used_levels, old_levels) - nranef <- nrow(ranef) - nlevels <- length(old_levels) - max_level <- nlevels - - out <- vector("list", length(gf)) - for (i in seq_along(gf)) { - has_new_levels <- any(gf[[i]] > nlevels) - if (has_new_levels) { - new_indices <- sort(setdiff(gf[[i]], seq_len(nlevels))) - out[[i]] <- matrix(NA, nrow(rdraws), nranef * length(new_indices)) - if (sample_new_levels == "uncertainty") { - for (j in seq_along(new_indices)) { - # selected levels need to be the same for all varying effects - # to correctly take their correlations into account - if (length(old_by_per_level)) { - # select from all levels matching the 'by' variable - new_by <- used_by_per_level[used_levels == new_levels[j]] - possible_levels <- old_levels[old_by_per_level == new_by] - possible_levels <- which(old_levels %in% possible_levels) - sel_levels <- sample(possible_levels, NROW(rdraws), TRUE) - } else { - # select from all levels - sel_levels <- sample(seq_len(nlevels), NROW(rdraws), TRUE) - } - for (k in seq_len(nranef)) { - for (s in seq_rows(rdraws)) { - sel <- (sel_levels[s] - 1) * nranef + k - out[[i]][s, (j - 1) * nranef + k] <- rdraws[s, sel] - } - } - } - } else if (sample_new_levels == "old_levels") { - for (j in seq_along(new_indices)) { - # choose an existing person to take the parameters from - if (length(old_by_per_level)) { - # select from all levels matching the 'by' variable - new_by <- used_by_per_level[used_levels == new_levels[j]] - possible_levels <- old_levels[old_by_per_level == new_by] - possible_levels <- which(old_levels %in% possible_levels) - sel_level <- sample(possible_levels, 1) - } else { - # select from all levels - sel_level <- sample(seq_len(nlevels), 1) - } - for (k in seq_len(nranef)) { - sel <- (sel_level - 1) * nranef + k - out[[i]][, (j - 1) * nranef + k] <- rdraws[, sel] - } - } - } else if (sample_new_levels == "gaussian") { - if (any(!ranef$dist %in% "gaussian")) { - stop2("Option sample_new_levels = 'gaussian' is not ", - "available for non-gaussian group-level effects.") - } - for (j in seq_along(new_indices)) { - # extract hyperparameters used to compute the covariance matrix - if (length(old_by_per_level)) { - new_by <- used_by_per_level[used_levels == new_levels[j]] - rnames <- as.vector(get_rnames(ranef, bylevels = new_by)) - } else { - rnames <- get_rnames(ranef) - } - sd_pars <- paste0("sd_", g, "__", rnames) - sd_draws <- prepare_draws(draws, sd_pars) - cor_type <- paste0("cor_", g) - cor_pars <- get_cornames(rnames, cor_type, brackets = FALSE) - cor_draws <- matrix(0, nrow(sd_draws), length(cor_pars)) - for (k in seq_along(cor_pars)) { - if (cor_pars[k] %in% colnames(draws)) { - cor_draws[, k] <- prepare_draws(draws, cor_pars[k]) - } - } - cov_matrix <- get_cov_matrix(sd_draws, cor_draws) - # sample new levels from the normal distribution - # implied by the covariance matrix - indices <- ((j - 1) * nranef + 1):(j * nranef) - out[[i]][, indices] <- t(apply( - cov_matrix, 1, rmulti_normal, - n = 1, mu = rep(0, length(sd_pars)) - )) - } - } - max_level <- max_level + length(new_indices) - } else { - out[[i]] <- matrix(nrow = nrow(rdraws), ncol = 0) - } - } - out <- do_call(cbind, out) - structure(out, gf = gf, max_level = max_level) -} - -# prepare draws of selected variables -prepare_draws <- function(x, variable, ...) { - x <- subset_draws(x, variable = variable, ...) - # brms still assumes standard dropping behavior in many places - # and so keeping the posterior format is dangerous at the moment - unclass_draws(x) -} - -# compute point estimates of posterior draws -# currently used primarily for 'loo_subsample' -# @param draws matrix of posterior draws -# @param point_estimate optional name of the point estimate to be computed -# @return a draws_matrix with one row -point_draws <- function(draws, point_estimate = NULL) { - if (is.null(point_estimate)) { - return(draws) - } - point_estimate <- match.arg(point_estimate, c("mean", "median")) - variables <- colnames(draws) - if (point_estimate == "mean") { - draws <- matrixStats::colMeans2(draws) - } else if (point_estimate == "median") { - draws <- matrixStats::colMedians(draws) - } - draws <- t(draws) - colnames(draws) <- variables - as_draws_matrix(draws) -} - -is.brmsprep <- function(x) { - inherits(x, "brmsprep") -} - -is.mvbrmsprep <- function(x) { - inherits(x, "mvbrmsprep") -} - -is.bprepl <- function(x) { - inherits(x, "bprepl") -} - -is.bprepnl <- function(x) { - inherits(x, "bprepnl") -} - -#' Prepare Predictions -#' -#' This method helps in preparing \pkg{brms} models for certin post-processing -#' tasks most notably various forms of predictions. Unless you are a package -#' developer, you will rarely need to call \code{prepare_predictions} directly. -#' -#' @name prepare_predictions -#' @aliases prepare_predictions.brmsfit extract_draws -#' -#' @param x An \R object typically of class \code{'brmsfit'}. -#' @param newdata An optional data.frame for which to evaluate predictions. If -#' \code{NULL} (default), the original data of the model is used. -#' \code{NA} values within factors are interpreted as if all dummy -#' variables of this factor are zero. This allows, for instance, to make -#' predictions of the grand mean when using sum coding. -#' @param re_formula formula containing group-level effects to be considered in -#' the prediction. If \code{NULL} (default), include all group-level effects; -#' if \code{NA}, include no group-level effects. -#' @param allow_new_levels A flag indicating if new levels of group-level -#' effects are allowed (defaults to \code{FALSE}). Only relevant if -#' \code{newdata} is provided. -#'@param sample_new_levels Indicates how to sample new levels for grouping -#' factors specified in \code{re_formula}. This argument is only relevant if -#' \code{newdata} is provided and \code{allow_new_levels} is set to -#' \code{TRUE}. If \code{"uncertainty"} (default), each posterior sample for a -#' new level is drawn from the posterior draws of a randomly chosen existing -#' level. Each posterior sample for a new level may be drawn from a different -#' existing level such that the resulting set of new posterior draws -#' represents the variation across existing levels. If \code{"gaussian"}, -#' sample new levels from the (multivariate) normal distribution implied by the -#' group-level standard deviations and correlations. This options may be useful -#' for conducting Bayesian power analysis or predicting new levels in -#' situations where relatively few levels where observed in the old_data. If -#' \code{"old_levels"}, directly sample new levels from the existing levels, -#' where a new level is assigned all of the posterior draws of the same -#' (randomly chosen) existing level. -#' @param newdata2 A named \code{list} of objects containing new data, which -#' cannot be passed via argument \code{newdata}. Required for some objects -#' used in autocorrelation structures, or \code{\link{stanvars}}. -#' @param new_objects Deprecated alias of \code{newdata2}. -#' @param incl_autocor A flag indicating if correlation structures originally -#' specified via \code{autocor} should be included in the predictions. -#' Defaults to \code{TRUE}. -#' @param offset Logical; Indicates if offsets should be included in the -#' predictions. Defaults to \code{TRUE}. -#' @param oos Optional indices of observations for which to compute -#' out-of-sample rather than in-sample predictions. Only required in models -#' that make use of response values to make predictions, that is, currently -#' only ARMA models. -#' @param smooths_only Logical; If \code{TRUE} only predictions related to the -#' @param resp Optional names of response variables. If specified, predictions -#' are performed only for the specified response variables. -#' @param ndraws Positive integer indicating how many posterior draws should -#' be used. If \code{NULL} (the default) all draws are used. Ignored if -#' \code{draw_ids} is not \code{NULL}. -#' @param draw_ids An integer vector specifying the posterior draws to be used. -#' If \code{NULL} (the default), all draws are used. -#' @param nsamples Deprecated alias of \code{ndraws}. -#' @param subset Deprecated alias of \code{draw_ids}. -#' @param nug Small positive number for Gaussian process terms only. For -#' numerical reasons, the covariance matrix of a Gaussian process might not be -#' positive definite. Adding a very small number to the matrix's diagonal -#' often solves this problem. If \code{NULL} (the default), \code{nug} is -#' chosen internally. -#' @param point_estimate Shall the returned object contain only point estimates -#' of the parameters instead of their posterior draws? Defaults to -#' \code{NULL} in which case no point estimate is computed. Alternatively, may -#' be set to \code{"mean"} or \code{"median"}. This argument is primarily -#' implemented to ensure compatibility with the \code{\link{loo_subsample}} -#' method. -#' @param ... Further arguments passed to \code{\link{validate_newdata}}. -#' -#' @return An object of class \code{'brmsprep'} or \code{'mvbrmsprep'}, -#' depending on whether a univariate or multivariate model is passed. -#' -#' @export -prepare_predictions <- function(x, ...) { - UseMethod("prepare_predictions") -} - -#' @export -prepare_predictions.default <- function(x, ...) { - NULL -} - -# the name 'extract_draws' is deprecated as of brms 2.12.6 -# remove it eventually in brms 3.0 -#' @export -extract_draws <- function(x, ...) { - warning2("Method 'extract_draws' is deprecated. ", - "Please use 'prepare_predictions' instead.") - UseMethod("prepare_predictions") -} +#' @export +#' @rdname prepare_predictions +prepare_predictions.brmsfit <- function( + x, newdata = NULL, re_formula = NULL, + allow_new_levels = FALSE, sample_new_levels = "uncertainty", + incl_autocor = TRUE, oos = NULL, resp = NULL, ndraws = NULL, draw_ids = NULL, + nsamples = NULL, subset = NULL, nug = NULL, smooths_only = FALSE, + offset = TRUE, newdata2 = NULL, new_objects = NULL, point_estimate = NULL, + ... +) { + + x <- restructure(x) + # allows functions to fall back to old default behavior + # which was used when originally fitting the model + options(.brmsfit_version = x$version$brms) + on.exit(options(.brmsfit_version = NULL)) + + snl_options <- c("uncertainty", "gaussian", "old_levels") + sample_new_levels <- match.arg(sample_new_levels, snl_options) + ndraws <- use_alias(ndraws, nsamples) + draw_ids <- use_alias(draw_ids, subset) + warn_brmsfit_multiple(x, newdata = newdata) + newdata2 <- use_alias(newdata2, new_objects) + x <- exclude_terms( + x, incl_autocor = incl_autocor, + offset = offset, smooths_only = smooths_only + ) + resp <- validate_resp(resp, x) + draw_ids <- validate_draw_ids(x, draw_ids, ndraws) + draws <- as_draws_matrix(x) + draws <- suppressMessages(subset_draws(draws, draw = draw_ids)) + draws <- point_draws(draws, point_estimate) + + new_formula <- update_re_terms(x$formula, re_formula) + bterms <- brmsterms(new_formula) + ranef <- tidy_ranef(bterms, x$data) + meef <- tidy_meef(bterms, x$data) + new <- !is.null(newdata) + sdata <- standata( + x, newdata = newdata, re_formula = re_formula, + newdata2 = newdata2, resp = resp, + allow_new_levels = allow_new_levels, + internal = TRUE, ... + ) + prep_ranef <- prepare_predictions_ranef( + ranef = ranef, draws = draws, sdata = sdata, + resp = resp, old_ranef = x$ranef, + sample_new_levels = sample_new_levels, + ) + prepare_predictions( + bterms, draws = draws, sdata = sdata, data = x$data, + prep_ranef = prep_ranef, meef = meef, resp = resp, + sample_new_levels = sample_new_levels, nug = nug, + new = new, oos = oos, stanvars = x$stanvars + ) +} + +prepare_predictions.mvbrmsterms <- function(x, draws, sdata, resp = NULL, ...) { + resp <- validate_resp(resp, x$responses) + if (length(resp) > 1) { + if (has_subset(x)) { + stop2("Argument 'resp' must be a single variable name ", + "for models using addition argument 'draw_ids'.") + } + out <- list(ndraws = nrow(draws), nobs = sdata$N) + out$resps <- named_list(resp) + out$old_order <- attr(sdata, "old_order") + for (r in resp) { + out$resps[[r]] <- prepare_predictions( + x$terms[[r]], draws = draws, sdata = sdata, ... + ) + } + if (x$rescor) { + out$family <- out$resps[[1]]$family + out$family$fun <- paste0(out$family$family, "_mv") + rescor <- get_cornames(resp, type = "rescor", brackets = FALSE) + out$mvpars$rescor <- prepare_draws(draws, rescor) + if (out$family$family == "student") { + # store in out$dpars so that get_dpar can be called on nu + out$dpars$nu <- as.vector(prepare_draws(draws, "nu")) + } + out$data$N <- out$resps[[1]]$data$N + out$data$weights <- out$resps[[1]]$data$weights + Y <- lapply(out$resps, function(x) x$data$Y) + out$data$Y <- do_call(cbind, Y) + } + out <- structure(out, class = "mvbrmsprep") + } else { + out <- prepare_predictions( + x$terms[[resp]], draws = draws, sdata = sdata, ... + ) + } + out +} + +#' @export +prepare_predictions.brmsterms <- function(x, draws, sdata, data, ...) { + data <- subset_data(data, x) + ndraws <- nrow(draws) + nobs <- sdata[[paste0("N", usc(x$resp))]] + resp <- usc(combine_prefix(x)) + out <- nlist(ndraws, nobs, resp = x$resp) + out$family <- prepare_family(x) + out$old_order <- attr(sdata, "old_order") + valid_dpars <- valid_dpars(x) + out$dpars <- named_list(valid_dpars) + for (dp in valid_dpars) { + dp_regex <- paste0("^", dp, resp, "$") + if (is.btl(x$dpars[[dp]]) || is.btnl(x$dpars[[dp]])) { + out$dpars[[dp]] <- prepare_predictions( + x$dpars[[dp]], draws = draws, + sdata = sdata, data = data, ... + ) + } else if (any(grepl(dp_regex, colnames(draws)))) { + out$dpars[[dp]] <- + as.vector(prepare_draws(draws, dp_regex, regex = TRUE)) + } else if (is.numeric(x$fdpars[[dp]]$value)) { + # fixed dpars are stored as regular draws as of brms 2.12.9 + # so this manual extraction is only required for older models + out$dpars[[dp]] <- x$fdpars[[dp]]$value + } + } + out$nlpars <- named_list(names(x$nlpars)) + for (nlp in names(x$nlpars)) { + out$nlpars[[nlp]] <- prepare_predictions( + x$nlpars[[nlp]], draws = draws, + sdata = sdata, data = data, ... + ) + } + if (is.mixfamily(x$family)) { + families <- family_names(x$family) + thetas <- paste0("theta", seq_along(families)) + if (any(ulapply(out$dpars[thetas], is.list))) { + # theta was predicted + missing_id <- which(ulapply(out$dpars[thetas], is.null)) + out$dpars[[paste0("theta", missing_id)]] <- structure( + data2draws(0, c(ndraws, nobs)), predicted = TRUE + ) + } else { + # theta was not predicted + out$dpars$theta <- do_call(cbind, out$dpars[thetas]) + out$dpars[thetas] <- NULL + if (nrow(out$dpars$theta) == 1L) { + dim <- c(nrow(draws), ncol(out$dpars$theta)) + out$dpars$theta <- data2draws(out$dpars$theta, dim = dim) + } + } + } + if (is_ordinal(x$family)) { + # it is better to handle ordinal thresholds outside the + # main predictor term in particular for use in custom families + if (is.mixfamily(x$family)) { + mu_pars <- str_subset(names(x$dpars), "^mu[[:digit:]]+") + for (mu in mu_pars) { + out$thres[[mu]] <- + prepare_predictions_thres(x$dpars[[mu]], draws, sdata, ...) + } + } else { + out$thres <- prepare_predictions_thres(x$dpars$mu, draws, sdata, ...) + } + } + if (is_logistic_normal(x$family)) { + out$dpars$lncor <- prepare_draws(draws, "^lncor__", regex = TRUE) + } + if (is_cox(x$family)) { + # prepare baseline hazard functions for the Cox model + if (is.mixfamily(x$family)) { + mu_pars <- str_subset(names(x$dpars), "^mu[[:digit:]]+") + for (mu in mu_pars) { + out$bhaz[[mu]] <- prepare_predictions_bhaz( + x$dpars[[mu]], draws, sdata, ... + ) + } + } else { + out$bhaz <- prepare_predictions_bhaz(x$dpars$mu, draws, sdata, ...) + } + } + # response category names for categorical and ordinal models + out$cats <- get_cats(x) + # reference category for categorical models + out$refcat <- get_refcat(x, int = TRUE) + # only include those autocor draws on the top-level + # of the output which imply covariance matrices on natural residuals + out$ac <- prepare_predictions_ac(x$dpars$mu, draws, sdata, nat_cov = TRUE, ...) + out$data <- prepare_predictions_data(x, sdata = sdata, data = data, ...) + structure(out, class = "brmsprep") +} + +#' @export +prepare_predictions.btnl <- function(x, draws, sdata, ...) { + out <- list( + family = x$family, nlform = x$formula[[2]], + ndraws = nrow(draws), + nobs = sdata[[paste0("N", usc(x$resp))]], + used_nlpars = x$used_nlpars, + loop = x$loop + ) + class(out) <- "bprepnl" + p <- usc(combine_prefix(x)) + covars <- all.vars(x$covars) + dim <- c(out$ndraws, out$nobs) + for (i in seq_along(covars)) { + cvalues <- sdata[[paste0("C", p, "_", i)]] + out$C[[covars[i]]] <- data2draws(cvalues, dim = dim) + } + out +} + +#' @export +prepare_predictions.btl <- function(x, draws, sdata, ...) { + ndraws <- nrow(draws) + nobs <- sdata[[paste0("N", usc(x$resp))]] + out <- nlist(family = x$family, ndraws, nobs) + class(out) <- "bprepl" + out$fe <- prepare_predictions_fe(x, draws, sdata, ...) + out$sp <- prepare_predictions_sp(x, draws, sdata, ...) + out$cs <- prepare_predictions_cs(x, draws, sdata, ...) + out$sm <- prepare_predictions_sm(x, draws, sdata, ...) + out$gp <- prepare_predictions_gp(x, draws, sdata, ...) + out$re <- prepare_predictions_re(x, sdata, ...) + out$ac <- prepare_predictions_ac(x, draws, sdata, nat_cov = FALSE, ...) + out$offset <- prepare_predictions_offset(x, sdata, ...) + out +} + +# prepare predictions of ordinary population-level effects +prepare_predictions_fe <- function(bterms, draws, sdata, ...) { + out <- list() + if (is.null(bterms[["fe"]])) { + return(out) + } + p <- usc(combine_prefix(bterms)) + X <- sdata[[paste0("X", p)]] + fixef <- colnames(X) + if (length(fixef)) { + out$X <- X + b_pars <- paste0("b", p, "_", fixef) + out$b <- prepare_draws(draws, b_pars) + } + out +} + +# prepare predictions of special effects terms +prepare_predictions_sp <- function(bterms, draws, sdata, data, + meef = empty_meef(), new = FALSE, ...) { + out <- list() + spef <- tidy_spef(bterms, data) + if (!nrow(spef)) { + return(out) + } + p <- usc(combine_prefix(bterms)) + resp <- usc(bterms$resp) + # prepare calls evaluated in sp_predictor + out$calls <- vector("list", nrow(spef)) + for (i in seq_along(out$calls)) { + call <- spef$joint_call[[i]] + if (!is.null(spef$calls_mo[[i]])) { + new_mo <- paste0(".mo(simo_", spef$Imo[[i]], ", Xmo_", spef$Imo[[i]], ")") + call <- rename(call, spef$calls_mo[[i]], new_mo) + } + if (!is.null(spef$calls_me[[i]])) { + new_me <- paste0("Xme_", seq_along(meef$term)) + call <- rename(call, meef$term, new_me) + } + if (!is.null(spef$calls_mi[[i]])) { + is_na_idx <- is.na(spef$idx2_mi[[i]]) + idx_mi <- paste0("idxl", p, "_", spef$vars_mi[[i]], "_", spef$idx2_mi[[i]]) + idx_mi <- ifelse(is_na_idx, "", paste0("[, ", idx_mi, "]")) + new_mi <- paste0("Yl_", spef$vars_mi[[i]], idx_mi) + call <- rename(call, spef$calls_mi[[i]], new_mi) + } + if (spef$Ic[i] > 0) { + str_add(call) <- paste0(" * Csp_", spef$Ic[i]) + } + out$calls[[i]] <- parse(text = paste0(call)) + } + # extract general data and parameters for special effects + bsp_pars <- paste0("bsp", p, "_", spef$coef) + out$bsp <- prepare_draws(draws, bsp_pars) + colnames(out$bsp) <- spef$coef + # prepare predictions specific to monotonic effects + simo_coef <- get_simo_labels(spef) + Jmo <- sdata[[paste0("Jmo", p)]] + out$simo <- out$Xmo <- named_list(simo_coef) + for (i in seq_along(simo_coef)) { + J <- seq_len(Jmo[i]) + simo_par <- paste0("simo", p, "_", simo_coef[i], "[", J, "]") + out$simo[[i]] <- prepare_draws(draws, simo_par) + out$Xmo[[i]] <- sdata[[paste0("Xmo", p, "_", i)]] + } + # prepare predictions specific to noise-free effects + warn_me <- FALSE + if (nrow(meef)) { + save_mevars <- any(grepl("^Xme_", colnames(draws))) + warn_me <- warn_me || !new && !save_mevars + out$Xme <- named_list(meef$coef) + Xme_regex <- paste0("^Xme_", escape_all(meef$coef), "\\[") + Xn <- sdata[paste0("Xn_", seq_rows(meef))] + noise <- sdata[paste0("noise_", seq_rows(meef))] + groups <- unique(meef$grname) + for (i in seq_along(groups)) { + g <- groups[i] + K <- which(meef$grname %in% g) + if (nzchar(g)) { + Jme <- sdata[[paste0("Jme_", i)]] + } + if (!new && save_mevars) { + # extract original draws of latent variables + for (k in K) { + out$Xme[[k]] <- prepare_draws(draws, Xme_regex[k], regex = TRUE) + } + } else { + # sample new values of latent variables + if (nzchar(g)) { + # TODO: reuse existing levels in predictions? + # represent all indices between 1 and length(unique(Jme)) + Jme <- as.numeric(factor(Jme)) + me_dim <- c(nrow(out$bsp), max(Jme)) + } else { + me_dim <- c(nrow(out$bsp), sdata$N) + } + for (k in K) { + dXn <- data2draws(Xn[[k]], me_dim) + dnoise <- data2draws(noise[[k]], me_dim) + out$Xme[[k]] <- array(rnorm(prod(me_dim), dXn, dnoise), me_dim) + remove(dXn, dnoise) + } + } + if (nzchar(g)) { + for (k in K) { + out$Xme[[k]] <- out$Xme[[k]][, Jme, drop = FALSE] + } + } + } + } + # prepare predictions specific to missing value variables + dim <- c(nrow(out$bsp), sdata[[paste0("N", resp)]]) + vars_mi <- unique(unlist(spef$vars_mi)) + if (length(vars_mi)) { + # we know at this point that the model is multivariate + Yl_names <- paste0("Yl_", vars_mi) + out$Yl <- named_list(Yl_names) + for (i in seq_along(out$Yl)) { + vmi <- vars_mi[i] + dim_y <- c(nrow(out$bsp), sdata[[paste0("N_", vmi)]]) + Y <- data2draws(sdata[[paste0("Y_", vmi)]], dim_y) + sdy <- sdata[[paste0("noise_", vmi)]] + if (is.null(sdy)) { + # missings only + out$Yl[[i]] <- Y + if (!new) { + Ymi_regex <- paste0("^Ymi_", escape_all(vmi), "\\[") + Ymi <- prepare_draws(draws, Ymi_regex, regex = TRUE) + Jmi <- sdata[[paste0("Jmi_", vmi)]] + out$Yl[[i]][, Jmi] <- Ymi + } + } else { + # measurement-error in the response + save_mevars <- any(grepl("^Yl_", colnames(draws))) + if (save_mevars && !new) { + Ymi_regex <- paste0("^Yl_", escape_all(vmi), "\\[") + out$Yl[[i]] <- prepare_draws(draws, Ymi_regex, regex = TRUE) + } else { + warn_me <- warn_me || !new + sdy <- data2draws(sdy, dim) + out$Yl[[i]] <- rcontinuous( + n = prod(dim), dist = "norm", + mean = Y, sd = sdy, + lb = sdata[[paste0("lbmi_", vmi)]], + ub = sdata[[paste0("ubmi_", vmi)]] + ) + out$Yl[[i]] <- array(out$Yl[[i]], dim_y) + } + } + } + # extract index variables belonging to mi terms + uni_mi <- na.omit(attr(spef, "uni_mi")) + idxl_vars <- paste0("idxl", p, "_", uni_mi$var, "_", uni_mi$idx2) + out$idxl <- sdata[idxl_vars] + } + if (warn_me) { + warning2( + "Noise-free latent variables were not saved. ", + "You can control saving those variables via 'save_pars()'. ", + "Treating original data as if it was new data as a workaround." + ) + } + # prepare covariates + ncovars <- max(spef$Ic) + out$Csp <- vector("list", ncovars) + for (i in seq_len(ncovars)) { + out$Csp[[i]] <- sdata[[paste0("Csp", p, "_", i)]] + out$Csp[[i]] <- data2draws(out$Csp[[i]], dim = dim) + } + out +} + +# prepare predictions of category specific effects +prepare_predictions_cs <- function(bterms, draws, sdata, data, ...) { + out <- list() + if (!is_ordinal(bterms$family)) { + return(out) + } + resp <- usc(bterms$resp) + out$nthres <- sdata[[paste0("nthres", resp)]] + csef <- colnames(get_model_matrix(bterms$cs, data)) + if (length(csef)) { + p <- usc(combine_prefix(bterms)) + cs_pars <- paste0("^bcs", p, "_", escape_all(csef), "\\[") + out$bcs <- prepare_draws(draws, cs_pars, regex = TRUE) + out$Xcs <- sdata[[paste0("Xcs", p)]] + } + out +} + +# prepare predictions of smooth terms +prepare_predictions_sm <- function(bterms, draws, sdata, data, ...) { + out <- list() + smef <- tidy_smef(bterms, data) + if (!NROW(smef)) { + return(out) + } + p <- usc(combine_prefix(bterms)) + Xs_names <- attr(smef, "Xs_names") + if (length(Xs_names)) { + out$fe$Xs <- sdata[[paste0("Xs", p)]] + # allow for "b_" prefix for compatibility with version <= 2.5.0 + bspars <- paste0("^bs?", p, "_", escape_all(Xs_names), "$") + out$fe$bs <- prepare_draws(draws, bspars, regex = TRUE) + } + out$re <- named_list(smef$label) + for (i in seq_rows(smef)) { + sm <- list() + for (j in seq_len(smef$nbases[i])) { + sm$Zs[[j]] <- sdata[[paste0("Zs", p, "_", i, "_", j)]] + spars <- paste0("^s", p, "_", smef$label[i], "_", j, "\\[") + sm$s[[j]] <- prepare_draws(draws, spars, regex = TRUE) + } + out$re[[i]] <- sm + } + out +} + +# prepare predictions for Gaussian processes +# @param new is new data used? +# @param nug small numeric value to avoid numerical problems in GPs +prepare_predictions_gp <- function(bterms, draws, sdata, data, + new = FALSE, nug = NULL, ...) { + gpef <- tidy_gpef(bterms, data) + if (!nrow(gpef)) { + return(list()) + } + p <- usc(combine_prefix(bterms)) + if (is.null(nug)) { + # nug for old data must be the same as in the Stan code as even tiny + # differences (e.g., 1e-12 vs. 1e-11) will matter for larger lscales + nug <- ifelse(new, 1e-8, 1e-12) + } + out <- named_list(gpef$label) + for (i in seq_along(out)) { + cons <- gpef$cons[[i]] + if (length(cons)) { + gp <- named_list(cons) + for (j in seq_along(cons)) { + gp[[j]] <- .prepare_predictions_gp( + gpef, draws = draws, sdata = sdata, + nug = nug, new = new, byj = j, p = p, i = i + ) + } + attr(gp, "byfac") <- TRUE + } else { + gp <- .prepare_predictions_gp( + gpef, draws = draws, sdata = sdata, + nug = nug, new = new, p = p, i = i + ) + } + out[[i]] <- gp + } + out +} + +# prepare predictions for Gaussian processes +# @param gpef output of tidy_gpef +# @param p prefix created by combine_prefix() +# @param i indiex of the Gaussian process +# @param byj index for the contrast of a categorical 'by' variable +# @return a list to be evaluated by .predictor_gp() +.prepare_predictions_gp <- function(gpef, draws, sdata, nug, + new, p, i, byj = NULL) { + sfx1 <- escape_all(gpef$sfx1[[i]]) + sfx2 <- escape_all(gpef$sfx2[[i]]) + if (is.null(byj)) { + lvl <- "" + } else { + lvl <- gpef$bylevels[[i]][byj] + sfx1 <- sfx1[byj] + sfx2 <- sfx2[byj, ] + } + j <- usc(byj) + pi <- paste0(p, "_", i) + gp <- list() + sdgp <- paste0("^sdgp", p, "_", sfx1, "$") + gp$sdgp <- as.vector(prepare_draws(draws, sdgp, regex = TRUE)) + lscale <- paste0("^lscale", p, "_", sfx2, "$") + gp$lscale <- prepare_draws(draws, lscale, regex = TRUE) + zgp_regex <- paste0("^zgp", p, "_", sfx1, "\\[") + gp$zgp <- prepare_draws(draws, zgp_regex, regex = TRUE) + Xgp_name <- paste0("Xgp", pi, j) + Igp_name <- paste0("Igp", pi, j) + Jgp_name <- paste0("Jgp", pi, j) + if (new && isNA(gpef$k[i])) { + # in exact GPs old covariate values are required for predictions + gp$x <- sdata[[paste0(Xgp_name, "_old")]] + # nug for old data must be the same as in the Stan code as even tiny + # differences (e.g., 1e-12 vs. 1e-11) will matter for larger lscales + gp$nug <- 1e-12 + # computing GPs for new data requires the old GP terms + gp$yL <- .predictor_gp(gp) + gp$x_new <- sdata[[Xgp_name]] + gp$Igp <- sdata[[Igp_name]] + } else { + gp$x <- sdata[[Xgp_name]] + gp$Igp <- sdata[[Igp_name]] + if (!isNA(gpef$k[i])) { + gp$slambda <- sdata[[paste0("slambda", pi, j)]] + } + } + gp$Jgp <- sdata[[Jgp_name]] + # possible factor from 'by' variable + gp$Cgp <- sdata[[paste0("Cgp", pi, j)]] + gp$nug <- nug + gp +} + +# prepare predictions for all group level effects +# needs to be separate from 'prepare_predictions_re' to take correlations +# across responses and distributional parameters into account (#779) +# @param ranef output of 'tidy_ranef' based on the new formula and old data +# @param old_ranef same as 'ranef' but based on the original formula +# @return a named list with one element per group containing posterior draws +# of levels used in the data as well as additional meta-data +prepare_predictions_ranef <- function(ranef, draws, sdata, old_ranef, resp = NULL, + sample_new_levels = "uncertainty", ...) { + if (!nrow(ranef)) { + return(list()) + } + # ensures subsetting 'ranef' by 'resp' works correctly + resp <- resp %||% "" + groups <- unique(ranef$group) + out <- named_list(groups, list()) + for (g in groups) { + # prepare general variables related to group g + ranef_g <- subset2(ranef, group = g) + old_ranef_g <- subset2(old_ranef, group = g) + used_levels <- attr(sdata, "levels")[[g]] + old_levels <- attr(old_ranef, "levels")[[g]] + nlevels <- length(old_levels) + nranef <- nrow(ranef_g) + # prepare draws of group-level effects + rpars <- paste0("^r_", g, "(__.+)?\\[") + rdraws <- prepare_draws(draws, rpars, regex = TRUE) + if (!length(rdraws)) { + stop2( + "Group-level coefficients of group '", g, "' not found. ", + "You can control saving those coefficients via 'save_pars()'." + ) + } + # only prepare predictions of effects specified in the new formula + cols_match <- c("coef", "resp", "dpar", "nlpar") + used_rpars <- which(find_rows(old_ranef_g, ls = ranef_g[cols_match])) + used_rpars <- outer(seq_len(nlevels), (used_rpars - 1) * nlevels, "+") + used_rpars <- as.vector(used_rpars) + rdraws <- rdraws[, used_rpars, drop = FALSE] + rdraws <- column_to_row_major_order(rdraws, nranef) + # prepare data required for indexing parameters + gtype <- ranef_g$gtype[1] + resp_g <- intersect(ranef_g$resp, resp)[1] + # any valid ID works here as J and W are independent of the ID + id <- subset2(ranef_g, resp = resp)$id[1] + idresp <- paste0(id, usc(resp_g)) + if (gtype == "mm") { + ngf <- length(ranef_g$gcall[[1]]$groups) + gf <- sdata[paste0("J_", idresp, "_", seq_len(ngf))] + weights <- sdata[paste0("W_", idresp, "_", seq_len(ngf))] + } else { + gf <- sdata[paste0("J_", idresp)] + weights <- list(rep(1, length(gf[[1]]))) + } + # generate draws for new levels + args_new_rdraws <- nlist( + ranef = ranef_g, gf, used_levels, old_levels, + rdraws = rdraws, draws, sample_new_levels + ) + new_rdraws <- do_call(get_new_rdraws, args_new_rdraws) + max_level <- attr(new_rdraws, "max_level") + gf <- attr(new_rdraws, "gf") + rdraws <- cbind(rdraws, new_rdraws) + # keep only those levels actually used in the current data + levels <- unique(unlist(gf)) + rdraws <- subset_levels(rdraws, levels, nranef) + # store all information required in 'prepare_predictions_re' + out[[g]]$ranef <- ranef_g + out[[g]]$rdraws <- rdraws + out[[g]]$levels <- levels + out[[g]]$nranef <- nranef + out[[g]]$max_level <- max_level + out[[g]]$gf <- gf + out[[g]]$weights <- weights + } + out +} + +# prepare predictions of group-level effects +# @param prep_ranef a named list with one element per group containing +# posterior draws of levels as well as additional meta-data +prepare_predictions_re <- function(bterms, sdata, prep_ranef = list(), + sample_new_levels = "uncertainty", ...) { + out <- list() + if (!length(prep_ranef)) { + return(out) + } + px <- check_prefix(bterms) + p <- usc(combine_prefix(px)) + ranef_px <- lapply(prep_ranef, "[[", "ranef") + ranef_px <- do_call(rbind, ranef_px) + ranef_px <- subset2(ranef_px, ls = px) + if (!NROW(ranef_px)) { + return(out) + } + groups <- unique(ranef_px$group) + # assigning S4 objects requires initialisation of list elements + out[c("Z", "Zsp", "Zcs")] <- list(named_list(groups)) + for (g in groups) { + # extract variables specific to group 'g' + ranef_g <- prep_ranef[[g]]$ranef + ranef_g_px <- subset2(ranef_g, ls = px) + rdraws <- prep_ranef[[g]]$rdraws + nranef <- prep_ranef[[g]]$nranef + levels <- prep_ranef[[g]]$levels + max_level <- prep_ranef[[g]]$max_level + gf <- prep_ranef[[g]]$gf + weights <- prep_ranef[[g]]$weights + # TODO: define 'select' according to parameter names not by position + # store draws and corresponding data in the output + # special group-level terms (mo, me, mi) + ranef_g_px_sp <- subset2(ranef_g_px, type = "sp") + if (nrow(ranef_g_px_sp)) { + Z <- matrix(1, length(gf[[1]])) + out[["Zsp"]][[g]] <- prepare_Z(Z, gf, max_level, weights) + for (co in ranef_g_px_sp$coef) { + # select from all varying effects of that group + select <- find_rows(ranef_g, ls = px) & + ranef_g$coef == co & ranef_g$type == "sp" + select <- which(select) + select <- select + nranef * (seq_along(levels) - 1) + out[["rsp"]][[co]][[g]] <- rdraws[, select, drop = FALSE] + } + } + # category specific group-level terms + ranef_g_px_cs <- subset2(ranef_g_px, type = "cs") + if (nrow(ranef_g_px_cs)) { + # all categories share the same Z matrix + ranef_g_px_cs_1 <- ranef_g_px_cs[grepl("\\[1\\]$", ranef_g_px_cs$coef), ] + Znames <- paste0("Z_", ranef_g_px_cs_1$id, p, "_", ranef_g_px_cs_1$cn) + Z <- do_call(cbind, sdata[Znames]) + out[["Zcs"]][[g]] <- prepare_Z(Z, gf, max_level, weights) + for (i in seq_len(sdata$nthres)) { + index <- paste0("\\[", i, "\\]$") + # select from all varying effects of that group + select <- find_rows(ranef_g, ls = px) & + grepl(index, ranef_g$coef) & ranef_g$type == "cs" + select <- which(select) + select <- as.vector(outer(select, nranef * (seq_along(levels) - 1), "+")) + out[["rcs"]][[g]][[i]] <- rdraws[, select, drop = FALSE] + } + } + # basic group-level terms + ranef_g_px_basic <- subset2(ranef_g_px, type = c("", "mmc")) + if (nrow(ranef_g_px_basic)) { + Znames <- paste0("Z_", ranef_g_px_basic$id, p, "_", ranef_g_px_basic$cn) + if (ranef_g_px_basic$gtype[1] == "mm") { + ng <- length(ranef_g_px_basic$gcall[[1]]$groups) + Z <- vector("list", ng) + for (k in seq_len(ng)) { + Z[[k]] <- do_call(cbind, sdata[paste0(Znames, "_", k)]) + } + } else { + Z <- do_call(cbind, sdata[Znames]) + } + out[["Z"]][[g]] <- prepare_Z(Z, gf, max_level, weights) + # select from all varying effects of that group + select <- find_rows(ranef_g, ls = px) & ranef_g$type %in% c("", "mmc") + select <- which(select) + select <- as.vector(outer(select, nranef * (seq_along(levels) - 1), "+")) + out[["r"]][[g]] <- rdraws[, select, drop = FALSE] + } + } + out +} + +# prepare predictions of autocorrelation parameters +# @param nat_cov extract terms for covariance matrices of natural residuals? +prepare_predictions_ac <- function(bterms, draws, sdata, oos = NULL, + nat_cov = FALSE, new = FALSE, ...) { + out <- list() + nat_cov <- as_one_logical(nat_cov) + acef <- tidy_acef(bterms) + acef <- subset2(acef, nat_cov = nat_cov) + if (!NROW(acef)) { + return(out) + } + out$acef <- acef + p <- usc(combine_prefix(bterms)) + out$N_tg <- sdata[[paste0("N_tg", p)]] + if (has_ac_class(acef, "arma")) { + acef_arma <- subset2(acef, class = "arma") + out$Y <- sdata[[paste0("Y", p)]] + if (!is.null(oos)) { + if (any(oos > length(out$Y))) { + stop2("'oos' should not contain integers larger than N.") + } + # .predictor_arma has special behavior for NA responses + out$Y[oos] <- NA + } + out$J_lag <- sdata[[paste0("J_lag", p)]] + if (acef_arma$p > 0) { + ar_regex <- paste0("^ar", p, "\\[") + out$ar <- prepare_draws(draws, ar_regex, regex = TRUE) + } + if (acef_arma$q > 0) { + ma_regex <- paste0("^ma", p, "\\[") + out$ma <- prepare_draws(draws, ma_regex, regex = TRUE) + } + } + if (has_ac_class(acef, "cosy")) { + cosy_regex <- paste0("^cosy", p, "$") + out$cosy <- prepare_draws(draws, cosy_regex, regex = TRUE) + } + if (use_ac_cov_time(acef)) { + # prepare predictions for the covariance structures of time-series models + out$begin_tg <- sdata[[paste0("begin_tg", p)]] + out$end_tg <- sdata[[paste0("end_tg", p)]] + } + if (has_ac_latent_residuals(bterms)) { + err_regex <- paste0("^err", p, "\\[") + has_err <- any(grepl(err_regex, colnames(draws))) + if (has_err && !new) { + out$err <- prepare_draws(draws, err_regex, regex = TRUE) + } else { + if (!use_ac_cov_time(acef)) { + stop2("Cannot predict new latent residuals ", + "when using cov = FALSE in autocor terms.") + } + # need to sample correlated residuals + out$err <- matrix(nrow = nrow(draws), ncol = length(out$Y)) + sderr_regex <- paste0("^sderr", p, "$") + out$sderr <- prepare_draws(draws, sderr_regex, regex = TRUE) + for (i in seq_len(out$N_tg)) { + obs <- with(out, begin_tg[i]:end_tg[i]) + zeros <- rep(0, length(obs)) + cov <- get_cov_matrix_ac(list(ac = out), obs, latent = TRUE) + .err <- function(s) rmulti_normal(1, zeros, Sigma = cov[s, , ]) + out$err[, obs] <- rblapply(seq_rows(draws), .err) + } + } + } + if (has_ac_class(acef, "sar")) { + lagsar_regex <- paste0("^lagsar", p, "$") + errorsar_regex <- paste0("^errorsar", p, "$") + out$lagsar <- prepare_draws(draws, lagsar_regex, regex = TRUE) + out$errorsar <- prepare_draws(draws, errorsar_regex, regex = TRUE) + out$Msar <- sdata[[paste0("Msar", p)]] + } + if (has_ac_class(acef, "car")) { + acef_car <- subset2(acef, class = "car") + if (new && acef_car$gr == "NA") { + stop2("Without a grouping factor, CAR models cannot handle newdata.") + } + gcar <- sdata[[paste0("Jloc", p)]] + Zcar <- matrix(rep(1, length(gcar))) + out$Zcar <- prepare_Z(Zcar, list(gcar)) + rcar_regex <- paste0("^rcar", p, "\\[") + rcar <- prepare_draws(draws, rcar_regex, regex = TRUE) + rcar <- rcar[, unique(gcar), drop = FALSE] + out$rcar <- rcar + } + if (has_ac_class(acef, "fcor")) { + out$Mfcor <- sdata[[paste0("Mfcor", p)]] + } + out +} + +prepare_predictions_offset <- function(bterms, sdata, ...) { + p <- usc(combine_prefix(bterms)) + sdata[[paste0("offsets", p)]] +} + +# prepare predictions of ordinal thresholds +prepare_predictions_thres <- function(bterms, draws, sdata, ...) { + out <- list() + if (!is_ordinal(bterms$family)) { + return(out) + } + resp <- usc(bterms$resp) + out$nthres <- sdata[[paste0("nthres", resp)]] + out$Jthres <- sdata[[paste0("Jthres", resp)]] + p <- usc(combine_prefix(bterms)) + thres_regex <- paste0("^b", p, "_Intercept\\[") + out$thres <- prepare_draws(draws, thres_regex, regex = TRUE) + out +} + +# prepare predictions of baseline functions for the cox model +prepare_predictions_bhaz <- function(bterms, draws, sdata, ...) { + if (!is_cox(bterms$family)) { + return(NULL) + } + out <- list() + p <- usc(combine_prefix(bterms)) + sbhaz_regex <- paste0("^sbhaz", p) + sbhaz <- prepare_draws(draws, sbhaz_regex, regex = TRUE) + Zbhaz <- sdata[[paste0("Zbhaz", p)]] + out$bhaz <- tcrossprod(sbhaz, Zbhaz) + Zcbhaz <- sdata[[paste0("Zcbhaz", p)]] + out$cbhaz <- tcrossprod(sbhaz, Zcbhaz) + out +} + +# extract data mainly related to the response variable +prepare_predictions_data <- function(bterms, sdata, data, stanvars = NULL, ...) { + resp <- usc(combine_prefix(bterms)) + vars <- c( + "Y", "trials", "ncat", "nthres", "se", "weights", + "denom", "dec", "cens", "rcens", "lb", "ub" + ) + vars <- paste0(vars, resp) + vars <- intersect(vars, names(sdata)) + # variables of variable length need to be handled via regular expression + escaped_resp <- escape_all(resp) + vl_vars <- c("vreal", "vint") + vl_vars <- regex_or(vl_vars) + vl_vars <- paste0("^", vl_vars, "[[:digit:]]+", escaped_resp, "$") + vl_vars <- str_subset(names(sdata), vl_vars) + vars <- union(vars, vl_vars) + out <- sdata[vars] + # remove resp suffix from names to simplify post-processing + names(out) <- sub(paste0(escaped_resp, "$"), "", names(out)) + if (length(stanvars)) { + stopifnot(is.stanvars(stanvars)) + out[names(stanvars)] <- sdata[names(stanvars)] + } + out +} + +# choose number of observations to be used in post-processing methods +choose_N <- function(prep) { + stopifnot(is.brmsprep(prep) || is.mvbrmsprep(prep)) + if (!is.null(prep$ac$N_tg)) prep$ac$N_tg else prep$nobs +} + +# create pseudo brmsprep objects for components of mixture models +# @param comp the mixture component number +# @param draw_ids see predict_mixture +pseudo_prep_for_mixture <- function(prep, comp, draw_ids = NULL) { + stopifnot(is.brmsprep(prep), is.mixfamily(prep$family)) + if (!is.null(draw_ids)) { + ndraws <- length(draw_ids) + } else { + ndraws <- prep$ndraws + } + out <- list( + family = prep$family$mix[[comp]], ndraws = ndraws, + nobs = prep$nobs, data = prep$data + ) + out$family$fun <- out$family$family + for (dp in valid_dpars(out$family)) { + out$dpars[[dp]] <- prep$dpars[[paste0(dp, comp)]] + if (length(draw_ids) && length(out$dpars[[dp]]) > 1L) { + out$dpars[[dp]] <- p(out$dpars[[dp]], draw_ids, row = TRUE) + } + } + if (is_ordinal(out$family)) { + out$thres <- prep$thres[[paste0("mu", comp)]] + } + if (is_cox(out$family)) { + out$bhaz <- prep$bhaz[[paste0("mu", comp)]] + } + # weighting should happen after computing the mixture + out$data$weights <- NULL + structure(out, class = "brmsprep") +} + +# take relevant cols of a matrix of group-level terms +# if only a subset of levels is provided (for newdata) +# @param x a matrix typically draws of r or Z design matrices +# draws need to be stored in row major order +# @param levels grouping factor levels to keep +# @param nranef number of group-level effects +subset_levels <- function(x, levels, nranef) { + take_levels <- ulapply(levels, + function(l) ((l - 1) * nranef + 1):(l * nranef) + ) + x[, take_levels, drop = FALSE] +} + +# transform x from column to row major order +# rows represent levels and columns represent effects +# @param x a matrix of draws of group-level parameters +# @param nranef number of group-level effects +column_to_row_major_order <- function(x, nranef) { + nlevels <- ncol(x) / nranef + sort_levels <- ulapply(seq_len(nlevels), + function(l) seq(l, ncol(x), by = nlevels) + ) + x[, sort_levels, drop = FALSE] +} + +# prepare group-level design matrices for use in 'predictor' +# @param Z (list of) matrices to be prepared +# @param gf (list of) vectors containing grouping factor values +# @param weights optional (list of) weights of the same length as gf +# @param max_level maximal level of 'gf' +# @return a sparse matrix representation of Z +prepare_Z <- function(Z, gf, max_level = NULL, weights = NULL) { + if (!is.list(Z)) { + Z <- list(Z) + } + if (!is.list(gf)) { + gf <- list(gf) + } + if (is.null(weights)) { + weights <- rep(1, length(gf[[1]])) + } + if (!is.list(weights)) { + weights <- list(weights) + } + if (is.null(max_level)) { + max_level <- max(unlist(gf)) + } + levels <- unique(unlist(gf)) + nranef <- ncol(Z[[1]]) + Z <- mapply( + expand_matrix, A = Z, x = gf, weights = weights, + MoreArgs = nlist(max_level) + ) + Z <- Reduce("+", Z) + subset_levels(Z, levels, nranef) +} + +# expand a matrix into a sparse matrix of higher dimension +# @param A matrix to be expanded +# @param x levels to expand the matrix +# @param max_level maximal number of levels that x can take on +# @param weights weights to apply to rows of A before expanding +# @param a sparse matrix of dimension nrow(A) x (ncol(A) * max_level) +expand_matrix <- function(A, x, max_level = max(x), weights = 1) { + stopifnot(is.matrix(A)) + stopifnot(length(x) == nrow(A)) + stopifnot(all(is_wholenumber(x) & x > 0)) + stopifnot(length(weights) %in% c(1, nrow(A), prod(dim(A)))) + A <- A * as.vector(weights) + K <- ncol(A) + i <- rep(seq_along(x), each = K) + make_j <- function(n, K, x) K * (x[n] - 1) + 1:K + j <- ulapply(seq_along(x), make_j, K = K, x = x) + Matrix::sparseMatrix( + i = i, j = j, x = as.vector(t(A)), + dims = c(nrow(A), ncol(A) * max_level) + ) +} + +# generate draws for new group levels +# @param ranef 'ranef_frame' object of only a single grouping variable +# @param gf list of vectors of level indices in the current data +# @param rdraws matrix of group-level draws in row major order +# @param used_levels names of levels used in the current data +# @param old_levels names of levels used in the original data +# @param sample_new_levels specifies the way in which new draws are generated +# @param draws optional matrix of draws from all model parameters +# @return a matrix of draws for new group levels +get_new_rdraws <- function(ranef, gf, rdraws, used_levels, old_levels, + sample_new_levels, draws = NULL) { + snl_options <- c("uncertainty", "gaussian", "old_levels") + sample_new_levels <- match.arg(sample_new_levels, snl_options) + g <- unique(ranef$group) + stopifnot(length(g) == 1L) + stopifnot(is.list(gf)) + used_by_per_level <- attr(used_levels, "by") + old_by_per_level <- attr(old_levels, "by") + new_levels <- setdiff(used_levels, old_levels) + nranef <- nrow(ranef) + nlevels <- length(old_levels) + max_level <- nlevels + + out <- vector("list", length(gf)) + for (i in seq_along(gf)) { + has_new_levels <- any(gf[[i]] > nlevels) + if (has_new_levels) { + new_indices <- sort(setdiff(gf[[i]], seq_len(nlevels))) + out[[i]] <- matrix(NA, nrow(rdraws), nranef * length(new_indices)) + if (sample_new_levels == "uncertainty") { + for (j in seq_along(new_indices)) { + # selected levels need to be the same for all varying effects + # to correctly take their correlations into account + if (length(old_by_per_level)) { + # select from all levels matching the 'by' variable + new_by <- used_by_per_level[used_levels == new_levels[j]] + possible_levels <- old_levels[old_by_per_level == new_by] + possible_levels <- which(old_levels %in% possible_levels) + sel_levels <- sample(possible_levels, NROW(rdraws), TRUE) + } else { + # select from all levels + sel_levels <- sample(seq_len(nlevels), NROW(rdraws), TRUE) + } + for (k in seq_len(nranef)) { + for (s in seq_rows(rdraws)) { + sel <- (sel_levels[s] - 1) * nranef + k + out[[i]][s, (j - 1) * nranef + k] <- rdraws[s, sel] + } + } + } + } else if (sample_new_levels == "old_levels") { + for (j in seq_along(new_indices)) { + # choose an existing person to take the parameters from + if (length(old_by_per_level)) { + # select from all levels matching the 'by' variable + new_by <- used_by_per_level[used_levels == new_levels[j]] + possible_levels <- old_levels[old_by_per_level == new_by] + possible_levels <- which(old_levels %in% possible_levels) + sel_level <- sample(possible_levels, 1) + } else { + # select from all levels + sel_level <- sample(seq_len(nlevels), 1) + } + for (k in seq_len(nranef)) { + sel <- (sel_level - 1) * nranef + k + out[[i]][, (j - 1) * nranef + k] <- rdraws[, sel] + } + } + } else if (sample_new_levels == "gaussian") { + if (any(!ranef$dist %in% "gaussian")) { + stop2("Option sample_new_levels = 'gaussian' is not ", + "available for non-gaussian group-level effects.") + } + for (j in seq_along(new_indices)) { + # extract hyperparameters used to compute the covariance matrix + if (length(old_by_per_level)) { + new_by <- used_by_per_level[used_levels == new_levels[j]] + rnames <- as.vector(get_rnames(ranef, bylevels = new_by)) + } else { + rnames <- get_rnames(ranef) + } + sd_pars <- paste0("sd_", g, "__", rnames) + sd_draws <- prepare_draws(draws, sd_pars) + cor_type <- paste0("cor_", g) + cor_pars <- get_cornames(rnames, cor_type, brackets = FALSE) + cor_draws <- matrix(0, nrow(sd_draws), length(cor_pars)) + for (k in seq_along(cor_pars)) { + if (cor_pars[k] %in% colnames(draws)) { + cor_draws[, k] <- prepare_draws(draws, cor_pars[k]) + } + } + cov_matrix <- get_cov_matrix(sd_draws, cor_draws) + # sample new levels from the normal distribution + # implied by the covariance matrix + indices <- ((j - 1) * nranef + 1):(j * nranef) + out[[i]][, indices] <- t(apply( + cov_matrix, 1, rmulti_normal, + n = 1, mu = rep(0, length(sd_pars)) + )) + } + } + max_level <- max_level + length(new_indices) + } else { + out[[i]] <- matrix(nrow = nrow(rdraws), ncol = 0) + } + } + out <- do_call(cbind, out) + structure(out, gf = gf, max_level = max_level) +} + +# prepare draws of selected variables +prepare_draws <- function(x, variable, ...) { + x <- subset_draws(x, variable = variable, ...) + # brms still assumes standard dropping behavior in many places + # and so keeping the posterior format is dangerous at the moment + unclass_draws(x) +} + +# compute point estimates of posterior draws +# currently used primarily for 'loo_subsample' +# @param draws matrix of posterior draws +# @param point_estimate optional name of the point estimate to be computed +# @return a draws_matrix with one row +point_draws <- function(draws, point_estimate = NULL) { + if (is.null(point_estimate)) { + return(draws) + } + point_estimate <- match.arg(point_estimate, c("mean", "median")) + variables <- colnames(draws) + if (point_estimate == "mean") { + draws <- matrixStats::colMeans2(draws) + } else if (point_estimate == "median") { + draws <- matrixStats::colMedians(draws) + } + draws <- t(draws) + colnames(draws) <- variables + as_draws_matrix(draws) +} + +is.brmsprep <- function(x) { + inherits(x, "brmsprep") +} + +is.mvbrmsprep <- function(x) { + inherits(x, "mvbrmsprep") +} + +is.bprepl <- function(x) { + inherits(x, "bprepl") +} + +is.bprepnl <- function(x) { + inherits(x, "bprepnl") +} + +#' Prepare Predictions +#' +#' This method helps in preparing \pkg{brms} models for certin post-processing +#' tasks most notably various forms of predictions. Unless you are a package +#' developer, you will rarely need to call \code{prepare_predictions} directly. +#' +#' @name prepare_predictions +#' @aliases prepare_predictions.brmsfit extract_draws +#' +#' @param x An \R object typically of class \code{'brmsfit'}. +#' @param newdata An optional data.frame for which to evaluate predictions. If +#' \code{NULL} (default), the original data of the model is used. +#' \code{NA} values within factors are interpreted as if all dummy +#' variables of this factor are zero. This allows, for instance, to make +#' predictions of the grand mean when using sum coding. +#' @param re_formula formula containing group-level effects to be considered in +#' the prediction. If \code{NULL} (default), include all group-level effects; +#' if \code{NA}, include no group-level effects. +#' @param allow_new_levels A flag indicating if new levels of group-level +#' effects are allowed (defaults to \code{FALSE}). Only relevant if +#' \code{newdata} is provided. +#'@param sample_new_levels Indicates how to sample new levels for grouping +#' factors specified in \code{re_formula}. This argument is only relevant if +#' \code{newdata} is provided and \code{allow_new_levels} is set to +#' \code{TRUE}. If \code{"uncertainty"} (default), each posterior sample for a +#' new level is drawn from the posterior draws of a randomly chosen existing +#' level. Each posterior sample for a new level may be drawn from a different +#' existing level such that the resulting set of new posterior draws +#' represents the variation across existing levels. If \code{"gaussian"}, +#' sample new levels from the (multivariate) normal distribution implied by the +#' group-level standard deviations and correlations. This options may be useful +#' for conducting Bayesian power analysis or predicting new levels in +#' situations where relatively few levels where observed in the old_data. If +#' \code{"old_levels"}, directly sample new levels from the existing levels, +#' where a new level is assigned all of the posterior draws of the same +#' (randomly chosen) existing level. +#' @param newdata2 A named \code{list} of objects containing new data, which +#' cannot be passed via argument \code{newdata}. Required for some objects +#' used in autocorrelation structures, or \code{\link{stanvars}}. +#' @param new_objects Deprecated alias of \code{newdata2}. +#' @param incl_autocor A flag indicating if correlation structures originally +#' specified via \code{autocor} should be included in the predictions. +#' Defaults to \code{TRUE}. +#' @param offset Logical; Indicates if offsets should be included in the +#' predictions. Defaults to \code{TRUE}. +#' @param oos Optional indices of observations for which to compute +#' out-of-sample rather than in-sample predictions. Only required in models +#' that make use of response values to make predictions, that is, currently +#' only ARMA models. +#' @param smooths_only Logical; If \code{TRUE} only predictions related to the +#' @param resp Optional names of response variables. If specified, predictions +#' are performed only for the specified response variables. +#' @param ndraws Positive integer indicating how many posterior draws should +#' be used. If \code{NULL} (the default) all draws are used. Ignored if +#' \code{draw_ids} is not \code{NULL}. +#' @param draw_ids An integer vector specifying the posterior draws to be used. +#' If \code{NULL} (the default), all draws are used. +#' @param nsamples Deprecated alias of \code{ndraws}. +#' @param subset Deprecated alias of \code{draw_ids}. +#' @param nug Small positive number for Gaussian process terms only. For +#' numerical reasons, the covariance matrix of a Gaussian process might not be +#' positive definite. Adding a very small number to the matrix's diagonal +#' often solves this problem. If \code{NULL} (the default), \code{nug} is +#' chosen internally. +#' @param point_estimate Shall the returned object contain only point estimates +#' of the parameters instead of their posterior draws? Defaults to +#' \code{NULL} in which case no point estimate is computed. Alternatively, may +#' be set to \code{"mean"} or \code{"median"}. This argument is primarily +#' implemented to ensure compatibility with the \code{\link{loo_subsample}} +#' method. +#' @param ... Further arguments passed to \code{\link{validate_newdata}}. +#' +#' @return An object of class \code{'brmsprep'} or \code{'mvbrmsprep'}, +#' depending on whether a univariate or multivariate model is passed. +#' +#' @export +prepare_predictions <- function(x, ...) { + UseMethod("prepare_predictions") +} + +#' @export +prepare_predictions.default <- function(x, ...) { + NULL +} + +# the name 'extract_draws' is deprecated as of brms 2.12.6 +# remove it eventually in brms 3.0 +#' @export +extract_draws <- function(x, ...) { + warning2("Method 'extract_draws' is deprecated. ", + "Please use 'prepare_predictions' instead.") + UseMethod("prepare_predictions") +} diff -Nru r-cran-brms-2.16.3/R/prior_draws.R r-cran-brms-2.17.0/R/prior_draws.R --- r-cran-brms-2.16.3/R/prior_draws.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/prior_draws.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,152 +1,152 @@ -#' Extract Prior Draws -#' -#' Extract prior draws of specified parameters -#' -#' @aliases prior_draws.brmsfit prior_samples -#' -#' @param x An \code{R} object typically of class \code{brmsfit}. -#' @inheritParams as.data.frame.brmsfit -#' @param ... Arguments passed to individual methods (if applicable). -#' -#' @details To make use of this function, the model must contain draws of -#' prior distributions. This can be ensured by setting \code{sample_prior = -#' TRUE} in function \code{brm}. Priors of certain parameters cannot be saved -#' for technical reasons. For instance, this is the case for the -#' population-level intercept, which is only computed after fitting the model -#' by default. If you want to treat the intercept as part of all the other -#' regression coefficients, so that sampling from its prior becomes possible, -#' use \code{... ~ 0 + Intercept + ...} in the formulas. -#' -#' @return A \code{data.frame} containing the prior draws. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(rating ~ treat + period + carry + (1|subject), -#' data = inhaler, family = "cumulative", -#' prior = set_prior("normal(0,2)", class = "b"), -#' sample_prior = TRUE) -#' -#' # extract all prior draws -#' draws1 <- prior_draws(fit) -#' head(draws1) -#' -#' # extract prior draws for the coefficient of 'treat' -#' draws2 <- prior_draws(fit, "b_treat") -#' head(draws2) -#' } -#' -#' @export -prior_draws.brmsfit <- function(x, variable = NULL, pars = NULL, ...) { - variable <- use_alias(variable, pars) - if (!is.null(variable)) { - variable <- as.character(variable) - } - all_names <- variables(x) - prior_names <- unique(all_names[grepl("^prior_", all_names)]) - if (!length(prior_names)) { - return(data.frame(NULL)) - } - draws <- as.data.frame(x, variable = prior_names) - names(draws) <- sub("^prior_", "", prior_names) - if (is.null(variable)) { - return(draws) - } - # get prior draws for a single variable - .prior_draws <- function(variable) { - matches <- paste0("^", escape_all(names(draws))) - matches <- lapply(matches, regexpr, text = variable) - matches <- ulapply(matches, attr, which = "match.length") - if (max(matches) == -1 || ignore_prior(x, variable)) { - out <- NULL - } else { - take <- match(max(matches), matches) - # order draws randomly to avoid artificial dependencies - # between parameters using the same prior draws - draws <- list(draws[sample(ndraws(x)), take]) - out <- structure(draws, names = variable) - } - return(out) - } - draws <- rmNULL(lapply(variable, .prior_draws)) - draws <- data.frame(draws, check.names = FALSE) - draws -} - -#' @rdname prior_draws.brmsfit -#' @export -prior_draws <- function(x, ...) { - UseMethod("prior_draws") -} - -#' @export -prior_draws.default <- function(x, variable = NULL, pars = NULL, - regex = FALSE, fixed = FALSE, ...) { - call <- match.call() - if ("pars" %in% names(call)) { - variable <- use_alias(variable, pars) - regex <- !as_one_logical(fixed) - } - if (is.null(variable)) { - variable <- "^prior_" - regex <- TRUE - } else { - variable <- as.character(variable) - regex <- as_one_logical(regex) - if (regex) { - hat <- substr(variable, 1, 1) == "^" - variable <- ifelse(hat, substr(variable, 2, nchar(variable)), variable) - variable <- paste0("^prior_", variable) - } else { - variable <- paste0("prior_", variable) - } - } - x <- as_draws_df(as.data.frame(x)) - if (!regex) { - # missing variables will leads to an error in posterior - variable <- intersect(variable, variables(x)) - if (!length(variable)) { - return(data.frame(NULL)) - } - } - x <- subset_draws(x, variable = variable, regex = regex, ...) - unclass_draws(x) -} - -#' @rdname prior_draws.brmsfit -#' @export -prior_samples <- function(x, ...) { - warning2("'prior_samples' is deprecated. Please use 'prior_draws' instead.") - UseMethod("prior_draws") -} - -# ignore priors of certain parameters from whom we cannot obtain prior draws -# currently applies only to overall intercepts of centered design matrices -# fixes issue #696 -# @param x a brmsfit object -# @param variable name of a single variable -# @return TRUE (if the prior should be ignored) or FALSE -ignore_prior <- function(x, variable) { - stopifnot(is.brmsfit(x)) - variable <- as_one_character(variable) - out <- FALSE - if (grepl("^b_.*Intercept($|\\[)", variable)) { - # cannot sample from intercepts if 'center' was TRUE - intercept_priors <- subset2(x$prior, class = "Intercept") - if (NROW(intercept_priors)) { - # prefixes of the model intercepts - p_intercepts <- usc(combine_prefix(intercept_priors)) - # prefix of the parameter under question - p_par <- sub("^b", "", variable) - p_par <- sub("_Intercept($|\\[)", "", p_par) - out <- p_par %in% p_intercepts - if (out) { - warning2( - "Sampling from the prior of an overall intercept is not ", - "possible by default. See the documentation of the ", - "'sample_prior' argument in help('brm')." - ) - } - } - } - out -} +#' Extract Prior Draws +#' +#' Extract prior draws of specified parameters +#' +#' @aliases prior_draws.brmsfit prior_samples +#' +#' @param x An \code{R} object typically of class \code{brmsfit}. +#' @inheritParams as.data.frame.brmsfit +#' @param ... Arguments passed to individual methods (if applicable). +#' +#' @details To make use of this function, the model must contain draws of +#' prior distributions. This can be ensured by setting \code{sample_prior = +#' TRUE} in function \code{brm}. Priors of certain parameters cannot be saved +#' for technical reasons. For instance, this is the case for the +#' population-level intercept, which is only computed after fitting the model +#' by default. If you want to treat the intercept as part of all the other +#' regression coefficients, so that sampling from its prior becomes possible, +#' use \code{... ~ 0 + Intercept + ...} in the formulas. +#' +#' @return A \code{data.frame} containing the prior draws. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(rating ~ treat + period + carry + (1|subject), +#' data = inhaler, family = "cumulative", +#' prior = set_prior("normal(0,2)", class = "b"), +#' sample_prior = TRUE) +#' +#' # extract all prior draws +#' draws1 <- prior_draws(fit) +#' head(draws1) +#' +#' # extract prior draws for the coefficient of 'treat' +#' draws2 <- prior_draws(fit, "b_treat") +#' head(draws2) +#' } +#' +#' @export +prior_draws.brmsfit <- function(x, variable = NULL, pars = NULL, ...) { + variable <- use_alias(variable, pars) + if (!is.null(variable)) { + variable <- as.character(variable) + } + all_names <- variables(x) + prior_names <- unique(all_names[grepl("^prior_", all_names)]) + if (!length(prior_names)) { + return(data.frame(NULL)) + } + draws <- as.data.frame(x, variable = prior_names) + names(draws) <- sub("^prior_", "", prior_names) + if (is.null(variable)) { + return(draws) + } + # get prior draws for a single variable + .prior_draws <- function(variable) { + matches <- paste0("^", escape_all(names(draws))) + matches <- lapply(matches, regexpr, text = variable) + matches <- ulapply(matches, attr, which = "match.length") + if (max(matches) == -1 || ignore_prior(x, variable)) { + out <- NULL + } else { + take <- match(max(matches), matches) + # order draws randomly to avoid artificial dependencies + # between parameters using the same prior draws + draws <- list(draws[sample(ndraws(x)), take]) + out <- structure(draws, names = variable) + } + return(out) + } + draws <- rmNULL(lapply(variable, .prior_draws)) + draws <- data.frame(draws, check.names = FALSE) + draws +} + +#' @rdname prior_draws.brmsfit +#' @export +prior_draws <- function(x, ...) { + UseMethod("prior_draws") +} + +#' @export +prior_draws.default <- function(x, variable = NULL, pars = NULL, + regex = FALSE, fixed = FALSE, ...) { + call <- match.call() + if ("pars" %in% names(call)) { + variable <- use_alias(variable, pars) + regex <- !as_one_logical(fixed) + } + if (is.null(variable)) { + variable <- "^prior_" + regex <- TRUE + } else { + variable <- as.character(variable) + regex <- as_one_logical(regex) + if (regex) { + hat <- substr(variable, 1, 1) == "^" + variable <- ifelse(hat, substr(variable, 2, nchar(variable)), variable) + variable <- paste0("^prior_", variable) + } else { + variable <- paste0("prior_", variable) + } + } + x <- as_draws_df(as.data.frame(x)) + if (!regex) { + # missing variables will leads to an error in posterior + variable <- intersect(variable, variables(x)) + if (!length(variable)) { + return(data.frame(NULL)) + } + } + x <- subset_draws(x, variable = variable, regex = regex, ...) + unclass_draws(x) +} + +#' @rdname prior_draws.brmsfit +#' @export +prior_samples <- function(x, ...) { + warning2("'prior_samples' is deprecated. Please use 'prior_draws' instead.") + UseMethod("prior_draws") +} + +# ignore priors of certain parameters from whom we cannot obtain prior draws +# currently applies only to overall intercepts of centered design matrices +# fixes issue #696 +# @param x a brmsfit object +# @param variable name of a single variable +# @return TRUE (if the prior should be ignored) or FALSE +ignore_prior <- function(x, variable) { + stopifnot(is.brmsfit(x)) + variable <- as_one_character(variable) + out <- FALSE + if (grepl("^b_.*Intercept($|\\[)", variable)) { + # cannot sample from intercepts if 'center' was TRUE + intercept_priors <- subset2(x$prior, class = "Intercept") + if (NROW(intercept_priors)) { + # prefixes of the model intercepts + p_intercepts <- usc(combine_prefix(intercept_priors)) + # prefix of the parameter under question + p_par <- sub("^b", "", variable) + p_par <- sub("_Intercept($|\\[)", "", p_par) + out <- p_par %in% p_intercepts + if (out) { + warning2( + "Sampling from the prior of an overall intercept is not ", + "possible by default. See the documentation of the ", + "'sample_prior' argument in help('brm')." + ) + } + } + } + out +} diff -Nru r-cran-brms-2.16.3/R/priors.R r-cran-brms-2.17.0/R/priors.R --- r-cran-brms-2.16.3/R/priors.R 2021-10-29 07:24:09.000000000 +0000 +++ r-cran-brms-2.17.0/R/priors.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,20 +1,20 @@ #' Prior Definitions for \pkg{brms} Models #' #' Define priors for specific parameters or classes of parameters. -#' +#' #' @aliases brmsprior brmsprior-class #' #' @param prior A character string defining a distribution in \pkg{Stan} language -#' @param class The parameter class. Defaults to \code{"b"} -#' (i.e. population-level effects). -#' See 'Details' for other valid parameter classes. -#' @param coef Name of the coefficient within the parameter class. +#' @param class The parameter class. Defaults to \code{"b"} +#' (i.e. population-level effects). +#' See 'Details' for other valid parameter classes. +#' @param coef Name of the coefficient within the parameter class. #' @param group Grouping factor for group-level parameters. #' @param resp Name of the response variable. #' Only used in multivariate models. #' @param dpar Name of a distributional parameter. #' Only used in distributional models. -#' @param nlpar Name of a non-linear parameter. +#' @param nlpar Name of a non-linear parameter. #' Only used in non-linear models. #' @param lb Lower bound for parameter restriction. Currently only allowed #' for classes \code{"b"}. Defaults to \code{NULL}, that is no restriction. @@ -25,277 +25,277 @@ #' Defaults to \code{TRUE}. If \code{FALSE}, \code{prior} is passed #' to the Stan code as is, and all other arguments are ignored. #' @param ... Arguments passed to \code{set_prior}. -#' +#' #' @return An object of class \code{brmsprior} to be used in the \code{prior} #' argument of \code{\link{brm}}. -#' -#' @details -#' \code{set_prior} is used to define prior distributions for parameters +#' +#' @details +#' \code{set_prior} is used to define prior distributions for parameters #' in \pkg{brms} models. The functions \code{prior}, \code{prior_}, and #' \code{prior_string} are aliases of \code{set_prior} each allowing -#' for a different kind of argument specification. +#' for a different kind of argument specification. #' \code{prior} allows specifying arguments as expression without -#' quotation marks using non-standard evaluation. +#' quotation marks using non-standard evaluation. #' \code{prior_} allows specifying arguments as one-sided formulas #' or wrapped in \code{quote}. #' \code{prior_string} allows specifying arguments as strings just #' as \code{set_prior} itself. -#' -#' Below, we explain its usage and list some common -#' prior distributions for parameters. -#' A complete overview on possible prior distributions is given +#' +#' Below, we explain its usage and list some common +#' prior distributions for parameters. +#' A complete overview on possible prior distributions is given #' in the Stan Reference Manual available at \url{https://mc-stan.org/}. -#' -#' To combine multiple priors, use \code{c(...)} or the \code{+} operator -#' (see 'Examples'). \pkg{brms} does not check if the priors are written -#' in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their -#' syntactical correctness when the model is parsed to \code{C++} and -#' returns an error if they are not. -#' This, however, does not imply that priors are always meaningful if they are -#' accepted by \pkg{Stan}. Although \pkg{brms} trys to find common problems -#' (e.g., setting bounded priors on unbounded parameters), there is no guarantee +#' +#' To combine multiple priors, use \code{c(...)} or the \code{+} operator +#' (see 'Examples'). \pkg{brms} does not check if the priors are written +#' in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their +#' syntactical correctness when the model is parsed to \code{C++} and +#' returns an error if they are not. +#' This, however, does not imply that priors are always meaningful if they are +#' accepted by \pkg{Stan}. Although \pkg{brms} trys to find common problems +#' (e.g., setting bounded priors on unbounded parameters), there is no guarantee #' that the defined priors are reasonable for the model. -#' Below, we list the types of parameters in \pkg{brms} models, +#' Below, we list the types of parameters in \pkg{brms} models, #' for which the user can specify prior distributions. -#' +#' #' 1. Population-level ('fixed') effects -#' -#' Every Population-level effect has its own regression parameter -# These parameters are internally named as \code{b_}, where \code{} -#' represents the name of the corresponding population-level effect. -#' Suppose, for instance, that \code{y} is predicted by \code{x1} and \code{x2} -#' (i.e., \code{y ~ x1 + x2} in formula syntax). -#' Then, \code{x1} and \code{x2} have regression parameters -#' \code{b_x1} and \code{b_x2} respectively. -#' The default prior for population-level effects (including monotonic and -#' category specific effects) is an improper flat prior over the reals. -#' Other common options are normal priors or student-t priors. -#' If we want to have a normal prior with mean 0 and -#' standard deviation 5 for \code{x1}, and a unit student-t prior with 10 +#' +#' Every Population-level effect has its own regression parameter +# These parameters are internally named as \code{b_}, where \code{} +#' represents the name of the corresponding population-level effect. +#' Suppose, for instance, that \code{y} is predicted by \code{x1} and \code{x2} +#' (i.e., \code{y ~ x1 + x2} in formula syntax). +#' Then, \code{x1} and \code{x2} have regression parameters +#' \code{b_x1} and \code{b_x2} respectively. +#' The default prior for population-level effects (including monotonic and +#' category specific effects) is an improper flat prior over the reals. +#' Other common options are normal priors or student-t priors. +#' If we want to have a normal prior with mean 0 and +#' standard deviation 5 for \code{x1}, and a unit student-t prior with 10 #' degrees of freedom for \code{x2}, we can specify this via #' \code{set_prior("normal(0,5)", class = "b", coef = "x1")} and \cr #' \code{set_prior("student_t(10, 0, 1)", class = "b", coef = "x2")}. -#' To put the same prior on all population-level effects at once, -#' we may write as a shortcut \code{set_prior("", class = "b")}. -#' This also leads to faster sampling, because priors can be vectorized in this case. -#' Both ways of defining priors can be combined using for instance +#' To put the same prior on all population-level effects at once, +#' we may write as a shortcut \code{set_prior("", class = "b")}. +#' This also leads to faster sampling, because priors can be vectorized in this case. +#' Both ways of defining priors can be combined using for instance #' \code{set_prior("normal(0, 2)", class = "b")} and \cr #' \code{set_prior("normal(0, 10)", class = "b", coef = "x1")} -#' at the same time. This will set a \code{normal(0, 10)} prior on -#' the effect of \code{x1} and a \code{normal(0, 2)} prior -#' on all other population-level effects. +#' at the same time. This will set a \code{normal(0, 10)} prior on +#' the effect of \code{x1} and a \code{normal(0, 2)} prior +#' on all other population-level effects. #' However, this will break vectorization and #' may slow down the sampling procedure a bit. -#' -#' In case of the default intercept parameterization -#' (discussed in the 'Details' section of \code{\link{brmsformula}}), -#' general priors on class \code{"b"} will \emph{not} affect -#' the intercept. Instead, the intercept has its own parameter class -#' named \code{"Intercept"} and priors can thus be +#' +#' In case of the default intercept parameterization +#' (discussed in the 'Details' section of \code{\link{brmsformula}}), +#' general priors on class \code{"b"} will \emph{not} affect +#' the intercept. Instead, the intercept has its own parameter class +#' named \code{"Intercept"} and priors can thus be #' specified via \code{set_prior("", class = "Intercept")}. #' Setting a prior on the intercept will not break vectorization #' of the other population-level effects. #' Note that technically, this prior is set on an intercept that -#' results when internally centering all population-level predictors -#' around zero to improve sampling efficiency. On this centered -#' intercept, specifying a prior is actually much easier and -#' intuitive than on the original intercept, since the former -#' represents the expected response value when all predictors -#' are at their means. To treat the intercept as an ordinary -#' population-level effect and avoid the centering parameterization, +#' results when internally centering all population-level predictors +#' around zero to improve sampling efficiency. On this centered +#' intercept, specifying a prior is actually much easier and +#' intuitive than on the original intercept, since the former +#' represents the expected response value when all predictors +#' are at their means. To treat the intercept as an ordinary +#' population-level effect and avoid the centering parameterization, #' use \code{0 + Intercept} on the right-hand side of the model formula. -#' +#' #' A special shrinkage prior to be applied on population-level effects is the #' (regularized) horseshoe prior and related priors. See #' \code{\link{horseshoe}} for details. Another shrinkage prior is the #' so-called lasso prior. See \code{\link{lasso}} for details. -#' -#' In non-linear models, population-level effects are defined separately +#' +#' In non-linear models, population-level effects are defined separately #' for each non-linear parameter. Accordingly, it is necessary to specify #' the non-linear parameter in \code{set_prior} so that priors -#' we can be assigned correctly. +#' we can be assigned correctly. #' If, for instance, \code{alpha} is the parameter and \code{x} the predictor #' for which we want to define the prior, we can write -#' \code{set_prior("", coef = "x", nlpar = "alpha")}. +#' \code{set_prior("", coef = "x", nlpar = "alpha")}. #' As a shortcut we can use \code{set_prior("", nlpar = "alpha")} #' to set the same prior on all population-level effects of \code{alpha} at once. -#' -#' If desired, population-level effects can be restricted to fall only +#' +#' If desired, population-level effects can be restricted to fall only #' within a certain interval using the \code{lb} and \code{ub} arguments #' of \code{set_prior}. This is often required when defining priors #' that are not defined everywhere on the real line, such as uniform -#' or gamma priors. When defining a \code{uniform(2,4)} prior, -#' you should write \code{set_prior("uniform(2,4)", lb = 2, ub = 4)}. -#' When using a prior that is defined on the positive reals only -#' (such as a gamma prior) set \code{lb = 0}. +#' or gamma priors. When defining a \code{uniform(2,4)} prior, +#' you should write \code{set_prior("uniform(2,4)", lb = 2, ub = 4)}. +#' When using a prior that is defined on the positive reals only +#' (such as a gamma prior) set \code{lb = 0}. #' In most situations, it is not useful to restrict population-level -#' parameters through bounded priors -#' (non-linear models are an important exception), +#' parameters through bounded priors +#' (non-linear models are an important exception), #' but if you really want to this is the way to go. -#' +#' #' 2. Standard deviations of group-level ('random') effects -#' +#' #' Each group-level effect of each grouping factor has a standard deviation named -#' \code{sd__}. Consider, for instance, the formula +#' \code{sd__}. Consider, for instance, the formula #' \code{y ~ x1 + x2 + (1 + x1 | g)}. #' We see that the intercept as well as \code{x1} are group-level effects -#' nested in the grouping factor \code{g}. -#' The corresponding standard deviation parameters are named as -#' \code{sd_g_Intercept} and \code{sd_g_x1} respectively. -#' These parameters are restricted to be non-negative and, by default, -#' have a half student-t prior with 3 degrees of freedom and a -#' scale parameter that depends on the standard deviation of the response -#' after applying the link function. Minimally, the scale parameter is 2.5. +#' nested in the grouping factor \code{g}. +#' The corresponding standard deviation parameters are named as +#' \code{sd_g_Intercept} and \code{sd_g_x1} respectively. +#' These parameters are restricted to be non-negative and, by default, +#' have a half student-t prior with 3 degrees of freedom and a +#' scale parameter that depends on the standard deviation of the response +#' after applying the link function. Minimally, the scale parameter is 2.5. #' This prior is used (a) to be only weakly informative in order to influence #' results as few as possible, while (b) providing at least some regularization #' to considerably improve convergence and sampling efficiency. -#' To define a prior distribution only for standard deviations +#' To define a prior distribution only for standard deviations #' of a specific grouping factor, -#' use \cr \code{set_prior("", class = "sd", group = "")}. -#' To define a prior distribution only for a specific standard deviation +#' use \cr \code{set_prior("", class = "sd", group = "")}. +#' To define a prior distribution only for a specific standard deviation #' of a specific grouping factor, you may write \cr -#' \code{set_prior("", class = "sd", group = "", coef = "")}. -#' Recommendations on useful prior distributions for +#' \code{set_prior("", class = "sd", group = "", coef = "")}. +#' Recommendations on useful prior distributions for #' standard deviations are given in Gelman (2006), but note that he #' is no longer recommending uniform priors, anymore. \cr -#' -#' When defining priors on group-level parameters in non-linear models, -#' please make sure to specify the corresponding non-linear parameter -#' through the \code{nlpar} argument in the same way as +#' +#' When defining priors on group-level parameters in non-linear models, +#' please make sure to specify the corresponding non-linear parameter +#' through the \code{nlpar} argument in the same way as #' for population-level effects. -#' -#' 3. Correlations of group-level ('random') effects -#' -#' If there is more than one group-level effect per grouping factor, -#' the correlations between those effects have to be estimated. -#' The prior \code{lkj_corr_cholesky(eta)} or in short -#' \code{lkj(eta)} with \code{eta > 0} -#' is essentially the only prior for (Cholesky factors) of correlation matrices. -#' If \code{eta = 1} (the default) all correlations matrices -#' are equally likely a priori. If \code{eta > 1}, extreme correlations -#' become less likely, whereas \code{0 < eta < 1} results in -#' higher probabilities for extreme correlations. -#' Correlation matrix parameters in \code{brms} models are named as +#' +#' 3. Correlations of group-level ('random') effects +#' +#' If there is more than one group-level effect per grouping factor, +#' the correlations between those effects have to be estimated. +#' The prior \code{lkj_corr_cholesky(eta)} or in short +#' \code{lkj(eta)} with \code{eta > 0} +#' is essentially the only prior for (Cholesky factors) of correlation matrices. +#' If \code{eta = 1} (the default) all correlations matrices +#' are equally likely a priori. If \code{eta > 1}, extreme correlations +#' become less likely, whereas \code{0 < eta < 1} results in +#' higher probabilities for extreme correlations. +#' Correlation matrix parameters in \code{brms} models are named as #' \code{cor_}, (e.g., \code{cor_g} if \code{g} is the grouping factor). -#' To set the same prior on every correlation matrix, +#' To set the same prior on every correlation matrix, #' use for instance \code{set_prior("lkj(2)", class = "cor")}. #' Internally, the priors are transformed to be put on the Cholesky factors #' of the correlation matrices to improve efficiency and numerical stability. #' The corresponding parameter class of the Cholesky factors is \code{L}, #' but it is not recommended to specify priors for this parameter class directly. -#' +#' #' 4. Splines -#' -#' Splines are implemented in \pkg{brms} using the 'random effects' -#' formulation as explained in \code{\link[mgcv:gamm]{gamm}}). -#' Thus, each spline has its corresponding standard deviations -#' modeling the variability within this term. In \pkg{brms}, this +#' +#' Splines are implemented in \pkg{brms} using the 'random effects' +#' formulation as explained in \code{\link[mgcv:gamm]{gamm}}). +#' Thus, each spline has its corresponding standard deviations +#' modeling the variability within this term. In \pkg{brms}, this #' parameter class is called \code{sds} and priors can -#' be specified via \code{set_prior("", class = "sds", +#' be specified via \code{set_prior("", class = "sds", #' coef = "")}. The default prior is the same as #' for standard deviations of group-level effects. -#' +#' #' 5. Gaussian processes -#' +#' #' Gaussian processes as currently implemented in \pkg{brms} have -#' two parameters, the standard deviation parameter \code{sdgp}, -#' and characteristic length-scale parameter \code{lscale} -#' (see \code{\link{gp}} for more details). The default prior -#' of \code{sdgp} is the same as for standard deviations of +#' two parameters, the standard deviation parameter \code{sdgp}, +#' and characteristic length-scale parameter \code{lscale} +#' (see \code{\link{gp}} for more details). The default prior +#' of \code{sdgp} is the same as for standard deviations of #' group-level effects. The default prior of \code{lscale} -#' is an informative inverse-gamma prior specifically tuned +#' is an informative inverse-gamma prior specifically tuned #' to the covariates of the Gaussian process (for more details see #' \url{https://betanalpha.github.io/assets/case_studies/gp_part3/part3.html}). -#' This tuned prior may be overly informative in some cases, so please +#' This tuned prior may be overly informative in some cases, so please #' consider other priors as well to make sure inference is -#' robust to the prior specification. If tuning fails, a half-normal prior +#' robust to the prior specification. If tuning fails, a half-normal prior #' is used instead. -#' +#' #' 6. Autocorrelation parameters -#' -#' The autocorrelation parameters currently implemented are named -#' \code{ar} (autoregression), \code{ma} (moving average), -#' \code{arr} (autoregression of the response), \code{car} -#' (spatial conditional autoregression), as well as \code{lagsar} -#' and \code{errorsar} (Spatial simultaneous autoregression). -#' -#' Priors can be defined by \code{set_prior("", class = "ar")} -#' for \code{ar} and similar for other autocorrelation parameters. -#' By default, \code{ar} and \code{ma} are bounded between \code{-1} -#' and \code{1}, \code{car}, \code{lagsar}, and \code{errorsar} are -#' bounded between \code{0}, and \code{1}, and \code{arr} is unbounded -#' (you may change this by using the arguments \code{lb} and \code{ub}). -#' The default prior is flat over the definition area. -#' +#' +#' The autocorrelation parameters currently implemented are named \code{ar} +#' (autoregression), \code{ma} (moving average), \code{sderr} (standard +#' deviation of latent residuals in latent ARMA models), \code{cosy} (compound +#' symmetry correlation), \code{car} (spatial conditional autoregression), as +#' well as \code{lagsar} and \code{errorsar} (spatial simultaneous +#' autoregression). +#' +#' Priors can be defined by \code{set_prior("", class = "ar")} for +#' \code{ar} and similar for other autocorrelation parameters. By default, +#' \code{ar} and \code{ma} are bounded between \code{-1} and \code{1}; +#' \code{cosy}, \code{car}, \code{lagsar}, and \code{errorsar} are bounded +#' between \code{0} and \code{1}. The default priors are flat over the +#' respective definition areas. +#' #' 7. Distance parameters of monotonic effects -#' +#' #' As explained in the details section of \code{\link{brm}}, #' monotonic effects make use of a special parameter vector to -#' estimate the 'normalized distances' between consecutive predictor +#' estimate the 'normalized distances' between consecutive predictor #' categories. This is realized in \pkg{Stan} using the \code{simplex} -#' parameter type. This class is named \code{"simo"} (short for -#' simplex monotonic) in \pkg{brms}. +#' parameter type. This class is named \code{"simo"} (short for +#' simplex monotonic) in \pkg{brms}. #' The only valid prior for simplex parameters is the #' dirichlet prior, which accepts a vector of length \code{K - 1} #' (K = number of predictor categories) as input defining the -#' 'concentration' of the distribution. Explaining the dirichlet prior +#' 'concentration' of the distribution. Explaining the dirichlet prior #' is beyond the scope of this documentation, but we want to describe #' how to define this prior syntactically correct. -#' If a predictor \code{x} with \code{K} categories is modeled as monotonic, +#' If a predictor \code{x} with \code{K} categories is modeled as monotonic, #' we can define a prior on its corresponding simplex via \cr #' \code{prior(dirichlet(), class = simo, coef = mox1)}. #' The \code{1} in the end of \code{coef} indicates that this is the first #' simplex in this term. If interactions between multiple monotonic -#' variables are modeled, multiple simplexes per term are required. +#' variables are modeled, multiple simplexes per term are required. #' For \code{}, we can put in any \code{R} expression -#' defining a vector of length \code{K - 1}. The default is a uniform +#' defining a vector of length \code{K - 1}. The default is a uniform #' prior (i.e. \code{ = rep(1, K-1)}) over all simplexes -#' of the respective dimension. -#' -#' 8. Parameters for specific families -#' -#' Some families need additional parameters to be estimated. +#' of the respective dimension. +#' +#' 8. Parameters for specific families +#' +#' Some families need additional parameters to be estimated. #' Families \code{gaussian}, \code{student}, \code{skew_normal}, -#' \code{lognormal}, and \code{gen_extreme_value} need the parameter +#' \code{lognormal}, and \code{gen_extreme_value} need the parameter #' \code{sigma} to account for the residual standard deviation. -#' By default, \code{sigma} has a half student-t prior that scales +#' By default, \code{sigma} has a half student-t prior that scales #' in the same way as the group-level standard deviations. -#' Further, family \code{student} needs the parameter -#' \code{nu} representing the degrees of freedom of students-t distribution. +#' Further, family \code{student} needs the parameter +#' \code{nu} representing the degrees of freedom of students-t distribution. #' By default, \code{nu} has prior \code{gamma(2, 0.1)} #' and a fixed lower bound of \code{1}. #' Families \code{gamma}, \code{weibull}, \code{inverse.gaussian}, and -#' \code{negbinomial} need a \code{shape} parameter that has a -#' \code{gamma(0.01, 0.01)} prior by default. -#' For families \code{cumulative}, \code{cratio}, \code{sratio}, -#' and \code{acat}, and only if \code{threshold = "equidistant"}, -#' the parameter \code{delta} is used to model the distance between -#' two adjacent thresholds. +#' \code{negbinomial} need a \code{shape} parameter that has a +#' \code{gamma(0.01, 0.01)} prior by default. +#' For families \code{cumulative}, \code{cratio}, \code{sratio}, +#' and \code{acat}, and only if \code{threshold = "equidistant"}, +#' the parameter \code{delta} is used to model the distance between +#' two adjacent thresholds. #' By default, \code{delta} has an improper flat prior over the reals. #' The \code{von_mises} family needs the parameter \code{kappa}, representing -#' the concentration parameter. By default, \code{kappa} has prior +#' the concentration parameter. By default, \code{kappa} has prior #' \code{gamma(2, 0.01)}. \cr #' Every family specific parameter has its own prior class, so that #' \code{set_prior("", class = "")} is the right way to go. #' All of these priors are chosen to be weakly informative, #' having only minimal influence on the estimations, #' while improving convergence and sampling efficiency. -#' +#' #' Fixing parameters to constants is possible by using the \code{constant} #' function, for example, \code{constant(1)} to fix a parameter to 1. #' Broadcasting to vectors and matrices is done automatically. -#' +#' #' Often, it may not be immediately clear, which parameters are present in the #' model. To get a full list of parameters and parameter classes for which #' priors can be specified (depending on the model) use function #' \code{\link{get_prior}}. #' #' @seealso \code{\link{get_prior}} -#' +#' #' @references #' Gelman A. (2006). Prior distributions for variance parameters in hierarchical models. #' Bayesian analysis, 1(3), 515 -- 534. -#' +#' #' @examples #' ## use alias functions #' (prior1 <- prior(cauchy(0, 1), class = sd)) @@ -303,41 +303,41 @@ #' (prior3 <- prior_string("cauchy(0, 1)", class = "sd")) #' identical(prior1, prior2) #' identical(prior1, prior3) -#' +#' #' # check which parameters can have priors #' get_prior(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = cumulative()) -#' -#' # define some priors +#' +#' # define some priors #' bprior <- c(prior_string("normal(0,10)", class = "b"), #' prior(normal(1,2), class = b, coef = treat), -#' prior_(~cauchy(0,2), class = ~sd, +#' prior_(~cauchy(0,2), class = ~sd, #' group = ~subject, coef = ~Intercept)) -#' +#' #' # verify that the priors indeed found their way into Stan's model code #' make_stancode(rating ~ treat + period + carry + (1|subject), #' data = inhaler, family = cumulative(), #' prior = bprior) -#' +#' #' # use the horseshoe prior to model sparsity in regression coefficients #' make_stancode(count ~ zAge + zBase * Trt, #' data = epilepsy, family = poisson(), #' prior = set_prior("horseshoe(3)")) -#' +#' #' # fix certain priors to constants #' bprior <- prior(constant(1), class = "b") + #' prior(constant(2), class = "b", coef = "zBase") + #' prior(constant(0.5), class = "sd") #' make_stancode(count ~ zAge + zBase + (1 | patient), #' data = epilepsy, prior = bprior) -#' +#' #' # pass priors to Stan without checking #' prior <- prior_string("target += normal_lpdf(b[1] | 0, 1)", check = FALSE) #' make_stancode(count ~ Trt, data = epilepsy, prior = prior) #' #' @export set_prior <- function(prior, class = "b", coef = "", group = "", - resp = "", dpar = "", nlpar = "", + resp = "", dpar = "", nlpar = "", lb = NA, ub = NA, check = TRUE) { input <- nlist(prior, class, coef, group, resp, dpar, nlpar, lb, ub, check) input <- try(as.data.frame(input), silent = TRUE) @@ -350,9 +350,9 @@ } Reduce("+", out) } - + # validate arguments passed to 'set_prior' -.set_prior <- function(prior, class, coef, group, resp, +.set_prior <- function(prior, class, coef, group, resp, dpar, nlpar, lb, ub, check) { prior <- as_one_character(prior) class <- as_one_character(class) @@ -361,47 +361,26 @@ resp <- as_one_character(resp) dpar <- as_one_character(dpar) nlpar <- as_one_character(nlpar) + check <- as_one_logical(check) lb <- as_one_character(lb, allow_na = TRUE) ub <- as_one_character(ub, allow_na = TRUE) - check <- as_one_logical(check) - # validate boundaries - bound <- "" - if (class %in% c("ar", "ma") && (!is.na(lb) || !is.na(ub))) { - # changed in version 2.9.5 - lb <- ub <- NA - warning2( - "Changing the boundaries of autocorrelation parameters ", - "is deprecated and will be ignored." - ) - } - if (!is.na(lb) || !is.na(ub)) { - # TODO: extend the boundary interface to more parameter classes - boundary_classes <- c("b") - if (!class %in% boundary_classes) { - stop2("Currently boundaries are only allowed for classe(s) ", - collapse_comma(boundary_classes), "." - ) - } + if (check && (!is.na(lb) || !is.na(ub))) { + # proper boundaries have been specified if (nzchar(coef)) { + # TODO: enable bounds for coefficients as well? stop2("Argument 'coef' may not be specified when using boundaries.") } - # don't put spaces in boundary declarations - lb <- if (!is.na(lb)) paste0("lower=", lb) - ub <- if (!is.na(ub)) paste0("upper=", ub) - if (!is.null(lb) || !is.null(ub)) { - bound <- paste0("<", paste(c(lb, ub), collapse = ","), ">") - } } if (!check) { # prior will be added to the log-posterior as is - class <- coef <- group <- resp <- dpar <- nlpar <- bound <- "" + class <- coef <- group <- resp <- dpar <- nlpar <- lb <- ub <- "" } source <- "user" - out <- nlist(prior, source, class, coef, group, resp, dpar, nlpar, bound) + out <- nlist(prior, source, class, coef, group, resp, dpar, nlpar, lb, ub) do_call(brmsprior, out) } -#' @describeIn set_prior Alias of \code{set_prior} allowing to +#' @describeIn set_prior Alias of \code{set_prior} allowing to #' specify arguments as expressions without quotation marks. #' @export prior <- function(prior, ...) { @@ -412,7 +391,7 @@ do_call(set_prior, c(call, seval)) } -#' @describeIn set_prior Alias of \code{set_prior} allowing to specify +#' @describeIn set_prior Alias of \code{set_prior} allowing to specify #' arguments as as one-sided formulas or wrapped in \code{quote}. #' @export prior_ <- function(prior, ...) { @@ -425,7 +404,7 @@ } else if (is.call(x) || is.name(x) || is.atomic(x)) { deparse_no_string(x) } else { - stop2("Arguments must be one-sided formula, call, name, or constant.") + stop2("Arguments must be one-sided formula, call, name, or constant.") } } call <- lapply(call, as_string) @@ -445,58 +424,58 @@ } #' Overview on Priors for \pkg{brms} Models -#' -#' Get information on all parameters (and parameter classes) for which priors +#' +#' Get information on all parameters (and parameter classes) for which priors #' may be specified including default priors. -#' +#' #' @inheritParams brm #' @param ... Other arguments for internal usage only. -#' +#' #' @return A data.frame with columns \code{prior}, \code{class}, \code{coef}, #' and \code{group} and several rows, each providing information on a #' parameter (or parameter class) on which priors can be specified. The prior #' column is empty except for internal default priors. -#' +#' #' @seealso \code{\link{set_prior}} -#' -#' @examples +#' +#' @examples #' ## get all parameters and parameters classes to define priors on #' (prior <- get_prior(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), -#' data = epilepsy, family = poisson())) -#' +#' data = epilepsy, family = poisson())) +#' #' ## define a prior on all population-level effects a once #' prior$prior[1] <- "normal(0,10)" -#' +#' #' ## define a specific prior on the population-level effect of Trt -#' prior$prior[5] <- "student_t(10, 0, 5)" -#' +#' prior$prior[5] <- "student_t(10, 0, 5)" +#' #' ## verify that the priors indeed found their way into Stan's model code #' make_stancode(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), -#' data = epilepsy, family = poisson(), +#' data = epilepsy, family = poisson(), #' prior = prior) -#' +#' #' @export -get_prior <- function(formula, data, family = gaussian(), autocor = NULL, +get_prior <- function(formula, data, family = gaussian(), autocor = NULL, data2 = NULL, knots = NULL, sparse = NULL, ...) { if (is.brmsfit(formula)) { stop2("Use 'prior_summary' to extract priors from 'brmsfit' objects.") } formula <- validate_formula( - formula, data = data, family = family, + formula, data = data, family = family, autocor = autocor, sparse = sparse ) bterms <- brmsterms(formula) data2 <- validate_data2( - data2, bterms = bterms, + data2, bterms = bterms, get_data2_autocor(formula) ) data <- validate_data( - data, bterms = bterms, + data, bterms = bterms, data2 = data2, knots = knots ) .get_prior(bterms, data, ...) } - + # internal work function of 'get_prior' # @param internal return priors for internal use? # @return a brmsprior object @@ -541,7 +520,7 @@ prior_predictor.mvbrmsterms <- function(x, internal = FALSE, ...) { prior <- empty_prior() for (i in seq_along(x$terms)) { - prior <- prior + prior_predictor(x$terms[[i]], ...) + prior <- prior + prior_predictor(x$terms[[i]], ...) } for (cl in c("b", "Intercept")) { # deprecated; see warning in 'validate_prior_special' @@ -557,13 +536,14 @@ prior <- prior + brmsprior(class = "rescor", prior = "lkj(1)") } if (family_names(x)[1] %in% "student") { - prior <- prior + brmsprior(class = "nu", prior = "gamma(2, 0.1)") + prior <- prior + + brmsprior(class = "nu", prior = "gamma(2, 0.1)", lb = "1") } } prior } -prior_predictor.brmsterms <- function(x, data, ...) { +prior_predictor.brmsterms <- function(x, data, internal = FALSE, ...) { data <- subset_data(data, x) def_scale_prior <- def_scale_prior(x, data) valid_dpars <- valid_dpars(x) @@ -574,16 +554,16 @@ # individual theta parameters should not have a prior in this case theta_dpars <- str_subset(valid_dpars, "^theta[[:digit:]]+") valid_dpars <- setdiff(valid_dpars, theta_dpars) - prior <- prior + + prior <- prior + brmsprior(prior = "dirichlet(1)", class = "theta", resp = x$resp) } if (fix_intercepts(x)) { - # fixing thresholds across mixture components + # fixing thresholds across mixture components # requires a single set of priors at the top level stopifnot(is_ordinal(x)) prior <- prior + prior_thres(x, def_scale_prior = def_scale_prior) } - } + } # priors for distributional parameters for (dp in valid_dpars) { def_dprior <- def_dprior(x, dp, data = data) @@ -599,7 +579,11 @@ dp_prior <- empty_prior() } else { # parameter is estimated - dp_prior <- brmsprior(def_dprior, class = dp, resp = x$resp) + dp_bound <- dpar_bounds(dp, suffix = x$resp, family = x$family) + dp_prior <- brmsprior( + def_dprior, class = dp, resp = x$resp, + lb = dp_bound$lb, ub = dp_bound$ub + ) } prior <- prior + dp_prior } @@ -620,11 +604,21 @@ } } } + if (is_logistic_normal(x$family)) { + if (internal) { + prior <- prior + + brmsprior("lkj_corr_cholesky(1)", class = "Llncor", resp = x$resp) + } else { + prior <- prior + + brmsprior("lkj(1)", class = "lncor", resp = x$resp) + } + } # priors for noise-free response variables sdy <- get_sdy(x, data) if (!is.null(sdy)) { - prior <- prior + + prior <- prior + brmsprior(class = "meanme", resp = x$resp) + + # don't specify lb as we already have it in 'prior_Xme' brmsprior(class = "sdme", resp = x$resp) } # priors for autocorrelation parameters @@ -639,7 +633,7 @@ prior_thres(x, ...) + prior_sp(x, ...) + prior_cs(x, ...) + - prior_sm(x, ...) + + prior_sm(x, ...) + prior_gp(x, ...) + prior_ac(x, ...) + prior_bhaz(x, ...) @@ -681,25 +675,25 @@ # fixed thresholds cannot have separate priors return(prior) } - + # create priors for threshold per group .prior_thres <- function(thres, thres_prior = "", group = "") { prior <- empty_prior() if (has_equidistant_thres(bterms)) { # prior for the delta parameter for equidistant thresholds thres <- character(0) - bound <- str_if(has_ordered_thres(bterms), "") + lb <- str_if(has_ordered_thres(bterms), "0") prior <- prior + brmsprior( - class = "delta", group = group, bound = bound, ls = px + class = "delta", group = group, lb = lb, ls = px ) - } + } prior <- prior + brmsprior( prior = c(thres_prior, rep("", length(thres))), - class = "Intercept", coef = c("", thres), + class = "Intercept", coef = c("", thres), group = group, ls = px ) } - + px <- check_prefix(bterms) groups <- get_thres_groups(bterms) if (any(nzchar(groups))) { @@ -740,9 +734,9 @@ simo_coef <- get_simo_labels(spef, use_id = TRUE) if (length(simo_coef)) { prior <- prior + brmsprior( - prior = "dirichlet(1)", class = "simo", + prior = "dirichlet(1)", class = "simo", coef = simo_coef, ls = px - ) + ) } } prior @@ -754,7 +748,7 @@ csef <- colnames(get_model_matrix(bterms$cs, data = data)) if (length(csef)) { px <- check_prefix(bterms) - prior <- prior + + prior <- prior + brmsprior(class = "b", coef = c("", csef), ls = px) } prior @@ -765,9 +759,11 @@ stopifnot(is.meef_frame(meef)) prior <- empty_prior() if (nrow(meef)) { - prior <- prior + - brmsprior(class = "meanme", coef = c("", meef$coef)) + - brmsprior(class = "sdme", coef = c("", meef$coef)) + prior <- prior + + brmsprior(class = "meanme") + + brmsprior(class = "meanme", coef = meef$coef) + + brmsprior(class = "sdme", lb = "0") + + brmsprior(class = "sdme", coef = meef$coef) # priors for correlation parameters groups <- unique(meef$grname) for (i in seq_along(groups)) { @@ -792,7 +788,7 @@ } # default priors of gaussian processes -# @param def_scale_prior: a character string defining +# @param def_scale_prior: a character string defining # the default prior SD parameters prior_gp <- function(bterms, data, def_scale_prior, ...) { prior <- empty_prior() @@ -801,10 +797,11 @@ px <- check_prefix(bterms) lscale_prior <- def_lscale_prior(bterms, data) prior <- prior + - brmsprior(class = "sdgp", prior = def_scale_prior, ls = px) + + brmsprior(class = "sdgp", prior = def_scale_prior, ls = px, + lb = "0") + brmsprior(class = "sdgp", coef = unlist(gpef$sfx1), ls = px) + - brmsprior(class = "lscale", ls = px) + - brmsprior(class = "lscale", prior = lscale_prior, + brmsprior(class = "lscale", ls = px, lb = "0") + + brmsprior(class = "lscale", prior = lscale_prior, coef = names(lscale_prior), ls = px) } prior @@ -836,7 +833,7 @@ if (opt_res$termcd %in% 1:2) { # use the inverse-gamma prior only in case of convergence pars <- exp(opt_res$x) - prior <- paste0("inv_gamma(", sargs(round(pars, 6)), ")") + prior <- paste0("inv_gamma(", sargs(round(pars, 6)), ")") } return(prior) } @@ -873,7 +870,7 @@ # priors for varying effects parameters # @param ranef: a list returned by tidy_ranef -# @param def_scale_prior a character string defining +# @param def_scale_prior a character string defining # the default prior for SD parameters # @param internal: see 'get_prior' prior_re <- function(ranef, def_scale_prior, internal = FALSE, ...) { @@ -885,10 +882,11 @@ px <- check_prefix(ranef) upx <- unique(px) if (length(def_scale_prior) > 1L) { - def_scale_prior <- def_scale_prior[px$resp] + def_scale_prior <- def_scale_prior[px$resp] } global_sd_prior <- brmsprior( - class = "sd", prior = def_scale_prior, ls = px + class = "sd", prior = def_scale_prior, + lb = "0", ls = px ) prior <- prior + global_sd_prior for (id in unique(ranef$id)) { @@ -897,7 +895,8 @@ rpx <- check_prefix(r) urpx <- unique(rpx) # include group-level standard deviations - prior <- prior + + prior <- prior + + # don't specify lb as we already have it above brmsprior(class = "sd", group = group, ls = urpx) + brmsprior(class = "sd", coef = r$coef, group = group, ls = rpx) # detect duplicated group-level effects @@ -925,8 +924,9 @@ } tranef <- get_dist_groups(ranef, "student") if (isTRUE(nrow(tranef) > 0L)) { - prior <- prior + - brmsprior("gamma(2, 0.1)", class = "df", group = tranef$group) + prior <- prior + + brmsprior("gamma(2, 0.1)", class = "df", group = tranef$group, + lb = "1") } prior } @@ -946,11 +946,10 @@ } # prior for SD parameters of the RE coefficients smterms <- unique(smef$term) - prior_strings <- c(def_scale_prior, rep("", length(smterms))) - prior <- prior + brmsprior( - class = "sds", coef = c("", smterms), - prior = prior_strings, ls = px - ) + prior <- prior + + brmsprior(prior = def_scale_prior, class = "sds", + lb = "0", ls = px) + + brmsprior(class = "sds", coef = smterms, ls = px) } prior } @@ -963,40 +962,57 @@ return(prior) } px <- check_prefix(bterms) + p <- combine_prefix(px) + has_ac_latent_residuals <- has_ac_latent_residuals(bterms) if (has_ac_class(acef, "arma")) { acef_arma <- subset2(acef, class = "arma") + # no boundaries are required in the conditional formulation + # when natural residuals automatically define the scale + need_arma_bound <- acef_arma$cov || has_ac_latent_residuals + arma_lb <- str_if(need_arma_bound, "-1") + arma_ub <- str_if(need_arma_bound, "1") if (acef_arma$p > 0) { - prior <- prior + brmsprior(class = "ar", ls = px) + prior <- prior + + brmsprior(class = "ar", ls = px, lb = arma_lb, ub = arma_ub) } if (acef_arma$q > 0) { - prior <- prior + brmsprior(class = "ma", ls = px) + prior <- prior + + brmsprior(class = "ma", ls = px, lb = arma_lb, ub = arma_ub) } } if (has_ac_class(acef, "cosy")) { - prior <- prior + brmsprior(class = "cosy", ls = px) + # cosy correlations may be negative in theory but + # this causes problems with divergent transitions (#878) + prior <- prior + + brmsprior(class = "cosy", ls = px, lb = "0", ub = "1") } if (has_ac_latent_residuals(bterms)) { - prior <- prior + - brmsprior(def_scale_prior, class = "sderr", ls = px) + prior <- prior + + brmsprior(def_scale_prior, class = "sderr", ls = px, lb = "0") } if (has_ac_class(acef, "sar")) { acef_sar <- subset2(acef, class = "sar") + sar_lb <- glue("min_eigenMsar{p}") + sar_ub <- glue("max_eigenMsar{p}") if (acef_sar$type == "lag") { - prior <- prior + brmsprior(class = "lagsar", ls = px) + prior <- prior + + brmsprior(class = "lagsar", lb = sar_lb, ub = sar_ub, ls = px) } if (acef_sar$type == "error") { - prior <- prior + brmsprior(class = "errorsar", ls = px) + prior <- prior + + brmsprior(class = "errorsar", lb = sar_lb, ub = sar_ub, ls = px) } } if (has_ac_class(acef, "car")) { acef_car <- subset2(acef, class = "car") - prior <- prior + - brmsprior(def_scale_prior, class = "sdcar", ls = px) + prior <- prior + + brmsprior(def_scale_prior, class = "sdcar", lb = "0", ls = px) if (acef_car$type %in% "escar") { - prior <- prior + brmsprior(class = "car", ls = px) - } else if (acef_car$type %in% "bym2") { prior <- prior + - brmsprior("beta(1, 1)", class = "rhocar", ls = px) + brmsprior(class = "car", lb = "0", ub = "1", ls = px) + } else if (acef_car$type %in% "bym2") { + prior <- prior + + brmsprior("beta(1, 1)", class = "rhocar", lb = "0", ub = "1", ls = px) } } prior @@ -1018,19 +1034,19 @@ # dpar is estimated or predicted on the linear scale out <- switch(dpar_class, "", mu = def_scale_prior(x, data, center = FALSE, dpar = dpar), - sigma = def_scale_prior(x, data), + sigma = def_scale_prior(x, data), shape = "gamma(0.01, 0.01)", - nu = "gamma(2, 0.1)", + nu = "gamma(2, 0.1)", phi = "gamma(0.01, 0.01)", - kappa = "gamma(2, 0.01)", - beta = "gamma(1, 0.1)", - zi = "beta(1, 1)", - hu = "beta(1, 1)", + kappa = "gamma(2, 0.01)", + beta = "gamma(1, 0.1)", + zi = "beta(1, 1)", + hu = "beta(1, 1)", zoi = "beta(1, 1)", coi = "beta(1, 1)", - bs = "gamma(1, 1)", - ndt = glue("uniform(0, min_Y{resp})"), - bias = "beta(1, 1)", + bs = "gamma(1, 1)", + ndt = glue("uniform(0, min_Y{resp})"), + bias = "beta(1, 1)", quantile = "beta(1, 1)", xi = "normal(0, 2.5)", alpha = "normal(0, 4)", @@ -1043,16 +1059,16 @@ mu = def_scale_prior(x, data, center = FALSE, dpar = dpar), sigma = def_scale_prior(x, data), shape = "student_t(3, 0, 2.5)", - nu = "normal(2.7, 0.8)", + nu = "normal(2.7, 0.8)", phi = "student_t(3, 0, 2.5)", - kappa = "normal(5.0, 0.8)", - beta = "normal(1.7, 1.3)", - zi = "logistic(0, 1)", - hu = "logistic(0, 1)", + kappa = "normal(5.0, 0.8)", + beta = "normal(1.7, 1.3)", + zi = "logistic(0, 1)", + hu = "logistic(0, 1)", zoi = "logistic(0, 1)", coi = "logistic(0, 1)", - bs = "normal(-0.6, 1.3)", - bias = "logistic(0, 1)", + bs = "normal(-0.6, 1.3)", + bias = "logistic(0, 1)", quantile = "logistic(0, 1)", xi = "normal(0, 4)", alpha = "normal(0, 4)", @@ -1077,7 +1093,7 @@ # @param center Should the prior be centered around zero? # If FALSE, the prior location is computed based on Y. #' @export -def_scale_prior.brmsterms <- function(x, data, center = TRUE, df = 3, +def_scale_prior.brmsterms <- function(x, data, center = TRUE, df = 3, location = 0, scale = 2.5, dpar = NULL, ...) { y <- unname(model.response(model.frame(x$respform, data))) @@ -1089,25 +1105,25 @@ if (link %in% tlinks && !is_like_factor(y) && !conv_cats_dpars(x)) { if (link %in% c("log", "inverse", "1/mu^2")) { # avoid Inf in link(y) - y <- ifelse(y == 0, y + 0.1, y) + y <- ifelse(y == 0, y + 0.1, y) } y_link <- SW(link(y, link = link)) scale_y <- round(mad(y_link), 1) if (is.finite(scale_y)) { scale <- max(scale, scale_y) - } + } if (!center) { location_y <- round(median(y_link), 1) if (is.finite(location_y)) { location <- location_y } - # offsets may render default intercept priors not sensible + # offsets may render default intercept priors not sensible dpar <- as_one_character(dpar) offset <- unname(unlist(data_offset(x$dpars[[dpar]], data))) if (length(offset)) { mean_offset <- mean(offset) if (is.finite(mean_offset)) { - location <- location - mean_offset + location <- location - mean_offset } } } @@ -1116,39 +1132,39 @@ } #' Validate Prior for \pkg{brms} Models -#' +#' #' Validate priors supplied by the user. Return a complete #' set of priors for the given model, including default priors. -#' +#' #' @inheritParams get_prior #' @inheritParams brm -#' +#' #' @return An object of class \code{brmsprior}. -#' +#' #' @seealso \code{\link{get_prior}}, \code{\link{set_prior}}. -#' -#' @examples -#' prior1 <- prior(normal(0,10), class = b) + +#' +#' @examples +#' prior1 <- prior(normal(0,10), class = b) + #' prior(cauchy(0,2), class = sd) #' validate_prior(prior1, count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson()) -#' +#' #' @export validate_prior <- function(prior, formula, data, family = gaussian(), - sample_prior = "no", data2 = NULL, knots = NULL, + sample_prior = "no", data2 = NULL, knots = NULL, ...) { formula <- validate_formula(formula, data = data, family = family) bterms <- brmsterms(formula) data2 <- validate_data2(data2, bterms = bterms) data <- validate_data( - data, bterms = bterms, + data, bterms = bterms, data2 = data2, knots = knots ) .validate_prior( prior, bterms = bterms, data = data, sample_prior = sample_prior, ... ) -} +} # internal work function of 'validate_prior' .validate_prior <- function(prior, bterms, data, sample_prior, @@ -1169,8 +1185,8 @@ prior <- prior[!no_checks, ] # check for duplicated priors prior$class <- rename( - prior$class, c("^cor$", "^rescor$", "^corme$"), - c("L", "Lrescor", "Lme"), fixed = FALSE + prior$class, c("^cor$", "^rescor$", "^corme$", "^lncor"), + c("L", "Lrescor", "Lme", "Llncor"), fixed = FALSE ) if (any(duplicated(prior))) { stop2("Duplicated prior specifications are not allowed.") @@ -1183,7 +1199,7 @@ invalid <- !seq_rows(prior) %in% (valid_ids - nrow(all_priors)) if (any(invalid) && !allow_invalid_prior) { stop2( - "The following priors do not correspond ", + "The following priors do not correspond ", "to any model parameter: \n", collapse(.print_prior(prior[invalid, ]), "\n"), "Function 'get_prior' might be helpful to you." @@ -1192,11 +1208,43 @@ prior <- prior[!invalid, ] } prior$prior <- sub("^(lkj|lkj_corr)\\(", "lkj_corr_cholesky(", prior$prior) - check_prior_content(prior) + + # include default parameter bounds; only new priors need bounds + which_needs_lb <- which(is.na(prior$lb) & !nzchar(prior$coef)) + for (i in which_needs_lb) { + if (!is.na(prior$ub[i]) && nzchar(prior$ub[i])) { + # if ub is specified lb should be specified in the same line as well + prior$lb[i] <- stan_base_prior(all_priors, "lb", sel_prior = prior[i, ]) + } else { + # take the corresponding lb from the default prior + prior_sub_i <- rbind(prior[i, ], all_priors) + prior_sub_i <- prior_sub_i[duplicated(prior_sub_i), ] + stopifnot(NROW(prior_sub_i) == 1L) + prior$lb[i] <- prior_sub_i$lb + } + } + which_needs_ub <- which(is.na(prior$ub) & !nzchar(prior$coef)) + for (i in which_needs_ub) { + if (!is.na(prior$lb[i]) && nzchar(prior$lb[i])) { + # if lb is specified ub should be specified in the same line as well + prior$ub[i] <- stan_base_prior(all_priors, "ub", sel_prior = prior[i, ]) + } else { + # take the corresponding lb from the default prior + prior_sub_i <- rbind(prior[i, ], all_priors) + prior_sub_i <- prior_sub_i[duplicated(prior_sub_i), ] + stopifnot(NROW(prior_sub_i) == 1L) + prior$ub[i] <- prior_sub_i$ub + } + } + # the remaining NAs are in coef priors which cannot have bounds yet + prior$lb[is.na(prior$lb)] <- prior$ub[is.na(prior$ub)] <- "" + # merge user-specified priors with default priors prior$new <- rep(TRUE, nrow(prior)) all_priors$new <- rep(FALSE, nrow(all_priors)) prior <- c(all_priors, prior, replace = TRUE) + check_prior_content(prior) + # don't require priors on nlpars if some priors are not checked (#1124) require_nlpar_prior <- require_nlpar_prior && !any(no_checks) prior <- validate_prior_special( @@ -1204,7 +1252,7 @@ require_nlpar_prior = require_nlpar_prior, ... ) prior <- prior[with(prior, order(class, group, resp, dpar, nlpar, coef)), ] - # check and warn about valid but unused priors + # check and warn valid but unused priors for (i in which(nzchar(prior$prior) & !nzchar(prior$coef))) { ls <- prior[i, c("class", "group", "resp", "dpar", "nlpar")] class(ls) <- "data.frame" @@ -1212,8 +1260,8 @@ prior_sub_coef <- prior_sub_coef[nzchar(prior_sub_coef$coef), ] if (nrow(prior_sub_coef) && all(nzchar(prior_sub_coef$prior))) { warning2( - "The global prior '", prior$prior[i], "' of class '", prior$class[i], - "' will not be used in the model as all related coefficients have ", + "The global prior '", prior$prior[i], "' of class '", prior$class[i], + "' will not be used in the model as all related coefficients have ", "individual priors already. If you did not set those ", "priors yourself, then maybe brms has assigned default priors. ", "See ?set_prior and ?get_prior for more details." @@ -1229,7 +1277,7 @@ def_prior <- subset2(def_prior, source = "default") if (nrow(def_prior)) { message("The following priors were automatically added to the model:") - print(def_prior, show_df = TRUE) + print(def_prior, show_df = TRUE) } } prior @@ -1238,86 +1286,72 @@ # try to check if prior distributions are reasonable # @param prior A brmsprior object check_prior_content <- function(prior) { - if (!is.brmsprior(prior)) { + if (!is.brmsprior(prior) || !NROW(prior)) { return(invisible(TRUE)) } - if (nrow(prior)) { - lb_priors <- c( - "lognormal", "chi_square", "inv_chi_square", - "scaled_inv_chi_square", "exponential", "gamma", - "inv_gamma", "weibull", "frechet", "rayleigh", - "pareto", "pareto_type_2" - ) - lb_priors_reg <- paste0("^(", paste0(lb_priors, collapse = "|"), ")") - ulb_priors <- c("beta", "uniform", "von_mises") - ulb_priors_reg <- paste0("^(", paste0(ulb_priors, collapse = "|"), ")") - nb_pars <- c("b", "alpha", "xi") - lb_pars <- c( - "sigma", "shape", "nu", "phi", "kappa", "beta", "bs", - "disc", "sdcar", "sigmaLL", "sd", "sds", "sdgp", "lscale" - ) - cormat_pars <- c("cor", "rescor", "corme", "L", "Lrescor", "Lme") - lb_warning <- ub_warning <- "" - for (i in seq_rows(prior)) { - msg_prior <- .print_prior(prior[i, , drop = FALSE]) - has_lb_prior <- grepl(lb_priors_reg, prior$prior[i]) - has_ulb_prior <- grepl(ulb_priors_reg, prior$prior[i]) - # priors with nchar(coef) inherit their boundaries - j <- which(with(prior, - class == class[i] & group == group[i] & - nlpar == nlpar[i] & !nzchar(coef) - )) - bound <- if (length(j)) prior$bound[j] else "" - has_lb <- grepl("lower", bound) - has_ub <- grepl("upper", bound) - if (prior$class[i] %in% nb_pars) { - if ((has_lb_prior || has_ulb_prior) && !has_lb) { - lb_warning <- paste0(lb_warning, msg_prior, "\n") - } - if (has_ulb_prior && !has_ub) { - ub_warning <- paste0(ub_warning, msg_prior, "\n") - } - } else if (prior$class[i] %in% lb_pars) { - if (has_ulb_prior && !has_ub) { - ub_warning <- paste0(ub_warning, msg_prior, "\n") - } - } else if (prior$class[i] %in% cormat_pars) { - regex <- "^((lkj)|(constant))" - if (nzchar(prior$prior[i]) && !grepl(regex, prior$prior[i])) { - stop2( - "The only supported prior for correlation matrices is ", - "the 'lkj' prior. See help(set_prior) for more details." - ) - } - } else if (prior$class[i] %in% c("simo", "theta", "sbhaz")) { - regex <- "^((dirichlet)|(constant))\\(" - if (nchar(prior$prior[i]) && !grepl(regex, prior$prior[i])) { - stop2( - "Currently 'dirichlet' is the only valid prior for ", - "simplex parameters. See help(set_prior) for more details." - ) - } - } - } - if (nchar(lb_warning)) { - warning2( - "It appears as if you have specified a lower bounded ", - "prior on a parameter that has no natural lower bound.", - "\nIf this is really what you want, please specify ", - "argument 'lb' of 'set_prior' appropriately.", - "\nWarning occurred for prior \n", lb_warning + lb_priors <- c( + "lognormal", "chi_square", "inv_chi_square", "scaled_inv_chi_square", + "exponential", "gamma", "inv_gamma", "weibull", "frechet", "rayleigh", + "pareto", "pareto_type_2" + ) + lb_priors_regex <- paste0("^(", paste0(lb_priors, collapse = "|"), ")") + ulb_priors <- c("beta", "uniform", "von_mises", "beta_proportion") + ulb_priors_regex <- paste0("^(", paste0(ulb_priors, collapse = "|"), ")") + cormat_pars <- c("cor", "L", "rescor", "Lrescor", "corme", "Lme", "lncor", "Llncor") + cormat_regex <- "^((lkj)|(constant))" + simplex_pars <- c("simo", "theta", "sbhaz") + simplex_regex <- "^((dirichlet)|(constant))\\(" + + lb_warning <- ub_warning <- "" + for (i in seq_rows(prior)) { + if (!nzchar(prior$prior[i]) || !prior$new[i]) { + next + } + msg_prior <- .print_prior(prior[i, ]) + has_lb_prior <- grepl(lb_priors_regex, prior$prior[i]) + has_ulb_prior <- grepl(ulb_priors_regex, prior$prior[i]) + base_bounds <- stan_base_prior(prior, c("lb", "ub"), sel_prior = prior[i, ]) + has_lb <- nzchar(base_bounds[, "lb"]) + has_ub <- nzchar(base_bounds[, "ub"]) + if ((has_lb_prior || has_ulb_prior) && !has_lb) { + lb_warning <- paste0(lb_warning, msg_prior, "\n") + } + if (has_ulb_prior && !has_ub) { + ub_warning <- paste0(ub_warning, msg_prior, "\n") + } + if (prior$class[i] %in% cormat_pars && + !grepl(cormat_regex, prior$prior[i])) { + stop2( + "The only supported prior for correlation matrices is ", + "the 'lkj' prior. See help(set_prior) for more details." ) } - if (nchar(ub_warning)) { - warning2( - "It appears as if you have specified an upper bounded ", - "prior on a parameter that has no natural upper bound.", - "\nIf this is really what you want, please specify ", - "argument 'ub' of 'set_prior' appropriately.", - "\nWarning occurred for prior \n", ub_warning + if (prior$class[i] %in% simplex_pars && + !grepl(simplex_regex, prior$prior[i])) { + stop2( + "Currently 'dirichlet' is the only valid prior for ", + "simplex parameters. See help(set_prior) for more details." ) } } + if (nzchar(lb_warning)) { + warning2( + "It appears as if you have specified a lower bounded ", + "prior on a parameter that has no natural lower bound.", + "\nIf this is really what you want, please specify ", + "argument 'lb' of 'set_prior' appropriately.", + "\nWarning occurred for prior \n", lb_warning + ) + } + if (nzchar(ub_warning)) { + warning2( + "It appears as if you have specified an upper bounded ", + "prior on a parameter that has no natural upper bound.", + "\nIf this is really what you want, please specify ", + "argument 'ub' of 'set_prior' appropriately.", + "\nWarning occurred for prior \n", ub_warning + ) + } invisible(TRUE) } @@ -1335,7 +1369,7 @@ #' @export validate_prior_special.brmsprior <- function(x, bterms, ...) { if (!NROW(x)) { - return(x) + return(x) } if (is.null(x$new)) { x$new <- TRUE @@ -1356,10 +1390,10 @@ if (!any(nzchar(prior$prior[gi]))) { next } - # allowing global priors in multivariate models implies conceptual problems - # in the specification of default priors as it becomes unclear on which + # allowing global priors in multivariate models implies conceptual problems + # in the specification of default priors as it becomes unclear on which # prior level they should be defined - warning2("Specifying global priors for regression coefficients in ", + warning2("Specifying global priors for regression coefficients in ", "multivariate models is deprecated. Please specify priors ", "separately for each response variable.") for (r in x$responses) { @@ -1367,7 +1401,7 @@ for (ri in rows) { if (isTRUE(!prior$new[ri] || !nzchar(prior$prior[ri]))) { prior$prior[ri] <- prior$prior[gi] - } + } } } } @@ -1393,10 +1427,10 @@ if (!any(nzchar(prior$prior[gi]))) { next } - # allowing global priors in categorical models implies conceptual problems - # in the specification of default priors as it becomes unclear on which + # allowing global priors in categorical models implies conceptual problems + # in the specification of default priors as it becomes unclear on which # prior level they should be defined - warning2("Specifying global priors for regression coefficients in ", + warning2("Specifying global priors for regression coefficients in ", "categorical models is deprecated. Please specify priors ", "separately for each response category.") for (dp in names(x$dpars)) { @@ -1450,7 +1484,7 @@ if (!any(nzchar(nlp_prior$prior)) && require_nlpar_prior) { stop2( "Priors on population-level coefficients are required in ", - "non-linear models, but none were found for parameter ", + "non-linear models, but none were found for parameter ", "'", px$nlpar, "'. See help(set_prior) for more details." ) } @@ -1464,7 +1498,7 @@ if (any(is_special_prior(b_prior))) { # horseshoe prior for population-level parameters if (any(nzchar(prior[b_index, "bound"]))) { - stop2("Setting boundaries on coefficients is not ", + stop2("Setting boundaries on coefficients is not ", "allowed when using the special priors.") } if (is.formula(x[["cs"]])) { @@ -1477,27 +1511,24 @@ ) if (any(nchar(prior$prior[b_coef_indices]))) { stop2( - "Defining separate priors for single coefficients is not ", - "allowed when using special priors for the whole ", + "Defining separate priors for single coefficients is not ", + "allowed when using special priors for the whole ", "set of coefficients (except for the Intercept)." ) } if (is_special_prior(b_prior, "horseshoe")) { special$horseshoe <- attributes(eval2(b_prior)) - special$horseshoe$autoscale <- + special$horseshoe$autoscale <- isTRUE(special$horseshoe$autoscale) && allow_autoscale } else if (is_special_prior(b_prior, "R2D2")) { special$R2D2 <- attributes(eval2(b_prior)) - special$R2D2$autoscale <- + special$R2D2$autoscale <- isTRUE(special$R2D2$autoscale) && allow_autoscale } else if (is_special_prior(b_prior, "lasso")) { # the parameterization via double_exponential appears to be more - # efficient than an indirect parameterization via normal and + # efficient than an indirect parameterization via normal and # exponential distributions; tested on 2017-06-09 - p <- usc(combine_prefix(px)) - lasso_scale <- paste0("lasso_scale", p, " * lasso_inv_lambda", p) - lasso_prior <- paste0("double_exponential(0, ", lasso_scale, ")") - prior$prior[b_index] <- lasso_prior + # TODO: enable autoscaling for lasso as well? special$lasso <- attributes(eval2(b_prior)) } } @@ -1525,26 +1556,9 @@ validate_sample_prior(attr(prior, "sample_prior", TRUE)) } -# extract prior boundaries of a parameter -# @param prior a brmsprior object -# @param class,coef,group,px passed to 'subset2' -get_bound <- function(prior, class = "b", coef = "", - group = "", px = list()) { - stopifnot(is.brmsprior(prior)) - class <- as_one_character(class) - if (!length(coef)) coef <- "" - if (!length(group)) group <- "" - bound <- subset2(prior, ls = c(nlist(class, coef, group), px))$bound - if (!length(bound)) bound <- "" - if (length(bound) != 1L) { - stop("Extracting parameter boundaries failed. Please report a bug.") - } - bound -} - # create data.frames containing prior information -brmsprior <- function(prior = "", class = "", coef = "", group = "", - resp = "", dpar = "", nlpar = "", bound = "", +brmsprior <- function(prior = "", class = "", coef = "", group = "", + resp = "", dpar = "", nlpar = "", lb = "", ub = "", source = "", ls = list()) { if (length(ls)) { if (is.null(names(ls))) { @@ -1559,8 +1573,8 @@ } } out <- data.frame( - prior, class, coef, group, - resp, dpar, nlpar, bound, source, + prior, class, coef, group, + resp, dpar, nlpar, lb, ub, source, stringsAsFactors = FALSE ) class(out) <- c("brmsprior", "data.frame") @@ -1568,18 +1582,18 @@ } #' @describeIn set_prior Create an empty \code{brmsprior} object. -#' @export +#' @export empty_prior <- function() { char0 <- character(0) brmsprior( prior = char0, source = char0, class = char0, - coef = char0, group = char0, resp = char0, - dpar = char0, nlpar = char0, bound = char0 + coef = char0, group = char0, resp = char0, + dpar = char0, nlpar = char0, lb = char0, ub = char0 ) } # natural upper and lower bounds for priors -# @param a named list with elements 'lb and 'ub' +# @param a named list with elements 'lb' and 'ub' prior_bounds <- function(prior) { switch(prior, lognormal = list(lb = 0, ub = Inf), @@ -1602,8 +1616,8 @@ # all columns of brmsprior objects all_cols_prior <- function() { - c("prior", "class", "coef", "group", "resp", - "dpar", "nlpar", "bound", "source") + c("prior", "class", "coef", "group", "resp", + "dpar", "nlpar", "lb", "ub", "source") } # relevant columns for duplication checks in brmsprior objects @@ -1611,73 +1625,133 @@ c("class", "coef", "group", "resp", "dpar", "nlpar") } -# upper and lower bounds for parameter classes -# @param par name of a distributional parameter -# @param bound optional Stan code of boundaries to extract values from -# @param resp optional name of the response variable -# @return A named list with elements 'lb and 'ub' -par_bounds <- function(par, bound = "", resp = "") { - resp <- usc(resp) - out <- switch(par, - sigma = list(lb = 0, ub = Inf), - shape = list(lb = 0, ub = Inf), - nu = list(lb = 1, ub = Inf), - phi = list(lb = 0, ub = Inf), - kappa = list(lb = 0, ub = Inf), - beta = list(lb = 0, ub = Inf), - zi = list(lb = 0, ub = 1), - hu = list(lb = 0, ub = 1), - zoi = list(lb = 0, ub = 1), - coi = list(lb = 0, ub = 1), - bs = list(lb = 0, ub = Inf), - ndt = list(lb = 0, ub = glue("min_Y{resp}")), - bias = list(lb = 0, ub = 1), - disc = list(lb = 0, ub = Inf), - quantile = list(lb = 0, ub = 1), - ar = list(lb = -1, ub = 1), - ma = list(lb = -1, ub = 1), - lagsar = list(lb = 0, ub = 1), - errorsar = list(lb = 0, ub = 1), - car = list(lb = 0, ub = 1), - sdcar = list(lb = 0, ub = Inf), - rhocar = list(lb = 0, ub = 1), - sigmaLL = list(lb = 0, ub = Inf), - sd = list(lb = 0, ub = Inf), - sds = list(lb = 0, ub = Inf), - sdgp = list(lb = 0, ub = Inf), - lscale = list(lb = 0, ub = Inf), - list(lb = -Inf, ub = Inf) +# default Stan definitions for distributional parameters +# @param dpar name of a distributional parameter +# @param suffix optional suffix of the parameter name +# @param family optional brmsfamily object +# @return a named list with numeric elements 'lb' and 'ub' +dpar_bounds <- function(dpar, suffix = "", family = NULL) { + dpar <- as_one_character(dpar) + suffix <- usc(as_one_character(suffix)) + if (is.mixfamily(family)) { + if (dpar_class(dpar) == "theta") { + return(list(lb = -Inf, ub = Inf)) + } + family <- family$mix[[as.numeric(dpar_id(dpar))]] + } + dpar_class <- dpar_class(dpar, family) + if (is.customfamily(family)) { + lb <- family$lb[[dpar_class]] + ub <- family$ub[[dpar_class]] + return(nlist(lb, ub)) + } + min_Y <- glue("min_Y{suffix}") + out <- switch(dpar_class, + sigma = list(lb = "0", ub = ""), + shape = list(lb = "0", ub = ""), + nu = list(lb = "1", ub = ""), + phi = list(lb = "0", ub = ""), + kappa = list(lb = "0", ub = ""), + beta = list(lb = "0", ub = ""), + zi = list(lb = "0", ub = "1"), + hu = list(lb = "0", ub = "1"), + zoi = list(lb = "0", ub = "1"), + coi = list(lb = "0", ub = "1"), + bs = list(lb = "0", ub = ""), + ndt = list(lb = "0", ub = min_Y), + bias = list(lb = "0", ub = "1"), + disc = list(lb = "0", ub = ""), + quantile = list(lb = "0", ub = "1"), + xi = list(lb = "", ub = ""), + alpha = list(lb = "", ub = "") ) - if (isTRUE(nzchar(bound))) { - opt_lb <- get_matches("(<|,)lower=[^,>]+", bound) - if (isTRUE(nzchar(opt_lb))) { - out$lb <- substr(opt_lb, 8, nchar(opt_lb)) - } - opt_ub <- get_matches("(<|,)upper=[^,>]+", bound) - if (isTRUE(nzchar(opt_ub))) { - out$ub <- substr(opt_ub, 8, nchar(opt_ub)) - } + out +} + +# convert parameter bounds to Stan syntax +# vectorized over both 'lb' and 'ub' vectors +# @param bounds a named list with elements 'lb' and 'ub' +# @param default default output if no proper bounds are specified +convert_bounds2stan <- function(bounds, default = "") { + lb <- as.character(bounds$lb) + ub <- as.character(bounds$ub) + stopifnot(length(lb) == length(ub)) + default <- as_one_character(default, allow_na = TRUE) + if (any(lb %in% "Inf")) { + stop2("Lower boundaries cannot be positive infinite.") + } + if (any(ub %in% "-Inf")) { + stop2("Upper boundaries cannot be negative infinite.") + } + lb <- ifelse( + !is.na(lb) & !lb %in% c("NA", "-Inf", ""), + paste0("lower=", lb), "" + ) + ub <- ifelse( + !is.na(ub) & !ub %in% c("NA", "Inf", ""), + paste0("upper=", ub), "" + ) + out <- ifelse( + nzchar(lb) & nzchar(ub), glue("<{lb},{ub}>"), + ifelse( + nzchar(lb) & !nzchar(ub), glue("<{lb}>"), + ifelse( + !nzchar(lb) & nzchar(ub), glue("<{ub}>"), + default + ) + ) + ) + out +} + +# convert parameter bounds in Stan syntax +# TODO: vectorize over a character vector of bounds? +# complicated because of a mix of character and numeric values +# to a named list with elements 'lb' and 'ub' +convert_stan2bounds <- function(bound, default = c(-Inf, Inf)) { + bound <- as_one_character(bound) + stopifnot(length(default) == 2L) + out <- list(lb = default[[1]], ub = default[[2]]) + if (!is.na(bound) && isTRUE(nzchar(bound))) { + lb <- get_matches("(<|,)lower=[^,>]+", bound) + if (isTRUE(nzchar(lb))) { + lb <- substr(lb, 8, nchar(lb)) + lb_num <- SW(as.numeric(lb)) + if (!is.na(lb_num)) { + lb <- lb_num + } + out$lb <- lb + } + ub <- get_matches("(<|,)upper=[^,>]+", bound) + if (isTRUE(nzchar(ub))) { + ub <- substr(ub, 8, nchar(ub)) + ub_num <- SW(as.numeric(ub)) + if (!is.na(ub_num)) { + ub <- ub_num + } + out$ub <- ub + } } out } #' Checks if argument is a \code{brmsprior} object -#' +#' #' @param x An \R object -#' +#' #' @export is.brmsprior <- function(x) { inherits(x, "brmsprior") } #' Print method for \code{brmsprior} objects -#' +#' #' @param x An object of class \code{brmsprior}. -#' @param show_df Logical; Print priors as a single -#' \code{data.frame} (\code{TRUE}) or as a sequence of +#' @param show_df Logical; Print priors as a single +#' \code{data.frame} (\code{TRUE}) or as a sequence of #' sampling statements (\code{FALSE})? #' @param ... Currently ignored. -#' +#' #' @export print.brmsprior <- function(x, show_df = NULL, ...) { if (is.null(show_df)) { @@ -1697,15 +1771,10 @@ prepare_print_prior <- function(x) { stopifnot(is.brmsprior(x)) x$source[!nzchar(x$source)] <- "(unknown)" - # column names to vectorize over - cols <- c("group", "nlpar", "dpar", "resp", "class") - empty_strings <- rep("", 4) + # vectorize priors and bounds for pretty printing + # TODO: improve efficiency of adding vectorization tags for (i in which(!nzchar(x$prior))) { - ls <- x[i, cols] - ls <- rbind(ls, c(empty_strings, ls$class)) - ls <- as.list(ls) - sub_prior <- subset2(x, ls = ls) - base_prior <- stan_base_prior(sub_prior) + base_prior <- stan_base_prior(x, sel_prior = x[i, ]) if (nzchar(base_prior)) { x$prior[i] <- base_prior x$source[i] <- "(vectorized)" @@ -1713,6 +1782,11 @@ x$prior[i] <- "(flat)" } } + for (i in which(!nzchar(x$lb) & !nzchar(x$ub))) { + base_bounds <- stan_base_prior(x, c("lb", "ub"), sel_prior = x[i, ]) + x$lb[i] <- base_bounds[, "lb"] + x$ub[i] <- base_bounds[, "ub"] + } x } @@ -1726,7 +1800,8 @@ if (any(nzchar(c(resp, dpar, nlpar, coef)))) { group <- usc(group, "suffix") } - bound <- ifelse(nzchar(x$bound), paste0(x$bound, " "), "") + bound <- convert_bounds2stan(x[c("lb", "ub")]) + bound <- ifelse(nzchar(bound), paste0(bound, " "), "") tilde <- ifelse(nzchar(x$class) | nzchar(group) | nzchar(coef), " ~ ", "") prior <- ifelse(nzchar(x$prior), x$prior, "(flat)") paste0(bound, x$class, group, resp, dpar, nlpar, coef, tilde, prior) @@ -1739,10 +1814,10 @@ if (all(sapply(dots, is.brmsprior))) { replace <- as_one_logical(replace) # don't use 'c()' here to avoid creating a recursion - out <- do_call(rbind, list(x, ...)) + out <- do_call(rbind, list(x, ...)) if (replace) { # update duplicated priors - out <- unique(out, fromLast = TRUE) + out <- unique(out, fromLast = TRUE) } } else { if (length(dots)) { @@ -1780,7 +1855,7 @@ dirichlet <- function(...) { out <- try(as.numeric(c(...))) if (is(out, "try-error")) { - stop2("Something went wrong. Did you forget to store ", + stop2("Something went wrong. Did you forget to store ", "auxiliary data in the 'data2' argument?") } if (anyNA(out) || any(out <= 0)) { @@ -1789,10 +1864,10 @@ if (!is.null(len)) { if (length(out) == 1L) { out <- rep(out, len) - } + } if (length(out) != len) { stop2("Invalid Dirichlet prior. Expected input of length ", len, ".") - } + } } return(out) } @@ -1804,101 +1879,101 @@ } #' Regularized horseshoe priors in \pkg{brms} -#' +#' #' Function used to set up regularized horseshoe priors and related #' hierarchical shrinkage priors for population-level effects in \pkg{brms}. The #' function does not evaluate its arguments -- it exists purely to help set up #' the model. -#' -#' @param df Degrees of freedom of student-t prior of the +#' +#' @param df Degrees of freedom of student-t prior of the #' local shrinkage parameters. Defaults to \code{1}. -#' @param scale_global Scale of the student-t prior of the global shrinkage -#' parameter. Defaults to \code{1}. -#' In linear models, \code{scale_global} will internally be +#' @param scale_global Scale of the student-t prior of the global shrinkage +#' parameter. Defaults to \code{1}. +#' In linear models, \code{scale_global} will internally be #' multiplied by the residual standard deviation parameter \code{sigma}. -#' @param df_global Degrees of freedom of student-t prior of the +#' @param df_global Degrees of freedom of student-t prior of the #' global shrinkage parameter. Defaults to \code{1}. If \code{df_global} #' is greater \code{1}, the shape of the prior will no longer resemble #' a horseshoe and it may be more appropriately called an hierarchical #' shrinkage prior in this case. #' @param scale_slab Scale of the student-t prior of the regularization -#' parameter. Defaults to \code{2}. The original unregularized horseshoe +#' parameter. Defaults to \code{2}. The original unregularized horseshoe #' prior is obtained by setting \code{scale_slab} to infinite, which -#' we can approximate in practice by setting it to a very large real value. -#' @param df_slab Degrees of freedom of the student-t prior of -#' the regularization parameter. Defaults to \code{4}. -#' @param par_ratio Ratio of the expected number of non-zero coefficients +#' we can approximate in practice by setting it to a very large real value. +#' @param df_slab Degrees of freedom of the student-t prior of +#' the regularization parameter. Defaults to \code{4}. +#' @param par_ratio Ratio of the expected number of non-zero coefficients #' to the expected number of zero coefficients. If specified, #' \code{scale_global} is ignored and internally computed as -#' \code{par_ratio / sqrt(N)}, where \code{N} is the total number +#' \code{par_ratio / sqrt(N)}, where \code{N} is the total number #' of observations in the data. #' @param autoscale Logical; indicating whether the horseshoe #' prior should be scaled using the residual standard deviation #' \code{sigma} if possible and sensible (defaults to \code{TRUE}). -#' Autoscaling is not applied for distributional parameters or +#' Autoscaling is not applied for distributional parameters or #' when the model does not contain the parameter \code{sigma}. -#' +#' #' @return A character string obtained by \code{match.call()} with #' additional arguments. -#' -#' @details +#' +#' @details #' The horseshoe prior is a special shrinkage prior initially proposed by #' Carvalho et al. (2009). #' It is symmetric around zero with fat tails and an infinitely large spike -#' at zero. This makes it ideal for sparse models that have -#' many regression coefficients, although only a minority of them is non-zero. -#' The horseshoe prior can be applied on all population-level effects at once +#' at zero. This makes it ideal for sparse models that have +#' many regression coefficients, although only a minority of them is non-zero. +#' The horseshoe prior can be applied on all population-level effects at once #' (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. -#' The \code{1} implies that the student-t prior of the local shrinkage -#' parameters has 1 degrees of freedom. This may, however, lead to an +#' The \code{1} implies that the student-t prior of the local shrinkage +#' parameters has 1 degrees of freedom. This may, however, lead to an #' increased number of divergent transition in \pkg{Stan}. -#' Accordingly, increasing the degrees of freedom to slightly higher values -#' (e.g., \code{3}) may often be a better option, although the prior -#' no longer resembles a horseshoe in this case. +#' Accordingly, increasing the degrees of freedom to slightly higher values +#' (e.g., \code{3}) may often be a better option, although the prior +#' no longer resembles a horseshoe in this case. #' Further, the scale of the global shrinkage parameter plays an important role #' in amount of shrinkage applied. It defaults to \code{1}, #' but this may result in too few shrinkage (Piironen & Vehtari, 2016). #' It is thus possible to change the scale using argument \code{scale_global} #' of the horseshoe prior, for instance \code{horseshoe(1, scale_global = 0.5)}. -#' In linear models, \code{scale_global} will internally be multiplied by the -#' residual standard deviation parameter \code{sigma}. See Piironen and +#' In linear models, \code{scale_global} will internally be multiplied by the +#' residual standard deviation parameter \code{sigma}. See Piironen and #' Vehtari (2016) for recommendations how to properly set the global scale. -#' The degrees of freedom of the global shrinkage prior may also be -#' adjusted via argument \code{df_global}. -#' Piironen and Vehtari (2017) recommend to specifying the ratio of the -#' expected number of non-zero coefficients to the expected number of zero +#' The degrees of freedom of the global shrinkage prior may also be +#' adjusted via argument \code{df_global}. +#' Piironen and Vehtari (2017) recommend to specifying the ratio of the +#' expected number of non-zero coefficients to the expected number of zero #' coefficients \code{par_ratio} rather than \code{scale_global} directly. -#' As proposed by Piironen and Vehtari (2017), an additional regularization +#' As proposed by Piironen and Vehtari (2017), an additional regularization #' is applied that only affects non-zero coefficients. The amount of #' regularization can be controlled via \code{scale_slab} and \code{df_slab}. -#' To make sure that shrinkage can equally affect all coefficients, -#' predictors should be one the same scale. +#' To make sure that shrinkage can equally affect all coefficients, +#' predictors should be one the same scale. #' Generally, models with horseshoe priors a more likely than other models -#' to have divergent transitions so that increasing \code{adapt_delta} +#' to have divergent transitions so that increasing \code{adapt_delta} #' from \code{0.8} to values closer to \code{1} will often be necessary. #' See the documentation of \code{\link{brm}} for instructions -#' on how to increase \code{adapt_delta}. -#' -#' @references -#' Carvalho, C. M., Polson, N. G., & Scott, J. G. (2009). -#' Handling sparsity via the horseshoe. +#' on how to increase \code{adapt_delta}. +#' +#' @references +#' Carvalho, C. M., Polson, N. G., & Scott, J. G. (2009). +#' Handling sparsity via the horseshoe. #' In International Conference on Artificial Intelligence and Statistics (pp. 73-80). -#' -#' Piironen J. & Vehtari A. (2016). On the Hyperprior Choice for the Global -#' Shrinkage Parameter in the Horseshoe Prior. +#' +#' Piironen J. & Vehtari A. (2016). On the Hyperprior Choice for the Global +#' Shrinkage Parameter in the Horseshoe Prior. #' \url{https://arxiv.org/pdf/1610.05559v1.pdf} -#' +#' #' Piironen, J., and Vehtari, A. (2017). Sparsity information and regularization -#' in the horseshoe and other shrinkage priors. -#' \url{https://arxiv.org/abs/1707.01694} -#' +#' in the horseshoe and other shrinkage priors. +#' \url{https://arxiv.org/abs/1707.01694} +#' #' @seealso \code{\link{set_prior}} -#' -#' @examples +#' +#' @examples #' set_prior(horseshoe(df = 3, par_ratio = 0.1)) -#' +#' #' @export -horseshoe <- function(df = 1, scale_global = 1, df_global = 1, +horseshoe <- function(df = 1, scale_global = 1, df_global = 1, scale_slab = 2, df_slab = 4, par_ratio = NULL, autoscale = TRUE) { out <- deparse(match.call(), width.cutoff = 500L) @@ -1908,23 +1983,23 @@ scale_global <- as.numeric(scale_global) scale_slab <- as.numeric(scale_slab) if (!isTRUE(df > 0)) { - stop2("Invalid horseshoe prior: Degrees of freedom of ", + stop2("Invalid horseshoe prior: Degrees of freedom of ", "the local priors must be a single positive number.") } if (!isTRUE(df_global > 0)) { - stop2("Invalid horseshoe prior: Degrees of freedom of ", + stop2("Invalid horseshoe prior: Degrees of freedom of ", "the global prior must be a single positive number.") } if (!isTRUE(scale_global > 0)) { - stop2("Invalid horseshoe prior: Scale of the global ", + stop2("Invalid horseshoe prior: Scale of the global ", "prior must be a single positive number.") } if (!isTRUE(df_slab > 0)) { - stop2("Invalid horseshoe prior: Degrees of freedom of ", + stop2("Invalid horseshoe prior: Degrees of freedom of ", "the slab part must be a single positive number.") } if (!isTRUE(scale_slab > 0)) { - stop2("Invalid horseshoe prior: Scale of the slab ", + stop2("Invalid horseshoe prior: Scale of the slab ", "part must be a single positive number.") } if (!is.null(par_ratio)) { @@ -1935,7 +2010,7 @@ } autoscale <- as_one_logical(autoscale) att <- nlist( - df, df_global, df_slab, scale_global, + df, df_global, df_slab, scale_global, scale_slab, par_ratio, autoscale ) attributes(out)[names(att)] <- att @@ -1943,11 +2018,11 @@ } #' R2-D2 Priors in \pkg{brms} -#' +#' #' Function used to set up R2D2 priors for population-level effects in #' \pkg{brms}. The function does not evaluate its arguments -- it exists purely #' to help set up the model. -#' +#' #' @param mean_R2 mean of the Beta prior on the coefficient of determination R^2. #' @param prec_R2 precision of the Beta prior on the coefficient of determination R^2. #' @param cons_D2 concentration vector of the Dirichlet prior on the variance @@ -1955,20 +2030,20 @@ #' @param autoscale Logical; indicating whether the horseshoe #' prior should be scaled using the residual standard deviation #' \code{sigma} if possible and sensible (defaults to \code{TRUE}). -#' Autoscaling is not applied for distributional parameters or +#' Autoscaling is not applied for distributional parameters or #' when the model does not contain the parameter \code{sigma}. -#' +#' #' @references -#' Zhang, Y. D., Naughton, B. P., Bondell, H. D., & Reich, B. J. (2020). -#' Bayesian regression using a prior on the model fit: The R2-D2 shrinkage +#' Zhang, Y. D., Naughton, B. P., Bondell, H. D., & Reich, B. J. (2020). +#' Bayesian regression using a prior on the model fit: The R2-D2 shrinkage #' prior. Journal of the American Statistical Association. #' \url{https://arxiv.org/pdf/1609.00046.pdf} -#' +#' #' @seealso \code{\link{set_prior}} -#' -#' @examples +#' +#' @examples #' set_prior(R2D2(mean_R2 = 0.8, prec_R2 = 10)) -#' +#' #' @export R2D2 <- function(mean_R2 = 0.5, prec_R2 = 2, cons_D2 = 1, autoscale = TRUE) { out <- deparse(match.call(), width.cutoff = 500L) @@ -1994,23 +2069,23 @@ } #' Set up a lasso prior in \pkg{brms} -#' -#' Function used to set up a lasso prior for population-level effects +#' +#' Function used to set up a lasso prior for population-level effects #' in \pkg{brms}. The function does not evaluate its arguments -- #' it exists purely to help set up the model. -#' +#' #' @param df Degrees of freedom of the chi-square prior of the inverse tuning #' parameter. Defaults to \code{1}. #' @param scale Scale of the lasso prior. Defaults to \code{1}. -#' +#' #' @return A character string obtained by \code{match.call()} with #' additional arguments. -#' -#' @details +#' +#' @details #' The lasso prior is the Bayesian equivalent to the LASSO method for performing #' variable selection (Park & Casella, 2008). -#' With this prior, independent Laplace (i.e. double exponential) priors -#' are placed on the population-level effects. +#' With this prior, independent Laplace (i.e. double exponential) priors +#' are placed on the population-level effects. #' The scale of the Laplace priors depends on a tuning parameter #' that controls the amount of shrinkage. In \pkg{brms}, the inverse #' of the tuning parameter is used so that smaller values imply @@ -2018,32 +2093,32 @@ #' and with degrees of freedom controlled via argument \code{df} #' of function \code{lasso} (defaults to \code{1}). For instance, #' one can specify a lasso prior using \code{set_prior("lasso(1)")}. -#' To make sure that shrinkage can equally affect all coefficients, +#' To make sure that shrinkage can equally affect all coefficients, #' predictors should be one the same scale. #' If you do not want to standardized all variables, #' you can adjust the general scale of the lasso prior via argument #' \code{scale}, for instance, \code{lasso(1, scale = 10)}. -#' +#' #' @references -#' Park, T., & Casella, G. (2008). The Bayesian Lasso. Journal of the American +#' Park, T., & Casella, G. (2008). The Bayesian Lasso. Journal of the American #' Statistical Association, 103(482), 681-686. -#' +#' #' @seealso \code{\link{set_prior}} -#' -#' @examples +#' +#' @examples #' set_prior(lasso(df = 1, scale = 10)) -#' +#' #' @export lasso <- function(df = 1, scale = 1) { out <- deparse(match.call(), width.cutoff = 500L) df <- as.numeric(df) scale <- as.numeric(scale) if (!isTRUE(df > 0)) { - stop2("Invalid lasso prior: Degrees of freedom of the shrinkage ", + stop2("Invalid lasso prior: Degrees of freedom of the shrinkage ", "parameter prior must be a single positive number.") } if (!isTRUE(scale > 0)) { - stop2("Invalid lasso prior: Scale of the Laplace ", + stop2("Invalid lasso prior: Scale of the Laplace ", "priors must be a single positive number.") } att <- nlist(df, scale) @@ -2051,7 +2126,7 @@ out } -# check for the usage of special priors +# check for the usage of special priors # @param prior a character vector of priors # @param target optional special priors to search for # if NULL search for all special priors @@ -2059,7 +2134,7 @@ is_special_prior <- function(prior, target = NULL) { stopifnot(is.character(prior)) if (is.null(target)) { - target <- c("horseshoe", "R2D2", "lasso") + target <- c("horseshoe", "R2D2", "lasso") } regex <- paste0("^", regex_or(target), "\\(") grepl(regex, prior) diff -Nru r-cran-brms-2.16.3/R/projpred.R r-cran-brms-2.17.0/R/projpred.R --- r-cran-brms-2.16.3/R/projpred.R 2021-11-04 16:37:08.000000000 +0000 +++ r-cran-brms-2.17.0/R/projpred.R 2022-04-03 19:33:18.000000000 +0000 @@ -1,5 +1,5 @@ #' Projection Predictive Variable Selection: Get Reference Model -#' +#' #' The \code{get_refmodel.brmsfit} method can be used to create the reference #' model structure which is needed by the \pkg{projpred} package for performing #' a projection predictive variable selection. This method is called @@ -7,53 +7,65 @@ #' \code{\link[projpred:varsel]{varsel}} or #' \code{\link[projpred:cv_varsel]{cv_varsel}}, so you will rarely need to call #' it manually yourself. -#' +#' #' @inheritParams posterior_predict.brmsfit #' @param cvfun Optional cross-validation function -#' (see \code{\link[projpred:get-refmodel]{get_refmodel}} for details). +#' (see \code{\link[projpred:get_refmodel]{get_refmodel}} for details). #' If \code{NULL} (the default), \code{cvfun} is defined internally #' based on \code{\link{kfold.brmsfit}}. -#' @param ... Further arguments passed to -#' \code{\link[projpred:get-refmodel]{init_refmodel}}. -#' +#' @param brms_seed A seed used to infer seeds for \code{\link{kfold.brmsfit}} +#' and for sampling group-level effects for new levels (in multilevel models). +#' @param ... Further arguments passed to +#' \code{\link[projpred:init_refmodel]{init_refmodel}}. +#' #' @details Note that the \code{extract_model_data} function used internally by #' \code{get_refmodel.brmsfit} ignores arguments \code{wrhs}, \code{orhs}, and #' \code{extract_y}. This is relevant for #' \code{\link[projpred:predict.refmodel]{predict.refmodel}}, for example. -#' +#' #' @return A \code{refmodel} object to be used in conjunction with the #' \pkg{projpred} package. -#' -#' @examples +#' +#' @examples #' \dontrun{ #' # fit a simple model #' fit <- brm(count ~ zAge + zBase * Trt, #' data = epilepsy, family = poisson()) #' summary(fit) -#' +#' #' # The following code requires the 'projpred' package to be installed: #' library(projpred) -#' +#' #' # perform variable selection without cross-validation #' vs <- varsel(fit) #' summary(vs) #' plot(vs) -#' +#' #' # perform variable selection with cross-validation #' cv_vs <- cv_varsel(fit) #' summary(cv_vs) #' plot(cv_vs) #' } -get_refmodel.brmsfit <- function(object, newdata = NULL, resp = NULL, - cvfun = NULL, ...) { +get_refmodel.brmsfit <- function(object, newdata = NULL, resp = NULL, + cvfun = NULL, brms_seed = NULL, ...) { require_package("projpred") - dots <- list(...) resp <- validate_resp(resp, object, multiple = FALSE) formula <- formula(object) if (!is.null(resp)) { formula <- formula$forms[[resp]] } - + + # Infer "sub-seeds": + if (exists(".Random.seed", envir = .GlobalEnv)) { + rng_state_old <- get(".Random.seed", envir = .GlobalEnv) + on.exit(assign(".Random.seed", rng_state_old, envir = .GlobalEnv)) + } + if (!is.null(brms_seed)) { + set.seed(brms_seed) + } + kfold_seed <- sample.int(.Machine$integer.max, 1) + refprd_seed <- sample.int(.Machine$integer.max, 1) + # prepare the family object for use in projpred family <- family(object, resp = resp) if (family$family == "bernoulli") { @@ -64,16 +76,11 @@ # For the augmented-data approach, do not re-define ordinal or categorical # families to preserve their family-specific extra arguments ("extra" meaning # "additionally to `link`") like `refcat` and `thresholds` (see ?brmsfamily): - if (!(isTRUE(dots$aug_data) && is_polytomous(family))) { + aug_data <- is_categorical(family) || is_ordinal(family) + if (!aug_data) { family <- get(family$family, mode = "function")(link = family$link) - } else { - # TODO: uncomment the lines below as soon as the - # `extend_family_` exist (in brms): - # family <- get(paste0("extend_family_", family$family, mode = "function"))( - # family - # ) } - + # check if the model is supported by projpred bterms <- brmsterms(formula) if (length(bterms$dpars) > 1L && !conv_cats_dpars(family$family)) { @@ -86,12 +93,12 @@ if (any(not_ok_term_types %in% names(bterms$dpars$mu))) { stop2("Projpred only supports standard multilevel terms and offsets.") } - + # only use the raw formula for selection of terms formula <- formula$formula # LHS should only contain the response variable formula[[2]] <- bterms$respform[[2]] - + # projpred requires the dispersion parameter if present dis <- NULL if (family$family == "gaussian") { @@ -101,102 +108,145 @@ dis <- paste0("shape", usc(resp)) dis <- as.data.frame(object, variable = dis)[[dis]] } - - # prepare data passed to projpred - data <- current_data(object, newdata, resp = resp, check_response = TRUE) - attr(data, "terms") <- NULL - + # allows to handle additional arguments implicitly extract_model_data <- function(object, newdata = NULL, ...) { .extract_model_data(object, newdata = newdata, resp = resp, ...) } - - # Using the default prediction function from projpred is usually fine - ref_predfun <- NULL - if (isTRUE(dots$aug_data) && is_ordinal(family$family)) { - stop2("This case is not yet supported.") - # Use argument `incl_thres` of posterior_linpred() (and convert the - # 3-dimensional array to an "augmented-rows" matrix) - # TODO: uncomment the lines below as soon as arr2augmat() is exported - # ref_predfun <- function(fit, newdata = NULL) { - # # Note: `transform = FALSE` is not needed, but included here for - # # consistency with projpred's default ref_predfun(): - # linpred_out <- posterior_linpred( - # fit, transform = FALSE, newdata = newdata, incl_thres = TRUE - # ) - # stopifnot(length(dim(linpred_out)) == 3L) - # # Since posterior_linpred() is supposed to include the offsets in its - # # result, subtract them here: - # # Observation weights are not needed here, so use `wrhs = NULL` to avoid - # # potential conflicts for a non-`NULL` default `wrhs`: - # offs <- extract_model_data(fit, newdata = newdata, wrhs = NULL)$offset - # if (length(offs)) { - # stopifnot(length(offs) %in% c(1L, dim(linpred_out)[2])) - # linpred_out <- sweep(linpred_out, 2, offs) - # } - # linpred_out <- projpred:::arr2augmat(linpred_out, margin_draws = 1) - # return(linpred_out) - # } + + # The default `ref_predfun` from projpred does not set `allow_new_levels`, so + # use a customized `ref_predfun` which also handles some preparations for the + # augmented-data projection: + ref_predfun <- function(fit, newdata = NULL) { + # Setting a seed is necessary for reproducible sampling of group-level + # effects for new levels: + if (exists(".Random.seed", envir = .GlobalEnv)) { + rng_state_old <- get(".Random.seed", envir = .GlobalEnv) + on.exit(assign(".Random.seed", rng_state_old, envir = .GlobalEnv)) + } + set.seed(refprd_seed) + lprd_args <- nlist( + object = fit, newdata, resp, allow_new_levels = TRUE, + sample_new_levels = "gaussian" + ) + if (is_ordinal(family)) { + c(lprd_args) <- list(incl_thres = TRUE) + } + out <- do_call(posterior_linpred, lprd_args) + if (length(dim(out)) == 2) { + out <- t(out) + } + out + } + + if (utils::packageVersion("projpred") <= "2.0.2" && NROW(object$ranef)) { + warning2("Under projpred version <= 2.0.2, projpred's K-fold CV results ", + "may not be reproducible for multilevel brms reference models.") } - + # extract a list of K-fold sub-models if (is.null(cvfun)) { cvfun <- function(folds, ...) { - cvres <- kfold( - object, K = max(folds), - save_fits = TRUE, folds = folds, - ... - ) - fits <- cvres$fits[, "fit"] - return(fits) + kfold( + object, K = max(folds), save_fits = TRUE, folds = folds, + seed = kfold_seed, ... + )$fits[, "fit"] } } else { if (!is.function(cvfun)) { stop2("'cvfun' should be a function.") } } - + + cvrefbuilder <- function(cvfit) { + # For `brms_seed` in fold `cvfit$projpred_k` (= k) of K, choose a new seed + # which is based on the original `brms_seed`: + if (is.null(brms_seed)) { + brms_seed_k <- NULL + } else { + brms_seed_k <- brms_seed + cvfit$projpred_k + } + projpred::get_refmodel(cvfit, resp = resp, brms_seed = brms_seed_k, ...) + } + + # prepare data passed to projpred + data <- current_data( + object, newdata, resp = resp, check_response = TRUE, + allow_new_levels = TRUE + ) + attr(data, "terms") <- NULL args <- nlist( - object, data, formula, family, dis, ref_predfun = ref_predfun, - cvfun = cvfun, extract_model_data = extract_model_data, ... + object, data, formula, family, dis, ref_predfun, + cvfun, extract_model_data, cvrefbuilder, ... ) + if (aug_data) { + c(args) <- list( + augdat_link = get(paste0("link_", family$family), mode = "function"), + augdat_ilink = get(paste0("inv_link_", family$family), mode = "function") + ) + if (is_ordinal(family)) { + c(args) <- list( + augdat_args_link = list(link = family$link), + augdat_args_ilink = list(link = family$link) + ) + } + } do_call(projpred::init_refmodel, args) } # auxiliary data required in predictions via projpred -# @return a named list with slots 'weights' and 'offset' +# @return a named list with slots 'y', 'weights', and 'offset' .extract_model_data <- function(object, newdata = NULL, resp = NULL, ...) { stopifnot(is.brmsfit(object)) resp <- validate_resp(resp, object, multiple = FALSE) - family <- family(object, resp = resp) - + + # extract the response variable manually instead of from make_standata + # so that it passes input checks of validate_newdata later on (#1314) + formula <- formula(object) + if (!is.null(resp)) { + formula <- formula$forms[[resp]] + } + respform <- brmsterms(formula)$respform + data <- current_data( + object, newdata, resp = resp, check_response = TRUE, + allow_new_levels = TRUE + ) + y <- unname(model.response(model.frame(respform, data, na.action = na.pass))) + aug_data <- is_categorical(formula) || is_ordinal(formula) + if (aug_data) { + y_lvls <- levels(as.factor(y)) + if (!is_equal(y_lvls, get_cats(formula))) { + stop2("The augmented data approach requires all response categories to ", + "be present in the data passed to projpred.") + } + } + + # extract relevant auxiliary data # call standata to ensure the correct format of the data args <- nlist( object, newdata, resp, - check_response = TRUE, + allow_new_levels = TRUE, + check_response = TRUE, internal = TRUE ) sdata <- do_call(standata, args) - - # extract relevant auxiliary data + usc_resp <- usc(resp) - y <- as.vector(sdata[[paste0("Y", usc_resp)]]) - offset <- as.vector(sdata[[paste0("offsets", usc_resp)]]) weights <- as.vector(sdata[[paste0("weights", usc_resp)]]) trials <- as.vector(sdata[[paste0("trials", usc_resp)]]) - stopifnot(!is.null(y)) - if (is_binary(family)) { + if (is_binary(formula)) { trials <- rep(1, length(y)) } if (!is.null(trials)) { if (!is.null(weights)) { - stop2("Projpred cannot handle 'trials' and 'weights' at the same time.") + stop2("Projpred cannot handle 'trials' and 'weights' at the same time.") } weights <- trials } if (is.null(weights)) { weights <- rep(1, length(y)) } + offset <- as.vector(sdata[[paste0("offsets", usc_resp)]]) if (is.null(offset)) { offset <- rep(0, length(y)) } diff -Nru r-cran-brms-2.16.3/R/reloo.R r-cran-brms-2.17.0/R/reloo.R --- r-cran-brms-2.16.3/R/reloo.R 2021-10-29 06:42:16.000000000 +0000 +++ r-cran-brms-2.17.0/R/reloo.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,43 +1,46 @@ #' Compute exact cross-validation for problematic observations -#' +#' #' Compute exact cross-validation for problematic observations for which #' approximate leave-one-out cross-validation may return incorrect results. #' Models for problematic observations can be run in parallel using the #' \pkg{future} package. -#' +#' #' @inheritParams predict.brmsfit #' @param x An \R object of class \code{brmsfit} or \code{loo} depending #' on the method. #' @param loo An \R object of class \code{loo}. #' @param fit An \R object of class \code{brmsfit}. -#' @param k_threshold The threshold at which Pareto \eqn{k} -#' estimates are treated as problematic. Defaults to \code{0.7}. +#' @param k_threshold The threshold at which Pareto \eqn{k} +#' estimates are treated as problematic. Defaults to \code{0.7}. #' See \code{\link[loo:pareto-k-diagnostic]{pareto_k_ids}} #' for more details. #' @param check Logical; If \code{TRUE} (the default), some checks #' check are performed if the \code{loo} object was generated #' from the \code{brmsfit} object passed to argument \code{fit}. -#' @param ... Further arguments passed to +#' @param future_args A list of further arguments passed to +#' \code{\link[future:future]{future}} for additional control over parallel +#' execution if activated. +#' @param ... Further arguments passed to #' \code{\link{update.brmsfit}} and \code{\link{log_lik.brmsfit}}. -#' +#' #' @return An object of the class \code{loo}. -#' -#' @details +#' +#' @details #' Warnings about Pareto \eqn{k} estimates indicate observations #' for which the approximation to LOO is problematic (this is described in -#' detail in Vehtari, Gelman, and Gabry (2017) and the +#' detail in Vehtari, Gelman, and Gabry (2017) and the #' \pkg{\link[loo:loo-package]{loo}} package documentation). #' If there are \eqn{J} observations with \eqn{k} estimates above -#' \code{k_threshold}, then \code{reloo} will refit the original model -#' \eqn{J} times, each time leaving out one of the \eqn{J} +#' \code{k_threshold}, then \code{reloo} will refit the original model +#' \eqn{J} times, each time leaving out one of the \eqn{J} #' problematic observations. The pointwise contributions of these observations #' to the total ELPD are then computed directly and substituted for the #' previous estimates from these \eqn{J} observations that are stored in the #' original \code{loo} object. -#' +#' #' @seealso \code{\link{loo}}, \code{\link{kfold}} -#' -#' @examples +#' +#' @examples #' \dontrun{ #' fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), #' data = epilepsy, family = poisson()) @@ -45,17 +48,18 @@ #' (loo1 <- loo(fit1)) #' (reloo1 <- reloo(fit1, loo = loo1, chains = 1)) #' } -#' +#' #' @export -reloo.brmsfit <- function(x, loo, k_threshold = 0.7, newdata = NULL, - resp = NULL, check = TRUE, ...) { - stopifnot(is.loo(loo), is.brmsfit(x)) +reloo.brmsfit <- function(x, loo, k_threshold = 0.7, newdata = NULL, + resp = NULL, check = TRUE, future_args = list(), + ...) { + stopifnot(is.loo(loo), is.brmsfit(x), is.list(future_args)) if (is.brmsfit_multiple(x)) { warn_brmsfit_multiple(x) class(x) <- "brmsfit" } if (is.null(newdata)) { - mf <- model.frame(x) + mf <- model.frame(x) } else { mf <- as.data.frame(newdata) } @@ -86,7 +90,7 @@ ) return(loo) } - + # split dots for use in log_lik and update dots <- list(...) ll_arg_names <- arg_names("log_lik") @@ -99,7 +103,7 @@ up_arg_names <- setdiff(names(dots), setdiff(ll_arg_names, "cores")) up_args <- dots[up_arg_names] up_args$refresh <- 0 - + .reloo <- function(j) { omitted <- obs[j] mf_omitted <- mf[-omitted, , drop = FALSE] @@ -113,21 +117,22 @@ ll_args$newdata2 <- subset_data2(x$data2, omitted) return(do_call(log_lik, ll_args)) } - + lls <- futures <- vector("list", J) message( - J, " problematic observation(s) found.", + J, " problematic observation(s) found.", "\nThe model will be refit ", J, " times." ) x <- recompile_model(x) + future_args$FUN <- .reloo + future_args$seed <- TRUE for (j in seq_len(J)) { message( "\nFitting model ", j, " out of ", J, " (leaving out observation ", obs[j], ")" ) - futures[[j]] <- future::future( - .reloo(j), packages = "brms", seed = TRUE - ) + future_args$args <- list(j) + futures[[j]] <- do_call("futureCall", future_args, pkg = "future") } for (j in seq_len(J)) { lls[[j]] <- future::value(futures[[j]]) diff -Nru r-cran-brms-2.16.3/R/rename_pars.R r-cran-brms-2.17.0/R/rename_pars.R --- r-cran-brms-2.16.3/R/rename_pars.R 2021-09-10 12:23:54.000000000 +0000 +++ r-cran-brms-2.17.0/R/rename_pars.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,31 +1,31 @@ #' Rename Parameters -#' +#' #' Rename parameters within the \code{stanfit} object after model fitting to #' ensure reasonable parameter names. This function is usually called #' automatically by \code{\link{brm}} and users will rarely be required to call #' it themselves. -#' +#' #' @param x A brmsfit object. #' @return A brmfit object with adjusted parameter names. -#' +#' #' @examples #' \dontrun{ #' # fit a model manually via rstan #' scode <- make_stancode(count ~ Trt, data = epilepsy) #' sdata <- make_standata(count ~ Trt, data = epilepsy) #' stanfit <- rstan::stan(model_code = scode, data = sdata) -#' +#' #' # feed the Stan model back into brms #' fit <- brm(count ~ Trt, data = epilepsy, empty = TRUE) #' fit$fit <- stanfit #' fit <- rename_pars(fit) #' summary(fit) #' } -#' +#' #' @export rename_pars <- function(x) { if (!length(x$fit@sim)) { - return(x) + return(x) } bterms <- brmsterms(x$formula) data <- model.frame(x) @@ -84,6 +84,7 @@ if (is.formula(x$adforms$mi)) { c(out) <- change_Ymi(x, ...) } + c(out) <- change_family_cor_pars(x, ...) out } @@ -212,7 +213,7 @@ } else { indices <- seq_len(sum(pos)) } - fnames <- paste0(Xme_new, "[", indices, "]") + fnames <- paste0(Xme_new, "[", indices, "]") lc(out) <- clist(pos, fnames) } } @@ -271,7 +272,7 @@ lscale_names <- paste0(lscale, "_", sfx2) lc(out) <- clist(lscale_pos, lscale_names) c(out) <- change_prior(lscale_old, pars, names = sfx2, new_class = lscale) - + zgp <- paste0("zgp", p) zgp_old <- paste0(zgp, "_", i) if (length(sfx1) > 1L) { @@ -346,7 +347,7 @@ sd_pos <- grepl(paste0("^sd_", id, "(\\[|$)"), pars) lc(out) <- clist(sd_pos, sd_names) c(out) <- change_prior( - paste0("sd_", id), pars, new_class = paste0("sd_", g), + paste0("sd_", id), pars, new_class = paste0("sd_", g), names = paste0("_", as.vector(rnames)) ) # rename group-level correlations @@ -382,7 +383,7 @@ } } out -} +} # helps in renaming varying effects parameters per level # @param ranef: data.frame returned by 'tidy_ranef' @@ -403,6 +404,20 @@ out } +# helps to rename correlation parameters of likelihoods +change_family_cor_pars <- function(x, pars, ...) { + stopifnot(is.brmsterms(x)) + out <- list() + if (is_logistic_normal(x$family)) { + predcats <- get_predcats(x$family) + lncor_names <- get_cornames( + predcats, type = "lncor", brackets = FALSE + ) + lc(out) <- clist(grepl("^lncor\\[", pars), lncor_names) + } + out +} + # rename parameters related to special priors change_special_prior_local <- function(bterms, coef, pars) { out <- list() @@ -427,12 +442,13 @@ change_prior <- function(class, pars, names = NULL, new_class = class, is_vector = FALSE) { out <- list() - regex <- paste0("^prior_", class, "(_[[:digit:]]+|$|\\[)") + # 'stan_rngprior' adds '__' before the digits to disambiguate + regex <- paste0("^prior_", class, "(__[[:digit:]]+|$|\\[)") pos_priors <- which(grepl(regex, pars)) if (length(pos_priors)) { priors <- gsub( - paste0("^prior_", class), - paste0("prior_", new_class), + paste0("^prior_", class), + paste0("prior_", new_class), pars[pos_priors] ) if (is_vector) { @@ -445,12 +461,12 @@ lc(out) <- clist(pos_priors, priors) } else { digits <- sapply(priors, function(prior) { - d <- regmatches(prior, gregexpr("_[[:digit:]]+$", prior))[[1]] - if (length(d)) as.numeric(substr(d, 2, nchar(d))) else 0 + d <- regmatches(prior, gregexpr("__[[:digit:]]+$", prior))[[1]] + if (length(d)) as.numeric(substr(d, 3, nchar(d))) else 0 }) for (i in seq_along(priors)) { if (digits[i] && !is.null(names)) { - priors[i] <- gsub("[[:digit:]]+$", names[digits[i]], priors[i]) + priors[i] <- gsub("_[[:digit:]]+$", names[digits[i]], priors[i]) } if (pars[pos_priors[i]] != priors[i]) { lc(out) <- clist(pos_priors[i], priors[i]) @@ -472,7 +488,7 @@ # compute index names in square brackets for indexing stan parameters # @param rownames a vector of row names -# @param colnames a vector of columns +# @param colnames a vector of columns # @param dim the number of output dimensions # @return all index pairs of rows and cols make_index_names <- function(rownames, colnames = NULL, dim = 1) { @@ -507,13 +523,13 @@ for (i in seq_len(chains)) { names(x$fit@sim$samples[[i]])[change$pos] <- change$fnames if (!is.null(change$sort)) { - x$fit@sim$samples[[i]][change$pos] <- + x$fit@sim$samples[[i]][change$pos] <- x$fit@sim$samples[[i]][change$pos][change$sort] } } return(x) } - chains <- length(x$fit@sim$samples) + chains <- length(x$fit@sim$samples) # temporary fix for issue #387 until fixed in rstan for (i in seq_len(chains)) { x$fit@sim$samples[[i]]$lp__.1 <- NULL @@ -528,12 +544,12 @@ # @param x brmsfit object reorder_pars <- function(x) { all_classes <- unique(c( - "b", "bs", "bsp", "bcs", "ar", "ma", "lagsar", "errorsar", - "car", "sdcar", "cosy", "sd", "cor", "df", "sds", "sdgp", - "lscale", valid_dpars(x), "Intercept", "tmp", "rescor", - "delta", "lasso", "simo", "r", "s", "zgp", "rcar", "sbhaz", - "R2D2", "Ymi", "Yl", "meanme", "sdme", "corme", "Xme", "prior", - "lp" + "b", "bs", "bsp", "bcs", "ar", "ma", "sderr", "lagsar", "errorsar", + "car", "rhocar", "sdcar", "cosy", "sd", "cor", "df", "sds", "sdgp", + "lscale", valid_dpars(x), "lncor", "Intercept", "tmp", "rescor", + "delta", "lasso", "simo", "r", "s", "zgp", "rcar", "sbhaz", + "R2D2", "Ymi", "Yl", "meanme", "sdme", "corme", "Xme", "prior", + "lprior", "lp" )) # reorder parameter classes class <- get_matches("^[^_]+", x$fit@sim$pars_oi) @@ -556,13 +572,13 @@ chains <- length(x$fit@sim$samples) for (i in seq_len(chains)) { # attributes of samples must be kept - x$fit@sim$samples[[i]] <- + x$fit@sim$samples[[i]] <- subset_keep_attr(x$fit@sim$samples[[i]], new_order) } x } -# wrapper function to compute and store quantities in the stanfit +# wrapper function to compute and store quantities in the stanfit # object which were not computed / stored by Stan itself # @param x a brmsfit object # @return a brmsfit object diff -Nru r-cran-brms-2.16.3/R/restructure.R r-cran-brms-2.17.0/R/restructure.R --- r-cran-brms-2.16.3/R/restructure.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/restructure.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,720 +1,747 @@ -#' Restructure Old \code{brmsfit} Objects -#' -#' Restructure old \code{brmsfit} objects to work with -#' the latest \pkg{brms} version. This function is called -#' internally when applying post-processing methods. -#' However, in order to avoid unnecessary run time caused -#' by the restructuring, I recommend explicitly calling -#' \code{restructure} once per model after updating \pkg{brms}. -#' -#' @param x An object of class \code{brmsfit}. -#' @param ... Currently ignored. -#' -#' @return A \code{brmsfit} object compatible with the latest version -#' of \pkg{brms}. -#' -#' @export -restructure <- function(x, ...) { - stopifnot(is.brmsfit(x)) - if (is.null(x$version)) { - # this is the latest version without saving the version number - x$version <- list(brms = package_version("0.9.1")) - } else if (is.package_version(x$version)) { - # also added the rstan version in brms 1.5.0 - x$version <- list(brms = x$version) - } - current_version <- utils::packageVersion("brms") - restr_version <- restructure_version(x) - if (restr_version >= current_version) { - # object is up to date with the current brms version - return(x) - } - if (restr_version < "2.0.0") { - x <- restructure_v1(x) - } - if (restr_version < "3.0.0") { - x <- restructure_v2(x) - } - # remember the version with which the object was restructured - x$version$restructure <- current_version - # remove unused attribute - attr(x, "restructured") <- NULL - x -} - -restructure_v2 <- function(x) { - # restructure models fitted with brms 2.x - x$formula <- update_old_family(x$formula) - bterms <- SW(brmsterms(x$formula)) - pars <- variables(x) - version <- restructure_version(x) - if (version < "2.1.2") { - x <- do_renaming(x, change_old_bsp(pars)) - } - if (version < "2.1.3") { - if ("weibull" %in% family_names(x)) { - stop_parameterization_changed("weibull", "2.1.3") - } - } - if (version < "2.1.8") { - if ("exgaussian" %in% family_names(x)) { - stop_parameterization_changed("exgaussian", "2.1.8") - } - } - if (version < "2.1.9") { - # reworked 'me' terms (#372) - meef <- tidy_meef(bterms, model.frame(x)) - if (isTRUE(nrow(meef) > 0)) { - warning2( - "Measurement error ('me') terms have been reworked ", - "in version 2.1.9. I strongly recommend refitting your ", - "model with the latest version of brms." - ) - } - } - if (version < "2.2.4") { - # added 'dist' argument to grouping terms - x$ranef <- tidy_ranef(bterms, model.frame(x)) - } - if (version < "2.3.7") { - check_old_nl_dpars(bterms) - } - if (version < "2.8.3") { - # argument 'sparse' is now specified within 'formula' - sparse <- if (grepl("sparse matrix", stancode(x))) TRUE - x$formula <- SW(validate_formula(x$formula, data = x$data, sparse = sparse)) - } - if (version < "2.8.4") { - x <- rescale_old_mo(x) - } - if (version < "2.8.5") { - if (any(grepl("^arr(\\[|_|$)", pars))) { - warning2("ARR structures are no longer supported.") - } - } - if (version < "2.8.6") { - # internal handling of special effects terms has changed - # this requires updating the 'terms' attribute of the data - x$data <- rm_attr(x$data, c("brmsframe", "terms")) - x$data <- validate_data(x$data, bterms) - } - if (version < "2.8.9") { - if (any(grepl("^loclev(\\[|_|$)", pars))) { - warning2("BSTS structures are no longer supported.") - } - } - if (version < "2.10.4") { - # model fit criteria have been moved to x$criteria - criterion_names <- c("loo", "waic", "kfold", "R2", "marglik") - criteria <- x[intersect(criterion_names, names(x))] - x[criterion_names] <- NULL - # rename 'R2' to 'bayes_R2' according to #793 - names(criteria)[names(criteria) == "R2"] <- "bayes_R2" - x$criteria <- criteria - } - if (version < "2.10.5") { - # new slot 'thres' stored inside ordinal families - if (is_ordinal(x$formula)) { - x$formula <- SW(validate_formula(x$formula, data = x$data)) - } - } - if (version < "2.11.2") { - # 'autocor' was integrated into the formula interface - x$formula <- SW(validate_formula(x$formula)) - x$data2 <- validate_data2( - data2 = list(), bterms = bterms, - get_data2_autocor(x$formula) - ) - } - if (version < "2.11.3") { - # ordering after IDs matches the order of the posterior draws - # if multiple IDs are used for the same grouping factor (#835) - x$ranef <- x$ranef[order(x$ranef$id), , drop = FALSE] - } - if (version < "2.11.5") { - # 'cats' is stored inside ordinal families again - if (is_ordinal(x$formula)) { - x$formula <- SW(validate_formula(x$formula, data = x$data)) - } - } - if (version < "2.12.5") { - # 'cov_ranef' was integrated into the formula interface - if (length(x$cov_ranef)) { - x$formula <- SW(validate_formula(x$formula, cov_ranef = x$cov_ranef)) - cov_ranef <- get_data2_cov_ranef(x$formula) - x$data2[names(cov_ranef)] <- cov_ranef - } - } - if (version < "2.12.6") { - # minor structural changes as part of internal interface improvements - attr(x$data, "data_name") <- x$data.name - x$stanvars <- SW(validate_stanvars(x$stanvars, stan_funs = x$stan_funs)) - } - if (version < "2.12.11") { - # argument 'position' was added to stanvars - for (i in seq_along(x$stanvars)) { - x$stanvars[[i]]$position <- "start" - } - } - if (version < "2.13.2") { - # added support for 'cmdstanr' as additional backend - x$backend <- "rstan" - } - if (version < "2.13.5") { - # see issue #962 for discussion - if ("cox" %in% family_names(x)) { - stop_parameterization_changed("cox", "2.13.5") - } - } - if (version < "2.13.8") { - x$prior$source <- "" - # ensure correct ordering of columns - cols_prior <- intersect(all_cols_prior(), names(x$prior)) - x$prior <- x$prior[, cols_prior] - } - if (version < "2.13.10") { - # added support for threading - x$threads <- threading() - } - if (version < "2.13.12") { - # added more control over which parameters to save - save_ranef <- isTRUE(attr(x$exclude, "save_ranef")) - save_mevars <- isTRUE(attr(x$exclude, "save_mevars")) - save_all_pars <- isTRUE(attr(x$exclude, "save_all_pars")) - x$save_pars <- SW(validate_save_pars( - save_pars(), save_ranef = save_ranef, - save_mevars = save_mevars, - save_all_pars = save_all_pars - )) - x$exclude <- NULL - } - if (version < "2.15.6") { - # added support for OpenCL - x$opencl <- opencl() - } - if (version < "2.16.1") { - # problems with rstan::read_stan_csv as well as - # non-unique variable names became apparent (#1218) - x$fit <- repair_stanfit_names(x$fit) - } - x -} - -# restructure models fitted with brms 1.x -restructure_v1 <- function(x) { - version <- restructure_version(x) - if (version < "1.0.0") { - warning2( - "Models fitted with brms < 1.0 are no longer offically ", - "supported and post-processing them may fail. I recommend ", - "refitting the model with the latest version of brms." - ) - } - x$formula <- restructure_formula_v1(formula(x), x$nonlinear) - x$formula <- SW(validate_formula( - formula(x), data = model.frame(x), family = family(x), - autocor = x$autocor, threshold = x$threshold - )) - x$nonlinear <- x$partial <- x$threshold <- NULL - bterms <- brmsterms(formula(x)) - x$data <- rm_attr(x$data, "brmsframe") - x$data <- validate_data(x$data, bterms) - x$ranef <- tidy_ranef(bterms, model.frame(x)) - if ("prior_frame" %in% class(x$prior)) { - class(x$prior) <- c("brmsprior", "data.frame") - } - if (is(x$autocor, "cov_fixed")) { - # deprecated as of brms 1.4.0 - class(x$autocor) <- "cor_fixed" - } - if (version < "0.10.1") { - if (length(bterms$dpars$mu$nlpars)) { - # nlpar and group have changed positions - change <- change_old_re(x$ranef, variables(x), x$fit@sim$dims_oi) - x <- do_renaming(x, change) - } - } - if (version < "1.0.0") { - # double underscores were added to group-level parameters - change <- change_old_re2(x$ranef, variables(x), x$fit@sim$dims_oi) - x <- do_renaming(x, change) - } - if (version < "1.0.1.1") { - # names of spline parameters had to be changed after - # allowing for multiple covariates in one spline term - change <- change_old_sm( - bterms, model.frame(x), variables(x), x$fit@sim$dims_oi - ) - x <- do_renaming(x, change) - } - if (version < "1.8.0.1") { - att <- attributes(x$exclude) - if (is.null(att$save_ranef)) { - attr(x$exclude, "save_ranef") <- - any(grepl("^r_", variables(x))) || !nrow(x$ranef) - } - if (is.null(att$save_mevars)) { - attr(x$exclude, "save_mevars") <- - any(grepl("^Xme_", variables(x))) - } - } - if (version < "1.8.0.2") { - x$prior$resp <- x$prior$dpar <- "" - # ensure correct ordering of columns - cols_prior <- intersect(all_cols_prior(), names(x$prior)) - x$prior <- x$prior[, cols_prior] - } - if (version < "1.9.0.4") { - # names of monotonic parameters had to be changed after - # allowing for interactions in monotonic terms - change <- change_old_mo(bterms, x$data, pars = variables(x)) - x <- do_renaming(x, change) - } - if (version >= "1.0.0" && version < "2.0.0") { - change <- change_old_categorical(bterms, x$data, pars = variables(x)) - x <- do_renaming(x, change) - } - x -} - -# get version with which a brmsfit object was restructured -restructure_version <- function(x) { - stopifnot(is.brmsfit(x)) - out <- x$version$restructure - if (!is.package_version(out)) { - # models restructured with brms 2.11.1 store it as an attribute - out <- attr(x, "restructured", exact = TRUE) - } - if (!is.package_version(out)) { - out <- x$version$brms - } - out -} - -# convert old model formulas to brmsformula objects -restructure_formula_v1 <- function(formula, nonlinear = NULL) { - if (is.brmsformula(formula) && is.formula(formula)) { - # convert deprecated brmsformula objects back to formula - class(formula) <- "formula" - } - if (is.brmsformula(formula)) { - # already up to date - return(formula) - } - old_nonlinear <- attr(formula, "nonlinear") - nl <- length(nonlinear) > 0 - if (is.logical(old_nonlinear)) { - nl <- nl || old_nonlinear - } else if (length(old_nonlinear)) { - nonlinear <- c(nonlinear, old_nonlinear) - nl <- TRUE - } - out <- structure(nlist(formula), class = "brmsformula") - old_forms <- rmNULL(attributes(formula)[old_dpars()]) - old_forms <- c(old_forms, nonlinear) - out$pforms[names(old_forms)] <- old_forms - bf(out, nl = nl) -} - -# parameters to be restructured in old brmsformula objects -old_dpars <- function() { - c("mu", "sigma", "shape", "nu", "phi", "kappa", "beta", "xi", - "zi", "hu", "zoi", "coi", "disc", "bs", "ndt", "bias", - "quantile", "alpha", "theta") -} - -# interchanges group and nlpar in names of group-level parameters -# required for brms <= 0.10.0.9000 -# @param ranef output of tidy_ranef -# @param pars names of all parameters in the model -# @param dims dimension of parameters -# @return a list whose elements can be interpreted by do_renaming -change_old_re <- function(ranef, pars, dims) { - out <- list() - for (id in unique(ranef$id)) { - r <- subset2(ranef, id = id) - g <- r$group[1] - nlpar <- r$nlpar[1] - stopifnot(nzchar(nlpar)) - # rename sd-parameters - old_sd_names <- paste0("sd_", nlpar, "_", g, "_", r$coef) - new_sd_names <- paste0("sd_", g, "_", nlpar, "_", r$coef) - for (i in seq_along(old_sd_names)) { - lc(out) <- change_simple( - old_sd_names[i], new_sd_names[i], pars, dims - ) - } - # rename cor-parameters - new_cor_names <- get_cornames( - paste0(nlpar, "_", r$coef), type = paste0("cor_", g), - brackets = FALSE, sep = "_" - ) - old_cor_names <- get_cornames( - r$coef, brackets = FALSE, sep = "_", - type = paste0("cor_", nlpar, "_", g) - ) - for (i in seq_along(old_cor_names)) { - lc(out) <- change_simple( - old_cor_names[i], new_cor_names[i], pars, dims - ) - } - # rename r-parameters - old_r_name <- paste0("r_", nlpar, "_", g) - new_r_name <- paste0("r_", g, "_", nlpar) - levels <- gsub("[ \t\r\n]", ".", attr(ranef, "levels")[[g]]) - index_names <- make_index_names(levels, r$coef, dim = 2) - new_r_names <- paste0(new_r_name, index_names) - lc(out) <- change_simple( - old_r_name, new_r_names, pars, dims, - pnames = new_r_name - ) - } - out -} - -# add double underscore in group-level parameters -# required for brms < 1.0.0 -# @note assumes that group and nlpar are correctly ordered already -# @param ranef output of tidy_ranef -# @param pars names of all parameters in the model -# @param dims dimension of parameters -# @return a list whose elements can be interpreted by do_renaming -change_old_re2 <- function(ranef, pars, dims) { - out <- list() - for (id in unique(ranef$id)) { - r <- subset2(ranef, id = id) - g <- r$group[1] - nlpars_usc <- usc(r$nlpar, "suffix") - # rename sd-parameters - old_sd_names <- paste0("sd_", g, "_", nlpars_usc, r$coef) - new_sd_names <- paste0("sd_", g, "__", nlpars_usc, r$coef) - for (i in seq_along(old_sd_names)) { - lc(out) <- change_simple(old_sd_names[i], new_sd_names[i], pars, dims) - } - # rename cor-parameters - new_cor_names <- get_cornames( - paste0(nlpars_usc, r$coef), type = paste0("cor_", g), - brackets = FALSE - ) - old_cor_names <- get_cornames( - paste0(nlpars_usc, r$coef), type = paste0("cor_", g), - brackets = FALSE, sep = "_" - ) - for (i in seq_along(old_cor_names)) { - lc(out) <- change_simple(old_cor_names[i], new_cor_names[i], pars, dims) - } - # rename r-parameters - for (nlpar in unique(r$nlpar)) { - sub_r <- r[r$nlpar == nlpar, ] - old_r_name <- paste0("r_", g, usc(nlpar)) - new_r_name <- paste0("r_", g, usc(usc(nlpar))) - levels <- gsub("[ \t\r\n]", ".", attr(ranef, "levels")[[g]]) - index_names <- make_index_names(levels, sub_r$coef, dim = 2) - new_r_names <- paste0(new_r_name, index_names) - lc(out) <- change_simple( - old_r_name, new_r_names, pars, dims, - pnames = new_r_name - ) - } - } - out -} - -# change names of spline parameters fitted with brms <= 1.0.1 -# this became necessary after allowing smooths with multiple covariates -change_old_sm <- function(bterms, data, pars, dims) { - .change_old_sm <- function(bt) { - out <- list() - smef <- tidy_smef(bt, data) - if (nrow(smef)) { - p <- usc(combine_prefix(bt), "suffix") - old_smooths <- rename(paste0(p, smef$term)) - new_smooths <- rename(paste0(p, smef$label)) - old_sds_pars <- paste0("sds_", old_smooths) - new_sds_pars <- paste0("sds_", new_smooths, "_1") - old_s_pars <- paste0("s_", old_smooths) - new_s_pars <- paste0("s_", new_smooths, "_1") - for (i in seq_along(old_smooths)) { - lc(out) <- change_simple(old_sds_pars[i], new_sds_pars[i], pars, dims) - dim_s <- dims[[old_s_pars[i]]] - if (!is.null(dim_s)) { - new_s_par_indices <- paste0(new_s_pars[i], "[", seq_len(dim_s), "]") - lc(out) <- change_simple( - old_s_pars[i], new_s_par_indices, pars, dims, - pnames = new_s_pars[i] - ) - } - } - } - return(out) - } - - out <- list() - if (is.mvbrmsterms(bterms)) { - for (r in bterms$responses) { - c(out) <- .change_old_sm(bterms$terms[[r]]$dpars$mu) - } - } else if (is.brmsterms(bterms)) { - for (dp in names(bterms$dpars)) { - bt <- bterms$dpars[[dp]] - if (length(bt$nlpars)) { - for (nlp in names(bt$nlpars)) { - c(out) <- .change_old_sm(bt$nlpars[[nlp]]) - } - } else { - c(out) <- .change_old_sm(bt) - } - } - } - out -} - -# change names of monotonic effects fitted with brms <= 1.9.0 -# this became necessary after implementing monotonic interactions -change_old_mo <- function(bterms, data, pars) { - .change_old_mo <- function(bt) { - out <- list() - spef <- tidy_spef(bt, data) - has_mo <- lengths(spef$calls_mo) > 0 - if (!any(has_mo)) { - return(out) - } - spef <- spef[has_mo, ] - p <- usc(combine_prefix(bt)) - bmo_prefix <- paste0("bmo", p, "_") - bmo_regex <- paste0("^", bmo_prefix, "[^_]+$") - bmo_old <- pars[grepl(bmo_regex, pars)] - bmo_new <- paste0(bmo_prefix, spef$coef) - if (length(bmo_old) != length(bmo_new)) { - stop2("Restructuring failed. Please refit your ", - "model with the latest version of brms.") - } - for (i in seq_along(bmo_old)) { - pos <- grepl(paste0("^", bmo_old[i]), pars) - lc(out) <- clist(pos, fnames = bmo_new[i]) - } - simo_regex <- paste0("^simplex", p, "_[^_]+$") - simo_old_all <- pars[grepl(simo_regex, pars)] - simo_index <- get_matches("\\[[[:digit:]]+\\]$", simo_old_all) - simo_old <- unique(sub("\\[[[:digit:]]+\\]$", "", simo_old_all)) - simo_coef <- get_simo_labels(spef) - for (i in seq_along(simo_old)) { - regex_pos <- paste0("^", simo_old[i]) - pos <- grepl(regex_pos, pars) - simo_new <- paste0("simo", p, "_", simo_coef[i]) - simo_index_part <- simo_index[grepl(regex_pos, simo_old_all)] - simo_new <- paste0(simo_new, simo_index_part) - lc(out) <- clist(pos, fnames = simo_new) - } - return(out) - } - - out <- list() - if (is.mvbrmsterms(bterms)) { - for (r in bterms$responses) { - c(out) <- .change_old_mo(bterms$terms[[r]]$dpars$mu) - } - } else if (is.brmsterms(bterms)) { - for (dp in names(bterms$dpars)) { - bt <- bterms$dpars[[dp]] - if (length(bt$nlpars)) { - for (nlp in names(bt$nlpars)) { - c(out) <- .change_old_mo(bt$nlpars[[nlp]]) - } - } else { - c(out) <- .change_old_mo(bt) - } - } - } - out -} - -# between version 1.0 and 2.0 categorical models used -# the internal multivariate interface -change_old_categorical <- function(bterms, data, pars) { - stopifnot(is.brmsterms(bterms)) - if (!is_categorical(bterms$family)) { - return(list()) - } - # compute the old category names - respform <- bterms$respform - old_dpars <- model.response(model.frame(respform, data = data)) - old_dpars <- levels(factor(old_dpars)) - old_dpars <- make.names(old_dpars[-1], unique = TRUE) - old_dpars <- rename(old_dpars, ".", "x") - new_dpars <- bterms$family$dpars - stopifnot(length(old_dpars) == length(new_dpars)) - pos <- rep(FALSE, length(pars)) - new_pars <- pars - for (i in seq_along(old_dpars)) { - # not perfectly save but hopefully mostly correct - regex <- paste0("(?<=_)", old_dpars[i], "(?=_|\\[)") - pos <- pos | grepl(regex, pars, perl = TRUE) - new_pars <- gsub(regex, new_dpars[i], new_pars, perl = TRUE) - } - list(nlist(pos, fnames = new_pars[pos])) -} - -# as of brms 2.2 'mo' and 'me' terms are handled together -change_old_bsp <- function(pars) { - pos <- grepl("^(bmo|bme)_", pars) - if (!any(pos)) return(list()) - fnames <- gsub("^(bmo|bme)_", "bsp_", pars[pos]) - list(nlist(pos, fnames)) -} - -# prepare for renaming of parameters in old models -change_simple <- function(oldname, fnames, pars, dims, pnames = fnames) { - pos <- grepl(paste0("^", oldname), pars) - if (any(pos)) { - out <- nlist(pos, oldname, pnames, fnames, dims = dims[[oldname]]) - class(out) <- c("clist", "list") - } else { - out <- NULL - } - out -} - -# rescale old 'b' coefficients of monotonic effects -# to represent average instead of total differences -rescale_old_mo <- function(x, ...) { - UseMethod("rescale_old_mo") -} - -#' @export -rescale_old_mo.brmsfit <- function(x, ...) { - bterms <- brmsterms(x$formula) - rescale_old_mo(bterms, fit = x, ...) -} - -#' @export -rescale_old_mo.mvbrmsterms <- function(x, fit, ...) { - for (resp in x$responses) { - fit <- rescale_old_mo(x$terms[[resp]], fit = fit, ...) - } - fit -} - -#' @export -rescale_old_mo.brmsterms <- function(x, fit, ...) { - for (dp in names(x$dpars)) { - fit <- rescale_old_mo(x$dpars[[dp]], fit = fit, ...) - } - for (nlp in names(x$nlpars)) { - fit <- rescale_old_mo(x$nlpars[[nlp]], fit = fit, ...) - } - fit -} - -#' @export -rescale_old_mo.btnl <- function(x, fit, ...) { - fit -} - -#' @export -rescale_old_mo.btl <- function(x, fit, ...) { - spef <- tidy_spef(x, fit$data) - has_mo <- lengths(spef$Imo) > 0L - if (!any(has_mo)) { - return(fit) - } - warning2( - "The parameterization of monotonic effects has changed in brms 2.8.4 ", - "so that corresponding 'b' coefficients now represent average instead ", - "of total differences between categories. See vignette('brms_monotonic') ", - "for more details. Parameters of old models are adjusted automatically." - ) - p <- combine_prefix(x) - all_pars <- variables(fit) - chains <- fit$fit@sim$chains - for (i in which(has_mo)) { - bsp_par <- paste0("bsp", p, "_", spef$coef[i]) - simo_regex <- paste0(spef$coef[i], seq_along(spef$Imo[[i]])) - simo_regex <- paste0("simo", p, "_", simo_regex, "[") - simo_regex <- paste0("^", escape_all(simo_regex)) - # scaling factor by which to divide the old 'b' coefficients - D <- prod(ulapply(simo_regex, function(r) sum(grepl(r, all_pars)))) - for (j in seq_len(chains)) { - fit$fit@sim$samples[[j]][[bsp_par]] <- - fit$fit@sim$samples[[j]][[bsp_par]] / D - } - } - fit -} - -# update old families to work with the latest brms version -update_old_family <- function(x, ...) { - UseMethod("update_old_family") -} - -#' @export -update_old_family.default <- function(x, ...) { - validate_family(x) -} - -#' @export -update_old_family.brmsfamily <- function(x, ...) { - # new specials may have been added in new brms versions - family_info <- get(paste0(".family_", x$family))() - x$specials <- family_info$specials - x -} - -#' @export -update_old_family.customfamily <- function(x, ...) { - if (!is.null(x$predict)) { - x$posterior_predict <- x$predict - x$predict <- NULL - } - if (!is.null(x$fitted)) { - x$posterior_epred <- x$fitted - x$fitted <- NULL - } - x -} - -#' @export -update_old_family.mixfamily <- function(x, ...) { - x$mix <- lapply(x$mix, update_old_family, ...) - x -} - -#' @export -update_old_family.brmsformula <- function(x, ...) { - x$family <- update_old_family(x$family, ...) - x -} - -#' @export -update_old_family.mvbrmsformula <- function(x, ...) { - x$forms <- lapply(x$forms, update_old_family, ...) - x -} - -stop_parameterization_changed <- function(family, version) { - stop2( - "The parameterization of '", family, "' models has changed in brms ", - version, ". Please refit your model with the current version of brms." - ) -} - -check_old_nl_dpars <- function(bterms) { - .check_nl_dpars <- function(x) { - stopifnot(is.brmsterms(x)) - non_mu_dpars <- x$dpars[names(x$dpars) != "mu"] - if (any(ulapply(non_mu_dpars, is.btnl))) { - stop2( - "Non-linear parameters are global within univariate models ", - "as of version 2.3.7. Please refit your model with the ", - "latest version of brms." - ) - } - return(TRUE) - } - if (is.mvbrmsterms(bterms)) { - lapply(bterms$terms, .check_nl_dpars) - } else { - .check_nl_dpars(bterms) - } - TRUE -} +#' Restructure Old \code{brmsfit} Objects +#' +#' Restructure old \code{brmsfit} objects to work with +#' the latest \pkg{brms} version. This function is called +#' internally when applying post-processing methods. +#' However, in order to avoid unnecessary run time caused +#' by the restructuring, I recommend explicitly calling +#' \code{restructure} once per model after updating \pkg{brms}. +#' +#' @param x An object of class \code{brmsfit}. +#' @param ... Currently ignored. +#' +#' @return A \code{brmsfit} object compatible with the latest version +#' of \pkg{brms}. +#' +#' @export +restructure <- function(x, ...) { + stopifnot(is.brmsfit(x)) + if (is.null(x$version)) { + # this is the latest version without saving the version number + x$version <- list(brms = package_version("0.9.1")) + } else if (is.package_version(x$version)) { + # also added the rstan version in brms 1.5.0 + x$version <- list(brms = x$version) + } + current_version <- utils::packageVersion("brms") + restr_version <- restructure_version(x) + if (restr_version >= current_version) { + # object is up to date with the current brms version + return(x) + } + if (restr_version < "2.0.0") { + x <- restructure_v1(x) + } + if (restr_version < "3.0.0") { + x <- restructure_v2(x) + } + # remember the version with which the object was restructured + x$version$restructure <- current_version + # remove unused attribute + attr(x, "restructured") <- NULL + x +} + +restructure_v2 <- function(x) { + # restructure models fitted with brms 2.x + x$formula <- update_old_family(x$formula) + bterms <- SW(brmsterms(x$formula)) + pars <- variables(x) + version <- restructure_version(x) + if (version < "2.1.2") { + x <- do_renaming(x, change_old_bsp(pars)) + } + if (version < "2.1.3") { + if ("weibull" %in% family_names(x)) { + stop_parameterization_changed("weibull", "2.1.3") + } + } + if (version < "2.1.8") { + if ("exgaussian" %in% family_names(x)) { + stop_parameterization_changed("exgaussian", "2.1.8") + } + } + if (version < "2.1.9") { + # reworked 'me' terms (#372) + meef <- tidy_meef(bterms, model.frame(x)) + if (isTRUE(nrow(meef) > 0)) { + warning2( + "Measurement error ('me') terms have been reworked ", + "in version 2.1.9. I strongly recommend refitting your ", + "model with the latest version of brms." + ) + } + } + if (version < "2.2.4") { + # added 'dist' argument to grouping terms + x$ranef <- tidy_ranef(bterms, model.frame(x)) + } + if (version < "2.3.7") { + check_old_nl_dpars(bterms) + } + if (version < "2.8.3") { + # argument 'sparse' is now specified within 'formula' + sparse <- if (grepl("sparse matrix", stancode(x))) TRUE + x$formula <- SW(validate_formula(x$formula, data = x$data, sparse = sparse)) + } + if (version < "2.8.4") { + x <- rescale_old_mo(x) + } + if (version < "2.8.5") { + if (any(grepl("^arr(\\[|_|$)", pars))) { + warning2("ARR structures are no longer supported.") + } + } + if (version < "2.8.6") { + # internal handling of special effects terms has changed + # this requires updating the 'terms' attribute of the data + x$data <- rm_attr(x$data, c("brmsframe", "terms")) + x$data <- validate_data(x$data, bterms) + } + if (version < "2.8.9") { + if (any(grepl("^loclev(\\[|_|$)", pars))) { + warning2("BSTS structures are no longer supported.") + } + } + if (version < "2.10.4") { + # model fit criteria have been moved to x$criteria + criterion_names <- c("loo", "waic", "kfold", "R2", "marglik") + criteria <- x[intersect(criterion_names, names(x))] + x[criterion_names] <- NULL + # rename 'R2' to 'bayes_R2' according to #793 + names(criteria)[names(criteria) == "R2"] <- "bayes_R2" + x$criteria <- criteria + } + if (version < "2.10.5") { + # new slot 'thres' stored inside ordinal families + if (is_ordinal(x$formula)) { + x$formula <- SW(validate_formula(x$formula, data = x$data)) + } + } + if (version < "2.11.2") { + # 'autocor' was integrated into the formula interface + x$formula <- SW(validate_formula(x$formula)) + x$data2 <- validate_data2( + data2 = list(), bterms = bterms, + get_data2_autocor(x$formula) + ) + } + if (version < "2.11.3") { + # ordering after IDs matches the order of the posterior draws + # if multiple IDs are used for the same grouping factor (#835) + x$ranef <- x$ranef[order(x$ranef$id), , drop = FALSE] + } + if (version < "2.11.5") { + # 'cats' is stored inside ordinal families again + if (is_ordinal(x$formula)) { + x$formula <- SW(validate_formula(x$formula, data = x$data)) + } + } + if (version < "2.12.5") { + # 'cov_ranef' was integrated into the formula interface + if (length(x$cov_ranef)) { + x$formula <- SW(validate_formula(x$formula, cov_ranef = x$cov_ranef)) + cov_ranef <- get_data2_cov_ranef(x$formula) + x$data2[names(cov_ranef)] <- cov_ranef + } + } + if (version < "2.12.6") { + # minor structural changes as part of internal interface improvements + attr(x$data, "data_name") <- x$data.name + x$stanvars <- SW(validate_stanvars(x$stanvars, stan_funs = x$stan_funs)) + } + if (version < "2.12.11") { + # argument 'position' was added to stanvars + for (i in seq_along(x$stanvars)) { + x$stanvars[[i]]$position <- "start" + } + } + if (version < "2.13.2") { + # added support for 'cmdstanr' as additional backend + x$backend <- "rstan" + } + if (version < "2.13.5") { + # see issue #962 for discussion + if ("cox" %in% family_names(x)) { + stop_parameterization_changed("cox", "2.13.5") + } + } + if (version < "2.13.8") { + x$prior$source <- "" + # ensure correct ordering of columns + cols_prior <- intersect(all_cols_prior(), names(x$prior)) + x$prior <- x$prior[, cols_prior] + } + if (version < "2.13.10") { + # added support for threading + x$threads <- threading() + } + if (version < "2.13.12") { + # added more control over which parameters to save + save_ranef <- isTRUE(attr(x$exclude, "save_ranef")) + save_mevars <- isTRUE(attr(x$exclude, "save_mevars")) + save_all_pars <- isTRUE(attr(x$exclude, "save_all_pars")) + x$save_pars <- SW(validate_save_pars( + save_pars(), save_ranef = save_ranef, + save_mevars = save_mevars, + save_all_pars = save_all_pars + )) + x$exclude <- NULL + } + if (version < "2.15.6") { + # added support for OpenCL + x$opencl <- opencl() + } + if (version < "2.16.1") { + # problems with rstan::read_stan_csv as well as + # non-unique variable names became apparent (#1218) + x$fit <- repair_stanfit_names(x$fit) + } + if (version < "2.16.12") { + # added full user control over parameter boundaries (#1324) + # explicit bounds need to be added to old priors as a result + x$prior$ub <- x$prior$lb <- NA + for (i in which(nzchar(x$prior$bound))) { + bounds <- convert_stan2bounds(x$prior$bound[i], default = c("", "")) + x$prior[i, c("lb", "ub")] <- bounds + } + x$prior$bound <- NULL + all_priors <- get_prior(x$formula, x$data, data2 = x$data2, internal = TRUE) + # checking for lb is sufficient because both bounds are NA at the same time + which_needs_bounds <- which(is.na(x$prior$lb) & !nzchar(x$prior$coef)) + for (i in which_needs_bounds) { + # take the corresponding bounds from the default prior + prior_sub_i <- rbind(x$prior[i, ], all_priors) + prior_sub_i <- prior_sub_i[duplicated(prior_sub_i), ] + # should always have exactly one row but still check whether it has + # any rows at all to prevent things from breaking accidentally + if (NROW(prior_sub_i)) { + x$prior[i, c("lb", "ub")] <- prior_sub_i[1, c("lb", "ub")] + } else { + x$prior[i, c("lb", "ub")] <- "" + } + } + x$prior$lb[is.na(x$prior$lb)] <- x$prior$ub[is.na(x$prior$ub)] <- "" + x$prior <- move2end(x$prior, "source") + } + x +} + +# restructure models fitted with brms 1.x +restructure_v1 <- function(x) { + version <- restructure_version(x) + if (version < "1.0.0") { + warning2( + "Models fitted with brms < 1.0 are no longer offically ", + "supported and post-processing them may fail. I recommend ", + "refitting the model with the latest version of brms." + ) + } + x$formula <- restructure_formula_v1(formula(x), x$nonlinear) + x$formula <- SW(validate_formula( + formula(x), data = model.frame(x), family = family(x), + autocor = x$autocor, threshold = x$threshold + )) + x$nonlinear <- x$partial <- x$threshold <- NULL + bterms <- brmsterms(formula(x)) + x$data <- rm_attr(x$data, "brmsframe") + x$data <- validate_data(x$data, bterms) + x$ranef <- tidy_ranef(bterms, model.frame(x)) + if ("prior_frame" %in% class(x$prior)) { + class(x$prior) <- c("brmsprior", "data.frame") + } + if (is(x$autocor, "cov_fixed")) { + # deprecated as of brms 1.4.0 + class(x$autocor) <- "cor_fixed" + } + if (version < "0.10.1") { + if (length(bterms$dpars$mu$nlpars)) { + # nlpar and group have changed positions + change <- change_old_re(x$ranef, variables(x), x$fit@sim$dims_oi) + x <- do_renaming(x, change) + } + } + if (version < "1.0.0") { + # double underscores were added to group-level parameters + change <- change_old_re2(x$ranef, variables(x), x$fit@sim$dims_oi) + x <- do_renaming(x, change) + } + if (version < "1.0.1.1") { + # names of spline parameters had to be changed after + # allowing for multiple covariates in one spline term + change <- change_old_sm( + bterms, model.frame(x), variables(x), x$fit@sim$dims_oi + ) + x <- do_renaming(x, change) + } + if (version < "1.8.0.1") { + att <- attributes(x$exclude) + if (is.null(att$save_ranef)) { + attr(x$exclude, "save_ranef") <- + any(grepl("^r_", variables(x))) || !nrow(x$ranef) + } + if (is.null(att$save_mevars)) { + attr(x$exclude, "save_mevars") <- + any(grepl("^Xme_", variables(x))) + } + } + if (version < "1.8.0.2") { + x$prior$resp <- x$prior$dpar <- "" + # ensure correct ordering of columns + cols_prior <- intersect(all_cols_prior(), names(x$prior)) + x$prior <- x$prior[, cols_prior] + } + if (version < "1.9.0.4") { + # names of monotonic parameters had to be changed after + # allowing for interactions in monotonic terms + change <- change_old_mo(bterms, x$data, pars = variables(x)) + x <- do_renaming(x, change) + } + if (version >= "1.0.0" && version < "2.0.0") { + change <- change_old_categorical(bterms, x$data, pars = variables(x)) + x <- do_renaming(x, change) + } + x +} + +# get version with which a brmsfit object was restructured +restructure_version <- function(x) { + stopifnot(is.brmsfit(x)) + out <- x$version$restructure + if (!is.package_version(out)) { + # models restructured with brms 2.11.1 store it as an attribute + out <- attr(x, "restructured", exact = TRUE) + } + if (!is.package_version(out)) { + out <- x$version$brms + } + out +} + +# convert old model formulas to brmsformula objects +restructure_formula_v1 <- function(formula, nonlinear = NULL) { + if (is.brmsformula(formula) && is.formula(formula)) { + # convert deprecated brmsformula objects back to formula + class(formula) <- "formula" + } + if (is.brmsformula(formula)) { + # already up to date + return(formula) + } + old_nonlinear <- attr(formula, "nonlinear") + nl <- length(nonlinear) > 0 + if (is.logical(old_nonlinear)) { + nl <- nl || old_nonlinear + } else if (length(old_nonlinear)) { + nonlinear <- c(nonlinear, old_nonlinear) + nl <- TRUE + } + out <- structure(nlist(formula), class = "brmsformula") + old_forms <- rmNULL(attributes(formula)[old_dpars()]) + old_forms <- c(old_forms, nonlinear) + out$pforms[names(old_forms)] <- old_forms + bf(out, nl = nl) +} + +# parameters to be restructured in old brmsformula objects +old_dpars <- function() { + c("mu", "sigma", "shape", "nu", "phi", "kappa", "beta", "xi", + "zi", "hu", "zoi", "coi", "disc", "bs", "ndt", "bias", + "quantile", "alpha", "theta") +} + +# interchanges group and nlpar in names of group-level parameters +# required for brms <= 0.10.0.9000 +# @param ranef output of tidy_ranef +# @param pars names of all parameters in the model +# @param dims dimension of parameters +# @return a list whose elements can be interpreted by do_renaming +change_old_re <- function(ranef, pars, dims) { + out <- list() + for (id in unique(ranef$id)) { + r <- subset2(ranef, id = id) + g <- r$group[1] + nlpar <- r$nlpar[1] + stopifnot(nzchar(nlpar)) + # rename sd-parameters + old_sd_names <- paste0("sd_", nlpar, "_", g, "_", r$coef) + new_sd_names <- paste0("sd_", g, "_", nlpar, "_", r$coef) + for (i in seq_along(old_sd_names)) { + lc(out) <- change_simple( + old_sd_names[i], new_sd_names[i], pars, dims + ) + } + # rename cor-parameters + new_cor_names <- get_cornames( + paste0(nlpar, "_", r$coef), type = paste0("cor_", g), + brackets = FALSE, sep = "_" + ) + old_cor_names <- get_cornames( + r$coef, brackets = FALSE, sep = "_", + type = paste0("cor_", nlpar, "_", g) + ) + for (i in seq_along(old_cor_names)) { + lc(out) <- change_simple( + old_cor_names[i], new_cor_names[i], pars, dims + ) + } + # rename r-parameters + old_r_name <- paste0("r_", nlpar, "_", g) + new_r_name <- paste0("r_", g, "_", nlpar) + levels <- gsub("[ \t\r\n]", ".", attr(ranef, "levels")[[g]]) + index_names <- make_index_names(levels, r$coef, dim = 2) + new_r_names <- paste0(new_r_name, index_names) + lc(out) <- change_simple( + old_r_name, new_r_names, pars, dims, + pnames = new_r_name + ) + } + out +} + +# add double underscore in group-level parameters +# required for brms < 1.0.0 +# @note assumes that group and nlpar are correctly ordered already +# @param ranef output of tidy_ranef +# @param pars names of all parameters in the model +# @param dims dimension of parameters +# @return a list whose elements can be interpreted by do_renaming +change_old_re2 <- function(ranef, pars, dims) { + out <- list() + for (id in unique(ranef$id)) { + r <- subset2(ranef, id = id) + g <- r$group[1] + nlpars_usc <- usc(r$nlpar, "suffix") + # rename sd-parameters + old_sd_names <- paste0("sd_", g, "_", nlpars_usc, r$coef) + new_sd_names <- paste0("sd_", g, "__", nlpars_usc, r$coef) + for (i in seq_along(old_sd_names)) { + lc(out) <- change_simple(old_sd_names[i], new_sd_names[i], pars, dims) + } + # rename cor-parameters + new_cor_names <- get_cornames( + paste0(nlpars_usc, r$coef), type = paste0("cor_", g), + brackets = FALSE + ) + old_cor_names <- get_cornames( + paste0(nlpars_usc, r$coef), type = paste0("cor_", g), + brackets = FALSE, sep = "_" + ) + for (i in seq_along(old_cor_names)) { + lc(out) <- change_simple(old_cor_names[i], new_cor_names[i], pars, dims) + } + # rename r-parameters + for (nlpar in unique(r$nlpar)) { + sub_r <- r[r$nlpar == nlpar, ] + old_r_name <- paste0("r_", g, usc(nlpar)) + new_r_name <- paste0("r_", g, usc(usc(nlpar))) + levels <- gsub("[ \t\r\n]", ".", attr(ranef, "levels")[[g]]) + index_names <- make_index_names(levels, sub_r$coef, dim = 2) + new_r_names <- paste0(new_r_name, index_names) + lc(out) <- change_simple( + old_r_name, new_r_names, pars, dims, + pnames = new_r_name + ) + } + } + out +} + +# change names of spline parameters fitted with brms <= 1.0.1 +# this became necessary after allowing smooths with multiple covariates +change_old_sm <- function(bterms, data, pars, dims) { + .change_old_sm <- function(bt) { + out <- list() + smef <- tidy_smef(bt, data) + if (nrow(smef)) { + p <- usc(combine_prefix(bt), "suffix") + old_smooths <- rename(paste0(p, smef$term)) + new_smooths <- rename(paste0(p, smef$label)) + old_sds_pars <- paste0("sds_", old_smooths) + new_sds_pars <- paste0("sds_", new_smooths, "_1") + old_s_pars <- paste0("s_", old_smooths) + new_s_pars <- paste0("s_", new_smooths, "_1") + for (i in seq_along(old_smooths)) { + lc(out) <- change_simple(old_sds_pars[i], new_sds_pars[i], pars, dims) + dim_s <- dims[[old_s_pars[i]]] + if (!is.null(dim_s)) { + new_s_par_indices <- paste0(new_s_pars[i], "[", seq_len(dim_s), "]") + lc(out) <- change_simple( + old_s_pars[i], new_s_par_indices, pars, dims, + pnames = new_s_pars[i] + ) + } + } + } + return(out) + } + + out <- list() + if (is.mvbrmsterms(bterms)) { + for (r in bterms$responses) { + c(out) <- .change_old_sm(bterms$terms[[r]]$dpars$mu) + } + } else if (is.brmsterms(bterms)) { + for (dp in names(bterms$dpars)) { + bt <- bterms$dpars[[dp]] + if (length(bt$nlpars)) { + for (nlp in names(bt$nlpars)) { + c(out) <- .change_old_sm(bt$nlpars[[nlp]]) + } + } else { + c(out) <- .change_old_sm(bt) + } + } + } + out +} + +# change names of monotonic effects fitted with brms <= 1.9.0 +# this became necessary after implementing monotonic interactions +change_old_mo <- function(bterms, data, pars) { + .change_old_mo <- function(bt) { + out <- list() + spef <- tidy_spef(bt, data) + has_mo <- lengths(spef$calls_mo) > 0 + if (!any(has_mo)) { + return(out) + } + spef <- spef[has_mo, ] + p <- usc(combine_prefix(bt)) + bmo_prefix <- paste0("bmo", p, "_") + bmo_regex <- paste0("^", bmo_prefix, "[^_]+$") + bmo_old <- pars[grepl(bmo_regex, pars)] + bmo_new <- paste0(bmo_prefix, spef$coef) + if (length(bmo_old) != length(bmo_new)) { + stop2("Restructuring failed. Please refit your ", + "model with the latest version of brms.") + } + for (i in seq_along(bmo_old)) { + pos <- grepl(paste0("^", bmo_old[i]), pars) + lc(out) <- clist(pos, fnames = bmo_new[i]) + } + simo_regex <- paste0("^simplex", p, "_[^_]+$") + simo_old_all <- pars[grepl(simo_regex, pars)] + simo_index <- get_matches("\\[[[:digit:]]+\\]$", simo_old_all) + simo_old <- unique(sub("\\[[[:digit:]]+\\]$", "", simo_old_all)) + simo_coef <- get_simo_labels(spef) + for (i in seq_along(simo_old)) { + regex_pos <- paste0("^", simo_old[i]) + pos <- grepl(regex_pos, pars) + simo_new <- paste0("simo", p, "_", simo_coef[i]) + simo_index_part <- simo_index[grepl(regex_pos, simo_old_all)] + simo_new <- paste0(simo_new, simo_index_part) + lc(out) <- clist(pos, fnames = simo_new) + } + return(out) + } + + out <- list() + if (is.mvbrmsterms(bterms)) { + for (r in bterms$responses) { + c(out) <- .change_old_mo(bterms$terms[[r]]$dpars$mu) + } + } else if (is.brmsterms(bterms)) { + for (dp in names(bterms$dpars)) { + bt <- bterms$dpars[[dp]] + if (length(bt$nlpars)) { + for (nlp in names(bt$nlpars)) { + c(out) <- .change_old_mo(bt$nlpars[[nlp]]) + } + } else { + c(out) <- .change_old_mo(bt) + } + } + } + out +} + +# between version 1.0 and 2.0 categorical models used +# the internal multivariate interface +change_old_categorical <- function(bterms, data, pars) { + stopifnot(is.brmsterms(bterms)) + if (!is_categorical(bterms$family)) { + return(list()) + } + # compute the old category names + respform <- bterms$respform + old_dpars <- model.response(model.frame(respform, data = data)) + old_dpars <- levels(factor(old_dpars)) + old_dpars <- make.names(old_dpars[-1], unique = TRUE) + old_dpars <- rename(old_dpars, ".", "x") + new_dpars <- bterms$family$dpars + stopifnot(length(old_dpars) == length(new_dpars)) + pos <- rep(FALSE, length(pars)) + new_pars <- pars + for (i in seq_along(old_dpars)) { + # not perfectly save but hopefully mostly correct + regex <- paste0("(?<=_)", old_dpars[i], "(?=_|\\[)") + pos <- pos | grepl(regex, pars, perl = TRUE) + new_pars <- gsub(regex, new_dpars[i], new_pars, perl = TRUE) + } + list(nlist(pos, fnames = new_pars[pos])) +} + +# as of brms 2.2 'mo' and 'me' terms are handled together +change_old_bsp <- function(pars) { + pos <- grepl("^(bmo|bme)_", pars) + if (!any(pos)) return(list()) + fnames <- gsub("^(bmo|bme)_", "bsp_", pars[pos]) + list(nlist(pos, fnames)) +} + +# prepare for renaming of parameters in old models +change_simple <- function(oldname, fnames, pars, dims, pnames = fnames) { + pos <- grepl(paste0("^", oldname), pars) + if (any(pos)) { + out <- nlist(pos, oldname, pnames, fnames, dims = dims[[oldname]]) + class(out) <- c("clist", "list") + } else { + out <- NULL + } + out +} + +# rescale old 'b' coefficients of monotonic effects +# to represent average instead of total differences +rescale_old_mo <- function(x, ...) { + UseMethod("rescale_old_mo") +} + +#' @export +rescale_old_mo.brmsfit <- function(x, ...) { + bterms <- brmsterms(x$formula) + rescale_old_mo(bterms, fit = x, ...) +} + +#' @export +rescale_old_mo.mvbrmsterms <- function(x, fit, ...) { + for (resp in x$responses) { + fit <- rescale_old_mo(x$terms[[resp]], fit = fit, ...) + } + fit +} + +#' @export +rescale_old_mo.brmsterms <- function(x, fit, ...) { + for (dp in names(x$dpars)) { + fit <- rescale_old_mo(x$dpars[[dp]], fit = fit, ...) + } + for (nlp in names(x$nlpars)) { + fit <- rescale_old_mo(x$nlpars[[nlp]], fit = fit, ...) + } + fit +} + +#' @export +rescale_old_mo.btnl <- function(x, fit, ...) { + fit +} + +#' @export +rescale_old_mo.btl <- function(x, fit, ...) { + spef <- tidy_spef(x, fit$data) + has_mo <- lengths(spef$Imo) > 0L + if (!any(has_mo)) { + return(fit) + } + warning2( + "The parameterization of monotonic effects has changed in brms 2.8.4 ", + "so that corresponding 'b' coefficients now represent average instead ", + "of total differences between categories. See vignette('brms_monotonic') ", + "for more details. Parameters of old models are adjusted automatically." + ) + p <- combine_prefix(x) + all_pars <- variables(fit) + chains <- fit$fit@sim$chains + for (i in which(has_mo)) { + bsp_par <- paste0("bsp", p, "_", spef$coef[i]) + simo_regex <- paste0(spef$coef[i], seq_along(spef$Imo[[i]])) + simo_regex <- paste0("simo", p, "_", simo_regex, "[") + simo_regex <- paste0("^", escape_all(simo_regex)) + # scaling factor by which to divide the old 'b' coefficients + D <- prod(ulapply(simo_regex, function(r) sum(grepl(r, all_pars)))) + for (j in seq_len(chains)) { + fit$fit@sim$samples[[j]][[bsp_par]] <- + fit$fit@sim$samples[[j]][[bsp_par]] / D + } + } + fit +} + +# update old families to work with the latest brms version +update_old_family <- function(x, ...) { + UseMethod("update_old_family") +} + +#' @export +update_old_family.default <- function(x, ...) { + validate_family(x) +} + +#' @export +update_old_family.brmsfamily <- function(x, ...) { + # new specials may have been added in new brms versions + family_info <- get(paste0(".family_", x$family))() + x$specials <- family_info$specials + x +} + +#' @export +update_old_family.customfamily <- function(x, ...) { + if (!is.null(x$predict)) { + x$posterior_predict <- x$predict + x$predict <- NULL + } + if (!is.null(x$fitted)) { + x$posterior_epred <- x$fitted + x$fitted <- NULL + } + x +} + +#' @export +update_old_family.mixfamily <- function(x, ...) { + x$mix <- lapply(x$mix, update_old_family, ...) + x +} + +#' @export +update_old_family.brmsformula <- function(x, ...) { + x$family <- update_old_family(x$family, ...) + x +} + +#' @export +update_old_family.mvbrmsformula <- function(x, ...) { + x$forms <- lapply(x$forms, update_old_family, ...) + x +} + +stop_parameterization_changed <- function(family, version) { + stop2( + "The parameterization of '", family, "' models has changed in brms ", + version, ". Please refit your model with the current version of brms." + ) +} + +check_old_nl_dpars <- function(bterms) { + .check_nl_dpars <- function(x) { + stopifnot(is.brmsterms(x)) + non_mu_dpars <- x$dpars[names(x$dpars) != "mu"] + if (any(ulapply(non_mu_dpars, is.btnl))) { + stop2( + "Non-linear parameters are global within univariate models ", + "as of version 2.3.7. Please refit your model with the ", + "latest version of brms." + ) + } + return(TRUE) + } + if (is.mvbrmsterms(bterms)) { + lapply(bterms$terms, .check_nl_dpars) + } else { + .check_nl_dpars(bterms) + } + TRUE +} diff -Nru r-cran-brms-2.16.3/R/stan-helpers.R r-cran-brms-2.17.0/R/stan-helpers.R --- r-cran-brms-2.16.3/R/stan-helpers.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/stan-helpers.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,259 +1,263 @@ -# unless otherwise specified, functions return a named list -# of Stan code snippets to be pasted together later on - -# define Stan functions or globally used transformed data -# TODO: refactor to not require extraction of information from all model parts -stan_global_defs <- function(bterms, prior, ranef, threads) { - families <- family_names(bterms) - links <- family_info(bterms, "link") - unique_combs <- !duplicated(paste0(families, ":", links)) - families <- families[unique_combs] - links <- links[unique_combs] - out <- list() - # TODO: detect these links in all dpars not just in 'mu' - if (any(links == "cauchit")) { - str_add(out$fun) <- " #include 'fun_cauchit.stan'\n" - } else if (any(links == "cloglog")) { - str_add(out$fun) <- " #include 'fun_cloglog.stan'\n" - } else if (any(links == "softplus")) { - str_add(out$fun) <- " #include 'fun_softplus.stan'\n" - } else if (any(links == "squareplus")) { - str_add(out$fun) <- " #include 'fun_squareplus.stan'\n" - } - special <- get_special_prior(prior) - if (!isNULL(lapply(special, "[[", "horseshoe"))) { - str_add(out$fun) <- " #include 'fun_horseshoe.stan'\n" - } - if (!isNULL(lapply(special, "[[", "R2D2"))) { - str_add(out$fun) <- " #include 'fun_r2d2.stan'\n" - } - if (nrow(ranef)) { - r_funs <- NULL - ids <- unique(ranef$id) - for (id in ids) { - r <- ranef[ranef$id == id, ] - if (nrow(r) > 1L && r$cor[1]) { - if (nzchar(r$by[1])) { - if (nzchar(r$cov[1])) { - c(r_funs) <- " #include 'fun_scale_r_cor_by_cov.stan'\n" - } else { - c(r_funs) <- " #include 'fun_scale_r_cor_by.stan'\n" - } - } else { - if (nzchar(r$cov[1])) { - c(r_funs) <- " #include 'fun_scale_r_cor_cov.stan'\n" - } else { - c(r_funs) <- " #include 'fun_scale_r_cor.stan'\n" - } - } - } - } - str_add(out$fun) <- collapse(unique(r_funs)) - } - family_files <- family_info(bterms, "include") - if (length(family_files)) { - str_add(out$fun) <- cglue(" #include '{family_files}'\n") - } - is_ordinal <- ulapply(families, is_ordinal) - if (any(is_ordinal)) { - ord_fams <- families[is_ordinal] - ord_links <- links[is_ordinal] - for (i in seq_along(ord_fams)) { - str_add(out$fun) <- stan_ordinal_lpmf(ord_fams[i], ord_links[i]) - } - } - uni_mo <- ulapply(get_effect(bterms, "sp"), attr, "uni_mo") - if (length(uni_mo)) { - str_add(out$fun) <- " #include 'fun_monotonic.stan'\n" - } - if (length(get_effect(bterms, "gp"))) { - # TODO: include functions selectively - str_add(out$fun) <- " #include 'fun_gaussian_process.stan'\n" - str_add(out$fun) <- " #include 'fun_gaussian_process_approx.stan'\n" - str_add(out$fun) <- " #include 'fun_which_range.stan'\n" - } - acterms <- get_effect(bterms, "ac") - acefs <- lapply(acterms, tidy_acef) - if (any(ulapply(acefs, has_ac_subset, dim = "time", cov = TRUE))) { - # TODO: include functions selectively - str_add(out$fun) <- glue( - " #include 'fun_normal_time.stan'\n", - " #include 'fun_student_t_time.stan'\n", - " #include 'fun_scale_time_err.stan'\n", - " #include 'fun_cholesky_cor_ar1.stan'\n", - " #include 'fun_cholesky_cor_ma1.stan'\n", - " #include 'fun_cholesky_cor_arma1.stan'\n", - " #include 'fun_cholesky_cor_cosy.stan'\n" - ) - } - if (any(ulapply(acefs, has_ac_class, "sar"))) { - if ("gaussian" %in% families) { - str_add(out$fun) <- glue( - " #include 'fun_normal_lagsar.stan'\n", - " #include 'fun_normal_errorsar.stan'\n" - ) - } - if ("student" %in% families) { - str_add(out$fun) <- glue( - " #include 'fun_student_t_lagsar.stan'\n", - " #include 'fun_student_t_errorsar.stan'\n" - ) - } - } - if (any(ulapply(acefs, has_ac_class, "car"))) { - str_add(out$fun) <- glue( - " #include 'fun_sparse_car_lpdf.stan'\n", - " #include 'fun_sparse_icar_lpdf.stan'\n" - ) - } - if (any(ulapply(acefs, has_ac_class, "fcor"))) { - str_add(out$fun) <- glue( - " #include 'fun_normal_fcor.stan'\n", - " #include 'fun_student_t_fcor.stan'\n" - ) - } - if (use_threading(threads)) { - str_add(out$fun) <- " #include 'fun_sequence.stan'\n" - } - out -} - -# link function in Stan language -# @param link name of the link function -stan_link <- function(link) { - switch(link, - identity = "", - log = "log", - logm1 = "logm1", - inverse = "inv", - sqrt = "sqrt", - "1/mu^2" = "inv_square", - logit = "logit", - probit = "inv_Phi", - probit_approx = "inv_Phi", - cloglog = "cloglog", - cauchit = "cauchit", - tan_half = "tan_half", - log1p = "log1p", - softplus = "log_expm1", - squareplus = "inv_squareplus" - ) -} - -# inverse link in Stan language -# @param link name of the link function -stan_ilink <- function(link) { - switch(link, - identity = "", - log = "exp", - logm1 = "expp1", - inverse = "inv", - sqrt = "square", - "1/mu^2" = "inv_sqrt", - logit = "inv_logit", - probit = "Phi", - probit_approx = "Phi_approx", - cloglog = "inv_cloglog", - cauchit = "inv_cauchit", - tan_half = "inv_tan_half", - log1p = "expm1", - softplus = "log1p_exp", - squareplus = "squareplus" - ) -} - -# define a vector in Stan language -stan_vector <- function(...) { - paste0("transpose([", paste0(c(...), collapse = ", "), "])") -} - -# prepare Stan code for correlations in the generated quantities block -# @param cor name of the correlation vector -# @param ncol number of columns of the correlation matrix -stan_cor_gen_comp <- function(cor, ncol) { - Cor <- paste0(toupper(substring(cor, 1, 1)), substring(cor, 2)) - glue( - " // extract upper diagonal of correlation matrix\n", - " for (k in 1:{ncol}) {{\n", - " for (j in 1:(k - 1)) {{\n", - " {cor}[choose(k - 1, 2) + j] = {Cor}[j, k];\n", - " }}\n", - " }}\n" - ) -} - -# indicates if a family-link combination has a built in -# function in Stan (such as binomial_logit) -# @param family a list with elements 'family' and 'link' -# ideally a (brms)family object -# @param bterms brmsterms object of the univariate model -stan_has_built_in_fun <- function(family, bterms) { - stopifnot(all(c("family", "link") %in% names(family))) - stopifnot(is.brmsterms(bterms)) - cens_or_trunc <- stan_log_lik_adj(bterms$adforms, c("cens", "trunc")) - link <- family[["link"]] - dpar <- family[["dpar"]] - if (cens_or_trunc) { - # only few families have special lcdf and lccdf functions - out <- has_built_in_fun(family, link, cdf = TRUE) || - has_built_in_fun(bterms, link, dpar = dpar, cdf = TRUE) - } else { - out <- has_built_in_fun(family, link) || - has_built_in_fun(bterms, link, dpar = dpar) - } - out -} - -# get all variable names accepted in Stan -stan_all_vars <- function(x) { - x <- gsub("\\.", "+", x) - all_vars(x) -} - -# transform names to be used as variable names in Stan -make_stan_names <- function(x) { - gsub("\\.|_", "", make.names(x, unique = TRUE)) -} - -# functions to handle indexing when threading -stan_slice <- function(threads) { - str_if(use_threading(threads), "[start:end]") -} - -stan_nn <- function(threads) { - str_if(use_threading(threads), "[nn]", "[n]") -} - -stan_nn_def <- function(threads) { - str_if(use_threading(threads), " int nn = n + start - 1;\n") -} - -stan_nn_regex <- function() { - "\\[((n)|(nn))\\]" -} - -# clean up arguments for partial_log_lik -# @param ... strings containing arguments of the form ', type identifier' -# @return named list of two elements: -# typed: types + identifiers for use in the function header -# plain: identifiers only for use in the function call -stan_clean_pll_args <- function(...) { - args <- paste0(...) - # split up header to remove duplicates - typed <- unlist(strsplit(args, ", +"))[-1] - typed <- unique(typed) - plain <- rm_wsp(get_matches(" [^ ]+$", typed)) - typed <- collapse(", ", typed) - plain <- collapse(", ", plain) - nlist(typed, plain) -} - -# prepare a string to be used as comment in Stan -stan_comment <- function(comment, wsp = 2) { - comment <- as.character(comment) - wsp <- wsp(nsp = wsp) - if (!length(comment)) { - return(character(0)) - } - ifelse(nzchar(comment), paste0(wsp, "// ", comment), "") -} +# unless otherwise specified, functions return a named list +# of Stan code snippets to be pasted together later on + +# define Stan functions or globally used transformed data +# TODO: refactor to not require extraction of information from all model parts +stan_global_defs <- function(bterms, prior, ranef, threads) { + families <- family_names(bterms) + links <- family_info(bterms, "link") + unique_combs <- !duplicated(paste0(families, ":", links)) + families <- families[unique_combs] + links <- links[unique_combs] + out <- list() + # TODO: detect these links in all dpars not just in 'mu' + if (any(links == "cauchit")) { + str_add(out$fun) <- " #include 'fun_cauchit.stan'\n" + } else if (any(links == "cloglog")) { + str_add(out$fun) <- " #include 'fun_cloglog.stan'\n" + } else if (any(links == "softplus")) { + str_add(out$fun) <- " #include 'fun_softplus.stan'\n" + } else if (any(links == "squareplus")) { + str_add(out$fun) <- " #include 'fun_squareplus.stan'\n" + } else if (any(links == "softit")) { + str_add(out$fun) <- " #include 'fun_softit.stan'\n" + } + special <- get_special_prior(prior) + if (!isNULL(lapply(special, "[[", "horseshoe"))) { + str_add(out$fun) <- " #include 'fun_horseshoe.stan'\n" + } + if (!isNULL(lapply(special, "[[", "R2D2"))) { + str_add(out$fun) <- " #include 'fun_r2d2.stan'\n" + } + if (nrow(ranef)) { + r_funs <- NULL + ids <- unique(ranef$id) + for (id in ids) { + r <- ranef[ranef$id == id, ] + if (nrow(r) > 1L && r$cor[1]) { + if (nzchar(r$by[1])) { + if (nzchar(r$cov[1])) { + c(r_funs) <- " #include 'fun_scale_r_cor_by_cov.stan'\n" + } else { + c(r_funs) <- " #include 'fun_scale_r_cor_by.stan'\n" + } + } else { + if (nzchar(r$cov[1])) { + c(r_funs) <- " #include 'fun_scale_r_cor_cov.stan'\n" + } else { + c(r_funs) <- " #include 'fun_scale_r_cor.stan'\n" + } + } + } + } + str_add(out$fun) <- collapse(unique(r_funs)) + } + family_files <- family_info(bterms, "include") + if (length(family_files)) { + str_add(out$fun) <- cglue(" #include '{family_files}'\n") + } + is_ordinal <- ulapply(families, is_ordinal) + if (any(is_ordinal)) { + ord_fams <- families[is_ordinal] + ord_links <- links[is_ordinal] + for (i in seq_along(ord_fams)) { + str_add(out$fun) <- stan_ordinal_lpmf(ord_fams[i], ord_links[i]) + } + } + uni_mo <- ulapply(get_effect(bterms, "sp"), attr, "uni_mo") + if (length(uni_mo)) { + str_add(out$fun) <- " #include 'fun_monotonic.stan'\n" + } + if (length(get_effect(bterms, "gp"))) { + # TODO: include functions selectively + str_add(out$fun) <- " #include 'fun_gaussian_process.stan'\n" + str_add(out$fun) <- " #include 'fun_gaussian_process_approx.stan'\n" + str_add(out$fun) <- " #include 'fun_which_range.stan'\n" + } + acterms <- get_effect(bterms, "ac") + acefs <- lapply(acterms, tidy_acef) + if (any(ulapply(acefs, has_ac_subset, dim = "time", cov = TRUE))) { + # TODO: include functions selectively + str_add(out$fun) <- glue( + " #include 'fun_normal_time.stan'\n", + " #include 'fun_student_t_time.stan'\n", + " #include 'fun_scale_time_err.stan'\n", + " #include 'fun_cholesky_cor_ar1.stan'\n", + " #include 'fun_cholesky_cor_ma1.stan'\n", + " #include 'fun_cholesky_cor_arma1.stan'\n", + " #include 'fun_cholesky_cor_cosy.stan'\n" + ) + } + if (any(ulapply(acefs, has_ac_class, "sar"))) { + if ("gaussian" %in% families) { + str_add(out$fun) <- glue( + " #include 'fun_normal_lagsar.stan'\n", + " #include 'fun_normal_errorsar.stan'\n" + ) + } + if ("student" %in% families) { + str_add(out$fun) <- glue( + " #include 'fun_student_t_lagsar.stan'\n", + " #include 'fun_student_t_errorsar.stan'\n" + ) + } + } + if (any(ulapply(acefs, has_ac_class, "car"))) { + str_add(out$fun) <- glue( + " #include 'fun_sparse_car_lpdf.stan'\n", + " #include 'fun_sparse_icar_lpdf.stan'\n" + ) + } + if (any(ulapply(acefs, has_ac_class, "fcor"))) { + str_add(out$fun) <- glue( + " #include 'fun_normal_fcor.stan'\n", + " #include 'fun_student_t_fcor.stan'\n" + ) + } + if (use_threading(threads)) { + str_add(out$fun) <- " #include 'fun_sequence.stan'\n" + } + out +} + +# link function in Stan language +# @param link name of the link function +stan_link <- function(link) { + switch(link, + identity = "", + log = "log", + logm1 = "logm1", + inverse = "inv", + sqrt = "sqrt", + "1/mu^2" = "inv_square", + logit = "logit", + probit = "inv_Phi", + probit_approx = "inv_Phi", + cloglog = "cloglog", + cauchit = "cauchit", + tan_half = "tan_half", + log1p = "log1p", + softplus = "log_expm1", + squareplus = "inv_squareplus", + softit = "softit" + ) +} + +# inverse link in Stan language +# @param link name of the link function +stan_inv_link <- function(link) { + switch(link, + identity = "", + log = "exp", + logm1 = "expp1", + inverse = "inv", + sqrt = "square", + "1/mu^2" = "inv_sqrt", + logit = "inv_logit", + probit = "Phi", + probit_approx = "Phi_approx", + cloglog = "inv_cloglog", + cauchit = "inv_cauchit", + tan_half = "inv_tan_half", + log1p = "expm1", + softplus = "log1p_exp", + squareplus = "squareplus", + softit = "inv_softit" + ) +} + +# define a vector in Stan language +stan_vector <- function(...) { + paste0("transpose([", paste0(c(...), collapse = ", "), "])") +} + +# prepare Stan code for correlations in the generated quantities block +# @param cor name of the correlation vector +# @param ncol number of columns of the correlation matrix +stan_cor_gen_comp <- function(cor, ncol) { + Cor <- paste0(toupper(substring(cor, 1, 1)), substring(cor, 2)) + glue( + " // extract upper diagonal of correlation matrix\n", + " for (k in 1:{ncol}) {{\n", + " for (j in 1:(k - 1)) {{\n", + " {cor}[choose(k - 1, 2) + j] = {Cor}[j, k];\n", + " }}\n", + " }}\n" + ) +} + +# indicates if a family-link combination has a built in +# function in Stan (such as binomial_logit) +# @param family a list with elements 'family' and 'link' +# ideally a (brms)family object +# @param bterms brmsterms object of the univariate model +stan_has_built_in_fun <- function(family, bterms) { + stopifnot(all(c("family", "link") %in% names(family))) + stopifnot(is.brmsterms(bterms)) + cens_or_trunc <- stan_log_lik_adj(bterms$adforms, c("cens", "trunc")) + link <- family[["link"]] + dpar <- family[["dpar"]] + if (cens_or_trunc) { + # only few families have special lcdf and lccdf functions + out <- has_built_in_fun(family, link, cdf = TRUE) || + has_built_in_fun(bterms, link, dpar = dpar, cdf = TRUE) + } else { + out <- has_built_in_fun(family, link) || + has_built_in_fun(bterms, link, dpar = dpar) + } + out +} + +# get all variable names accepted in Stan +stan_all_vars <- function(x) { + x <- gsub("\\.", "+", x) + all_vars(x) +} + +# transform names to be used as variable names in Stan +make_stan_names <- function(x) { + gsub("\\.|_", "", make.names(x, unique = TRUE)) +} + +# functions to handle indexing when threading +stan_slice <- function(threads) { + str_if(use_threading(threads), "[start:end]") +} + +stan_nn <- function(threads) { + str_if(use_threading(threads), "[nn]", "[n]") +} + +stan_nn_def <- function(threads) { + str_if(use_threading(threads), " int nn = n + start - 1;\n") +} + +stan_nn_regex <- function() { + "\\[((n)|(nn))\\]" +} + +# clean up arguments for partial_log_lik +# @param ... strings containing arguments of the form ', type identifier' +# @return named list of two elements: +# typed: types + identifiers for use in the function header +# plain: identifiers only for use in the function call +stan_clean_pll_args <- function(...) { + args <- paste0(...) + # split up header to remove duplicates + typed <- unlist(strsplit(args, ", +"))[-1] + typed <- unique(typed) + plain <- rm_wsp(get_matches(" [^ ]+$", typed)) + typed <- collapse(", ", typed) + plain <- collapse(", ", plain) + nlist(typed, plain) +} + +# prepare a string to be used as comment in Stan +stan_comment <- function(comment, wsp = 2) { + comment <- as.character(comment) + wsp <- wsp(nsp = wsp) + if (!length(comment)) { + return(character(0)) + } + ifelse(nzchar(comment), paste0(wsp, "// ", comment), "") +} diff -Nru r-cran-brms-2.16.3/R/stan-likelihood.R r-cran-brms-2.17.0/R/stan-likelihood.R --- r-cran-brms-2.16.3/R/stan-likelihood.R 2021-11-22 15:22:36.000000000 +0000 +++ r-cran-brms-2.17.0/R/stan-likelihood.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,11 +1,11 @@ -# unless otherwise specified, functions return a single character +# unless otherwise specified, functions return a single character # string defining the likelihood of the model in Stan language stan_log_lik <- function(x, ...) { UseMethod("stan_log_lik") } -# Stan code for the model likelihood +# Stan code for the model likelihood # @param bterms object of class brmsterms # @param data data passed by the user # @param mix optional mixture component ID @@ -35,9 +35,9 @@ if (grepl(stan_nn_regex(), out) && !nzchar(mix)) { # loop over likelihood if it cannot be vectorized out <- paste0( - " for (n in 1:N", resp, ") {\n", - stan_nn_def(threads), - " ", out, + " for (n in 1:N", resp, ") {\n", + stan_nn_def(threads), + " ", out, " }\n" ) } @@ -56,13 +56,13 @@ sbterms$dpars <- sbterms$dpars[dp_ids == i] sbterms$fdpars <- sbterms$fdpars[fdp_ids == i] ll[i] <- stan_log_lik( - x$mix[[i]], sbterms, mix = i, ptheta = ptheta, + x$mix[[i]], sbterms, mix = i, ptheta = ptheta, threads = threads, ... ) } resp <- usc(combine_prefix(bterms)) n <- stan_nn(threads) - has_weights <- is.formula(bterms$adforms$weights) + has_weights <- is.formula(bterms$adforms$weights) weights <- str_if(has_weights, glue("weights{resp}{n} * ")) out <- glue( " // likelihood of the mixture model\n", @@ -88,7 +88,7 @@ if (x$rescor) { out <- stan_log_lik(as.brmsterms(x), ...) } else { - out <- ulapply(x$terms, stan_log_lik, ...) + out <- ulapply(x$terms, stan_log_lik, ...) } out } @@ -118,9 +118,9 @@ tp <- tp() out <- glue( "// special treatment of censored data\n", - s, "if (cens{resp}{n} == 0) {{\n", + s, "if (cens{resp}{n} == 0) {{\n", s, "{tp}{w}{ll$dist}_{lpdf}({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n", - s, "}} else if (cens{resp}{n} == 1) {{\n", + s, "}} else if (cens{resp}{n} == 1) {{\n", s, "{tp}{w}{ll$dist}_lccdf({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n", s, "}} else if (cens{resp}{n} == -1) {{\n", s, "{tp}{w}{ll$dist}_lcdf({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n" @@ -129,9 +129,9 @@ # interval censoring is required str_add(out) <- glue( s, "}} else if (cens{resp}{n} == 2) {{\n", - s, "{tp}{w}log_diff_exp(\n", - s, " {ll$dist}_lcdf(rcens{resp}{n}{ll$shift} | {ll$args}),\n", - s, " {ll$dist}_lcdf({Y}{resp}{n}{ll$shift} | {ll$args})\n", + s, "{tp}{w}log_diff_exp(\n", + s, " {ll$dist}_lcdf(rcens{resp}{n}{ll$shift} | {ll$args}),\n", + s, " {ll$dist}_lcdf({Y}{resp}{n}{ll$shift} | {ll$args})\n", s, " ){tr};\n" ) } @@ -147,17 +147,17 @@ Y <- stan_log_lik_Y_name(bterms) n <- stan_nn(threads) glue( - "{tp()}weights{resp}{n} * ({ll$dist}_{lpdf}", + "{tp()}weights{resp}{n} * ({ll$dist}_{lpdf}", "({Y}{resp}{n}{ll$shift} | {ll$args}){tr});\n" ) } # likelihood of a single mixture component -stan_log_lik_mix <- function(ll, bterms, data, mix, ptheta, threads, +stan_log_lik_mix <- function(ll, bterms, data, mix, ptheta, threads, normalize, resp = "", ...) { stopifnot(is.sdist(ll)) theta <- str_if(ptheta, - glue("theta{mix}{resp}[n]"), + glue("theta{mix}{resp}[n]"), glue("log(theta{mix}{resp})") ) tr <- stan_log_lik_trunc(ll, bterms, data, resp = resp, threads = threads) @@ -170,10 +170,10 @@ s <- wsp(nsp = 4) out <- glue( "// special treatment of censored data\n", - s, "if (cens{resp}{n} == 0) {{\n", - s, " ps[{mix}] = {theta} + ", + s, "if (cens{resp}{n} == 0) {{\n", + s, " ps[{mix}] = {theta} + ", "{ll$dist}_{lpdf}({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n", - s, "}} else if (cens{resp}{n} == 1) {{\n", + s, "}} else if (cens{resp}{n} == 1) {{\n", s, " ps[{mix}] = {theta} + ", "{ll$dist}_lccdf({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n", s, "}} else if (cens{resp}{n} == -1) {{\n", @@ -184,25 +184,25 @@ # interval censoring is required str_add(out) <- glue( s, "}} else if (cens{resp}{n} == 2) {{\n", - s, " ps[{mix}] = {theta} + log_diff_exp(\n", - s, " {ll$dist}_lcdf(rcens{resp}{n}{ll$shift} | {ll$args}),\n", - s, " {ll$dist}_lcdf({Y}{resp}{n}{ll$shift} | {ll$args})\n", + s, " ps[{mix}] = {theta} + log_diff_exp(\n", + s, " {ll$dist}_lcdf(rcens{resp}{n}{ll$shift} | {ll$args}),\n", + s, " {ll$dist}_lcdf({Y}{resp}{n}{ll$shift} | {ll$args})\n", s, " ){tr};\n" ) } str_add(out) <- glue(s, "}}\n") } else { out <- glue( - "ps[{mix}] = {theta} + ", + "ps[{mix}] = {theta} + ", "{ll$dist}_{lpdf}({Y}{resp}{n}{ll$shift} | {ll$args}){tr};\n" - ) + ) } out } # truncated part of the likelihood # @param short use the T[, ] syntax? -stan_log_lik_trunc <- function(ll, bterms, data, threads, resp = "", +stan_log_lik_trunc <- function(ll, bterms, data, threads, resp = "", short = FALSE) { stopifnot(is.sdist(ll)) bounds <- trunc_bounds(bterms, data = data) @@ -257,11 +257,16 @@ # @param reqn will the likelihood be wrapped in a loop over n? # @param dpars optional names of distributional parameters to be prepared # if not specified will prepare all distributional parameters -stan_log_lik_dpars <- function(bterms, reqn, resp = "", mix = "", dpars = NULL) { +stan_log_lik_dpars <- function(bterms, reqn, resp = "", mix = "", dpars = NULL, + type = NULL) { if (is.null(dpars)) { - dpars <- paste0(valid_dpars(bterms), mix) + dpars <- paste0(valid_dpars(bterms, type = type), mix) } - is_pred <- dpars %in% c("mu", names(bterms$dpars)) + pred_dpars <- names(bterms$dpars) + if (is_equal(type, "multi")) { + pred_dpars <- unique(dpar_class(pred_dpars, bterms)) + } + is_pred <- dpars %in% pred_dpars out <- paste0(dpars, resp, ifelse(reqn & is_pred, "[n]", "")) named_list(dpars, out) } @@ -288,14 +293,14 @@ } # add 'se' to 'sigma' within the Stan likelihood -stan_log_lik_add_se <- function(sigma, bterms, reqn, resp = "", +stan_log_lik_add_se <- function(sigma, bterms, reqn, resp = "", threads = NULL) { if (!is.formula(bterms$adforms$se)) { - return(sigma) + return(sigma) } nse <- str_if(reqn, stan_nn(threads), stan_slice(threads)) if (no_sigma(bterms)) { - sigma <- glue("se{resp}{nse}") + sigma <- glue("se{resp}{nse}") } else { sigma <- glue("sqrt(square({sigma}) + se2{resp}{nse})") } @@ -304,7 +309,7 @@ # multiply 'dpar' by the 'rate' denominator within the Stan likelihood # @param log add the rate denominator on the log scale if sensible? -stan_log_lik_multiply_rate_denom <- function(dpar, bterms, reqn, resp = "", +stan_log_lik_multiply_rate_denom <- function(dpar, bterms, reqn, resp = "", log = FALSE, transform = NULL) { dpar_transform <- dpar if (!is.null(transform)) { @@ -347,7 +352,7 @@ reqn <- stan_log_lik_adj(bterms) || nzchar(mix) p <- stan_log_lik_dpars(bterms, reqn, resp, mix) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, reqn, resp, threads) - out <- sdist("normal", p$mu, p$sigma) + out <- sdist("normal", p$mu, p$sigma) } out } @@ -367,7 +372,7 @@ v <- c("chol_cor", "se2", "nobs_tg", "begin_tg", "end_tg") p[v] <- as.list(paste0(v, resp)) sfx <- str_if("sigma" %in% names(bterms$dpars), "het", "hom") - sdist(glue("normal_time_{sfx}"), + sdist(glue("normal_time_{sfx}"), p$mu, p$sigma, p$chol_cor, p$se2, p$nobs_tg, p$begin_tg, p$end_tg ) @@ -393,7 +398,7 @@ sdist("normal_lagsar", p$mu, p$sigma, p$lagsar, p$Msar, p$eigenMsar) } -stan_log_lik_gaussian_errorsar <- function(bterms, resp = "", mix = "", +stan_log_lik_gaussian_errorsar <- function(bterms, resp = "", mix = "", threads = NULL, ...) { p <- stan_log_lik_dpars(bterms, FALSE, resp, mix) p$sigma <- stan_log_lik_add_se(p$sigma, bterms, FALSE, resp, threads) @@ -426,7 +431,7 @@ v <- c("chol_cor", "se2", "nobs_tg", "begin_tg", "end_tg") p[v] <- as.list(paste0(v, resp)) sfx <- str_if("sigma" %in% names(bterms$dpars), "het", "hom") - sdist(glue("student_t_time_{sfx}"), + sdist(glue("student_t_time_{sfx}"), p$nu, p$mu, p$sigma, p$chol_cor, p$se2, p$nobs_tg, p$begin_tg, p$end_tg ) @@ -449,7 +454,7 @@ p$sigma <- stan_log_lik_add_se(p$sigma, bterms, FALSE, resp, threads) v <- c("lagsar", "Msar", "eigenMsar") p[v] <- as.list(paste0(v, resp)) - sdist("student_t_lagsar", p$nu, p$mu, p$sigma, + sdist("student_t_lagsar", p$nu, p$mu, p$sigma, p$lagsar, p$Msar, p$eigenMsar) } @@ -459,7 +464,7 @@ p$sigma <- stan_log_lik_add_se(p$sigma, bterms, FALSE, resp, threads) v <- c("errorsar", "Msar", "eigenMsar") p[v] <- as.list(paste0(v, resp)) - sdist("student_t_errorsar", p$nu, p$mu, p$sigma, + sdist("student_t_errorsar", p$nu, p$mu, p$sigma, p$errorsar, p$Msar, p$eigenMsar) } @@ -544,7 +549,7 @@ out } -stan_log_lik_geometric <- function(bterms, resp = "", mix = "", threads = NULL, +stan_log_lik_geometric <- function(bterms, resp = "", mix = "", threads = NULL, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, resp = resp, threads = threads) @@ -561,7 +566,7 @@ } } -stan_log_lik_binomial <- function(bterms, resp = "", mix = "", threads = NULL, +stan_log_lik_binomial <- function(bterms, resp = "", mix = "", threads = NULL, ...) { reqn <- stan_log_lik_adj(bterms) || nzchar(mix) p <- stan_log_lik_dpars(bterms, reqn, resp, mix) @@ -571,7 +576,19 @@ sdist(lpdf, p$trials, p$mu) } -stan_log_lik_bernoulli <- function(bterms, resp = "", mix = "", threads = NULL, +stan_log_lik_beta_binomial <- function(bterms, resp = "", mix = "", + threads = NULL, ...) { + p <- stan_log_lik_dpars(bterms, TRUE, resp, mix) + n <- stan_nn(threads) + sdist( + "beta_binomial", + paste0("trials", resp, n), + paste0(p$mu, " * ", p$phi), + paste0("(1 - ", p$mu, ") * ", p$phi) + ) +} + +stan_log_lik_bernoulli <- function(bterms, resp = "", mix = "", threads = NULL, ...) { if (use_glm_primitive(bterms)) { p <- args_glm_primitive(bterms$dpars$mu, resp = resp, threads = threads) @@ -629,7 +646,7 @@ reqn <- stan_log_lik_adj(bterms) || nzchar(mix) p <- stan_log_lik_dpars(bterms, reqn, resp, mix) sdist( - "exp_mod_normal", paste0(p$mu, " - ", p$beta), + "exp_mod_normal", paste0(p$mu, " - ", p$beta), p$sigma, paste0("inv(", p$beta, ")") ) } @@ -656,7 +673,7 @@ paste0("phi", mix) %in% names(bterms$dpars) p <- stan_log_lik_dpars(bterms, reqn, resp, mix) sdist("beta", - paste0(p$mu, " * ", p$phi), + paste0(p$mu, " * ", p$phi), paste0("(1 - ", p$mu, ") * ", p$phi) ) } @@ -688,7 +705,7 @@ p <- args_glm_primitive(bterms$dpars$mu, resp = resp, threads = threads) out <- sdist("ordered_logistic_glm", p$x, p$beta, p$alpha) return(out) - } + } stan_log_lik_ordinal(bterms, resp, mix, threads, ...) } @@ -697,12 +714,12 @@ stan_log_lik_ordinal(bterms, resp, mix, threads, ...) } -stan_log_lik_cratio <- function(bterms, resp = "", mix = "", +stan_log_lik_cratio <- function(bterms, resp = "", mix = "", threads = NULL, ...) { stan_log_lik_ordinal(bterms, resp, mix, threads, ...) } -stan_log_lik_acat <- function(bterms, resp = "", mix = "", +stan_log_lik_acat <- function(bterms, resp = "", mix = "", threads = NULL, ...) { stan_log_lik_ordinal(bterms, resp, mix, threads, ...) } @@ -710,21 +727,21 @@ stan_log_lik_categorical <- function(bterms, resp = "", mix = "", ...) { stopifnot(bterms$family$link == "logit") stopifnot(!isTRUE(nzchar(mix))) # mixture models are not allowed - p <- stan_log_lik_dpars(bterms, TRUE, resp, mix, dpars = "mu") + p <- stan_log_lik_dpars(bterms, TRUE, resp, mix, dpars = "mu", type = "multi") sdist("categorical_logit", p$mu) } stan_log_lik_multinomial <- function(bterms, resp = "", mix = "", ...) { stopifnot(bterms$family$link == "logit") stopifnot(!isTRUE(nzchar(mix))) # mixture models are not allowed - p <- stan_log_lik_dpars(bterms, TRUE, resp, mix, dpars = "mu") + p <- stan_log_lik_dpars(bterms, TRUE, resp, mix, dpars = "mu", type = "multi") sdist("multinomial_logit2", p$mu) } stan_log_lik_dirichlet <- function(bterms, resp = "", mix = "", ...) { stopifnot(bterms$family$link == "logit") stopifnot(!isTRUE(nzchar(mix))) # mixture models are not allowed - mu <- stan_log_lik_dpars(bterms, TRUE, resp, mix, dpars = "mu")$mu + mu <- stan_log_lik_dpars(bterms, TRUE, resp, mix, dpars = "mu", type = "multi")$mu reqn <- glue("phi{mix}") %in% names(bterms$dpars) phi <- stan_log_lik_dpars(bterms, reqn, resp, mix, dpars = "phi")$phi sdist("dirichlet_logit", mu, phi) @@ -732,11 +749,20 @@ stan_log_lik_dirichlet2 <- function(bterms, resp = "", mix = "", ...) { stopifnot(!isTRUE(nzchar(mix))) # mixture models are not allowed - mu <- stan_log_lik_dpars(bterms, TRUE, resp, mix, dpars = "mu")$mu + mu <- stan_log_lik_dpars(bterms, TRUE, resp, mix, dpars = "mu", type = "multi")$mu sdist("dirichlet", mu) } -stan_log_lik_ordinal <- function(bterms, resp = "", mix = "", +stan_log_lik_logistic_normal <- function(bterms, resp = "", mix = "", ...) { + stopifnot(bterms$family$link == "identity") + stopifnot(!isTRUE(nzchar(mix))) # mixture models are not allowed + p <- stan_log_lik_dpars(bterms, TRUE, resp, mix, type = "multi") + p$Llncor <- glue("Llncor{mix}{resp}") + p$refcat <- get_refcat(bterms$family, int = TRUE) + sdist("logistic_normal_cholesky_cor", p$mu, p$sigma, p$Llncor, p$refcat) +} + +stan_log_lik_ordinal <- function(bterms, resp = "", mix = "", threads = NULL, ...) { prefix <- paste0(str_if(nzchar(mix), paste0("_mu", mix)), resp) p <- stan_log_lik_dpars(bterms, TRUE, resp, mix) @@ -745,7 +771,7 @@ lpdf <- "ordered_logistic" p[grepl("^disc", names(p))] <- NULL } else { - lpdf <- paste0(bterms$family$family, "_", bterms$family$link) + lpdf <- paste0(bterms$family$family, "_", bterms$family$link) } if (has_thres_groups(bterms)) { str_add(lpdf) <- "_merged" @@ -761,7 +787,7 @@ } if (has_cs(bterms)) { if (has_thres_groups(bterms)) { - stop2("Cannot use category specific effects ", + stop2("Cannot use category specific effects ", "in models with multiple thresholds.") } str_add(p$thres) <- paste0(" - transpose(mucs", prefix, "[n])") @@ -797,7 +823,7 @@ sdist(lpdf, p$mu, p$sigma, p$hu) } -stan_log_lik_zero_inflated_poisson <- function(bterms, resp = "", mix = "", +stan_log_lik_zero_inflated_poisson <- function(bterms, resp = "", mix = "", ...) { p <- stan_log_lik_dpars(bterms, TRUE, resp, mix) lpdf <- stan_log_lik_simple_lpdf("zero_inflated_poisson", "log", bterms) @@ -824,6 +850,17 @@ sdist(lpdf, p$trials, p$mu, p$zi) } +stan_log_lik_zero_inflated_beta_binomial <- function(bterms, resp = "", + mix = "", threads = NULL, + ...) { + p <- stan_log_lik_dpars(bterms, TRUE, resp, mix) + n <- stan_nn(threads) + p$trials <- paste0("trials", resp, n) + lpdf <- "zero_inflated_beta_binomial" + lpdf <- paste0(lpdf, stan_log_lik_dpar_usc_logit("zi", bterms)) + sdist(lpdf, p$trials, p$mu, p$phi, p$zi) +} + stan_log_lik_zero_inflated_beta <- function(bterms, resp = "", mix = "", ...) { p <- stan_log_lik_dpars(bterms, TRUE, resp, mix) usc_logit <- stan_log_lik_dpar_usc_logit("zi", bterms) @@ -831,7 +868,7 @@ sdist(lpdf, p$mu, p$phi, p$zi) } -stan_log_lik_zero_one_inflated_beta <- function(bterms, resp = "", mix = "", +stan_log_lik_zero_one_inflated_beta <- function(bterms, resp = "", mix = "", ...) { p <- stan_log_lik_dpars(bterms, TRUE, resp, mix) sdist("zero_one_inflated_beta", p$mu, p$phi, p$zoi, p$coi) @@ -849,7 +886,7 @@ family <- bterms$family no_loop <- isFALSE(family$loop) if (no_loop && (stan_log_lik_adj(bterms) || nzchar(mix))) { - stop2("This model requires evaluating the custom ", + stop2("This model requires evaluating the custom ", "likelihood as a loop over observations.") } reqn <- !no_loop @@ -933,7 +970,7 @@ alpha <- glue("Intercept{resp}") } else { alpha <- "0" - } + } } nlist(x, alpha, beta) } @@ -942,7 +979,7 @@ use_ordered_logistic <- function(bterms) { stopifnot(is.brmsterms(bterms)) isTRUE(bterms$family$family == "cumulative") && - isTRUE(bterms$family$link == "logit") && + isTRUE(bterms$family$link == "logit") && isTRUE(bterms$fdpars$disc$value == 1) && !has_cs(bterms) } diff -Nru r-cran-brms-2.16.3/R/stan-predictor.R r-cran-brms-2.17.0/R/stan-predictor.R --- r-cran-brms-2.16.3/R/stan-predictor.R 2021-09-07 16:10:26.000000000 +0000 +++ r-cran-brms-2.17.0/R/stan-predictor.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,4 +1,4 @@ -# unless otherwise specified, functions return a named list +# unless otherwise specified, functions return a named list # of Stan code snippets to be pasted together later on # generate stan code for predictor terms @@ -22,7 +22,7 @@ stan_bhaz(x, ...), stan_special_prior_global(x, ...) ) - stan_eta_combine(out, bterms = x, ...) + stan_eta_combine(out, bterms = x, ...) } # prepare Stan code for non-linear terms @@ -52,67 +52,67 @@ } for (dp in valid_dpars) { dp_terms <- x$dpars[[dp]] + dp_comment <- stan_dpar_comments(dp, family = x$family) if (is.btl(dp_terms) || is.btnl(dp_terms)) { # distributional parameter is predicted - ilink <- stan_eta_ilink(dp, bterms = x, resp = resp) - dp_args <- list(dp_terms, ilink = ilink) + inv_link <- stan_eta_inv_link(dp, bterms = x, resp = resp) + dp_args <- list(dp_terms, inv_link = inv_link) str_add_list(out) <- do_call(stan_predictor, c(dp_args, args)) } else if (is.numeric(x$fdpars[[dp]]$value)) { - # distributional parameter is fixed to a numeric value - dp_type <- stan_dpar_types(dp, resp, family = x$family, fixed = TRUE) - if (nzchar(dp_type)) { - dp_value <- x$fdpars[[dp]]$value - dp_comment <- stan_comment(attr(dp_type, "comment")) - str_add(out$tpar_def) <- glue( - " {dp_type} {dp}{resp} = {dp_value};{dp_comment}\n" - ) - str_add(out$pll_args) <- glue(", real {dp}{resp}") + # distributional parameter is fixed to constant + if (is_mix_proportion(dp, family = x$family)) { + # mixture proportions are handled in 'stan_mixture' + next } + dp_value <- x$fdpars[[dp]]$value + dp_comment <- stan_comment(dp_comment) + str_add(out$tpar_def) <- glue( + " real {dp}{resp} = {dp_value};{dp_comment}\n" + ) + str_add(out$pll_args) <- glue(", real {dp}{resp}") } else if (is.character(x$fdpars[[dp]]$value)) { # distributional parameter is fixed to another distributional parameter if (!x$fdpars[[dp]]$value %in% valid_dpars) { stop2("Parameter '", x$fdpars[[dp]]$value, "' cannot be found.") } - dp_type <- stan_dpar_types(dp, resp, family = x$family) - if (nzchar(dp_type)) { - dp_value <- x$fdpars[[dp]]$value - dp_comment <- stan_comment(attr(dp_type, "comment")) - str_add(out$tpar_def) <- glue( - " {dp_type} {dp}{resp};{dp_comment}\n" - ) - str_add(out$tpar_comp) <- glue( - " {dp}{resp} = {dp_value}{resp};\n" - ) - str_add(out$pll_args) <- glue(", real {dp}{resp}") + if (is_mix_proportion(dp, family = x$family)) { + stop2("Cannot set mixture proportions to be equal.") } + dp_value <- x$fdpars[[dp]]$value + dp_comment <- stan_comment(dp_comment) + str_add(out$tpar_def) <- glue( + " real {dp}{resp};{dp_comment}\n" + ) + str_add(out$tpar_comp) <- glue( + " {dp}{resp} = {dp_value}{resp};\n" + ) + str_add(out$pll_args) <- glue(", real {dp}{resp}") } else { # distributional parameter is estimated as a scalar - dp_type <- stan_dpar_types(dp, resp, family = x$family) - dp_tmp_type <- stan_dpar_tmp_types(dp, resp, family = x$family) - if (nzchar(dp_tmp_type)) { - # distributional parameter has a temporary definition - dp_comment <- attr(dp_tmp_type, "comment") - str_add_list(out) <- stan_prior( - prior, dp, type = dp_tmp_type, prefix = "tmp_", - suffix = resp, header_type = "real", px = px, - comment = dp_comment, normalize = normalize - ) - } else if (nzchar(dp_type)) { - # distributional parameter has a regular definition - dp_comment <- attr(dp_type, "comment") - str_add_list(out) <- stan_prior( - prior, dp, type = dp_type, suffix = resp, - header_type = "real", px = px, - comment = dp_comment, normalize = normalize - ) + if (is_mix_proportion(dp, family = x$family)) { + # mixture proportions are handled in 'stan_mixture' + next + } + prefix <- "" + if (dp %in% valid_dpars(x, type = "tmp")) { + # some parameters are fully computed only after the model is run + prefix <- "tmp_" + dp_comment <- paste0(dp_comment, " (temporary)") } + str_add_list(out) <- stan_prior( + prior, dp, prefix = prefix, suffix = resp, + header_type = "real", px = px, + comment = dp_comment, normalize = normalize + ) } } + str_add_list(out) <- stan_dpar_transform( + x, prior = prior, normalize = normalize, ... + ) str_add_list(out) <- stan_mixture( x, data = data, prior = prior, normalize = normalize, ... ) - str_add_list(out) <- stan_dpar_transform(x, ...) - out$model_log_lik <- stan_log_lik(x, data = data, normalize = normalize, ...) + out$model_log_lik <- stan_log_lik(x, data = data, normalize = normalize, ...) list(out) } @@ -131,7 +131,7 @@ adnames <- unique(ulapply(adforms, names)) adallowed <- c("se", "weights", "mi") if (!all(adnames %in% adallowed)) { - stop2("Only ", collapse_comma(adallowed), " are supported ", + stop2("Only ", collapse_comma(adallowed), " are supported ", "addition arguments when 'rescor' is estimated.") } # we already know at this point that all families are identical @@ -139,7 +139,7 @@ stopifnot(family %in% c("gaussian", "student")) resp <- x$responses nresp <- length(resp) - str_add(out$model_def) <- glue( + str_add(out$model_def) <- glue( " // multivariate predictor array\n", " vector[nresp] Mu[N];\n" ) @@ -147,7 +147,7 @@ " Mu[n] = {stan_vector(glue('mu_{resp}[n]'))};\n" ) str_add(out$data) <- glue( - " int nresp; // number of responses\n", + " int nresp; // number of responses\n", " int nrescor; // number of residual correlations\n" ) str_add(out$pll_args) <- glue(", data int nresp") @@ -163,7 +163,7 @@ if (any(adnames %in% "weights")) { str_add(out$tdata_def) <- glue( " // weights of the pointwise log-likelihood\n", - " vector[N] weights = weights_{resp[1]};\n" + " vector[N] weights = weights_{resp[1]};\n" ) str_add(out$pll_args) <- glue(", data vector weights") } @@ -173,7 +173,7 @@ str_add(out$pll_args) <- ", vector[] Yl" for (i in seq_along(miforms)) { j <- match(names(miforms)[i], resp) - # needs to happen outside of reduce_sum + # needs to happen outside of reduce_sum # to maintain consistency of indexing Yl str_add(out$model_no_pll_comp_mvjoin) <- glue( " Yl[n][{j}] = Yl_{resp[j]}[n];\n" @@ -181,17 +181,17 @@ } } str_add_list(out) <- stan_prior( - prior, class = "Lrescor", + prior, class = "Lrescor", type = "cholesky_factor_corr[nresp]", header_type = "matrix", comment = "parameters for multivariate linear models", normalize = normalize ) if (family == "student") { str_add_list(out) <- stan_prior( - prior, class = "nu", type = stan_dpar_types("nu"), - header_type = "real", normalize = normalize + prior, class = "nu", header_type = "real", + normalize = normalize ) - } + } sigma <- ulapply(x$terms, stan_sigma_transform, threads = threads) if (any(grepl(stan_nn_regex(), sigma))) { str_add(out$model_def) <- " vector[nresp] sigma[N];\n" @@ -212,8 +212,8 @@ " matrix[nresp, nresp] Sigma[N];\n" ) str_add(out$model_comp_mvjoin) <- glue( - " Sigma[n] = multiply_lower_tri_self_transpose(", - "diag_pre_multiply(sigma[n], Lrescor));\n" + " Sigma[n] = multiply_lower_tri_self_transpose(", + "diag_pre_multiply(sigma[n], Lrescor));\n" ) } } else { @@ -230,7 +230,7 @@ str_add(out$model_def) <- glue( " // residual covariance matrix\n", " matrix[nresp, nresp] Sigma = ", - "multiply_lower_tri_self_transpose(", + "multiply_lower_tri_self_transpose(", "diag_pre_multiply(sigma, Lrescor));\n" ) } @@ -244,16 +244,16 @@ str_add(out$gen_comp) <- stan_cor_gen_comp("rescor", "nresp") out$model_comp_mvjoin <- paste0( " // combine univariate parameters\n", - " for (n in 1:N) {\n", + " for (n in 1:N) {\n", stan_nn_def(threads), - out$model_comp_mvjoin, + out$model_comp_mvjoin, " }\n" ) if (isTRUE(nzchar(out$model_no_pll_comp_mvjoin))) { out$model_no_pll_comp_mvjoin <- paste0( " // combine univariate parameters\n", - " for (n in 1:N) {\n", - out$model_no_pll_comp_mvjoin, + " for (n in 1:N) {\n", + out$model_no_pll_comp_mvjoin, " }\n" ) } @@ -264,7 +264,7 @@ } # Stan code for population-level effects -stan_fe <- function(bterms, data, prior, stanvars, threads, primitive, +stan_fe <- function(bterms, data, prior, stanvars, threads, primitive, normalize, ...) { out <- list() family <- bterms$family @@ -285,14 +285,14 @@ p <- usc(combine_prefix(px)) resp <- usc(px$resp) if (length(fixef)) { - str_add(out$data) <- glue( + str_add(out$data) <- glue( " int K{p};", - " // number of population-level effects\n", + " // number of population-level effects\n", " matrix[N{resp}, K{p}] X{p};", " // population-level design matrix\n" ) if (decomp == "none") { - str_add(out$pll_args) <- glue(", data matrix X{ct}{p}") + str_add(out$pll_args) <- glue(", data matrix X{ct}{p}") } if (sparse) { if (decomp != "none") { @@ -303,7 +303,7 @@ } str_add(out$tdata_def) <- glue( " // sparse matrix representation of X{p}\n", - " vector[rows(csr_extract_w(X{p}))] wX{p}", + " vector[rows(csr_extract_w(X{p}))] wX{p}", " = csr_extract_w(X{p});\n", " int vX{p}[size(csr_extract_v(X{p}))]", " = csr_extract_v(X{p});\n", @@ -312,40 +312,42 @@ ) } # prepare population-level coefficients - b_bound <- get_bound(prior, class = "b", px = px) - b_type <- glue("vector{b_bound}[K{ct}{p}]") - b_coef_type <- glue("real{b_bound}") + b_type <- glue("vector[K{ct}{p}]") + has_special_b_prior <- stan_has_special_b_prior(bterms, prior) assign_b_tpar <- stan_assign_b_tpar(bterms, prior) if (decomp == "none") { b_suffix <- "" b_comment <- "population-level effects" - if (assign_b_tpar) { - str_add(out$tpar_def) <- glue(" {b_type} b{p}; // {b_comment}\n") - str_add(out$pll_args) <- glue(", vector b{p}") + if (has_special_b_prior) { + stopif_prior_bound(prior, class = "b", ls = px) + if (assign_b_tpar) { + # only some special priors assign b in transformed parameters + str_add(out$tpar_def) <- glue(" {b_type} b{p}; // {b_comment}\n") + str_add(out$pll_args) <- glue(", vector b{p}") + } } else { str_add_list(out) <- stan_prior( - prior, class = "b", coef = fixef, type = b_type, - coef_type = b_coef_type, px = px, suffix = p, - header_type = "vector", comment = b_comment, - normalize = normalize + prior, class = "b", coef = fixef, type = b_type, + px = px, suffix = p, header_type = "vector", + comment = b_comment, normalize = normalize ) } } else { stopifnot(decomp == "QR") - if (nzchar(b_bound)) { - stop2("Cannot impose bounds on decomposed coefficients.") - } + stopif_prior_bound(prior, class = "b", ls = px) b_suffix <- "Q" b_comment <- "regression coefficients at QR scale" - if (assign_b_tpar) { - str_add(out$tpar_def) <- glue(" {b_type} bQ{p}; // {b_comment}\n") - str_add(out$pll_args) <- glue(", vector bQ{p}") + if (has_special_b_prior) { + if (assign_b_tpar) { + # only some special priors assign b in transformed parameters + str_add(out$tpar_def) <- glue(" {b_type} bQ{p}; // {b_comment}\n") + str_add(out$pll_args) <- glue(", vector bQ{p}") + } } else { str_add_list(out) <- stan_prior( prior, class = "b", coef = fixef, type = b_type, - coef_type = b_coef_type, px = px, suffix = glue("Q{p}"), - header_type = "vector", comment = b_comment, - normalize = normalize + px = px, suffix = glue("Q{p}"), header_type = "vector", + comment = b_comment, normalize = normalize ) } str_add(out$gen_def) <- glue( @@ -354,12 +356,12 @@ ) } str_add_list(out) <- stan_special_prior_local( - prior, class = "b", ncoef = length(fixef), + prior, class = "b", ncoef = length(fixef), px = px, center_X = center_X, suffix = b_suffix, normalize = normalize ) } - + order_intercepts <- order_intercepts(bterms) if (order_intercepts && !center_X) { stop2( @@ -377,7 +379,7 @@ # the intercept was already removed during the data preparation str_add(out$tdata_def) <- glue( " int Kc{p} = K{p};\n", - " matrix[N{resp}, Kc{p}] Xc{p};", + " matrix[N{resp}, Kc{p}] Xc{p};", " // centered version of X{p}\n", " vector[Kc{p}] means_X{p};", " // column means of X{p} before centering\n" @@ -391,7 +393,7 @@ } else { str_add(out$tdata_def) <- glue( " int Kc{p} = K{p} - 1;\n", - " matrix[N{resp}, Kc{p}] Xc{p};", + " matrix[N{resp}, Kc{p}] Xc{p};", " // centered version of X{p} without an intercept\n", " vector[Kc{p}] means_X{p};", " // column means of X{p} before centering\n" @@ -411,7 +413,7 @@ # identify mixtures via ordering of the intercepts dp_id <- dpar_id(px$dpar) str_add(out$tpar_def) <- glue( - " // identify mixtures via ordering of the intercepts\n", + " // identify mixtures via ordering of the intercepts\n", " real Intercept{p} = ordered_Intercept{resp}[{dp_id}];\n" ) str_add(out$pll_args) <- glue(", real Intercept{p}") @@ -425,7 +427,7 @@ ) str_add_list(out) <- stan_prior( prior, class = "Intercept", type = intercept_type, - suffix = p, px = px, header_type = "real", + suffix = p, px = px, header_type = "real", comment = "temporary intercept for centered predictors", normalize = normalize ) @@ -459,19 +461,19 @@ # are defined on a per-group basis instead of a per-ID basis tranef <- get_dist_groups(ranef, "student") if (has_rows(tranef)) { - str_add(out$par) <- + str_add(out$par) <- " // parameters for student-t distributed group-level effects\n" for (i in seq_rows(tranef)) { g <- usc(tranef$ggn[i]) id <- tranef$id[i] str_add_list(out) <- stan_prior( - prior, class = "df", group = tranef$group[i], - type = "real", suffix = g, normalize = normalize + prior, class = "df", group = tranef$group[i], + suffix = g, normalize = normalize ) str_add(out$par) <- glue( " vector[N_{id}] udf{g};\n" ) - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( " target += inv_chi_square_{lpdf}(udf{g} | df{g});\n" ) # separate definition from computation to support fixed parameters @@ -499,7 +501,7 @@ r <- subset2(ranef, id = id) has_cov <- nzchar(r$cov[1]) has_by <- nzchar(r$by[[1]]) - Nby <- seq_along(r$bylevels[[1]]) + Nby <- seq_along(r$bylevels[[1]]) ng <- seq_along(r$gcall[[1]]$groups) px <- check_prefix(r) uresp <- usc(unique(px$resp)) @@ -534,8 +536,8 @@ if (has_by) { str_add(out$data) <- glue( " int Nby_{id}; // number of by-factor levels\n", - " int Jby_{id}[N_{id}];", - " // by-factor indicator per observation\n" + " int Jby_{id}[N_{id}];", + " // by-factor indicator per observation\n" ) } if (has_cov) { @@ -570,8 +572,8 @@ if (has_by) { str_add_list(out) <- stan_prior( prior, class = "sd", group = r$group[1], coef = r$coef, - type = glue("matrix[M_{id}, Nby_{id}]"), - coef_type = glue("row_vector[Nby_{id}]"), + type = glue("matrix[M_{id}, Nby_{id}]"), + coef_type = glue("row_vector[Nby_{id}]"), suffix = glue("_{id}"), px = px, broadcast = "matrix", comment = "group-level standard deviations", normalize = normalize @@ -579,9 +581,7 @@ } else { str_add_list(out) <- stan_prior( prior, class = "sd", group = r$group[1], coef = r$coef, - type = glue("vector[M_{id}]"), - coef_type = "real", - suffix = glue("_{id}"), px = px, + type = glue("vector[M_{id}]"), suffix = glue("_{id}"), px = px, comment = "group-level standard deviations", normalize = normalize ) @@ -590,14 +590,14 @@ tr <- get_dist_groups(r, "student") if (nrow(r) > 1L && r$cor[1]) { # multiple correlated group-level effects - str_add(out$data) <- glue( + str_add(out$data) <- glue( " int NC_{id}; // number of group-level correlations\n" ) str_add(out$par) <- glue( " matrix[M_{id}, N_{id}] z_{id};", " // standardized group-level effects\n" ) - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( " target += std_normal_{lpdf}(to_vector(z_{id}));\n" ) if (has_rows(tr)) { @@ -605,13 +605,13 @@ } if (has_by) { str_add_list(out) <- stan_prior( - prior, class = "L", group = r$group[1], coef = Nby, + prior, class = "L", group = r$group[1], coef = Nby, type = glue("cholesky_factor_corr[M_{id}]"), coef_type = glue("cholesky_factor_corr[M_{id}]"), - suffix = glue("_{id}"), dim = glue("[Nby_{id}]"), + suffix = glue("_{id}"), dim = glue("[Nby_{id}]"), comment = "cholesky factor of correlation matrix", normalize = normalize - ) + ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- glue( " matrix[N_{id}, M_{id}] r_{id}; // actual group-level effects\n" @@ -621,12 +621,12 @@ "scale_r_cor_by_cov(z_{id}, sd_{id}, L_{id}, Jby_{id}, Lcov_{id})" ) } else { - rdef <- glue("scale_r_cor_by(z_{id}, sd_{id}, L_{id}, Jby_{id})") + rdef <- glue("scale_r_cor_by(z_{id}, sd_{id}, L_{id}, Jby_{id})") } str_add(out$tpar_comp) <- glue( " // compute actual group-level effects\n", " r_{id} = {dfm}{rdef};\n" - ) + ) str_add(out$gen_def) <- cglue( " // compute group-level correlations\n", " corr_matrix[M_{id}] Cor_{id}_{Nby}", @@ -639,7 +639,7 @@ } else { str_add_list(out) <- stan_prior( prior, class = "L", group = r$group[1], suffix = usc(id), - type = glue("cholesky_factor_corr[M_{id}]"), + type = glue("cholesky_factor_corr[M_{id}]"), comment = "cholesky factor of correlation matrix", normalize = normalize ) @@ -667,7 +667,7 @@ ) } # separate definition from computation to support fixed parameters - str_add(out$tpar_def) <- + str_add(out$tpar_def) <- " // using vectors speeds up indexing in loops\n" str_add(out$tpar_def) <- cglue( " vector[N_{id}] r_{idp}_{r$cn};\n" @@ -684,7 +684,7 @@ " vector[N_{id}] z_{id}[M_{id}];", " // standardized group-level effects\n" ) - str_add(out$prior) <- cglue( + str_add(out$model_prior) <- cglue( " target += std_normal_{lpdf}(z_{id}[{seq_rows(r)}]);\n" ) Lcov <- str_if(has_cov, glue("Lcov_{id} * ")) @@ -697,7 +697,7 @@ " vector[N_{id}] r_{idp}_{r$cn}; // actual group-level effects\n" ) str_add(out$tpar_comp) <- cglue( - " r_{idp}_{r$cn} = {dfm}(transpose(sd_{id}[{J}, Jby_{id}])", + " r_{idp}_{r$cn} = {dfm}(transpose(sd_{id}[{J}, Jby_{id}])", " .* ({Lcov}z_{id}[{J}]));\n" ) } else { @@ -739,8 +739,8 @@ str_add(out$pll_args) <- glue(", data matrix Xs{p}") str_add_list(out) <- stan_prior( prior, class = "b", coef = Xs_names, - type = glue("vector[Ks{p}]"), suffix = glue("s{p}"), - header_type = "vector", px = px, + type = glue("vector[Ks{p}]"), suffix = glue("s{p}"), + header_type = "vector", px = px, comment = "spline coefficients", normalize = normalize ) str_add(out$eta) <- glue(" + Xs{p}{slice} * bs{p}") @@ -749,7 +749,7 @@ pi <- glue("{p}_{i}") nb <- seq_len(smef$nbases[[i]]) str_add(out$data) <- glue( - " // data for spline {smef$byterm[i]}\n", + " // data for spline {smef$byterm[i]}\n", " int nb{pi}; // number of bases\n", " int knots{pi}[nb{pi}]; // number of knots\n" ) @@ -767,12 +767,11 @@ ) for (j in nb) { str_add_list(out) <- stan_prior( - prior, class = "sds", coef = smef$term[i], - type = "real", coef_type = "real", - suffix = glue("{pi}_{j}"), px = px, + prior, class = "sds", coef = smef$term[i], + suffix = glue("{pi}_{j}"), px = px, comment = "standard deviations of spline coefficients", normalize = normalize - ) + ) } # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- cglue( @@ -784,7 +783,7 @@ " s{pi}_{nb} = sds{pi}_{nb} * zs{pi}_{nb};\n" ) str_add(out$pll_args) <- cglue(", vector s{pi}_{nb}") - str_add(out$prior) <- cglue( + str_add(out$model_prior) <- cglue( " target += std_normal_{lpdf}(zs{pi}_{nb});\n" ) str_add(out$eta) <- cglue( @@ -810,11 +809,10 @@ " matrix[N{resp}, Kcs{p}] Xcs{p}; // category specific design matrix\n" ) str_add(out$pll_args) <- glue(", data matrix Xcs{p}") - bound <- get_bound(prior, class = "b", px = px) str_add_list(out) <- stan_prior( prior, class = "b", coef = csef, - type = glue("matrix{bound}[Kcs{p}, nthres{resp}]"), - coef_type = glue("row_vector{bound}[nthres{resp}]"), + type = glue("matrix[Kcs{p}, nthres{resp}]"), + coef_type = glue("row_vector[nthres{resp}]"), suffix = glue("cs{p}"), px = px, broadcast = "matrix", header_type = "matrix", comment = "category specific effects", normalize = normalize @@ -828,8 +826,8 @@ if (!length(csef)) { # only group-level category specific effects present str_add(out$model_def) <- glue( - " // linear predictor for category specific effects\n", - " matrix[N{resp}, nthres{resp}] mucs{p}", + " // linear predictor for category specific effects\n", + " matrix[N{resp}, nthres{resp}] mucs{p}", " = rep_matrix(0, N{resp}, nthres{resp});\n" ) } @@ -855,8 +853,8 @@ str_add(mucs_loop) <- ";\n" } str_add(out$model_comp_eta_loop) <- glue( - " for (n in 1:N{resp}) {{\n", - stan_nn_def(threads), mucs_loop, + " for (n in 1:N{resp}) {{\n", + stan_nn_def(threads), mucs_loop, " }\n" ) } @@ -864,7 +862,7 @@ } # Stan code for special effects -stan_sp <- function(bterms, data, prior, stanvars, ranef, meef, threads, +stan_sp <- function(bterms, data, prior, stanvars, ranef, meef, threads, normalize, ...) { out <- list() spef <- tidy_spef(bterms, data) @@ -878,8 +876,8 @@ invalid_coef <- setdiff(ranef$coef, spef_coef) if (length(invalid_coef)) { stop2( - "Special group-level terms require corresponding ", - "population-level terms:\nOccured for ", + "Special group-level terms require corresponding ", + "population-level terms:\nOccured for ", collapse_comma(invalid_coef) ) } @@ -912,7 +910,7 @@ rpars <- str_if(nrow(r), cglue(" + {stan_eta_rsp(r)}")) str_add(out$loopeta) <- glue(" + (bsp{p}[{i}]{rpars}) * {eta}") } - + # prepare general Stan code ncovars <- max(spef$Ic) str_add(out$data) <- glue( @@ -925,7 +923,7 @@ ) str_add(out$pll_args) <- cglue(", data vector Csp{p}_{seq_len(ncovars)}") } - + # include special Stan code for monotonic effects which_Imo <- which(lengths(spef$Imo) > 0) if (any(which_Imo)) { @@ -950,14 +948,14 @@ if (is.na(id) || j_id == j) { # no ID or first appearance of the ID str_add(out$data) <- glue( - " vector[Jmo{p}[{j}]] con_simo{p}_{j};", + " vector[Jmo{p}[{j}]] con_simo{p}_{j};", " // prior concentration of monotonic simplex\n" ) str_add(out$par) <- glue( " simplex[Jmo{p}[{j}]] simo{p}_{j}; // monotonic simplex\n" ) - str_add(out$prior) <- glue( - " target += dirichlet_{lpdf}(simo{p}_{j} | con_simo{p}_{j});\n" + str_add(out$tpar_prior) <- glue( + " lprior += dirichlet_{lpdf}(simo{p}_{j} | con_simo{p}_{j});\n" ) } else { # use the simplex shared across all terms of the same ID @@ -968,7 +966,7 @@ } } } - + # include special Stan code for missing value terms uni_mi <- na.omit(attr(spef, "uni_mi")) for (j in seq_rows(uni_mi)) { @@ -978,28 +976,30 @@ ) str_add(out$pll_args) <- glue(", data int[] {idxl}") } - + # prepare special effects coefficients - bound <- get_bound(prior, class = "b", px = px) - if (stan_assign_b_tpar(bterms, prior)) { - str_add(out$tpar_def) <- glue( - " // special effects coefficients\n", - " vector{bound}[Ksp{p}] bsp{p};\n" - ) + if (stan_has_special_b_prior(bterms, prior)) { + stopif_prior_bound(prior, class = "b", ls = px) + if (stan_assign_b_tpar(bterms, prior)) { + # only some special priors assign b in transformed parameters + str_add(out$tpar_def) <- glue( + " // special effects coefficients\n", + " vector[Ksp{p}] bsp{p};\n" + ) + } } else { str_add_list(out) <- stan_prior( - prior, class = "b", coef = spef$coef, - type = glue("vector{bound}[Ksp{p}]"), - coef_type = glue("real{bound}"), px = px, + prior, class = "b", coef = spef$coef, + type = glue("vector[Ksp{p}]"), px = px, suffix = glue("sp{p}"), header_type = "vector", comment = "special effects coefficients", normalize = normalize ) } stan_special_priors <- stan_special_prior_local( - prior, class = "bsp", ncoef = nrow(spef), + prior, class = "bsp", ncoef = nrow(spef), px = px, center_X = FALSE, normalize = normalize - ) + ) out <- collapse_lists(out, stan_special_priors) out } @@ -1016,10 +1016,10 @@ # kernel methods cannot simply be split up into partial sums for (i in seq_rows(gpef)) { pi <- glue("{p}_{i}") - byvar <- gpef$byvars[[i]] + byvar <- gpef$byvars[[i]] cons <- gpef$cons[[i]] byfac <- length(cons) > 0L - bynum <- !is.null(byvar) && !byfac + bynum <- !is.null(byvar) && !byfac k <- gpef$k[i] is_approx <- !isNA(k) iso <- gpef$iso[i] @@ -1028,7 +1028,7 @@ sfx2 <- gpef$sfx2[[i]] str_add(out$data) <- glue( " // data related to GPs\n", - " int Kgp{pi};", + " int Kgp{pi};", " // number of sub-GPs (equal to 1 unless 'by' was used)\n", " int Dgp{pi}; // GP dimension\n" ) @@ -1037,20 +1037,19 @@ " // number of basis functions of an approximate GP\n", " int NBgp{pi};\n" ) - } + } str_add_list(out) <- stan_prior( - prior, class = "sdgp", coef = sfx1, - type = glue("vector[Kgp{pi}]"), - coef_type = "real", px = px, suffix = pi, + prior, class = "sdgp", coef = sfx1, + type = glue("vector[Kgp{pi}]"), px = px, suffix = pi, comment = "GP standard deviation parameters", normalize = normalize ) if (gpef$iso[i]) { - lscale_type <- "vector[1]" + lscale_type <- "vector[1]" lscale_dim <- glue("[Kgp{pi}]") lscale_comment <- "GP length-scale parameters" } else { - lscale_type <- glue("vector[Dgp{pi}]") + lscale_type <- glue("vector[Dgp{pi}]") lscale_dim <- glue("[Kgp{pi}]") lscale_comment <- "GP length-scale parameters" } @@ -1063,7 +1062,7 @@ " // number of observations relevant for a certain sub-GP\n", " int {Ngp}[Kgp{pi}];\n" ) - str_add(out$data) <- + str_add(out$data) <- " // indices and contrasts of sub-GPs per observation\n" str_add(out$data) <- cglue( " int {Igp}[{Ngp}[{J}]];\n", @@ -1073,10 +1072,9 @@ ", data int[] {Igp}, data vector Cgp{pi}_{J}" ) str_add_list(out) <- stan_prior( - prior, class = "lscale", coef = sfx2, - type = lscale_type, coef_type = "real", - dim = lscale_dim, suffix = glue("{pi}"), px = px, - comment = lscale_comment, normalize = normalize + prior, class = "lscale", coef = sfx2, + type = lscale_type, dim = lscale_dim, suffix = glue("{pi}"), + px = px, comment = lscale_comment, normalize = normalize ) if (gr) { str_add(out$data) <- glue( @@ -1090,7 +1088,7 @@ str_add(out$pll_args) <- cglue(", data int[] Jgp{pi}_{J}") } if (is_approx) { - str_add(out$data) <- + str_add(out$data) <- " // approximate GP basis matrices and eigenvalues\n" str_add(out$data) <- cglue( " matrix[{Nsubgp}[{J}], NBgp{pi}] Xgp{pi}_{J};\n", @@ -1102,7 +1100,7 @@ ) str_add(out$model_no_pll_def) <- " // scale latent variables of the GP\n" str_add(out$model_no_pll_def) <- cglue( - " vector[NBgp{pi}] rgp{pi}_{J} = sqrt(spd_cov_exp_quad(", + " vector[NBgp{pi}] rgp{pi}_{J} = sqrt(spd_cov_exp_quad(", "slambda{pi}_{J}, sdgp{pi}[{J}], lscale{pi}[{J}])) .* zgp{pi}_{J};\n" ) gp_call <- glue("Xgp{pi}_{J} * rgp{pi}_{J}") @@ -1124,7 +1122,7 @@ Igp_sub <- Igp if (use_threading(threads)) { str_add(out$model_comp_basic) <- cglue( - " int which_gp{pi}_{J}[size_range({Igp}, start, end)] =", + " int which_gp{pi}_{J}[size_range({Igp}, start, end)] =", " which_range({Igp}, start, end);\n" ) slice2 <- glue("[which_gp{pi}_{J}]") @@ -1142,16 +1140,15 @@ str_add(out$model_comp_basic) <- cglue( " {eta} += {Cgp}gp_pred{pi}_{J}{Jgp};\n" ) - str_add(out$prior) <- cglue( + str_add(out$model_prior) <- cglue( "{tp()}std_normal_{lpdf}(zgp{pi}_{J});\n" ) } else { # no by-factor variable str_add_list(out) <- stan_prior( - prior, class = "lscale", coef = sfx2, - type = lscale_type, coef_type = "real", - dim = lscale_dim, suffix = glue("{pi}"), px = px, - comment = lscale_comment, normalize = normalize + prior, class = "lscale", coef = sfx2, + type = lscale_type, dim = lscale_dim, suffix = glue("{pi}"), + px = px, comment = lscale_comment, normalize = normalize ) Nsubgp <- glue("N{resp}") if (gr) { @@ -1185,7 +1182,7 @@ ) str_add(out$model_no_pll_def) <- glue( " // scale latent variables of the GP\n", - " vector[NBgp{pi}] rgp{pi} = sqrt(spd_cov_exp_quad(", + " vector[NBgp{pi}] rgp{pi} = sqrt(spd_cov_exp_quad(", "slambda{pi}, sdgp{pi}[1], lscale{pi}[1])) .* zgp{pi};\n" ) if (gr) { @@ -1207,13 +1204,13 @@ # exact GPs str_add(out$data) <- glue( " vector[Dgp{pi}] Xgp{pi}[{Nsubgp}]; // covariates of the GP\n" - ) + ) str_add(out$par) <- glue( " vector[{Nsubgp}] zgp{pi}; // latent variables of the GP\n" ) gp_call <- glue("gp(Xgp{pi}, sdgp{pi}[1], lscale{pi}[1], zgp{pi})") # exact GPs are kernel based methods which - # need to be computed outside of reduce_sum + # need to be computed outside of reduce_sum str_add(out$model_no_pll_def) <- glue( " vector[{Nsubgp}] gp_pred{pi} = {gp_call};\n" ) @@ -1221,7 +1218,7 @@ str_add(out$eta) <- glue(" + {Cgp}gp_pred{pi}{Jgp}") str_add(out$pll_args) <- glue(", vector gp_pred{pi}") } - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( "{tp()}std_normal_{lpdf}(zgp{pi});\n" ) } @@ -1229,7 +1226,7 @@ out } -# Stan code for the linear predictor of autocorrelation terms +# Stan code for the linear predictor of autocorrelation terms stan_ac <- function(bterms, data, prior, threads, normalize, ...) { lpdf <- stan_lpdf_name(normalize) out <- list() @@ -1241,7 +1238,7 @@ has_natural_residuals <- has_natural_residuals(bterms) has_ac_latent_residuals <- has_ac_latent_residuals(bterms) acef <- tidy_acef(bterms, data) - + if (has_ac_latent_residuals) { # families that do not have natural residuals require latent # residuals for residual-based autocor structures @@ -1254,14 +1251,13 @@ ) str_add_list(out) <- stan_prior( prior, class = "sderr", px = px, suffix = p, - type = "real", comment = "SD of residuals", - normalize = normalize + comment = "SD of residuals", normalize = normalize ) str_add(out$tpar_def) <- glue( " vector[N{resp}] err{p}; // actual residuals\n" ) str_add(out$pll_args) <- glue(", vector err{p}") - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( " target += std_normal_{lpdf}(zerr{p});\n" ) str_add(out$eta) <- glue(" + err{p}{slice}") @@ -1273,12 +1269,12 @@ if (use_threading(threads) && (!acef_arma$cov || has_natural_residuals)) { stop2("Threading is not supported for this ARMA model.") } - str_add(out$data) <- glue( + str_add(out$data) <- glue( " // data needed for ARMA correlations\n", " int Kar{p}; // AR order\n", " int Kma{p}; // MA order\n" ) - str_add(out$tdata_def) <- glue( + str_add(out$tdata_def) <- glue( " int max_lag{p} = max(Kar{p}, Kma{p});\n" ) if (!acef_arma$cov) { @@ -1286,9 +1282,9 @@ if (is.formula(bterms$adforms$se)) { stop2(err_msg, " when including known standard errors.") } - str_add(out$data) <- glue( + str_add(out$data) <- glue( " // number of lags per observation\n", - " int J_lag{p}[N{resp}];\n" + " int J_lag{p}[N{resp}];\n" ) str_add(out$model_def) <- glue( " // matrix storing lagged residuals\n", @@ -1299,7 +1295,7 @@ str_add(out$model_def) <- glue( " vector[N{resp}] err{p}; // actual residuals\n" ) - Y <- str_if(is.formula(bterms$adforms$mi), "Yl", "Y") + Y <- str_if(is.formula(bterms$adforms$mi), "Yl", "Y") comp_err <- glue(" err{p}[n] = {Y}{p}[n] - mu{p}[n];\n") } else { if (acef_arma$q > 0) { @@ -1315,10 +1311,10 @@ comp_err <- "" } add_ar <- str_if(acef_arma$p > 0, - glue(" mu{p}[n] += Err{p}[n, 1:Kar{p}] * ar{p};\n") + glue(" mu{p}[n] += Err{p}[n, 1:Kar{p}] * ar{p};\n") ) add_ma <- str_if(acef_arma$q > 0, - glue(" mu{p}[n] += Err{p}[n, 1:Kma{p}] * ma{p};\n") + glue(" mu{p}[n] += Err{p}[n, 1:Kma{p}] * ma{p};\n") ) str_add(out$model_comp_arma) <- glue( " // include ARMA terms\n", @@ -1332,64 +1328,50 @@ " }}\n" ) } - # no boundaries are required in the conditional formulation - # when natural residuals automatically define the scale - need_arma_bound <- acef_arma$cov || has_ac_latent_residuals if (acef_arma$p > 0) { - ar_bound <- str_if(need_arma_bound, "") str_add_list(out) <- stan_prior( prior, class = "ar", px = px, suffix = p, coef = seq_along(acef_arma$p), - type = glue("vector{ar_bound}[Kar{p}]"), - coef_type = glue("real{ar_bound}"), + type = glue("vector[Kar{p}]"), header_type = "vector", comment = "autoregressive coefficients", normalize = normalize ) } if (acef_arma$q > 0) { - ma_bound <- str_if(need_arma_bound, "") str_add_list(out) <- stan_prior( prior, class = "ma", px = px, suffix = p, coef = seq_along(acef_arma$q), - type = glue("vector{ma_bound}[Kma{p}]"), - coef_type = glue("real{ma_bound}"), + type = glue("vector[Kma{p}]"), header_type = "vector", comment = "moving-average coefficients", normalize = normalize ) } } - + acef_cosy <- subset2(acef, class = "cosy") if (NROW(acef_cosy)) { # compound symmetry correlation structure # most code is shared with ARMA covariance models - # cosy correlations may be negative in theory but - # this causes problems divergent transitions (#878) - # str_add(out$tdata_def) <- glue( - # " real lb_cosy{p} = -1.0 / (max(nobs_tg{p}) - 1);", - # " // lower bound of the cosy correlation\n" - # ) str_add_list(out) <- stan_prior( - prior, class = "cosy", px = px, suffix = p, - type = glue("real"), + prior, class = "cosy", px = px, suffix = p, comment = "compound symmetry correlation", normalize = normalize ) } - + acef_time_cov <- subset2(acef, dim = "time", cov = TRUE) if (NROW(acef_time_cov)) { # use correlation structures in covariance matrix parameterization # optional for ARMA models and obligatory for COSY models # can only model one covariance structure at a time stopifnot(NROW(acef_time_cov) == 1) - str_add(out$data) <- glue( + str_add(out$data) <- glue( " // see the functions block for details\n", " int N_tg{p};\n", - " int begin_tg{p}[N_tg{p}];\n", - " int end_tg{p}[N_tg{p}];\n", + " int begin_tg{p}[N_tg{p}];\n", + " int end_tg{p}[N_tg{p}];\n", " int nobs_tg{p}[N_tg{p}];\n" ) str_add(out$tdata_def) <- glue( @@ -1404,7 +1386,7 @@ } str_add(out$tpar_def) <- glue( " // cholesky factor of the autocorrelation matrix\n", - " matrix[max_nobs_tg{p}, max_nobs_tg{p}] chol_cor{p};\n" + " matrix[max_nobs_tg{p}, max_nobs_tg{p}] chol_cor{p};\n" ) if (acef_time_cov$class == "arma") { if (acef_time_cov$p > 0 && acef_time_cov$q == 0) { @@ -1433,7 +1415,7 @@ ) } } - + acef_sar <- subset2(acef, class = "sar") if (NROW(acef_sar)) { if (!has_natural_residuals) { @@ -1454,20 +1436,18 @@ if (acef_sar$type == "lag") { str_add_list(out) <- stan_prior( prior, class = "lagsar", px = px, suffix = p, - type = glue("real"), comment = "lag-SAR correlation parameter", normalize = normalize ) } else if (acef_sar$type == "error") { str_add_list(out) <- stan_prior( prior, class = "errorsar", px = px, suffix = p, - type = glue("real"), comment = "error-SAR correlation parameter", normalize = normalize ) } } - + acef_car <- subset2(acef, class = "car") if (NROW(acef_car)) { if (is.btnl(bterms)) { @@ -1483,8 +1463,7 @@ ) str_add_list(out) <- stan_prior( prior, class = "sdcar", px = px, suffix = p, - type = "real", comment = "SD of the CAR structure", - normalize = normalize + comment = "SD of the CAR structure", normalize = normalize ) str_add(out$pll_args) <- glue(", vector rcar{p}, data int[] Jloc{p}") str_add(out$loopeta) <- glue(" + rcar{p}[Jloc{p}{n}]") @@ -1500,15 +1479,15 @@ ) str_add_list(out) <- stan_prior( prior, class = "car", px = px, suffix = p, - type = "real", normalize = normalize + normalize = normalize ) car_args <- c( - "car", "sdcar", "Nloc", "Nedges", + "car", "sdcar", "Nloc", "Nedges", "Nneigh", "eigenMcar", "edges1", "edges2" ) car_args <- paste0(car_args, p, collapse = ", ") - str_add(out$prior) <- glue( - " target += sparse_car_lpdf(\n", + str_add(out$model_prior) <- glue( + " target += sparse_car_lpdf(\n", " rcar{p} | {car_args}\n", " );\n" ) @@ -1517,7 +1496,7 @@ " vector[Nloc{p} - 1] zcar{p};\n" ) str_add(out$tpar_def) <- glue( - " vector[Nloc{p}] rcar{p};\n" + " vector[Nloc{p}] rcar{p};\n" ) str_add(out$tpar_comp) <- glue( " // sum-to-zero constraint\n", @@ -1525,12 +1504,12 @@ " rcar[Nloc{p}] = - sum(zcar{p});\n" ) car_args <- c( - "sdcar", "Nloc", "Nedges", "Nneigh", + "sdcar", "Nloc", "Nedges", "Nneigh", "eigenMcar", "edges1", "edges2" ) car_args <- paste0(car_args, p, collapse = ", ") - str_add(out$prior) <- glue( - " target += sparse_icar_lpdf(\n", + str_add(out$model_prior) <- glue( + " target += sparse_icar_lpdf(\n", " rcar{p} | {car_args}\n", " );\n" ) @@ -1550,7 +1529,7 @@ " // compute scaled parameters for the ICAR structure\n", " rcar{p} = zcar{p} * sdcar{p};\n" ) - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( " // improper prior on the spatial CAR component\n", " target += -0.5 * dot_self(zcar{p}[edges1{p}] - zcar{p}[edges2{p}]);\n", " // soft sum-to-zero constraint\n", @@ -1571,7 +1550,6 @@ ) str_add_list(out) <- stan_prior( prior, class = "rhocar", px = px, suffix = p, - type = "real", normalize = normalize ) # separate definition from computation to support fixed parameters @@ -1581,10 +1559,10 @@ ) str_add(out$tpar_comp) <- glue( " // join the spatial and the non-spatial CAR component\n", - " rcar{p} = (sqrt(1 - rhocar{p}) * nszcar{p}", + " rcar{p} = (sqrt(1 - rhocar{p}) * nszcar{p}", " + sqrt(rhocar{p} * inv(car_scale{p})) * zcar{p}) * sdcar{p};\n" ) - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( " // improper prior on the spatial BYM2 component\n", " target += -0.5 * dot_self(zcar{p}[edges1{p}] - zcar{p}[edges2{p}]);\n", " // soft sum-to-zero constraint\n", @@ -1594,7 +1572,7 @@ ) } } - + acef_fcor <- subset2(acef, class = "fcor") if (NROW(acef_fcor)) { if (!has_natural_residuals) { @@ -1603,7 +1581,7 @@ if (use_threading(threads)) { stop2("Threading is not supported for FCOR models.") } - str_add(out$data) <- glue( + str_add(out$data) <- glue( " matrix[N{resp}, N{resp}] Mfcor{p}; // known residual covariance matrix\n" ) str_add(out$tdata_def) <- glue( @@ -1630,14 +1608,14 @@ # Stan code for non-linear predictor terms # @param nlpars names of the non-linear parameters -# @param ilink character vector of length 2 defining the link to be applied -stan_nl <- function(bterms, data, nlpars, threads, ilink = rep("", 2), ...) { - stopifnot(length(ilink) == 2L) +# @param inv_link character vector of length 2 defining the link to be applied +stan_nl <- function(bterms, data, nlpars, threads, inv_link = rep("", 2), ...) { + stopifnot(length(inv_link) == 2L) out <- list() resp <- usc(bterms$resp) par <- combine_prefix(bterms, keep_mu = TRUE, nlp = TRUE) # prepare non-linear model - n <- paste0(str_if(bterms$loop, "[n]"), " ") + n <- paste0(str_if(bterms$loop, "[n]"), " ") new_nlpars <- glue(" nlp{resp}_{nlpars}{n}") # covariates in the non-linear model covars <- all.vars(bterms$covars) @@ -1671,12 +1649,12 @@ } # add white spaces to be able to replace parameters and covariates syms <- c( - "+", "-", "*", "/", "%", "^", ".*", "./", "'", ")", "(", - ",", "==", "!=", "<=", ">=", "<", ">", "!", "&&", "||" + "+", "-", "*", "/", "%", "^", ".*", "./", "'", ")", "(", + ",", "==", "!=", "<=", ">=", "<", ">", "!", "&&", "||" ) regex <- glue("(?[Mme_{i}]"), - coef_type = "real", comment = "latent SDs", + type = glue("vector[Mme_{i}]"), comment = "latent SDs", normalize = normalize ) - str_add(out$prior) <- cglue( + str_add(out$model_prior) <- cglue( " target += normal_{lpdf}(Xn_{K} | Xme_{K}, noise_{K});\n" ) if (meef$cor[K[1]] && length(K) > 1L) { @@ -1773,7 +1750,7 @@ ) str_add(out$tpar_comp) <- glue( " // compute actual latent values\n", - " Xme{i} = rep_matrix(transpose(meanme_{i}), {Nme})", + " Xme{i} = rep_matrix(transpose(meanme_{i}), {Nme})", " + transpose(diag_pre_multiply(sdme_{i}, Lme_{i}) * zme_{i});\n" ) str_add(out$tpar_def) <- cglue( @@ -1784,12 +1761,12 @@ " Xme_{K} = Xme{i}[, {J}];\n" ) str_add(out$pll_args) <- cglue(", vector Xme_{K}") - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( " target += std_normal_{lpdf}(to_vector(zme_{i}));\n" ) str_add(out$gen_def) <- cglue( " // obtain latent correlation matrix\n", - " corr_matrix[Mme_{i}] Corme_{i}", + " corr_matrix[Mme_{i}] Corme_{i}", " = multiply_lower_tri_self_transpose(Lme_{i});\n", " vector[NCme_{i}] corme_{i};\n" ) @@ -1809,7 +1786,7 @@ " Xme_{K} = meanme_{i}[{J}] + sdme_{i}[{J}] * zme_{K};\n" ) str_add(out$pll_args) <- cglue(", vector Xme_{K}") - str_add(out$prior) <- cglue( + str_add(out$model_prior) <- cglue( " target += std_normal_{lpdf}(zme_{K});\n" ) } @@ -1822,12 +1799,12 @@ # @param bterms btl object # @param ranef output of tidy_ranef # @param primitive use Stan's GLM likelihood primitives? -# @param ilink character vector of length 2 defining the link to be applied +# @param inv_link character vector of length 2 defining the link to be applied # @param ... currently unused # @return list of character strings containing Stan code stan_eta_combine <- function(out, bterms, ranef, threads, primitive, - ilink = c("", ""), ...) { - stopifnot(is.list(out), is.btl(bterms), length(ilink) == 2L) + inv_link = c("", ""), ...) { + stopifnot(is.list(out), is.btl(bterms), length(inv_link) == 2L) if (primitive && !has_special_terms(bterms)) { # only overall effects and perhaps an intercept are present # which will be evaluated directly in the GLM primitive likelihood @@ -1856,14 +1833,14 @@ } out$loopeta <- NULL # possibly transform eta before it is passed to the likelihood - if (sum(nzchar(ilink))) { + if (sum(nzchar(inv_link))) { # make sure mu comes last as it might depend on other parameters is_mu <- isTRUE("mu" %in% dpar_class(bterms[["dpar"]])) position <- str_if(is_mu, "model_comp_mu_link", "model_comp_dpar_link") str_add(out[[position]]) <- glue( " for (n in 1:N{resp}) {{\n", " // apply the inverse link function\n", - " {eta}[n] = {ilink[1]}{eta}[n]{ilink[2]};\n", + " {eta}[n] = {inv_link[1]}{eta}[n]{inv_link[2]};\n", " }}\n" ) } @@ -1898,7 +1875,7 @@ slice <- stan_slice(threads) eta_fe <- glue("X{sfx_X}{p}{slice} * b{sfx_b}{p}") } - } else { + } else { resp <- usc(bterms$resp) eta_fe <- glue("rep_vector(0.0, N{resp})") } @@ -1920,10 +1897,10 @@ ng <- seq_along(r$gcall[[1]]$groups) for (i in seq_rows(r)) { str_add(eta_re) <- cglue( - " + W_{idresp[i]}_{ng}{n}", + " + W_{idresp[i]}_{ng}{n}", " * r_{idp[i]}_{r$cn[i]}[J_{idresp[i]}_{ng}{n}]", " * Z_{idp[i]}_{r$cn[i]}_{ng}{n}" - ) + ) } } else { str_add(eta_re) <- cglue( @@ -1936,7 +1913,7 @@ # Stan code for group-level parameters in special predictor terms # @param r data.frame created by tidy_ranef -# @return a character vector: one element per row of 'r' +# @return a character vector: one element per row of 'r' stan_eta_rsp <- function(r) { stopifnot(nrow(r) > 0L, length(unique(r$gtype)) == 1L) rpx <- check_prefix(r) @@ -1949,7 +1926,7 @@ out[i] <- glue( "W_{idresp[i]}_{ng}[n] * r_{idp[i]}_{r$cn[i]}[J_{idresp[i]}_{ng}[n]]", collapse = " + " - ) + ) } } else { out <- glue("r_{idp}_{r$cn}[J_{idresp}[n]]") @@ -1962,7 +1939,7 @@ # @param cens_or_trunc is the model censored or truncated? stan_eta_transform <- function(family, bterms) { transeta <- "transeta" %in% family_info(family, "specials") - no_transform <- family$link == "identity" && !transeta || + no_transform <- family$link == "identity" && !transeta || has_joint_link(family) && !is.customfamily(family) !no_transform && !stan_has_built_in_fun(family, bterms) } @@ -1972,7 +1949,7 @@ # @param bterms object of class 'brmsterms' # @param resp name of the response variable # @return a single character string -stan_eta_ilink <- function(dpar, bterms, resp = "") { +stan_eta_inv_link <- function(dpar, bterms, resp = "") { stopifnot(is.brmsterms(bterms)) out <- rep("", 2) family <- bterms$dpars[[dpar]]$family @@ -1985,14 +1962,14 @@ nu <- glue("nu{dpar_id}") n_nu <- str_if(nu %in% pred_dpars, "[n]") nu <- glue("{nu}{resp}{n_nu}") - + family_link <- str_if( family$family %in% c("gamma", "hurdle_gamma", "exponential"), paste0(family$family, "_", family$link), family$family ) - ilink <- stan_ilink(family$link) + inv_link <- stan_inv_link(family$link) out <- switch(family_link, - c(glue("{ilink}("), ")"), + c(glue("{inv_link}("), ")"), gamma_log = c(glue("{shape} * exp(-("), "))"), gamma_inverse = c(glue("{shape} * ("), ")"), gamma_identity = c(glue("{shape} / ("), ")"), @@ -2002,8 +1979,8 @@ exponential_log = c("exp(-(", "))"), exponential_inverse = c("(", ")"), exponential_identity = c("inv(", ")"), - weibull = c(glue("{ilink}("), glue(") / tgamma(1 + 1 / {shape})")), - frechet = c(glue("{ilink}("), glue(") / tgamma(1 - 1 / {nu})")) + weibull = c(glue("{inv_link}("), glue(") / tgamma(1 + 1 / {shape})")), + frechet = c(glue("{inv_link}("), glue(") / tgamma(1 - 1 / {nu})")) ) } out @@ -2012,167 +1989,72 @@ # indicate if the population-level design matrix should be centered # implies a temporary shift in the intercept of the model stan_center_X <- function(x) { - is.btl(x) && !no_center(x$fe) && has_intercept(x$fe) && + is.btl(x) && !no_center(x$fe) && has_intercept(x$fe) && !fix_intercepts(x) && !is_sparse(x$fe) && !has_sum_to_zero_thres(x) } +# indicate if the overall coefficients 'b' have a special prior +stan_has_special_b_prior <- function(bterms, prior) { + special <- get_special_prior(prior, bterms) + !is.null(special$horseshoe) || !is.null(special$R2D2) || + !is.null(special$lasso) +} + # indicate if the overall coefficients 'b' should be -# assigned in the transformed parameters block +# assigned in the transformed parameters block stan_assign_b_tpar <- function(bterms, prior) { special <- get_special_prior(prior, bterms) !is.null(special$horseshoe) || !is.null(special$R2D2) } -# default Stan definitions for distributional parameters -# @param dpar name of a distributional parameter -# @param suffix optional suffix of the parameter name -# @param family optional brmsfamily object -# @param fixed should the parameter be fixed to a certain value? -stan_dpar_types <- function(dpar, suffix = "", family = NULL, fixed = FALSE) { - dpar <- as_one_character(dpar) - suffix <- as_one_character(suffix) - fixed <- as_one_logical(fixed) - if (is.mixfamily(family)) { - if (dpar_class(dpar) == "theta") { - return("") # theta is handled in stan_mixture - } - family <- family$mix[[as.numeric(dpar_id(dpar))]] - } - if (is.customfamily(family)) { - dpar_class <- dpar_class(dpar) - lb <- family$lb[[dpar_class]] - ub <- family$ub[[dpar_class]] - lb <- if (!is.na(lb)) glue("lower={lb}") - ub <- if (!is.na(ub)) glue("upper={ub}") - bounds <- paste0(c(lb, ub), collapse = ",") - if (nzchar(bounds)) bounds <- glue("<{bounds}>") - return(glue("real{bounds}")) - } - if (fixed) { - min_Y <- glue("min(Y{suffix})") - } else { - min_Y <- glue("min_Y{suffix}") - } - default_types <- list( - sigma = list( - type = "real", - comment = "dispersion parameter" - ), - shape = list( - type = "real", - comment = "shape parameter" - ), - nu = list( - type = "real", - comment = "degrees of freedom or shape" - ), - phi = list( - type = "real", - comment = "precision parameter" - ), - kappa = list( - type = "real", - comment = "precision parameter" - ), - beta = list( - type = "real", - comment = "scale parameter" - ), - zi = list( - type = "real", - comment = "zero-inflation probability" - ), - hu = list( - type = "real", - comment = "hurdle probability" - ), - zoi = list( - type = "real", - comment = "zero-one-inflation probability" - ), - coi = list( - type = "real", - comment = "conditional one-inflation probability" - ), - bs = list( - type = "real", - comment = "boundary separation parameter" - ), - ndt = list( - type = glue("real"), - comment = "non-decision time parameter" - ), - bias = list( - type = "real", - comment = "initial bias parameter" - ), - disc = list( - type = "real", - comment = "discrimination parameters" - ), - quantile = list( - type = "real", - comment = "quantile parameter" - ), - xi = list( - type = "real", - comment = "shape parameter" - ), - alpha = list( - type = "real", - comment = "skewness parameter" - ) - ) - out <- "" - types <- default_types[[dpar_class(dpar)]] - if (!is.null(types)) { - out <- types$type - attr(out, "comment") <- types$comment - } - out -} - -# default Stan definitions for temporary distributional parameters -stan_dpar_tmp_types <- function(dpar, suffix = "", family = NULL) { - dpar <- as_one_character(dpar) - suffix <- as_one_character(suffix) - if (is.mixfamily(family)) { - family <- family$mix[[as.numeric(dpar_id(dpar))]] - } - if (is.customfamily(family)) { - return("") # no temporary parameters in custom families - } - default_types <- list( - xi = list( - type = "real", - comment = "unscaled shape parameter" - ) +stan_dpar_comments <- function(dpar, family) { + dpar_class <- dpar_class(dpar, family) + out <- switch(dpar_class, "", + sigma = "dispersion parameter", + shape = "shape parameter", + nu = "degrees of freedom or shape", + phi = "precision parameter", + kappa = "precision parameter", + beta = "scale parameter", + zi = "zero-inflation probability", + hu = "hurdle probability", + zoi = "zero-one-inflation probability", + coi = "conditional one-inflation probability", + bs = "boundary separation parameter", + ndt = "non-decision time parameter", + bias = "initial bias parameter", + disc = "discrimination parameters", + quantile = "quantile parameter", + xi = "shape parameter", + alpha = "skewness parameter" ) - out <- "" - types <- default_types[[dpar_class(dpar)]] - if (!is.null(types)) { - out <- types$type - attr(out, "comment") <- types$comment - } out } # Stan code for transformations of distributional parameters -stan_dpar_transform <- function(bterms, threads, ...) { +stan_dpar_transform <- function(bterms, prior, threads, normalize, ...) { stopifnot(is.brmsterms(bterms)) out <- list() families <- family_names(bterms) - p <- usc(combine_prefix(bterms)) + px <- check_prefix(bterms) + p <- usc(combine_prefix(px)) resp <- usc(bterms$resp) if (any(conv_cats_dpars(families))) { - str_add(out$model_def) <- glue( + stopifnot(length(families) == 1L) + is_logistic_normal <- any(is_logistic_normal(families)) + len_mu <- glue("ncat{p}{str_if(is_logistic_normal, '-1')}") + str_add(out$model_def) <- glue( " // linear predictor matrix\n", - " vector[ncat{p}] mu{p}[N{resp}];\n" + " vector[{len_mu}] mu{p}[N{resp}];\n" ) mu_dpars <- make_stan_names(glue("mu{bterms$family$cats}")) mu_dpars <- glue("{mu_dpars}{p}[n]") - iref <- match(bterms$family$refcat, bterms$family$cats) - mu_dpars[iref] <- "0" + iref <- get_refcat(bterms$family, int = TRUE) + if (is_logistic_normal) { + mu_dpars <- mu_dpars[-iref] + } else { + mu_dpars[iref] <- "0" + } str_add(out$model_comp_catjoin) <- glue( " for (n in 1:N{resp}) {{\n", " mu{p}[n] = {stan_vector(mu_dpars)};\n", @@ -2180,7 +2062,7 @@ ) } if (any(families %in% "skew_normal")) { - # as suggested by Stephen Martin use sigma and mu of CP + # as suggested by Stephen Martin use sigma and mu of CP # but the skewness parameter alpha of DP dp_names <- names(bterms$dpars) for (i in which(families %in% "skew_normal")) { @@ -2213,7 +2095,7 @@ stan_nn_def(threads), str_if(nzchar(na), glue(" ", comp_delta)), str_if(nzchar(no), glue(" ", comp_omega)), - " mu{id}{p}[n] = mu{id}{p}[n]", + " mu{id}{p}[n] = mu{id}{p}[n]", " - {omega} * {delta} * sqrt(2 / pi());\n", " }}\n" ) @@ -2231,7 +2113,7 @@ sigma <- glue("sigma{id}") sfx <- str_if(sigma %in% names(bterms$dpars), "_vector") args <- sargs( - glue("tmp_{xi}"), glue("Y{p}"), + glue("tmp_{xi}"), glue("Y{p}"), glue("mu{id}{p}"), glue("{sigma}{p}") ) str_add(out$model_comp_dpar_trans) <- glue( @@ -2240,6 +2122,52 @@ } } } + if (any(families %in% "logistic_normal")) { + stopifnot(length(families) == 1L) + predcats <- get_predcats(bterms$family) + sigma_dpars <- glue("sigma{predcats}") + reqn <- sigma_dpars %in% names(bterms$dpars) + n <- ifelse(reqn, "[n]", "") + sigma_dpars <- glue("{sigma_dpars}{p}{n}") + ncatm1 <- glue("ncat{p}-1") + if (any(reqn)) { + # some of the sigmas are predicted + str_add(out$model_def) <- glue( + " // sigma parameter matrix\n", + " vector[{ncatm1}] sigma{p}[N{resp}];\n" + ) + str_add(out$model_comp_catjoin) <- glue( + " for (n in 1:N{resp}) {{\n", + " sigma{p}[n] = {stan_vector(sigma_dpars)};\n", + " }}\n" + ) + } else { + # none of the sigmas is predicted + str_add(out$model_def) <- glue( + " // sigma parameter vector\n", + " vector[{ncatm1}] sigma{p} = {stan_vector(sigma_dpars)};\n" + ) + } + # handle the latent correlation matrix 'lncor' + str_add(out$tdata_def) <- glue( + " // number of logistic normal correlations\n", + " int nlncor{p} = choose({ncatm1}, 2);\n" + ) + str_add_list(out) <- stan_prior( + prior, "Llncor", suffix = p, px = px, + type = glue("cholesky_factor_corr[{ncatm1}]"), + header_type = "matrix", + comment = "logistic-normal Cholesky correlation matrix", + normalize = normalize + ) + str_add(out$gen_def) <- glue( + " // logistic normal correlations\n", + " corr_matrix[{ncatm1}] Lncor", + " = multiply_lower_tri_self_transpose(Llncor);\n", + " vector[nlncor] lncor;\n" + ) + str_add(out$gen_comp) <- stan_cor_gen_comp("lncor", ncatm1) + } out } @@ -2258,8 +2186,8 @@ sigma <- str_if(has_sigma, glue("sigma{id}{p}{ns}")) if (is.formula(bterms$adforms$se)) { nse <- stan_nn(threads) - sigma <- str_if(nzchar(sigma), - glue("sqrt(square({sigma}) + se2{p}{nse})"), + sigma <- str_if(nzchar(sigma), + glue("sqrt(square({sigma}) + se2{p}{nse})"), glue("se{p}{nse}") ) } diff -Nru r-cran-brms-2.16.3/R/stan-prior.R r-cran-brms-2.17.0/R/stan-prior.R --- r-cran-brms-2.16.3/R/stan-prior.R 2021-10-24 11:01:16.000000000 +0000 +++ r-cran-brms-2.17.0/R/stan-prior.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,4 +1,4 @@ -# unless otherwise specified, functions return a single character +# unless otherwise specified, functions return a single character # string defining the likelihood of the model in Stan language # Define priors for parameters in Stan language @@ -9,7 +9,7 @@ # @param type Stan type used in the definition of the parameter # if type is empty the parameter is not initialized inside 'stan_prior' # @param dim stan array dimension to be specified after the parameter name -# cannot be merged with 'suffix' as the latter should apply to +# cannot be merged with 'suffix' as the latter should apply to # individual coefficients while 'dim' should not # TODO: decide whether to support arrays for parameters at all # an alternative would be to specify elements directly as parameters @@ -17,40 +17,42 @@ # coefficients; only relevant when mixing estimated and fixed coefficients # @param prefix a prefix to put at the parameter class # @param suffix a suffix to put at the parameter class -# @param broadcast Stan type to which the prior should be broadcasted +# @param broadcast Stan type to which the prior should be broadcasted # in order to handle vectorized prior statements # supported values are 'vector' or 'matrix' # @param comment character string containing a comment for the parameter # @param px list or data.frame after which to subset 'prior' # @return a named list of character strings in Stan language -stan_prior <- function(prior, class, coef = NULL, group = NULL, +stan_prior <- function(prior, class, coef = NULL, group = NULL, type = "real", dim = "", coef_type = "real", - prefix = "", suffix = "", broadcast = "vector", + prefix = "", suffix = "", broadcast = "vector", header_type = "", comment = "", px = list(), normalize = TRUE) { prior_only <- isTRUE(attr(prior, "sample_prior") == "only") prior <- subset2( - prior, class = class, coef = c(coef, ""), + prior, class = class, coef = c(coef, ""), group = c(group, ""), ls = px ) # special priors cannot be passed literally to Stan is_special_prior <- is_special_prior(prior$prior) if (any(is_special_prior)) { special_prior <- prior$prior[is_special_prior] - stop2("Prior ", collapse_comma(special_prior), " is used in an invalid ", + stop2("Prior ", collapse_comma(special_prior), " is used in an invalid ", "context. See ?set_prior for details on how to use special priors.") } - + px <- as.data.frame(px, stringsAsFactors = FALSE) upx <- unique(px) if (nrow(upx) > 1L) { # TODO: find a better solution to handle this case # can only happen for SD parameters of the same ID - base_prior <- rep(NA, nrow(upx)) + base_prior <- lb <- ub <- rep(NA, nrow(upx)) + base_bounds <- data.frame(lb = lb, ub = ub) for (i in seq_rows(upx)) { sub_upx <- lapply(upx[i, ], function(x) c(x, "")) - sub_prior <- subset2(prior, ls = sub_upx) + sub_prior <- subset2(prior, ls = sub_upx) base_prior[i] <- stan_base_prior(sub_prior) + base_bounds[i, ] <- stan_base_prior(sub_prior, col = c("lb", "ub")) } if (length(unique(base_prior)) > 1L) { # define prior for single coefficients manually @@ -61,12 +63,18 @@ prior$prior[take_coef_prior] <- base_prior[take_base_prior] } base_prior <- base_prior[1] - bound <- "" + if (nrow(unique(base_bounds)) > 1L) { + stop2("Conflicting boundary information for ", + "coefficients of class '", class, "'.") + } + base_bounds <- base_bounds[1, ] } else { base_prior <- stan_base_prior(prior) - bound <- prior[!nzchar(prior$coef), "bound"] + # select both bounds together so that they come from the same base prior + base_bounds <- stan_base_prior(prior, col = c("lb", "ub")) } - + bound <- convert_bounds2stan(base_bounds) + # generate stan prior statements out <- list() par <- paste0(prefix, class, suffix) @@ -101,7 +109,7 @@ coef_prior <- base_prior } if (!stan_is_constant_prior(coef_prior)) { - # all parameters with non-constant priors are estimated + # all parameters with non-constant priors are estimated c(estimated_coef_indices) <- list(index) } if (nzchar(coef_prior)) { @@ -111,33 +119,34 @@ stopifnot(all(index == 1L)) par_ij <- par } else { - par_ij <- paste0(par, collapse("[", index, "]")) + par_ij <- paste0(par, collapse("[", index, "]")) } if (stan_is_constant_prior(coef_prior)) { coef_prior <- stan_constant_prior( coef_prior, par_ij, broadcast = broadcast ) - str_add(out$tpar_prior) <- paste0(coef_prior, ";\n") + str_add(out$tpar_prior_const) <- paste0(coef_prior, ";\n") } else { coef_prior <- stan_target_prior( - coef_prior, par_ij, broadcast = broadcast, + coef_prior, par_ij, broadcast = broadcast, bound = bound, resp = px$resp[1], normalize = normalize ) - str_add(out$prior) <- paste0(tp(), coef_prior, ";\n") + str_add(out$tpar_prior) <- paste0(lpp(), coef_prior, ";\n") } } } } # the base prior may be improper flat in which no Stan code is added # but we still have estimated coefficients if the base prior is used - has_estimated_priors <- isTRUE(nzchar(out$prior)) || + has_estimated_priors <- isTRUE(nzchar(out$tpar_prior)) || used_base_prior && !stan_is_constant_prior(base_prior) - has_constant_priors <- isTRUE(nzchar(out$tpar_prior)) + has_constant_priors <- isTRUE(nzchar(out$tpar_prior_const)) if (has_estimated_priors && has_constant_priors) { # need to mix definition in the parameters and transformed parameters block if (!nzchar(coef_type)) { stop2("Can either estimate or fix all values of parameter '", par, "'.") } + coef_type <- stan_type_add_bounds(coef_type, bound) for (i in seq_along(estimated_coef_indices)) { index <- estimated_coef_indices[[i]] iu <- paste0(index, collapse = "_") @@ -145,9 +154,9 @@ " {coef_type} par_{par}_{iu};\n" ) ib <- collapse("[", index, "]") - str_add(out$tpar_prior) <- cglue( + str_add(out$tpar_prior_const) <- cglue( " {par}{ib} = par_{par}_{iu};\n" - ) + ) } } } else if (nzchar(base_prior)) { @@ -158,54 +167,75 @@ constant_base_prior <- stan_constant_prior( base_prior, par = par, ncoef = ncoef, broadcast = broadcast ) - str_add(out$tpar_prior) <- paste0(constant_base_prior, ";\n") + str_add(out$tpar_prior_const) <- paste0(constant_base_prior, ";\n") } else { target_base_prior <- stan_target_prior( base_prior, par = par, ncoef = ncoef, bound = bound, broadcast = broadcast, resp = px$resp[1], normalize = normalize ) - str_add(out$prior) <- paste0(tp(), target_base_prior, ";\n") + str_add(out$tpar_prior) <- paste0(lpp(), target_base_prior, ";\n") } } - + if (nzchar(type)) { # only define the parameter here if type is non-empty + type <- stan_type_add_bounds(type, bound) comment <- stan_comment(comment) par_definition <- glue(" {type} {par}{dim};{comment}\n") if (has_constant_priors) { - # parameter must be defined in the transformed parameters block + # parameter must be defined in the transformed parameters block str_add(out$tpar_def) <- par_definition } else { # parameter can be defined in the parameters block str_add(out$par) <- par_definition } if (nzchar(header_type)) { - str_add(out$pll_args) <- glue(", {header_type} {par}") + str_add(out$pll_args) <- glue(", {header_type} {par}") } } else { if (has_constant_priors) { stop2("Cannot fix parameter '", par, "' in this model.") } } - has_improper_prior <- !is.null(out$par) && is.null(out$prior) + has_improper_prior <- !is.null(out$par) && is.null(out$tpar_prior) if (prior_only && has_improper_prior) { - stop2("Sampling from priors is not possible as ", + stop2("Sampling from priors is not possible as ", "some parameters have no proper priors. ", "Error occurred for parameter '", par, "'.") } out } -# get the base prior for all coefficients -# this is the lowest level non-coefficient prior +# extract base prior information for a given set of priors +# the base prior is the lowest level, non-flat, non-coefficient prior # @param prior a brmsprior object -# @return a character string defining the base prior -stan_base_prior <- function(prior) { +# @param col columns for which base prior information is to be found +# @param sel_prior optional brmsprior object to subset 'prior' before +# finding the base prior +# @return the 'col' columns of the identified base prior +stan_base_prior <- function(prior, col = "prior", sel_prior = NULL, ...) { + stopifnot(all(col %in% c("prior", "lb", "ub"))) + if (!is.null(sel_prior)) { + # find the base prior using sel_prior for subsetting + stopifnot(is.brmsprior(sel_prior)) + prior <- subset2( + prior, class = sel_prior$class, group = c(sel_prior$group, ""), + dpar = sel_prior$dpar, nlpar = sel_prior$nlpar, resp = sel_prior$resp, + ... + ) + } else { + prior <- subset2(prior, ...) + } stopifnot(length(unique(prior$class)) <= 1) - take <- with(prior, !nzchar(coef) & nzchar(prior)) + # take all rows with non-zero entries on any of the chosen columns + take <- !nzchar(prior$coef) & Reduce("|", lapply(prior[col], nzchar)) prior <- prior[take, ] if (!NROW(prior)) { - return("") + if (length(col) == 1L) { + return("") + } else { + return(brmsprior()[, col]) + } } vars <- c("group", "nlpar", "dpar", "resp", "class") for (v in vars) { @@ -214,8 +244,8 @@ prior <- prior[take, ] } } - stopifnot(NROW(prior) == 1) - prior$prior + stopifnot(NROW(prior) == 1L) + prior[, col] } # Stan prior in target += notation @@ -223,7 +253,7 @@ # @param par name of the parameter on which to set the prior # @param ncoef number of coefficients in the parameter # @param bound bounds of the parameter in Stan language -# @param broadcast Stan type to which the prior should be broadcasted +# @param broadcast Stan type to which the prior should be broadcasted # @param name of the response variable # @return a character string defining the prior in Stan language stan_target_prior <- function(prior, par, ncoef = 0, broadcast = "vector", @@ -244,17 +274,17 @@ prior_args[i] <- sub(")$", "", prior_args[i]) } if (broadcast == "matrix" && ncoef > 0) { - # apply a scalar prior to all elements of a matrix + # apply a scalar prior to all elements of a matrix par <- glue("to_vector({par})") } - + if (nzchar(prior_args)) { str_add(prior_args, start = TRUE) <- " | " } lpdf <- stan_lpdf_name(normalize) out <- glue("{prior_name}_{lpdf}({par}{prior_args})") par_class <- unique(get_matches("^[^_]+", par)) - par_bound <- par_bounds(par_class, bound, resp = resp) + par_bound <- convert_stan2bounds(bound) prior_bound <- prior_bounds(prior_name) trunc_lb <- is.character(par_bound$lb) || par_bound$lb > prior_bound$lb trunc_ub <- is.character(par_bound$ub) || par_bound$ub < prior_bound$ub @@ -274,7 +304,7 @@ ) } else if (trunc_lb && trunc_ub) { str_add(out) <- glue( - "\n{wsp}- {ncoef} * log_diff_exp(", + "\n{wsp}- {ncoef} * log_diff_exp(", "{prior_name}_lcdf({par_bound$ub}{prior_args}), ", "{prior_name}_lcdf({par_bound$lb}{prior_args}))" ) @@ -301,7 +331,7 @@ # no action required for individual coefficients of vectors } else if (broadcast == "matrix") { if (ncoef > 0) { - # broadcast the scalar prior on the whole parameter matrix + # broadcast the scalar prior on the whole parameter matrix prior_args <- glue("rep_matrix({prior_args}, rows({par}), cols({par}))") } else { # single coefficient is a row in the parameter matrix @@ -316,6 +346,7 @@ stan_special_prior_global <- function(bterms, data, prior, normalize, ...) { out <- list() tp <- tp() + lpp <- lpp() lpdf <- stan_lpdf_name(normalize) px <- check_prefix(bterms) p <- usc(combine_prefix(px)) @@ -327,21 +358,21 @@ " real hs_df_global{p}; // global degrees of freedom\n", " real hs_df_slab{p}; // slab degrees of freedom\n", " real hs_scale_global{p}; // global prior scale\n", - " real hs_scale_slab{p}; // slab prior scale\n" + " real hs_scale_slab{p}; // slab prior scale\n" ) str_add(out$par) <- glue( " // horseshoe shrinkage parameters\n", - " real hs_global{p}; // global shrinkage parameters\n", + " real hs_global{p}; // global shrinkage parameter\n", " real hs_slab{p}; // slab regularization parameter\n" ) hs_scale_global <- glue("hs_scale_global{p}") if (isTRUE(special$horseshoe$autoscale)) { str_add(hs_scale_global) <- glue(" * sigma{usc(px$resp)}") } - str_add(out$prior) <- glue( - "{tp}student_t_{lpdf}(hs_global{p} | hs_df_global{p}, 0, {hs_scale_global})", + str_add(out$tpar_prior) <- glue( + "{lpp}student_t_{lpdf}(hs_global{p} | hs_df_global{p}, 0, {hs_scale_global})", str_if(normalize, "\n - 1 * log(0.5)"), ";\n", - "{tp}inv_gamma_{lpdf}(hs_slab{p} | 0.5 * hs_df_slab{p}, 0.5 * hs_df_slab{p});\n" + "{lpp}inv_gamma_{lpdf}(hs_slab{p} | 0.5 * hs_df_slab{p}, 0.5 * hs_df_slab{p});\n" ) } if (!is.null(special$R2D2)) { @@ -363,8 +394,8 @@ str_add(out$tpar_comp) <- glue( " R2D2_tau2{p} = {var_mult}R2D2_R2{p} / (1 - R2D2_R2{p});\n" ) - str_add(out$prior) <- glue( - "{tp}beta_{lpdf}(R2D2_R2{p} | R2D2_mean_R2{p} * R2D2_prec_R2{p}, ", + str_add(out$tpar_prior) <- glue( + "{lpp}beta_{lpdf}(R2D2_R2{p} | R2D2_mean_R2{p} * R2D2_prec_R2{p}, ", "(1 - R2D2_mean_R2{p}) * R2D2_prec_R2{p});\n" ) } @@ -378,8 +409,8 @@ " // lasso shrinkage parameter\n", " real lasso_inv_lambda{p};\n" ) - str_add(out$prior) <- glue( - "{tp}chi_square_{lpdf}(lasso_inv_lambda{p} | lasso_df{p});\n" + str_add(out$tpar_prior) <- glue( + "{lpp}chi_square_{lpdf}(lasso_inv_lambda{p} | lasso_df{p});\n" ) } out @@ -393,7 +424,7 @@ # @param px named list to subset 'prior' # @param center_X is the design matrix centered? # @param suffix optional suffix of the 'b' coefficient vector -stan_special_prior_local <- function(prior, class, ncoef, px, +stan_special_prior_local <- function(prior, class, ncoef, px, center_X = FALSE, suffix = "", normalize = TRUE) { class <- as_one_character(class) @@ -407,19 +438,19 @@ special <- get_special_prior(prior, px) if (!is.null(special$horseshoe)) { str_add(out$par) <- glue( - " // local parameters for horseshoe prior\n", + " // local parameters for the horseshoe prior\n", " vector[K{ct}{sp}] zb{sp};\n", " vector[K{ct}{sp}] hs_local{sp};\n" ) hs_args <- sargs( - glue("zb{sp}"), glue("hs_local{sp}"), glue("hs_global{p}"), + glue("zb{sp}"), glue("hs_local{sp}"), glue("hs_global{p}"), glue("hs_scale_slab{p}^2 * hs_slab{p}") ) str_add(out$tpar_reg_prior) <- glue( - " // compute actual regression coefficients\n", + " // compute the actual regression coefficients\n", " b{suffix}{sp} = horseshoe({hs_args});\n" ) - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( "{tp}std_normal_{lpdf}(zb{sp});\n", "{tp}student_t_{lpdf}(hs_local{sp} | hs_df{p}, 0, 1)", str_if(normalize, "\n - rows(hs_local{sp}) * log(0.5)"), ";\n" @@ -446,11 +477,19 @@ " // compute actual regression coefficients\n", " b{suffix}{sp} = R2D2({R2D2_args});\n" ) - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( "{tp}std_normal_{lpdf}(zb{sp});\n", "{tp}dirichlet_{lpdf}(R2D2_phi{sp} | R2D2_cons_D2{p});\n" ) } + if (!is.null(special$lasso)) { + str_add(out$par) <- glue( + " vector[K{ct}{sp}] b{sp}; // population-level effects\n" + ) + str_add(out$model_prior) <- glue( + "{tp}double_exponential_lpdf(b{sp} | 0, lasso_scale{p} * lasso_inv_lambda{p});\n" + ) + } out } @@ -467,22 +506,23 @@ } # Stan code to sample separately from priors -# @param prior character string taken from stan_prior +# @param tpar_prior character string taken from stan_prior that contains +# all priors that can potentially be sampled from separately # @param par_declars the parameters block of the Stan code -# required to extract boundaries +# required to extract boundaries # @param gen_quantities Stan code from the generated quantities block # @param prior_special a list of values pertaining to special priors # such as horseshoe or lasso # @param sample_prior take draws from priors? -stan_rngprior <- function(prior, par_declars, gen_quantities, +stan_rngprior <- function(tpar_prior, par_declars, gen_quantities, prior_special, sample_prior = "yes") { if (!is_equal(sample_prior, "yes")) { return(list()) } - prior <- strsplit(gsub(" |\\n", "", prior), ";")[[1]] + tpar_prior <- strsplit(gsub(" |\\n", "", tpar_prior), ";")[[1]] # D will contain all relevant information about the priors - D <- data.frame(prior = prior[nzchar(prior)]) - pars_regex <- "(?<=(_lpdf\\())[^|]+" + D <- data.frame(prior = tpar_prior[nzchar(tpar_prior)]) + pars_regex <- "(?<=(_lpdf\\())[^|]+" D$par <- get_matches(pars_regex, D$prior, perl = TRUE, first = TRUE) # 'std_normal' has no '|' and thus the above regex matches too much np <- !grepl("\\|", D$prior) @@ -493,27 +533,27 @@ tv_regex <- "(^to_vector\\()|(\\)(?=((\\[[[:digit:]]+\\])?)$))" D$par[has_tv] <- gsub(tv_regex, "", D$par[has_tv], perl = TRUE) # do not sample from some auxiliary parameters - excl_regex <- c("z", "zs", "zb", "zgp", "Xn", "Y", "hs", "tmp") + excl_regex <- c("tmp") excl_regex <- paste0("(", excl_regex, ")", collapse = "|") excl_regex <- paste0("^(", excl_regex, ")(_|$)") D <- D[!grepl(excl_regex, D$par), ] if (!NROW(D)) return(list()) - + # rename parameters containing indices has_ind <- grepl("\\[[[:digit:]]+\\]", D$par) D$par[has_ind] <- ulapply(D$par[has_ind], function(par) { ind_regex <- "(?<=\\[)[[:digit:]]+(?=\\])" ind <- get_matches(ind_regex, par, perl = TRUE) - gsub("\\[[[:digit:]]+\\]", paste0("_", ind), par) + gsub("\\[[[:digit:]]+\\]", paste0("__", ind), par) }) # cannot handle priors on variable transformations D <- D[D$par %in% stan_all_vars(D$par), ] if (!NROW(D)) return(list()) - + class_old <- c("^L_", "^Lrescor") class_new <- c("cor_", "rescor") D$par <- rename(D$par, class_old, class_new, fixed = FALSE) - dis_regex <- "(?<=target\\+=)[^\\(]+(?=_lpdf\\()" + dis_regex <- "(?<=lprior\\+=)[^\\(]+(?=_lpdf\\()" D$dist <- get_matches(dis_regex, D$prior, perl = TRUE, first = TRUE) D$dist <- sub("corr_cholesky$", "corr", D$dist) args_regex <- "(?<=\\|)[^$\\|]+(?=\\)($|-))" @@ -522,7 +562,7 @@ has_std_normal <- D$dist == "std_normal" D$dist[has_std_normal] <- "normal" D$args[has_std_normal] <- "0,1" - + # extract information from the initial parameter definition par_declars <- unlist(strsplit(par_declars, "\n", fixed = TRUE)) par_declars <- gsub("^[[:blank:]]*", "", par_declars) @@ -535,7 +575,7 @@ all_dims <- get_matches( "(?<=\\[)[^\\]]*", par_declars, first = TRUE, perl = TRUE ) - + # define parameter types and boundaries D$dim <- D$bounds <- "" D$type <- "real" @@ -554,7 +594,7 @@ contains_other_pars <- ulapply(found_vars, function(x) any(x %in% all_pars)) D <- D[!contains_other_pars, ] if (!NROW(D)) return(list()) - + out <- list() # sample priors in the generated quantities block D$lkj <- grepl("^lkj_corr$", D$dist) @@ -565,7 +605,7 @@ str_add(out$gen_def) <- cglue( " {D$type} {D$prior_par} = {D$dist}_rng({D$args}){D$lkj_index};\n" ) - + # sample from truncated priors using rejection sampling D$lb <- stan_extract_bounds(D$bounds, bound = "lower") D$ub <- stan_extract_bounds(D$bounds, bound = "upper") @@ -609,3 +649,26 @@ } out } + +# add bounds to a Stan type specification which may include dimensions +stan_type_add_bounds <- function(type, bound) { + regex_dim <- "\\[.*$" + type_type <- sub(regex_dim, "", type) + type_dim <- get_matches(regex_dim, type, first = TRUE) + glue("{type_type}{bound}{type_dim}") +} + +stopif_prior_bound <- function(prior, class, ...) { + lb <- stan_base_prior(prior, "lb", class = class, ...) + ub <- stan_base_prior(prior, "ub", class = class, ...) + if (nzchar(lb) || nzchar(ub)) { + stop2("Cannot add bounds to class '", class, "' for this prior.") + } + return(invisible(NULL)) +} + +# lprior plus equal +lpp <- function(wsp = 2) { + wsp <- collapse(rep(" ", wsp)) + paste0(wsp, "lprior += ") +} diff -Nru r-cran-brms-2.16.3/R/stan-response.R r-cran-brms-2.17.0/R/stan-response.R --- r-cran-brms-2.16.3/R/stan-response.R 2021-09-09 18:41:41.000000000 +0000 +++ r-cran-brms-2.17.0/R/stan-response.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,4 +1,4 @@ -# unless otherwise specifiedm functions return a named list +# unless otherwise specifiedm functions return a named list # of Stan code snippets to be pasted together later on # Stan code for the response variables @@ -65,7 +65,7 @@ } if (is.formula(bterms$adforms$weights)) { str_add(out$data) <- glue( - " vector[N{resp}] weights{resp}; // model weights\n" + " vector[N{resp}] weights{resp}; // model weights\n" ) str_add(out$pll_args) <- glue(", data vector weights{resp}") } @@ -78,9 +78,9 @@ " int Jthres{resp}[N{resp}, 2]; // threshold indices\n" ) str_add(out$tdata_def) <- glue( - " int nmthres{resp} = sum(nthres{resp});", + " int nmthres{resp} = sum(nthres{resp});", " // total number of thresholds\n", - " int Kthres_start{resp}[ngrthres{resp}];", + " int Kthres_start{resp}[ngrthres{resp}];", " // start index per threshold group\n", " int Kthres_end{resp}[ngrthres{resp}];", " // end index per threshold group\n" @@ -183,7 +183,7 @@ ) str_add(out$model_no_pll_def) <- glue( " // vector combining observed and missing responses\n", - " vector[N{resp}] Yl{resp} = Y{resp};\n" + " vector[N{resp}] Yl{resp} = Y{resp};\n" ) str_add(out$model_no_pll_comp_basic) <- glue( " Yl{resp}[Jmi{resp}] = Ymi{resp};\n" @@ -200,7 +200,7 @@ str_add(out$par) <- glue( " vector{Ybounds}[N{resp}] Yl{resp}; // latent variable\n" ) - str_add(out$prior) <- glue( + str_add(out$model_prior) <- glue( " target += normal_{lpdf}(Y{resp}[Jme{resp}]", " | Yl{resp}[Jme{resp}], noise{resp}[Jme{resp}]);\n" ) @@ -262,7 +262,7 @@ str_add(out$tpar_def) <- cglue( " {type}[nthres{resp}{grb}] Intercept{p}{gr};\n" ) - str_add(out$tpar_comp) <- + str_add(out$tpar_comp) <- " // fix thresholds across ordinal mixture components\n" str_add(out$tpar_comp) <- cglue( " Intercept{p}{gr} = fixed_Intercept{resp}{gr};\n" @@ -272,35 +272,33 @@ bound <- subset2(prior, class = "delta", group = "", ls = px)$bound for (i in seq_along(groups)) { str_add_list(out) <- stan_prior( - prior, class = "Intercept", group = groups[i], - type = "real", prefix = "first_", - suffix = glue("{p}{gr[i]}"), px = px, + prior, class = "Intercept", group = groups[i], + prefix = "first_", suffix = glue("{p}{gr[i]}"), px = px, comment = "first threshold", normalize = normalize ) str_add_list(out) <- stan_prior( - prior, class = "delta", group = groups[i], - type = glue("real{bound}"), px = px, suffix = gr[i], + prior, class = "delta", group = groups[i], px = px, suffix = gr[i], comment = "distance between thresholds", normalize = normalize ) } - str_add(out$tpar_def) <- + str_add(out$tpar_def) <- " // temporary thresholds for centered predictors\n" str_add(out$tpar_def) <- cglue( " {type}[nthres{resp}{grb}] Intercept{p}{gr};\n" ) - str_add(out$tpar_comp) <- + str_add(out$tpar_comp) <- " // compute equidistant thresholds\n" str_add(out$tpar_comp) <- cglue( " for (k in 1:(nthres{resp}{grb})) {{\n", - " Intercept{p}{gr}[k] = first_Intercept{p}{gr}", + " Intercept{p}{gr}[k] = first_Intercept{p}{gr}", " + (k - 1.0) * delta{p}{gr};\n", " }}\n" ) } else { for (i in seq_along(groups)) { str_add_list(out) <- stan_prior( - prior, class = "Intercept", group = groups[i], - coef = get_thres(bterms, group = groups[i]), + prior, class = "Intercept", group = groups[i], + coef = get_thres(bterms, group = groups[i]), type = glue("{type}[nthres{resp}{grb[i]}]"), coef_type = coef_type, px = px, suffix = glue("{p}{gr[i]}"), comment = "temporary thresholds for centered predictors", @@ -345,8 +343,8 @@ } str_add(out$gen_def) <- " // compute actual thresholds\n" str_add(out$gen_def) <- cglue( - " vector[nthres{resp}{grb}] b{p}_Intercept{gr}", - " = Intercept{p}{stz}{gr}{sub_X_means};\n" + " vector[nthres{resp}{grb}] b{p}_Intercept{gr}", + " = Intercept{p}{stz}{gr}{sub_X_means};\n" ) out } @@ -376,8 +374,8 @@ str_add(out$par) <- glue( " simplex[Kbhaz{resp}] sbhaz{resp}; // baseline coefficients\n" ) - str_add(out$prior) <- glue( - " target += dirichlet_{lpdf}(sbhaz{resp} | con_sbhaz{resp});\n" + str_add(out$tpar_prior) <- glue( + " lprior += dirichlet_{lpdf}(sbhaz{resp} | con_sbhaz{resp});\n" ) str_add(out$model_def) <- glue( " // compute values of baseline function\n", @@ -414,8 +412,8 @@ } missing_id <- setdiff(1:nmix, dpar_id(names(theta_pred))) str_add(out$model_def) <- glue( - " vector[N{p}] theta{missing_id}{p} = rep_vector(0.0, N{p});\n", - " real log_sum_exp_theta;\n" + " vector[N{p}] theta{missing_id}{p} = rep_vector(0.0, N{p});\n", + " real log_sum_exp_theta;\n" ) sum_exp_theta <- glue("exp(theta{1:nmix}{p}[n])", collapse = " + ") str_add(out$model_comp_mix) <- glue( @@ -440,13 +438,13 @@ } else { # estimate mixture proportions str_add(out$data) <- glue( - " vector[{nmix}] con_theta{p}; // prior concentration\n" + " vector[{nmix}] con_theta{p}; // prior concentration\n" ) str_add(out$par) <- glue( " simplex[{nmix}] theta{p}; // mixing proportions\n" ) - str_add(out$prior) <- glue( - " target += dirichlet_{lpdf}(theta{p} | con_theta{p});\n" + str_add(out$tpar_prior) <- glue( + " lprior += dirichlet_{lpdf}(theta{p} | con_theta{p});\n" ) # separate definition from computation to support fixed parameters str_add(out$tpar_def) <- " // mixing proportions\n" @@ -460,7 +458,7 @@ } if (order_intercepts(bterms)) { # identify mixtures by ordering the intercepts of their components - str_add(out$par) <- glue( + str_add(out$par) <- glue( " ordered[{nmix}] ordered_Intercept{p}; // to identify mixtures\n" ) } @@ -478,10 +476,10 @@ coef_type <- str_if(has_ordered_thres(bterms), "", "real") for (i in seq_along(groups)) { str_add_list(out) <- stan_prior( - prior, class = "Intercept", - coef = get_thres(bterms, group = groups[i]), - type = glue("{type}[nthres{p}{grb[i]}]"), - coef_type = coef_type, px = px, + prior, class = "Intercept", + coef = get_thres(bterms, group = groups[i]), + type = glue("{type}[nthres{p}{grb[i]}]"), + coef_type = coef_type, px = px, prefix = "fixed_", suffix = glue("{p}{gr[i]}"), comment = "thresholds fixed over mixture components", normalize = normalize @@ -495,9 +493,9 @@ # @return a character string stan_ordinal_lpmf <- function(family, link) { stopifnot(is.character(family), is.character(link)) - ilink <- stan_ilink(link) + inv_link <- stan_inv_link(link) th <- function(k) { - # helper function generating stan code inside ilink(.) + # helper function generating stan code inside inv_link(.) if (family %in% c("cumulative", "sratio")) { out <- glue("thres[{k}] - mu") } else if (family %in% c("cratio", "acat")) { @@ -512,14 +510,14 @@ " * mu: latent mean parameter\n", " * disc: discrimination parameter\n", " * thres: ordinal thresholds\n", - " * Returns:\n", + " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", " real {family}_{link}_lpmf(int y, real mu, real disc, vector thres) {{\n" ) # define the function body if (family == "cumulative") { - if (ilink == "inv_logit") { + if (inv_link == "inv_logit") { str_add(out) <- glue( " int nthres = num_elements(thres);\n", " if (y == 1) {{\n", @@ -540,44 +538,45 @@ " int nthres = num_elements(thres);\n", " real p;\n", " if (y == 1) {{\n", - " p = {ilink}({th(1)});\n", + " p = {inv_link}({th(1)});\n", " }} else if (y == nthres + 1) {{\n", - " p = 1 - {ilink}({th('nthres')});\n", + " p = 1 - {inv_link}({th('nthres')});\n", " }} else {{\n", - " p = {ilink}({th('y')}) -\n", - " {ilink}({th('y - 1')});\n", + " p = {inv_link}({th('y')}) -\n", + " {inv_link}({th('y - 1')});\n", " }}\n", " return log(p);\n", " }}\n" ) } } else if (family %in% c("sratio", "cratio")) { - if (ilink == "inv_cloglog") { + # TODO: support 'softit' link as well + if (inv_link == "inv_cloglog") { qk <- str_if( - family == "sratio", + family == "sratio", "-exp({th('k')})", "log1m_exp(-exp({th('k')}))" ) - } else if (ilink == "inv_logit") { + } else if (inv_link == "inv_logit") { qk <- str_if( - family == "sratio", + family == "sratio", "log1m_inv_logit({th('k')})", "log_inv_logit({th('k')})" ) - } else if (ilink == "Phi") { + } else if (inv_link == "Phi") { # TODO: replace with more stable std_normal_lcdf once rstan >= 2.25 qk <- str_if( - family == "sratio", + family == "sratio", "normal_lccdf({th('k')}|0,1)", "normal_lcdf({th('k')}|0,1)" ) - } else if (ilink == "Phi_approx") { + } else if (inv_link == "Phi_approx") { qk <- str_if( family == "sratio", "log1m_inv_logit(0.07056 * pow({th('k')}, 3.0) + 1.5976 * {th('k')})", "log_inv_logit(0.07056 * pow({th('k')}, 3.0) + 1.5976 * {th('k')})" ) - } else if (ilink == "inv_cauchit") { + } else if (inv_link == "inv_cauchit") { qk <- str_if( family == "sratio", "cauchy_lccdf({th('k')}|0,1)", @@ -593,7 +592,7 @@ " while (k <= min(y, nthres)) {{\n", " q[k] = {qk};\n", " p[k] = log1m_exp(q[k]);\n", - " for (kk in 1:(k - 1)) p[k] = p[k] + q[kk];\n", + " for (kk in 1:(k - 1)) p[k] = p[k] + q[kk];\n", " k += 1;\n", " }}\n", " if (y == nthres + 1) {{\n", @@ -603,7 +602,7 @@ " }}\n" ) } else if (family == "acat") { - if (ilink == "inv_logit") { + if (inv_link == "inv_logit") { str_add(out) <- glue( " int nthres = num_elements(thres);\n", " vector[nthres + 1] p = append_row(0, cumulative_sum(disc * (mu - thres)));\n", @@ -611,18 +610,18 @@ " }}\n" ) } else { - str_add(out) <- glue( + str_add(out) <- glue( " int nthres = num_elements(thres);\n", " vector[nthres + 1] p;\n", " vector[nthres] q;\n", " for (k in 1:(nthres))\n", - " q[k] = {ilink}({th('k')});\n", - " for (k in 1:(nthres + 1)) {{\n", + " q[k] = {inv_link}({th('k')});\n", + " for (k in 1:(nthres + 1)) {{\n", " p[k] = 1.0;\n", " for (kk in 1:(k - 1)) p[k] = p[k] * q[kk];\n", - " for (kk in k:(nthres)) p[k] = p[k] * (1 - q[kk]);\n", + " for (kk in k:(nthres)) p[k] = p[k] * (1 - q[kk]);\n", " }}\n", - " return log(p[y] / sum(p));\n", + " return log(p[y]) - log(sum(p));\n", " }}\n" ) } @@ -636,16 +635,16 @@ " * disc: discrimination parameter\n", " * thres: vector of merged ordinal thresholds\n", " * j: start and end index for the applid threshold within 'thres'\n", - " * Returns:\n", + " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", - " real {family}_{link}_merged_lpmf(", + " real {family}_{link}_merged_lpmf(", "int y, real mu, real disc, vector thres, int[] j) {{\n", " return {family}_{link}_lpmf(y | mu, disc, thres[j[1]:j[2]]);\n", " }}\n" ) if (family == "cumulative" && link == "logit") { - # use the more efficient 'ordered_logistic' built-in function + # use the more efficient 'ordered_logistic' built-in function str_add(out) <- glue( " /* ordered-logistic log-PDF for a single response and merged thresholds\n", " * Args:\n", @@ -653,10 +652,10 @@ " * mu: latent mean parameter\n", " * thres: vector of merged ordinal thresholds\n", " * j: start and end index for the applid threshold within 'thres'\n", - " * Returns:\n", + " * Returns:\n", " * a scalar to be added to the log posterior\n", " */\n", - " real ordered_logistic_merged_lpmf(", + " real ordered_logistic_merged_lpmf(", "int y, real mu, vector thres, int[] j) {{\n", " return ordered_logistic_lpmf(y | mu, thres[j[1]:j[2]]);\n", " }}\n" diff -Nru r-cran-brms-2.16.3/R/stanvars.R r-cran-brms-2.17.0/R/stanvars.R --- r-cran-brms-2.16.3/R/stanvars.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/stanvars.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,257 +1,257 @@ -#' User-defined variables passed to Stan -#' -#' Prepare user-defined variables to be passed to one of Stan's -#' program blocks. This is primarily useful for defining more complex -#' priors, for refitting models without recompilation despite -#' changing priors, or for defining custom Stan functions. -#' -#' @aliases stanvars -#' -#' @param x An \R object containing data to be passed to Stan. -#' Only required if \code{block = 'data'} and ignored otherwise. -#' @param name Optional character string providing the desired variable -#' name of the object in \code{x}. If \code{NULL} (the default) -#' the variable name is directly inferred from \code{x}. -#' @param scode Line of Stan code to define the variable -#' in Stan language. If \code{block = 'data'}, the -#' Stan code is inferred based on the class of \code{x} by default. -#' @param block Name of one of Stan's program blocks in -#' which the variable should be defined. Can be \code{'data'}, -#' \code{'tdata'} (transformed data), \code{'parameters'}, -#' \code{'tparameters'} (transformed parameters), \code{'model'}, -#' \code{'likelihood'} (part of the model block where the likelihood is given), -#' \code{'genquant'} (generated quantities) or \code{'functions'}. -#' @param position Name of the position within the block where the -#' Stan code should be placed. Currently allowed are \code{'start'} -#' (the default) and \code{'end'} of the block. -#' @param pll_args Optional Stan code to be put into the header -#' of \code{partial_log_lik} functions. This ensures that the variables -#' specified in \code{scode} can be used in the likelihood even when -#' within-chain parallelization is activated via \code{\link{threading}}. -#' -#' @return An object of class \code{stanvars}. -#' -#' @examples -#' bprior <- prior(normal(mean_intercept, 10), class = "Intercept") -#' stanvars <- stanvar(5, name = "mean_intercept") -#' make_stancode(count ~ Trt, epilepsy, prior = bprior, -#' stanvars = stanvars) -#' -#' # define a multi-normal prior with known covariance matrix -#' bprior <- prior(multi_normal(M, V), class = "b") -#' stanvars <- stanvar(rep(0, 2), "M", scode = " vector[K] M;") + -#' stanvar(diag(2), "V", scode = " matrix[K, K] V;") -#' make_stancode(count ~ Trt + zBase, epilepsy, -#' prior = bprior, stanvars = stanvars) -#' -#' # define a hierachical prior on the regression coefficients -#' bprior <- set_prior("normal(0, tau)", class = "b") + -#' set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) -#' stanvars <- stanvar(scode = "real tau;", -#' block = "parameters") -#' make_stancode(count ~ Trt + zBase, epilepsy, -#' prior = bprior, stanvars = stanvars) -#' -#' # ensure that 'tau' is passed to the likelihood of a threaded model -#' # not necessary for this example but may be necessary in other cases -#' stanvars <- stanvar(scode = "real tau;", -#' block = "parameters", pll_args = "real tau") -#' make_stancode(count ~ Trt + zBase, epilepsy, -#' stanvars = stanvars, threads = threading(2)) -#' -#' @export -stanvar <- function(x = NULL, name = NULL, scode = NULL, - block = "data", position = "start", - pll_args = NULL) { - vblocks <- c( - "data", "tdata", "parameters", "tparameters", - "model", "genquant", "functions", "likelihood" - ) - block <- match.arg(block, vblocks) - vpositions <- c("start", "end") - position <- match.arg(position, vpositions) - if (block == "data") { - if (is.null(x)) { - stop2("Argument 'x' is required if block = 'data'.") - } - if (is.null(name)) { - name <- deparse(substitute(x)) - } - name <- as_one_character(name) - if (!is_equal(name, make.names(name)) || grepl("\\.", name)) { - stop2("'", limit_chars(name, 30), "' is not ", - "a valid variable name in Stan.") - } - if (is.null(scode)) { - # infer scode from x - if (is.integer(x)) { - if (length(x) == 1L) { - scode <- paste0("int ", name) - } else { - scode <- paste0("int ", name, "[", length(x), "]") - } - } else if (is.vector(x)) { - if (length(x) == 1L) { - scode <- paste0("real ", name) - } else { - scode <- paste0("vector[", length(x), "] ", name) - } - } else if (is.array(x)) { - if (length(dim(x)) == 1L) { - scode <- paste0("vector[", length(x), "] ", name) - } else if (is.matrix(x)) { - scode <- paste0("matrix[", nrow(x), ", ", ncol(x), "] ", name) - } - } - if (is.null(scode)) { - stop2( - "'stanvar' could not infer the Stan code for an object ", - "of class '", class(x), "'. Please specify the Stan code ", - "manually via argument 'scode'." - ) - } - scode <- paste0(scode, ";") - } - if (is.null(pll_args)) { - # infer pll_args from x - pll_type <- str_if(block %in% c("data", "tdata"), "data ") - if (is.integer(x)) { - if (length(x) == 1L) { - pll_type <- paste0(pll_type, "int") - } else { - pll_type <- paste0(pll_type, "int[]") - } - } else if (is.vector(x)) { - if (length(x) == 1L) { - pll_type <- paste0(pll_type, "real") - } else { - pll_type <- paste0(pll_type, "vector") - } - } else if (is.array(x)) { - if (length(dim(x)) == 1L) { - pll_type <- paste0(pll_type, "vector") - } else if (is.matrix(x)) { - pll_type <- paste0(pll_type, "matrix") - } - } - if (!is.null(pll_type)) { - pll_args <- paste0(pll_type, " ", name) - } else { - # don't throw an error because most people will not use threading - pll_args <- character(0) - } - } - } else { - x <- NULL - if (is.null(name)) { - name <- "" - } - name <- as_one_character(name) - if (is.null(scode)) { - stop2("Argument 'scode' is required if block is not 'data'.") - } - scode <- as.character(scode) - pll_args <- as.character(pll_args) - } - if (position == "end" && block %in% c("functions", "data")) { - stop2("Position '", position, "' is not sensible for block '", block, "'.") - } - out <- nlist(name, sdata = x, scode, block, position, pll_args) - structure(setNames(list(out), name), class = "stanvars") -} - -# take a subset of a stanvars object -# @param x a stanvars object -# @param ... conditions defining the desired subset -subset_stanvars <- function(x, ...) { - x <- validate_stanvars(x) - structure_not_null(x[find_elements(x, ...)], class = "stanvars") -} - -# collapse Stan code provided in a stanvars object -collapse_stanvars <- function(x, block = NULL, position = NULL) { - x <- validate_stanvars(x) - if (!length(x)) { - return(character(0)) - } - if (!is.null(block)) { - x <- subset_stanvars(x, block = block) - } - if (!is.null(position)) { - x <- subset_stanvars(x, position = position) - } - if (!length(x)) { - return("") - } - collapse(wsp(nsp = 2), ulapply(x, "[[", "scode"), "\n") -} - -# collapse partial lpg-lik code provided in a stanvars object -collapse_stanvars_pll_args <- function(x) { - x <- validate_stanvars(x) - if (!length(x)) { - return(character(0)) - } - out <- ulapply(x, "[[", "pll_args") - if (!length(out)) { - return("") - } - collapse(", ", out) -} - -# validate 'stanvars' objects -validate_stanvars <- function(x, stan_funs = NULL) { - if (is.null(x)) { - x <- empty_stanvars() - } - if (!is.stanvars(x)) { - stop2("Argument 'stanvars' is invalid. See ?stanvar for help.") - } - if (length(stan_funs) > 0) { - warning2("Argument 'stan_funs' is deprecated. Please use argument ", - "'stanvars' instead. See ?stanvar for more help.") - stan_funs <- as_one_character(stan_funs) - x <- x + stanvar(scode = stan_funs, block = "functions") - } - x -} - -# add new data to stanvars -# @param x a 'stanvars' object -# @param newdata2 a list with new 'data2' objects -# @return a 'stanvars' object -add_newdata_stanvars <- function(x, newdata2) { - stopifnot(is.stanvars(x)) - stanvars_data <- subset_stanvars(x, block = "data") - for (name in names(stanvars_data)) { - if (name %in% names(newdata2)) { - x[[name]]$sdata <- newdata2[[name]] - } - } - x -} - -#' @export -c.stanvars <- function(x, ...) { - dots <- lapply(list(...), validate_stanvars) - class(x) <- "list" - out <- unlist(c(list(x), dots), recursive = FALSE) - svnames <- names(out)[nzchar(names(out))] - if (any(duplicated(svnames))) { - stop2("Duplicated names in 'stanvars' are not allowed.") - } - structure(out, class = "stanvars") -} - -#' @export -"+.stanvars" <- function(e1, e2) { - c(e1, e2) -} - -is.stanvars <- function(x) { - inherits(x, "stanvars") -} - -empty_stanvars <- function() { - structure(list(), class = "stanvars") -} +#' User-defined variables passed to Stan +#' +#' Prepare user-defined variables to be passed to one of Stan's +#' program blocks. This is primarily useful for defining more complex +#' priors, for refitting models without recompilation despite +#' changing priors, or for defining custom Stan functions. +#' +#' @aliases stanvars +#' +#' @param x An \R object containing data to be passed to Stan. +#' Only required if \code{block = 'data'} and ignored otherwise. +#' @param name Optional character string providing the desired variable +#' name of the object in \code{x}. If \code{NULL} (the default) +#' the variable name is directly inferred from \code{x}. +#' @param scode Line of Stan code to define the variable +#' in Stan language. If \code{block = 'data'}, the +#' Stan code is inferred based on the class of \code{x} by default. +#' @param block Name of one of Stan's program blocks in +#' which the variable should be defined. Can be \code{'data'}, +#' \code{'tdata'} (transformed data), \code{'parameters'}, +#' \code{'tparameters'} (transformed parameters), \code{'model'}, +#' \code{'likelihood'} (part of the model block where the likelihood is given), +#' \code{'genquant'} (generated quantities) or \code{'functions'}. +#' @param position Name of the position within the block where the +#' Stan code should be placed. Currently allowed are \code{'start'} +#' (the default) and \code{'end'} of the block. +#' @param pll_args Optional Stan code to be put into the header +#' of \code{partial_log_lik} functions. This ensures that the variables +#' specified in \code{scode} can be used in the likelihood even when +#' within-chain parallelization is activated via \code{\link{threading}}. +#' +#' @return An object of class \code{stanvars}. +#' +#' @examples +#' bprior <- prior(normal(mean_intercept, 10), class = "Intercept") +#' stanvars <- stanvar(5, name = "mean_intercept") +#' make_stancode(count ~ Trt, epilepsy, prior = bprior, +#' stanvars = stanvars) +#' +#' # define a multi-normal prior with known covariance matrix +#' bprior <- prior(multi_normal(M, V), class = "b") +#' stanvars <- stanvar(rep(0, 2), "M", scode = " vector[K] M;") + +#' stanvar(diag(2), "V", scode = " matrix[K, K] V;") +#' make_stancode(count ~ Trt + zBase, epilepsy, +#' prior = bprior, stanvars = stanvars) +#' +#' # define a hierachical prior on the regression coefficients +#' bprior <- set_prior("normal(0, tau)", class = "b") + +#' set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) +#' stanvars <- stanvar(scode = "real tau;", +#' block = "parameters") +#' make_stancode(count ~ Trt + zBase, epilepsy, +#' prior = bprior, stanvars = stanvars) +#' +#' # ensure that 'tau' is passed to the likelihood of a threaded model +#' # not necessary for this example but may be necessary in other cases +#' stanvars <- stanvar(scode = "real tau;", +#' block = "parameters", pll_args = "real tau") +#' make_stancode(count ~ Trt + zBase, epilepsy, +#' stanvars = stanvars, threads = threading(2)) +#' +#' @export +stanvar <- function(x = NULL, name = NULL, scode = NULL, + block = "data", position = "start", + pll_args = NULL) { + vblocks <- c( + "data", "tdata", "parameters", "tparameters", + "model", "genquant", "functions", "likelihood" + ) + block <- match.arg(block, vblocks) + vpositions <- c("start", "end") + position <- match.arg(position, vpositions) + if (block == "data") { + if (is.null(x)) { + stop2("Argument 'x' is required if block = 'data'.") + } + if (is.null(name)) { + name <- deparse(substitute(x)) + } + name <- as_one_character(name) + if (!is_equal(name, make.names(name)) || grepl("\\.", name)) { + stop2("'", limit_chars(name, 30), "' is not ", + "a valid variable name in Stan.") + } + if (is.null(scode)) { + # infer scode from x + if (is.integer(x)) { + if (length(x) == 1L) { + scode <- paste0("int ", name) + } else { + scode <- paste0("int ", name, "[", length(x), "]") + } + } else if (is.vector(x)) { + if (length(x) == 1L) { + scode <- paste0("real ", name) + } else { + scode <- paste0("vector[", length(x), "] ", name) + } + } else if (is.array(x)) { + if (length(dim(x)) == 1L) { + scode <- paste0("vector[", length(x), "] ", name) + } else if (is.matrix(x)) { + scode <- paste0("matrix[", nrow(x), ", ", ncol(x), "] ", name) + } + } + if (is.null(scode)) { + stop2( + "'stanvar' could not infer the Stan code for an object ", + "of class '", class(x), "'. Please specify the Stan code ", + "manually via argument 'scode'." + ) + } + scode <- paste0(scode, ";") + } + if (is.null(pll_args)) { + # infer pll_args from x + pll_type <- str_if(block %in% c("data", "tdata"), "data ") + if (is.integer(x)) { + if (length(x) == 1L) { + pll_type <- paste0(pll_type, "int") + } else { + pll_type <- paste0(pll_type, "int[]") + } + } else if (is.vector(x)) { + if (length(x) == 1L) { + pll_type <- paste0(pll_type, "real") + } else { + pll_type <- paste0(pll_type, "vector") + } + } else if (is.array(x)) { + if (length(dim(x)) == 1L) { + pll_type <- paste0(pll_type, "vector") + } else if (is.matrix(x)) { + pll_type <- paste0(pll_type, "matrix") + } + } + if (!is.null(pll_type)) { + pll_args <- paste0(pll_type, " ", name) + } else { + # don't throw an error because most people will not use threading + pll_args <- character(0) + } + } + } else { + x <- NULL + if (is.null(name)) { + name <- "" + } + name <- as_one_character(name) + if (is.null(scode)) { + stop2("Argument 'scode' is required if block is not 'data'.") + } + scode <- as.character(scode) + pll_args <- as.character(pll_args) + } + if (position == "end" && block %in% c("functions", "data")) { + stop2("Position '", position, "' is not sensible for block '", block, "'.") + } + out <- nlist(name, sdata = x, scode, block, position, pll_args) + structure(setNames(list(out), name), class = "stanvars") +} + +# take a subset of a stanvars object +# @param x a stanvars object +# @param ... conditions defining the desired subset +subset_stanvars <- function(x, ...) { + x <- validate_stanvars(x) + structure_not_null(x[find_elements(x, ...)], class = "stanvars") +} + +# collapse Stan code provided in a stanvars object +collapse_stanvars <- function(x, block = NULL, position = NULL) { + x <- validate_stanvars(x) + if (!length(x)) { + return(character(0)) + } + if (!is.null(block)) { + x <- subset_stanvars(x, block = block) + } + if (!is.null(position)) { + x <- subset_stanvars(x, position = position) + } + if (!length(x)) { + return("") + } + collapse(wsp(nsp = 2), ulapply(x, "[[", "scode"), "\n") +} + +# collapse partial lpg-lik code provided in a stanvars object +collapse_stanvars_pll_args <- function(x) { + x <- validate_stanvars(x) + if (!length(x)) { + return(character(0)) + } + out <- ulapply(x, "[[", "pll_args") + if (!length(out)) { + return("") + } + collapse(", ", out) +} + +# validate 'stanvars' objects +validate_stanvars <- function(x, stan_funs = NULL) { + if (is.null(x)) { + x <- empty_stanvars() + } + if (!is.stanvars(x)) { + stop2("Argument 'stanvars' is invalid. See ?stanvar for help.") + } + if (length(stan_funs) > 0) { + warning2("Argument 'stan_funs' is deprecated. Please use argument ", + "'stanvars' instead. See ?stanvar for more help.") + stan_funs <- as_one_character(stan_funs) + x <- x + stanvar(scode = stan_funs, block = "functions") + } + x +} + +# add new data to stanvars +# @param x a 'stanvars' object +# @param newdata2 a list with new 'data2' objects +# @return a 'stanvars' object +add_newdata_stanvars <- function(x, newdata2) { + stopifnot(is.stanvars(x)) + stanvars_data <- subset_stanvars(x, block = "data") + for (name in names(stanvars_data)) { + if (name %in% names(newdata2)) { + x[[name]]$sdata <- newdata2[[name]] + } + } + x +} + +#' @export +c.stanvars <- function(x, ...) { + dots <- lapply(list(...), validate_stanvars) + class(x) <- "list" + out <- unlist(c(list(x), dots), recursive = FALSE) + svnames <- names(out)[nzchar(names(out))] + if (any(duplicated(svnames))) { + stop2("Duplicated names in 'stanvars' are not allowed.") + } + structure(out, class = "stanvars") +} + +#' @export +"+.stanvars" <- function(e1, e2) { + c(e1, e2) +} + +is.stanvars <- function(x) { + inherits(x, "stanvars") +} + +empty_stanvars <- function() { + structure(list(), class = "stanvars") +} diff -Nru r-cran-brms-2.16.3/R/summary.R r-cran-brms-2.17.0/R/summary.R --- r-cran-brms-2.16.3/R/summary.R 2021-08-26 17:47:34.000000000 +0000 +++ r-cran-brms-2.17.0/R/summary.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,578 +1,593 @@ -#' Create a summary of a fitted model represented by a \code{brmsfit} object -#' -#' @param object An object of class \code{brmsfit}. -#' @param priors Logical; Indicating if priors should be included -#' in the summary. Default is \code{FALSE}. -#' @param prob A value between 0 and 1 indicating the desired probability -#' to be covered by the uncertainty intervals. The default is 0.95. -#' @param mc_se Logical; Indicating if the uncertainty in \code{Estimate} -#' caused by the MCMC sampling should be shown in the summary. Defaults to -#' \code{FALSE}. -#' @param ... Other potential arguments -#' @inheritParams posterior_summary -#' -#' @details The convergence diagnostics \code{Rhat}, \code{Bulk_ESS}, and -#' \code{Tail_ESS} are described in detail in Vehtari et al. (2020). -#' -#' @references -#' Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and -#' Paul-Christian Bürkner (2020). Rank-normalization, folding, and -#' localization: An improved R-hat for assessing convergence of -#' MCMC. *Bayesian Analysis*. 1–28. dpi:10.1214/20-BA1221 -#' -#' @method summary brmsfit -#' @importMethodsFrom rstan summary -#' @importFrom posterior subset_draws summarize_draws -#' @export -summary.brmsfit <- function(object, priors = FALSE, prob = 0.95, - robust = FALSE, mc_se = FALSE, ...) { - priors <- as_one_logical(priors) - probs <- validate_ci_bounds(prob) - robust <- as_one_logical(robust) - mc_se <- as_one_logical(mc_se) - object <- restructure(object) - bterms <- brmsterms(object$formula) - out <- list( - formula = object$formula, - data_name = get_data_name(object$data), - group = unique(object$ranef$group), - nobs = nobs(object), - ngrps = ngrps(object), - autocor = object$autocor, - prior = empty_prior(), - algorithm = algorithm(object) - ) - class(out) <- "brmssummary" - if (!length(object$fit@sim)) { - # the model does not contain posterior draws - return(out) - } - out$chains <- nchains(object) - out$iter <- niterations(object) + nwarmup(object) - out$warmup <- nwarmup(object) - out$thin <- nthin(object) - stan_args <- object$fit@stan_args[[1]] - out$sampler <- paste0(stan_args$method, "(", stan_args$algorithm, ")") - if (priors) { - out$prior <- prior_summary(object, all = FALSE) - } - - # compute a summary for given set of parameters - # TODO: align names with summary outputs of other methods and packages - .summary <- function(draws, variables, probs, robust) { - # quantiles with appropriate names to retain backwards compatibility - .quantile <- function(x, ...) { - qs <- posterior::quantile2(x, probs = probs, ...) - prob <- probs[2] - probs[1] - names(qs) <- paste0(c("l-", "u-"), prob * 100, "% CI") - return(qs) - } - draws <- subset_draws(draws, variable = variables) - measures <- list() - if (robust) { - measures$Estimate <- median - if (mc_se) { - measures$MCSE <- posterior::mcse_median - } - measures$Est.Error <- mad - } else { - measures$Estimate <- mean - if (mc_se) { - measures$MCSE <- posterior::mcse_mean - } - measures$Est.Error <- sd - } - c(measures) <- list( - quantiles = .quantile, - Rhat = posterior::rhat, - Bulk_ESS = posterior::ess_bulk, - Tail_ESS = posterior::ess_tail - ) - out <- do.call(summarize_draws, c(list(draws), measures)) - out <- as.data.frame(out) - rownames(out) <- out$variable - out$variable <- NULL - return(out) - } - - variables <- variables(object) - excl_regex <- "^(r|s|z|zs|zgp|Xme|L|Lrescor|prior|lp)(_|$)" - variables <- variables[!grepl(excl_regex, variables)] - draws <- as_draws_array(object) - full_summary <- .summary(draws, variables, probs, robust) - if (algorithm(object) == "sampling") { - Rhats <- full_summary[, "Rhat"] - if (any(Rhats > 1.05, na.rm = TRUE)) { - warning2( - "Parts of the model have not converged (some Rhats are > 1.05). ", - "Be careful when analysing the results! We recommend running ", - "more iterations and/or setting stronger priors." - ) - } - div_trans <- sum(nuts_params(object, pars = "divergent__")$Value) - adapt_delta <- control_params(object)$adapt_delta - if (div_trans > 0) { - warning2( - "There were ", div_trans, " divergent transitions after warmup. ", - "Increasing adapt_delta above ", adapt_delta, " may help. See ", - "http://mc-stan.org/misc/warnings.html#divergent-transitions-after-warmup" - ) - } - } - - # summary of population-level effects - fe_pars <- variables[grepl(fixef_pars(), variables)] - out$fixed <- full_summary[fe_pars, , drop = FALSE] - rownames(out$fixed) <- gsub(fixef_pars(), "", fe_pars) - - # summary of family specific parameters - spec_pars <- c(valid_dpars(object), "delta") - spec_pars <- paste0(spec_pars, collapse = "|") - spec_pars <- paste0("^(", spec_pars, ")($|_)") - spec_pars <- variables[grepl(spec_pars, variables)] - out$spec_pars <- full_summary[spec_pars, , drop = FALSE] - - # summary of residual correlations - rescor_pars <- variables[grepl("^rescor_", variables)] - if (length(rescor_pars)) { - out$rescor_pars <- full_summary[rescor_pars, , drop = FALSE] - rescor_pars <- sub("__", ",", sub("__", "(", rescor_pars)) - rownames(out$rescor_pars) <- paste0(rescor_pars, ")") - } - - # summary of autocorrelation effects - cor_pars <- variables[grepl(regex_autocor_pars(), variables)] - out$cor_pars <- full_summary[cor_pars, , drop = FALSE] - rownames(out$cor_pars) <- cor_pars - - # summary of group-level effects - for (g in out$group) { - gregex <- escape_dot(g) - sd_prefix <- paste0("^sd_", gregex, "__") - sd_pars <- variables[grepl(sd_prefix, variables)] - cor_prefix <- paste0("^cor_", gregex, "__") - cor_pars <- variables[grepl(cor_prefix, variables)] - df_prefix <- paste0("^df_", gregex, "$") - df_pars <- variables[grepl(df_prefix, variables)] - gpars <- c(df_pars, sd_pars, cor_pars) - out$random[[g]] <- full_summary[gpars, , drop = FALSE] - if (has_rows(out$random[[g]])) { - sd_names <- sub(sd_prefix, "sd(", sd_pars) - cor_names <- sub(cor_prefix, "cor(", cor_pars) - cor_names <- sub("__", ",", cor_names) - df_names <- sub(df_prefix, "df", df_pars) - gnames <- c(df_names, paste0(c(sd_names, cor_names), ")")) - rownames(out$random[[g]]) <- gnames - } - } - # summary of smooths - sm_pars <- variables[grepl("^sds_", variables)] - if (length(sm_pars)) { - out$splines <- full_summary[sm_pars, , drop = FALSE] - rownames(out$splines) <- paste0(gsub("^sds_", "sds(", sm_pars), ")") - } - # summary of monotonic parameters - mo_pars <- variables[grepl("^simo_", variables)] - if (length(mo_pars)) { - out$mo <- full_summary[mo_pars, , drop = FALSE] - rownames(out$mo) <- gsub("^simo_", "", mo_pars) - } - # summary of gaussian processes - gp_pars <- variables[grepl("^(sdgp|lscale)_", variables)] - if (length(gp_pars)) { - out$gp <- full_summary[gp_pars, , drop = FALSE] - rownames(out$gp) <- gsub("^sdgp_", "sdgp(", rownames(out$gp)) - rownames(out$gp) <- gsub("^lscale_", "lscale(", rownames(out$gp)) - rownames(out$gp) <- paste0(rownames(out$gp), ")") - } - out -} - -#' Print a summary for a fitted model represented by a \code{brmsfit} object -#' -#' @aliases print.brmssummary -#' -#' @param x An object of class \code{brmsfit} -#' @param digits The number of significant digits for printing out the summary; -#' defaults to 2. The effective sample size is always rounded to integers. -#' @param ... Additional arguments that would be passed -#' to method \code{summary} of \code{brmsfit}. -#' -#' @seealso \code{\link{summary.brmsfit}} -#' -#' @export -print.brmsfit <- function(x, digits = 2, ...) { - print(summary(x, ...), digits = digits, ...) -} - -#' @export -print.brmssummary <- function(x, digits = 2, ...) { - cat(" Family: ") - cat(summarise_families(x$formula), "\n") - cat(" Links: ") - cat(summarise_links(x$formula, wsp = 9), "\n") - cat("Formula: ") - print(x$formula, wsp = 9) - cat(paste0( - " Data: ", x$data_name, - " (Number of observations: ", x$nobs, ") \n" - )) - if (!isTRUE(nzchar(x$sampler))) { - cat("\nThe model does not contain posterior draws.\n") - } else { - total_ndraws <- ceiling((x$iter - x$warmup) / x$thin * x$chains) - cat(paste0( - " Draws: ", x$chains, " chains, each with iter = ", x$iter, - "; warmup = ", x$warmup, "; thin = ", x$thin, ";\n", - " total post-warmup draws = ", total_ndraws, "\n\n" - )) - if (nrow(x$prior)) { - cat("Priors: \n") - print(x$prior, show_df = FALSE) - cat("\n") - } - if (length(x$splines)) { - cat("Smooth Terms: \n") - print_format(x$splines, digits) - cat("\n") - } - if (length(x$gp)) { - cat("Gaussian Process Terms: \n") - print_format(x$gp, digits) - cat("\n") - } - if (nrow(x$cor_pars)) { - cat("Correlation Structures:\n") - # TODO: better printing for correlation structures? - print_format(x$cor_pars, digits) - cat("\n") - } - if (length(x$random)) { - cat("Group-Level Effects: \n") - for (i in seq_along(x$random)) { - g <- names(x$random)[i] - cat(paste0("~", g, " (Number of levels: ", x$ngrps[[g]], ") \n")) - print_format(x$random[[g]], digits) - cat("\n") - } - } - if (nrow(x$fixed)) { - cat("Population-Level Effects: \n") - print_format(x$fixed, digits) - cat("\n") - } - if (length(x$mo)) { - cat("Simplex Parameters: \n") - print_format(x$mo, digits) - cat("\n") - } - if (nrow(x$spec_pars)) { - cat("Family Specific Parameters: \n") - print_format(x$spec_pars, digits) - cat("\n") - } - if (length(x$rescor_pars)) { - cat("Residual Correlations: \n") - print_format(x$rescor, digits) - cat("\n") - } - cat(paste0("Draws were sampled using ", x$sampler, ". ")) - if (x$algorithm == "sampling") { - cat(paste0( - "For each parameter, Bulk_ESS\n", - "and Tail_ESS are effective sample size measures, ", - "and Rhat is the potential\n", - "scale reduction factor on split chains ", - "(at convergence, Rhat = 1)." - )) - } - cat("\n") - } - invisible(x) -} - -# helper function to print summary matrices in nice format -# also displays -0.00 as a result of round negative values to zero (#263) -# @param x object to be printed; coerced to matrix -# @param digits number of digits to show -# @param no_digits names of columns for which no digits should be shown -print_format <- function(x, digits = 2, no_digits = c("Bulk_ESS", "Tail_ESS")) { - x <- as.matrix(x) - digits <- as.numeric(digits) - if (length(digits) != 1L) { - stop2("'digits' should be a single numeric value.") - } - out <- x - fmt <- paste0("%.", digits, "f") - for (i in seq_cols(x)) { - if (isTRUE(colnames(x)[i] %in% no_digits)) { - out[, i] <- sprintf("%.0f", x[, i]) - } else { - out[, i] <- sprintf(fmt, x[, i]) - } - } - print(out, quote = FALSE, right = TRUE) - invisible(x) -} - -# regex to extract population-level coefficients -fixef_pars <- function() { - types <- c("", "s", "cs", "sp", "mo", "me", "mi", "m") - types <- paste0("(", types, ")", collapse = "|") - paste0("^b(", types, ")_") -} - -# algorithm used in the model fitting -algorithm <- function(x) { - stopifnot(is.brmsfit(x)) - if (is.null(x$algorithm)) "sampling" - else x$algorithm -} - -#' Summarize Posterior draws -#' -#' Summarizes posterior draws based on point estimates (mean or median), -#' estimation errors (SD or MAD) and quantiles. This function mainly exists to -#' retain backwards compatibility. It will eventually be replaced by functions -#' of the \pkg{posterior} package (see examples below). -#' -#' @param x An \R object. -#' @inheritParams as.matrix.brmsfit -#' @param probs The percentiles to be computed by the -#' \code{\link[stats:quantile]{quantile}} function. -#' @param robust If \code{FALSE} (the default) the mean is used as -#' the measure of central tendency and the standard deviation as -#' the measure of variability. If \code{TRUE}, the median and the -#' median absolute deviation (MAD) are applied instead. -#' @param ... More arguments passed to or from other methods. -#' -#' @return A matrix where rows indicate variables -#' and columns indicate the summary estimates. -#' -#' @seealso \code{\link[posterior:summarize_draws]{summarize_draws}} -#' -#' @examples -#' \dontrun{ -#' fit <- brm(time ~ age * sex, data = kidney) -#' posterior_summary(fit) -#' -#' # recommended workflow using posterior -#' library(posterior) -#' draws <- as_draws_array(fit) -#' summarise_draws(draws, default_summary_measures()) -#' } -#' -#' @export -posterior_summary <- function(x, ...) { - UseMethod("posterior_summary") -} - -#' @rdname posterior_summary -#' @export -posterior_summary.default <- function(x, probs = c(0.025, 0.975), - robust = FALSE, ...) { - # TODO: replace with summary functions from posterior - # TODO: find a way to represent 3D summaries as well - if (!length(x)) { - stop2("No posterior draws supplied.") - } - if (robust) { - coefs <- c("median", "mad", "quantile") - } else { - coefs <- c("mean", "sd", "quantile") - } - .posterior_summary <- function(x) { - do_call(cbind, lapply( - coefs, get_estimate, draws = x, - probs = probs, na.rm = TRUE - )) - } - if (length(dim(x)) <= 2L) { - # data.frames cause trouble in as.array - x <- as.matrix(x) - } else { - x <- as.array(x) - } - if (length(dim(x)) == 2L) { - out <- .posterior_summary(x) - rownames(out) <- colnames(x) - } else if (length(dim(x)) == 3L) { - out <- lapply(array2list(x), .posterior_summary) - out <- abind(out, along = 3) - dnx <- dimnames(x) - dimnames(out) <- list(dnx[[2]], dimnames(out)[[2]], dnx[[3]]) - } else { - stop("'x' must be of dimension 2 or 3.") - } - # TODO: align names with summary outputs of other methods and packages - colnames(out) <- c("Estimate", "Est.Error", paste0("Q", probs * 100)) - out -} - -#' @rdname posterior_summary -#' @export -posterior_summary.brmsfit <- function(x, pars = NA, variable = NULL, - probs = c(0.025, 0.975), - robust = FALSE, ...) { - out <- as.matrix(x, pars = pars, variable = variable, ...) - posterior_summary(out, probs = probs, robust = robust, ...) -} - -# calculate estimates over posterior draws -# @param coef coefficient to be applied on the draws (e.g., "mean") -# @param draws the draws over which to apply coef -# @param margin see 'apply' -# @param ... additional arguments passed to get(coef) -# @return typically a matrix with colnames(draws) as colnames -get_estimate <- function(coef, draws, margin = 2, ...) { - # TODO: replace with summary functions from posterior - dots <- list(...) - args <- list(X = draws, MARGIN = margin, FUN = coef) - fun_args <- names(formals(coef)) - if (!"..." %in% fun_args) { - dots <- dots[names(dots) %in% fun_args] - } - x <- do_call(apply, c(args, dots)) - if (is.null(dim(x))) { - x <- matrix(x, dimnames = list(NULL, coef)) - } else if (coef == "quantile") { - x <- aperm(x, length(dim(x)):1) - } - x -} - -# validate bounds of credible intervals -# @return a numeric vector of length 2 -validate_ci_bounds <- function(prob, probs = NULL) { - if (!is.null(probs)) { - # deprecated as of version 2.13.7 - warning2("Argument 'probs' is deprecated. Please use 'prob' instead.") - if (length(probs) != 2L) { - stop2("Arguments 'probs' must be of length 2.") - } - probs <- as.numeric(probs) - } else { - prob <- as_one_numeric(prob) - if (prob < 0 || prob > 1) { - stop2("'prob' must be a single numeric value in [0, 1].") - } - probs <- c((1 - prob) / 2, 1 - (1 - prob) / 2) - } - probs -} - -#' Table Creation for Posterior Draws -#' -#' Create a table for unique values of posterior draws. -#' This is usually only useful when summarizing predictions -#' of ordinal models. -#' -#' @param x A matrix of posterior draws where rows -#' indicate draws and columns indicate parameters. -#' @param levels Optional values of possible posterior values. -#' Defaults to all unique values in \code{x}. -#' -#' @return A matrix where rows indicate parameters -#' and columns indicate the unique values of -#' posterior draws. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(rating ~ period + carry + treat, -#' data = inhaler, family = cumulative()) -#' pr <- predict(fit, summary = FALSE) -#' posterior_table(pr) -#' } -#' -#' @export -posterior_table <- function(x, levels = NULL) { - x <- as.matrix(x) - if (anyNA(x)) { - warning2("NAs will be ignored in 'posterior_table'.") - } - if (is.null(levels)) { - levels <- sort(unique(as.vector(x))) - } - xlevels <- attr(x, "levels") - if (length(xlevels) != length(levels)) { - xlevels <- levels - } - out <- lapply(seq_len(ncol(x)), - function(n) table(factor(x[, n], levels = levels)) - ) - out <- do_call(rbind, out) - # compute relative frequencies - out <- out / rowSums(out) - rownames(out) <- colnames(x) - colnames(out) <- paste0("P(Y = ", xlevels, ")") - out -} - -#' Compute posterior uncertainty intervals -#' -#' Compute posterior uncertainty intervals for \code{brmsfit} objects. -#' -#' @param object An object of class \code{brmsfit}. -#' @param prob A value between 0 and 1 indicating the desired probability -#' to be covered by the uncertainty intervals. The default is 0.95. -#' @inheritParams as.matrix.brmsfit -#' @param ... More arguments passed to \code{\link{as.matrix.brmsfit}}. -#' -#' @return A \code{matrix} with lower and upper interval bounds -#' as columns and as many rows as selected variables. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt, -#' data = epilepsy, family = negbinomial()) -#' posterior_interval(fit) -#' } -#' -#' @aliases posterior_interval -#' @method posterior_interval brmsfit -#' @export -#' @export posterior_interval -#' @importFrom rstantools posterior_interval -posterior_interval.brmsfit <- function( - object, pars = NA, variable = NULL, prob = 0.95, ... -) { - ps <- as.matrix(object, pars = pars, variable = variable, ...) - rstantools::posterior_interval(ps, prob = prob) -} - -#' Extract Priors of a Bayesian Model Fitted with \pkg{brms} -#' -#' @aliases prior_summary -#' -#' @param object An object of class \code{brmsfit}. -#' @param all Logical; Show all parameters in the model which may have -#' priors (\code{TRUE}) or only those with proper priors (\code{FALSE})? -#' @param ... Further arguments passed to or from other methods. -#' -#' @return For \code{brmsfit} objects, an object of class \code{brmsprior}. -#' -#' @examples -#' \dontrun{ -#' fit <- brm(count ~ zAge + zBase * Trt -#' + (1|patient) + (1|obs), -#' data = epilepsy, family = poisson(), -#' prior = c(prior(student_t(5,0,10), class = b), -#' prior(cauchy(0,2), class = sd))) -#' -#' prior_summary(fit) -#' prior_summary(fit, all = FALSE) -#' print(prior_summary(fit, all = FALSE), show_df = FALSE) -#' } -#' -#' @method prior_summary brmsfit -#' @export -#' @export prior_summary -#' @importFrom rstantools prior_summary -prior_summary.brmsfit <- function(object, all = TRUE, ...) { - object <- restructure(object) - prior <- object$prior - if (!all) { - prior <- prior[nzchar(prior$prior), ] - } - prior -} +#' Create a summary of a fitted model represented by a \code{brmsfit} object +#' +#' @param object An object of class \code{brmsfit}. +#' @param priors Logical; Indicating if priors should be included +#' in the summary. Default is \code{FALSE}. +#' @param prob A value between 0 and 1 indicating the desired probability +#' to be covered by the uncertainty intervals. The default is 0.95. +#' @param mc_se Logical; Indicating if the uncertainty in \code{Estimate} +#' caused by the MCMC sampling should be shown in the summary. Defaults to +#' \code{FALSE}. +#' @param ... Other potential arguments +#' @inheritParams posterior_summary +#' +#' @details The convergence diagnostics \code{Rhat}, \code{Bulk_ESS}, and +#' \code{Tail_ESS} are described in detail in Vehtari et al. (2020). +#' +#' @references +#' Aki Vehtari, Andrew Gelman, Daniel Simpson, Bob Carpenter, and +#' Paul-Christian Bürkner (2020). Rank-normalization, folding, and +#' localization: An improved R-hat for assessing convergence of +#' MCMC. *Bayesian Analysis*. 1–28. dpi:10.1214/20-BA1221 +#' +#' @method summary brmsfit +#' @importMethodsFrom rstan summary +#' @importFrom posterior subset_draws summarize_draws +#' @export +summary.brmsfit <- function(object, priors = FALSE, prob = 0.95, + robust = FALSE, mc_se = FALSE, ...) { + priors <- as_one_logical(priors) + probs <- validate_ci_bounds(prob) + robust <- as_one_logical(robust) + mc_se <- as_one_logical(mc_se) + object <- restructure(object) + bterms <- brmsterms(object$formula) + out <- list( + formula = object$formula, + data_name = get_data_name(object$data), + group = unique(object$ranef$group), + nobs = nobs(object), + ngrps = ngrps(object), + autocor = object$autocor, + prior = empty_prior(), + algorithm = algorithm(object) + ) + class(out) <- "brmssummary" + if (!length(object$fit@sim)) { + # the model does not contain posterior draws + return(out) + } + out$chains <- nchains(object) + # iterations before thinning + out$iter <- object$fit@sim$iter + out$warmup <- object$fit@sim$warmup + out$thin <- nthin(object) + stan_args <- object$fit@stan_args[[1]] + out$sampler <- paste0(stan_args$method, "(", stan_args$algorithm, ")") + if (priors) { + out$prior <- prior_summary(object, all = FALSE) + } + + # compute a summary for given set of parameters + # TODO: align names with summary outputs of other methods and packages + .summary <- function(draws, variables, probs, robust) { + # quantiles with appropriate names to retain backwards compatibility + .quantile <- function(x, ...) { + qs <- posterior::quantile2(x, probs = probs, ...) + prob <- probs[2] - probs[1] + names(qs) <- paste0(c("l-", "u-"), prob * 100, "% CI") + return(qs) + } + draws <- subset_draws(draws, variable = variables) + measures <- list() + if (robust) { + measures$Estimate <- median + if (mc_se) { + measures$MCSE <- posterior::mcse_median + } + measures$Est.Error <- mad + } else { + measures$Estimate <- mean + if (mc_se) { + measures$MCSE <- posterior::mcse_mean + } + measures$Est.Error <- sd + } + c(measures) <- list( + quantiles = .quantile, + Rhat = posterior::rhat, + Bulk_ESS = posterior::ess_bulk, + Tail_ESS = posterior::ess_tail + ) + out <- do.call(summarize_draws, c(list(draws), measures)) + out <- as.data.frame(out) + rownames(out) <- out$variable + out$variable <- NULL + return(out) + } + + variables <- variables(object) + incl_classes <- c( + "b", "bs", "bcs", "bsp", "bmo", "bme", "bmi", "bm", + valid_dpars(object), "delta", "lncor", "rescor", "ar", "ma", + "sderr", "cosy", "lagsar", "errorsar", "car", "sdcar", "rhocar", + "sd", "cor", "df", "sds", "sdgp", "lscale", "simo" + ) + incl_regex <- paste0("^", regex_or(incl_classes), "(_|$)") + variables <- variables[grepl(incl_regex, variables)] + draws <- as_draws_array(object, variable = variables) + full_summary <- .summary(draws, variables, probs, robust) + if (algorithm(object) == "sampling") { + Rhats <- full_summary[, "Rhat"] + if (any(Rhats > 1.05, na.rm = TRUE)) { + warning2( + "Parts of the model have not converged (some Rhats are > 1.05). ", + "Be careful when analysing the results! We recommend running ", + "more iterations and/or setting stronger priors." + ) + } + div_trans <- sum(nuts_params(object, pars = "divergent__")$Value) + adapt_delta <- control_params(object)$adapt_delta + if (div_trans > 0) { + warning2( + "There were ", div_trans, " divergent transitions after warmup. ", + "Increasing adapt_delta above ", adapt_delta, " may help. See ", + "http://mc-stan.org/misc/warnings.html#divergent-transitions-after-warmup" + ) + } + } + + # summary of population-level effects + fe_pars <- variables[grepl(fixef_pars(), variables)] + out$fixed <- full_summary[fe_pars, , drop = FALSE] + rownames(out$fixed) <- gsub(fixef_pars(), "", fe_pars) + + # summary of family specific parameters + spec_pars <- c(valid_dpars(object), "delta") + spec_pars <- paste0(spec_pars, collapse = "|") + spec_pars <- paste0("^(", spec_pars, ")($|_)") + spec_pars <- variables[grepl(spec_pars, variables)] + out$spec_pars <- full_summary[spec_pars, , drop = FALSE] + # correlation parameters require renaming to look good in the summary + lncor_pars <- variables[grepl("^lncor_", variables)] + if (length(lncor_pars)) { + lncor_summary <- full_summary[lncor_pars, , drop = FALSE] + lncor_pars <- sub("__", ",", sub("__", "(", lncor_pars)) + rownames(lncor_summary) <- paste0(lncor_pars, ")") + out$spec_pars <- rbind(out$spec_pars, lncor_summary) + } + + # summary of residual correlations + rescor_pars <- variables[grepl("^rescor_", variables)] + if (length(rescor_pars)) { + out$rescor_pars <- full_summary[rescor_pars, , drop = FALSE] + rescor_pars <- sub("__", ",", sub("__", "(", rescor_pars)) + rownames(out$rescor_pars) <- paste0(rescor_pars, ")") + } + + # summary of autocorrelation effects + cor_pars <- variables[grepl(regex_autocor_pars(), variables)] + out$cor_pars <- full_summary[cor_pars, , drop = FALSE] + rownames(out$cor_pars) <- cor_pars + + # summary of group-level effects + for (g in out$group) { + gregex <- escape_dot(g) + sd_prefix <- paste0("^sd_", gregex, "__") + sd_pars <- variables[grepl(sd_prefix, variables)] + cor_prefix <- paste0("^cor_", gregex, "__") + cor_pars <- variables[grepl(cor_prefix, variables)] + df_prefix <- paste0("^df_", gregex, "$") + df_pars <- variables[grepl(df_prefix, variables)] + gpars <- c(df_pars, sd_pars, cor_pars) + out$random[[g]] <- full_summary[gpars, , drop = FALSE] + if (has_rows(out$random[[g]])) { + sd_names <- sub(sd_prefix, "sd(", sd_pars) + cor_names <- sub(cor_prefix, "cor(", cor_pars) + cor_names <- sub("__", ",", cor_names) + df_names <- sub(df_prefix, "df", df_pars) + gnames <- c(df_names, paste0(c(sd_names, cor_names), ")")) + rownames(out$random[[g]]) <- gnames + } + } + # summary of smooths + sm_pars <- variables[grepl("^sds_", variables)] + if (length(sm_pars)) { + out$splines <- full_summary[sm_pars, , drop = FALSE] + rownames(out$splines) <- paste0(gsub("^sds_", "sds(", sm_pars), ")") + } + # summary of monotonic parameters + mo_pars <- variables[grepl("^simo_", variables)] + if (length(mo_pars)) { + out$mo <- full_summary[mo_pars, , drop = FALSE] + rownames(out$mo) <- gsub("^simo_", "", mo_pars) + } + # summary of gaussian processes + gp_pars <- variables[grepl("^(sdgp|lscale)_", variables)] + if (length(gp_pars)) { + out$gp <- full_summary[gp_pars, , drop = FALSE] + rownames(out$gp) <- gsub("^sdgp_", "sdgp(", rownames(out$gp)) + rownames(out$gp) <- gsub("^lscale_", "lscale(", rownames(out$gp)) + rownames(out$gp) <- paste0(rownames(out$gp), ")") + } + out +} + +#' Print a summary for a fitted model represented by a \code{brmsfit} object +#' +#' @aliases print.brmssummary +#' +#' @param x An object of class \code{brmsfit} +#' @param digits The number of significant digits for printing out the summary; +#' defaults to 2. The effective sample size is always rounded to integers. +#' @param ... Additional arguments that would be passed +#' to method \code{summary} of \code{brmsfit}. +#' +#' @seealso \code{\link{summary.brmsfit}} +#' +#' @export +print.brmsfit <- function(x, digits = 2, ...) { + print(summary(x, ...), digits = digits, ...) +} + +#' @export +print.brmssummary <- function(x, digits = 2, ...) { + cat(" Family: ") + cat(summarise_families(x$formula), "\n") + cat(" Links: ") + cat(summarise_links(x$formula, wsp = 9), "\n") + cat("Formula: ") + print(x$formula, wsp = 9) + cat(paste0( + " Data: ", x$data_name, + " (Number of observations: ", x$nobs, ") \n" + )) + if (!isTRUE(nzchar(x$sampler))) { + cat("\nThe model does not contain posterior draws.\n") + } else { + total_ndraws <- ceiling((x$iter - x$warmup) / x$thin * x$chains) + cat(paste0( + " Draws: ", x$chains, " chains, each with iter = ", x$iter, + "; warmup = ", x$warmup, "; thin = ", x$thin, ";\n", + " total post-warmup draws = ", total_ndraws, "\n\n" + )) + if (nrow(x$prior)) { + cat("Priors: \n") + print(x$prior, show_df = FALSE) + cat("\n") + } + if (length(x$splines)) { + cat("Smooth Terms: \n") + print_format(x$splines, digits) + cat("\n") + } + if (length(x$gp)) { + cat("Gaussian Process Terms: \n") + print_format(x$gp, digits) + cat("\n") + } + if (nrow(x$cor_pars)) { + cat("Correlation Structures:\n") + # TODO: better printing for correlation structures? + print_format(x$cor_pars, digits) + cat("\n") + } + if (length(x$random)) { + cat("Group-Level Effects: \n") + for (i in seq_along(x$random)) { + g <- names(x$random)[i] + cat(paste0("~", g, " (Number of levels: ", x$ngrps[[g]], ") \n")) + print_format(x$random[[g]], digits) + cat("\n") + } + } + if (nrow(x$fixed)) { + cat("Population-Level Effects: \n") + print_format(x$fixed, digits) + cat("\n") + } + if (length(x$mo)) { + cat("Simplex Parameters: \n") + print_format(x$mo, digits) + cat("\n") + } + if (nrow(x$spec_pars)) { + cat("Family Specific Parameters: \n") + print_format(x$spec_pars, digits) + cat("\n") + } + if (length(x$rescor_pars)) { + cat("Residual Correlations: \n") + print_format(x$rescor, digits) + cat("\n") + } + cat(paste0("Draws were sampled using ", x$sampler, ". ")) + if (x$algorithm == "sampling") { + cat(paste0( + "For each parameter, Bulk_ESS\n", + "and Tail_ESS are effective sample size measures, ", + "and Rhat is the potential\n", + "scale reduction factor on split chains ", + "(at convergence, Rhat = 1)." + )) + } + cat("\n") + } + invisible(x) +} + +# helper function to print summary matrices in nice format +# also displays -0.00 as a result of round negative values to zero (#263) +# @param x object to be printed; coerced to matrix +# @param digits number of digits to show +# @param no_digits names of columns for which no digits should be shown +print_format <- function(x, digits = 2, no_digits = c("Bulk_ESS", "Tail_ESS")) { + x <- as.matrix(x) + digits <- as.numeric(digits) + if (length(digits) != 1L) { + stop2("'digits' should be a single numeric value.") + } + out <- x + fmt <- paste0("%.", digits, "f") + for (i in seq_cols(x)) { + if (isTRUE(colnames(x)[i] %in% no_digits)) { + out[, i] <- sprintf("%.0f", x[, i]) + } else { + out[, i] <- sprintf(fmt, x[, i]) + } + } + print(out, quote = FALSE, right = TRUE) + invisible(x) +} + +# regex to extract population-level coefficients +fixef_pars <- function() { + types <- c("", "s", "cs", "sp", "mo", "me", "mi", "m") + types <- paste0("(", types, ")", collapse = "|") + paste0("^b(", types, ")_") +} + +# algorithm used in the model fitting +algorithm <- function(x) { + stopifnot(is.brmsfit(x)) + if (is.null(x$algorithm)) "sampling" + else x$algorithm +} + +#' Summarize Posterior draws +#' +#' Summarizes posterior draws based on point estimates (mean or median), +#' estimation errors (SD or MAD) and quantiles. This function mainly exists to +#' retain backwards compatibility. It will eventually be replaced by functions +#' of the \pkg{posterior} package (see examples below). +#' +#' @param x An \R object. +#' @inheritParams as.matrix.brmsfit +#' @param probs The percentiles to be computed by the +#' \code{\link[stats:quantile]{quantile}} function. +#' @param robust If \code{FALSE} (the default) the mean is used as +#' the measure of central tendency and the standard deviation as +#' the measure of variability. If \code{TRUE}, the median and the +#' median absolute deviation (MAD) are applied instead. +#' @param ... More arguments passed to or from other methods. +#' +#' @return A matrix where rows indicate variables +#' and columns indicate the summary estimates. +#' +#' @seealso \code{\link[posterior:summarize_draws]{summarize_draws}} +#' +#' @examples +#' \dontrun{ +#' fit <- brm(time ~ age * sex, data = kidney) +#' posterior_summary(fit) +#' +#' # recommended workflow using posterior +#' library(posterior) +#' draws <- as_draws_array(fit) +#' summarise_draws(draws, default_summary_measures()) +#' } +#' +#' @export +posterior_summary <- function(x, ...) { + UseMethod("posterior_summary") +} + +#' @rdname posterior_summary +#' @export +posterior_summary.default <- function(x, probs = c(0.025, 0.975), + robust = FALSE, ...) { + # TODO: replace with summary functions from posterior + # TODO: find a way to represent 3D summaries as well + if (!length(x)) { + stop2("No posterior draws supplied.") + } + if (robust) { + coefs <- c("median", "mad", "quantile") + } else { + coefs <- c("mean", "sd", "quantile") + } + .posterior_summary <- function(x) { + do_call(cbind, lapply( + coefs, get_estimate, draws = x, + probs = probs, na.rm = TRUE + )) + } + if (length(dim(x)) <= 2L) { + # data.frames cause trouble in as.array + x <- as.matrix(x) + } else { + x <- as.array(x) + } + if (length(dim(x)) == 2L) { + out <- .posterior_summary(x) + rownames(out) <- colnames(x) + } else if (length(dim(x)) == 3L) { + out <- lapply(array2list(x), .posterior_summary) + out <- abind(out, along = 3) + dnx <- dimnames(x) + dimnames(out) <- list(dnx[[2]], dimnames(out)[[2]], dnx[[3]]) + } else { + stop("'x' must be of dimension 2 or 3.") + } + # TODO: align names with summary outputs of other methods and packages + colnames(out) <- c("Estimate", "Est.Error", paste0("Q", probs * 100)) + out +} + +#' @rdname posterior_summary +#' @export +posterior_summary.brmsfit <- function(x, pars = NA, variable = NULL, + probs = c(0.025, 0.975), + robust = FALSE, ...) { + out <- as.matrix(x, pars = pars, variable = variable, ...) + posterior_summary(out, probs = probs, robust = robust, ...) +} + +# calculate estimates over posterior draws +# @param coef coefficient to be applied on the draws (e.g., "mean") +# @param draws the draws over which to apply coef +# @param margin see 'apply' +# @param ... additional arguments passed to get(coef) +# @return typically a matrix with colnames(draws) as colnames +get_estimate <- function(coef, draws, margin = 2, ...) { + # TODO: replace with summary functions from posterior + dots <- list(...) + args <- list(X = draws, MARGIN = margin, FUN = coef) + fun_args <- names(formals(coef)) + if (!"..." %in% fun_args) { + dots <- dots[names(dots) %in% fun_args] + } + x <- do_call(apply, c(args, dots)) + if (is.null(dim(x))) { + x <- matrix(x, dimnames = list(NULL, coef)) + } else if (coef == "quantile") { + x <- aperm(x, length(dim(x)):1) + } + x +} + +# validate bounds of credible intervals +# @return a numeric vector of length 2 +validate_ci_bounds <- function(prob, probs = NULL) { + if (!is.null(probs)) { + # deprecated as of version 2.13.7 + warning2("Argument 'probs' is deprecated. Please use 'prob' instead.") + if (length(probs) != 2L) { + stop2("Arguments 'probs' must be of length 2.") + } + probs <- as.numeric(probs) + } else { + prob <- as_one_numeric(prob) + if (prob < 0 || prob > 1) { + stop2("'prob' must be a single numeric value in [0, 1].") + } + probs <- c((1 - prob) / 2, 1 - (1 - prob) / 2) + } + probs +} + +#' Table Creation for Posterior Draws +#' +#' Create a table for unique values of posterior draws. +#' This is usually only useful when summarizing predictions +#' of ordinal models. +#' +#' @param x A matrix of posterior draws where rows +#' indicate draws and columns indicate parameters. +#' @param levels Optional values of possible posterior values. +#' Defaults to all unique values in \code{x}. +#' +#' @return A matrix where rows indicate parameters +#' and columns indicate the unique values of +#' posterior draws. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(rating ~ period + carry + treat, +#' data = inhaler, family = cumulative()) +#' pr <- predict(fit, summary = FALSE) +#' posterior_table(pr) +#' } +#' +#' @export +posterior_table <- function(x, levels = NULL) { + x <- as.matrix(x) + if (anyNA(x)) { + warning2("NAs will be ignored in 'posterior_table'.") + } + if (is.null(levels)) { + levels <- sort(unique(as.vector(x))) + } + xlevels <- attr(x, "levels") + if (length(xlevels) != length(levels)) { + xlevels <- levels + } + out <- lapply(seq_len(ncol(x)), + function(n) table(factor(x[, n], levels = levels)) + ) + out <- do_call(rbind, out) + # compute relative frequencies + out <- out / rowSums(out) + rownames(out) <- colnames(x) + colnames(out) <- paste0("P(Y = ", xlevels, ")") + out +} + +#' Compute posterior uncertainty intervals +#' +#' Compute posterior uncertainty intervals for \code{brmsfit} objects. +#' +#' @param object An object of class \code{brmsfit}. +#' @param prob A value between 0 and 1 indicating the desired probability +#' to be covered by the uncertainty intervals. The default is 0.95. +#' @inheritParams as.matrix.brmsfit +#' @param ... More arguments passed to \code{\link{as.matrix.brmsfit}}. +#' +#' @return A \code{matrix} with lower and upper interval bounds +#' as columns and as many rows as selected variables. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt, +#' data = epilepsy, family = negbinomial()) +#' posterior_interval(fit) +#' } +#' +#' @aliases posterior_interval +#' @method posterior_interval brmsfit +#' @export +#' @export posterior_interval +#' @importFrom rstantools posterior_interval +posterior_interval.brmsfit <- function( + object, pars = NA, variable = NULL, prob = 0.95, ... +) { + ps <- as.matrix(object, pars = pars, variable = variable, ...) + rstantools::posterior_interval(ps, prob = prob) +} + +#' Extract Priors of a Bayesian Model Fitted with \pkg{brms} +#' +#' @aliases prior_summary +#' +#' @param object An object of class \code{brmsfit}. +#' @param all Logical; Show all parameters in the model which may have +#' priors (\code{TRUE}) or only those with proper priors (\code{FALSE})? +#' @param ... Further arguments passed to or from other methods. +#' +#' @return For \code{brmsfit} objects, an object of class \code{brmsprior}. +#' +#' @examples +#' \dontrun{ +#' fit <- brm(count ~ zAge + zBase * Trt +#' + (1|patient) + (1|obs), +#' data = epilepsy, family = poisson(), +#' prior = c(prior(student_t(5,0,10), class = b), +#' prior(cauchy(0,2), class = sd))) +#' +#' prior_summary(fit) +#' prior_summary(fit, all = FALSE) +#' print(prior_summary(fit, all = FALSE), show_df = FALSE) +#' } +#' +#' @method prior_summary brmsfit +#' @export +#' @export prior_summary +#' @importFrom rstantools prior_summary +prior_summary.brmsfit <- function(object, all = TRUE, ...) { + object <- restructure(object) + prior <- object$prior + if (!all) { + prior <- prior[nzchar(prior$prior), ] + } + prior +} diff -Nru r-cran-brms-2.16.3/R/update.R r-cran-brms-2.17.0/R/update.R --- r-cran-brms-2.16.3/R/update.R 2021-10-28 17:57:52.000000000 +0000 +++ r-cran-brms-2.17.0/R/update.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,43 +1,43 @@ #' Update \pkg{brms} models -#' +#' #' This method allows to update an existing \code{brmsfit} object. -#' +#' #' @param object An object of class \code{brmsfit}. -#' @param formula. Changes to the formula; for details see +#' @param formula. Changes to the formula; for details see #' \code{\link{update.formula}} and \code{\link{brmsformula}}. #' @param newdata Optional \code{data.frame} to update the model with new data. #' Data-dependent default priors will not be updated automatically. -#' @param recompile Logical, indicating whether the Stan model should +#' @param recompile Logical, indicating whether the Stan model should #' be recompiled. If \code{NULL} (the default), \code{update} tries -#' to figure out internally, if recompilation is necessary. -#' Setting it to \code{FALSE} will cause all Stan code changing -#' arguments to be ignored. +#' to figure out internally, if recompilation is necessary. +#' Setting it to \code{FALSE} will cause all Stan code changing +#' arguments to be ignored. #' @param ... Other arguments passed to \code{\link{brm}}. -#' -#' @examples +#' +#' @examples #' \dontrun{ -#' fit1 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), +#' fit1 <- brm(time | cens(censored) ~ age * sex + disease + (1|patient), #' data = kidney, family = gaussian("log")) #' summary(fit1) -#' +#' #' ## remove effects of 'disease' #' fit2 <- update(fit1, formula. = ~ . - disease) #' summary(fit2) -#' +#' #' ## remove the group specific term of 'patient' and #' ## change the data (just take a subset in this example) -#' fit3 <- update(fit1, formula. = ~ . - (1|patient), +#' fit3 <- update(fit1, formula. = ~ . - (1|patient), #' newdata = kidney[1:38, ]) #' summary(fit3) -#' +#' #' ## use another family and add population-level priors -#' fit4 <- update(fit1, family = weibull(), inits = "0", +#' fit4 <- update(fit1, family = weibull(), init = "0", #' prior = set_prior("normal(0,5)")) #' summary(fit4) #' } #' #' @export -update.brmsfit <- function(object, formula., newdata = NULL, +update.brmsfit <- function(object, formula., newdata = NULL, recompile = NULL, ...) { dots <- list(...) testmode <- isTRUE(dots[["testmode"]]) @@ -53,9 +53,9 @@ warning2("Updating models fitted with older versions of brms may fail.") } object$file <- NULL - + if ("data" %in% names(dots)) { - # otherwise the data name cannot be found by substitute + # otherwise the data name cannot be found by substitute stop2("Please use argument 'newdata' to update the data.") } if (!is.null(newdata)) { @@ -65,12 +65,12 @@ dots$data <- object$data data_name <- get_data_name(object$data) } - + if (missing(formula.) || is.null(formula.)) { dots$formula <- object$formula if (!is.null(dots[["family"]])) { dots$formula <- bf(dots$formula, family = dots$family) - } + } if (!is.null(dots[["autocor"]])) { dots$formula <- bf(dots$formula, autocor = dots$autocor) } @@ -82,7 +82,7 @@ if (is.brmsformula(formula.)) { nl <- get_nl(formula.) } else { - formula. <- as.formula(formula.) + formula. <- as.formula(formula.) nl <- get_nl(formula(object)) } family <- get_arg("family", formula., dots, object) @@ -94,8 +94,8 @@ } else { dots$formula <- update(object$formula, dots$formula, mode = "replace") if (silent < 2) { - message("Argument 'formula.' will completely replace the ", - "original formula in non-linear models.") + message("Argument 'formula.' will completely replace the ", + "original formula in non-linear models.") } } } else { @@ -110,11 +110,11 @@ } # update response categories and ordinal thresholds dots$formula <- validate_formula(dots$formula, data = dots$data) - + if (is.null(dots$prior)) { dots$prior <- object$prior } else { - if (!is.brmsprior(dots$prior)) { + if (!is.brmsprior(dots$prior)) { stop2("Argument 'prior' needs to be a 'brmsprior' object.") } # update existing priors manually @@ -156,7 +156,7 @@ if (!"normalize" %in% names(dots)) { dots$normalize <- is_normalized(object$model) } - + # update arguments controlling the sampling process if (is.null(dots$iter)) { # only keep old 'warmup' if also keeping old 'iter' @@ -165,22 +165,25 @@ dots$iter <- first_not_null(dots$iter, object$fit@sim$iter) dots$chains <- first_not_null(dots$chains, object$fit@sim$chains) dots$thin <- first_not_null(dots$thin, object$fit@sim$thin) - control <- attr(object$fit@sim$samples[[1]], "args")$control - control <- control[setdiff(names(control), names(dots$control))] - dots$control[names(control)] <- control - + dots$backend <- match.arg(dots$backend, backend_choices()) + same_backend <- is_equal(dots$backend, object$backend) + if (same_backend) { + # reusing control arguments in other backends may cause errors #1259 + control <- attr(object$fit@sim$samples[[1]], "args")$control + control <- control[setdiff(names(control), names(dots$control))] + dots$control[names(control)] <- control + } + if (is.null(recompile)) { - dots$backend <- match.arg(dots$backend, backend_choices()) # only recompile if new and old stan code do not match new_stancode <- suppressMessages(do_call(make_stancode, dots)) # stan code may differ just because of the version number (#288) new_stancode <- sub("^[^\n]+\n", "", new_stancode) old_stancode <- stancode(object, version = FALSE) - recompile <- needs_recompilation(object) || - !is_equal(new_stancode, old_stancode) || - !is_equal(dots$backend, object$backend) + recompile <- needs_recompilation(object) || !same_backend || + !is_equal(new_stancode, old_stancode) if (recompile && silent < 2) { - message("The desired updates require recompiling the model") + message("The desired updates require recompiling the model") } } recompile <- as_one_logical(recompile) @@ -209,8 +212,8 @@ attr(object$prior, "sample_prior") <- dots$sample_prior } object$save_pars <- validate_save_pars( - save_pars = dots$save_pars, - save_ranef = dots$save_ranef, + save_pars = dots$save_pars, + save_ranef = dots$save_ranef, save_mevars = dots$save_mevars, save_all_pars = dots$save_all_pars ) @@ -228,26 +231,26 @@ } #' Update \pkg{brms} models based on multiple data sets -#' +#' #' This method allows to update an existing \code{brmsfit_multiple} object. -#' +#' #' @param object An object of class \code{brmsfit_multiple}. -#' @param formula. Changes to the formula; for details see +#' @param formula. Changes to the formula; for details see #' \code{\link{update.formula}} and \code{\link{brmsformula}}. #' @param newdata List of \code{data.frames} to update the model with new data. #' Currently required even if the original data should be used. #' @param ... Other arguments passed to \code{\link{update.brmsfit}} #' and \code{\link{brm_multiple}}. -#' -#' @examples +#' +#' @examples #' \dontrun{ #' library(mice) #' imp <- mice(nhanes2) -#' -#' # initially fit the model +#' +#' # initially fit the model #' fit_imp1 <- brm_multiple(bmi ~ age + hyp + chl, data = imp, chains = 1) #' summary(fit_imp1) -#' +#' #' # update the model using fewer predictors #' fit_imp2 <- update(fit_imp1, formula. = . ~ hyp + chl, newdata = imp) #' summary(fit_imp2) @@ -257,7 +260,7 @@ update.brmsfit_multiple <- function(object, formula., newdata = NULL, ...) { dots <- list(...) if ("data" %in% names(dots)) { - # otherwise the data name cannot be found by substitute + # otherwise the data name cannot be found by substitute stop2("Please use argument 'newdata' to update the data.") } if (is.null(newdata)) { @@ -270,7 +273,7 @@ } else if (!(is.list(newdata) && is.vector(newdata))) { stop2("'newdata' must be a list of data.frames.") } - + # update the template model using all arguments if (missing(formula.)) { formula. <- NULL @@ -279,11 +282,11 @@ args$file <- NULL args$chains <- 0 fit <- do_call(update.brmsfit, args) - + # arguments later passed to brm_multiple args <- c(nlist(fit, data = newdata), dots) # update arguments controlling the sampling process - # they cannot be accessed directly from the template model + # they cannot be accessed directly from the template model # as it does not contain any draws (chains = 0) if (is.null(args$iter)) { # only keep old 'warmup' if also keeping old 'iter' @@ -299,7 +302,7 @@ control <- control[setdiff(names(control), names(args$control))] args$control[names(control)] <- control args$recompile <- NULL - + out <- do_call(brm_multiple, args) attr(out$data, "data_name") <- data_name out diff -Nru r-cran-brms-2.16.3/README.md r-cran-brms-2.17.0/README.md --- r-cran-brms-2.16.3/README.md 2021-10-07 11:33:56.000000000 +0000 +++ r-cran-brms-2.17.0/README.md 2022-04-08 11:57:41.000000000 +0000 @@ -4,8 +4,7 @@ # brms -[![Build -Status](https://travis-ci.org/paul-buerkner/brms.svg?branch=master)](https://travis-ci.org/paul-buerkner/brms) +[![R-CMD-check](https://github.com/paul-buerkner/brms/workflows/R-CMD-check/badge.svg)](https://github.com/paul-buerkner/brms/actions) [![Coverage Status](https://codecov.io/github/paul-buerkner/brms/coverage.svg?branch=master)](https://codecov.io/github/paul-buerkner/brms?branch=master) [![CRAN @@ -35,9 +34,8 @@ ## Resources -- [Introduction to - brms](https://doi.org/10.18637/jss.v080.i01) (Journal of - Statistical Software) +- [Introduction to brms](https://doi.org/10.18637/jss.v080.i01) + (Journal of Statistical Software) - [Advanced multilevel modeling with brms](https://journal.r-project.org/archive/2018/RJ-2018-017/index.html) (The R Journal) @@ -66,20 +64,20 @@ data. ``` r -fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), +fit1 <- brm(count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = poisson()) ``` The results (i.e., posterior draws) can be investigated using ``` r -summary(fit1) +summary(fit1) #> Family: poisson #> Links: mu = log #> Formula: count ~ zAge + zBase * Trt + (1 | patient) #> Data: epilepsy (Number of observations: 236) -#> Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; -#> total post-warmup samples = 4000 +#> Draws: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; +#> total post-warmup draws = 4000 #> #> Group-Level Effects: #> ~patient (Number of levels: 59) @@ -94,7 +92,7 @@ #> Trt1 -0.27 0.17 -0.59 0.06 1.00 661 1046 #> zBase:Trt1 0.05 0.16 -0.26 0.37 1.00 993 1624 #> -#> Samples were drawn using sampling(NUTS). For each parameter, Bulk_ESS +#> Draws were sampled using sampling(NUTS). For each parameter, Bulk_ESS #> and Tail_ESS are effective sample size measures, and Rhat is the potential #> scale reduction factor on split chains (at convergence, Rhat = 1). ``` @@ -131,7 +129,7 @@ results of the regression coefficients of `Trt` and `zBase`, we go for ``` r -plot(fit1, variable = c("b_Trt1", "b_zBase")) +plot(fit1, variable = c("b_Trt1", "b_zBase")) ``` @@ -185,7 +183,7 @@ intercept that captures possible overdispersion. ``` r -fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), +fit2 <- brm(count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson()) ``` diff -Nru r-cran-brms-2.16.3/tests/testthat/helpers/insert_refcat_ch.R r-cran-brms-2.17.0/tests/testthat/helpers/insert_refcat_ch.R --- r-cran-brms-2.16.3/tests/testthat/helpers/insert_refcat_ch.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/helpers/insert_refcat_ch.R 2021-12-20 13:50:54.000000000 +0000 @@ -1,38 +1,38 @@ -# Very similar to insert_refcat(), but iterates over the observations (if -# necessary): -insert_refcat_ch <- function(eta, family) { - ndim <- length(dim(eta)) - if (ndim == 2) { - return(insert_refcat_ch_i(eta, family = family)) - } else if (ndim == 3) { - out <- abind::abind(lapply(seq_cols(eta), function(i) { - insert_refcat_ch_i(slice_col(eta, i), family = family) - }), along = 3) - return(aperm(out, perm = c(1, 3, 2))) - } else { - stop2("eta has wrong dimensions.") - } -} -environment(insert_refcat_ch) <- as.environment(asNamespace("brms")) - -# A matrix-only variant of insert_refcat() (used to be insert_refcat() before it -# was extended to arrays): -insert_refcat_ch_i <- function(eta, family) { - stopifnot(is.matrix(eta), is.brmsfamily(family)) - if (!conv_cats_dpars(family) || isNA(family$refcat)) { - return(eta) - } - # need to add zeros for the reference category - zeros <- as.matrix(rep(0, nrow(eta))) - if (is.null(family$refcat) || is.null(family$cats)) { - # no information on the categories provided: - # use the first category as the reference - return(cbind(zeros, eta)) - } - colnames(zeros) <- paste0("mu", family$refcat) - iref <- match(family$refcat, family$cats) - before <- seq_len(iref - 1) - after <- setdiff(seq_cols(eta), before) - cbind(eta[, before, drop = FALSE], zeros, eta[, after, drop = FALSE]) -} -environment(insert_refcat_ch_i) <- as.environment(asNamespace("brms")) +# Very similar to insert_refcat(), but iterates over the observations (if +# necessary): +insert_refcat_ch <- function(eta, family) { + ndim <- length(dim(eta)) + if (ndim == 2) { + return(insert_refcat_ch_i(eta, family = family)) + } else if (ndim == 3) { + out <- abind::abind(lapply(seq_cols(eta), function(i) { + insert_refcat_ch_i(slice_col(eta, i), family = family) + }), along = 3) + return(aperm(out, perm = c(1, 3, 2))) + } else { + stop2("eta has wrong dimensions.") + } +} +environment(insert_refcat_ch) <- as.environment(asNamespace("brms")) + +# A matrix-only variant of insert_refcat() (used to be insert_refcat() before it +# was extended to arrays): +insert_refcat_ch_i <- function(eta, family) { + stopifnot(is.matrix(eta), is.brmsfamily(family)) + if (!conv_cats_dpars(family) || isNA(family$refcat)) { + return(eta) + } + # need to add zeros for the reference category + zeros <- as.matrix(rep(0, nrow(eta))) + if (is.null(family$refcat) || is.null(family$cats)) { + # no information on the categories provided: + # use the first category as the reference + return(cbind(zeros, eta)) + } + colnames(zeros) <- paste0("mu", family$refcat) + iref <- match(family$refcat, family$cats) + before <- seq_len(iref - 1) + after <- setdiff(seq_cols(eta), before) + cbind(eta[, before, drop = FALSE], zeros, eta[, after, drop = FALSE]) +} +environment(insert_refcat_ch_i) <- as.environment(asNamespace("brms")) diff -Nru r-cran-brms-2.16.3/tests/testthat/helpers/inv_link_categorical_ch.R r-cran-brms-2.17.0/tests/testthat/helpers/inv_link_categorical_ch.R --- r-cran-brms-2.16.3/tests/testthat/helpers/inv_link_categorical_ch.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/helpers/inv_link_categorical_ch.R 2022-02-02 22:25:35.000000000 +0000 @@ -1,42 +1,47 @@ -# Very similar to inv_link_categorical(), but iterates over the observations: -inv_link_categorical_ch <- function(x, log = FALSE) { - ndim <- length(dim(x)) - # For testing purposes, only allow 3-dimensional arrays here: - if (ndim <= 1) { - x <- array(x, dim = c(1, 1, length(x))) - ndim <- length(dim(x)) - need_drop <- TRUE - } else if (ndim == 2) { - x <- array(x, dim = c(dim(x)[1], 1, dim(x)[2])) - ndim <- length(dim(x)) - need_drop <- TRUE - } else if (ndim > 3) { - stop("At most 3 dimensions are allowed here.") - } else { - need_drop <- FALSE - } - ndraws <- dim(x)[1] - nobsv <- dim(x)[2] - ncat <- dim(x)[3] - .softmax <- if (log) { - log_softmax - } else { - softmax - } - out <- aperm( - array( - sapply(seq_len(nobsv), function(i) { - .softmax(slice(x, 2, i)) - }, simplify = "array"), - dim = c(ndraws, ncat, nobsv) - ), - perm = c(1, 3, 2) - ) - # Quick-and-dirty solution to drop the margin for a single observation (but - # only if the input object was not a 3-dimensional array): - if (need_drop) { - return(slice(out, 2, 1)) - } - out -} -environment(inv_link_categorical_ch) <- as.environment(asNamespace("brms")) +# Very similar to inv_link_categorical(), but iterates over the observations and +# always assumes the first category to be the reference category: +inv_link_categorical_ch <- function(x, log = FALSE, refcat_ins = TRUE) { + if (refcat_ins) { + zeros_arr <- array(0, dim = c(head(dim(x), -1), 1)) + x <- abind::abind(zeros_arr, x) + } + ndim <- length(dim(x)) + # For testing purposes, only allow 3-dimensional arrays here: + if (ndim <= 1) { + x <- array(x, dim = c(1, 1, length(x))) + ndim <- length(dim(x)) + need_drop <- TRUE + } else if (ndim == 2) { + x <- array(x, dim = c(dim(x)[1], 1, dim(x)[2])) + ndim <- length(dim(x)) + need_drop <- TRUE + } else if (ndim > 3) { + stop("At most 3 dimensions are allowed here.") + } else { + need_drop <- FALSE + } + ndraws <- dim(x)[1] + nobsv <- dim(x)[2] + ncat <- dim(x)[3] + .softmax <- if (log) { + log_softmax + } else { + softmax + } + out <- aperm( + array( + sapply(seq_len(nobsv), function(i) { + .softmax(slice(x, 2, i)) + }, simplify = "array"), + dim = c(ndraws, ncat, nobsv) + ), + perm = c(1, 3, 2) + ) + # Quick-and-dirty solution to drop the margin for a single observation (but + # only if the input object was not a 3-dimensional array): + if (need_drop) { + return(slice(out, 2, 1)) + } + out +} +environment(inv_link_categorical_ch) <- as.environment(asNamespace("brms")) diff -Nru r-cran-brms-2.16.3/tests/testthat/helpers/inv_link_ordinal_ch.R r-cran-brms-2.17.0/tests/testthat/helpers/inv_link_ordinal_ch.R --- r-cran-brms-2.16.3/tests/testthat/helpers/inv_link_ordinal_ch.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/helpers/inv_link_ordinal_ch.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,92 +1,92 @@ -inv_link_cumulative_ch <- function(x, link) { - x <- ilink(x, link) - ndim <- length(dim(x)) - ncat <- dim(x)[ndim] + 1 - out <- vector("list", ncat) - out[[1]] <- slice(x, ndim, 1) - if (ncat > 2) { - .diff <- function(k) { - slice(x, ndim, k) - slice(x, ndim, k - 1) - } - mid_cats <- 2:(ncat - 1) - out[mid_cats] <- lapply(mid_cats, .diff) - } - out[[ncat]] <- 1 - slice(x, ndim, ncat - 1) - abind::abind(out, along = ndim) -} -environment(inv_link_cumulative_ch) <- as.environment(asNamespace("brms")) - -inv_link_sratio_ch <- function(x, link) { - x <- ilink(x, link) - ndim <- length(dim(x)) - ncat <- dim(x)[ndim] + 1 - marg_noncat <- seq_along(dim(x))[-ndim] - out <- vector("list", ncat) - out[[1]] <- slice(x, ndim, 1) - if (ncat > 2) { - .condprod <- function(k) { - slice(x, ndim, k) * - apply(1 - slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) - } - mid_cats <- 2:(ncat - 1) - out[mid_cats] <- lapply(mid_cats, .condprod) - } - out[[ncat]] <- apply(1 - x, marg_noncat, prod) - abind::abind(out, along = ndim) -} -environment(inv_link_sratio_ch) <- as.environment(asNamespace("brms")) - -inv_link_cratio_ch <- function(x, link) { - x <- ilink(x, link) - ndim <- length(dim(x)) - ncat <- dim(x)[ndim] + 1 - marg_noncat <- seq_along(dim(x))[-ndim] - out <- vector("list", ncat) - out[[1]] <- 1 - slice(x, ndim, 1) - if (ncat > 2) { - .condprod <- function(k) { - (1 - slice(x, ndim, k)) * - apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) - } - mid_cats <- 2:(ncat - 1) - out[mid_cats] <- lapply(mid_cats, .condprod) - } - out[[ncat]] <- apply(x, marg_noncat, prod) - abind::abind(out, along = ndim) -} -environment(inv_link_cratio_ch) <- as.environment(asNamespace("brms")) - -inv_link_acat_ch <- function(x, link) { - ndim <- length(dim(x)) - ncat <- dim(x)[ndim] + 1 - marg_noncat <- seq_along(dim(x))[-ndim] - out <- vector("list", ncat) - if (link == "logit") { - # faster evaluation in this case - out[[1]] <- array(1, dim = dim(x)[-ndim]) - out[[2]] <- exp(slice(x, ndim, 1)) - if (ncat > 2) { - .catsum <- function(k) { - exp(apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, sum)) - } - remaincats <- 3:ncat - out[remaincats] <- lapply(remaincats, .catsum) - } - } else { - x <- ilink(x, link) - out[[1]] <- apply(1 - x, marg_noncat, prod) - if (ncat > 2) { - .othercatprod <- function(k) { - apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) * - apply(slice(1 - x, ndim, k:(ncat - 1), drop = FALSE), marg_noncat, prod) - } - mid_cats <- 2:(ncat - 1) - out[mid_cats] <- lapply(mid_cats, .othercatprod) - } - out[[ncat]] <- apply(x, marg_noncat, prod) - } - out <- abind::abind(out, along = ndim) - catsum <- apply(out, marg_noncat, sum) - sweep(out, marg_noncat, catsum, "/") -} -environment(inv_link_acat_ch) <- as.environment(asNamespace("brms")) +inv_link_cumulative_ch <- function(x, link) { + x <- inv_link(x, link) + ndim <- length(dim(x)) + ncat <- dim(x)[ndim] + 1 + out <- vector("list", ncat) + out[[1]] <- slice(x, ndim, 1) + if (ncat > 2) { + .diff <- function(k) { + slice(x, ndim, k) - slice(x, ndim, k - 1) + } + mid_cats <- 2:(ncat - 1) + out[mid_cats] <- lapply(mid_cats, .diff) + } + out[[ncat]] <- 1 - slice(x, ndim, ncat - 1) + abind::abind(out, along = ndim) +} +environment(inv_link_cumulative_ch) <- as.environment(asNamespace("brms")) + +inv_link_sratio_ch <- function(x, link) { + x <- inv_link(x, link) + ndim <- length(dim(x)) + ncat <- dim(x)[ndim] + 1 + marg_noncat <- seq_along(dim(x))[-ndim] + out <- vector("list", ncat) + out[[1]] <- slice(x, ndim, 1) + if (ncat > 2) { + .condprod <- function(k) { + slice(x, ndim, k) * + apply(1 - slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) + } + mid_cats <- 2:(ncat - 1) + out[mid_cats] <- lapply(mid_cats, .condprod) + } + out[[ncat]] <- apply(1 - x, marg_noncat, prod) + abind::abind(out, along = ndim) +} +environment(inv_link_sratio_ch) <- as.environment(asNamespace("brms")) + +inv_link_cratio_ch <- function(x, link) { + x <- inv_link(x, link) + ndim <- length(dim(x)) + ncat <- dim(x)[ndim] + 1 + marg_noncat <- seq_along(dim(x))[-ndim] + out <- vector("list", ncat) + out[[1]] <- 1 - slice(x, ndim, 1) + if (ncat > 2) { + .condprod <- function(k) { + (1 - slice(x, ndim, k)) * + apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) + } + mid_cats <- 2:(ncat - 1) + out[mid_cats] <- lapply(mid_cats, .condprod) + } + out[[ncat]] <- apply(x, marg_noncat, prod) + abind::abind(out, along = ndim) +} +environment(inv_link_cratio_ch) <- as.environment(asNamespace("brms")) + +inv_link_acat_ch <- function(x, link) { + ndim <- length(dim(x)) + ncat <- dim(x)[ndim] + 1 + marg_noncat <- seq_along(dim(x))[-ndim] + out <- vector("list", ncat) + if (link == "logit") { + # faster evaluation in this case + out[[1]] <- array(1, dim = dim(x)[-ndim]) + out[[2]] <- exp(slice(x, ndim, 1)) + if (ncat > 2) { + .catsum <- function(k) { + exp(apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, sum)) + } + remaincats <- 3:ncat + out[remaincats] <- lapply(remaincats, .catsum) + } + } else { + x <- inv_link(x, link) + out[[1]] <- apply(1 - x, marg_noncat, prod) + if (ncat > 2) { + .othercatprod <- function(k) { + apply(slice(x, ndim, 1:(k - 1), drop = FALSE), marg_noncat, prod) * + apply(slice(1 - x, ndim, k:(ncat - 1), drop = FALSE), marg_noncat, prod) + } + mid_cats <- 2:(ncat - 1) + out[mid_cats] <- lapply(mid_cats, .othercatprod) + } + out[[ncat]] <- apply(x, marg_noncat, prod) + } + out <- abind::abind(out, along = ndim) + catsum <- apply(out, marg_noncat, sum) + sweep(out, marg_noncat, catsum, "/") +} +environment(inv_link_acat_ch) <- as.environment(asNamespace("brms")) diff -Nru r-cran-brms-2.16.3/tests/testthat/helpers/link_categorical_ch.R r-cran-brms-2.17.0/tests/testthat/helpers/link_categorical_ch.R --- r-cran-brms-2.16.3/tests/testthat/helpers/link_categorical_ch.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/helpers/link_categorical_ch.R 2022-02-02 22:25:35.000000000 +0000 @@ -1,23 +1,23 @@ -# Very similar to link_categorical(), but iterates over the observations: -link_categorical_ch <- function(x, refcat = 1, return_refcat = TRUE) { - # For testing purposes, only allow 3-dimensional arrays here: - stopifnot(length(dim(x)) == 3) - x_tosweep <- if (return_refcat) { - x - } else { - slice(x, 3, -refcat, drop = FALSE) - } - ndraws <- dim(x)[1] - nobsv <- dim(x)[2] - ncat <- dim(x)[3] - log(aperm( - array( - sapply(seq_len(nobsv), function(i) { - slice(x_tosweep, 2, i) / slice(slice(x, 2, i), 2, refcat) - }, simplify = "array"), - dim = c(ndraws, ncat - !return_refcat, nobsv) - ), - perm = c(1, 3, 2) - )) -} -environment(link_categorical_ch) <- as.environment(asNamespace("brms")) +# Very similar to link_categorical(), but iterates over the observations: +link_categorical_ch <- function(x, refcat = 1, return_refcat = FALSE) { + # For testing purposes, only allow 3-dimensional arrays here: + stopifnot(length(dim(x)) == 3) + x_tosweep <- if (return_refcat) { + x + } else { + slice(x, 3, -refcat, drop = FALSE) + } + ndraws <- dim(x)[1] + nobsv <- dim(x)[2] + ncat <- dim(x)[3] + log(aperm( + array( + sapply(seq_len(nobsv), function(i) { + slice(x_tosweep, 2, i) / slice(slice(x, 2, i), 2, refcat) + }, simplify = "array"), + dim = c(ndraws, ncat - !return_refcat, nobsv) + ), + perm = c(1, 3, 2) + )) +} +environment(link_categorical_ch) <- as.environment(asNamespace("brms")) diff -Nru r-cran-brms-2.16.3/tests/testthat/helpers/link_ordinal_ch.R r-cran-brms-2.17.0/tests/testthat/helpers/link_ordinal_ch.R --- r-cran-brms-2.16.3/tests/testthat/helpers/link_ordinal_ch.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/helpers/link_ordinal_ch.R 2021-12-20 13:50:54.000000000 +0000 @@ -1,82 +1,82 @@ -link_ch <- function(x, link) { - # switch() would be more straightforward, but for testing purposes, use if () - # here: - if (link == "logit") { - return(qlogis(x)) - } else if (link == "probit") { - return(qnorm(x)) - } else if (link == "cauchit") { - return(qcauchy(x)) - } else if (link == "cloglog") { - return(log(-log(1 - x))) - } else { - stop("Unknown link.") - } -} - -# Very similar to link_cumulative(), but iterates over the observations: -link_cumulative_ch <- function(x, link) { - # For testing purposes, only allow 3-dimensional arrays here: - stopifnot(length(dim(x)) == 3) - ndraws <- dim(x)[1] - nobsv <- dim(x)[2] - ncat <- dim(x)[3] - x_cumsum <- aperm( - array( - sapply(seq_len(nobsv), function(i) { - apply(x[, i, -ncat, drop = FALSE], 1, cumsum) - }, simplify = "array"), - dim = c(ncat - 1, ndraws, nobsv) - ), - perm = c(2, 3, 1) - ) - link_ch(x_cumsum, link = link) -} - -# The same as link_sratio(), but dropping margins: -link_sratio_ch <- function(x, link) { - ndim <- length(dim(x)) - .F_k <- function(k) { - if (k == 1) { - prev_res <- list(F_k = NULL, S_km1_prod = 1) - } else { - prev_res <- .F_k(k - 1) - } - F_k <- slice(x, ndim, k) / prev_res$S_km1_prod - return(list(F_k = abind::abind(prev_res$F_k, F_k, along = ndim), - S_km1_prod = prev_res$S_km1_prod * (1 - F_k))) - } - x <- .F_k(dim(x)[ndim] - 1)$F_k - link_ch(x, link) -} -environment(link_sratio_ch) <- as.environment(asNamespace("brms")) - -# The same as link_cratio(), but dropping margins: -link_cratio_ch <- function(x, link) { - ndim <- length(dim(x)) - .F_k <- function(k) { - if (k == 1) { - prev_res <- list(F_k = NULL, F_km1_prod = 1) - } else { - prev_res <- .F_k(k - 1) - } - F_k <- 1 - slice(x, ndim, k) / prev_res$F_km1_prod - return(list(F_k = abind::abind(prev_res$F_k, F_k, along = ndim), - F_km1_prod = prev_res$F_km1_prod * F_k)) - } - x <- .F_k(dim(x)[ndim] - 1)$F_k - link_ch(x, link) -} -environment(link_cratio_ch) <- as.environment(asNamespace("brms")) - -# The same as link_acat(), but possibly dropping margins and not treating the -# logit link as a special case: -link_acat_ch <- function(x, link) { - ndim <- length(dim(x)) - ncat <- dim(x)[ndim] - dim_noncat <- dim(x)[-ndim] - x <- slice(x, ndim, -1) / slice(x, ndim, -ncat) - x <- inv_odds(x) - array(link_ch(x, link), dim = c(dim_noncat, ncat - 1)) -} -environment(link_acat_ch) <- as.environment(asNamespace("brms")) +link_ch <- function(x, link) { + # switch() would be more straightforward, but for testing purposes, use if () + # here: + if (link == "logit") { + return(qlogis(x)) + } else if (link == "probit") { + return(qnorm(x)) + } else if (link == "cauchit") { + return(qcauchy(x)) + } else if (link == "cloglog") { + return(log(-log(1 - x))) + } else { + stop("Unknown link.") + } +} + +# Very similar to link_cumulative(), but iterates over the observations: +link_cumulative_ch <- function(x, link) { + # For testing purposes, only allow 3-dimensional arrays here: + stopifnot(length(dim(x)) == 3) + ndraws <- dim(x)[1] + nobsv <- dim(x)[2] + ncat <- dim(x)[3] + x_cumsum <- aperm( + array( + sapply(seq_len(nobsv), function(i) { + apply(x[, i, -ncat, drop = FALSE], 1, cumsum) + }, simplify = "array"), + dim = c(ncat - 1, ndraws, nobsv) + ), + perm = c(2, 3, 1) + ) + link_ch(x_cumsum, link = link) +} + +# The same as link_sratio(), but dropping margins: +link_sratio_ch <- function(x, link) { + ndim <- length(dim(x)) + .F_k <- function(k) { + if (k == 1) { + prev_res <- list(F_k = NULL, S_km1_prod = 1) + } else { + prev_res <- .F_k(k - 1) + } + F_k <- slice(x, ndim, k) / prev_res$S_km1_prod + return(list(F_k = abind::abind(prev_res$F_k, F_k, along = ndim), + S_km1_prod = prev_res$S_km1_prod * (1 - F_k))) + } + x <- .F_k(dim(x)[ndim] - 1)$F_k + link_ch(x, link) +} +environment(link_sratio_ch) <- as.environment(asNamespace("brms")) + +# The same as link_cratio(), but dropping margins: +link_cratio_ch <- function(x, link) { + ndim <- length(dim(x)) + .F_k <- function(k) { + if (k == 1) { + prev_res <- list(F_k = NULL, F_km1_prod = 1) + } else { + prev_res <- .F_k(k - 1) + } + F_k <- 1 - slice(x, ndim, k) / prev_res$F_km1_prod + return(list(F_k = abind::abind(prev_res$F_k, F_k, along = ndim), + F_km1_prod = prev_res$F_km1_prod * F_k)) + } + x <- .F_k(dim(x)[ndim] - 1)$F_k + link_ch(x, link) +} +environment(link_cratio_ch) <- as.environment(asNamespace("brms")) + +# The same as link_acat(), but possibly dropping margins and not treating the +# logit link as a special case: +link_acat_ch <- function(x, link) { + ndim <- length(dim(x)) + ncat <- dim(x)[ndim] + dim_noncat <- dim(x)[-ndim] + x <- slice(x, ndim, -1) / slice(x, ndim, -ncat) + x <- inv_odds(x) + array(link_ch(x, link), dim = c(dim_noncat, ncat - 1)) +} +environment(link_acat_ch) <- as.environment(asNamespace("brms")) diff -Nru r-cran-brms-2.16.3/tests/testthat/helpers/simopts_catlike_oneobs.R r-cran-brms-2.17.0/tests/testthat/helpers/simopts_catlike_oneobs.R --- r-cran-brms-2.16.3/tests/testthat/helpers/simopts_catlike_oneobs.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/helpers/simopts_catlike_oneobs.R 2021-12-20 13:50:54.000000000 +0000 @@ -1,4 +1,4 @@ -# This test corresponds to a single observation. -set.seed(1234) -ndraws_vec <- c(1, 5) -ncat_vec <- c(2, 3) +# This test corresponds to a single observation. +set.seed(1234) +ndraws_vec <- c(1, 5) +ncat_vec <- c(2, 3) diff -Nru r-cran-brms-2.16.3/tests/testthat/helpers/simopts_catlike.R r-cran-brms-2.17.0/tests/testthat/helpers/simopts_catlike.R --- r-cran-brms-2.16.3/tests/testthat/helpers/simopts_catlike.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/helpers/simopts_catlike.R 2021-12-20 13:50:54.000000000 +0000 @@ -1,4 +1,4 @@ -set.seed(1234) -ndraws_vec <- c(1, 5) -nobsv_vec <- c(1, 4) -ncat_vec <- c(2, 3) +set.seed(1234) +ndraws_vec <- c(1, 5) +nobsv_vec <- c(1, 4) +ncat_vec <- c(2, 3) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.brm.R r-cran-brms-2.17.0/tests/testthat/tests.brm.R --- r-cran-brms-2.16.3/tests/testthat/tests.brm.R 2021-09-13 07:24:24.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.brm.R 2022-03-13 16:10:29.000000000 +0000 @@ -5,18 +5,18 @@ test_that("brm works fully with mock backend", { skip_on_cran() dat <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:5, 2)) - + # Positive control - forced error gets thrown and propagated - expect_error(brm(y ~ x + (1|g), dat, backend = "mock", + expect_error(brm(y ~ x + (1|g), dat, backend = "mock", stan_model_args = list(compile_error = "Test error")), "Test error") - + # Positive control - bad Stan code from stanvars gets an error expect_error(suppressMessages( - brm(y ~ x + (1|g), dat, backend = "mock", + brm(y ~ x + (1|g), dat, backend = "mock", stanvars = stanvar(scode = "invalid;", block = "model")) )) - + # Testing some models mock_fit <- brm(y ~ x + (1|g), dat, mock_fit = 1, backend = "mock", rename = FALSE) expect_equal(mock_fit$fit, 1) @@ -25,43 +25,43 @@ test_that("brm(file = xx) works fully with mock backend", { skip_on_cran() dat <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:5, 2)) - + file <- tempfile(fileext = ".rds") - mock_fit1 <- brm(y ~ x + (1|g), dat, mock_fit = "stored", backend = "mock", + mock_fit1 <- brm(y ~ x + (1|g), dat, mock_fit = "stored", backend = "mock", rename = FALSE, file = file) expect_true(file.exists(file)) - mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", + mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", rename = FALSE, file = file) expect_equal(mock_fit2$fit, "stored") - - # In default settings, even using different data/model should result in the + + # In default settings, even using different data/model should result in the # model being loaded from file changed_data <- dat[1:8, ] - mock_fit2 <- brm(y ~ x + 0, changed_data, mock_fit = "new", backend = "mock", + mock_fit2 <- brm(y ~ x + 0, changed_data, mock_fit = "new", backend = "mock", rename = FALSE, file = file) expect_equal(mock_fit2$fit, "stored") - + # Now test using file_refit = "on_change" which should be more clever # No change - mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", + mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", rename = FALSE, file = file) expect_equal(mock_fit2$fit, "stored") - - + + # Change data, but not code - mock_fit2 <- brm(y ~ x + (1|g), changed_data, mock_fit = "new", backend = "mock", + mock_fit2 <- brm(y ~ x + (1|g), changed_data, mock_fit = "new", backend = "mock", rename = FALSE, file = file, file_refit = "on_change") expect_equal(mock_fit2$fit, "new") - + # Change code but not data - mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", + mock_fit2 <- brm(y ~ x + (1|g), dat, mock_fit = "new", backend = "mock", rename = FALSE, file = file, file_refit = "on_change", prior = prior(normal(0,2), class = sd)) expect_equal(mock_fit2$fit, "new") # Change both - mock_fit2 <- brm(y ~ x + 0, changed_data, mock_fit = "new", backend = "mock", + mock_fit2 <- brm(y ~ x + 0, changed_data, mock_fit = "new", backend = "mock", rename = FALSE, file = file, file_refit = "on_change") expect_equal(mock_fit2$fit, "new") }) @@ -69,9 +69,9 @@ test_that("brm produces expected errors", { dat <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:5, 2)) - + # formula parsing - expect_error(brm(~ x + (1|g), dat, file = "test"), + expect_error(brm(~ x + (1|g), dat, file = "test"), "Response variable is missing") expect_error(brm(bf(y ~ a, nl = TRUE)), "No non-linear parameters specified") @@ -88,9 +88,9 @@ "The following addition terms are invalid:") expect_error(brm(bf(y ~ x, shape ~ x), family = gaussian()), "The parameter 'shape' is not a valid distributional") - expect_error(brm(y ~ x + (1|abc|g/x), dat), + expect_error(brm(y ~ x + (1|abc|g/x), dat), "Can only combine group-level terms") - expect_error(brm(y ~ x + (1|g) + (x|g), dat), + expect_error(brm(y ~ x + (1|g) + (x|g), dat), "Duplicated group-level effects are not allowed") expect_error(brm(y~mo(g)*t2(x), dat), fixed = TRUE, "The term 'mo(g):t2(x)' is invalid") @@ -100,26 +100,24 @@ "Variable 'x' is used in different calls to 'me'") expect_error(brm(y ~ 1 + set_rescor(TRUE), data = dat), "Function 'set_rescor' should not be part") - + # autocorrelation - expect_error(brm(y ~ ar(x+y, g), dat), + expect_error(brm(y ~ ar(x+y, g), dat), "Cannot coerce 'x \\+ y' to a single variable name") - expect_error(brm(y ~ ar(gr = g1/g2), dat), + expect_error(brm(y ~ ar(gr = g1/g2), dat), "Illegal grouping term 'g1/g2'") expect_error(brm(y ~ ma(x), dat, poisson()), "Please set cov = TRUE") expect_error(brm(bf(y ~ 1) + arma(x), dat), "Autocorrelation terms can only be specified") - + # ordinal models expect_error(brm(rating ~ treat + (cs(period)|subject), - data = inhaler, family = categorical()), + data = inhaler, family = categorical()), "Category specific effects are not supported") - + # families and links - expect_error(brm(y ~ x, dat, family = gaussian("logit")), - "'logit' is not a supported link for family 'gaussian'") - expect_error(brm(y ~ x, dat, family = poisson("inverse")), + expect_error(brm(y ~ x, dat, family = poisson("inverse")), "'inverse' is not a supported link for family 'poisson'") expect_error(brm(y ~ x, dat, family = c("weibull", "sqrt")), "'sqrt' is not a supported link for family 'weibull'") diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.brmsfit-helpers.R r-cran-brms-2.17.0/tests/testthat/tests.brmsfit-helpers.R --- r-cran-brms-2.16.3/tests/testthat/tests.brmsfit-helpers.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.brmsfit-helpers.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,204 +1,210 @@ -context("Tests for brmsfit helper functions") - -test_that("first_greater returns expected results", { - A <- cbind(1:10, 11:20, 21:30) - x <- c(5, 25, 7, 15, 7, 10, 15, 19, 3, 11) - expect_equal(first_greater(A, x), c(2, 3, 2, 3, 2, 2, 2, 3, 1, 2)) - expect_equal(first_greater(A, x, i = 2), c(2, 3, 2, 3, 2, 2, 2, 3, 2, 2)) -}) - -test_that("array2list performs correct conversion", { - A <- array(1:27, dim = c(3,3,3)) - B <- list(matrix(1:9,3,3), matrix(10:18,3,3), matrix(19:27,3,3)) - expect_equal(brms:::array2list(A), B) -}) - -test_that("probit and probit_approx produce similar results", { - expect_equal(brms:::ilink(-10:10, "probit"), - brms:::ilink(-10:10, "probit_approx"), - tolerance = 1e-3) -}) - -test_that("autocorrelation matrices are computed correctly", { - ar <- 0.5 - ma <- 0.3 - - ar_mat <- brms:::get_cor_matrix_ar1(ar = matrix(ar), nobs = 4) - expected_ar_mat <- 1 / (1 - ar^2) * - cbind(c(1, ar, ar^2, ar^3), - c(ar, 1, ar, ar^2), - c(ar^2, ar, 1, ar), - c(ar^3, ar^2, ar, 1)) - expect_equal(ar_mat[1, , ], expected_ar_mat) - - ma_mat <- brms:::get_cor_matrix_ma1(ma = matrix(ma), nobs = 4) - expected_ma_mat <- cbind(c(1+ma^2, ma, 0, 0), - c(ma, 1+ma^2, ma, 0), - c(0, ma, 1+ma^2, ma), - c(0, 0, ma, 1+ma^2)) - expect_equal(ma_mat[1, , ], expected_ma_mat) - - arma_mat <- brms:::get_cor_matrix_arma1( - ar = matrix(ar), ma = matrix(ma), nobs = 4 - ) - g0 <- 1 + ma^2 + 2 * ar * ma - g1 <- (1 + ar * ma) * (ar + ma) - expected_arma_mat <- 1 / (1 - ar^2) * - cbind(c(g0, g1, g1 * ar, g1 * ar^2), - c(g1, g0, g1, g1 * ar), - c(g1 * ar, g1, g0, g1), - c(g1 * ar^2, g1 * ar, g1, g0)) - expect_equal(arma_mat[1, , ], expected_arma_mat) - - cosy <- 0.6 - cosy_mat <- brms:::get_cor_matrix_cosy(cosy = as.matrix(cosy), nobs = 4) - expected_cosy_mat <- matrix(cosy, 4, 4) - diag(expected_cosy_mat) <- 1 - expect_equal(cosy_mat[1, , ], expected_cosy_mat) - - ident_mat <- brms:::get_cor_matrix_ident(ndraws = 10, nobs = 4) - expected_ident_mat <- diag(1, 4) - expect_equal(ident_mat[1, , ], expected_ident_mat) -}) - -test_that("evidence_ratio returns expected results", { - ps <- -4:10 - prs <- -2:12 - expect_true(evidence_ratio(ps, prior_samples = prs) > 1) - expect_true(is.na(evidence_ratio(ps))) - expect_equal(evidence_ratio(ps, cut = 0.5, wsign = "greater"), 10/5) - expect_equal(evidence_ratio(ps, cut = 0.5, wsign = "less"), 5/10) -}) - -test_that("find_vars finds all valid variable names in a string", { - string <- "x + b.x - .5 + abc(a__3) : 1/2 - 0.2" - expect_equal(find_vars(string), c("x", "b.x", "a__3")) -}) - -test_that(".predictor_arma runs without errors", { - ns <- 20 - nobs <- 30 - Y = rnorm(nobs) - J_lag = c(1:3, 3, 3, rep(c(0:3, 3), 4), 0:3, 0) - ar <- matrix(rnorm(ns * 3), nrow = ns, ncol = 3) - ma <- matrix(rnorm(ns * 1), nrow = ns, ncol = 1) - eta <- matrix(rnorm(ns * nobs), nrow = ns, ncol = nobs) - expect_equal(.predictor_arma(eta, Y = Y, J_lag = J_lag), eta) - expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ar = ar)) - expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ma = ma)) - expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ar = ar, ma = ma)) -}) - -test_that("make_conditions works correctly", { - conds <- make_conditions(epilepsy, c("zBase", "zAge")) - expect_equal(dim(conds), c(9, 3)) - expect_equal(conds$cond__[3], "zBase = -1 & zAge = 1") -}) - -test_that("brmsfit_needs_refit works correctly", { - cache_tmp <- tempfile(fileext = ".rds") - - expect_null(read_brmsfit(cache_tmp)) - - saveRDS(list(a = 1), file = cache_tmp) - expect_error(read_brmsfit(cache_tmp)) - - data_model1 <- data.frame(y = rnorm(10), x = rnorm(10)) - fake_fit <- brm(y ~ x, data = data_model1, empty = TRUE) - - fake_fit_file <- fake_fit - fake_fit_file$file <- cache_tmp - - scode_model1 <- make_stancode(y ~ x, data = data_model1) - sdata_model1 <- make_standata(y ~ x, data = data_model1) - - data_model2 <- data_model1 - data_model2$x[1] <- data_model2$x[1] + 1 - scode_model2 <- make_stancode(y ~ 0 + x, data = data_model2) - sdata_model2 <- make_standata(y ~ 0 + x, data = data_model2) - - - write_brmsfit(fake_fit, file = cache_tmp) - cache_res <- read_brmsfit(file = cache_tmp) - expect_equal(cache_res, fake_fit_file) - - expect_false(brmsfit_needs_refit( - cache_res, sdata = sdata_model1, scode = scode_model1, - algorithm = "sampling", silent = TRUE)) - expect_false(brmsfit_needs_refit( - cache_res, sdata = sdata_model1, scode = scode_model1, algorithm = NULL, - silent = TRUE)) - expect_false(brmsfit_needs_refit( - cache_res, sdata = sdata_model1, scode = NULL, - algorithm = "sampling", silent = TRUE)) - expect_false(brmsfit_needs_refit( - cache_res, sdata = NULL, scode = scode_model1, algorithm = "sampling", - silent = TRUE)) - - - expect_true(brmsfit_needs_refit( - cache_res, sdata = sdata_model2, scode = scode_model1, - algorithm = "sampling", silent = TRUE)) - expect_true(brmsfit_needs_refit( - cache_res, sdata = sdata_model1, scode = scode_model2, - algorithm = "sampling", silent = TRUE)) - expect_true(brmsfit_needs_refit( - cache_res, sdata = sdata_model2, scode = scode_model2, - algorithm = "sampling", silent = TRUE)) - expect_true(brmsfit_needs_refit( - cache_res, sdata = sdata_model1, scode = scode_model1, - algorithm = "optimize", silent = TRUE)) - - expect_true(brmsfit_needs_refit( - cache_res, sdata = make_standata(y ~ x, data = data_model1, - sample_prior = "only"), - scode = scode_model1, algorithm = NULL, silent = TRUE)) - -}) - -test_that("insert_refcat() works correctly", { - source(testthat::test_path(file.path("helpers", "insert_refcat_ch.R"))) - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - cats <- paste0("cat", 1:ncat) - fam_list <- list( - fam_refNULL = categorical(), - fam_ref1 = categorical(refcat = cats[1]), - fam_reflast = categorical(refcat = cats[ncat]) - ) - if (ncat > 2) { - fam_list <- c(fam_list, list(fam_ref2 = categorical(refcat = cats[2]))) - } - eta_test_list <- list(array(rnorm(ndraws * nobsv * (ncat - 1)), - dim = c(ndraws, nobsv, ncat - 1))) - if (nobsv == 1) { - eta_test_list <- c( - eta_test_list, - list(matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws)) - ) - } - for (eta_test in eta_test_list) { - for (fam in fam_list) { - # Emulate content of `fam` after fit: - if (is.null(fam$refcat)) { - fam$refcat <- cats[1] - } - fam$cats <- cats - - # Perform the check: - eta_ref <- insert_refcat(eta_test, fam) - eta_ref_ch <- insert_refcat_ch(eta_test, fam) - expect_equivalent(eta_ref, eta_ref_ch) - if (length(dim(eta_test)) == 3) { - expect_equal(dim(eta_ref), c(ndraws, nobsv, ncat)) - } else if (length(dim(eta_test)) == 2) { - expect_equal(dim(eta_ref), c(ndraws, ncat)) - } - } - } - } - } - } -}) +context("Tests for brmsfit helper functions") + +test_that("first_greater returns expected results", { + A <- cbind(1:10, 11:20, 21:30) + x <- c(5, 25, 7, 15, 7, 10, 15, 19, 3, 11) + expect_equal(first_greater(A, x), c(2, 3, 2, 3, 2, 2, 2, 3, 1, 2)) + expect_equal(first_greater(A, x, i = 2), c(2, 3, 2, 3, 2, 2, 2, 3, 2, 2)) +}) + +test_that("array2list performs correct conversion", { + A <- array(1:27, dim = c(3,3,3)) + B <- list(matrix(1:9,3,3), matrix(10:18,3,3), matrix(19:27,3,3)) + expect_equal(brms:::array2list(A), B) +}) + +test_that("probit and probit_approx produce similar results", { + expect_equal(brms:::inv_link(-10:10, "probit"), + brms:::inv_link(-10:10, "probit_approx"), + tolerance = 1e-3) +}) + +test_that("autocorrelation matrices are computed correctly", { + ar <- 0.5 + ma <- 0.3 + + ar_mat <- brms:::get_cor_matrix_ar1(ar = matrix(ar), nobs = 4) + expected_ar_mat <- 1 / (1 - ar^2) * + cbind(c(1, ar, ar^2, ar^3), + c(ar, 1, ar, ar^2), + c(ar^2, ar, 1, ar), + c(ar^3, ar^2, ar, 1)) + expect_equal(ar_mat[1, , ], expected_ar_mat) + + ma_mat <- brms:::get_cor_matrix_ma1(ma = matrix(ma), nobs = 4) + expected_ma_mat <- cbind(c(1+ma^2, ma, 0, 0), + c(ma, 1+ma^2, ma, 0), + c(0, ma, 1+ma^2, ma), + c(0, 0, ma, 1+ma^2)) + expect_equal(ma_mat[1, , ], expected_ma_mat) + + arma_mat <- brms:::get_cor_matrix_arma1( + ar = matrix(ar), ma = matrix(ma), nobs = 4 + ) + g0 <- 1 + ma^2 + 2 * ar * ma + g1 <- (1 + ar * ma) * (ar + ma) + expected_arma_mat <- 1 / (1 - ar^2) * + cbind(c(g0, g1, g1 * ar, g1 * ar^2), + c(g1, g0, g1, g1 * ar), + c(g1 * ar, g1, g0, g1), + c(g1 * ar^2, g1 * ar, g1, g0)) + expect_equal(arma_mat[1, , ], expected_arma_mat) + + cosy <- 0.6 + cosy_mat <- brms:::get_cor_matrix_cosy(cosy = as.matrix(cosy), nobs = 4) + expected_cosy_mat <- matrix(cosy, 4, 4) + diag(expected_cosy_mat) <- 1 + expect_equal(cosy_mat[1, , ], expected_cosy_mat) + + ident_mat <- brms:::get_cor_matrix_ident(ndraws = 10, nobs = 4) + expected_ident_mat <- diag(1, 4) + expect_equal(ident_mat[1, , ], expected_ident_mat) +}) + +test_that("evidence_ratio returns expected results", { + ps <- -4:10 + prs <- -2:12 + expect_true(evidence_ratio(ps, prior_samples = prs) > 1) + expect_true(is.na(evidence_ratio(ps))) + expect_equal(evidence_ratio(ps, cut = 0.5, wsign = "greater"), 10/5) + expect_equal(evidence_ratio(ps, cut = 0.5, wsign = "less"), 5/10) +}) + +test_that("find_vars finds all valid variable names in a string", { + string <- "x + b.x - .5 + abc(a__3) : 1/2 - 0.2" + expect_equal(find_vars(string), c("x", "b.x", "a__3")) +}) + +test_that(".predictor_arma runs without errors", { + ns <- 20 + nobs <- 30 + Y = rnorm(nobs) + J_lag = c(1:3, 3, 3, rep(c(0:3, 3), 4), 0:3, 0) + ar <- matrix(rnorm(ns * 3), nrow = ns, ncol = 3) + ma <- matrix(rnorm(ns * 1), nrow = ns, ncol = 1) + eta <- matrix(rnorm(ns * nobs), nrow = ns, ncol = nobs) + expect_equal(.predictor_arma(eta, Y = Y, J_lag = J_lag), eta) + expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ar = ar)) + expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ma = ma)) + expect_silent(.predictor_arma(eta, Y = Y, J_lag = J_lag, ar = ar, ma = ma)) +}) + +test_that("make_conditions works correctly", { + conds <- make_conditions(epilepsy, c("zBase", "zAge")) + expect_equal(dim(conds), c(9, 3)) + expect_equal(conds$cond__[3], "zBase = -1 & zAge = 1") +}) + +test_that("brmsfit_needs_refit works correctly", { + cache_tmp <- tempfile(fileext = ".rds") + + expect_null(read_brmsfit(cache_tmp)) + + saveRDS(list(a = 1), file = cache_tmp) + expect_error(read_brmsfit(cache_tmp)) + + data_model1 <- data.frame(y = rnorm(10), x = rnorm(10)) + fake_fit <- brm(y ~ x, data = data_model1, empty = TRUE) + + fake_fit_file <- fake_fit + fake_fit_file$file <- cache_tmp + + scode_model1 <- make_stancode(y ~ x, data = data_model1) + sdata_model1 <- make_standata(y ~ x, data = data_model1) + + data_model2 <- data_model1 + data_model2$x[1] <- data_model2$x[1] + 1 + scode_model2 <- make_stancode(y ~ 0 + x, data = data_model2) + sdata_model2 <- make_standata(y ~ 0 + x, data = data_model2) + + + write_brmsfit(fake_fit, file = cache_tmp) + cache_res <- read_brmsfit(file = cache_tmp) + expect_equal(cache_res, fake_fit_file) + + expect_false(brmsfit_needs_refit( + cache_res, sdata = sdata_model1, scode = scode_model1, + algorithm = "sampling", silent = TRUE)) + expect_false(brmsfit_needs_refit( + cache_res, sdata = sdata_model1, scode = scode_model1, algorithm = NULL, + silent = TRUE)) + expect_false(brmsfit_needs_refit( + cache_res, sdata = sdata_model1, scode = NULL, + algorithm = "sampling", silent = TRUE)) + expect_false(brmsfit_needs_refit( + cache_res, sdata = NULL, scode = scode_model1, algorithm = "sampling", + silent = TRUE)) + + + expect_true(brmsfit_needs_refit( + cache_res, sdata = sdata_model2, scode = scode_model1, + algorithm = "sampling", silent = TRUE)) + expect_true(brmsfit_needs_refit( + cache_res, sdata = sdata_model1, scode = scode_model2, + algorithm = "sampling", silent = TRUE)) + expect_true(brmsfit_needs_refit( + cache_res, sdata = sdata_model2, scode = scode_model2, + algorithm = "sampling", silent = TRUE)) + expect_true(brmsfit_needs_refit( + cache_res, sdata = sdata_model1, scode = scode_model1, + algorithm = "optimize", silent = TRUE)) + + expect_true(brmsfit_needs_refit( + cache_res, sdata = make_standata(y ~ x, data = data_model1, + sample_prior = "only"), + scode = scode_model1, algorithm = NULL, silent = TRUE)) + +}) + +test_that("insert_refcat() works correctly", { + source(testthat::test_path(file.path("helpers", "insert_refcat_ch.R"))) + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + cats <- paste0("cat", 1:ncat) + ref_list <- list( + ref1 = 1, + reflast = ncat + ) + fam_list <- list( + fam_ref1 = categorical(refcat = cats[1]), + fam_reflast = categorical(refcat = cats[ncat]) + ) + if (ncat > 2) { + ref_list <- c(ref_list, list(ref2 = 2)) + fam_list <- c(fam_list, list(fam_ref2 = categorical(refcat = cats[2]))) + } + eta_test_list <- list(array(rnorm(ndraws * nobsv * (ncat - 1)), + dim = c(ndraws, nobsv, ncat - 1))) + if (nobsv == 1) { + eta_test_list <- c( + eta_test_list, + list(matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws)) + ) + } + for (eta_test in eta_test_list) { + for (i in seq_along(fam_list)) { + # Emulate content of `fam` after fit: + fam <- fam_list[[i]] + if (is.null(fam$refcat)) { + fam$refcat <- cats[1] + } + fam$cats <- cats + ref <- ref_list[[i]] + + # Perform the check: + eta_ref <- insert_refcat(eta_test, ref) + eta_ref_ch <- insert_refcat_ch(eta_test, fam) + expect_equivalent(eta_ref, eta_ref_ch) + if (length(dim(eta_test)) == 3) { + expect_equal(dim(eta_ref), c(ndraws, nobsv, ncat)) + } else if (length(dim(eta_test)) == 2) { + expect_equal(dim(eta_ref), c(ndraws, ncat)) + } + } + } + } + } + } +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.brmsfit-methods.R r-cran-brms-2.17.0/tests/testthat/tests.brmsfit-methods.R --- r-cran-brms-2.16.3/tests/testthat/tests.brmsfit-methods.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.brmsfit-methods.R 2022-04-08 11:57:41.000000000 +0000 @@ -1,977 +1,980 @@ -context("Tests for brmsfit methods") - -# to reduce testing time on CRAN substantially -skip_on_cran() - -expect_range <- function(object, lower = -Inf, upper = Inf, ...) { - testthat::expect_true(all(object >= lower & object <= upper), ...) -} -expect_ggplot <- function(object, ...) { - testthat::expect_true(is(object, "ggplot"), ...) -} - -SM <- suppressMessages -SW <- suppressWarnings - -fit1 <- rename_pars(brms:::brmsfit_example1) -fit2 <- rename_pars(brms:::brmsfit_example2) -fit3 <- rename_pars(brms:::brmsfit_example3) -fit4 <- rename_pars(brms:::brmsfit_example4) -fit5 <- rename_pars(brms:::brmsfit_example5) -fit6 <- rename_pars(brms:::brmsfit_example6) - -# test S3 methods in alphabetical order -test_that("as_draws and friends have resonable outputs", { - draws <- as_draws(fit1, variable = "b_Intercept") - expect_s3_class(draws, "draws_list") - expect_equal(variables(draws), "b_Intercept") - expect_equal(ndraws(draws), ndraws(fit1)) - - draws <- SM(as_draws_matrix(fit1)) - expect_s3_class(draws, "draws_matrix") - expect_equal(ndraws(draws), ndraws(fit1)) - - draws <- as_draws_array(fit2) - expect_s3_class(draws, "draws_array") - expect_equal(niterations(draws), ndraws(fit2)) - - draws <- as_draws_df(fit2, variable = "^b_", regex = TRUE) - expect_s3_class(draws, "draws_df") - expect_true(all(grepl("^b_", variables(draws)))) - - draws <- as_draws_list(fit2) - expect_s3_class(draws, "draws_list") - expect_equal(nchains(draws), nchains(fit2)) - - draws <- as_draws_rvars(fit3) - expect_s3_class(draws, "draws_rvars") - expect_equal(ndraws(draws), ndraws(fit3)) - expect_true(length(variables(draws)) > 0) -}) - -test_that("as.data.frame has reasonable ouputs", { - draws <- as.data.frame(fit1) - expect_true(is(draws, "data.frame")) - expect_equal(dim(draws), c(ndraws(fit1), length(variables(fit1)))) - - # deprecated 'pars' argument still works - expect_warning( - draws <- as.data.frame(fit1, pars = "^b_"), - "'pars' is deprecated" - ) - expect_s3_class(draws, "data.frame") - expect_true(ncol(draws) > 0) - - # deprecated 'subset' argument still works - expect_warning( - draws <- as.data.frame(fit1, subset = 10:20), - "'subset' is deprecated" - ) - expect_s3_class(draws, "data.frame") - expect_equal(nrow(draws), 11) -}) - -test_that("as.matrix has reasonable ouputs", { - draws <- as.matrix(fit1, iteration = 1:10) - expect_true(is(draws, "matrix")) - expect_equal(dim(draws), c(10, length(variables(fit1)))) -}) - -test_that("as.array has reasonable ouputs", { - draws <- as.array(fit1) - expect_true(is.array(draws)) - chains <- fit1$fit@sim$chains - ps_dim <- c(niterations(fit1), chains, length(variables(fit1))) - expect_equal(dim(draws), ps_dim) - - draws <- as.array(fit1, chain = 1) - expect_true(is.array(draws)) - ps_dim <- c(niterations(fit1), 1, length(variables(fit1))) - expect_equal(dim(draws), ps_dim) -}) - -test_that("as.mcmc has reasonable ouputs", { - chains <- fit1$fit@sim$chains - mc <- SW(as.mcmc(fit1)) - expect_equal(length(mc), chains) - expect_equal(dim(mc[[1]]), c(ndraws(fit1) / chains, length(variables(fit1)))) - mc <- SW(as.mcmc(fit1, combine_chains = TRUE)) - expect_equal(dim(mc), c(ndraws(fit1), length(variables(fit1)))) - # test assumes thin = 1 - expect_equal(dim(SW(as.mcmc(fit1, inc_warmup = TRUE)[[1]])), - c(fit1$fit@sim$iter, length(variables(fit1)))) -}) - -test_that("autocor has reasonable ouputs", { - expect_true(is.null(SW(autocor(fit1)))) - expect_true(is.null(SW(autocor(fit6, resp = "count")))) -}) - -test_that("bayes_R2 has reasonable ouputs", { - fit1 <- add_criterion(fit1, "bayes_R2") - R2 <- bayes_R2(fit1, summary = FALSE) - expect_equal(dim(R2), c(ndraws(fit1), 1)) - R2 <- bayes_R2(fit2, newdata = model.frame(fit2)[1:5, ], re_formula = NA) - expect_equal(dim(R2), c(1, 4)) - R2 <- bayes_R2(fit6) - expect_equal(dim(R2), c(2, 4)) -}) - -test_that("bayes_factor has reasonable ouputs", { - # don't test for now as it requires calling Stan's C++ code -}) - -test_that("bridge_sampler has reasonable ouputs", { - # don't test for now as it requires calling Stan's C++ code -}) - -test_that("coef has reasonable ouputs", { - coef1 <- SM(coef(fit1)) - expect_equal(dim(coef1$visit), c(4, 4, 9)) - coef1 <- SM(coef(fit1, summary = FALSE)) - expect_equal(dim(coef1$visit), c(ndraws(fit1), 4, 9)) - coef2 <- SM(coef(fit2)) - expect_equal(dim(coef2$patient), c(59, 4, 4)) - coef4 <- SM(coef(fit4)) - expect_equal(dim(coef4$subject), c(10, 4, 8)) -}) - -test_that("combine_models has reasonable ouputs", { - expect_equal(ndraws(combine_models(fit1, fit1)), ndraws(fit1) * 2) -}) - -test_that("conditional_effects has reasonable ouputs", { - me <- conditional_effects(fit1, resp = "count") - expect_equal(nrow(me[[2]]), 100) - meplot <- plot(me, points = TRUE, rug = TRUE, - ask = FALSE, plot = FALSE) - expect_ggplot(meplot[[1]]) - - me <- conditional_effects(fit1, "Trt", select_points = 0.1) - expect_lt(nrow(attr(me[[1]], "points")), nobs(fit1)) - - me <- conditional_effects(fit1, "volume:Age", surface = TRUE, - resolution = 15, too_far = 0.2) - meplot <- plot(me, plot = FALSE) - expect_ggplot(meplot[[1]]) - meplot <- plot(me, stype = "raster", plot = FALSE) - expect_ggplot(meplot[[1]]) - - me <- conditional_effects(fit1, "Age", spaghetti = TRUE, ndraws = 10) - expect_equal(nrow(attr(me$Age, "spaghetti")), 1000) - meplot <- plot(me, plot = FALSE) - expect_ggplot(meplot[[1]]) - expect_error( - conditional_effects(fit1, "Age", spaghetti = TRUE, surface = TRUE), - "Cannot use 'spaghetti' and 'surface' at the same time" - ) - - me <- conditional_effects(fit1, effects = "Age:visit", re_formula = NULL) - exp_nrow <- 100 * length(unique(fit1$data$visit)) - expect_equal(nrow(me[[1]]), exp_nrow) - - mdata = data.frame( - Age = c(-0.3, 0, 0.3), - count = c(10, 20, 30), - Exp = c(1, 3, 5) - ) - exp_nrow <- nrow(mdata) * 100 - me <- conditional_effects(fit1, effects = "Age", conditions = mdata) - expect_equal(nrow(me[[1]]), exp_nrow) - - mdata$visit <- 1:3 - me <- conditional_effects(fit1, re_formula = NULL, conditions = mdata) - expect_equal(nrow(me$Age), exp_nrow) - - me <- conditional_effects( - fit1, "Age:Trt", int_conditions = list(Age = rnorm(5)) - ) - expect_equal(nrow(me[[1]]), 10) - me <- conditional_effects( - fit1, "Age:Trt", int_conditions = list(Age = quantile) - ) - expect_equal(nrow(me[[1]]), 10) - - expect_error(conditional_effects(fit1, effects = "Trtc"), - "All specified effects are invalid for this model") - expect_warning(conditional_effects(fit1, effects = c("Trtc", "Trt")), - "Some specified effects are invalid for this model") - expect_error(conditional_effects(fit1, effects = "Trtc:a:b"), - "please use the 'conditions' argument") - - mdata$visit <- NULL - mdata$Exp <- NULL - mdata$patient <- 1 - expect_equal(nrow(conditional_effects(fit2)[[2]]), 100) - me <- conditional_effects(fit2, re_formula = NULL, conditions = mdata) - expect_equal(nrow(me$Age), exp_nrow) - - expect_warning( - me4 <- conditional_effects(fit4), - "Predictions are treated as continuous variables" - ) - expect_true(is(me4, "brms_conditional_effects")) - me4 <- conditional_effects(fit4, "x2", categorical = TRUE) - expect_true(is(me4, "brms_conditional_effects")) - - me5 <- conditional_effects(fit5) - expect_true(is(me5, "brms_conditional_effects")) - - me6 <- conditional_effects(fit6, ndraws = 40) - expect_true(is(me6, "brms_conditional_effects")) -}) - -test_that("plot of conditional_effects has reasonable outputs", { - SW(ggplot2::theme_set(theme_black())) - N <- 90 - marg_results <- data.frame( - effect1__ = rpois(N, 20), - effect2__ = factor(rep(1:3, each = N / 3)), - estimate__ = rnorm(N, sd = 5), - se__ = rt(N, df = 10), - cond__ = rep(1:2, each = N / 2), - cats__ = factor(rep(1:3, each = N / 3)) - ) - marg_results[["lower__"]] <- marg_results$estimate__ - 2 - marg_results[["upper__"]] <- marg_results$estimate__ + 2 - marg_results <- list(marg_results[order(marg_results$effect1__), ]) - class(marg_results) <- "brms_conditional_effects" - attr(marg_results[[1]], "response") <- "count" - # test with 1 numeric predictor - attr(marg_results[[1]], "effects") <- "P1" - marg_plot <- plot(marg_results, plot = FALSE) - expect_ggplot(marg_plot[[1]]) - # test with 1 categorical predictor - attr(marg_results[[1]], "effects") <- "P2" - marg_plot <- plot(marg_results, plot = FALSE) - expect_ggplot(marg_plot[[1]]) - # test with 1 numeric and 1 categorical predictor - attr(marg_results[[1]], "effects") <- c("P1", "P2") - marg_plot <- plot(marg_results, plot = FALSE) - expect_ggplot(marg_plot[[1]]) - # test ordinal raster plot - attr(marg_results[[1]], "effects") <- c("P1", "cats__") - attr(marg_results[[1]], "ordinal") <- TRUE - marg_plot <- plot(marg_results, plot = FALSE) - expect_ggplot(marg_plot[[1]]) -}) - -test_that("conditional_smooths has reasonable ouputs", { - ms <- conditional_smooths(fit1) - expect_equal(nrow(ms[[1]]), 100) - expect_true(is(ms, "brms_conditional_effects")) - - ms <- conditional_smooths(fit1, spaghetti = TRUE, ndraws = 10) - expect_equal(nrow(attr(ms[[1]], "spaghetti")), 1000) - - expect_error(conditional_smooths(fit1, smooths = "s3"), - "No valid smooth terms found in the model") - expect_error(conditional_smooths(fit2), - "No valid smooth terms found in the model") -}) - -test_that("family has reasonable ouputs", { - expect_is(family(fit1), "brmsfamily") - expect_is(family(fit6, resp = "count"), "brmsfamily") - expect_output(print(family(fit1), links = TRUE), "student.*log.*logm1") - expect_output(print(family(fit5)), "Mixture.*gaussian.*exponential") -}) - -test_that("fitted has reasonable outputs", { - skip_on_cran() - - fi <- fitted(fit1) - expect_equal(dim(fi), c(nobs(fit1), 4)) - expect_equal(colnames(fi), c("Estimate", "Est.Error", "Q2.5", "Q97.5")) - - newdata <- data.frame( - Age = c(0, -0.2), visit = c(1, 4), Trt = c(0, 1), - count = c(20, 13), patient = c(1, 42), Exp = c(2, 4), - volume = 0 - ) - fi <- fitted(fit1, newdata = newdata) - expect_equal(dim(fi), c(2, 4)) - newdata$visit <- c(1, 6) - fi <- fitted(fit1, newdata = newdata, - allow_new_levels = TRUE) - expect_equal(dim(fi), c(2, 4)) - - # fitted values with new_levels - newdata <- data.frame( - Age = 0, visit = paste0("a", 1:100), Trt = 0, - count = 20, patient = 1, Exp = 2, volume = 0 - ) - fi <- fitted(fit1, newdata = newdata, allow_new_levels = TRUE, - sample_new_levels = "old_levels", ndraws = 10) - expect_equal(dim(fi), c(100, 4)) - fi <- fitted(fit1, newdata = newdata, allow_new_levels = TRUE, - sample_new_levels = "gaussian", ndraws = 1) - expect_equal(dim(fi), c(100, 4)) - - # fitted values of auxiliary parameters - newdata <- data.frame( - Age = 0, visit = c("a", "b"), Trt = 0, - count = 20, patient = 1, Exp = 2, volume = 0 - ) - fi <- fitted(fit1, dpar = "sigma") - expect_equal(dim(fi), c(nobs(fit1), 4)) - expect_true(all(fi > 0)) - fi_lin <- fitted(fit1, dpar = "sigma", scale = "linear") - expect_equal(dim(fi_lin), c(nobs(fit1), 4)) - expect_true(!isTRUE(all.equal(fi, fi_lin))) - expect_error(fitted(fit1, dpar = "inv"), - "Invalid argument 'dpar'") - - fi <- fitted(fit2) - expect_equal(dim(fi), c(nobs(fit2), 4)) - fi <- fitted(fit2, newdata = newdata, - allow_new_levels = TRUE) - expect_equal(dim(fi), c(2, 4)) - fi <- fitted(fit2, dpar = "shape") - expect_equal(dim(fi), c(nobs(fit2), 4)) - expect_equal(fi[1, ], fi[2, ]) - fi <- fitted(fit2, nlpar = "a") - expect_equal(dim(fi), c(nobs(fit2), 4)) - - fi <- fitted(fit3, newdata = fit3$data[1:10, ]) - expect_equal(dim(fi), c(10, 4)) - - fi <- fitted(fit4) - expect_equal(dim(fi), c(nobs(fit4), 4, 4)) - fi <- fitted(fit4, newdata = fit4$data[1, ]) - expect_equal(dim(fi), c(1, 4, 4)) - fi <- fitted(fit4, newdata = fit4$data[1, ], scale = "linear") - expect_equal(dim(fi), c(1, 4, 3)) - - fi <- fitted(fit5) - expect_equal(dim(fi), c(nobs(fit5), 4)) - - fi <- fitted(fit6) - expect_equal(dim(fi), c(nobs(fit6), 4, 2)) - expect_equal(dimnames(fi)[[3]], c("volume", "count")) -}) - -test_that("fixef has reasonable ouputs", { - fixef1 <- SM(fixef(fit1)) - expect_equal(rownames(fixef1), - c("Intercept", "sigma_Intercept", "Trt1", "Age", "volume", - "Trt1:Age", "sigma_Trt1", "sAge_1", "moExp") - ) - fixef1 <- SM(fixef(fit1, pars = c("Age", "sAge_1"))) - expect_equal(rownames(fixef1), c("Age", "sAge_1")) -}) - -test_that("formula has reasonable ouputs", { - expect_true(is.brmsformula(formula(fit1))) -}) - -test_that("hypothesis has reasonable ouputs", { - hyp <- hypothesis(fit1, c("Age > Trt1", "Trt1:Age = -1")) - expect_equal(dim(hyp$hypothesis), c(2, 8)) - expect_output(print(hyp), "(Age)-(Trt1) > 0", fixed = TRUE) - expect_ggplot(plot(hyp, plot = FALSE)[[1]]) - - hyp <- hypothesis(fit1, "Intercept = 0", class = "sd", group = "visit") - expect_true(is.numeric(hyp$hypothesis$Evid.Ratio[1])) - expect_output(print(hyp), "class sd_visit:", fixed = TRUE) - expect_ggplot(plot(hyp, ignore_prior = TRUE, plot = FALSE)[[1]]) - - hyp <- hypothesis(fit1, "0 > r_visit[4,Intercept]", class = "", alpha = 0.01) - expect_equal(dim(hyp$hypothesis), c(1, 8)) - expect_output(print(hyp, chars = NULL), "r_visit[4,Intercept]", fixed = TRUE) - expect_output(print(hyp), "99%-CI", fixed = TRUE) - - hyp <- hypothesis( - fit1, c("Intercept = 0", "Intercept + exp(Trt1) = 0"), - group = "visit", scope = "coef" - ) - expect_equal(dim(hyp$hypothesis), c(8, 9)) - expect_equal(hyp$hypothesis$Group[1], factor(1, levels = 1:4)) - - expect_error(hypothesis(fit1, "Intercept > x"), fixed = TRUE, - "cannot be found in the model: \n'b_x'") - expect_error(hypothesis(fit1, 1), - "Argument 'hypothesis' must be a character vector") - expect_error(hypothesis(fit2, "b_Age = 0", alpha = 2), - "Argument 'alpha' must be a single value in [0,1]", - fixed = TRUE) - expect_error(hypothesis(fit3, "b_Age x 0"), - "Every hypothesis must be of the form 'left (= OR < OR >) right'", - fixed = TRUE) - - # test hypothesis.default method - hyp <- hypothesis(as.data.frame(fit3), "bsp_meAgeAgeSD > sigma") - expect_equal(dim(hyp$hypothesis), c(1, 8)) - hyp <- hypothesis(fit3$fit, "bsp_meAgeAgeSD > sigma") - expect_equal(dim(hyp$hypothesis), c(1, 8)) -}) - -test_that("launch_shinystan has reasonable ouputs", { - # requires running shiny which is not reasonable in automated tests -}) - -test_that("log_lik has reasonable ouputs", { - expect_equal(dim(log_lik(fit1)), c(ndraws(fit1), nobs(fit1))) - expect_equal(dim(logLik(fit1)), c(ndraws(fit1), nobs(fit1))) - expect_equal(dim(log_lik(fit2)), c(ndraws(fit2), nobs(fit2))) -}) - -test_that("loo has reasonable outputs", { - skip_on_cran() - - loo1 <- SW(LOO(fit1, cores = 1)) - expect_true(is.numeric(loo1$estimates)) - expect_output(print(loo1), "looic") - - loo_compare1 <- SW(loo(fit1, fit1, cores = 1)) - expect_equal(names(loo_compare1$loos), c("fit1", "fit1")) - expect_equal(dim(loo_compare1$ic_diffs__), c(1, 2)) - expect_output(print(loo_compare1), "'fit1':") - expect_is(loo_compare1$diffs, "compare.loo") - - loo2 <- SW(loo(fit2, cores = 1)) - expect_true(is.numeric(loo2$estimates)) - - loo3 <- SW(loo(fit3, cores = 1)) - expect_true(is.numeric(loo3$estimates)) - loo3 <- SW(loo(fit3, pointwise = TRUE, cores = 1)) - expect_true(is.numeric(loo3$estimates)) - - loo4 <- SW(loo(fit4, cores = 1)) - expect_true(is.numeric(loo4$estimates)) - - # fails because of too small effective sample size - # loo5 <- SW(loo(fit5, cores = 1)) - # expect_true(is.numeric(loo5$estimates)) - - loo6_1 <- SW(loo(fit6, cores = 1)) - expect_true(is.numeric(loo6_1$estimates)) - loo6_2 <- SW(loo(fit6, cores = 1, newdata = fit6$data)) - expect_true(is.numeric(loo6_2$estimates)) - loo_compare <- loo_compare(loo6_1, loo6_2) - expect_range(loo_compare[2, 1], -1, 1) -}) - -test_that("loo_subsample has reasonable outputs", { - skip_on_cran() - - loo2 <- SW(loo_subsample(fit2, observations = 50)) - expect_true(is.numeric(loo2$estimates)) - expect_equal(nrow(loo2$pointwise), 50) - expect_output(print(loo2), "looic") -}) - -test_that("loo_R2 has reasonable outputs", { - skip_on_cran() - - R2 <- SW(loo_R2(fit1)) - expect_equal(dim(R2), c(1, 4)) - - R2 <- SW(loo_R2(fit2, summary = FALSE)) - expect_equal(dim(R2), c(ndraws(fit1), 1)) -}) - -test_that("loo_linpred has reasonable outputs", { - skip_on_cran() - - llp <- SW(loo_linpred(fit1)) - expect_equal(length(llp), nobs(fit1)) - expect_error(loo_linpred(fit4), "Method 'loo_linpred'") - llp <- SW(loo_linpred(fit2, scale = "response", type = "var")) - expect_equal(length(llp), nobs(fit2)) -}) - -test_that("loo_predict has reasonable outputs", { - skip_on_cran() - - llp <- SW(loo_predict(fit1)) - expect_equal(length(llp), nobs(fit1)) - - newdata <- data.frame( - Age = 0, visit = c("a", "b"), Trt = 0, - count = 20, patient = 1, Exp = 2, volume = 0 - ) - llp <- SW(loo_predict( - fit1, newdata = newdata, - type = "quantile", probs = c(0.25, 0.75), - allow_new_levels = TRUE - )) - expect_equal(dim(llp), c(2, nrow(newdata))) - llp <- SW(loo_predict(fit4)) - expect_equal(length(llp), nobs(fit4)) -}) - -test_that("loo_predictive_interval has reasonable outputs", { - skip_on_cran() - - llp <- SW(loo_predictive_interval(fit3)) - expect_equal(dim(llp), c(nobs(fit3), 2)) -}) - -test_that("loo_model_weights has reasonable outputs", { - skip_on_cran() - - llw <- SW(loo_model_weights(fit1, fit1)) - expect_is(llw[1:2], "numeric") - expect_equal(names(llw), c("fit1", "fit1")) -}) - -test_that("model.frame has reasonable ouputs", { - expect_equal(model.frame(fit1), fit1$data) -}) - -test_that("model_weights has reasonable ouputs", { - mw <- model_weights(fit1, fit1, weights = "waic") - expect_equal(names(mw), c("fit1", "fit1")) - # fails with MKL on CRAN for unknown reasons - # expect_equal(mw, setNames(c(0.5, 0.5), c("fit1", "fit1"))) -}) - -test_that("ndraws and friends have reasonable ouputs", { - expect_equal(ndraws(fit1), 50) - expect_equal(nchains(fit1), 1) - expect_equal(niterations(fit1), 50) -}) - -test_that("ngrps has reasonable ouputs", { - expect_equal(ngrps(fit1), list(visit = 4)) - expect_equal(ngrps(fit2), list(patient = 59)) -}) - -test_that("nobs has reasonable ouputs", { - expect_equal(nobs(fit1), nrow(epilepsy)) -}) - -test_that("nsamples has reasonable ouputs", { - expect_equal(SW(nsamples(fit1)), 50) - expect_equal(SW(nsamples(fit1, subset = 10:1)), 10) - expect_equal(SW(nsamples(fit1, incl_warmup = TRUE)), 200) -}) - -test_that("pairs has reasonable outputs", { - expect_s3_class(SW(pairs(fit1, variable = variables(fit1)[1:3])), - "bayesplot_grid") -}) - -test_that("plot has reasonable outputs", { - expect_silent(p <- plot(fit1, plot = FALSE)) - expect_silent(p <- plot(fit1, variable = "^b", regex = TRUE, plot = FALSE)) - expect_silent(p <- plot(fit1, variable = "^sd", regex = TRUE, plot = FALSE)) - expect_error(plot(fit1, variable = "123")) -}) - -test_that("post_prob has reasonable ouputs", { - # only test error messages for now - expect_error(post_prob(fit1, fit2, model_names = "test1"), - "Number of model names is not equal to the number of models") -}) - -test_that("posterior_average has reasonable outputs", { - pnames <- c("b_Age", "nu") - draws <- posterior_average(fit1, fit1, variable = pnames, weights = c(0.3, 0.7)) - expect_equal(dim(draws), c(ndraws(fit1), 2)) - expect_equal(names(draws), pnames) - - weights <- rexp(3) - draws <- brms:::SW(posterior_average( - fit1, fit2, fit3, variable = "nu", weights = rexp(3), - missing = 1, ndraws = 10 - )) - expect_equal(dim(draws), c(10, 1)) - expect_equal(names(draws), "nu") -}) - -test_that("posterior_samples has reasonable outputs", { - draws <- SW(posterior_samples(fit1)) - expect_equal(dim(draws), c(ndraws(fit1), length(variables(fit1)))) - expect_equal(names(draws), variables(fit1)) - expect_equal(names(SW(posterior_samples(fit1, pars = "^b_"))), - c("b_Intercept", "b_sigma_Intercept", "b_Trt1", - "b_Age", "b_volume", "b_Trt1:Age", "b_sigma_Trt1")) - - # test default method - draws <- SW(posterior_samples(fit1$fit, "^b_Intercept$")) - expect_equal(dim(draws), c(ndraws(fit1), 1)) -}) - -test_that("posterior_summary has reasonable outputs", { - draws <- posterior_summary(fit1, variable = "^b_", regex = TRUE) - expect_equal(dim(draws), c(7, 4)) -}) - -test_that("posterior_interval has reasonable outputs", { - expect_equal(dim(posterior_interval(fit1)), - c(length(variables(fit1)), 2)) -}) - -test_that("posterior_predict has reasonable outputs", { - expect_equal(dim(posterior_predict(fit1)), - c(ndraws(fit1), nobs(fit1))) -}) - -test_that("posterior_linpred has reasonable outputs", { - expect_equal(dim(posterior_linpred(fit1)), - c(ndraws(fit1), nobs(fit1))) -}) - -test_that("pp_average has reasonable outputs", { - ppa <- pp_average(fit1, fit1, weights = "waic") - expect_equal(dim(ppa), c(nobs(fit1), 4)) - ppa <- pp_average(fit1, fit1, weights = c(1, 4)) - expect_equal(attr(ppa, "weights"), c(fit1 = 0.2, fit1 = 0.8)) - ns <- c(fit1 = ndraws(fit1) / 5, fit1 = 4 * ndraws(fit1) / 5) - expect_equal(attr(ppa, "ndraws"), ns) -}) - -test_that("pp_check has reasonable outputs", { - expect_ggplot(pp_check(fit1)) - expect_ggplot(pp_check(fit1, newdata = fit1$data[1:100, ])) - expect_ggplot(pp_check(fit1, "stat", ndraws = 5)) - expect_ggplot(pp_check(fit1, "error_binned")) - pp <- pp_check(fit1, "ribbon_grouped", group = "visit", x = "Age") - expect_ggplot(pp) - pp <- pp_check(fit1, type = "violin_grouped", - group = "visit", newdata = fit1$data[1:100, ]) - expect_ggplot(pp) - - pp <- SW(pp_check(fit1, type = "loo_pit", cores = 1)) - expect_ggplot(pp) - - expect_ggplot(pp_check(fit3)) - expect_ggplot(pp_check(fit2, "ribbon", x = "Age")) - expect_error(pp_check(fit2, "ribbon", x = "x"), - "Variable 'x' could not be found in the data") - expect_error(pp_check(fit1, "wrong_type")) - expect_error(pp_check(fit2, "violin_grouped"), "group") - expect_error(pp_check(fit1, "stat_grouped", group = "g"), - "Variable 'g' could not be found in the data") - expect_ggplot(pp_check(fit4)) - expect_ggplot(pp_check(fit5)) - expect_error(pp_check(fit4, "error_binned"), - "Type 'error_binned' is not available") -}) - -test_that("posterior_epred has reasonable outputs", { - expect_equal(dim(posterior_epred(fit1)), c(ndraws(fit1), nobs(fit1))) -}) - -test_that("pp_mixture has reasonable outputs", { - expect_equal(dim(pp_mixture(fit5)), c(nobs(fit5), 4, 2)) - expect_error(pp_mixture(fit1), - "Method 'pp_mixture' can only be applied to mixture models" - ) -}) - -test_that("predict has reasonable outputs", { - pred <- predict(fit1) - expect_equal(dim(pred), c(nobs(fit1), 4)) - expect_equal(colnames(pred), c("Estimate", "Est.Error", "Q2.5", "Q97.5")) - pred <- predict(fit1, ndraws = 10, probs = c(0.2, 0.5, 0.8)) - expect_equal(dim(pred), c(nobs(fit1), 5)) - - newdata <- data.frame( - Age = c(0, -0.2), visit = c(1, 4), Trt = c(1, 0), - count = c(2, 10), patient = c(1, 42), Exp = c(1, 2), - volume = 0 - ) - pred <- predict(fit1, newdata = newdata) - expect_equal(dim(pred), c(2, 4)) - - newdata$visit <- c(1, 6) - pred <- predict(fit1, newdata = newdata, allow_new_levels = TRUE) - expect_equal(dim(pred), c(2, 4)) - - # predict NA responses in ARMA models - df <- fit1$data[1:10, ] - df$count[8:10] <- NA - pred <- predict(fit1, newdata = df, ndraws = 1) - expect_true(!anyNA(pred[, "Estimate"])) - - pred <- predict(fit2) - expect_equal(dim(pred), c(nobs(fit2), 4)) - - pred <- predict(fit2, newdata = newdata, allow_new_levels = TRUE) - expect_equal(dim(pred), c(2, 4)) - - # check if grouping factors with a single level are accepted - newdata$patient <- factor(2) - pred <- predict(fit2, newdata = newdata) - expect_equal(dim(pred), c(2, 4)) - - pred <- predict(fit4) - expect_equal(dim(pred), c(nobs(fit4), 4)) - expect_equal(colnames(pred), paste0("P(Y = ", 1:4, ")")) - pred <- predict(fit4, newdata = fit4$data[1, ]) - expect_equal(dim(pred), c(1, 4)) - - pred <- predict(fit5) - expect_equal(dim(pred), c(nobs(fit5), 4)) - newdata <- fit5$data[1:10, ] - newdata$patient <- "a" - pred <- predict(fit5, newdata, allow_new_levels = TRUE, - sample_new_levels = "old_levels") - expect_equal(dim(pred), c(10, 4)) - pred <- predict(fit5, newdata, allow_new_levels = TRUE, - sample_new_levels = "gaussian") - expect_equal(dim(pred), c(10, 4)) -}) - -test_that("predictive_error has reasonable outputs", { - expect_equal(dim(predictive_error(fit1)), - c(ndraws(fit1), nobs(fit1))) -}) - -test_that("print has reasonable outputs", { - expect_output(SW(print(fit1)), "Group-Level Effects:") -}) - -test_that("prior_draws has reasonable outputs", { - prs1 <- prior_draws(fit1) - prior_names <- c( - "Intercept", "b", paste0("simo_moExp1[", 1:4, "]"), "bsp", - "bs", "sds_sAge_1", "b_sigma", "Intercept_sigma", "nu", - "sd_visit", "cor_visit" - ) - expect_equal(colnames(prs1), prior_names) - - prs2 <- prior_draws(fit1, variable = "b_Trt1") - expect_equal(dimnames(prs2), list(as.character(1:ndraws(fit1)), "b_Trt1")) - expect_equal(sort(prs1$b), sort(prs2$b_Trt)) - - # test default method - prs <- prior_draws(fit1$fit, variable = "^sd_visit", regex = TRUE) - expect_equal(names(prs), "prior_sd_visit") -}) - -test_that("prior_summary has reasonable outputs", { - expect_true(is(prior_summary(fit1), "brmsprior")) -}) - -test_that("ranef has reasonable outputs", { - ranef1 <- SM(ranef(fit1)) - expect_equal(dim(ranef1$visit), c(4, 4, 2)) - - ranef1 <- SM(ranef(fit1, pars = "Trt1")) - expect_equal(dimnames(ranef1$visit)[[3]], "Trt1") - - ranef1 <- SM(ranef(fit1, groups = "a")) - expect_equal(length(ranef1), 0L) - - ranef2 <- SM(ranef(fit2, summary = FALSE)) - expect_equal(dim(ranef2$patient), c(ndraws(fit2), 59, 2)) -}) - -test_that("residuals has reasonable outputs", { - res1 <- SW(residuals(fit1, type = "pearson", probs = c(0.65))) - expect_equal(dim(res1), c(nobs(fit1), 3)) - newdata <- cbind(epilepsy[1:10, ], Exp = rep(1:5, 2), volume = 0) - res2 <- residuals(fit1, newdata = newdata) - expect_equal(dim(res2), c(10, 4)) - newdata$visit <- rep(1:5, 2) - - res3 <- residuals(fit1, newdata = newdata, allow_new_levels = TRUE) - expect_equal(dim(res3), c(10, 4)) - - res4 <- residuals(fit2) - expect_equal(dim(res4), c(nobs(fit2), 4)) - - expect_error(residuals(fit4), "Predictive errors are not defined") - - res6 <- residuals(fit6) - expect_equal(dim(res6), c(nobs(fit6), 4, 2)) - expect_equal(dimnames(res6)[[3]], c("volume", "count")) -}) - -test_that("stancode has reasonable outputs", { - scode <- stancode(fit1) - expect_true(is.character(stancode(fit1))) - expect_match(stancode(fit1), "generated quantities") - expect_identical(scode, fit1$model) - - # test that stancode can be updated - scode <- stancode(fit2, threads = threading(1)) - expect_match(scode, "reduce_sum(partial_log_lik_lpmf,", fixed = TRUE) -}) - -test_that("standata has reasonable outputs", { - expect_equal(sort(names(standata(fit1))), - sort(c("N", "Y", "Kar", "Kma", "J_lag", "K", "X", "Ksp", "Imo", - "Xmo_1", "Jmo", "con_simo_1", "Z_1_1", "Z_1_2", "nb_1", - "knots_1", "Zs_1_1", "Ks", "Xs", "offsets", "K_sigma", - "X_sigma", "J_1", "N_1", "M_1", "NC_1", "prior_only")) - ) - expect_equal(sort(names(standata(fit2))), - sort(c("N", "Y", "weights", "C_1", "K_a", "X_a", "Z_1_a_1", - "K_b", "X_b", "Z_1_b_2", "J_1", "N_1", "M_1", - "NC_1", "prior_only")) - ) -}) - -test_that("mcmc_plot has reasonable outputs", { - expect_ggplot(mcmc_plot(fit1)) - expect_ggplot(mcmc_plot(fit1, variable = "^b", regex = TRUE)) - expect_ggplot(SM(mcmc_plot(fit1, type = "trace", variable = "^b_", regex = TRUE))) - expect_ggplot(mcmc_plot(fit1, type = "hist", variable = "^sd_", regex = TRUE)) - expect_ggplot(mcmc_plot(fit1, type = "dens")) - expect_ggplot(mcmc_plot(fit1, type = "scatter", variable = variables(fit1)[2:3])) - expect_ggplot(SW(mcmc_plot(fit1, type = "rhat", variable = "^b_", regex = TRUE))) - expect_ggplot(SW(mcmc_plot(fit1, type = "neff"))) - expect_ggplot(mcmc_plot(fit1, type = "acf")) - expect_silent(p <- mcmc_plot(fit1, type = "nuts_divergence")) - expect_error(mcmc_plot(fit1, type = "density"), "Invalid plot type") - expect_error(mcmc_plot(fit1, type = "hex"), - "Exactly 2 parameters must be selected") -}) - -test_that("summary has reasonable outputs", { - summary1 <- SW(summary(fit1, priors = TRUE)) - expect_true(is.data.frame(summary1$fixed)) - expect_equal(rownames(summary1$fixed), - c("Intercept", "sigma_Intercept", "Trt1", "Age", "volume", - "Trt1:Age", "sigma_Trt1", "sAge_1", "moExp")) - expect_equal(colnames(summary1$fixed), - c("Estimate", "Est.Error", "l-95% CI", - "u-95% CI", "Rhat", "Bulk_ESS", "Tail_ESS")) - expect_equal(rownames(summary1$random$visit), - c("sd(Intercept)", "sd(Trt1)", "cor(Intercept,Trt1)")) - expect_output(print(summary1), "Population-Level Effects:") - expect_output(print(summary1), "Priors:") - - summary5 <- SW(summary(fit5, robust = TRUE)) - expect_output(print(summary5), "sigma1") - expect_output(print(summary5), "theta1") - - summary6 <- SW(summary(fit6)) - expect_output(print(summary6), "sdgp") -}) - -test_that("update has reasonable outputs", { - # Do not actually refit the model as is causes CRAN checks to fail. - # Some tests are commented out as they fail when updating Stan code - # of internal example models because of Stan code mismatches. Refitting - # these example models is slow especially when done repeatedly and - # leads the git repo to blow up eventually due the size of the models. - up <- update(fit1, testmode = TRUE) - expect_true(is(up, "brmsfit")) - - new_data <- data.frame( - Age = rnorm(18), visit = rep(c(3, 2, 4), 6), - Trt = rep(0:1, 9), count = rep(c(5, 17, 28), 6), - patient = 1, Exp = 4, volume = 0 - ) - up <- update(fit1, newdata = new_data, save_pars = save_pars(group = FALSE), - testmode = TRUE) - expect_true(is(up, "brmsfit")) - expect_equal(attr(up$data, "data_name"), "new_data") - # expect_equal(attr(up$ranef, "levels")$visit, c("2", "3", "4")) - # expect_true("r_1_1" %in% up$exclude) - expect_error(update(fit1, data = new_data), "use argument 'newdata'") - - up <- update(fit1, formula = ~ . + I(exp(Age)), testmode = TRUE, - prior = set_prior("normal(0,10)")) - expect_true(is(up, "brmsfit")) - up <- update(fit1, ~ . - Age + factor(Age), testmode = TRUE) - expect_true(is(up, "brmsfit")) - - up <- update(fit1, formula = ~ . + I(exp(Age)), newdata = new_data, - sample_prior = FALSE, testmode = TRUE) - expect_true(is(up, "brmsfit")) - expect_error(update(fit1, formula. = ~ . + wrong_var), - "New variables found: 'wrong_var'") - - up <- update(fit1, save_pars = save_pars(group = FALSE), testmode = TRUE) - expect_true(is(up, "brmsfit")) - # expect_true("r_1_1" %in% up$exclude) - up <- update(fit3, save_pars = save_pars(latent = FALSE), testmode = TRUE) - expect_true(is(up, "brmsfit")) - # expect_true("Xme_1" %in% up$exclude) - - up <- update(fit2, algorithm = "fullrank", testmode = TRUE) - expect_true(is(up, "brmsfit")) - # expect_equal(up$algorithm, "fullrank") - up <- update(fit2, formula. = bf(. ~ ., a + b ~ 1, nl = TRUE), - testmode = TRUE) - expect_true(is(up, "brmsfit")) - up <- update(fit2, formula. = bf(count ~ a + b, nl = TRUE), testmode = TRUE) - expect_true(is(up, "brmsfit")) - up <- update(fit3, family = acat(), testmode = TRUE) - expect_true(is(up, "brmsfit")) - up <- update(fit3, bf(~., family = acat()), testmode = TRUE) - expect_true(is(up, "brmsfit")) -}) - -test_that("VarCorr has reasonable outputs", { - vc <- VarCorr(fit1) - expect_equal(names(vc), c("visit")) - Names <- c("Intercept", "Trt1") - expect_equal(dimnames(vc$visit$cov)[c(1, 3)], list(Names, Names)) - vc <- VarCorr(fit2) - expect_equal(names(vc), c("patient")) - expect_equal(dim(vc$patient$cor), c(2, 4, 2)) - vc <- VarCorr(fit2, summary = FALSE) - expect_equal(dim(vc$patient$cor), c(ndraws(fit2), 2, 2)) - expect_equal(dim(VarCorr(fit6)$residual__$sd), c(1, 4)) - vc <- VarCorr(fit5) - expect_equal(dim(vc$patient$sd), c(2, 4)) -}) - -test_that("variables has reasonable ouputs", { - expect_true(all( - c("b_Intercept", "bsp_moExp", "ar[1]", "cor_visit__Intercept__Trt1", - "nu", "simo_moExp1[2]", "r_visit[4,Trt1]", "s_sAge_1[8]", - "prior_sd_visit", "prior_cor_visit", "lp__") %in% - variables(fit1) - )) - expect_true(all( - c("b_a_Intercept", "b_b_Age", "sd_patient__b_Intercept", - "cor_patient__a_Intercept__b_Intercept", - "r_patient__a[1,Intercept]", "r_patient__b[4,Intercept]", - "prior_b_a") %in% - variables(fit2) - )) - expect_true(all( - c("lscale_volume_gpAgeTrt0", "lscale_volume_gpAgeTrt1") %in% - variables(fit6) - )) - expect_equal(variables(fit3), SW(parnames(fit3))) -}) - -test_that("vcov has reasonable outputs", { - expect_equal(dim(vcov(fit1)), c(9, 9)) - expect_equal(dim(vcov(fit1, cor = TRUE)), c(9, 9)) -}) - -test_that("waic has reasonable outputs", { - waic1 <- SW(WAIC(fit1)) - expect_true(is.numeric(waic1$estimates)) - # fails on MKL for unknown reasons - # expect_equal(waic1, SW(waic(fit1))) - - fit1 <- SW(add_criterion(fit1, "waic")) - expect_true(is.numeric(fit1$criteria$waic$estimates)) - # fails on MKL for unknown reasons - # expect_equal(waic(fit1), fit1$criteria$waic) - - waic_compare <- SW(waic(fit1, fit1)) - expect_equal(length(waic_compare$loos), 2) - expect_equal(dim(waic_compare$ic_diffs__), c(1, 2)) - waic2 <- SW(waic(fit2)) - expect_true(is.numeric(waic2$estimates)) - waic_pointwise <- SW(waic(fit2, pointwise = TRUE)) - expect_equal(waic2, waic_pointwise) - expect_warning(compare_ic(waic1, waic2), - "Model comparisons are likely invalid") - waic4 <- SW(waic(fit4)) - expect_true(is.numeric(waic4$estimates)) -}) - -test_that("diagnostic convenience functions have reasonable outputs", { - expect_true(is(log_posterior(fit1), "data.frame")) - expect_true(is(nuts_params(fit1), "data.frame")) - expect_true(is(rhat(fit1), "numeric")) - expect_true(is(neff_ratio(fit1), "numeric")) -}) - -test_that("contrasts of grouping factors are not stored #214", { - expect_true(is.null(attr(fit1$data$patient, "contrasts"))) -}) +context("Tests for brmsfit methods") + +# to reduce testing time on CRAN substantially +skip_on_cran() + +expect_range <- function(object, lower = -Inf, upper = Inf, ...) { + testthat::expect_true(all(object >= lower & object <= upper), ...) +} +expect_ggplot <- function(object, ...) { + testthat::expect_true(is(object, "ggplot"), ...) +} + +SM <- suppressMessages +SW <- suppressWarnings + +fit1 <- rename_pars(brms:::brmsfit_example1) +fit2 <- rename_pars(brms:::brmsfit_example2) +fit3 <- rename_pars(brms:::brmsfit_example3) +fit4 <- rename_pars(brms:::brmsfit_example4) +fit5 <- rename_pars(brms:::brmsfit_example5) +fit6 <- rename_pars(brms:::brmsfit_example6) + +# test S3 methods in alphabetical order +test_that("as_draws and friends have resonable outputs", { + draws <- as_draws(fit1, variable = "b_Intercept") + expect_s3_class(draws, "draws_list") + expect_equal(variables(draws), "b_Intercept") + expect_equal(ndraws(draws), ndraws(fit1)) + + draws <- SM(as_draws_matrix(fit1)) + expect_s3_class(draws, "draws_matrix") + expect_equal(ndraws(draws), ndraws(fit1)) + + draws <- as_draws_array(fit2) + expect_s3_class(draws, "draws_array") + expect_equal(niterations(draws), ndraws(fit2)) + + draws <- as_draws_df(fit2, variable = "^b_", regex = TRUE) + expect_s3_class(draws, "draws_df") + expect_true(all(grepl("^b_", variables(draws)))) + + draws <- as_draws_list(fit2) + expect_s3_class(draws, "draws_list") + expect_equal(nchains(draws), nchains(fit2)) + + draws <- as_draws_rvars(fit3) + expect_s3_class(draws, "draws_rvars") + expect_equal(ndraws(draws), ndraws(fit3)) + expect_true(length(variables(draws)) > 0) +}) + +test_that("as.data.frame has reasonable ouputs", { + draws <- as.data.frame(fit1) + expect_true(is(draws, "data.frame")) + expect_equal(dim(draws), c(ndraws(fit1), length(variables(fit1)))) + + # deprecated 'pars' argument still works + expect_warning( + draws <- as.data.frame(fit1, pars = "^b_"), + "'pars' is deprecated" + ) + expect_s3_class(draws, "data.frame") + expect_true(ncol(draws) > 0) + + # deprecated 'subset' argument still works + expect_warning( + draws <- as.data.frame(fit1, subset = 10:20), + "'subset' is deprecated" + ) + expect_s3_class(draws, "data.frame") + expect_equal(nrow(draws), 11) +}) + +test_that("as.matrix has reasonable ouputs", { + draws <- as.matrix(fit1, iteration = 1:10) + expect_true(is(draws, "matrix")) + expect_equal(dim(draws), c(10, length(variables(fit1)))) +}) + +test_that("as.array has reasonable ouputs", { + draws <- as.array(fit1) + expect_true(is.array(draws)) + chains <- fit1$fit@sim$chains + ps_dim <- c(niterations(fit1), chains, length(variables(fit1))) + expect_equal(dim(draws), ps_dim) + + draws <- as.array(fit1, chain = 1) + expect_true(is.array(draws)) + ps_dim <- c(niterations(fit1), 1, length(variables(fit1))) + expect_equal(dim(draws), ps_dim) +}) + +test_that("as.mcmc has reasonable ouputs", { + chains <- fit1$fit@sim$chains + mc <- SW(as.mcmc(fit1)) + expect_equal(length(mc), chains) + expect_equal(dim(mc[[1]]), c(ndraws(fit1) / chains, length(variables(fit1)))) + mc <- SW(as.mcmc(fit1, combine_chains = TRUE)) + expect_equal(dim(mc), c(ndraws(fit1), length(variables(fit1)))) + # test assumes thin = 1 + expect_equal(dim(SW(as.mcmc(fit1, inc_warmup = TRUE)[[1]])), + c(fit1$fit@sim$iter, length(variables(fit1)))) +}) + +test_that("autocor has reasonable ouputs", { + expect_true(is.null(SW(autocor(fit1)))) + expect_true(is.null(SW(autocor(fit6, resp = "count")))) +}) + +test_that("bayes_R2 has reasonable ouputs", { + fit1 <- add_criterion(fit1, "bayes_R2") + R2 <- bayes_R2(fit1, summary = FALSE) + expect_equal(dim(R2), c(ndraws(fit1), 1)) + R2 <- bayes_R2(fit2, newdata = model.frame(fit2)[1:5, ], re_formula = NA) + expect_equal(dim(R2), c(1, 4)) + R2 <- bayes_R2(fit6) + expect_equal(dim(R2), c(2, 4)) +}) + +test_that("bayes_factor has reasonable ouputs", { + # don't test for now as it requires calling Stan's C++ code +}) + +test_that("bridge_sampler has reasonable ouputs", { + # don't test for now as it requires calling Stan's C++ code +}) + +test_that("coef has reasonable ouputs", { + coef1 <- SM(coef(fit1)) + expect_equal(dim(coef1$visit), c(4, 4, 9)) + coef1 <- SM(coef(fit1, summary = FALSE)) + expect_equal(dim(coef1$visit), c(ndraws(fit1), 4, 9)) + coef2 <- SM(coef(fit2)) + expect_equal(dim(coef2$patient), c(59, 4, 4)) + coef4 <- SM(coef(fit4)) + expect_equal(dim(coef4$subject), c(10, 4, 8)) +}) + +test_that("combine_models has reasonable ouputs", { + expect_equal(ndraws(combine_models(fit1, fit1)), ndraws(fit1) * 2) +}) + +test_that("conditional_effects has reasonable ouputs", { + me <- conditional_effects(fit1, resp = "count") + expect_equal(nrow(me[[2]]), 100) + meplot <- plot(me, points = TRUE, rug = TRUE, + ask = FALSE, plot = FALSE) + expect_ggplot(meplot[[1]]) + + me <- conditional_effects(fit1, "Trt", select_points = 0.1) + expect_lt(nrow(attr(me[[1]], "points")), nobs(fit1)) + + me <- conditional_effects(fit1, "volume:Age", surface = TRUE, + resolution = 15, too_far = 0.2) + meplot <- plot(me, plot = FALSE) + expect_ggplot(meplot[[1]]) + meplot <- plot(me, stype = "raster", plot = FALSE) + expect_ggplot(meplot[[1]]) + + me <- conditional_effects(fit1, "Age", spaghetti = TRUE, ndraws = 10) + expect_equal(nrow(attr(me$Age, "spaghetti")), 1000) + meplot <- plot(me, plot = FALSE) + expect_ggplot(meplot[[1]]) + expect_error( + conditional_effects(fit1, "Age", spaghetti = TRUE, surface = TRUE), + "Cannot use 'spaghetti' and 'surface' at the same time" + ) + + me <- conditional_effects(fit1, effects = "Age:visit", re_formula = NULL) + exp_nrow <- 100 * length(unique(fit1$data$visit)) + expect_equal(nrow(me[[1]]), exp_nrow) + + mdata = data.frame( + Age = c(-0.3, 0, 0.3), + count = c(10, 20, 30), + Exp = c(1, 3, 5) + ) + exp_nrow <- nrow(mdata) * 100 + me <- conditional_effects(fit1, effects = "Age", conditions = mdata) + expect_equal(nrow(me[[1]]), exp_nrow) + + mdata$visit <- 1:3 + me <- conditional_effects(fit1, re_formula = NULL, conditions = mdata) + expect_equal(nrow(me$Age), exp_nrow) + + me <- conditional_effects( + fit1, "Age:Trt", int_conditions = list(Age = rnorm(5)) + ) + expect_equal(nrow(me[[1]]), 10) + me <- conditional_effects( + fit1, "Age:Trt", int_conditions = list(Age = quantile) + ) + expect_equal(nrow(me[[1]]), 10) + + expect_error(conditional_effects(fit1, effects = "Trtc"), + "All specified effects are invalid for this model") + expect_warning(conditional_effects(fit1, effects = c("Trtc", "Trt")), + "Some specified effects are invalid for this model") + expect_error(conditional_effects(fit1, effects = "Trtc:a:b"), + "please use the 'conditions' argument") + + mdata$visit <- NULL + mdata$Exp <- NULL + mdata$patient <- 1 + expect_equal(nrow(conditional_effects(fit2)[[2]]), 100) + me <- conditional_effects(fit2, re_formula = NULL, conditions = mdata) + expect_equal(nrow(me$Age), exp_nrow) + + expect_warning( + me4 <- conditional_effects(fit4), + "Predictions are treated as continuous variables" + ) + expect_true(is(me4, "brms_conditional_effects")) + me4 <- conditional_effects(fit4, "x2", categorical = TRUE) + expect_true(is(me4, "brms_conditional_effects")) + + me5 <- conditional_effects(fit5) + expect_true(is(me5, "brms_conditional_effects")) + + me6 <- conditional_effects(fit6, ndraws = 40) + expect_true(is(me6, "brms_conditional_effects")) +}) + +test_that("plot of conditional_effects has reasonable outputs", { + SW(ggplot2::theme_set(theme_black())) + N <- 90 + marg_results <- data.frame( + effect1__ = rpois(N, 20), + effect2__ = factor(rep(1:3, each = N / 3)), + estimate__ = rnorm(N, sd = 5), + se__ = rt(N, df = 10), + cond__ = rep(1:2, each = N / 2), + cats__ = factor(rep(1:3, each = N / 3)) + ) + marg_results[["lower__"]] <- marg_results$estimate__ - 2 + marg_results[["upper__"]] <- marg_results$estimate__ + 2 + marg_results <- list(marg_results[order(marg_results$effect1__), ]) + class(marg_results) <- "brms_conditional_effects" + attr(marg_results[[1]], "response") <- "count" + # test with 1 numeric predictor + attr(marg_results[[1]], "effects") <- "P1" + marg_plot <- plot(marg_results, plot = FALSE) + expect_ggplot(marg_plot[[1]]) + # test with 1 categorical predictor + attr(marg_results[[1]], "effects") <- "P2" + marg_plot <- plot(marg_results, plot = FALSE) + expect_ggplot(marg_plot[[1]]) + # test with 1 numeric and 1 categorical predictor + attr(marg_results[[1]], "effects") <- c("P1", "P2") + marg_plot <- plot(marg_results, plot = FALSE) + expect_ggplot(marg_plot[[1]]) + # test ordinal raster plot + attr(marg_results[[1]], "effects") <- c("P1", "cats__") + attr(marg_results[[1]], "ordinal") <- TRUE + marg_plot <- plot(marg_results, plot = FALSE) + expect_ggplot(marg_plot[[1]]) +}) + +test_that("conditional_smooths has reasonable ouputs", { + ms <- conditional_smooths(fit1) + expect_equal(nrow(ms[[1]]), 100) + expect_true(is(ms, "brms_conditional_effects")) + + ms <- conditional_smooths(fit1, spaghetti = TRUE, ndraws = 10) + expect_equal(nrow(attr(ms[[1]], "spaghetti")), 1000) + + expect_error(conditional_smooths(fit1, smooths = "s3"), + "No valid smooth terms found in the model") + expect_error(conditional_smooths(fit2), + "No valid smooth terms found in the model") +}) + +test_that("family has reasonable ouputs", { + expect_is(family(fit1), "brmsfamily") + expect_is(family(fit6, resp = "count"), "brmsfamily") + expect_output(print(family(fit1), links = TRUE), "student.*log.*logm1") + expect_output(print(family(fit5)), "Mixture.*gaussian.*exponential") +}) + +test_that("fitted has reasonable outputs", { + skip_on_cran() + + fi <- fitted(fit1) + expect_equal(dim(fi), c(nobs(fit1), 4)) + expect_equal(colnames(fi), c("Estimate", "Est.Error", "Q2.5", "Q97.5")) + + newdata <- data.frame( + Age = c(0, -0.2), visit = c(1, 4), Trt = c(0, 1), + count = c(20, 13), patient = c(1, 42), Exp = c(2, 4), + volume = 0 + ) + fi <- fitted(fit1, newdata = newdata) + expect_equal(dim(fi), c(2, 4)) + newdata$visit <- c(1, 6) + fi <- fitted(fit1, newdata = newdata, + allow_new_levels = TRUE) + expect_equal(dim(fi), c(2, 4)) + + # fitted values with new_levels + newdata <- data.frame( + Age = 0, visit = paste0("a", 1:100), Trt = 0, + count = 20, patient = 1, Exp = 2, volume = 0 + ) + fi <- fitted(fit1, newdata = newdata, allow_new_levels = TRUE, + sample_new_levels = "old_levels", ndraws = 10) + expect_equal(dim(fi), c(100, 4)) + fi <- fitted(fit1, newdata = newdata, allow_new_levels = TRUE, + sample_new_levels = "gaussian", ndraws = 1) + expect_equal(dim(fi), c(100, 4)) + + # fitted values of auxiliary parameters + newdata <- data.frame( + Age = 0, visit = c("a", "b"), Trt = 0, + count = 20, patient = 1, Exp = 2, volume = 0 + ) + fi <- fitted(fit1, dpar = "sigma") + expect_equal(dim(fi), c(nobs(fit1), 4)) + expect_true(all(fi > 0)) + fi_lin <- fitted(fit1, dpar = "sigma", scale = "linear") + expect_equal(dim(fi_lin), c(nobs(fit1), 4)) + expect_true(!isTRUE(all.equal(fi, fi_lin))) + expect_error(fitted(fit1, dpar = "inv"), + "Invalid argument 'dpar'") + + fi <- fitted(fit2) + expect_equal(dim(fi), c(nobs(fit2), 4)) + fi <- fitted(fit2, newdata = newdata, + allow_new_levels = TRUE) + expect_equal(dim(fi), c(2, 4)) + fi <- fitted(fit2, dpar = "shape") + expect_equal(dim(fi), c(nobs(fit2), 4)) + expect_equal(fi[1, ], fi[2, ]) + fi <- fitted(fit2, nlpar = "a") + expect_equal(dim(fi), c(nobs(fit2), 4)) + + fi <- fitted(fit3, newdata = fit3$data[1:10, ]) + expect_equal(dim(fi), c(10, 4)) + + fi <- fitted(fit4) + expect_equal(dim(fi), c(nobs(fit4), 4, 4)) + fi <- fitted(fit4, newdata = fit4$data[1, ]) + expect_equal(dim(fi), c(1, 4, 4)) + fi <- fitted(fit4, newdata = fit4$data[1, ], scale = "linear") + expect_equal(dim(fi), c(1, 4, 3)) + + fi <- fitted(fit5) + expect_equal(dim(fi), c(nobs(fit5), 4)) + + fi <- fitted(fit6) + expect_equal(dim(fi), c(nobs(fit6), 4, 2)) + expect_equal(dimnames(fi)[[3]], c("volume", "count")) +}) + +test_that("fixef has reasonable ouputs", { + fixef1 <- SM(fixef(fit1)) + expect_equal(rownames(fixef1), + c("Intercept", "sigma_Intercept", "Trt1", "Age", "volume", + "Trt1:Age", "sigma_Trt1", "sAge_1", "moExp") + ) + fixef1 <- SM(fixef(fit1, pars = c("Age", "sAge_1"))) + expect_equal(rownames(fixef1), c("Age", "sAge_1")) +}) + +test_that("formula has reasonable ouputs", { + expect_true(is.brmsformula(formula(fit1))) +}) + +test_that("hypothesis has reasonable ouputs", { + hyp <- hypothesis(fit1, c("Age > Trt1", "Trt1:Age = -1")) + expect_equal(dim(hyp$hypothesis), c(2, 8)) + expect_output(print(hyp), "(Age)-(Trt1) > 0", fixed = TRUE) + expect_ggplot(plot(hyp, plot = FALSE)[[1]]) + + hyp <- hypothesis(fit1, "Intercept = 0", class = "sd", group = "visit") + expect_true(is.numeric(hyp$hypothesis$Evid.Ratio[1])) + expect_output(print(hyp), "class sd_visit:", fixed = TRUE) + expect_ggplot(plot(hyp, ignore_prior = TRUE, plot = FALSE)[[1]]) + + hyp <- hypothesis(fit1, "0 > r_visit[4,Intercept]", class = "", alpha = 0.01) + expect_equal(dim(hyp$hypothesis), c(1, 8)) + expect_output(print(hyp, chars = NULL), "r_visit[4,Intercept]", fixed = TRUE) + expect_output(print(hyp), "99%-CI", fixed = TRUE) + + hyp <- hypothesis( + fit1, c("Intercept = 0", "Intercept + exp(Trt1) = 0"), + group = "visit", scope = "coef" + ) + expect_equal(dim(hyp$hypothesis), c(8, 9)) + expect_equal(hyp$hypothesis$Group[1], factor(1, levels = 1:4)) + + expect_error(hypothesis(fit1, "Intercept > x"), fixed = TRUE, + "cannot be found in the model: \n'b_x'") + expect_error(hypothesis(fit1, 1), + "Argument 'hypothesis' must be a character vector") + expect_error(hypothesis(fit2, "b_Age = 0", alpha = 2), + "Argument 'alpha' must be a single value in [0,1]", + fixed = TRUE) + expect_error(hypothesis(fit3, "b_Age x 0"), + "Every hypothesis must be of the form 'left (= OR < OR >) right'", + fixed = TRUE) + + # test hypothesis.default method + hyp <- hypothesis(as.data.frame(fit3), "bsp_meAgeAgeSD > sigma") + expect_equal(dim(hyp$hypothesis), c(1, 8)) + hyp <- hypothesis(fit3$fit, "bsp_meAgeAgeSD > sigma") + expect_equal(dim(hyp$hypothesis), c(1, 8)) +}) + +test_that("launch_shinystan has reasonable ouputs", { + # requires running shiny which is not reasonable in automated tests +}) + +test_that("log_lik has reasonable ouputs", { + expect_equal(dim(log_lik(fit1)), c(ndraws(fit1), nobs(fit1))) + expect_equal(dim(logLik(fit1)), c(ndraws(fit1), nobs(fit1))) + expect_equal(dim(log_lik(fit2)), c(ndraws(fit2), nobs(fit2))) +}) + +test_that("loo has reasonable outputs", { + skip_on_cran() + + loo1 <- SW(LOO(fit1, cores = 1)) + expect_true(is.numeric(loo1$estimates)) + expect_output(print(loo1), "looic") + + loo_compare1 <- SW(loo(fit1, fit1, cores = 1)) + expect_equal(names(loo_compare1$loos), c("fit1", "fit1")) + expect_equal(dim(loo_compare1$ic_diffs__), c(1, 2)) + expect_output(print(loo_compare1), "'fit1':") + expect_is(loo_compare1$diffs, "compare.loo") + + loo2 <- SW(loo(fit2, cores = 1)) + expect_true(is.numeric(loo2$estimates)) + + loo3 <- SW(loo(fit3, cores = 1)) + expect_true(is.numeric(loo3$estimates)) + loo3 <- SW(loo(fit3, pointwise = TRUE, cores = 1)) + expect_true(is.numeric(loo3$estimates)) + + loo4 <- SW(loo(fit4, cores = 1)) + expect_true(is.numeric(loo4$estimates)) + + # fails because of too small effective sample size + # loo5 <- SW(loo(fit5, cores = 1)) + # expect_true(is.numeric(loo5$estimates)) + + loo6_1 <- SW(loo(fit6, cores = 1)) + expect_true(is.numeric(loo6_1$estimates)) + loo6_2 <- SW(loo(fit6, cores = 1, newdata = fit6$data)) + expect_true(is.numeric(loo6_2$estimates)) + loo_compare <- loo_compare(loo6_1, loo6_2) + expect_range(loo_compare[2, 1], -1, 1) +}) + +test_that("loo_subsample has reasonable outputs", { + skip_on_cran() + + loo2 <- SW(loo_subsample(fit2, observations = 50)) + expect_true(is.numeric(loo2$estimates)) + expect_equal(nrow(loo2$pointwise), 50) + expect_output(print(loo2), "looic") +}) + +test_that("loo_R2 has reasonable outputs", { + skip_on_cran() + + R2 <- SW(loo_R2(fit1)) + expect_equal(dim(R2), c(1, 4)) + + R2 <- SW(loo_R2(fit2, summary = FALSE)) + expect_equal(dim(R2), c(ndraws(fit1), 1)) +}) + +test_that("loo_linpred has reasonable outputs", { + skip_on_cran() + + llp <- SW(loo_linpred(fit1)) + expect_equal(length(llp), nobs(fit1)) + expect_error(loo_linpred(fit4), "Method 'loo_linpred'") + llp <- SW(loo_linpred(fit2, scale = "response", type = "var")) + expect_equal(length(llp), nobs(fit2)) +}) + +test_that("loo_predict has reasonable outputs", { + skip_on_cran() + + llp <- SW(loo_predict(fit1)) + expect_equal(length(llp), nobs(fit1)) + + newdata <- data.frame( + Age = 0, visit = c("a", "b"), Trt = 0, + count = 20, patient = 1, Exp = 2, volume = 0 + ) + llp <- SW(loo_predict( + fit1, newdata = newdata, + type = "quantile", probs = c(0.25, 0.75), + allow_new_levels = TRUE + )) + expect_equal(dim(llp), c(2, nrow(newdata))) + llp <- SW(loo_predict(fit4)) + expect_equal(length(llp), nobs(fit4)) +}) + +test_that("loo_predictive_interval has reasonable outputs", { + skip_on_cran() + + llp <- SW(loo_predictive_interval(fit3)) + expect_equal(dim(llp), c(nobs(fit3), 2)) +}) + +test_that("loo_model_weights has reasonable outputs", { + skip_on_cran() + + llw <- SW(loo_model_weights(fit1, fit1)) + expect_is(llw[1:2], "numeric") + expect_equal(names(llw), c("fit1", "fit1")) +}) + +test_that("model.frame has reasonable ouputs", { + expect_equal(model.frame(fit1), fit1$data) +}) + +test_that("model_weights has reasonable ouputs", { + mw <- model_weights(fit1, fit1, weights = "waic") + expect_equal(names(mw), c("fit1", "fit1")) + # fails with MKL on CRAN for unknown reasons + # expect_equal(mw, setNames(c(0.5, 0.5), c("fit1", "fit1"))) +}) + +test_that("ndraws and friends have reasonable ouputs", { + expect_equal(ndraws(fit1), 50) + expect_equal(nchains(fit1), 1) + expect_equal(niterations(fit1), 50) +}) + +test_that("ngrps has reasonable ouputs", { + expect_equal(ngrps(fit1), list(visit = 4)) + expect_equal(ngrps(fit2), list(patient = 59)) +}) + +test_that("nobs has reasonable ouputs", { + expect_equal(nobs(fit1), nrow(epilepsy)) +}) + +test_that("nsamples has reasonable ouputs", { + expect_equal(SW(nsamples(fit1)), 50) + expect_equal(SW(nsamples(fit1, subset = 10:1)), 10) + expect_equal(SW(nsamples(fit1, incl_warmup = TRUE)), 200) +}) + +test_that("pairs has reasonable outputs", { + expect_s3_class(SW(pairs(fit1, variable = variables(fit1)[1:3])), + "bayesplot_grid") +}) + +test_that("plot has reasonable outputs", { + expect_silent(p <- plot(fit1, plot = FALSE)) + expect_silent(p <- plot(fit1, variable = "^b", regex = TRUE, plot = FALSE)) + expect_silent(p <- plot(fit1, variable = "^sd", regex = TRUE, plot = FALSE)) + expect_error(plot(fit1, variable = "123")) +}) + +test_that("post_prob has reasonable ouputs", { + # only test error messages for now + expect_error(post_prob(fit1, fit2, model_names = "test1"), + "Number of model names is not equal to the number of models") +}) + +test_that("posterior_average has reasonable outputs", { + pnames <- c("b_Age", "nu") + draws <- posterior_average(fit1, fit1, variable = pnames, weights = c(0.3, 0.7)) + expect_equal(dim(draws), c(ndraws(fit1), 2)) + expect_equal(names(draws), pnames) + + weights <- rexp(3) + draws <- brms:::SW(posterior_average( + fit1, fit2, fit3, variable = "nu", weights = rexp(3), + missing = 1, ndraws = 10 + )) + expect_equal(dim(draws), c(10, 1)) + expect_equal(names(draws), "nu") +}) + +test_that("posterior_samples has reasonable outputs", { + draws <- SW(posterior_samples(fit1)) + expect_equal(dim(draws), c(ndraws(fit1), length(variables(fit1)))) + expect_equal(names(draws), variables(fit1)) + expect_equal(names(SW(posterior_samples(fit1, pars = "^b_"))), + c("b_Intercept", "b_sigma_Intercept", "b_Trt1", + "b_Age", "b_volume", "b_Trt1:Age", "b_sigma_Trt1")) + + # test default method + draws <- SW(posterior_samples(fit1$fit, "^b_Intercept$")) + expect_equal(dim(draws), c(ndraws(fit1), 1)) +}) + +test_that("posterior_summary has reasonable outputs", { + draws <- posterior_summary(fit1, variable = "^b_", regex = TRUE) + expect_equal(dim(draws), c(7, 4)) +}) + +test_that("posterior_interval has reasonable outputs", { + expect_equal(dim(posterior_interval(fit1)), + c(length(variables(fit1)), 2)) +}) + +test_that("posterior_predict has reasonable outputs", { + expect_equal(dim(posterior_predict(fit1)), + c(ndraws(fit1), nobs(fit1))) +}) + +test_that("posterior_linpred has reasonable outputs", { + expect_equal(dim(posterior_linpred(fit1)), + c(ndraws(fit1), nobs(fit1))) +}) + +test_that("pp_average has reasonable outputs", { + ppa <- pp_average(fit1, fit1, weights = "waic") + expect_equal(dim(ppa), c(nobs(fit1), 4)) + ppa <- pp_average(fit1, fit1, weights = c(1, 4)) + expect_equal(attr(ppa, "weights"), c(fit1 = 0.2, fit1 = 0.8)) + ns <- c(fit1 = ndraws(fit1) / 5, fit1 = 4 * ndraws(fit1) / 5) + expect_equal(attr(ppa, "ndraws"), ns) +}) + +test_that("pp_check has reasonable outputs", { + expect_ggplot(pp_check(fit1)) + expect_ggplot(pp_check(fit1, newdata = fit1$data[1:100, ])) + expect_ggplot(pp_check(fit1, "stat", ndraws = 5)) + expect_ggplot(pp_check(fit1, "error_binned")) + pp <- pp_check(fit1, "ribbon_grouped", group = "visit", x = "Age") + expect_ggplot(pp) + pp <- pp_check(fit1, type = "violin_grouped", + group = "visit", newdata = fit1$data[1:100, ]) + expect_ggplot(pp) + + pp <- SW(pp_check(fit1, type = "loo_pit", cores = 1)) + expect_ggplot(pp) + + # ppd plots work + expect_ggplot(pp_check(fit1, prefix = "ppd")) + + expect_ggplot(pp_check(fit3)) + expect_ggplot(pp_check(fit2, "ribbon", x = "Age")) + expect_error(pp_check(fit2, "ribbon", x = "x"), + "Variable 'x' could not be found in the data") + expect_error(pp_check(fit1, "wrong_type")) + expect_error(pp_check(fit2, "violin_grouped"), "group") + expect_error(pp_check(fit1, "stat_grouped", group = "g"), + "Variable 'g' could not be found in the data") + expect_ggplot(pp_check(fit4)) + expect_ggplot(pp_check(fit5)) + expect_error(pp_check(fit4, "error_binned"), + "Type 'error_binned' is not available") +}) + +test_that("posterior_epred has reasonable outputs", { + expect_equal(dim(posterior_epred(fit1)), c(ndraws(fit1), nobs(fit1))) +}) + +test_that("pp_mixture has reasonable outputs", { + expect_equal(dim(pp_mixture(fit5)), c(nobs(fit5), 4, 2)) + expect_error(pp_mixture(fit1), + "Method 'pp_mixture' can only be applied to mixture models" + ) +}) + +test_that("predict has reasonable outputs", { + pred <- predict(fit1) + expect_equal(dim(pred), c(nobs(fit1), 4)) + expect_equal(colnames(pred), c("Estimate", "Est.Error", "Q2.5", "Q97.5")) + pred <- predict(fit1, ndraws = 10, probs = c(0.2, 0.5, 0.8)) + expect_equal(dim(pred), c(nobs(fit1), 5)) + + newdata <- data.frame( + Age = c(0, -0.2), visit = c(1, 4), Trt = c(1, 0), + count = c(2, 10), patient = c(1, 42), Exp = c(1, 2), + volume = 0 + ) + pred <- predict(fit1, newdata = newdata) + expect_equal(dim(pred), c(2, 4)) + + newdata$visit <- c(1, 6) + pred <- predict(fit1, newdata = newdata, allow_new_levels = TRUE) + expect_equal(dim(pred), c(2, 4)) + + # predict NA responses in ARMA models + df <- fit1$data[1:10, ] + df$count[8:10] <- NA + pred <- predict(fit1, newdata = df, ndraws = 1) + expect_true(!anyNA(pred[, "Estimate"])) + + pred <- predict(fit2) + expect_equal(dim(pred), c(nobs(fit2), 4)) + + pred <- predict(fit2, newdata = newdata, allow_new_levels = TRUE) + expect_equal(dim(pred), c(2, 4)) + + # check if grouping factors with a single level are accepted + newdata$patient <- factor(2) + pred <- predict(fit2, newdata = newdata) + expect_equal(dim(pred), c(2, 4)) + + pred <- predict(fit4) + expect_equal(dim(pred), c(nobs(fit4), 4)) + expect_equal(colnames(pred), paste0("P(Y = ", 1:4, ")")) + pred <- predict(fit4, newdata = fit4$data[1, ]) + expect_equal(dim(pred), c(1, 4)) + + pred <- predict(fit5) + expect_equal(dim(pred), c(nobs(fit5), 4)) + newdata <- fit5$data[1:10, ] + newdata$patient <- "a" + pred <- predict(fit5, newdata, allow_new_levels = TRUE, + sample_new_levels = "old_levels") + expect_equal(dim(pred), c(10, 4)) + pred <- predict(fit5, newdata, allow_new_levels = TRUE, + sample_new_levels = "gaussian") + expect_equal(dim(pred), c(10, 4)) +}) + +test_that("predictive_error has reasonable outputs", { + expect_equal(dim(predictive_error(fit1)), + c(ndraws(fit1), nobs(fit1))) +}) + +test_that("print has reasonable outputs", { + expect_output(SW(print(fit1)), "Group-Level Effects:") +}) + +test_that("prior_draws has reasonable outputs", { + prs1 <- prior_draws(fit1) + prior_names <- c( + "Intercept", "b", paste0("simo_moExp1[", 1:4, "]"), "bsp", + "bs", "sds_sAge_1", "b_sigma", "Intercept_sigma", "nu", + "sd_visit", "cor_visit" + ) + expect_equal(colnames(prs1), prior_names) + + prs2 <- prior_draws(fit1, variable = "b_Trt1") + expect_equal(dimnames(prs2), list(as.character(1:ndraws(fit1)), "b_Trt1")) + expect_equal(sort(prs1$b), sort(prs2$b_Trt)) + + # test default method + prs <- prior_draws(fit1$fit, variable = "^sd_visit", regex = TRUE) + expect_equal(names(prs), "prior_sd_visit") +}) + +test_that("prior_summary has reasonable outputs", { + expect_true(is(prior_summary(fit1), "brmsprior")) +}) + +test_that("ranef has reasonable outputs", { + ranef1 <- SM(ranef(fit1)) + expect_equal(dim(ranef1$visit), c(4, 4, 2)) + + ranef1 <- SM(ranef(fit1, pars = "Trt1")) + expect_equal(dimnames(ranef1$visit)[[3]], "Trt1") + + ranef1 <- SM(ranef(fit1, groups = "a")) + expect_equal(length(ranef1), 0L) + + ranef2 <- SM(ranef(fit2, summary = FALSE)) + expect_equal(dim(ranef2$patient), c(ndraws(fit2), 59, 2)) +}) + +test_that("residuals has reasonable outputs", { + res1 <- SW(residuals(fit1, type = "pearson", probs = c(0.65))) + expect_equal(dim(res1), c(nobs(fit1), 3)) + newdata <- cbind(epilepsy[1:10, ], Exp = rep(1:5, 2), volume = 0) + res2 <- residuals(fit1, newdata = newdata) + expect_equal(dim(res2), c(10, 4)) + newdata$visit <- rep(1:5, 2) + + res3 <- residuals(fit1, newdata = newdata, allow_new_levels = TRUE) + expect_equal(dim(res3), c(10, 4)) + + res4 <- residuals(fit2) + expect_equal(dim(res4), c(nobs(fit2), 4)) + + expect_error(residuals(fit4), "Predictive errors are not defined") + + res6 <- residuals(fit6) + expect_equal(dim(res6), c(nobs(fit6), 4, 2)) + expect_equal(dimnames(res6)[[3]], c("volume", "count")) +}) + +test_that("stancode has reasonable outputs", { + scode <- stancode(fit1) + expect_true(is.character(stancode(fit1))) + expect_match(stancode(fit1), "generated quantities") + expect_identical(scode, fit1$model) + + # test that stancode can be updated + scode <- stancode(fit2, threads = threading(1)) + expect_match(scode, "reduce_sum(partial_log_lik_lpmf,", fixed = TRUE) +}) + +test_that("standata has reasonable outputs", { + expect_equal(sort(names(standata(fit1))), + sort(c("N", "Y", "Kar", "Kma", "J_lag", "K", "X", "Ksp", "Imo", + "Xmo_1", "Jmo", "con_simo_1", "Z_1_1", "Z_1_2", "nb_1", + "knots_1", "Zs_1_1", "Ks", "Xs", "offsets", "K_sigma", + "X_sigma", "J_1", "N_1", "M_1", "NC_1", "prior_only")) + ) + expect_equal(sort(names(standata(fit2))), + sort(c("N", "Y", "weights", "C_1", "K_a", "X_a", "Z_1_a_1", + "K_b", "X_b", "Z_1_b_2", "J_1", "N_1", "M_1", + "NC_1", "prior_only")) + ) +}) + +test_that("mcmc_plot has reasonable outputs", { + expect_ggplot(mcmc_plot(fit1)) + expect_ggplot(mcmc_plot(fit1, variable = "^b", regex = TRUE)) + expect_ggplot(SM(mcmc_plot(fit1, type = "trace", variable = "^b_", regex = TRUE))) + expect_ggplot(mcmc_plot(fit1, type = "hist", variable = "^sd_", regex = TRUE)) + expect_ggplot(mcmc_plot(fit1, type = "dens")) + expect_ggplot(mcmc_plot(fit1, type = "scatter", variable = variables(fit1)[2:3])) + expect_ggplot(SW(mcmc_plot(fit1, type = "rhat", variable = "^b_", regex = TRUE))) + expect_ggplot(SW(mcmc_plot(fit1, type = "neff"))) + expect_ggplot(mcmc_plot(fit1, type = "acf")) + expect_silent(p <- mcmc_plot(fit1, type = "nuts_divergence")) + expect_error(mcmc_plot(fit1, type = "density"), "Invalid plot type") + expect_error(mcmc_plot(fit1, type = "hex"), + "Exactly 2 parameters must be selected") +}) + +test_that("summary has reasonable outputs", { + summary1 <- SW(summary(fit1, priors = TRUE)) + expect_true(is.data.frame(summary1$fixed)) + expect_equal(rownames(summary1$fixed), + c("Intercept", "sigma_Intercept", "Trt1", "Age", "volume", + "Trt1:Age", "sigma_Trt1", "sAge_1", "moExp")) + expect_equal(colnames(summary1$fixed), + c("Estimate", "Est.Error", "l-95% CI", + "u-95% CI", "Rhat", "Bulk_ESS", "Tail_ESS")) + expect_equal(rownames(summary1$random$visit), + c("sd(Intercept)", "sd(Trt1)", "cor(Intercept,Trt1)")) + expect_output(print(summary1), "Population-Level Effects:") + expect_output(print(summary1), "Priors:") + + summary5 <- SW(summary(fit5, robust = TRUE)) + expect_output(print(summary5), "sigma1") + expect_output(print(summary5), "theta1") + + summary6 <- SW(summary(fit6)) + expect_output(print(summary6), "sdgp") +}) + +test_that("update has reasonable outputs", { + # Do not actually refit the model as is causes CRAN checks to fail. + # Some tests are commented out as they fail when updating Stan code + # of internal example models because of Stan code mismatches. Refitting + # these example models is slow especially when done repeatedly and + # leads the git repo to blow up eventually due the size of the models. + up <- update(fit1, testmode = TRUE) + expect_true(is(up, "brmsfit")) + + new_data <- data.frame( + Age = rnorm(18), visit = rep(c(3, 2, 4), 6), + Trt = rep(0:1, 9), count = rep(c(5, 17, 28), 6), + patient = 1, Exp = 4, volume = 0 + ) + up <- update(fit1, newdata = new_data, save_pars = save_pars(group = FALSE), + testmode = TRUE) + expect_true(is(up, "brmsfit")) + expect_equal(attr(up$data, "data_name"), "new_data") + # expect_equal(attr(up$ranef, "levels")$visit, c("2", "3", "4")) + # expect_true("r_1_1" %in% up$exclude) + expect_error(update(fit1, data = new_data), "use argument 'newdata'") + + up <- update(fit1, formula = ~ . + I(exp(Age)), testmode = TRUE, + prior = set_prior("normal(0,10)")) + expect_true(is(up, "brmsfit")) + up <- update(fit1, ~ . - Age + factor(Age), testmode = TRUE) + expect_true(is(up, "brmsfit")) + + up <- update(fit1, formula = ~ . + I(exp(Age)), newdata = new_data, + sample_prior = FALSE, testmode = TRUE) + expect_true(is(up, "brmsfit")) + expect_error(update(fit1, formula. = ~ . + wrong_var), + "New variables found: 'wrong_var'") + + up <- update(fit1, save_pars = save_pars(group = FALSE), testmode = TRUE) + expect_true(is(up, "brmsfit")) + # expect_true("r_1_1" %in% up$exclude) + up <- update(fit3, save_pars = save_pars(latent = FALSE), testmode = TRUE) + expect_true(is(up, "brmsfit")) + # expect_true("Xme_1" %in% up$exclude) + + up <- update(fit2, algorithm = "fullrank", testmode = TRUE) + expect_true(is(up, "brmsfit")) + # expect_equal(up$algorithm, "fullrank") + up <- update(fit2, formula. = bf(. ~ ., a + b ~ 1, nl = TRUE), + testmode = TRUE) + expect_true(is(up, "brmsfit")) + up <- update(fit2, formula. = bf(count ~ a + b, nl = TRUE), testmode = TRUE) + expect_true(is(up, "brmsfit")) + up <- update(fit3, family = acat(), testmode = TRUE) + expect_true(is(up, "brmsfit")) + up <- update(fit3, bf(~., family = acat()), testmode = TRUE) + expect_true(is(up, "brmsfit")) +}) + +test_that("VarCorr has reasonable outputs", { + vc <- VarCorr(fit1) + expect_equal(names(vc), c("visit")) + Names <- c("Intercept", "Trt1") + expect_equal(dimnames(vc$visit$cov)[c(1, 3)], list(Names, Names)) + vc <- VarCorr(fit2) + expect_equal(names(vc), c("patient")) + expect_equal(dim(vc$patient$cor), c(2, 4, 2)) + vc <- VarCorr(fit2, summary = FALSE) + expect_equal(dim(vc$patient$cor), c(ndraws(fit2), 2, 2)) + expect_equal(dim(VarCorr(fit6)$residual__$sd), c(1, 4)) + vc <- VarCorr(fit5) + expect_equal(dim(vc$patient$sd), c(2, 4)) +}) + +test_that("variables has reasonable ouputs", { + expect_true(all( + c("b_Intercept", "bsp_moExp", "ar[1]", "cor_visit__Intercept__Trt1", + "nu", "simo_moExp1[2]", "r_visit[4,Trt1]", "s_sAge_1[8]", + "prior_sd_visit", "prior_cor_visit", "lp__") %in% + variables(fit1) + )) + expect_true(all( + c("b_a_Intercept", "b_b_Age", "sd_patient__b_Intercept", + "cor_patient__a_Intercept__b_Intercept", + "r_patient__a[1,Intercept]", "r_patient__b[4,Intercept]", + "prior_b_a") %in% + variables(fit2) + )) + expect_true(all( + c("lscale_volume_gpAgeTrt0", "lscale_volume_gpAgeTrt1") %in% + variables(fit6) + )) + expect_equal(variables(fit3), SW(parnames(fit3))) +}) + +test_that("vcov has reasonable outputs", { + expect_equal(dim(vcov(fit1)), c(9, 9)) + expect_equal(dim(vcov(fit1, cor = TRUE)), c(9, 9)) +}) + +test_that("waic has reasonable outputs", { + waic1 <- SW(WAIC(fit1)) + expect_true(is.numeric(waic1$estimates)) + # fails on MKL for unknown reasons + # expect_equal(waic1, SW(waic(fit1))) + + fit1 <- SW(add_criterion(fit1, "waic")) + expect_true(is.numeric(fit1$criteria$waic$estimates)) + # fails on MKL for unknown reasons + # expect_equal(waic(fit1), fit1$criteria$waic) + + waic_compare <- SW(waic(fit1, fit1)) + expect_equal(length(waic_compare$loos), 2) + expect_equal(dim(waic_compare$ic_diffs__), c(1, 2)) + waic2 <- SW(waic(fit2)) + expect_true(is.numeric(waic2$estimates)) + waic_pointwise <- SW(waic(fit2, pointwise = TRUE)) + expect_equal(waic2, waic_pointwise) + expect_warning(compare_ic(waic1, waic2), + "Model comparisons are likely invalid") + waic4 <- SW(waic(fit4)) + expect_true(is.numeric(waic4$estimates)) +}) + +test_that("diagnostic convenience functions have reasonable outputs", { + expect_true(is(log_posterior(fit1), "data.frame")) + expect_true(is(nuts_params(fit1), "data.frame")) + expect_true(is(rhat(fit1), "numeric")) + expect_true(is(neff_ratio(fit1), "numeric")) +}) + +test_that("contrasts of grouping factors are not stored #214", { + expect_true(is.null(attr(fit1$data$patient, "contrasts"))) +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.brmsformula.R r-cran-brms-2.17.0/tests/testthat/tests.brmsformula.R --- r-cran-brms-2.16.3/tests/testthat/tests.brmsformula.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.brmsformula.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,61 +1,61 @@ -context("Tests for brmsformula") - -test_that("brmsformula validates formulas of non-linear parameters", { - expect_error(bf(y ~ a, ~ 1, a ~ 1), - "Additional formulas must be named") - expect_error(bf(y ~ a^x, a.b ~ 1), - "not contain dots or underscores") - expect_error(bf(y ~ a^(x+b), a_b ~ 1), - "not contain dots or underscores") -}) - -test_that("brmsformula validates formulas of auxiliary parameters", { - expect_error(bf(y ~ a, ~ 1, sigma ~ 1), - "Additional formulas must be named") -}) - -test_that("brmsformula detects use if '~~'", { - # checks fix of issue #749 - expect_error(bf(y~~x), "~~") -}) - -test_that("brmsformula does not change a 'brmsformula' object", { - form <- bf(y ~ a, sigma ~ 1) - expect_identical(form, bf(form)) - form <- bf(y ~ a, sigma ~ 1, a ~ x, nl = TRUE) - expect_identical(form, bf(form)) -}) - -test_that("brmsformula detects auxiliary parameter equations", { - expect_error(bf(y~x, sigma1 = "sigmaa2"), - "Can only equate parameters of the same class") - expect_error(bf(y~x, mu3 = "mu2"), - "Equating parameters of class 'mu' is not allowed") - expect_error(bf(y~x, sigma1 = "sigma1"), - "Equating 'sigma1' with itself is not meaningful") - expect_error(bf(y~x, shape1 ~ x, shape2 = "shape1"), - "Cannot use predicted parameters on the right-hand side") - expect_error(bf(y~x, shape1 = "shape3", shape2 = "shape1"), - "Cannot use fixed parameters on the right-hand side") -}) - -test_that("update_adterms works correctly", { - form <- y | trials(size) ~ x - expect_equal( - update_adterms(form, ~ trials(10)), - y | trials(10) ~ x - ) - expect_equal( - update_adterms(form, ~ weights(w)), - y | trials(size) + weights(w) ~ x - ) - expect_equal( - update_adterms(form, ~ weights(w), action = "replace"), - y | weights(w) ~ x - ) - expect_equal( - update_adterms(y ~ x, ~ trials(10)), - y | trials(10) ~ x - ) -}) - +context("Tests for brmsformula") + +test_that("brmsformula validates formulas of non-linear parameters", { + expect_error(bf(y ~ a, ~ 1, a ~ 1), + "Additional formulas must be named") + expect_error(bf(y ~ a^x, a.b ~ 1), + "not contain dots or underscores") + expect_error(bf(y ~ a^(x+b), a_b ~ 1), + "not contain dots or underscores") +}) + +test_that("brmsformula validates formulas of auxiliary parameters", { + expect_error(bf(y ~ a, ~ 1, sigma ~ 1), + "Additional formulas must be named") +}) + +test_that("brmsformula detects use if '~~'", { + # checks fix of issue #749 + expect_error(bf(y~~x), "~~") +}) + +test_that("brmsformula does not change a 'brmsformula' object", { + form <- bf(y ~ a, sigma ~ 1) + expect_identical(form, bf(form)) + form <- bf(y ~ a, sigma ~ 1, a ~ x, nl = TRUE) + expect_identical(form, bf(form)) +}) + +test_that("brmsformula detects auxiliary parameter equations", { + expect_error(bf(y~x, sigma1 = "sigmaa2"), + "Can only equate parameters of the same class") + expect_error(bf(y~x, mu3 = "mu2"), + "Equating parameters of class 'mu' is not allowed") + expect_error(bf(y~x, sigma1 = "sigma1"), + "Equating 'sigma1' with itself is not meaningful") + expect_error(bf(y~x, shape1 ~ x, shape2 = "shape1"), + "Cannot use predicted parameters on the right-hand side") + expect_error(bf(y~x, shape1 = "shape3", shape2 = "shape1"), + "Cannot use fixed parameters on the right-hand side") +}) + +test_that("update_adterms works correctly", { + form <- y | trials(size) ~ x + expect_equal( + update_adterms(form, ~ trials(10)), + y | trials(10) ~ x + ) + expect_equal( + update_adterms(form, ~ weights(w)), + y | trials(size) + weights(w) ~ x + ) + expect_equal( + update_adterms(form, ~ weights(w), action = "replace"), + y | weights(w) ~ x + ) + expect_equal( + update_adterms(y ~ x, ~ trials(10)), + y | trials(10) ~ x + ) +}) + diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.brmsterms.R r-cran-brms-2.17.0/tests/testthat/tests.brmsterms.R --- r-cran-brms-2.16.3/tests/testthat/tests.brmsterms.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.brmsterms.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,90 +1,90 @@ -context("Tests for formula parsing functions") - -test_that("brmsterms finds all variables in very long formulas", { - expect_equal( - all.vars(brmsterms(t2_brand_recall ~ psi_expsi + psi_api_probsolv + - psi_api_ident + psi_api_intere + psi_api_groupint)$all), - all.vars(t2_brand_recall ~ t2_brand_recall + psi_expsi + psi_api_probsolv + psi_api_ident + - psi_api_intere + psi_api_groupint) - ) -}) - -test_that("brmsterms handles very long RE terms", { - # tests issue #100 - covariate_vector <- paste0("xxxxx", 1:80, collapse = "+") - formula <- paste(sprintf("y ~ 0 + trait + trait:(%s)", covariate_vector), - sprintf("(1+%s|id)", covariate_vector), sep = " + ") - bterms <- brmsterms(as.formula(formula)) - expect_equal(bterms$dpars$mu$re$group, "id") -}) - -test_that("brmsterms correctly handles auxiliary parameter 'mu'", { - bterms1 <- brmsterms(y ~ x + (x|g)) - bterms2 <- brmsterms(bf(y ~ 1, mu ~ x + (x|g))) - expect_equal(bterms1$dpars$mu, bterms2$dpars$mu) - - # commented out for now as updating is not yet enabled - # bterms1 <- brmsterms(bf(y ~ z + x + (x|g))) - # bterms2 <- brmsterms(bf(y ~ z, lf(mu ~ x + (x|g)))) - # expect_equal(bterms1$dpars$mu, bterms2$dpars$mu) - # - # bterms1 <- brmsterms(bf(y ~ z, lf(mu ~ x + (x|g), cmc = FALSE))) - # expect_true(!attr(bterms1$dpars$mu$fe, "cmc")) - # - # expect_error(brmsterms(bf(y ~ z, mu ~ x + (x|g), nl = TRUE)), - # "Cannot combine non-linear formulas") -}) - -test_that("brmsterms correctly check fixed auxiliary parameters", { - bform <- bf(y~1, sigma = 4, family = gaussian) - expect_true(is.brmsterms(brmsterms(bform))) - bform <- bf(y~1, zi = 0.5, family = zero_inflated_beta()) - expect_true(is.brmsterms(brmsterms(bform))) - bform <- bf(y~1, shape = -2, family = Gamma()) - expect_error(brmsterms(bform), "Parameter 'shape' must be positive") - bform <- bf(y~1, quantile = 1.5, family = asym_laplace()) - expect_error(brmsterms(bform), "Parameter 'quantile' must be between 0 and 1") -}) - -test_that("check_re_formula returns correct REs", { - old_form <- y ~ x + (1|patient) + (Trt_c|visit) - form <- check_re_formula(~ (1 | visit), old_form) - expect_equivalent(form, ~ (1 | gr(visit))) - form <- check_re_formula(~ (1 + Trt_c|visit), old_form) - expect_equivalent(form, ~ (1 + Trt_c | gr(visit))) - form <- check_re_formula(~ (0 + Trt_c | visit) + (1|patient), old_form) - expect_equivalent(form, ~ (1|gr(patient)) + (0 + Trt_c | gr(visit))) - - # checks for fix of issue #844 - old_form <- y ~ 0 + x1 + x2 + (0 + x1 + x2 | x3) - expect_error( - check_re_formula(~ (0 + x2 + x1 | x3), old_form), - "Order of terms in 're_formula' should match the original order" - ) -}) - -test_that("update_re_terms works correctly", { - expect_equivalent(update_re_terms(y ~ x, ~ (1|visit)), y ~ x) - expect_equivalent(update_re_terms(y ~ x*z + (1+Trt_c|patient), ~ (1|patient)), - y ~ x*z + (1|gr(patient))) - expect_equivalent(update_re_terms(y ~ x + (1|patient), ~ 1), y ~ x) - expect_equivalent(update_re_terms(y ~ 1|patient, ~ 1), y ~ 1) - expect_equivalent(update_re_terms(y ~ -1 + x + (1+visit|patient), NA), - y ~ -1 + x) - expect_equivalent(update_re_terms(y ~ x + (1+visit|patient), NULL), - y ~ x + (1+visit|patient)) - expect_equivalent(update_re_terms(y ~ (1|patient), NA), y ~ 1) - expect_equivalent(update_re_terms(y ~ x + (1+x|visit), ~ (1|visit)), - y ~ x + (1|gr(visit))) - expect_equivalent(update_re_terms(y ~ x + (1|visit), ~ (1|visit) + (x|visit)), - y ~ x + (1|gr(visit))) - expect_equal(update_re_terms(bf(y ~ x, sigma = ~ x + (x|g)), ~ (1|g)), - bf(y ~ x, sigma = ~ x + (1|gr(g)))) - expect_equal(update_re_terms(bf(y ~ x, x ~ z + (1|g), nl = TRUE), ~ (1|g)), - bf(y ~ x, x ~ z + (1|gr(g)), nl = TRUE)) -}) - -test_that("unused variables are correctly incorporated", { - bterms <- brmsterms(bf(y ~ 1, unused = ~ x)) - expect_true("x" %in% all.vars(bterms$allvars)) -}) +context("Tests for formula parsing functions") + +test_that("brmsterms finds all variables in very long formulas", { + expect_equal( + all.vars(brmsterms(t2_brand_recall ~ psi_expsi + psi_api_probsolv + + psi_api_ident + psi_api_intere + psi_api_groupint)$all), + all.vars(t2_brand_recall ~ t2_brand_recall + psi_expsi + psi_api_probsolv + psi_api_ident + + psi_api_intere + psi_api_groupint) + ) +}) + +test_that("brmsterms handles very long RE terms", { + # tests issue #100 + covariate_vector <- paste0("xxxxx", 1:80, collapse = "+") + formula <- paste(sprintf("y ~ 0 + trait + trait:(%s)", covariate_vector), + sprintf("(1+%s|id)", covariate_vector), sep = " + ") + bterms <- brmsterms(as.formula(formula)) + expect_equal(bterms$dpars$mu$re$group, "id") +}) + +test_that("brmsterms correctly handles auxiliary parameter 'mu'", { + bterms1 <- brmsterms(y ~ x + (x|g)) + bterms2 <- brmsterms(bf(y ~ 1, mu ~ x + (x|g))) + expect_equal(bterms1$dpars$mu, bterms2$dpars$mu) + + # commented out for now as updating is not yet enabled + # bterms1 <- brmsterms(bf(y ~ z + x + (x|g))) + # bterms2 <- brmsterms(bf(y ~ z, lf(mu ~ x + (x|g)))) + # expect_equal(bterms1$dpars$mu, bterms2$dpars$mu) + # + # bterms1 <- brmsterms(bf(y ~ z, lf(mu ~ x + (x|g), cmc = FALSE))) + # expect_true(!attr(bterms1$dpars$mu$fe, "cmc")) + # + # expect_error(brmsterms(bf(y ~ z, mu ~ x + (x|g), nl = TRUE)), + # "Cannot combine non-linear formulas") +}) + +test_that("brmsterms correctly check fixed auxiliary parameters", { + bform <- bf(y~1, sigma = 4, family = gaussian) + expect_true(is.brmsterms(brmsterms(bform))) + bform <- bf(y~1, zi = 0.5, family = zero_inflated_beta()) + expect_true(is.brmsterms(brmsterms(bform))) + bform <- bf(y~1, shape = -2, family = Gamma()) + expect_error(brmsterms(bform), "Parameter 'shape' must be positive") + bform <- bf(y~1, quantile = 1.5, family = asym_laplace()) + expect_error(brmsterms(bform), "Parameter 'quantile' must be between 0 and 1") +}) + +test_that("check_re_formula returns correct REs", { + old_form <- y ~ x + (1|patient) + (Trt_c|visit) + form <- check_re_formula(~ (1 | visit), old_form) + expect_equivalent(form, ~ (1 | gr(visit))) + form <- check_re_formula(~ (1 + Trt_c|visit), old_form) + expect_equivalent(form, ~ (1 + Trt_c | gr(visit))) + form <- check_re_formula(~ (0 + Trt_c | visit) + (1|patient), old_form) + expect_equivalent(form, ~ (1|gr(patient)) + (0 + Trt_c | gr(visit))) + + # checks for fix of issue #844 + old_form <- y ~ 0 + x1 + x2 + (0 + x1 + x2 | x3) + expect_error( + check_re_formula(~ (0 + x2 + x1 | x3), old_form), + "Order of terms in 're_formula' should match the original order" + ) +}) + +test_that("update_re_terms works correctly", { + expect_equivalent(update_re_terms(y ~ x, ~ (1|visit)), y ~ x) + expect_equivalent(update_re_terms(y ~ x*z + (1+Trt_c|patient), ~ (1|patient)), + y ~ x*z + (1|gr(patient))) + expect_equivalent(update_re_terms(y ~ x + (1|patient), ~ 1), y ~ x) + expect_equivalent(update_re_terms(y ~ 1|patient, ~ 1), y ~ 1) + expect_equivalent(update_re_terms(y ~ -1 + x + (1+visit|patient), NA), + y ~ -1 + x) + expect_equivalent(update_re_terms(y ~ x + (1+visit|patient), NULL), + y ~ x + (1+visit|patient)) + expect_equivalent(update_re_terms(y ~ (1|patient), NA), y ~ 1) + expect_equivalent(update_re_terms(y ~ x + (1+x|visit), ~ (1|visit)), + y ~ x + (1|gr(visit))) + expect_equivalent(update_re_terms(y ~ x + (1|visit), ~ (1|visit) + (x|visit)), + y ~ x + (1|gr(visit))) + expect_equal(update_re_terms(bf(y ~ x, sigma = ~ x + (x|g)), ~ (1|g)), + bf(y ~ x, sigma = ~ x + (1|gr(g)))) + expect_equal(update_re_terms(bf(y ~ x, x ~ z + (1|g), nl = TRUE), ~ (1|g)), + bf(y ~ x, x ~ z + (1|gr(g)), nl = TRUE)) +}) + +test_that("unused variables are correctly incorporated", { + bterms <- brmsterms(bf(y ~ 1, unused = ~ x)) + expect_true("x" %in% all.vars(bterms$allvars)) +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.data-helpers.R r-cran-brms-2.17.0/tests/testthat/tests.data-helpers.R --- r-cran-brms-2.16.3/tests/testthat/tests.data-helpers.R 2020-10-08 06:55:08.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.data-helpers.R 2022-03-13 16:10:29.000000000 +0000 @@ -15,12 +15,12 @@ test_that("validate_data returns correct model.frames", { dat <- data.frame(y = 1:5, x = 1:5, z = 6:10, g = 5:1) - + bterms <- brmsterms(y ~ as.numeric(x) + (as.factor(z) | g), family = gaussian()) mf <- brms:::validate_data(dat, bterms = bterms) expect_true(all(c("x", "z") %in% names(mf))) - + bterms <- brmsterms(y ~ 1 + (1|g/x/z), family = gaussian()) mf <- brms:::validate_data(dat, bterms = bterms) expect_equal(mf[["g:x"]], paste0(dat$g, "_", dat$x)) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.distributions.R r-cran-brms-2.17.0/tests/testthat/tests.distributions.R --- r-cran-brms-2.16.3/tests/testthat/tests.distributions.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.distributions.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,578 +1,592 @@ -context("Tests for distribution functions") - -test_that("student distribution works correctly", { - expect_equal(integrate(dstudent_t, -100, 100, df = 15, mu = 10, sigma = 5)$value, 1) - expect_equal(dstudent_t(1, df = 10, mu = 0, sigma = 5), dt(1/5, df = 10)/5) - expect_equal(pstudent_t(2, df = 20, mu = 2, sigma = 0.4), pt(0, df = 20)) - expect_equal(qstudent_t(0.7, df = 5, mu = 2, sigma = 3), 2 + 3*qt(0.7, df = 5)) - expect_equal(length(rstudent_t(10, df = 10, mu = rnorm(10), sigma = 1:10)), 10) -}) - -test_that("multivariate normal and student distributions work correctly", { - mu <- rnorm(3) - Sigma <- cov(matrix(rnorm(300), ncol = 3)) - expect_equal(dmulti_normal(1:3, mu = mu, Sigma = Sigma), - mnormt::dmnorm(1:3, mu, Sigma)) - expect_equal(dmulti_student_t(1:3, mu = mu, Sigma = Sigma, df = 10, log = TRUE), - mnormt::dmt(1:3, df = 10, mean = mu, S = Sigma, log = TRUE)) - expect_equal(dim(rmulti_normal(7, mu = mu, Sigma = Sigma)), c(7, 3)) - expect_equal(dim(rmulti_student_t(7, mu = mu, Sigma = Sigma, df = 10)), - c(7, 3)) - # test errors - expect_error(dmulti_normal(1:3, mu = rnorm(2), Sigma = Sigma, check = TRUE), - "Dimension of mu is incorrect") - expect_error(dmulti_normal(1:3, mu = mu, Sigma = Sigma[1:2, 1:2], - check = TRUE), - "Dimension of Sigma is incorrect") - expect_error(dmulti_normal(1:3, mu = mu, Sigma = Sigma[1:3, 3:1], - check = TRUE), - "Sigma must be a symmetric matrix") - expect_error(rmulti_normal(1.5, mu = mu, Sigma = Sigma, check = TRUE), - "n must be a positive integer") - expect_error(rmulti_normal(10, mu = mu, Sigma = Sigma[1:3, 3:1], - check = TRUE), - "Sigma must be a symmetric matrix") - expect_error(dmulti_student_t(rnorm(3), mu = mu, Sigma = Sigma, - df = -1, check = TRUE), - "df must be greater than 0") - expect_error(dmulti_student_t(rnorm(3), mu = mu, Sigma = Sigma[1:3, 3:1], - df = 30, check = TRUE), - "Sigma must be a symmetric matrix") - expect_error(rmulti_student_t(10, mu = mu, Sigma = Sigma, - df = -1, check = TRUE), - "df must be greater than 0") -}) - -test_that("von_mises distribution functions run without errors", { - n <- 10 - res <- dvon_mises(runif(n, -pi, pi), mu = 1, kappa = 1:n) - expect_true(length(res) == n) - res <- pvon_mises(runif(n, -pi, pi), mu = rnorm(n), kappa = 0:(n-1)) - expect_true(length(res) == n) - res <- rvon_mises(n, mu = rnorm(n), kappa = 0:(n-1)) - expect_true(length(res) == n) -}) - -test_that("skew_normal distribution functions run without errors", { - n <- 10 - x <- rnorm(n, 10, 3) - res <- dskew_normal(x, mu = 1, sigma = 2, alpha = 1) - expect_true(length(res) == n) - res <- pskew_normal(x, mu = rnorm(n), sigma = 1:n, - alpha = 3, log.p = TRUE) - expect_true(length(res) == n) - res <- qskew_normal(x, mu = rnorm(n), sigma = 1:n, - alpha = 3, log.p = TRUE) - expect_true(length(res) == n) - res <- rskew_normal(n, mu = rnorm(n), sigma = 10, alpha = -4:5) - expect_true(length(res) == n) -}) - -test_that("exgaussian distribution functions run without errors", { - n <- 10 - x <- rnorm(n, 10, 3) - res <- dexgaussian(x, mu = 1, sigma = 2, beta = 1) - expect_true(length(res) == n) - res <- pexgaussian(x, mu = rnorm(n), sigma = 1:n, - beta = 3, log.p = TRUE) - expect_true(length(res) == n) - res <- rexgaussian(n, mu = rnorm(n), sigma = 10, beta = 1:10) - expect_true(length(res) == n) -}) - -test_that("frechet distribution functions run without errors", { - n <- 10 - x <- 21:30 - res <- dfrechet(x, loc = 1, scale = 2, shape = 1, log = TRUE) - expect_true(length(res) == n) - loc <- 1:10 - res <- pfrechet(x, loc = loc, scale = 1:n, shape = 3) - expect_true(length(res) == n) - q <- qfrechet(res, loc = loc, scale = 1:n, shape = 3) - expect_equal(x, q) - res <- rfrechet(n, loc = loc, scale = 10, shape = 1:10) - expect_true(length(res) == n) -}) - -test_that("inv_gaussian distribution functions run without errors", { - n <- 10 - x <- rgamma(n, 10, 3) - res <- dinv_gaussian(x, mu = 1, shape = 1) - expect_true(length(res) == n) - res <- pinv_gaussian(x, mu = abs(rnorm(n)), shape = 3) - expect_true(length(res) == n) - res <- rinv_gaussian(n, mu = abs(rnorm(n)), shape = 1:10) - expect_true(length(res) == n) -}) - -test_that("gen_extreme_value distribution functions run without errors", { - n <- 10 - x <- rgamma(n, 10, 3) - res <- dgen_extreme_value(x, mu = 1, sigma = 2, xi = 1) - expect_true(length(res) == n) - res <- pgen_extreme_value(x, mu = rnorm(n), sigma = 1:n, xi = 3) - expect_true(length(res) == n) - res <- rgen_extreme_value(n, mu = rnorm(n), sigma = 10, xi = 1:10) - expect_true(length(res) == n) -}) - -test_that("asym_laplace distribution functions run without errors", { - n <- 10 - x <- rnorm(n, 10, 3) - res <- dasym_laplace(x, mu = 1, sigma = 2, quantile = 0.5) - expect_true(length(res) == n) - res <- pasym_laplace(x, mu = rnorm(n), sigma = 1:n, quantile = 0.3) - expect_true(length(res) == n) - res <- rasym_laplace(n, mu = rnorm(n), sigma = 10, - quantile = runif(n, 0, 1)) - expect_true(length(res) == n) -}) - -test_that("zero-inflated distribution functions run without errors", { - n <- 10 - x <- rpois(n, lambda = 1) - - res <- dzero_inflated_poisson(x, lambda = 1, zi = 0.1) - expect_true(length(res) == n) - res <- pzero_inflated_poisson(x, lambda = 1, zi = 0.1) - expect_true(length(res) == n) - - res <- dzero_inflated_negbinomial(x, mu = 2, shape = 5, zi = 0.1) - expect_true(length(res) == n) - res <- pzero_inflated_negbinomial(x, mu = 2, shape = 5, zi = 0.1) - expect_true(length(res) == n) - - res <- dzero_inflated_binomial(x, size = c(2, 10), prob = 0.4, zi = 0.1) - expect_true(length(res) == n) - res <- pzero_inflated_binomial(x, size = c(2, 10), prob = 0.4, zi = 0.1) - expect_true(length(res) == n) - - x <- c(rbeta(n - 2, shape1 = 2, shape2 = 3), 0, 0) - res <- dzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.1) - expect_true(length(res) == n) - res <- pzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.1) - expect_true(length(res) == n) -}) - -test_that("hurdle distribution functions run without errors", { - n <- 10 - x <- rpois(n, lambda = 1) - - res <- dhurdle_poisson(x, lambda = 1, hu = 0.1) - expect_true(length(res) == n) - res <- phurdle_poisson(x, lambda = 1, hu = 0.1) - expect_true(length(res) == n) - - res <- dhurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) - expect_true(length(res) == n) - res <- phurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) - expect_true(length(res) == n) - - res <- dhurdle_gamma(x, shape = 1, scale = 3, hu = 0.1) - expect_true(length(res) == n) - res <- phurdle_gamma(x, shape = 1, scale = 3, hu = 0.1) - expect_true(length(res) == n) - - res <- dhurdle_lognormal(x, mu = 2, sigma = 5, hu = 0.1) - expect_true(length(res) == n) - res <- phurdle_lognormal(x, mu = 2, sigma = 5, hu = 0.1) - expect_true(length(res) == n) -}) - -test_that("wiener distribution functions run without errors", { - set.seed(1234) - n <- 10 - x <- seq(0.1, 1, 0.1) - alpha <- rexp(n) - tau <- 0.05 - beta <- 0.5 - delta <- rnorm(n) - resp <- sample(c(0, 1), n, TRUE) - - d1 <- dwiener(x, alpha, tau, beta, delta, resp, backend = "Rwiener") - d2 <- dwiener(x, alpha, tau, beta, delta, resp, backend = "rtdists") - expect_equal(d1, d2) - - r1 <- rwiener(n, alpha, tau, beta, delta, backend = "Rwiener") - r2 <- rwiener(n, alpha, tau, beta, delta, backend = "rtdists") - expect_equal(names(r1), names(r2)) - expect_equal(dim(r1), dim(r2)) -}) - -test_that("d() works correctly", { - source(testthat::test_path(file.path("helpers", "inv_link_ordinal_ch.R"))) - source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) - for (ndraws in ndraws_vec) { - for (ncat in ncat_vec) { - thres_test <- matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) - # Emulate no category-specific effects (i.e., only a single vector of - # linear predictors) as well as category-specific effects (i.e., a matrix - # of linear predictors): - eta_test_list <- list( - rnorm(ndraws), - matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) - ) - for (eta_test in eta_test_list) { - thres_eta <- if (is.matrix(eta_test)) { - stopifnot(identical(dim(eta_test), dim(thres_test))) - thres_test - eta_test - } else { - # Just to try something different: - sweep(thres_test, 1, as.array(eta_test)) - } - eta_thres <- if (is.matrix(eta_test)) { - stopifnot(identical(dim(eta_test), dim(thres_test))) - eta_test - thres_test - } else { - # Just to try something different: - sweep(-thres_test, 1, as.array(eta_test), FUN = "+") - } - for (link in c("logit", "probit", "cauchit", "cloglog")) { - # cumulative(): - d_cumul <- dcumulative(seq_len(ncat), - eta_test, thres_test, link = link) - d_cumul_ch <- inv_link_cumulative_ch(thres_eta, link = link) - expect_equivalent(d_cumul, d_cumul_ch) - expect_equal(dim(d_cumul), c(ndraws, ncat)) - - # sratio(): - d_sratio <- dsratio(seq_len(ncat), - eta_test, thres_test, link = link) - d_sratio_ch <- inv_link_sratio_ch(thres_eta, link = link) - expect_equivalent(d_sratio, d_sratio_ch) - expect_equal(dim(d_sratio), c(ndraws, ncat)) - - # cratio(): - d_cratio <- dcratio(seq_len(ncat), - eta_test, thres_test, link = link) - d_cratio_ch <- inv_link_cratio_ch(eta_thres, link = link) - expect_equivalent(d_cratio, d_cratio_ch) - expect_equal(dim(d_cratio), c(ndraws, ncat)) - - # acat(): - d_acat <- dacat(seq_len(ncat), - eta_test, thres_test, link = link) - d_acat_ch <- inv_link_acat_ch(eta_thres, link = link) - expect_equivalent(d_acat, d_acat_ch) - expect_equal(dim(d_acat), c(ndraws, ncat)) - } - } - } - } -}) - -test_that("inv_link_() works correctly for arrays", { - source(testthat::test_path(file.path("helpers", "inv_link_ordinal_ch.R"))) - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), - dim = c(ndraws, nobsv, ncat - 1)) - nx_test <- -x_test - for (link in c("logit", "probit", "cauchit", "cloglog")) { - # cumulative(): - il_cumul <- inv_link_cumulative(x_test, link = link) - il_cumul_ch <- inv_link_cumulative_ch(x_test, link = link) - expect_equivalent(il_cumul, il_cumul_ch) - expect_equal(dim(il_cumul), c(ndraws, nobsv, ncat)) - - # sratio(): - il_sratio <- inv_link_sratio(x_test, link = link) - il_sratio_ch <- inv_link_sratio_ch(x_test, link = link) - expect_equivalent(il_sratio, il_sratio_ch) - expect_equal(dim(il_sratio), c(ndraws, nobsv, ncat)) - - # cratio(): - il_cratio <- inv_link_cratio(nx_test, link = link) - il_cratio_ch <- inv_link_cratio_ch(nx_test, link = link) - expect_equivalent(il_cratio, il_cratio_ch) - expect_equal(dim(il_cratio), c(ndraws, nobsv, ncat)) - - # acat(): - il_acat <- inv_link_acat(nx_test, link = link) - il_acat_ch <- inv_link_acat_ch(nx_test, link = link) - expect_equivalent(il_acat, il_acat_ch) - expect_equal(dim(il_acat), c(ndraws, nobsv, ncat)) - } - } - } - } -}) - -test_that("link_() works correctly for arrays", { - source(testthat::test_path(file.path("helpers", "link_ordinal_ch.R"))) - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), - dim = c(ndraws, nobsv, ncat)) - for (link in c("logit", "probit", "cauchit", "cloglog")) { - # cumulative(): - l_cumul <- link_cumulative(x_test, link = link) - l_cumul_ch <- link_cumulative_ch(x_test, link = link) - expect_equivalent(l_cumul, l_cumul_ch) - expect_equal(dim(l_cumul), c(ndraws, nobsv, ncat - 1)) - - # sratio(): - l_sratio <- link_sratio(x_test, link = link) - l_sratio_ch <- link_sratio_ch(x_test, link = link) - expect_equivalent(l_sratio, l_sratio_ch) - expect_equal(dim(l_sratio), c(ndraws, nobsv, ncat - 1)) - - # cratio(): - l_cratio <- link_cratio(x_test, link = link) - l_cratio_ch <- link_cratio_ch(x_test, link = link) - expect_equivalent(l_cratio, l_cratio_ch) - expect_equal(dim(l_cratio), c(ndraws, nobsv, ncat - 1)) - - # acat(): - l_acat <- link_acat(x_test, link = link) - l_acat_ch <- link_acat_ch(x_test, link = link) - expect_equivalent(l_acat, l_acat_ch) - expect_equal(dim(l_acat), c(ndraws, nobsv, ncat - 1)) - } - } - } - } -}) - -test_that("inv_link_() inverts link_()", { - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), - dim = c(ndraws, nobsv, ncat)) - for (link in c("logit", "probit", "cauchit", "cloglog")) { - # cumulative(): - l_cumul <- link_cumulative(x_test, link = link) - il_cumul <- inv_link_cumulative(l_cumul, link = link) - expect_equivalent(il_cumul, x_test) - - # sratio(): - l_sratio <- link_sratio(x_test, link = link) - il_sratio <- inv_link_sratio(l_sratio, link = link) - expect_equivalent(il_sratio, x_test) - - # cratio(): - l_cratio <- link_cratio(x_test, link = link) - il_cratio <- inv_link_cratio(l_cratio, link = link) - expect_equivalent(il_cratio, x_test) - - # acat(): - l_acat <- link_acat(x_test, link = link) - il_acat <- inv_link_acat(l_acat, link = link) - expect_equivalent(il_acat, x_test) - } - } - } - } -}) - -test_that("link_() inverts inv_link_()", { - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), - dim = c(ndraws, nobsv, ncat - 1)) - nx_test <- -x_test - for (link in c("logit", "probit", "cauchit", "cloglog")) { - # cumulative(): - il_cumul <- inv_link_cumulative(x_test, link = link) - l_cumul <- link_cumulative(il_cumul, link = link) - expect_equivalent(l_cumul, x_test) - - # sratio(): - il_sratio <- inv_link_sratio(x_test, link = link) - l_sratio <- link_sratio(il_sratio, link = link) - expect_equivalent(l_sratio, x_test) - - # cratio(): - il_cratio <- inv_link_cratio(x_test, link = link) - l_cratio <- link_cratio(il_cratio, link = link) - expect_equivalent(l_cratio, x_test) - - # acat(): - il_acat <- inv_link_acat(x_test, link = link) - l_acat <- link_acat(il_acat, link = link) - expect_equivalent(l_acat, x_test) - } - } - } - } -}) - -test_that(paste( - "dsratio() and dcratio() give the same results for symmetric distribution", - "functions" -), { - source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) - for (ndraws in ndraws_vec) { - for (ncat in ncat_vec) { - thres_test <- matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) - # Emulate no category-specific effects (i.e., only a single vector of - # linear predictors) as well as category-specific effects (i.e., a matrix - # of linear predictors): - eta_test_list <- list( - rnorm(ndraws), - matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) - ) - for (eta_test in eta_test_list) { - for (link in c("logit", "probit", "cauchit", "cloglog")) { - d_sratio <- dsratio(seq_len(ncat), - eta_test, thres_test, link = link) - d_cratio <- dcratio(seq_len(ncat), - eta_test, thres_test, link = link) - if (link != "cloglog") { - expect_equal(d_sratio, d_cratio) - } else { - expect_false(isTRUE(all.equal(d_sratio, d_cratio))) - } - } - } - } - } -}) - -test_that(paste( - "inv_link_sratio() and inv_link_cratio() applied to arrays give the same", - "results for symmetric distribution functions (when respecting the sign", - "appropriately)." -), { - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), - dim = c(ndraws, nobsv, ncat - 1)) - nx_test <- -x_test - for (link in c("logit", "probit", "cauchit", "cloglog")) { - il_sratio <- inv_link_sratio(x_test, link = link) - il_cratio <- inv_link_cratio(nx_test, link = link) - if (link != "cloglog") { - expect_equal(il_sratio, il_cratio) - } else { - expect_false(isTRUE(all.equal(il_sratio, il_cratio))) - } - } - } - } - } -}) - -test_that(paste( - "link_sratio() and link_cratio() applied to arrays give the same", - "results for symmetric distribution functions (when respecting the sign", - "appropriately)." -), { - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), - dim = c(ndraws, nobsv, ncat)) - for (link in c("logit", "probit", "cauchit", "cloglog")) { - l_sratio <- link_sratio(x_test, link = link) - l_cratio <- link_cratio(x_test, link = link) - if (link != "cloglog") { - expect_equal(l_sratio, -l_cratio) - } else { - expect_false(isTRUE(all.equal(l_sratio, -l_cratio))) - } - } - } - } - } -}) - -test_that("dcategorical() works correctly", { - source(testthat::test_path(file.path("helpers", "inv_link_categorical_ch.R"))) - source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) - for (ndraws in ndraws_vec) { - for (ncat in ncat_vec) { - eta_test_list <- list(cbind(0, - matrix(rnorm(ndraws * (ncat - 1)), - nrow = ndraws))) - if (ndraws == 1) { - eta_test_list <- c(eta_test_list, list(c(0, rnorm(ncat - 1)))) - } - for (eta_test in eta_test_list) { - d_categorical <- dcategorical(seq_len(ncat), eta_test) - d_categorical_ch <- inv_link_categorical_ch(eta_test) - expect_equivalent(d_categorical, d_categorical_ch) - expect_equal(dim(d_categorical), c(ndraws, ncat)) - } - } - } -}) - -test_that("inv_link_categorical() works correctly for arrays", { - source(testthat::test_path(file.path("helpers", "inv_link_categorical_ch.R"))) - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), - dim = c(ndraws, nobsv, ncat - 1)) - zeros_arr <- array(0, dim = c(ndraws, nobsv, 1)) - x_test <- abind::abind(zeros_arr, x_test) - il_categorical <- inv_link_categorical(x_test) - il_categorical_ch <- inv_link_categorical_ch(x_test) - expect_equivalent(il_categorical, il_categorical_ch) - expect_equal(dim(il_categorical), c(ndraws, nobsv, ncat)) - } - } - } -}) - -test_that("link_categorical() works correctly for arrays", { - source(testthat::test_path(file.path("helpers", "link_categorical_ch.R"))) - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), - dim = c(ndraws, nobsv, ncat)) - l_categorical <- link_categorical(x_test) - l_categorical_ch <- link_categorical_ch(x_test) - expect_equivalent(l_categorical, l_categorical_ch) - expect_equal(dim(l_categorical), c(ndraws, nobsv, ncat)) - } - } - } -}) - -test_that("inv_link_categorical() inverts link_categorical()", { - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), - dim = c(ndraws, nobsv, ncat)) - l_categorical <- link_categorical(x_test) - il_categorical <- inv_link_categorical(l_categorical) - expect_equivalent(il_categorical, x_test) - } - } - } -}) - -test_that("link_categorical() inverts inv_link_categorical()", { - source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) - for (ndraws in ndraws_vec) { - for (nobsv in nobsv_vec) { - for (ncat in ncat_vec) { - x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), - dim = c(ndraws, nobsv, ncat - 1)) - zeros_arr <- array(0, dim = c(ndraws, nobsv, 1)) - x_test <- abind::abind(zeros_arr, x_test) - il_categorical <- inv_link_categorical(x_test) - l_categorical <- link_categorical(il_categorical) - expect_equivalent(l_categorical, x_test) - } - } - } -}) +context("Tests for distribution functions") + +test_that("student distribution works correctly", { + expect_equal(integrate(dstudent_t, -100, 100, df = 15, mu = 10, sigma = 5)$value, 1) + expect_equal(dstudent_t(1, df = 10, mu = 0, sigma = 5), dt(1/5, df = 10)/5) + expect_equal(pstudent_t(2, df = 20, mu = 2, sigma = 0.4), pt(0, df = 20)) + expect_equal(qstudent_t(0.7, df = 5, mu = 2, sigma = 3), 2 + 3*qt(0.7, df = 5)) + expect_equal(length(rstudent_t(10, df = 10, mu = rnorm(10), sigma = 1:10)), 10) +}) + +test_that("multivariate normal and student distributions work correctly", { + mu <- rnorm(3) + Sigma <- cov(matrix(rnorm(300), ncol = 3)) + expect_equal(dmulti_normal(1:3, mu = mu, Sigma = Sigma), + mnormt::dmnorm(1:3, mu, Sigma)) + expect_equal(dmulti_student_t(1:3, mu = mu, Sigma = Sigma, df = 10, log = TRUE), + mnormt::dmt(1:3, df = 10, mean = mu, S = Sigma, log = TRUE)) + expect_equal(dim(rmulti_normal(7, mu = mu, Sigma = Sigma)), c(7, 3)) + expect_equal(dim(rmulti_student_t(7, mu = mu, Sigma = Sigma, df = 10)), + c(7, 3)) + # test errors + expect_error(dmulti_normal(1:3, mu = rnorm(2), Sigma = Sigma, check = TRUE), + "Dimension of mu is incorrect") + expect_error(dmulti_normal(1:3, mu = mu, Sigma = Sigma[1:2, 1:2], + check = TRUE), + "Dimension of Sigma is incorrect") + expect_error(dmulti_normal(1:3, mu = mu, Sigma = Sigma[1:3, 3:1], + check = TRUE), + "Sigma must be a symmetric matrix") + expect_error(rmulti_normal(1.5, mu = mu, Sigma = Sigma, check = TRUE), + "n must be a positive integer") + expect_error(rmulti_normal(10, mu = mu, Sigma = Sigma[1:3, 3:1], + check = TRUE), + "Sigma must be a symmetric matrix") + expect_error(dmulti_student_t(rnorm(3), mu = mu, Sigma = Sigma, + df = -1, check = TRUE), + "df must be greater than 0") + expect_error(dmulti_student_t(rnorm(3), mu = mu, Sigma = Sigma[1:3, 3:1], + df = 30, check = TRUE), + "Sigma must be a symmetric matrix") + expect_error(rmulti_student_t(10, mu = mu, Sigma = Sigma, + df = -1, check = TRUE), + "df must be greater than 0") +}) + +test_that("von_mises distribution functions run without errors", { + n <- 10 + res <- dvon_mises(runif(n, -pi, pi), mu = 1, kappa = 1:n) + expect_true(length(res) == n) + res <- pvon_mises(runif(n, -pi, pi), mu = rnorm(n), kappa = 0:(n-1)) + expect_true(length(res) == n) + res <- rvon_mises(n, mu = rnorm(n), kappa = 0:(n-1)) + expect_true(length(res) == n) +}) + +test_that("skew_normal distribution functions run without errors", { + n <- 10 + x <- rnorm(n, 10, 3) + res <- dskew_normal(x, mu = 1, sigma = 2, alpha = 1) + expect_true(length(res) == n) + res <- pskew_normal(x, mu = rnorm(n), sigma = 1:n, + alpha = 3, log.p = TRUE) + expect_true(length(res) == n) + res <- qskew_normal(x, mu = rnorm(n), sigma = 1:n, + alpha = 3, log.p = TRUE) + expect_true(length(res) == n) + res <- rskew_normal(n, mu = rnorm(n), sigma = 10, alpha = -4:5) + expect_true(length(res) == n) +}) + +test_that("exgaussian distribution functions run without errors", { + n <- 10 + x <- rnorm(n, 10, 3) + res <- dexgaussian(x, mu = 1, sigma = 2, beta = 1) + expect_true(length(res) == n) + res <- pexgaussian(x, mu = rnorm(n), sigma = 1:n, + beta = 3, log.p = TRUE) + expect_true(length(res) == n) + res <- rexgaussian(n, mu = rnorm(n), sigma = 10, beta = 1:10) + expect_true(length(res) == n) +}) + +test_that("frechet distribution functions run without errors", { + n <- 10 + x <- 21:30 + res <- dfrechet(x, loc = 1, scale = 2, shape = 1, log = TRUE) + expect_true(length(res) == n) + loc <- 1:10 + res <- pfrechet(x, loc = loc, scale = 1:n, shape = 3) + expect_true(length(res) == n) + q <- qfrechet(res, loc = loc, scale = 1:n, shape = 3) + expect_equal(x, q) + res <- rfrechet(n, loc = loc, scale = 10, shape = 1:10) + expect_true(length(res) == n) +}) + +test_that("inv_gaussian distribution functions run without errors", { + n <- 10 + x <- rgamma(n, 10, 3) + res <- dinv_gaussian(x, mu = 1, shape = 1) + expect_true(length(res) == n) + res <- pinv_gaussian(x, mu = abs(rnorm(n)), shape = 3) + expect_true(length(res) == n) + res <- rinv_gaussian(n, mu = abs(rnorm(n)), shape = 1:10) + expect_true(length(res) == n) +}) + +test_that("beta_binomial distribution functions run without errors", { + n <- 10 + x <- rpois(n, lambda = 1) + + res <- dbeta_binomial(x, c(2, 10), mu = 0.4, phi = 1) + expect_true(length(res) == n) + res <- pbeta_binomial(x, c(2, 10), mu = 0.4, phi = 1) + expect_true(length(res) == n) + res <- rbeta_binomial(n, c(2, 10), mu = 0.4, phi = 1) + expect_true(length(res) == n) +}) + +test_that("gen_extreme_value distribution functions run without errors", { + n <- 10 + x <- rgamma(n, 10, 3) + res <- dgen_extreme_value(x, mu = 1, sigma = 2, xi = 1) + expect_true(length(res) == n) + res <- pgen_extreme_value(x, mu = rnorm(n), sigma = 1:n, xi = 3) + expect_true(length(res) == n) + res <- rgen_extreme_value(n, mu = rnorm(n), sigma = 10, xi = 1:10) + expect_true(length(res) == n) +}) + +test_that("asym_laplace distribution functions run without errors", { + n <- 10 + x <- rnorm(n, 10, 3) + res <- dasym_laplace(x, mu = 1, sigma = 2, quantile = 0.5) + expect_true(length(res) == n) + res <- pasym_laplace(x, mu = rnorm(n), sigma = 1:n, quantile = 0.3) + expect_true(length(res) == n) + res <- rasym_laplace(n, mu = rnorm(n), sigma = 10, + quantile = runif(n, 0, 1)) + expect_true(length(res) == n) +}) + +test_that("zero-inflated distribution functions run without errors", { + n <- 10 + x <- rpois(n, lambda = 1) + + res <- dzero_inflated_poisson(x, lambda = 1, zi = 0.1) + expect_true(length(res) == n) + res <- pzero_inflated_poisson(x, lambda = 1, zi = 0.1) + expect_true(length(res) == n) + + res <- dzero_inflated_negbinomial(x, mu = 2, shape = 5, zi = 0.1) + expect_true(length(res) == n) + res <- pzero_inflated_negbinomial(x, mu = 2, shape = 5, zi = 0.1) + expect_true(length(res) == n) + + res <- dzero_inflated_binomial(x, size = c(2, 10), prob = 0.4, zi = 0.1) + expect_true(length(res) == n) + res <- pzero_inflated_binomial(x, size = c(2, 10), prob = 0.4, zi = 0.1) + expect_true(length(res) == n) + + res <- dzero_inflated_beta_binomial(x, c(2, 10), mu = 0.4, phi = 1, zi = 0.1) + expect_true(length(res) == n) + res <- pzero_inflated_beta_binomial(x, c(2, 10), mu = 0.4, phi = 1, zi = 0.1) + expect_true(length(res) == n) + + x <- c(rbeta(n - 2, shape1 = 2, shape2 = 3), 0, 0) + res <- dzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.1) + expect_true(length(res) == n) + res <- pzero_inflated_beta(x, shape1 = 2, shape2 = 3, zi = 0.1) + expect_true(length(res) == n) +}) + +test_that("hurdle distribution functions run without errors", { + n <- 10 + x <- rpois(n, lambda = 1) + + res <- dhurdle_poisson(x, lambda = 1, hu = 0.1) + expect_true(length(res) == n) + res <- phurdle_poisson(x, lambda = 1, hu = 0.1) + expect_true(length(res) == n) + + res <- dhurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) + expect_true(length(res) == n) + res <- phurdle_negbinomial(x, mu = 2, shape = 5, hu = 0.1) + expect_true(length(res) == n) + + res <- dhurdle_gamma(x, shape = 1, scale = 3, hu = 0.1) + expect_true(length(res) == n) + res <- phurdle_gamma(x, shape = 1, scale = 3, hu = 0.1) + expect_true(length(res) == n) + + res <- dhurdle_lognormal(x, mu = 2, sigma = 5, hu = 0.1) + expect_true(length(res) == n) + res <- phurdle_lognormal(x, mu = 2, sigma = 5, hu = 0.1) + expect_true(length(res) == n) +}) + +test_that("wiener distribution functions run without errors", { + set.seed(1234) + n <- 10 + x <- seq(0.1, 1, 0.1) + alpha <- rexp(n) + tau <- 0.05 + beta <- 0.5 + delta <- rnorm(n) + resp <- sample(c(0, 1), n, TRUE) + + d1 <- dwiener(x, alpha, tau, beta, delta, resp, backend = "Rwiener") + d2 <- dwiener(x, alpha, tau, beta, delta, resp, backend = "rtdists") + expect_equal(d1, d2) + + r1 <- rwiener(n, alpha, tau, beta, delta, backend = "Rwiener") + r2 <- rwiener(n, alpha, tau, beta, delta, backend = "rtdists") + expect_equal(names(r1), names(r2)) + expect_equal(dim(r1), dim(r2)) +}) + +test_that("d() works correctly", { + source(testthat::test_path(file.path("helpers", "inv_link_ordinal_ch.R"))) + source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) + for (ndraws in ndraws_vec) { + for (ncat in ncat_vec) { + thres_test <- matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) + # Emulate no category-specific effects (i.e., only a single vector of + # linear predictors) as well as category-specific effects (i.e., a matrix + # of linear predictors): + eta_test_list <- list( + rnorm(ndraws), + matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) + ) + for (eta_test in eta_test_list) { + thres_eta <- if (is.matrix(eta_test)) { + stopifnot(identical(dim(eta_test), dim(thres_test))) + thres_test - eta_test + } else { + # Just to try something different: + sweep(thres_test, 1, as.array(eta_test)) + } + eta_thres <- if (is.matrix(eta_test)) { + stopifnot(identical(dim(eta_test), dim(thres_test))) + eta_test - thres_test + } else { + # Just to try something different: + sweep(-thres_test, 1, as.array(eta_test), FUN = "+") + } + for (link in c("logit", "probit", "cauchit", "cloglog")) { + # cumulative(): + d_cumul <- dcumulative(seq_len(ncat), + eta_test, thres_test, link = link) + d_cumul_ch <- inv_link_cumulative_ch(thres_eta, link = link) + expect_equivalent(d_cumul, d_cumul_ch) + expect_equal(dim(d_cumul), c(ndraws, ncat)) + + # sratio(): + d_sratio <- dsratio(seq_len(ncat), + eta_test, thres_test, link = link) + d_sratio_ch <- inv_link_sratio_ch(thres_eta, link = link) + expect_equivalent(d_sratio, d_sratio_ch) + expect_equal(dim(d_sratio), c(ndraws, ncat)) + + # cratio(): + d_cratio <- dcratio(seq_len(ncat), + eta_test, thres_test, link = link) + d_cratio_ch <- inv_link_cratio_ch(eta_thres, link = link) + expect_equivalent(d_cratio, d_cratio_ch) + expect_equal(dim(d_cratio), c(ndraws, ncat)) + + # acat(): + d_acat <- dacat(seq_len(ncat), + eta_test, thres_test, link = link) + d_acat_ch <- inv_link_acat_ch(eta_thres, link = link) + expect_equivalent(d_acat, d_acat_ch) + expect_equal(dim(d_acat), c(ndraws, ncat)) + } + } + } + } +}) + +test_that("inv_link_() works correctly for arrays", { + source(testthat::test_path(file.path("helpers", "inv_link_ordinal_ch.R"))) + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), + dim = c(ndraws, nobsv, ncat - 1)) + nx_test <- -x_test + for (link in c("logit", "probit", "cauchit", "cloglog")) { + # cumulative(): + il_cumul <- inv_link_cumulative(x_test, link = link) + il_cumul_ch <- inv_link_cumulative_ch(x_test, link = link) + expect_equivalent(il_cumul, il_cumul_ch) + expect_equal(dim(il_cumul), c(ndraws, nobsv, ncat)) + + # sratio(): + il_sratio <- inv_link_sratio(x_test, link = link) + il_sratio_ch <- inv_link_sratio_ch(x_test, link = link) + expect_equivalent(il_sratio, il_sratio_ch) + expect_equal(dim(il_sratio), c(ndraws, nobsv, ncat)) + + # cratio(): + il_cratio <- inv_link_cratio(nx_test, link = link) + il_cratio_ch <- inv_link_cratio_ch(nx_test, link = link) + expect_equivalent(il_cratio, il_cratio_ch) + expect_equal(dim(il_cratio), c(ndraws, nobsv, ncat)) + + # acat(): + il_acat <- inv_link_acat(nx_test, link = link) + il_acat_ch <- inv_link_acat_ch(nx_test, link = link) + expect_equivalent(il_acat, il_acat_ch) + expect_equal(dim(il_acat), c(ndraws, nobsv, ncat)) + } + } + } + } +}) + +test_that("link_() works correctly for arrays", { + source(testthat::test_path(file.path("helpers", "link_ordinal_ch.R"))) + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), + dim = c(ndraws, nobsv, ncat)) + for (link in c("logit", "probit", "cauchit", "cloglog")) { + # cumulative(): + l_cumul <- link_cumulative(x_test, link = link) + l_cumul_ch <- link_cumulative_ch(x_test, link = link) + expect_equivalent(l_cumul, l_cumul_ch) + expect_equal(dim(l_cumul), c(ndraws, nobsv, ncat - 1)) + + # sratio(): + l_sratio <- link_sratio(x_test, link = link) + l_sratio_ch <- link_sratio_ch(x_test, link = link) + expect_equivalent(l_sratio, l_sratio_ch) + expect_equal(dim(l_sratio), c(ndraws, nobsv, ncat - 1)) + + # cratio(): + l_cratio <- link_cratio(x_test, link = link) + l_cratio_ch <- link_cratio_ch(x_test, link = link) + expect_equivalent(l_cratio, l_cratio_ch) + expect_equal(dim(l_cratio), c(ndraws, nobsv, ncat - 1)) + + # acat(): + l_acat <- link_acat(x_test, link = link) + l_acat_ch <- link_acat_ch(x_test, link = link) + expect_equivalent(l_acat, l_acat_ch) + expect_equal(dim(l_acat), c(ndraws, nobsv, ncat - 1)) + } + } + } + } +}) + +test_that("inv_link_() inverts link_()", { + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), + dim = c(ndraws, nobsv, ncat)) + for (link in c("logit", "probit", "cauchit", "cloglog")) { + # cumulative(): + l_cumul <- link_cumulative(x_test, link = link) + il_cumul <- inv_link_cumulative(l_cumul, link = link) + expect_equivalent(il_cumul, x_test) + + # sratio(): + l_sratio <- link_sratio(x_test, link = link) + il_sratio <- inv_link_sratio(l_sratio, link = link) + expect_equivalent(il_sratio, x_test) + + # cratio(): + l_cratio <- link_cratio(x_test, link = link) + il_cratio <- inv_link_cratio(l_cratio, link = link) + expect_equivalent(il_cratio, x_test) + + # acat(): + l_acat <- link_acat(x_test, link = link) + il_acat <- inv_link_acat(l_acat, link = link) + expect_equivalent(il_acat, x_test) + } + } + } + } +}) + +test_that("link_() inverts inv_link_()", { + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), + dim = c(ndraws, nobsv, ncat - 1)) + nx_test <- -x_test + for (link in c("logit", "probit", "cauchit", "cloglog")) { + # cumulative(): + il_cumul <- inv_link_cumulative(x_test, link = link) + l_cumul <- link_cumulative(il_cumul, link = link) + expect_equivalent(l_cumul, x_test) + + # sratio(): + il_sratio <- inv_link_sratio(x_test, link = link) + l_sratio <- link_sratio(il_sratio, link = link) + expect_equivalent(l_sratio, x_test) + + # cratio(): + il_cratio <- inv_link_cratio(x_test, link = link) + l_cratio <- link_cratio(il_cratio, link = link) + expect_equivalent(l_cratio, x_test) + + # acat(): + il_acat <- inv_link_acat(x_test, link = link) + l_acat <- link_acat(il_acat, link = link) + expect_equivalent(l_acat, x_test) + } + } + } + } +}) + +test_that(paste( + "dsratio() and dcratio() give the same results for symmetric distribution", + "functions" +), { + source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) + for (ndraws in ndraws_vec) { + for (ncat in ncat_vec) { + thres_test <- matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) + # Emulate no category-specific effects (i.e., only a single vector of + # linear predictors) as well as category-specific effects (i.e., a matrix + # of linear predictors): + eta_test_list <- list( + rnorm(ndraws), + matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) + ) + for (eta_test in eta_test_list) { + for (link in c("logit", "probit", "cauchit", "cloglog")) { + d_sratio <- dsratio(seq_len(ncat), + eta_test, thres_test, link = link) + d_cratio <- dcratio(seq_len(ncat), + eta_test, thres_test, link = link) + if (link != "cloglog") { + expect_equal(d_sratio, d_cratio) + } else { + expect_false(isTRUE(all.equal(d_sratio, d_cratio))) + } + } + } + } + } +}) + +test_that(paste( + "inv_link_sratio() and inv_link_cratio() applied to arrays give the same", + "results for symmetric distribution functions (when respecting the sign", + "appropriately)." +), { + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), + dim = c(ndraws, nobsv, ncat - 1)) + nx_test <- -x_test + for (link in c("logit", "probit", "cauchit", "cloglog")) { + il_sratio <- inv_link_sratio(x_test, link = link) + il_cratio <- inv_link_cratio(nx_test, link = link) + if (link != "cloglog") { + expect_equal(il_sratio, il_cratio) + } else { + expect_false(isTRUE(all.equal(il_sratio, il_cratio))) + } + } + } + } + } +}) + +test_that(paste( + "link_sratio() and link_cratio() applied to arrays give the same", + "results for symmetric distribution functions (when respecting the sign", + "appropriately)." +), { + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), + dim = c(ndraws, nobsv, ncat)) + for (link in c("logit", "probit", "cauchit", "cloglog")) { + l_sratio <- link_sratio(x_test, link = link) + l_cratio <- link_cratio(x_test, link = link) + if (link != "cloglog") { + expect_equal(l_sratio, -l_cratio) + } else { + expect_false(isTRUE(all.equal(l_sratio, -l_cratio))) + } + } + } + } + } +}) + +test_that("dcategorical() works correctly", { + source(testthat::test_path(file.path("helpers", "inv_link_categorical_ch.R"))) + source(testthat::test_path(file.path("helpers", "simopts_catlike_oneobs.R"))) + for (ndraws in ndraws_vec) { + for (ncat in ncat_vec) { + eta_test_list <- list(cbind( + 0, matrix(rnorm(ndraws * (ncat - 1)), nrow = ndraws) + )) + if (ndraws == 1) { + eta_test_list <- c(eta_test_list, list(c(0, rnorm(ncat - 1)))) + } + for (eta_test in eta_test_list) { + d_categorical <- dcategorical(seq_len(ncat), eta_test) + d_categorical_ch <- inv_link_categorical_ch(eta_test, + refcat_ins = FALSE) + expect_equivalent(d_categorical, d_categorical_ch) + expect_equal(dim(d_categorical), c(ndraws, ncat)) + } + } + } +}) + +test_that("inv_link_categorical() works correctly for arrays", { + source(testthat::test_path(file.path("helpers", "inv_link_categorical_ch.R"))) + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), + dim = c(ndraws, nobsv, ncat - 1)) + il_categorical <- inv_link_categorical(x_test) + il_categorical_ch <- inv_link_categorical_ch(x_test) + expect_equivalent(il_categorical, il_categorical_ch) + expect_equal(dim(il_categorical), c(ndraws, nobsv, ncat)) + } + } + } +}) + +test_that("link_categorical() works correctly for arrays", { + source(testthat::test_path(file.path("helpers", "link_categorical_ch.R"))) + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), + dim = c(ndraws, nobsv, ncat)) + l_categorical <- link_categorical(x_test) + l_categorical_ch <- link_categorical_ch(x_test) + expect_equivalent(l_categorical, l_categorical_ch) + expect_equal(dim(l_categorical), c(ndraws, nobsv, ncat - 1)) + } + } + } +}) + +test_that("inv_link_categorical() inverts link_categorical()", { + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rdirichlet(ndraws * nobsv, alpha = rep(1, ncat)), + dim = c(ndraws, nobsv, ncat)) + l_categorical <- link_categorical(x_test) + il_categorical <- inv_link_categorical(l_categorical) + expect_equivalent(il_categorical, x_test) + } + } + } +}) + +test_that("link_categorical() inverts inv_link_categorical()", { + source(testthat::test_path(file.path("helpers", "simopts_catlike.R"))) + for (ndraws in ndraws_vec) { + for (nobsv in nobsv_vec) { + for (ncat in ncat_vec) { + x_test <- array(rnorm(ndraws * nobsv * (ncat - 1)), + dim = c(ndraws, nobsv, ncat - 1)) + il_categorical <- inv_link_categorical(x_test) + l_categorical <- link_categorical(il_categorical) + expect_equivalent(l_categorical, x_test) + } + } + } +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.emmeans.R r-cran-brms-2.17.0/tests/testthat/tests.emmeans.R --- r-cran-brms-2.16.3/tests/testthat/tests.emmeans.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.emmeans.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,51 +1,51 @@ -context("Tests for emmeans support") - -skip_on_cran() - -require(emmeans) - -SW <- suppressWarnings -fit1 <- rename_pars(brms:::brmsfit_example1) -fit2 <- rename_pars(brms:::brmsfit_example2) -fit4 <- rename_pars(brms:::brmsfit_example4) -fit6 <- rename_pars(brms:::brmsfit_example6) - -test_that("emmeans returns expected output structure", { - em <- summary(emmeans(fit1, "Age", by = "Trt")) - expect_equal(nrow(em), 2) - - em <- summary(emmeans(fit1, "Trt", dpar = "sigma")) - expect_equal(nrow(em), 2) - - em <- summary(emmeans(fit1, "Age", by = "Exp")) - expect_equal(nrow(em), 5) - - em <- summary(emmeans(fit1, "Exp")) - expect_equal(nrow(em), 5) - - em <- SW(summary(emmeans(fit2, "Age", nlpar = "a"))) - expect_equal(nrow(em), 1) - - em <- SW(summary(emmeans(fit4, "x1", dpar = "mu"))) - expect_equal(nrow(em), 1) -}) - -test_that("emmeans supports 'epred' predictions", { - em <- summary(emmeans(fit2, "Age", epred = TRUE)) - expect_equal(nrow(em), 1) - - em <- summary(emmeans(fit2, "Age", by = "Trt", epred = TRUE)) - expect_equal(nrow(em), 2) - - # test for a multivariate model - em <- summary(emmeans(fit6, "Age", by = "Trt", epred = TRUE)) - expect_equal(nrow(em), 2) -}) - -test_that("emmeans supports multilevel terms", { - em <- summary(emmeans(fit1, "Age", by = "Trt", re_formula = NULL)) - expect_equal(nrow(em), 2) - - em <- SW(summary(emmeans(fit2, "Age", nlpar = "a", re_formula = NULL))) - expect_equal(nrow(em), 1) -}) +context("Tests for emmeans support") + +skip_on_cran() + +require(emmeans) + +SW <- suppressWarnings +fit1 <- rename_pars(brms:::brmsfit_example1) +fit2 <- rename_pars(brms:::brmsfit_example2) +fit4 <- rename_pars(brms:::brmsfit_example4) +fit6 <- rename_pars(brms:::brmsfit_example6) + +test_that("emmeans returns expected output structure", { + em <- summary(emmeans(fit1, "Age", by = "Trt")) + expect_equal(nrow(em), 2) + + em <- summary(emmeans(fit1, "Trt", dpar = "sigma")) + expect_equal(nrow(em), 2) + + em <- summary(emmeans(fit1, "Age", by = "Exp")) + expect_equal(nrow(em), 5) + + em <- summary(emmeans(fit1, "Exp")) + expect_equal(nrow(em), 5) + + em <- SW(summary(emmeans(fit2, "Age", nlpar = "a"))) + expect_equal(nrow(em), 1) + + em <- SW(summary(emmeans(fit4, "x1", dpar = "mu"))) + expect_equal(nrow(em), 1) +}) + +test_that("emmeans supports 'epred' predictions", { + em <- summary(emmeans(fit2, "Age", epred = TRUE)) + expect_equal(nrow(em), 1) + + em <- summary(emmeans(fit2, "Age", by = "Trt", epred = TRUE)) + expect_equal(nrow(em), 2) + + # test for a multivariate model + em <- summary(emmeans(fit6, "Age", by = "Trt", epred = TRUE)) + expect_equal(nrow(em), 2) +}) + +test_that("emmeans supports multilevel terms", { + em <- summary(emmeans(fit1, "Age", by = "Trt", re_formula = NULL)) + expect_equal(nrow(em), 2) + + em <- SW(summary(emmeans(fit2, "Age", nlpar = "a", re_formula = NULL))) + expect_equal(nrow(em), 1) +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.exclude_pars.R r-cran-brms-2.17.0/tests/testthat/tests.exclude_pars.R --- r-cran-brms-2.16.3/tests/testthat/tests.exclude_pars.R 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.exclude_pars.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,48 +1,48 @@ -context("Tests for exclude_pars helper functions") - -test_that("exclude_pars returns expected parameter names", { - dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), - g = rep(1:5, 2), h = factor(rep(1:5, each = 2))) - - fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, - empty = TRUE) - ep <- brms:::exclude_pars(fit) - expect_true(all(c("r_1", "r_2") %in% ep)) - - fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, - empty = TRUE, save_pars = save_pars(all = TRUE)) - ep <- brms:::exclude_pars(fit) - expect_true(!any(c("z_1", "z_2") %in% ep)) - - fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, - empty = TRUE, save_pars = save_pars(group = FALSE)) - ep <- brms:::exclude_pars(fit) - expect_true("r_1_1" %in% ep) - - fit <- brm(y ~ x1*x2 + (x1 | g) + (1 | h), dat, - empty = TRUE, save_pars = save_pars(group = "h")) - ep <- brms:::exclude_pars(fit) - expect_true(!"r_1_3" %in% ep) - - fit <- brm(y ~ s(x1) + x2, dat, empty = TRUE) - ep <- brms:::exclude_pars(fit) - expect_true("zs_1_1" %in% ep) - - fit <- brm(bf(y ~ eta, eta ~ x1 + s(x2), nl = TRUE), dat, empty = TRUE) - ep <- brms:::exclude_pars(fit) - expect_true("zs_eta_1_1" %in% ep) - - fit <- brm(y ~ me(x1, g), dat, empty = TRUE) - ep <- brms:::exclude_pars(fit) - expect_true("Xme_1" %in% ep) - - fit <- brm(y ~ me(x1, g), dat, empty = TRUE, - save_pars = save_pars(latent = "x1")) - ep <- brms:::exclude_pars(fit) - expect_true(!"Xme_1" %in% ep) - - fit <- brm(y ~ me(x1, g), dat, empty = TRUE, - save_pars = save_pars(manual = "Lme_1")) - ep <- brms:::exclude_pars(fit) - expect_true(!"Lme_1" %in% ep) -}) +context("Tests for exclude_pars helper functions") + +test_that("exclude_pars returns expected parameter names", { + dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), + g = rep(1:5, 2), h = factor(rep(1:5, each = 2))) + + fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, + empty = TRUE) + ep <- brms:::exclude_pars(fit) + expect_true(all(c("r_1", "r_2") %in% ep)) + + fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, + empty = TRUE, save_pars = save_pars(all = TRUE)) + ep <- brms:::exclude_pars(fit) + expect_true(!any(c("z_1", "z_2") %in% ep)) + + fit <- brm(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, + empty = TRUE, save_pars = save_pars(group = FALSE)) + ep <- brms:::exclude_pars(fit) + expect_true("r_1_1" %in% ep) + + fit <- brm(y ~ x1*x2 + (x1 | g) + (1 | h), dat, + empty = TRUE, save_pars = save_pars(group = "h")) + ep <- brms:::exclude_pars(fit) + expect_true(!"r_1_3" %in% ep) + + fit <- brm(y ~ s(x1) + x2, dat, empty = TRUE) + ep <- brms:::exclude_pars(fit) + expect_true("zs_1_1" %in% ep) + + fit <- brm(bf(y ~ eta, eta ~ x1 + s(x2), nl = TRUE), dat, empty = TRUE) + ep <- brms:::exclude_pars(fit) + expect_true("zs_eta_1_1" %in% ep) + + fit <- brm(y ~ me(x1, g), dat, empty = TRUE) + ep <- brms:::exclude_pars(fit) + expect_true("Xme_1" %in% ep) + + fit <- brm(y ~ me(x1, g), dat, empty = TRUE, + save_pars = save_pars(latent = "x1")) + ep <- brms:::exclude_pars(fit) + expect_true(!"Xme_1" %in% ep) + + fit <- brm(y ~ me(x1, g), dat, empty = TRUE, + save_pars = save_pars(manual = "Lme_1")) + ep <- brms:::exclude_pars(fit) + expect_true(!"Lme_1" %in% ep) +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.families.R r-cran-brms-2.17.0/tests/testthat/tests.families.R --- r-cran-brms-2.16.3/tests/testthat/tests.families.R 2020-10-08 06:56:22.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.families.R 2022-04-08 12:23:23.000000000 +0000 @@ -3,7 +3,6 @@ test_that("family functions returns expected results", { expect_equal(student(identity)$link, "identity") expect_equal(student()$link, "identity") - expect_error(student("logit"), "student") expect_equal(bernoulli(logit)$link, "logit") expect_error(bernoulli("sqrt"), "bernoulli") expect_equal(negbinomial(sqrt)$link, "sqrt") @@ -15,7 +14,7 @@ expect_equal(weibull()$family, "weibull") expect_error(weibull(sqrt), "weibull") expect_equal(Beta("probit")$link, "probit") - expect_error(Beta(log), "beta") + expect_error(Beta("1/mu^2"), "beta") expect_equal(hurdle_poisson()$link, "log") expect_equal(hurdle_negbinomial(log)$link, "log") expect_error(hurdle_negbinomial("inverse"), "hurdle_negbinomial") @@ -24,9 +23,9 @@ expect_equal(zero_inflated_poisson(log)$link, "log") expect_error(zero_inflated_poisson(list(1)), "zero_inflated_poisson") expect_equal(zero_inflated_negbinomial("log")$link, "log") - expect_error(zero_inflated_negbinomial("logit"), + expect_error(zero_inflated_negbinomial("logit"), "zero_inflated_negbinomial") - expect_equal(zero_inflated_beta(logit)$family, + expect_equal(zero_inflated_beta(logit)$family, "zero_inflated_beta") expect_equivalent(zero_inflated_binomial()$link_zi, "logit") expect_error(zero_inflated_binomial(y~x), "zero_inflated_binomial") @@ -39,11 +38,25 @@ expect_equal(brmsfamily("gaussian", inverse)$link, "inverse") expect_equal(brmsfamily("geometric", "identity")$family, "geometric") expect_equal(brmsfamily("zi_poisson")$link_zi, "logit") - - expect_error(weibull(link_shape = "logit"), + + expect_error(weibull(link_shape = "logit"), "'logit' is not a supported link for parameter 'shape'") expect_error(weibull(link_shape = c("log", "logit")), "Cannot coerce 'alink' to a single character value") + + expect_equal(beta_binomial()$link, "logit") + expect_equal(beta_binomial('probit')$link, "probit") + expect_equal(beta_binomial()$link_phi, "log") + expect_error(beta_binomial('log')) + expect_error(beta_binomial(link_phi = 'logit')) + expect_equal(zero_inflated_beta_binomial()$link, "logit") + expect_equal(zero_inflated_beta_binomial('probit')$link, "probit") + expect_equal(zero_inflated_beta_binomial()$link_phi, "log") + expect_equal(zero_inflated_beta_binomial()$link_zi, "logit") + expect_equal(zero_inflated_beta_binomial(link_zi = "identity")$link_zi, "identity") + expect_error(zero_inflated_beta_binomial('sqrt')) + expect_error(zero_inflated_beta_binomial(link_phi = 'logit')) + expect_error(zero_inflated_beta_binomial(link_zi = 'log')) }) test_that("print brmsfamily works correctly", { @@ -55,18 +68,18 @@ expect_equal(brms:::family_names(mix), rep("gaussian", 3)) mix <- mixture(gaussian, student, weibull, nmix = 3:1) expect_equal( - brms:::family_names(mix), + brms:::family_names(mix), c(rep("gaussian", 3), rep("student", 2), "weibull") ) - expect_error(mixture(gaussian, "x"), + expect_error(mixture(gaussian, "x"), "x is not a supported family") - expect_error(mixture(poisson(), categorical()), + expect_error(mixture(poisson(), categorical()), "Some of the families are not allowed in mixture models") expect_error(mixture(poisson, "cumulative"), "Cannot mix ordinal and non-ordinal families") - expect_error(mixture(lognormal, exgaussian, poisson()), + expect_error(mixture(lognormal, exgaussian, poisson()), "Cannot mix families with real and integer support") - expect_error(mixture(lognormal), + expect_error(mixture(lognormal), "Expecting at least 2 mixture components") expect_error(mixture(poisson, binomial, order = "x"), "Argument 'order' is invalid") diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.log_lik.R r-cran-brms-2.17.0/tests/testthat/tests.log_lik.R --- r-cran-brms-2.16.3/tests/testthat/tests.log_lik.R 2021-08-26 17:47:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.log_lik.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,497 +1,520 @@ -context("Tests for log_lik helper functions") - -test_that("log_lik for location shift models works as expected", { - ns <- 25 - prep <- structure(list(), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * 2), ncol = 2), - sigma = rchisq(ns, 3), nu = rgamma(ns, 4) - ) - prep$family <- gaussian() - prep$family$fun <- "gaussian" - prep$data <- list(Y = rnorm(ns)) - - ll_gaussian <- dnorm( - x = prep$data$Y[1], mean = prep$dpars$mu[, 1], - sd = prep$dpars$sigma, log = TRUE - ) - ll <- brms:::log_lik_gaussian(1, prep = prep) - expect_equal(ll, ll_gaussian) - - ll_student <- dstudent_t( - x = prep$data$Y[2], df = prep$dpars$nu, - mu = prep$dpars$mu[, 2], - sigma = prep$dpars$sigma, log = TRUE - ) - ll <- brms:::log_lik_student(2, prep = prep) - expect_equal(ll, ll_student) - - # also test weighting - prep$data$weights <- sample(1:10, ns, replace = TRUE) - ll <- brms:::log_lik_gaussian(1, prep = prep) - expect_equal(ll, ll_gaussian * prep$data$weights[1]) -}) - -test_that("log_lik for various skewed normal models works as expected", { - ns <- 50 - prep <- structure(list(), class = "brmsprep") - prep$dpars <- list( - sigma = rchisq(ns, 3), beta = rchisq(ns, 3), - mu = matrix(rnorm(ns*2), ncol = 2), - alpha = rnorm(ns), ndt = 1 - ) - prep$data <- list(Y = rlnorm(ns)) - - ll_lognormal <- dlnorm( - x = prep$data$Y[1], mean = prep$dpars$mu[, 1], - sd = prep$dpars$sigma, log = TRUE - ) - ll <- brms:::log_lik_lognormal(1, prep = prep) - expect_equal(ll, ll_lognormal) - - ll_shifted_lognormal <- dshifted_lnorm( - x = prep$data$Y[1], mean = prep$dpars$mu[, 1], - sd = prep$dpars$sigma, shift = prep$dpars$ndt, log = TRUE - ) - ll <- brms:::log_lik_shifted_lognormal(1, prep = prep) - expect_equal(ll, ll_shifted_lognormal) - - ll_exgaussian <- dexgaussian( - x = prep$data$Y[1], mu = prep$dpars$mu[, 1], - sigma = prep$dpars$sigma, beta = prep$dpars$beta, log = TRUE - ) - ll <- brms:::log_lik_exgaussian(1, prep = prep) - expect_equal(ll, ll_exgaussian) - - ll_skew_normal <- dskew_normal( - x = prep$data$Y[1], mu = prep$dpars$mu[, 1], - sigma = prep$dpars$sigma, alpha = prep$dpars$alpha, log = TRUE - ) - ll <- as.numeric(brms:::log_lik_skew_normal(1, prep = prep)) - expect_equal(ll, ll_skew_normal) -}) - -test_that("log_lik of aysm_laplace models runs without errors", { - ns <- 50 - prep <- structure(list(), class = "brmsprep") - prep$dpars <- list( - sigma = rchisq(ns, 3), - quantile = rbeta(ns, 2, 1), - mu = matrix(rnorm(ns*2), ncol = 2), - zi = rbeta(ns, 10, 10) - ) - prep$data <- list(Y = brms:::rasym_laplace(ns)) - ll <- brms:::log_lik_asym_laplace(1, prep = prep) - expect_equal(length(ll), ns) - - ll <- brms:::log_lik_zero_inflated_asym_laplace(1, prep = prep) - expect_equal(length(ll), ns) -}) - -test_that("log_lik for multivariate linear models runs without errors", { - ns <- 10 - nvars <- 3 - ncols <- 4 - nobs <- nvars * ncols - prep <- structure(list(), class = "mvbrmsprep") - Sigma = array(cov(matrix(rnorm(300), ncol = 3)), dim = c(3, 3, 10)) - prep$mvpars <- list( - Mu = array(rnorm(ns*nobs*nvars), dim = c(ns, nobs, nvars)), - Sigma = aperm(Sigma, c(3, 1, 2)) - ) - prep$dpars <- list(nu = rgamma(ns, 5)) - prep$ndraws <- ns - prep$data <- list(Y = matrix(rnorm(nobs), ncol = nvars)) - - ll <- brms:::log_lik_gaussian_mv(1, prep = prep) - expect_equal(length(ll), ns) - ll <- brms:::log_lik_student_mv(2, prep = prep) - expect_equal(length(ll), ns) -}) - -test_that("log_lik for ARMA models runs without errors", { - ns <- 20 - nobs <- 15 - prep <- structure(list(ndraws = ns), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns*nobs), ncol = nobs), - sigma = rchisq(ns, 3), - nu = rgamma(ns, 5) + 15 - ) - prep$ac <- list( - ar = matrix(rbeta(ns, 0.5, 0.5), ncol = 1), - ma = matrix(rbeta(ns, 0.2, 1), ncol = 1), - begin_tg = 2, end_tg = 5 - ) - prep$data <- list(Y = rnorm(nobs), se = rgamma(ns, 10)) - - prep$family$fun <- "gaussian_time" - ll <- brms:::log_lik_gaussian_time(1, prep = prep) - expect_equal(dim(ll), c(ns, 4)) - prep$family$fun <- "student_time" - ll <- brms:::log_lik_student_time(1, prep = prep) - expect_equal(dim(ll), c(ns, 4)) -}) - -test_that("log_lik for SAR models runs without errors", { - prep <- structure(list(ndraws = 3, nobs = 10), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(30), nrow = 3), - nu = rep(10, 3), - sigma = rep(10, 3) - ) - prep$ac <- list( - lagsar = matrix(c(0.3, 0.5, 0.7)), - Msar = diag(10) - ) - prep$data <- list(Y = rnorm(10)) - - ll <- brms:::log_lik_gaussian_lagsar(1, prep = prep) - expect_equal(dim(ll), c(3, 10)) - ll <- brms:::log_lik_student_lagsar(1, prep = prep) - expect_equal(dim(ll), c(3, 10)) - - prep$ac$errorsar <- prep$ac$lagsar - prep$ac$lagsar <- NULL - ll <- brms:::log_lik_gaussian_errorsar(1, prep = prep) - expect_equal(dim(ll), c(3, 10)) - ll <- brms:::log_lik_student_errorsar(1, prep = prep) - expect_equal(dim(ll), c(3, 10)) -}) - -test_that("log_lik for FCOR models runs without errors", { - ns <- 3 - nobs <- 10 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(nobs * ns), nrow = ns), - sigma = rep(1, ns), - nu = rep(10, ns) - ) - prep$ac <- list(Mfcor = diag(nobs)) - prep$data$Y <- rnorm(nobs) - ll <- brms:::log_lik_gaussian_fcor(1, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - ll <- brms:::log_lik_student_fcor(1, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) -}) - -test_that("log_lik for count and survival models works correctly", { - ns <- 25 - nobs <- 10 - trials <- sample(10:30, nobs, replace = TRUE) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - eta = matrix(rnorm(ns*nobs), ncol = nobs), - shape = rgamma(ns, 4), - xi = runif(ns, -1, 0.5) - ) - prep$dpars$sigma <- 1 / prep$dpars$shape - prep$dpars$nu <- prep$dpars$shape + 1 - prep$data <- list( - Y = rbinom(nobs, size = trials, prob = rbeta(nobs, 1, 1)), - trials = trials - ) - i <- sample(nobs, 1) - - prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) - ll_binom <- dbinom( - x = prep$data$Y[i], prob = prep$dpars$mu[, i], - size = prep$data$trials[i], log = TRUE - ) - ll <- brms:::log_lik_binomial(i, prep = prep) - expect_equal(ll, ll_binom) - - # don't test the actual values as they will be -Inf for this data - ll <- brms:::log_lik_discrete_weibull(i, prep = prep) - expect_equal(length(ll), ns) - - prep$dpars$mu <- exp(prep$dpars$eta) - ll_pois <- dpois( - x = prep$data$Y[i], lambda = prep$dpars$mu[, i], log = TRUE - ) - ll <- brms:::log_lik_poisson(i, prep = prep) - expect_equal(ll, ll_pois) - - ll_nbinom <- dnbinom( - x = prep$data$Y[i], mu = prep$dpars$mu[, i], - size = prep$dpars$shape, log = TRUE - ) - ll <- brms:::log_lik_negbinomial(i, prep = prep) - expect_equal(ll, ll_nbinom) - - ll <- brms:::log_lik_negbinomial2(i, prep = prep) - expect_equal(ll, ll_nbinom) - - ll_geo <- dnbinom( - x = prep$data$Y[i], mu = prep$dpars$mu[, i], - size = 1, log = TRUE - ) - ll <- brms:::log_lik_geometric(i, prep = prep) - expect_equal(ll, ll_geo) - - ll_com_pois <- brms:::dcom_poisson( - x = prep$data$Y[i], mu = prep$dpars$mu[, i], - shape = prep$dpars$shape, log = TRUE - ) - ll <- brms:::log_lik_com_poisson(i, prep = prep) - expect_equal(ll, ll_com_pois) - - ll_exp <- dexp( - x = prep$data$Y[i], rate = 1 / prep$dpars$mu[, i], log = TRUE - ) - ll <- brms:::log_lik_exponential(i, prep = prep) - expect_equal(ll, ll_exp) - - ll_gamma <- dgamma( - x = prep$data$Y[i], shape = prep$dpars$shape, - scale = prep$dpars$mu[, i] / prep$dpars$shape, - log = TRUE - ) - ll <- brms:::log_lik_gamma(i, prep = prep) - expect_equal(ll, ll_gamma) - - scale <- prep$dpars$mu[, i] / gamma(1 - 1 / prep$dpars$nu) - ll_frechet <- dfrechet( - x = prep$data$Y[i], shape = prep$dpars$nu, - scale = scale, log = TRUE - ) - ll <- brms:::log_lik_frechet(i, prep = prep) - expect_equal(ll, ll_frechet) - - ll_invgauss <- dinv_gaussian( - x = prep$data$Y[i], shape = prep$dpars$shape, - mu = prep$dpars$mu[, i], log = TRUE - ) - ll <- brms:::log_lik_inverse.gaussian(i, prep = prep) - expect_equal(ll, ll_invgauss) - - ll_weibull <- dweibull( - x = prep$data$Y[i], shape = prep$dpars$shape, - scale = prep$dpars$mu[, i] / gamma(1 + 1 / prep$dpars$shape), - log = TRUE - ) - ll <- brms:::log_lik_weibull(i, prep = prep) - expect_equal(ll, c(ll_weibull)) - - # keep test at the end - prep$family$link <- "identity" - prep$data$Y[i] <- 0 - ll_gen_extreme_value <- SW(dgen_extreme_value( - x = prep$data$Y[i], mu = prep$dpars$mu[, i], - sigma = prep$dpars$sigma, xi = prep$dpars$xi, log = TRUE - )) - ll <- SW(brms:::log_lik_gen_extreme_value(i, prep = prep)) - expect_equal(ll, ll_gen_extreme_value) -}) - -test_that("log_lik for bernoulli and beta models works correctly", { - ns <- 15 - nobs <- 10 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = brms:::inv_logit(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), - phi = rgamma(ns, 4) - ) - prep$data <- list(Y = sample(0:1, nobs, replace = TRUE)) - - i <- sample(1:nobs, 1) - ll_bern <- dbinom( - x = prep$data$Y[i], prob = prep$dpars$mu[, i], size = 1, log = TRUE - ) - ll <- brms:::log_lik_bernoulli(i, prep = prep) - expect_equal(ll, ll_bern) - - prep$data <- list(Y = rbeta(nobs, 1, 1)) - ll_beta <- dbeta( - x = prep$data$Y[i], shape1 = prep$dpars$mu[, i] * prep$dpars$phi, - shape2 = (1 - prep$dpars$mu[, i]) * prep$dpars$phi, log = TRUE - ) - ll <- brms:::log_lik_beta(i, prep = prep) - expect_equal(ll, ll_beta) -}) - -test_that("log_lik for circular models runs without errors", { - ns <- 15 - nobs <- 10 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = 2 * atan(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), - kappa = rgamma(ns, 4) - ) - prep$data <- list(Y = runif(nobs, -pi, pi)) - i <- sample(seq_len(nobs), 1) - ll <- brms:::log_lik_von_mises(i, prep = prep) - expect_equal(length(ll), ns) - prep$data$cens <- sample(-1:1, nobs, TRUE) - ll <- brms:::log_lik_von_mises(i, prep = prep) - expect_equal(length(ll), ns) -}) - -test_that("log_lik for zero-inflated and hurdle models runs without erros", { - ns <- 50 - nobs <- 8 - trials <- sample(10:30, nobs, replace = TRUE) - resp <- rbinom(nobs, size = trials, prob = rbeta(nobs, 1, 1)) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - eta = matrix(rnorm(ns*nobs), ncol = nobs), - shape = rgamma(ns, 4), - phi = rgamma(ns, 1), - zi = rbeta(ns, 1, 1), - coi = rbeta(ns, 5, 7) - ) - prep$dpars$hu <- prep$dpars$zoi <- prep$dpars$zi - prep$data <- list(Y = c(resp, rep(0, 4)), trials = trials) - - prep$dpars$mu <- exp(prep$dpars$eta) - ll <- brms:::log_lik_hurdle_poisson(1, prep = prep) - expect_equal(length(ll), ns) - - ll <- brms:::log_lik_hurdle_negbinomial(5, prep = prep) - expect_equal(length(ll), ns) - - ll <- brms:::log_lik_hurdle_gamma(2, prep = prep) - expect_equal(length(ll), ns) - - ll <- brms:::log_lik_hurdle_gamma(8, prep = prep) - expect_equal(length(ll), ns) - - ll <- brms:::log_lik_zero_inflated_poisson(3, prep = prep) - expect_equal(length(ll), ns) - - ll <- brms:::log_lik_zero_inflated_negbinomial(6, prep = prep) - expect_equal(length(ll), ns) - - prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) - ll <- brms:::log_lik_zero_inflated_binomial(4, prep = prep) - expect_equal(length(ll), ns) - - prep$data$Y[1:nobs] <- rbeta(nobs / 2, 0.5, 4) - ll <- brms:::log_lik_zero_inflated_beta(6, prep = prep) - expect_equal(length(ll), ns) - - ll <- brms:::log_lik_zero_one_inflated_beta(7, prep = prep) - expect_equal(length(ll), ns) -}) - -test_that("log_lik for ordinal models runs without erros", { - ns <- 50 - nobs <- 8 - nthres <- 3 - ncat <- nthres + 1 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = array(rnorm(ns * nobs), dim = c(ns, nobs)), - disc = rexp(ns) - ) - prep$thres$thres <- array(0, dim = c(ns, nthres)) - prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) - prep$family$link <- "logit" - - ll <- sapply(1:nobs, brms:::log_lik_cumulative, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - - ll <- sapply(1:nobs, brms:::log_lik_sratio, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - - ll <- sapply(1:nobs, brms:::log_lik_cratio, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - - ll <- sapply(1:nobs, brms:::log_lik_acat, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - - prep$family$link <- "probit" - ll <- sapply(1:nobs, brms:::log_lik_acat, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) -}) - -test_that("log_lik for categorical and related models runs without erros", { - ns <- 50 - nobs <- 8 - ncat <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu1 = array(rnorm(ns*nobs), dim = c(ns, nobs)), - mu2 = array(rnorm(ns*nobs), dim = c(ns, nobs)) - ) - prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) - prep$family <- categorical() - ll <- sapply(1:nobs, brms:::log_lik_categorical, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - - prep$data$Y <- matrix( - sample(1:20, nobs * ncat, TRUE), - nrow = nobs, ncol = ncat - ) - prep$data$trials <- sample(1:20, nobs) - prep$family <- multinomial() - ll <- sapply(1:nobs, brms:::log_lik_multinomial, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - - prep$data$Y <- prep$data$Y / rowSums(prep$data$Y) - prep$dpars$phi <- rexp(ns, 10) - prep$family <- dirichlet() - ll <- sapply(1:nobs, brms:::log_lik_dirichlet, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - - prep$family <- brmsfamily("dirichlet2") - prep$dpars$mu1 <- rexp(ns, 10) - prep$dpars$mu2 <- rexp(ns, 10) - prep$dpars$mu3 <- rexp(ns, 10) - ll <- sapply(1:nobs, brms:::log_lik_dirichlet2, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) -}) - -test_that("censored and truncated log_lik run without errors", { - ns <- 30 - nobs <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rchisq(ns, 3) - ) - prep$data <- list(Y = rnorm(ns), cens = c(-1,0,1)) - ll <- sapply(1:nobs, brms:::log_lik_gaussian, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) - prep$data <- list(Y = sample(-3:3, nobs), lb = -4, ub = 5) - ll <- sapply(1:nobs, brms:::log_lik_gaussian, prep = prep) - expect_equal(dim(ll), c(ns, nobs)) -}) - -test_that("log_lik for the wiener diffusion model runs without errors", { - ns <- 5 - nobs <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - bs = rchisq(ns, 3), ndt = rep(0.5, ns), - bias = rbeta(ns, 1, 1) - ) - prep$data <- list(Y = abs(rnorm(ns)) + 0.5, dec = c(1, 0, 1)) - i <- sample(1:nobs, 1) - expect_equal(length(brms:::log_lik_wiener(i, prep)), ns) -}) - -test_that("log_lik_custom runs without errors", { - ns <- 15 - nobs <- 10 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rbeta(ns * nobs * 2, 1, 1), ncol = nobs * 2) - ) - prep$data <- list( - Y = sample(0:1, nobs, replace = TRUE), - trials = rep(1, nobs) - ) - prep$family <- custom_family( - "beta_binomial2", dpars = c("mu", "tau"), - links = c("logit", "log"), lb = c(NA, 0), - type = "int", vars = "trials[n]" - ) - log_lik_beta_binomial2 <- function(i, prep) { - mu <- prep$dpars$mu[, i] - dbinom(prep$data$Y[i], size = prep$data$trials[i], prob = mu) - } - expect_equal(length(brms:::log_lik_custom(sample(1:nobs, 1), prep)), ns) -}) +context("Tests for log_lik helper functions") + +test_that("log_lik for location shift models works as expected", { + ns <- 25 + prep <- structure(list(), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * 2), ncol = 2), + sigma = rchisq(ns, 3), nu = rgamma(ns, 4) + ) + prep$family <- gaussian() + prep$family$fun <- "gaussian" + prep$data <- list(Y = rnorm(ns)) + + ll_gaussian <- dnorm( + x = prep$data$Y[1], mean = prep$dpars$mu[, 1], + sd = prep$dpars$sigma, log = TRUE + ) + ll <- brms:::log_lik_gaussian(1, prep = prep) + expect_equal(ll, ll_gaussian) + + ll_student <- dstudent_t( + x = prep$data$Y[2], df = prep$dpars$nu, + mu = prep$dpars$mu[, 2], + sigma = prep$dpars$sigma, log = TRUE + ) + ll <- brms:::log_lik_student(2, prep = prep) + expect_equal(ll, ll_student) + + # also test weighting + prep$data$weights <- sample(1:10, ns, replace = TRUE) + ll <- brms:::log_lik_gaussian(1, prep = prep) + expect_equal(ll, ll_gaussian * prep$data$weights[1]) +}) + +test_that("log_lik for various skewed normal models works as expected", { + ns <- 50 + prep <- structure(list(), class = "brmsprep") + prep$dpars <- list( + sigma = rchisq(ns, 3), beta = rchisq(ns, 3), + mu = matrix(rnorm(ns*2), ncol = 2), + alpha = rnorm(ns), ndt = 1 + ) + prep$data <- list(Y = rlnorm(ns)) + + ll_lognormal <- dlnorm( + x = prep$data$Y[1], mean = prep$dpars$mu[, 1], + sd = prep$dpars$sigma, log = TRUE + ) + ll <- brms:::log_lik_lognormal(1, prep = prep) + expect_equal(ll, ll_lognormal) + + ll_shifted_lognormal <- dshifted_lnorm( + x = prep$data$Y[1], mean = prep$dpars$mu[, 1], + sd = prep$dpars$sigma, shift = prep$dpars$ndt, log = TRUE + ) + ll <- brms:::log_lik_shifted_lognormal(1, prep = prep) + expect_equal(ll, ll_shifted_lognormal) + + ll_exgaussian <- dexgaussian( + x = prep$data$Y[1], mu = prep$dpars$mu[, 1], + sigma = prep$dpars$sigma, beta = prep$dpars$beta, log = TRUE + ) + ll <- brms:::log_lik_exgaussian(1, prep = prep) + expect_equal(ll, ll_exgaussian) + + ll_skew_normal <- dskew_normal( + x = prep$data$Y[1], mu = prep$dpars$mu[, 1], + sigma = prep$dpars$sigma, alpha = prep$dpars$alpha, log = TRUE + ) + ll <- as.numeric(brms:::log_lik_skew_normal(1, prep = prep)) + expect_equal(ll, ll_skew_normal) +}) + +test_that("log_lik of aysm_laplace models runs without errors", { + ns <- 50 + prep <- structure(list(), class = "brmsprep") + prep$dpars <- list( + sigma = rchisq(ns, 3), + quantile = rbeta(ns, 2, 1), + mu = matrix(rnorm(ns*2), ncol = 2), + zi = rbeta(ns, 10, 10) + ) + prep$data <- list(Y = brms:::rasym_laplace(ns)) + ll <- brms:::log_lik_asym_laplace(1, prep = prep) + expect_equal(length(ll), ns) + + ll <- brms:::log_lik_zero_inflated_asym_laplace(1, prep = prep) + expect_equal(length(ll), ns) +}) + +test_that("log_lik for multivariate linear models runs without errors", { + ns <- 10 + nvars <- 3 + ncols <- 4 + nobs <- nvars * ncols + prep <- structure(list(), class = "mvbrmsprep") + Sigma = array(cov(matrix(rnorm(300), ncol = 3)), dim = c(3, 3, 10)) + prep$mvpars <- list( + Mu = array(rnorm(ns*nobs*nvars), dim = c(ns, nobs, nvars)), + Sigma = aperm(Sigma, c(3, 1, 2)) + ) + prep$dpars <- list(nu = rgamma(ns, 5)) + prep$ndraws <- ns + prep$data <- list(Y = matrix(rnorm(nobs), ncol = nvars)) + + ll <- brms:::log_lik_gaussian_mv(1, prep = prep) + expect_equal(length(ll), ns) + ll <- brms:::log_lik_student_mv(2, prep = prep) + expect_equal(length(ll), ns) +}) + +test_that("log_lik for ARMA models runs without errors", { + ns <- 20 + nobs <- 15 + prep <- structure(list(ndraws = ns), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns*nobs), ncol = nobs), + sigma = rchisq(ns, 3), + nu = rgamma(ns, 5) + 15 + ) + prep$ac <- list( + ar = matrix(rbeta(ns, 0.5, 0.5), ncol = 1), + ma = matrix(rbeta(ns, 0.2, 1), ncol = 1), + begin_tg = 2, end_tg = 5 + ) + prep$data <- list(Y = rnorm(nobs), se = rgamma(ns, 10)) + + prep$family$fun <- "gaussian_time" + ll <- brms:::log_lik_gaussian_time(1, prep = prep) + expect_equal(dim(ll), c(ns, 4)) + prep$family$fun <- "student_time" + ll <- brms:::log_lik_student_time(1, prep = prep) + expect_equal(dim(ll), c(ns, 4)) +}) + +test_that("log_lik for SAR models runs without errors", { + prep <- structure(list(ndraws = 3, nobs = 10), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(30), nrow = 3), + nu = rep(10, 3), + sigma = rep(10, 3) + ) + prep$ac <- list( + lagsar = matrix(c(0.3, 0.5, 0.7)), + Msar = diag(10) + ) + prep$data <- list(Y = rnorm(10)) + + ll <- brms:::log_lik_gaussian_lagsar(1, prep = prep) + expect_equal(dim(ll), c(3, 10)) + ll <- brms:::log_lik_student_lagsar(1, prep = prep) + expect_equal(dim(ll), c(3, 10)) + + prep$ac$errorsar <- prep$ac$lagsar + prep$ac$lagsar <- NULL + ll <- brms:::log_lik_gaussian_errorsar(1, prep = prep) + expect_equal(dim(ll), c(3, 10)) + ll <- brms:::log_lik_student_errorsar(1, prep = prep) + expect_equal(dim(ll), c(3, 10)) +}) + +test_that("log_lik for FCOR models runs without errors", { + ns <- 3 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(nobs * ns), nrow = ns), + sigma = rep(1, ns), + nu = rep(10, ns) + ) + prep$ac <- list(Mfcor = diag(nobs)) + prep$data$Y <- rnorm(nobs) + ll <- brms:::log_lik_gaussian_fcor(1, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + ll <- brms:::log_lik_student_fcor(1, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) +}) + +test_that("log_lik for count and survival models works correctly", { + ns <- 25 + nobs <- 10 + trials <- sample(10:30, nobs, replace = TRUE) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + eta = matrix(rnorm(ns*nobs), ncol = nobs), + shape = rgamma(ns, 4), + xi = runif(ns, -1, 0.5), + phi = rgamma(ns, 1) + ) + prep$dpars$sigma <- 1 / prep$dpars$shape + prep$dpars$nu <- prep$dpars$shape + 1 + prep$data <- list( + Y = rbinom(nobs, size = trials, prob = rbeta(nobs, 1, 1)), + trials = trials + ) + i <- sample(nobs, 1) + + prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) + ll_binom <- dbinom( + x = prep$data$Y[i], prob = prep$dpars$mu[, i], + size = prep$data$trials[i], log = TRUE + ) + ll <- brms:::log_lik_binomial(i, prep = prep) + expect_equal(ll, ll_binom) + + ll_beta_binom <- dbeta_binomial( + x = prep$data$Y[i], size = prep$data$trials[i], + mu = prep$dpars$mu[, i], phi = prep$dpars$phi, log = TRUE + ) + ll <- brms:::log_lik_beta_binomial(i, prep = prep) + expect_equal(ll, ll_beta_binom) + + # don't test the actual values as they will be -Inf for this data + ll <- brms:::log_lik_discrete_weibull(i, prep = prep) + expect_equal(length(ll), ns) + + prep$dpars$mu <- exp(prep$dpars$eta) + ll_pois <- dpois( + x = prep$data$Y[i], lambda = prep$dpars$mu[, i], log = TRUE + ) + ll <- brms:::log_lik_poisson(i, prep = prep) + expect_equal(ll, ll_pois) + + ll_nbinom <- dnbinom( + x = prep$data$Y[i], mu = prep$dpars$mu[, i], + size = prep$dpars$shape, log = TRUE + ) + ll <- brms:::log_lik_negbinomial(i, prep = prep) + expect_equal(ll, ll_nbinom) + + ll <- brms:::log_lik_negbinomial2(i, prep = prep) + expect_equal(ll, ll_nbinom) + + ll_geo <- dnbinom( + x = prep$data$Y[i], mu = prep$dpars$mu[, i], + size = 1, log = TRUE + ) + ll <- brms:::log_lik_geometric(i, prep = prep) + expect_equal(ll, ll_geo) + + ll_com_pois <- brms:::dcom_poisson( + x = prep$data$Y[i], mu = prep$dpars$mu[, i], + shape = prep$dpars$shape, log = TRUE + ) + ll <- brms:::log_lik_com_poisson(i, prep = prep) + expect_equal(ll, ll_com_pois) + + ll_exp <- dexp( + x = prep$data$Y[i], rate = 1 / prep$dpars$mu[, i], log = TRUE + ) + ll <- brms:::log_lik_exponential(i, prep = prep) + expect_equal(ll, ll_exp) + + ll_gamma <- dgamma( + x = prep$data$Y[i], shape = prep$dpars$shape, + scale = prep$dpars$mu[, i] / prep$dpars$shape, + log = TRUE + ) + ll <- brms:::log_lik_gamma(i, prep = prep) + expect_equal(ll, ll_gamma) + + scale <- prep$dpars$mu[, i] / gamma(1 - 1 / prep$dpars$nu) + ll_frechet <- dfrechet( + x = prep$data$Y[i], shape = prep$dpars$nu, + scale = scale, log = TRUE + ) + ll <- brms:::log_lik_frechet(i, prep = prep) + expect_equal(ll, ll_frechet) + + ll_invgauss <- dinv_gaussian( + x = prep$data$Y[i], shape = prep$dpars$shape, + mu = prep$dpars$mu[, i], log = TRUE + ) + ll <- brms:::log_lik_inverse.gaussian(i, prep = prep) + expect_equal(ll, ll_invgauss) + + ll_weibull <- dweibull( + x = prep$data$Y[i], shape = prep$dpars$shape, + scale = prep$dpars$mu[, i] / gamma(1 + 1 / prep$dpars$shape), + log = TRUE + ) + ll <- brms:::log_lik_weibull(i, prep = prep) + expect_equal(ll, c(ll_weibull)) + + # keep test at the end + prep$family$link <- "identity" + prep$data$Y[i] <- 0 + ll_gen_extreme_value <- SW(dgen_extreme_value( + x = prep$data$Y[i], mu = prep$dpars$mu[, i], + sigma = prep$dpars$sigma, xi = prep$dpars$xi, log = TRUE + )) + ll <- SW(brms:::log_lik_gen_extreme_value(i, prep = prep)) + expect_equal(ll, ll_gen_extreme_value) +}) + +test_that("log_lik for bernoulli and beta models works correctly", { + ns <- 15 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = brms:::inv_logit(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), + phi = rgamma(ns, 4) + ) + prep$data <- list(Y = sample(0:1, nobs, replace = TRUE)) + + i <- sample(1:nobs, 1) + ll_bern <- dbinom( + x = prep$data$Y[i], prob = prep$dpars$mu[, i], size = 1, log = TRUE + ) + ll <- brms:::log_lik_bernoulli(i, prep = prep) + expect_equal(ll, ll_bern) + + prep$data <- list(Y = rbeta(nobs, 1, 1)) + ll_beta <- dbeta( + x = prep$data$Y[i], shape1 = prep$dpars$mu[, i] * prep$dpars$phi, + shape2 = (1 - prep$dpars$mu[, i]) * prep$dpars$phi, log = TRUE + ) + ll <- brms:::log_lik_beta(i, prep = prep) + expect_equal(ll, ll_beta) +}) + +test_that("log_lik for circular models runs without errors", { + ns <- 15 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = 2 * atan(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), + kappa = rgamma(ns, 4) + ) + prep$data <- list(Y = runif(nobs, -pi, pi)) + i <- sample(seq_len(nobs), 1) + ll <- brms:::log_lik_von_mises(i, prep = prep) + expect_equal(length(ll), ns) + prep$data$cens <- sample(-1:1, nobs, TRUE) + ll <- brms:::log_lik_von_mises(i, prep = prep) + expect_equal(length(ll), ns) +}) + +test_that("log_lik for zero-inflated and hurdle models runs without erros", { + ns <- 50 + nobs <- 8 + trials <- sample(10:30, nobs, replace = TRUE) + resp <- rbinom(nobs, size = trials, prob = rbeta(nobs, 1, 1)) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + eta = matrix(rnorm(ns*nobs), ncol = nobs), + shape = rgamma(ns, 4), + phi = rgamma(ns, 1), + zi = rbeta(ns, 1, 1), + coi = rbeta(ns, 5, 7) + ) + prep$dpars$hu <- prep$dpars$zoi <- prep$dpars$zi + prep$data <- list(Y = c(resp, rep(0, 4)), trials = trials) + + prep$dpars$mu <- exp(prep$dpars$eta) + ll <- brms:::log_lik_hurdle_poisson(1, prep = prep) + expect_equal(length(ll), ns) + + ll <- brms:::log_lik_hurdle_negbinomial(5, prep = prep) + expect_equal(length(ll), ns) + + ll <- brms:::log_lik_hurdle_gamma(2, prep = prep) + expect_equal(length(ll), ns) + + ll <- brms:::log_lik_hurdle_gamma(8, prep = prep) + expect_equal(length(ll), ns) + + ll <- brms:::log_lik_zero_inflated_poisson(3, prep = prep) + expect_equal(length(ll), ns) + + ll <- brms:::log_lik_zero_inflated_negbinomial(6, prep = prep) + expect_equal(length(ll), ns) + + prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) + ll <- brms:::log_lik_zero_inflated_binomial(4, prep = prep) + expect_equal(length(ll), ns) + + ll <- brms:::log_lik_zero_inflated_beta_binomial(7, prep = prep) + expect_equal(length(ll), ns) + + prep$data$Y[1:nobs] <- rbeta(nobs / 2, 0.5, 4) + ll <- brms:::log_lik_zero_inflated_beta(6, prep = prep) + expect_equal(length(ll), ns) + + ll <- brms:::log_lik_zero_one_inflated_beta(7, prep = prep) + expect_equal(length(ll), ns) +}) + +test_that("log_lik for ordinal models runs without erros", { + ns <- 50 + nobs <- 8 + nthres <- 3 + ncat <- nthres + 1 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = array(rnorm(ns * nobs), dim = c(ns, nobs)), + disc = rexp(ns) + ) + prep$thres$thres <- array(0, dim = c(ns, nthres)) + prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) + prep$family$link <- "logit" + + ll <- sapply(1:nobs, brms:::log_lik_cumulative, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + + ll <- sapply(1:nobs, brms:::log_lik_sratio, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + + ll <- sapply(1:nobs, brms:::log_lik_cratio, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + + ll <- sapply(1:nobs, brms:::log_lik_acat, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + + prep$family$link <- "probit" + ll <- sapply(1:nobs, brms:::log_lik_acat, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) +}) + +test_that("log_lik for categorical and related models runs without erros", { + ns <- 50 + nobs <- 8 + ncat <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu1 = array(rnorm(ns*nobs), dim = c(ns, nobs)), + mu2 = array(rnorm(ns*nobs), dim = c(ns, nobs)) + ) + prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) + prep$family <- categorical() + prep$refcat <- 1 + ll <- sapply(1:nobs, brms:::log_lik_categorical, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + + prep$data$Y <- matrix( + sample(1:20, nobs * ncat, TRUE), + nrow = nobs, ncol = ncat + ) + prep$data$trials <- sample(1:20, nobs) + prep$family <- multinomial() + ll <- sapply(1:nobs, brms:::log_lik_multinomial, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + + prep$data$Y <- prep$data$Y / rowSums(prep$data$Y) + prep$dpars$phi <- rexp(ns, 10) + prep$family <- dirichlet() + ll <- sapply(1:nobs, brms:::log_lik_dirichlet, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + + prep$family <- brmsfamily("dirichlet2") + prep$dpars$mu1 <- rexp(ns, 10) + prep$dpars$mu2 <- rexp(ns, 10) + prep$dpars$mu3 <- rexp(ns, 10) + ll <- sapply(1:nobs, brms:::log_lik_dirichlet2, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + + prep$family <- brmsfamily("logistic_normal") + prep$dpars <- list( + mu2 = rnorm(ns), + mu3 = rnorm(ns), + sigma2 = rexp(ns, 10), + sigma3 = rexp(ns, 10) + ) + prep$lncor <- rbeta(ns, 2, 1) + ll <- sapply(1:nobs, brms:::log_lik_logistic_normal, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) +}) + +test_that("censored and truncated log_lik run without errors", { + ns <- 30 + nobs <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rchisq(ns, 3) + ) + prep$data <- list(Y = rnorm(ns), cens = c(-1,0,1)) + ll <- sapply(1:nobs, brms:::log_lik_gaussian, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) + prep$data <- list(Y = sample(-3:3, nobs), lb = -4, ub = 5) + ll <- sapply(1:nobs, brms:::log_lik_gaussian, prep = prep) + expect_equal(dim(ll), c(ns, nobs)) +}) + +test_that("log_lik for the wiener diffusion model runs without errors", { + ns <- 5 + nobs <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + bs = rchisq(ns, 3), ndt = rep(0.5, ns), + bias = rbeta(ns, 1, 1) + ) + prep$data <- list(Y = abs(rnorm(ns)) + 0.5, dec = c(1, 0, 1)) + i <- sample(1:nobs, 1) + expect_equal(length(brms:::log_lik_wiener(i, prep)), ns) +}) + +test_that("log_lik_custom runs without errors", { + ns <- 15 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rbeta(ns * nobs * 2, 1, 1), ncol = nobs * 2) + ) + prep$data <- list( + Y = sample(0:1, nobs, replace = TRUE), + trials = rep(1, nobs) + ) + prep$family <- custom_family( + "beta_binomial2", dpars = c("mu", "tau"), + links = c("logit", "log"), lb = c(NA, 0), + type = "int", vars = "trials[n]" + ) + log_lik_beta_binomial2 <- function(i, prep) { + mu <- prep$dpars$mu[, i] + dbinom(prep$data$Y[i], size = prep$data$trials[i], prob = mu) + } + expect_equal(length(brms:::log_lik_custom(sample(1:nobs, 1), prep)), ns) +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.make_stancode.R r-cran-brms-2.17.0/tests/testthat/tests.make_stancode.R --- r-cran-brms-2.16.3/tests/testthat/tests.make_stancode.R 2021-10-24 11:10:38.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.make_stancode.R 2022-04-09 09:28:56.000000000 +0000 @@ -10,46 +10,49 @@ options(brms.parse_stancode = not_cran, brms.backend = "rstan") test_that("specified priors appear in the Stan code", { - dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), + dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10), g = rep(1:5, 2), h = factor(rep(1:5, each = 2))) - + prior <- c(prior(std_normal(), coef = x1), prior(normal(0,2), coef = x2), - prior(normal(0,5), Intercept), - prior(cauchy(0,1), sd, group = g), + prior(normal(0,5), Intercept, lb = 0), + prior(cauchy(0,1), sd, group = g, lb = "", ub = 5), prior(cauchy(0,2), sd, group = g, coef = x1), - prior(gamma(1, 1), class = sd, group = h)) + prior(gamma(1, 1), sd, group = h, ub = 10)) scode <- make_stancode(y ~ x1*x2 + (x1*x2|g) + (1 | h), dat, prior = prior, sample_prior = "yes") - expect_match2(scode, "target += std_normal_lpdf(b[1])") - expect_match2(scode, "target += normal_lpdf(b[2] | 0, 2)") - expect_match2(scode, "target += normal_lpdf(Intercept | 0, 5)") - expect_match2(scode, "target += cauchy_lpdf(sd_1[1] | 0, 1)") - expect_match2(scode, "- 1 * cauchy_lccdf(0 | 0, 1)") - expect_match2(scode, "target += cauchy_lpdf(sd_1[2] | 0, 2)") - expect_match2(scode, "target += student_t_lpdf(sigma | 3, 0, 3.7)") + expect_match2(scode, "vector[M_1] sd_1;") + expect_match2(scode, "vector[M_2] sd_2;") + expect_match2(scode, "target += lprior;") + expect_match2(scode, "lprior += std_normal_lpdf(b[1])") + expect_match2(scode, "lprior += normal_lpdf(b[2] | 0, 2)") + expect_match2(scode, "lprior += normal_lpdf(Intercept | 0, 5)") + expect_match2(scode, "lprior += cauchy_lpdf(sd_1[1] | 0, 1)") + expect_match2(scode, "- 1 * cauchy_lcdf(5 | 0, 1)") + expect_match2(scode, "lprior += cauchy_lpdf(sd_1[2] | 0, 2)") + expect_match2(scode, "lprior += student_t_lpdf(sigma | 3, 0, 3.7)") expect_match2(scode, "- 1 * student_t_lccdf(0 | 3, 0, 3.7)") - expect_match2(scode, "target += gamma_lpdf(sd_2 | 1, 1)") - expect_match2(scode, "prior_b_1 = normal_rng(0,1);") - expect_match2(scode, "prior_sd_1_1 = cauchy_rng(0,1)") - expect_match2(scode, "while (prior_sd_1_1 < 0)") + expect_match2(scode, "lprior += gamma_lpdf(sd_2 | 1, 1)") + expect_match2(scode, "prior_b__1 = normal_rng(0,1);") + expect_match2(scode, "prior_sd_1__1 = cauchy_rng(0,1)") + expect_match2(scode, "while (prior_sd_1__1 > 5)") expect_match2(scode, "prior_sd_2 = gamma_rng(1,1)") - expect_match2(scode, "while (prior_sd_2 < 0)") - + expect_match2(scode, "while (prior_sd_2 < 0 || prior_sd_2 > 10)") + prior <- c(prior(lkj(0.5), class = cor, group = g), prior(normal(0, 1), class = b), prior(normal(0, 5), class = Intercept), prior(cauchy(0, 5), class = sd)) - scode <- make_stancode(y ~ x1 + cs(x2) + (0 + x1 + x2 | g), - data = dat, family = acat(), + scode <- make_stancode(y ~ x1 + cs(x2) + (0 + x1 + x2 | g), + data = dat, family = acat(), prior = prior, sample_prior = TRUE) - expect_match2(scode, "target += normal_lpdf(b | 0, 1)") - expect_match2(scode, "target += normal_lpdf(Intercept | 0, 5)") - expect_match2(scode, "target += cauchy_lpdf(sd_1 | 0, 5)") - expect_match2(scode, "target += lkj_corr_cholesky_lpdf(L_1 | 0.5)") - expect_match2(scode, "target += normal_lpdf(to_vector(bcs) | 0, 1)") + expect_match2(scode, "lprior += normal_lpdf(b | 0, 1)") + expect_match2(scode, "lprior += normal_lpdf(Intercept | 0, 5)") + expect_match2(scode, "lprior += cauchy_lpdf(sd_1 | 0, 5)") + expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(L_1 | 0.5)") + expect_match2(scode, "lprior += normal_lpdf(to_vector(bcs) | 0, 1)") expect_match2(scode, "prior_bcs = normal_rng(0,1)") - + prior <- c(prior(normal(0,5), nlpar = a), prior(normal(0,10), nlpar = b), prior(cauchy(0,1), class = sd, nlpar = a), @@ -58,24 +61,24 @@ bf(y ~ a * exp(-b * x1), a + b ~ (1|ID|g), nl = TRUE), data = dat, prior = prior, sample_prior = TRUE ) - expect_match2(scode, "target += normal_lpdf(b_a | 0, 5)") - expect_match2(scode, "target += normal_lpdf(b_b | 0, 10)") - expect_match2(scode, "target += cauchy_lpdf(sd_1[1] | 0, 1)") - expect_match2(scode, "target += lkj_corr_cholesky_lpdf(L_1 | 2)") + expect_match2(scode, "lprior += normal_lpdf(b_a | 0, 5)") + expect_match2(scode, "lprior += normal_lpdf(b_b | 0, 10)") + expect_match2(scode, "lprior += cauchy_lpdf(sd_1[1] | 0, 1)") + expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(L_1 | 2)") expect_match2(scode, "prior_b_a = normal_rng(0,5)") - expect_match2(scode, "prior_sd_1_2 = student_t_rng(3,0,3.7)") + expect_match2(scode, "prior_sd_1__2 = student_t_rng(3,0,3.7)") expect_match2(scode, "prior_cor_1 = lkj_corr_rng(M_1,2)[1, 2]") - + prior <- c(prior(lkj(2), rescor), prior(cauchy(0, 5), sigma, resp = y), prior(cauchy(0, 1), sigma, resp = x1)) form <- bf(mvbind(y, x1) ~ x2) + set_rescor(TRUE) - scode <- make_stancode(form, dat, prior = prior, + scode <- make_stancode(form, dat, prior = prior, sample_prior = TRUE) - expect_match2(scode, "target += lkj_corr_cholesky_lpdf(Lrescor | 2)") + expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Lrescor | 2)") expect_match2(scode, "prior_sigma_y = cauchy_rng(0,5)") expect_match2(scode, "prior_rescor = lkj_corr_rng(nresp,2)[1, 2]") - + prior <- c(prior(uniform(-1, 1), ar), prior(normal(0, 0.5), ma), prior(normal(0, 5))) @@ -83,36 +86,38 @@ prior = prior, sample_prior = TRUE) expect_match2(scode, "vector[Kar] ar;") expect_match2(scode, "vector[Kma] ma;") - expect_match2(scode, "target += uniform_lpdf(ar | -1, 1)") - expect_match2(scode, "target += normal_lpdf(ma | 0, 0.5)") - expect_match2(scode, + expect_match2(scode, "lprior += uniform_lpdf(ar | -1, 1)") + expect_match2(scode, "lprior += normal_lpdf(ma | 0, 0.5)") + expect_match2(scode, "- 1 * log_diff_exp(normal_lcdf(1 | 0, 0.5), normal_lcdf(-1 | 0, 0.5))" ) - expect_match2(scode, "target += normal_lpdf(bsp | 0, 5)") - expect_match2(scode, "target += dirichlet_lpdf(simo_1 | con_simo_1)") + expect_match2(scode, "lprior += normal_lpdf(bsp | 0, 5)") + expect_match2(scode, "lprior += dirichlet_lpdf(simo_1 | con_simo_1)") expect_match2(scode, "prior_simo_1 = dirichlet_rng(con_simo_1)") expect_match2(scode, "prior_ar = uniform_rng(-1,1)") expect_match2(scode, "while (prior_ar < -1 || prior_ar > 1)") - + # test for problem described in #213 prior <- c(prior(normal(0, 1), coef = x1), prior(normal(0, 2), coef = x1, dpar = sigma)) scode <- make_stancode(bf(y ~ x1, sigma ~ x1), dat, prior = prior) - expect_match2(scode, "target += normal_lpdf(b[1] | 0, 1);") - expect_match2(scode, "target += normal_lpdf(b_sigma[1] | 0, 2);") - + expect_match2(scode, "lprior += normal_lpdf(b[1] | 0, 1);") + expect_match2(scode, "lprior += normal_lpdf(b_sigma[1] | 0, 2);") + prior <- c(set_prior("target += normal_lpdf(b[1] | 0, 1)", check = FALSE), set_prior("", class = "sigma")) scode <- make_stancode(y ~ x1, dat, prior = prior, sample_prior = TRUE) expect_match2(scode, "target += normal_lpdf(b[1] | 0, 1)") expect_true(!grepl("sigma \\|", scode)) - + + # commented out until fixes implemented in 'check_prior_content' prior <- prior(gamma(0, 1), coef = x1) expect_warning(make_stancode(y ~ x1, dat, prior = prior), "no natural lower bound") prior <- prior(uniform(0,5), class = sd) expect_warning(make_stancode(y ~ x1 + (1|g), dat, prior = prior), "no natural upper bound") + prior <- prior(uniform(-1, 1), class = cor) expect_error( make_stancode(y ~ x1 + (x1|g), dat, prior = prior), @@ -122,34 +127,34 @@ test_that("special shrinkage priors appear in the Stan code", { dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10)) - + # horseshoe prior hs <- horseshoe(7, scale_global = 2, df_global = 3, df_slab = 6, scale_slab = 3) - scode <- make_stancode(y ~ x1*x2, data = dat, + scode <- make_stancode(y ~ x1*x2, data = dat, prior = set_prior(hs), sample_prior = TRUE) - expect_match2(scode, "vector[Kc] hs_local;") - expect_match2(scode, "real hs_global;") - expect_match2(scode, + expect_match2(scode, "vector[Kc] hs_local;") + expect_match2(scode, "real hs_global;") + expect_match2(scode, "target += student_t_lpdf(hs_local | hs_df, 0, 1)" ) - expect_match2(scode, - "target += student_t_lpdf(hs_global | hs_df_global, 0, hs_scale_global * sigma)" + expect_match2(scode, + "lprior += student_t_lpdf(hs_global | hs_df_global, 0, hs_scale_global * sigma)" ) - expect_match2(scode, - "target += inv_gamma_lpdf(hs_slab | 0.5 * hs_df_slab, 0.5 * hs_df_slab)" + expect_match2(scode, + "lprior += inv_gamma_lpdf(hs_slab | 0.5 * hs_df_slab, 0.5 * hs_df_slab)" ) - expect_match2(scode, + expect_match2(scode, "b = horseshoe(zb, hs_local, hs_global, hs_scale_slab^2 * hs_slab);" ) - + scode <- make_stancode(y ~ x1*x2, data = dat, poisson(), prior = prior(horseshoe(scale_global = 3))) - expect_match2(scode, + expect_match2(scode, "b = horseshoe(zb, hs_local, hs_global, hs_scale_slab^2 * hs_slab);" ) - + scode <- make_stancode(x1 ~ mo(y), dat, prior = prior(horseshoe())) expect_match2(scode, "target += std_normal_lpdf(zbsp);") expect_match2(scode, @@ -160,30 +165,30 @@ "bsp = horseshoe(zbsp, hs_localsp, hs_global, hs_scale_slab^2 * hs_slab);" ) ) - - # R2D2 prior + + # R2D2 prior scode <- make_stancode(y ~ x1*x2, data = dat, prior = prior(R2D2(0.5, 10)), sample_prior = TRUE) expect_match2(scode, "b = R2D2(zb, R2D2_phi, R2D2_tau2);") expect_match2(scode, "target += dirichlet_lpdf(R2D2_phi | R2D2_cons_D2);") - expect_match2(scode, "target += beta_lpdf(R2D2_R2 | R2D2_mean_R2 * R2D2_prec_R2, (1 - R2D2_mean_R2) * R2D2_prec_R2);") + expect_match2(scode, "lprior += beta_lpdf(R2D2_R2 | R2D2_mean_R2 * R2D2_prec_R2, (1 - R2D2_mean_R2) * R2D2_prec_R2);") expect_match2(scode, "R2D2_tau2 = sigma^2 * R2D2_R2 / (1 - R2D2_R2);") - + # lasso prior scode <- make_stancode(y ~ x1*x2, data = dat, prior = prior(lasso(2, scale = 10)), sample_prior = TRUE) - expect_match2(scode, "target += chi_square_lpdf(lasso_inv_lambda | lasso_df);") - expect_match2(scode, + expect_match2(scode, "lprior += chi_square_lpdf(lasso_inv_lambda | lasso_df);") + expect_match2(scode, "target += double_exponential_lpdf(b | 0, lasso_scale * lasso_inv_lambda);" ) - + scode <- make_stancode(x1 ~ mo(y), dat, prior = prior(lasso())) - expect_match2(scode, + expect_match2(scode, "double_exponential_lpdf(bsp | 0, lasso_scale * lasso_inv_lambda)" ) - + # horseshoe and lasso prior applied in a non-linear model hs_a1 <- horseshoe(7, scale_global = 2, df_global = 3) lasso_a2 <- lasso(2, scale = 10) @@ -195,33 +200,33 @@ set_prior(lasso_a2, nlpar = "a2"), set_prior(R2D2_a3, nlpar = "a3")) ) - expect_match2(scode, "vector[K_a1] hs_local_a1;") - expect_match2(scode, "real hs_global_a1;") - expect_match2(scode, + expect_match2(scode, "vector[K_a1] hs_local_a1;") + expect_match2(scode, "real hs_global_a1;") + expect_match2(scode, "target += student_t_lpdf(hs_local_a1 | hs_df_a1, 0, 1)" ) - expect_match2(scode, - "target += student_t_lpdf(hs_global_a1 | hs_df_global_a1, 0, hs_scale_global_a1 * sigma)" + expect_match2(scode, + "lprior += student_t_lpdf(hs_global_a1 | hs_df_global_a1, 0, hs_scale_global_a1 * sigma)" ) - expect_match2(scode, - "target += inv_gamma_lpdf(hs_slab_a1 | 0.5 * hs_df_slab_a1, 0.5 * hs_df_slab_a1)" + expect_match2(scode, + "lprior += inv_gamma_lpdf(hs_slab_a1 | 0.5 * hs_df_slab_a1, 0.5 * hs_df_slab_a1)" ) - expect_match2(scode, + expect_match2(scode, "b_a1 = horseshoe(zb_a1, hs_local_a1, hs_global_a1, hs_scale_slab_a1^2 * hs_slab_a1);" ) expect_match2(scode, - "target += chi_square_lpdf(lasso_inv_lambda_a2 | lasso_df_a2);" + "lprior += chi_square_lpdf(lasso_inv_lambda_a2 | lasso_df_a2);" ) - expect_match2(scode, + expect_match2(scode, "target += double_exponential_lpdf(b_a2 | 0, lasso_scale_a2 * lasso_inv_lambda_a2);" ) expect_match2(scode, "b_a3 = R2D2(zb_a3, R2D2_phi_a3, R2D2_tau2_a3);") - + # check error messages - expect_error(make_stancode(y ~ x1*x2, data = dat, + expect_error(make_stancode(y ~ x1*x2, data = dat, prior = prior(horseshoe(-1))), "Degrees of freedom of the local priors") - expect_error(make_stancode(y ~ x1*x2, data = dat, + expect_error(make_stancode(y ~ x1*x2, data = dat, prior = prior(horseshoe(1, -1))), "Scale of the global prior") expect_error(make_stancode(y ~ x1*x2, data = dat, prior = prior(lasso(-1))), @@ -232,39 +237,39 @@ expect_error(make_stancode(x1 ~ y, dat, prior = bprior), "Defining separate priors for single coefficients") expect_error(make_stancode(x1 ~ y, dat, prior = prior(lasso(), lb = 0)), - "Setting boundaries on coefficients is not allowed") + "Cannot add bounds to class 'b' for this prior") }) test_that("priors can be fixed to constants", { - dat <- data.frame(y = 1:12, x1 = rnorm(12), x2 = rnorm(12), + dat <- data.frame(y = 1:12, x1 = rnorm(12), x2 = rnorm(12), g = rep(1:6, each = 2), h = factor(rep(1:2, each = 6))) - + prior <- prior(normal(0, 1), b) + prior(constant(3), b, coef = x1) + prior(constant(-1), b, coef = x2) + - prior(constant(10), Intercept) + + prior(constant(10), Intercept) + prior(normal(0, 5), sd) + - prior(constant(1), sd, group = g, coef = x2) + + prior(constant(1), sd, group = g, coef = x2) + prior(constant(2), sd, group = g, coef = x1) + prior(constant(0.3), sigma) scode <- make_stancode(y ~ x1*x2 + (x1*x2 | g), dat, prior = prior) expect_match2(scode, "b[1] = 3;") expect_match2(scode, "b[2] = -1;") expect_match2(scode, "b[3] = par_b_3;") - expect_match2(scode, "target += normal_lpdf(b[3] | 0, 1);") + expect_match2(scode, "lprior += normal_lpdf(b[3] | 0, 1);") expect_match2(scode, "Intercept = 1") expect_match2(scode, "sd_1[3] = 1;") expect_match2(scode, "sd_1[2] = 2;") expect_match2(scode, "sd_1[4] = par_sd_1_4;") - expect_match2(scode, "target += normal_lpdf(sd_1[4] | 0, 5)") + expect_match2(scode, "lprior += normal_lpdf(sd_1[4] | 0, 5)") expect_match2(scode, "sigma = 0.3;") - + prior <- prior(constant(3)) scode <- make_stancode(y ~ x2 + x1 + cs(g), dat, family = sratio(), prior = prior) expect_match2(scode, "b = rep_vector(3, rows(b));") expect_match2(scode, "bcs = rep_matrix(3, rows(bcs), cols(bcs));") - + prior <- prior(normal(0, 3)) + prior(constant(3), coef = x1) + prior(constant(-1), coef = g) @@ -272,30 +277,30 @@ prior = prior) expect_match2(scode, "b[1] = 3;") expect_match2(scode, "bcs[1] = par_bcs_1;") - expect_match2(scode, "target += normal_lpdf(bcs[1] | 0, 3);") + expect_match2(scode, "lprior += normal_lpdf(bcs[1] | 0, 3);") expect_match2(scode, "bcs[2] = rep_row_vector(-1, cols(bcs[2]));") - + prior <- prior(constant(3), class = "sd", group = "g") + prior("constant([[1, 0], [0, 1]])", class = "cor") scode <- make_stancode(y ~ x1 + (x1 | gr(g, by = h)), dat, prior = prior) expect_match2(scode, "sd_1 = rep_matrix(3, rows(sd_1), cols(sd_1));") expect_match2(scode, "L_1[2] = [[1, 0], [0, 1]];") - + prior <- prior(constant(0.5), class = lscale, coef = gpx1h1) + prior(normal(0, 10), class = lscale, coef = gpx1h2) scode <- make_stancode(y ~ gp(x1, by = h), dat, prior = prior) expect_match2(scode, "lscale_1[1][1] = 0.5;") expect_match2(scode, "lscale_1[2][1] = par_lscale_1_2_1;") - expect_match2(scode, "target += normal_lpdf(lscale_1[2][1] | 0, 10)") - + expect_match2(scode, "lprior += normal_lpdf(lscale_1[2][1] | 0, 10)") + # test that improper base priors are correctly recognized (#919) prior <- prior(constant(-1), b, coef = x2) scode <- make_stancode(y ~ x1*x2, dat, prior = prior) expect_match2(scode, "real par_b_1;") expect_match2(scode, "b[3] = par_b_3;") - + # test error messages - prior <- prior(normal(0, 1), Intercept) + + prior <- prior(normal(0, 1), Intercept) + prior(constant(3), Intercept, coef = 2) expect_error( make_stancode(y ~ x1, data = dat, family = cumulative(), prior = prior), @@ -305,12 +310,12 @@ test_that("link functions appear in the Stan code", { dat <- data.frame(y = 1:10, x = rnorm(10)) - expect_match2(make_stancode(y ~ s(x), dat, family = poisson()), + expect_match2(make_stancode(y ~ s(x), dat, family = poisson()), "target += poisson_log_lpmf(Y | mu);") - expect_match2(make_stancode(mvbind(y, y + 1) ~ x, dat, - family = skew_normal("log")), + expect_match2(make_stancode(mvbind(y, y + 1) ~ x, dat, + family = skew_normal("log")), "mu_y[n] = exp(mu_y[n]);") - expect_match2(make_stancode(y ~ x, dat, family = von_mises(tan_half)), + expect_match2(make_stancode(y ~ x, dat, family = von_mises(tan_half)), "mu[n] = inv_tan_half(mu[n]);") expect_match2(make_stancode(y ~ x, dat, family = weibull()), "mu[n] = exp(mu[n]) / tgamma(1 + 1 / shape);") @@ -320,39 +325,44 @@ "mu[n] = square(mu[n]);") expect_match2(make_stancode(y ~ s(x), dat, family = bernoulli()), "target += bernoulli_logit_lpmf(Y | mu);") + + scode <- make_stancode(y ~ x, dat, family = beta_binomial('logit')) + expect_match2(scode, "mu[n] = inv_logit(mu[n]);") + scode <- make_stancode(y ~ x, dat, family = beta_binomial('cloglog')) + expect_match2(scode, "mu[n] = inv_cloglog(mu[n]);") }) test_that("Stan GLM primitives are applied correctly", { dat <- data.frame(x = rnorm(10), y = 1:10) - + scode <- make_stancode(y ~ x, dat, family = gaussian) expect_match2(scode, "normal_id_glm_lpdf(Y | Xc, Intercept, b, sigma)") - + scode <- make_stancode(y ~ x, dat, family = bernoulli) expect_match2(scode, "bernoulli_logit_glm_lpmf(Y | Xc, Intercept, b)") - + scode <- make_stancode(y ~ x, dat, family = poisson) expect_match2(scode, "poisson_log_glm_lpmf(Y | Xc, Intercept, b)") - + scode <- make_stancode(y ~ x, dat, family = negbinomial) - expect_match2(scode, + expect_match2(scode, "neg_binomial_2_log_glm_lpmf(Y | Xc, Intercept, b, shape)" ) - + scode <- make_stancode(y ~ x, dat, family = brmsfamily("negbinomial2")) - expect_match2(scode, + expect_match2(scode, "neg_binomial_2_log_glm_lpmf(Y | Xc, Intercept, b, inv(sigma))" ) - + scode <- make_stancode(y ~ 0 + x, dat, family = gaussian) expect_match2(scode, "normal_id_glm_lpdf(Y | X, 0, b, sigma)") - + bform <- bf(y ~ x) + bf(x ~ 1, family = negbinomial()) + set_rescor(FALSE) scode <- make_stancode(bform, dat, family = gaussian) - expect_match2(scode, + expect_match2(scode, "normal_id_glm_lpdf(Y_y | Xc_y, Intercept_y, b_y, sigma_y)" ) - + scode <- make_stancode(bf(y ~ x, decomp = "QR"), dat, family = gaussian) expect_match2(scode, "normal_id_glm_lpdf(Y | XQ, Intercept, bQ, sigma);") }) @@ -361,28 +371,28 @@ M <- diag(1, nrow = length(unique(inhaler$subject))) rownames(M) <- unique(inhaler$subject) dat2 <- list(M = M) - - scode <- make_stancode(rating ~ treat + (1 | gr(subject, cov = M)), + + scode <- make_stancode(rating ~ treat + (1 | gr(subject, cov = M)), data = inhaler, data2 = dat2) expect_match2(scode, "r_1_1 = (sd_1[1] * (Lcov_1 * z_1[1]))") - - scode <- make_stancode(rating ~ treat + (1 + treat | gr(subject, cov = M)), + + scode <- make_stancode(rating ~ treat + (1 + treat | gr(subject, cov = M)), data = inhaler, data2 = dat2) expect_match2(scode, "r_1 = scale_r_cor_cov(z_1, sd_1, L_1, Lcov_1);") expect_match2(scode, "cor_1[choose(k - 1, 2) + j] = Cor_1[j, k];") - - scode <- make_stancode(rating ~ (1 + treat | gr(subject, cor = FALSE, cov = M)), + + scode <- make_stancode(rating ~ (1 + treat | gr(subject, cor = FALSE, cov = M)), data = inhaler, data2 = dat2) expect_match2(scode, "r_1_1 = (sd_1[1] * (Lcov_1 * z_1[1]));") expect_match2(scode, "r_1_2 = (sd_1[2] * (Lcov_1 * z_1[2]));") - + inhaler$by <- inhaler$subject %% 2 - scode <- make_stancode(rating ~ (1 + treat | gr(subject, by = by, cov = M)), + scode <- make_stancode(rating ~ (1 + treat | gr(subject, by = by, cov = M)), data = inhaler, data2 = dat2) expect_match2(scode, "r_1 = scale_r_cor_by_cov(z_1, sd_1, L_1, Jby_1, Lcov_1);") - + expect_warning( - scode <- make_stancode(rating ~ treat + period + carry + (1|subject), + scode <- make_stancode(rating ~ treat + period + carry + (1|subject), data = inhaler, cov_ranef = list(subject = 1)), "Argument 'cov_ranef' is deprecated" ) @@ -394,39 +404,39 @@ data = kidney, family = "gamma") expect_match2(scode, "target += gamma_lpdf(Y[n] | shape, mu[n]) -") expect_match2(scode, "gamma_lccdf(lb[n] | shape, mu[n]);") - - scode <- make_stancode(time | trunc(ub = 100) ~ age + sex + disease, + + scode <- make_stancode(time | trunc(ub = 100) ~ age + sex + disease, data = kidney, family = student("log")) - + expect_match2(scode, "target += student_t_lpdf(Y[n] | nu, mu[n], sigma) -") expect_match2(scode, "student_t_lcdf(ub[n] | nu, mu[n], sigma);") - - scode <- make_stancode(count | trunc(0, 150) ~ Trt, + + scode <- make_stancode(count | trunc(0, 150) ~ Trt, data = epilepsy, family = "poisson") expect_match2(scode, "target += poisson_lpmf(Y[n] | mu[n]) -") - expect_match2(scode, + expect_match2(scode, "log_diff_exp(poisson_lcdf(ub[n] | mu[n]), poisson_lcdf(lb[n] - 1 | mu[n]));" ) }) test_that("make_stancode handles models without fixed effects", { - expect_match2(make_stancode(count ~ 0 + (1|patient) + (1+Trt|visit), - data = epilepsy, family = "poisson"), + expect_match2(make_stancode(count ~ 0 + (1|patient) + (1+Trt|visit), + data = epilepsy, family = "poisson"), "mu = rep_vector(0.0, N);") }) test_that("make_stancode correctly restricts FE parameters", { data <- data.frame(y = rep(0:1, each = 5), x = rnorm(10)) - + scode <- make_stancode(y ~ x, data, prior = set_prior("", lb = 2)) expect_match2(scode, "vector[Kc] b") - + scode <- make_stancode( y ~ x, data, prior = set_prior("normal (0, 2)", ub = "4") ) expect_match2(scode, "vector[Kc] b") expect_match2(scode, "- 1 * normal_lcdf(4 | 0, 2)") - + prior <- set_prior("normal(0,5)", lb = "-3", ub = 5) scode <- make_stancode(y ~ 0 + x, data, prior = prior) expect_match2(scode, "vector[K] b") @@ -437,27 +447,27 @@ scode <- make_stancode(rating ~ treat, data = inhaler, family = bernoulli("cauchit")) expect_match2(scode, "real inv_cauchit(real y)") - + # softplus link scode <- make_stancode(rating ~ treat, data = inhaler, family = brmsfamily("poisson", "softplus")) expect_match2(scode, "real log_expm1(real x)") - + # squareplus link scode <- make_stancode(rating ~ treat, data = inhaler, family = brmsfamily("poisson", "squareplus")) expect_match2(scode, "real squareplus(real x)") - + # tan_half link expect_match2(make_stancode(rating ~ treat, data = inhaler, family = von_mises("tan_half")), "real inv_tan_half(real y)") - + # logm1 link expect_match2(make_stancode(rating ~ treat, data = inhaler, family = frechet()), "real expp1(real y)") - + # inverse gaussian models scode <- make_stancode(time | cens(censored) ~ age, data = kidney, family = inverse.gaussian) @@ -465,41 +475,44 @@ expect_match2(scode, "real inv_gaussian_lcdf(real y") expect_match2(scode, "real inv_gaussian_lccdf(real y") expect_match2(scode, "real inv_gaussian_vector_lpdf(vector y") - + # von Mises models scode <- make_stancode(time ~ age, data = kidney, family = von_mises) expect_match2(scode, "real von_mises_real_lpdf(real y") expect_match2(scode, "real von_mises_vector_lpdf(vector y") - + # zero-inflated and hurdle models - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_poisson"), "real zero_inflated_poisson_lpmf(int y") - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_negbinomial"), "real zero_inflated_neg_binomial_lpmf(int y") - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_binomial"), "real zero_inflated_binomial_lpmf(int y") - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, + family = "zero_inflated_beta_binomial"), + "real zero_inflated_beta_binomial_lpmf(int y") + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = "zero_inflated_beta"), "real zero_inflated_beta_lpdf(real y") - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = "zero_one_inflated_beta"), "real zero_one_inflated_beta_lpdf(real y") - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = hurdle_poisson()), "real hurdle_poisson_lpmf(int y") - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = hurdle_negbinomial), "real hurdle_neg_binomial_lpmf(int y") - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = hurdle_gamma("log")), "real hurdle_gamma_lpdf(real y") - expect_match2(make_stancode(count ~ Trt, data = epilepsy, + expect_match2(make_stancode(count ~ Trt, data = epilepsy, family = hurdle_lognormal("identity")), "real hurdle_lognormal_lpdf(real y") - + # linear models with special covariance structures expect_match2( make_stancode(rating ~ treat + ar(cov = TRUE), data = inhaler), @@ -510,7 +523,7 @@ family = "student"), "real student_t_time_hom_lpdf(vector y" ) - + # ARMA covariance matrices expect_match2( make_stancode(rating ~ treat + ar(cov = TRUE), data = inhaler), @@ -527,7 +540,7 @@ }) test_that("invalid combinations of modeling options are detected", { - data <- data.frame(y1 = rnorm(10), y2 = rnorm(10), + data <- data.frame(y1 = rnorm(10), y2 = rnorm(10), wi = 1:10, ci = sample(-1:1, 10, TRUE)) expect_error( make_stancode(y1 | cens(ci) ~ y2 + ar(cov = TRUE), data = data), @@ -546,13 +559,13 @@ test_that("Stan code for multivariate models is correct", { dat <- data.frame( - y1 = rnorm(10), y2 = rnorm(10), + y1 = rnorm(10), y2 = rnorm(10), x = 1:10, g = rep(1:2, each = 5), censi = sample(0:1, 10, TRUE) ) # models with residual correlations form <- bf(mvbind(y1, y2) ~ x) + set_rescor(TRUE) - prior <- prior(horseshoe(2), resp = "y1") + + prior <- prior(horseshoe(2), resp = "y1") + prior(horseshoe(2), resp = "y2") scode <- make_stancode(form, dat, prior = prior) expect_match2(scode, "target += multi_normal_cholesky_lpdf(Y | Mu, LSigma);") @@ -560,30 +573,30 @@ expect_match2(scode, "target += student_t_lpdf(hs_local_y1 | hs_df_y1, 0, 1)") expect_match2(scode, "target += student_t_lpdf(hs_local_y2 | hs_df_y2, 0, 1)") expect_match2(scode, "rescor[choose(k - 1, 2) + j] = Rescor[j, k];") - + form <- bf(mvbind(y1, y2) ~ x) + set_rescor(TRUE) - prior <- prior(lasso(2, 10), resp = "y1") + + prior <- prior(lasso(2, 10), resp = "y1") + prior(lasso(2, 10), resp = "y2") scode <- make_stancode(form, dat, student(), prior = prior) expect_match2(scode, "target += multi_student_t_lpdf(Y | nu, Mu, Sigma);") expect_match2(scode, "matrix[nresp, nresp] Sigma = multiply_lower") - expect_match2(scode, "target += gamma_lpdf(nu | 2, 0.1)") - expect_match2(scode, - "target += chi_square_lpdf(lasso_inv_lambda_y1 | lasso_df_y1)" + expect_match2(scode, "lprior += gamma_lpdf(nu | 2, 0.1)") + expect_match2(scode, + "lprior += chi_square_lpdf(lasso_inv_lambda_y1 | lasso_df_y1)" ) - expect_match2(scode, - "target += chi_square_lpdf(lasso_inv_lambda_y2 | lasso_df_y2)" + expect_match2(scode, + "lprior += chi_square_lpdf(lasso_inv_lambda_y2 | lasso_df_y2)" ) - + form <- bf(mvbind(y1, y2) | weights(x) ~ 1) + set_rescor(TRUE) scode <- make_stancode(form, dat) expect_match2(scode, "target += weights[n] * (multi_normal_cholesky_lpdf(Y[n] | Mu[n], LSigma));" ) - + # models without residual correlations expect_warning( - bform <- bf(y1 | cens(censi) ~ x + y2 + (x|2|g)) + + bform <- bf(y1 | cens(censi) ~ x + y2 + (x|2|g)) + gaussian() + cor_ar() + (bf(x ~ 1) + mixture(poisson, nmix = 2)) + (bf(y2 ~ s(y2) + (1|2|g)) + skew_normal()), @@ -597,15 +610,15 @@ expect_match2(scode, "target += normal_lccdf(Y_y1[n] | mu_y1[n], sigma_y1)") expect_match2(scode, "target += skew_normal_lpdf(Y_y2 | mu_y2, omega_y2, alpha_y2)") expect_match2(scode, "ps[1] = log(theta1_x) + poisson_log_lpmf(Y_x[n] | mu1_x[n])") - expect_match2(scode, "target += normal_lpdf(b_y1 | 0, 5)") - expect_match2(scode, "target += normal_lpdf(bs_y2 | 0, 10)") - + expect_match2(scode, "lprior += normal_lpdf(b_y1 | 0, 5)") + expect_match2(scode, "lprior += normal_lpdf(bs_y2 | 0, 10)") + # multivariate binomial models bform <- bf(x ~ 1) + bf(g ~ 1) + binomial() scode <- make_stancode(bform, dat) expect_match2(scode, "binomial_logit_lpmf(Y_x | trials_x, mu_x)") expect_match2(scode, "binomial_logit_lpmf(Y_g | trials_g, mu_g)") - + bform <- bform + weibull() scode <- make_stancode(bform, dat) expect_match2(scode, "mu_g[n] = exp(mu_g[n]) / tgamma(1 + 1 / shape_g)") @@ -617,20 +630,20 @@ prior(normal(0, 10), "b", dpar = mu2) + prior(cauchy(0, 1), "Intercept", dpar = mu2) + prior(normal(0, 2), "Intercept", dpar = mu3) - - scode <- make_stancode(y ~ x + (1 | gr(.g, id = "ID")), data = dat, + + scode <- make_stancode(y ~ x + (1 | gr(.g, id = "ID")), data = dat, family = categorical(), prior = prior) expect_match2(scode, "target += categorical_logit_lpmf(Y[n] | mu[n]);") expect_match2(scode, "mu[n] = transpose([0, mu2[n], mu3[n], muab[n]]);") expect_match2(scode, "mu2 = Intercept_mu2 + Xc_mu2 * b_mu2;") expect_match2(scode, "muab[n] += r_1_muab_3[J_1[n]] * Z_1_muab_3[n];") - expect_match2(scode, "target += normal_lpdf(b_mu2 | 0, 10);") - expect_match2(scode, "target += normal_lpdf(b_muab | 0, 5);") - expect_match2(scode, "target += cauchy_lpdf(Intercept_mu2 | 0, 1);") - expect_match2(scode, "target += normal_lpdf(Intercept_mu3 | 0, 2);") + expect_match2(scode, "lprior += normal_lpdf(b_mu2 | 0, 10);") + expect_match2(scode, "lprior += normal_lpdf(b_muab | 0, 5);") + expect_match2(scode, "lprior += cauchy_lpdf(Intercept_mu2 | 0, 1);") + expect_match2(scode, "lprior += normal_lpdf(Intercept_mu3 | 0, 2);") expect_match2(scode, "r_1 = scale_r_cor(z_1, sd_1, L_1);") - - scode <- make_stancode(y ~ x + (1 |ID| .g), data = dat, + + scode <- make_stancode(y ~ x + (1 |ID| .g), data = dat, family = categorical(refcat = NA)) expect_match2(scode, "mu[n] = transpose([mu1[n], mu2[n], mu3[n], muab[n]]);") }) @@ -638,7 +651,7 @@ test_that("Stan code for multinomial models is correct", { N <- 15 dat <- data.frame( - y1 = rbinom(N, 10, 0.3), y2 = rbinom(N, 10, 0.5), + y1 = rbinom(N, 10, 0.3), y2 = rbinom(N, 10, 0.5), y3 = rbinom(N, 10, 0.7), x = rnorm(N) ) dat$size <- with(dat, y1 + y2 + y3) @@ -646,14 +659,14 @@ prior <- prior(normal(0, 10), "b", dpar = muy2) + prior(cauchy(0, 1), "Intercept", dpar = muy2) + prior(normal(0, 2), "Intercept", dpar = muy3) - scode <- make_stancode(bf(y | trials(size) ~ 1, muy2 ~ x), data = dat, + scode <- make_stancode(bf(y | trials(size) ~ 1, muy2 ~ x), data = dat, family = multinomial(), prior = prior) expect_match2(scode, "int Y[N, ncat];") expect_match2(scode, "target += multinomial_logit2_lpmf(Y[n] | mu[n]);") expect_match2(scode, "muy2 = Intercept_muy2 + Xc_muy2 * b_muy2;") - expect_match2(scode, "target += normal_lpdf(b_muy2 | 0, 10);") - expect_match2(scode, "target += cauchy_lpdf(Intercept_muy2 | 0, 1);") - expect_match2(scode, "target += normal_lpdf(Intercept_muy3 | 0, 2);") + expect_match2(scode, "lprior += normal_lpdf(b_muy2 | 0, 10);") + expect_match2(scode, "lprior += cauchy_lpdf(Intercept_muy2 | 0, 1);") + expect_match2(scode, "lprior += normal_lpdf(Intercept_muy3 | 0, 2);") }) test_that("Stan code for dirichlet models is correct", { @@ -662,82 +675,121 @@ names(dat) <- c("y1", "y2", "y3") dat$x <- rnorm(N) dat$y <- with(dat, cbind(y1, y2, y3)) - + # dirichlet in probability-sum(alpha) concentration prior <- prior(normal(0, 5), class = "b", dpar = "muy3") + prior(exponential(10), "phi") - scode <- make_stancode(bf(y ~ 1, muy3 ~ x), data = dat, + scode <- make_stancode(bf(y ~ 1, muy3 ~ x), data = dat, family = dirichlet(), prior = prior) expect_match2(scode, "vector[ncat] Y[N];") expect_match2(scode, "target += dirichlet_logit_lpdf(Y[n] | mu[n], phi);") expect_match2(scode, "muy3 = Intercept_muy3 + Xc_muy3 * b_muy3;") - expect_match2(scode, "target += normal_lpdf(b_muy3 | 0, 5);") - expect_match2(scode, "target += exponential_lpdf(phi | 10);") - - scode <- make_stancode(bf(y ~ x, phi ~ x), data = dat, + expect_match2(scode, "lprior += normal_lpdf(b_muy3 | 0, 5);") + expect_match2(scode, "lprior += exponential_lpdf(phi | 10);") + + scode <- make_stancode(bf(y ~ x, phi ~ x), data = dat, family = dirichlet()) expect_match2(scode, "target += dirichlet_logit_lpdf(Y[n] | mu[n], phi[n]);") expect_match2(scode, "vector[N] phi = Intercept_phi + Xc_phi * b_phi;") expect_match2(scode, "phi[n] = exp(phi[n]);") - + # dirichlet2 in alpha parameterization prior <- prior(normal(0, 5), class = "b", dpar = "muy3") - scode <- make_stancode(bf(y ~ 1, muy3 ~ x), data = dat, + scode <- make_stancode(bf(y ~ 1, muy3 ~ x), data = dat, family = brmsfamily("dirichlet2"), prior = prior) expect_match2(scode, "vector[ncat] Y[N];") expect_match2(scode, "muy3[n] = exp(muy3[n]);") expect_match2(scode, "target += dirichlet_lpdf(Y[n] | mu[n]);") expect_match2(scode, "muy3 = Intercept_muy3 + Xc_muy3 * b_muy3;") expect_match2(scode, "mu[n] = transpose([muy1[n], muy2[n], muy3[n]]);") - expect_match2(scode, "target += normal_lpdf(b_muy3 | 0, 5);") - expect_match2(scode, "target += student_t_lpdf(Intercept_muy1 | 3, 0, 2.5);") + expect_match2(scode, "lprior += normal_lpdf(b_muy3 | 0, 5);") + expect_match2(scode, "lprior += student_t_lpdf(Intercept_muy1 | 3, 0, 2.5);") +}) + +test_that("Stan code for logistic_normal models is correct", { + N <- 15 + dat <- as.data.frame(rdirichlet(N, c(3, 2, 1))) + names(dat) <- c("y1", "y2", "y3") + dat$x <- rnorm(N) + dat$y <- with(dat, cbind(y1, y2, y3)) + + prior <- prior(normal(0, 5), class = "b", dpar = "muy3") + + prior(exponential(10), "sigmay1") + + prior(lkj(3), "lncor") + scode <- make_stancode(bf(y ~ x), data = dat, + family = logistic_normal(refcat = "y2"), + prior = prior) + expect_match2(scode, "vector[ncat] Y[N];") + expect_match2(scode, "mu[n] = transpose([muy1[n], muy3[n]]);") + expect_match2(scode, "vector[ncat-1] sigma = transpose([sigmay1, sigmay3]);") + expect_match2(scode, "target += logistic_normal_cholesky_cor_lpdf(Y[n] | mu[n], sigma, Llncor, 2);") + expect_match2(scode, "muy3 = Intercept_muy3 + Xc_muy3 * b_muy3;") + expect_match2(scode, "lprior += normal_lpdf(b_muy3 | 0, 5);") + expect_match2(scode, "lprior += exponential_lpdf(sigmay1 | 10);") + expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Llncor | 3);") + + prior <- prior(normal(0, 5), class = "b", dpar = "muy3") + + prior(normal(0, 3), class = "b", dpar = "sigmay2") + scode <- make_stancode(bf(y ~ 1, muy3 ~ x, sigmay2 ~ x), data = dat, + family = logistic_normal(), + prior = prior) + expect_match2(scode, "vector[ncat] Y[N];") + expect_match2(scode, "mu[n] = transpose([muy2[n], muy3[n]]);") + expect_match2(scode, "sigma[n] = transpose([sigmay2[n], sigmay3]);") + expect_match2(scode, "target += logistic_normal_cholesky_cor_lpdf(Y[n] | mu[n], sigma[n], Llncor, 1);") + expect_match2(scode, "muy3 = Intercept_muy3 + Xc_muy3 * b_muy3;") + expect_match2(scode, "lprior += normal_lpdf(b_muy3 | 0, 5);") + expect_match2(scode, "lprior += normal_lpdf(b_sigmay2 | 0, 3);") + expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Llncor | 1);") }) test_that("Stan code for ARMA models is correct", { dat <- data.frame(y = rep(1:4, 2), x = 1:8, time = 1:8) scode <- make_stancode(y ~ x + ar(time), dat, student()) + expect_match2(scode, "vector[Kar] ar") expect_match2(scode, "err[n] = Y[n] - mu[n];") expect_match2(scode, "mu[n] += Err[n, 1:Kar] * ar;") - + scode <- make_stancode(y ~ x + ma(time, q = 2), dat, student()) expect_match2(scode, "mu[n] += Err[n, 1:Kma] * ma;") - + expect_warning( - scode <- make_stancode(mvbind(y, x) ~ 1, dat, gaussian(), + scode <- make_stancode(mvbind(y, x) ~ 1, dat, gaussian(), autocor = cor_ar()), "Argument 'autocor' should be specified within the 'formula' argument" ) expect_match2(scode, "err_y[n] = Y_y[n] - mu_y[n];") - + bform <- bf(y ~ x, sigma ~ x) + acformula(~arma(time, cov = TRUE)) scode <- make_stancode(bform, dat, family = student) expect_match2(scode, "student_t_time_het_lpdf(Y | nu, mu, sigma, chol_cor") - + bform <- bf(y ~ exp(eta) - 1, eta ~ x, autocor = ~ar(time), nl = TRUE) scode <- make_stancode(bform, dat, family = student, prior = prior(normal(0, 1), nlpar = eta)) expect_match2(scode, "mu[n] += Err[n, 1:Kar] * ar;") - + # correlations of latent residuals scode <- make_stancode( y ~ x + ar(time, cov = TRUE), dat, family = poisson, prior = prior(cauchy(0, 10), class = sderr) ) expect_match2(scode, "chol_cor = cholesky_cor_ar1(ar[1], max_nobs_tg);") - expect_match2(scode, + expect_match2(scode, "err = scale_time_err(zerr, sderr, chol_cor, nobs_tg, begin_tg, end_tg);" ) expect_match2(scode, "vector[N] mu = Intercept + Xc * b + err;") - expect_match2(scode, "target += cauchy_lpdf(sderr | 0, 10);") - + expect_match2(scode, "lprior += cauchy_lpdf(sderr | 0, 10)") + scode <- make_stancode( y ~ x + ar(time), dat, family = poisson, prior = prior(cauchy(0, 10), class = sderr) ) + expect_match2(scode, "vector[Kar] ar") expect_match2(scode, "mu[n] += Err[n, 1:Kar] * ar;") expect_match2(scode, "err = sderr * zerr;") expect_match2(scode, "vector[N] mu = Intercept + Xc * b + err;") - expect_match2(scode, "target += cauchy_lpdf(sderr | 0, 10);") + expect_match2(scode, "lprior += cauchy_lpdf(sderr | 0, 10)") }) test_that("Stan code for compound symmetry models is correct", { @@ -748,38 +800,38 @@ ) expect_match2(scode, "real cosy;") expect_match2(scode, "chol_cor = cholesky_cor_cosy(cosy, max_nobs_tg);") - expect_match2(scode, "target += normal_lpdf(cosy | 0, 2);") - + expect_match2(scode, "lprior += normal_lpdf(cosy | 0, 2)") + scode <- make_stancode(bf(y ~ x + cosy(time), sigma ~ x), dat) expect_match2(scode, "normal_time_het_lpdf(Y | mu, sigma, chol_cor") - + scode <- make_stancode(y ~ x + cosy(time), dat, family = poisson) expect_match2(scode, "chol_cor = cholesky_cor_cosy(cosy, max_nobs_tg);") }) test_that("Stan code for intercept only models is correct", { expect_match2(make_stancode(rating ~ 1, data = inhaler), - "b_Intercept = Intercept;") + "b_Intercept = Intercept;") expect_match2(make_stancode(rating ~ 1, data = inhaler, family = cratio()), - "b_Intercept = Intercept;") + "b_Intercept = Intercept;") expect_match2(make_stancode(rating ~ 1, data = inhaler, family = categorical()), "b_mu3_Intercept = Intercept_mu3;") }) test_that("Stan code of ordinal models is correct", { - dat <- data.frame(y = c(rep(1:4, 2), 1, 1), x1 = rnorm(10), + dat <- data.frame(y = c(rep(1:4, 2), 1, 1), x1 = rnorm(10), x2 = rnorm(10), g = factor(rep(1:2, 5))) - + scode <- make_stancode( y ~ x1, dat, family = cumulative(), prior = prior(normal(0, 2), Intercept, coef = 2) ) - expect_match2(scode, + expect_match2(scode, "target += ordered_logistic_lpmf(Y[n] | mu[n], Intercept);" ) - expect_match2(scode, "target += student_t_lpdf(Intercept[1] | 3, 0, 2.5);") - expect_match2(scode, "target += normal_lpdf(Intercept[2] | 0, 2);") - + expect_match2(scode, "lprior += student_t_lpdf(Intercept[1] | 3, 0, 2.5);") + expect_match2(scode, "lprior += normal_lpdf(Intercept[2] | 0, 2);") + scode <- make_stancode( y ~ x1, dat, cumulative("probit", threshold = "equidistant"), prior = prior(normal(0, 2), Intercept) @@ -789,8 +841,8 @@ expect_match2(scode, "real delta;") expect_match2(scode, "Intercept[k] = first_Intercept + (k - 1.0) * delta;") expect_match2(scode, "b_Intercept = Intercept + dot_product(means_X, b);") - expect_match2(scode, "target += normal_lpdf(first_Intercept | 0, 2);") - + expect_match2(scode, "lprior += normal_lpdf(first_Intercept | 0, 2);") + scode <- make_stancode(y ~ x1, dat, family = cratio("probit")) expect_match2(scode, "real cratio_probit_lpmf(int y") expect_match2(scode, "q[k] = normal_lcdf(disc * (mu - thres[k])|0,1);") @@ -800,23 +852,23 @@ expect_match2(scode, "matrix[N, Kcs] Xcs;") expect_match2(scode, "matrix[Kcs, nthres] bcs;") expect_match2(scode, "mucs = Xcs * bcs;") - expect_match2(scode, + expect_match2(scode, "target += sratio_logit_lpmf(Y[n] | mu[n], disc, Intercept - transpose(mucs[n]));" ) - + scode <- make_stancode(y ~ x1 + cse(x2) + (cse(1)|g), dat, family = acat()) expect_match2(scode, "real acat_logit_lpmf(int y") expect_match2(scode, "mucs[n, 1] = mucs[n, 1] + r_1_1[J_1[n]] * Z_1_1[n];") expect_match2(scode, "b_Intercept = Intercept + dot_product(means_X, b);") - + scode <- make_stancode(y ~ x1 + (cse(x2)||g), dat, family = acat("probit_approx")) - expect_match2(scode, - paste("mucs[n, 3] = mucs[n, 3] + r_1_3[J_1[n]] * Z_1_3[n]", + expect_match2(scode, + paste("mucs[n, 3] = mucs[n, 3] + r_1_3[J_1[n]] * Z_1_3[n]", "+ r_1_6[J_1[n]] * Z_1_6[n];")) - expect_match2(scode, + expect_match2(scode, "target += acat_probit_approx_lpmf(Y[n] | mu[n], disc, Intercept - transpose(mucs[n]));" ) - + # sum-to-zero thresholds scode <- make_stancode( y ~ x1, dat, cumulative("probit", threshold = "sum_to_zero"), @@ -825,36 +877,36 @@ expect_match2(scode, "Intercept_stz = Intercept - mean(Intercept);") expect_match2(scode, "cumulative_probit_lpmf(Y[n] | mu[n], disc, Intercept_stz);") expect_match2(scode, "vector[nthres] b_Intercept = Intercept_stz;") - + # non-linear ordinal models scode <- make_stancode( bf(y ~ eta, eta ~ x1, nl = TRUE), dat, family = cumulative(), prior = prior(normal(0, 2), nlpar = eta) ) expect_match2(scode, "ordered[nthres] Intercept;") - expect_match2(scode, - "target += ordered_logistic_lpmf(Y[n] | mu[n], Intercept);" + expect_match2(scode, + "target += ordered_logistic_lpmf(Y[n] | mu[n], Intercept);" ) - + # ordinal mixture models with fixed intercepts scode <- make_stancode( - bf(y ~ 1, mu1 ~ x1, mu2 ~ 1), data = dat, + bf(y ~ 1, mu1 ~ x1, mu2 ~ 1), data = dat, family = mixture(cumulative(), nmix = 2, order = "mu") ) expect_match2(scode, "Intercept_mu2 = fixed_Intercept;") - expect_match2(scode, "target += student_t_lpdf(fixed_Intercept | 3, 0, 2.5);") + expect_match2(scode, "lprior += student_t_lpdf(fixed_Intercept | 3, 0, 2.5);") }) test_that("ordinal disc parameters appear in the Stan code", { scode <- make_stancode( bf(rating ~ period + carry + treat, disc ~ period), - data = inhaler, family = cumulative(), + data = inhaler, family = cumulative(), prior = prior(normal(0,5), dpar = disc) ) - expect_match2(scode, + expect_match2(scode, "target += cumulative_logit_lpmf(Y[n] | mu[n], disc[n], Intercept)" ) - expect_match2(scode, "target += normal_lpdf(b_disc | 0, 5)") + expect_match2(scode, "lprior += normal_lpdf(b_disc | 0, 5)") expect_match2(scode, "disc[n] = exp(disc[n])") }) @@ -866,43 +918,43 @@ th = rep(5:6, each = 5), x = rnorm(10) ) - + prior <- prior(normal(0,1), class = "Intercept", group = "b") scode <- make_stancode( - y | thres(th, gr) ~ x, data = dat, + y | thres(th, gr) ~ x, data = dat, family = sratio(), prior = prior ) expect_match2(scode, "int nthres[ngrthres];") expect_match2(scode, "merged_Intercept[Kthres_start[1]:Kthres_end[1]] = Intercept_1;") expect_match2(scode, "target += sratio_logit_merged_lpmf(Y[n]") - expect_match2(scode, "target += normal_lpdf(Intercept_2 | 0, 1);") + expect_match2(scode, "lprior += normal_lpdf(Intercept_2 | 0, 1);") # centering needs to be deactivated automatically expect_match2(scode, "vector[nthres[1]] b_Intercept_1 = Intercept_1;") - + # model with equidistant thresholds scode <- make_stancode( - y | thres(th, gr) ~ x, data = dat, - family = cumulative(threshold = "equidistant"), + y | thres(th, gr) ~ x, data = dat, + family = cumulative(threshold = "equidistant"), prior = prior ) expect_match2(scode, "target += ordered_logistic_merged_lpmf(Y[n]") expect_match2(scode, "real first_Intercept_1;") - expect_match2(scode, "target += normal_lpdf(first_Intercept_2 | 0, 1);") + expect_match2(scode, "lprior += normal_lpdf(first_Intercept_2 | 0, 1);") expect_match2(scode, "Intercept_2[k] = first_Intercept_2 + (k - 1.0) * delta_2;") - + # sum-to-zero constraints scode <- make_stancode( - y | thres(gr = gr) ~ x, data = dat, + y | thres(gr = gr) ~ x, data = dat, cumulative(threshold = "sum_to_zero"), prior = prior(normal(0, 2), Intercept) ) expect_match2(scode, "merged_Intercept_stz[Kthres_start[2]:Kthres_end[2]] = Intercept_stz_2;") expect_match2(scode, "ordered_logistic_merged_lpmf(Y[n] | mu[n], merged_Intercept_stz, Jthres[n]);") - + # ordinal mixture model scode <- make_stancode( - y | thres(th, gr) ~ x, data = dat, - family = mixture(cratio, acat, order = "mu"), + y | thres(th, gr) ~ x, data = dat, + family = mixture(cratio, acat, order = "mu"), prior = prior ) expect_match2(scode, "ps[1] = log(theta1) + cratio_logit_merged_lpmf(Y[n]") @@ -910,20 +962,20 @@ expect_match2(scode, "vector[nmthres] merged_Intercept_mu1;") expect_match2(scode, "merged_Intercept_mu2[Kthres_start[1]:Kthres_end[1]] = Intercept_mu2_1;") expect_match2(scode, "vector[nthres[1]] b_mu1_Intercept_1 = Intercept_mu1_1;") - + # multivariate ordinal model bform <- bf(y | thres(th, gr) ~ x, family = sratio) + - bf(y2 | thres(th, gr) ~ x, family = cumulative) + bf(y2 | thres(th, gr) ~ x, family = cumulative) scode <- make_stancode(bform, data = dat) - expect_match2(scode, "target += student_t_lpdf(Intercept_y2_1 | 3, 0, 2.5);") + expect_match2(scode, "lprior += student_t_lpdf(Intercept_y2_1 | 3, 0, 2.5);") expect_match2(scode, "merged_Intercept_y[Kthres_start_y[2]:Kthres_end_y[2]] = Intercept_y_2;") }) test_that("monotonic effects appear in the Stan code", { - dat <- data.frame(y = rpois(120, 10), x1 = rep(1:4, 30), + dat <- data.frame(y = rpois(120, 10), x1 = rep(1:4, 30), x2 = factor(rep(c("a", "b", "c"), 40), ordered = TRUE), g = rep(1:10, each = 12)) - + prior <- c(prior(normal(0,1), class = b, coef = mox1), prior(dirichlet(c(1,0.5,2)), simo, coef = mox11), prior(dirichlet(c(1,0.5,2)), simo, coef = mox21)) @@ -931,40 +983,40 @@ expect_match2(scode, "int Xmo_3[N];") expect_match2(scode, "simplex[Jmo[1]] simo_1;") expect_match2(scode, "(bsp[2]) * mo(simo_2, Xmo_2[n])") - expect_match2(scode, + expect_match2(scode, "(bsp[6]) * mo(simo_7, Xmo_7[n]) * mo(simo_8, Xmo_8[n]) * Csp_3[n]" ) - expect_match2(scode, "target += normal_lpdf(bsp[1] | 0, 1)") - expect_match2(scode, "target += dirichlet_lpdf(simo_1 | con_simo_1);") - expect_match2(scode, "target += dirichlet_lpdf(simo_8 | con_simo_8);") - + expect_match2(scode, "lprior += normal_lpdf(bsp[1] | 0, 1)") + expect_match2(scode, "lprior += dirichlet_lpdf(simo_1 | con_simo_1);") + expect_match2(scode, "lprior += dirichlet_lpdf(simo_8 | con_simo_8);") + scode <- make_stancode(y ~ mo(x1) + (mo(x1) | x2), dat) expect_match2(scode, "(bsp[1] + r_1_2[J_1[n]]) * mo(simo_1, Xmo_1[n])") expect_true(!grepl("Z_1_w", scode)) - + # test issue reported in discourse post #12978 scode <- make_stancode(y ~ mo(x1) + (mo(x1) | x2) + (mo(x1) | g), dat) expect_match2(scode, "(bsp[1] + r_1_2[J_1[n]] + r_2_2[J_2[n]]) * mo(simo_1, Xmo_1[n])") - + # test issue #813 scode <- make_stancode(y ~ mo(x1):y, dat) expect_match2(scode, "mu[n] += (bsp[1]) * mo(simo_1, Xmo_1[n]) * Csp_1[n];") - + # test issue #924 (conditional monotonicity) prior <- c(prior(dirichlet(c(1,0.5,2)), simo, coef = "v"), prior(dirichlet(c(1,0.5,2)), simo, coef = "w")) - scode <- make_stancode(y ~ y*mo(x1, id = "v")*mo(x2, id = "w"), + scode <- make_stancode(y ~ y*mo(x1, id = "v")*mo(x2, id = "w"), dat, prior = prior) - expect_match2(scode, "target += dirichlet_lpdf(simo_1 | con_simo_1);") - expect_match2(scode, "target += dirichlet_lpdf(simo_2 | con_simo_2);") + expect_match2(scode, "lprior += dirichlet_lpdf(simo_1 | con_simo_1);") + expect_match2(scode, "lprior += dirichlet_lpdf(simo_2 | con_simo_2);") expect_match2(scode, "simplex[Jmo[6]] simo_6 = simo_2;") expect_match2(scode, "simplex[Jmo[7]] simo_7 = simo_1;") - + expect_error( make_stancode(y ~ mo(x1) + (mo(x2) | x2), dat), "Special group-level terms require" ) - + prior <- prior(beta(1, 1), simo, coef = mox11) expect_error( make_stancode(y ~ mo(x1), dat, prior = prior), @@ -975,49 +1027,49 @@ test_that("Stan code for non-linear models is correct", { flist <- list(a ~ x, b ~ z + (1|g)) data <- data.frame( - y = rgamma(9, 1, 1), x = rnorm(9), + y = rgamma(9, 1, 1), x = rnorm(9), z = rnorm(9), v = 1L:9L, g = rep(1:3, 3) ) prior <- c(set_prior("normal(0,5)", nlpar = "a"), set_prior("normal(0,1)", nlpar = "b")) # syntactic validity is already checked within make_stancode scode <- make_stancode( - bf(y ~ a - exp(b^z) * (z <= a) * v, flist = flist, nl = TRUE), + bf(y ~ a - exp(b^z) * (z <= a) * v, flist = flist, nl = TRUE), data = data, prior = prior ) - expect_match2(scode, + expect_match2(scode, "mu[n] = nlp_a[n] - exp(nlp_b[n] ^ C_1[n]) * (C_1[n] <= nlp_a[n]) * C_2[n];" ) expect_match2(scode, "vector[N] C_1;") expect_match2(scode, "int C_2[N];") - + # non-linear predictor can be computed outside a loop - scode <- make_stancode(bf(y ~ a - exp(b + z), flist = flist, - nl = TRUE, loop = FALSE), + scode <- make_stancode(bf(y ~ a - exp(b + z), flist = flist, + nl = TRUE, loop = FALSE), data = data, prior = prior) expect_match2(scode, "mu = nlp_a - exp(nlp_b + C_1);") - + # check if that only works with threading - scode <- make_stancode(bf(y ~ a - exp(b + z), flist = flist, - nl = TRUE, loop = FALSE), - data = data, prior = prior, + scode <- make_stancode(bf(y ~ a - exp(b + z), flist = flist, + nl = TRUE, loop = FALSE), + data = data, prior = prior, threads = threading(2), parse = FALSE) expect_match2(scode, "mu = nlp_a - exp(nlp_b + C_1[start:end]);") - + flist <- list(a1 ~ 1, a2 ~ z + (x|g)) prior <- c(set_prior("beta(1,1)", nlpar = "a1", lb = 0, ub = 1), set_prior("normal(0,1)", nlpar = "a2")) scode <- make_stancode( - bf(y ~ a1 * exp(-x/(a2 + z)), + bf(y ~ a1 * exp(-x/(a2 + z)), flist = flist, nl = TRUE), - data = data, family = Gamma("log"), + data = data, family = Gamma("log"), prior = prior ) expect_match2(scode, - paste("mu[n] = shape * exp(-(nlp_a1[n] *", + paste("mu[n] = shape * exp(-(nlp_a1[n] *", "exp( - C_1[n] / (nlp_a2[n] + C_2[n]))));")) - - bform <- bf(y ~ x) + + + bform <- bf(y ~ x) + nlf(sigma ~ a1 * exp(-x/(a2 + z))) + lf(a1 ~ 1, a2 ~ z + (x|g)) + lf(alpha ~ x) @@ -1032,8 +1084,8 @@ expect_match2(scode, "sigma[n] = exp(nlp_a1[n] * exp( - C_sigma_1[n] / (nlp_a2[n] + C_sigma_2[n])))" ) - expect_match2(scode, "target += normal_lpdf(b_a2 | 0, 5)") - + expect_match2(scode, "lprior += normal_lpdf(b_a2 | 0, 5)") + expect_error(make_stancode(bform, data, family = skew_normal()), "Priors on population-level coefficients are required") }) @@ -1049,14 +1101,14 @@ prior(normal(0, 1), nlpar = "b") scode <- make_stancode(bform, dat, prior = bprior) expect_match2(scode, "nlp_lb[n] = inv_logit(nlp_a[n] / C_lb_1[n]);") - expect_match2(scode, + expect_match2(scode, "mu[n] = nlp_lb[n] + (1 - nlp_lb[n]) * inv_logit(nlp_b[n] * C_1[n]);" ) }) test_that("make_stancode accepts very long non-linear formulas", { data <- data.frame(y = rnorm(10), this_is_a_very_long_predictor = rnorm(10)) - expect_silent(make_stancode(bf(y ~ b0 + this_is_a_very_long_predictor + + expect_silent(make_stancode(bf(y ~ b0 + this_is_a_very_long_predictor + this_is_a_very_long_predictor + this_is_a_very_long_predictor, b0 ~ 1, nl = TRUE), @@ -1066,8 +1118,8 @@ test_that("no loop in trans-par is defined for simple 'identity' models", { expect_true(!grepl(make_stancode(time ~ age, data = kidney), "mu[n] = (mu[n]);", fixed = TRUE)) - expect_true(!grepl(make_stancode(time ~ age, data = kidney, - family = poisson("identity")), + expect_true(!grepl(make_stancode(time ~ age, data = kidney, + family = poisson("identity")), "mu[n] = (mu[n]);", fixed = TRUE)) }) @@ -1078,7 +1130,7 @@ expect_match2(scode, "target += weights[n] * (normal_lpdf(Y[n] | mu[n], se[n]))") scode <- make_stancode(time | se(age, sigma = TRUE) ~ sex, data = kidney) expect_match2(scode, "target += normal_lpdf(Y | mu, sqrt(square(sigma) + se2))") - scode <- make_stancode(bf(time | se(age, sigma = TRUE) ~ sex, sigma ~ sex), + scode <- make_stancode(bf(time | se(age, sigma = TRUE) ~ sex, sigma ~ sex), data = kidney) expect_match2(scode, "target += normal_lpdf(Y | mu, sqrt(square(sigma) + se2))") }) @@ -1109,17 +1161,17 @@ expect_match2(scode, "Zs_1_1 * s_1_1") expect_match2(scode, "matrix[N, knots_1[1]] Zs_1_1") expect_match2(scode, "target += std_normal_lpdf(zs_1_1)") - expect_match2(scode, "target += normal_lpdf(sds_1_1 | 0,2)") - + expect_match2(scode, "lprior += normal_lpdf(sds_1_1 | 0,2)") + prior <- c(set_prior("normal(0,5)", nlpar = "lp"), set_prior("normal(0,2)", "sds", nlpar = "lp")) - scode <- make_stancode(bf(y ~ lp, lp ~ s(x) + (1|g), nl = TRUE), + scode <- make_stancode(bf(y ~ lp, lp ~ s(x) + (1|g), nl = TRUE), data = dat, prior = prior) expect_match2(scode, "Zs_lp_1_1 * s_lp_1_1") expect_match2(scode, "matrix[N, knots_lp_1[1]] Zs_lp_1_1") expect_match2(scode, "target += std_normal_lpdf(zs_lp_1_1)") - expect_match2(scode, "target += normal_lpdf(sds_lp_1_1 | 0,2)") - + expect_match2(scode, "lprior += normal_lpdf(sds_lp_1_1 | 0,2)") + scode <- make_stancode( y ~ s(x) + t2(x,y), data = dat, prior = set_prior("normal(0,1)", "sds") + @@ -1128,9 +1180,9 @@ expect_match2(scode, "Zs_2_2 * s_2_2") expect_match2(scode, "matrix[N, knots_2[2]] Zs_2_2") expect_match2(scode, "target += std_normal_lpdf(zs_2_2)") - expect_match2(scode, "target += normal_lpdf(sds_1_1 | 0,1)") - expect_match2(scode, "target += normal_lpdf(sds_2_2 | 0,2)") - + expect_match2(scode, "lprior += normal_lpdf(sds_1_1 | 0,1)") + expect_match2(scode, "lprior += normal_lpdf(sds_2_2 | 0,2)") + scode <- make_stancode(y ~ g + s(x, by = g), data = dat) expect_match2(scode, "vector[knots_2[1]] zs_2_1") expect_match2(scode, "s_2_1 = sds_2_1 * zs_2_1") @@ -1146,62 +1198,62 @@ "target += exp_mod_normal_lpdf(Y | mu - beta, sigma, inv(beta))" ) expect_match2(scode, "mu[n] = exp(mu[n])") - expect_match2(scode, "target += gamma_lpdf(beta | 1, 1)") - + expect_match2(scode, "lprior += gamma_lpdf(beta | 1, 1)") + scode <- make_stancode(bf(count ~ Trt + (1|patient), sigma ~ Trt, beta ~ Trt), data = dat, family = exgaussian()) - expect_match2(scode, + expect_match2(scode, "target += exp_mod_normal_lpdf(Y | mu - beta, sigma, inv(beta))" ) expect_match2(scode, "beta[n] = exp(beta[n])") - + scode <- make_stancode(count | cens(cens) ~ Trt + (1|patient), data = dat, family = exgaussian("inverse")) expect_match2(scode, "exp_mod_normal_lccdf(Y[n] | mu[n] - beta, sigma, inv(beta))") - + scode <- make_stancode(count ~ Trt, dat, family = shifted_lognormal()) expect_match2(scode, "target += lognormal_lpdf(Y - ndt | mu, sigma)") - + scode <- make_stancode(count | cens(cens) ~ Trt, dat, family = shifted_lognormal()) expect_match2(scode, "target += lognormal_lcdf(Y[n] - ndt | mu[n], sigma)") - + # test issue #837 scode <- make_stancode(mvbind(count, zBase) ~ Trt, data = dat, family = shifted_lognormal()) - expect_match2(scode, "target += uniform_lpdf(ndt_count | 0, min_Y_count)") - expect_match2(scode, "target += uniform_lpdf(ndt_zBase | 0, min_Y_zBase)") + expect_match2(scode, "lprior += uniform_lpdf(ndt_count | 0, min_Y_count)") + expect_match2(scode, "lprior += uniform_lpdf(ndt_zBase | 0, min_Y_zBase)") }) test_that("Stan code of wiener diffusion models is correct", { dat <- data.frame(q = 1:10, resp = sample(0:1, 10, TRUE), x = rnorm(10)) scode <- make_stancode(q | dec(resp) ~ x, data = dat, family = wiener()) - expect_match2(scode, + expect_match2(scode, "target += wiener_diffusion_lpdf(Y[n] | dec[n], bs, ndt, bias, mu[n])" ) - - scode <- make_stancode(bf(q | dec(resp) ~ x, bs ~ x, ndt ~ x, bias ~ x), + + scode <- make_stancode(bf(q | dec(resp) ~ x, bs ~ x, ndt ~ x, bias ~ x), data = dat, family = wiener()) expect_match2(scode, "target += wiener_diffusion_lpdf(Y[n] | dec[n], bs[n], ndt[n], bias[n], mu[n])" ) expect_match2(scode, "bias[n] = inv_logit(bias[n]);") - - scode <- make_stancode(bf(q | dec(resp) ~ x, ndt = 0.5), + + scode <- make_stancode(bf(q | dec(resp) ~ x, ndt = 0.5), data = dat, family = wiener()) - expect_match2(scode, "real ndt = 0.5;") - + expect_match2(scode, "real ndt = 0.5;") + expect_error(make_stancode(q ~ x, data = dat, family = wiener()), "Addition argument 'dec' is required for family 'wiener'") }) test_that("Group IDs appear in the Stan code", { - form <- bf(count ~ Trt + (1+Trt|3|visit) + (1|patient), + form <- bf(count ~ Trt + (1+Trt|3|visit) + (1|patient), shape ~ (1|3|visit) + (Trt||patient)) scode <- make_stancode(form, data = epilepsy, family = negbinomial()) expect_match2(scode, "r_2_1 = r_2[, 1]") expect_match2(scode, "r_2_shape_3 = r_2[, 3]") - + form <- bf(count ~ a, sigma ~ (1|3|visit) + (Trt||patient), a ~ Trt + (1+Trt|3|visit) + (1|patient), nl = TRUE) scode <- make_stancode(form, data = epilepsy, family = student(), @@ -1213,67 +1265,80 @@ test_that("distributional gamma models are handled correctly", { # test fix of issue #124 scode <- make_stancode( - bf(time ~ age * sex + disease + (1|patient), - shape ~ age + (1|patient)), + bf(time ~ age * sex + disease + (1|patient), + shape ~ age + (1|patient)), data = kidney, family = Gamma("log") ) expect_match(scode, paste0( brms:::escape_all("shape[n] = exp(shape[n]);"), ".+", brms:::escape_all("mu[n] = shape[n] * exp(-(mu[n]));") )) - + scode <- make_stancode( bf(time ~ inv_logit(a) * exp(b * age), - a + b ~ sex + (1|patient), nl = TRUE, - shape ~ age + (1|patient)), + a + b ~ sex + (1|patient), nl = TRUE, + shape ~ age + (1|patient)), data = kidney, family = Gamma("identity"), prior = c(set_prior("normal(2,2)", nlpar = "a"), set_prior("normal(0,3)", nlpar = "b")) ) expect_match(scode, paste0( - brms:::escape_all("shape[n] = exp(shape[n]);"), ".+", + brms:::escape_all("shape[n] = exp(shape[n]);"), ".+", brms:::escape_all("mu[n] = shape[n] / (inv_logit(nlp_a[n]) * exp(nlp_b[n] * C_1[n]));") )) }) test_that("weighted, censored, and truncated likelihoods are correct", { dat <- data.frame(y = 1:9, x = rep(-1:1, 3), y2 = 10:18) - + scode <- make_stancode(y | weights(y2) ~ 1, dat, poisson()) expect_match2(scode, "target += weights[n] * (poisson_log_lpmf(Y[n] | mu[n]));") - + scode <- make_stancode(y | trials(y2) + weights(y2) ~ 1, dat, binomial()) - expect_match2(scode, + expect_match2(scode, "target += weights[n] * (binomial_logit_lpmf(Y[n] | trials[n], mu[n]));" ) - + scode <- make_stancode(y | cens(x, y2) ~ 1, dat, poisson()) expect_match2(scode, "target += poisson_lpmf(Y[n] | mu[n]);") - + scode <- make_stancode(y | cens(x) ~ 1, dat, weibull()) expect_match2(scode, "target += weibull_lccdf(Y[n] | shape, mu[n]);") - + dat$x[1] <- 2 scode <- make_stancode(y | cens(x, y2) ~ 1, dat, gaussian()) expect_match2(scode, paste0( - "target += log_diff_exp(\n", + "target += log_diff_exp(\n", " normal_lcdf(rcens[n] | mu[n], sigma)," )) dat$x <- 1 expect_match2(make_stancode(y | cens(x) + weights(x) ~ 1, dat, weibull()), "target += weights[n] * weibull_lccdf(Y[n] | shape, mu[n]);") - + scode <- make_stancode(y | cens(x) + trunc(0.1) ~ 1, dat, weibull()) expect_match2(scode, "target += weibull_lccdf(Y[n] | shape, mu[n]) -") expect_match2(scode, " weibull_lccdf(lb[n] | shape, mu[n]);") - + scode <- make_stancode(y | cens(x) + trunc(ub = 30) ~ 1, dat) expect_match2(scode, "target += normal_lccdf(Y[n] | mu[n], sigma) -") expect_match2(scode, " normal_lcdf(ub[n] | mu[n], sigma);") - + scode <- make_stancode(y | weights(x) + trunc(0, 30) ~ 1, dat) expect_match2(scode, "target += weights[n] * (normal_lpdf(Y[n] | mu[n], sigma) -") expect_match2(scode, " log_diff_exp(normal_lcdf(ub[n] | mu[n], sigma),") + + expect_match2( + make_stancode(y | trials(y2) + weights(y2) ~ 1, dat, beta_binomial()), + "target += weights[n] * (beta_binomial_lpmf(Y[n] | trials[n], mu[n] * phi," + ) + expect_match2( + make_stancode(y | trials(y2) + trunc(0, 30) ~ 1, dat, beta_binomial()), + "log_diff_exp(beta_binomial_lcdf(ub[n] | trials[n], mu[n] * phi," + ) + expect_match2( + make_stancode(y | trials(y2) + cens(x, y2) ~ 1, dat, beta_binomial()), + "beta_binomial_lcdf(rcens[n] | trials[n], mu[n] * phi," + ) }) test_that("noise-free terms appear in the Stan code", { @@ -1283,8 +1348,8 @@ xsd = abs(rnorm(N, 1)), zsd = abs(rnorm(N, 1)), ID = rep(1:5, each = N / 5) ) - - me_prior <- prior(normal(0,5)) + + + me_prior <- prior(normal(0,5)) + prior(normal(0, 10), "meanme") + prior(cauchy(0, 5), "sdme", coef = "mez") + prior(lkj(2), "corme") @@ -1292,52 +1357,52 @@ y ~ me(x, xsd)*me(z, zsd)*x, data = dat, prior = me_prior, sample_prior = "yes" ) - expect_match2(scode, + expect_match2(scode, "(bsp[1]) * Xme_1[n] + (bsp[2]) * Xme_2[n] + (bsp[3]) * Xme_1[n] * Xme_2[n]" ) expect_match2(scode, "(bsp[6]) * Xme_1[n] * Xme_2[n] * Csp_3[n]") expect_match2(scode, "target += normal_lpdf(Xn_2 | Xme_2, noise_2)") - expect_match2(scode, "target += normal_lpdf(bsp | 0, 5)") + expect_match2(scode, "lprior += normal_lpdf(bsp | 0, 5)") expect_match2(scode, "target += std_normal_lpdf(to_vector(zme_1))") - expect_match2(scode, "target += normal_lpdf(meanme_1 | 0, 10)") - expect_match2(scode, "target += cauchy_lpdf(sdme_1[2] | 0, 5)") - expect_match2(scode, "target += lkj_corr_cholesky_lpdf(Lme_1 | 2)") + expect_match2(scode, "lprior += normal_lpdf(meanme_1 | 0, 10)") + expect_match2(scode, "lprior += cauchy_lpdf(sdme_1[2] | 0, 5)") + expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(Lme_1 | 2)") expect_match2(scode, "+ transpose(diag_pre_multiply(sdme_1, Lme_1) * zme_1)") expect_match2(scode, "corme_1[choose(k - 1, 2) + j] = Corme_1[j, k];") - + scode <- make_stancode( y ~ me(x, xsd)*z + (me(x, xsd)*z | ID), data = dat ) expect_match2(scode, "(bsp[1] + r_1_3[J_1[n]]) * Xme_1[n]") expect_match2(scode, "(bsp[2] + r_1_4[J_1[n]]) * Xme_1[n] * Csp_1[n]") - + expect_match2(make_stancode(y ~ I(me(x, xsd)^2), data = dat), "(bsp[1]) * (Xme_1[n]^2)") - + # test that noise-free variables are unique across model parts scode <- make_stancode( - bf(y ~ me(x, xsd)*me(z, zsd)*x, sigma ~ me(x, xsd)), + bf(y ~ me(x, xsd)*me(z, zsd)*x, sigma ~ me(x, xsd)), data = dat, prior = prior(normal(0,5)) ) expect_match2(scode, "mu[n] += (bsp[1]) * Xme_1[n]") expect_match2(scode, "sigma[n] += (bsp_sigma[1]) * Xme_1[n]") - + scode <- make_stancode( - bf(y ~ a * b, a + b ~ me(x, xsd), nl = TRUE), - data = dat, - prior = prior(normal(0,5), nlpar = a) + + bf(y ~ a * b, a + b ~ me(x, xsd), nl = TRUE), + data = dat, + prior = prior(normal(0,5), nlpar = a) + prior(normal(0, 5), nlpar = b) ) expect_match2(scode, "nlp_a[n] += (bsp_a[1]) * Xme_1[n]") expect_match2(scode, "nlp_b[n] += (bsp_b[1]) * Xme_1[n]") - - bform <- bf(mvbind(y, z) ~ me(x, xsd)) + + + bform <- bf(mvbind(y, z) ~ me(x, xsd)) + set_rescor(TRUE) + set_mecor(FALSE) scode <- make_stancode(bform, dat) expect_match2(scode, "mu_y[n] += (bsp_y[1]) * Xme_1[n]") expect_match2(scode, "mu_z[n] += (bsp_z[1]) * Xme_1[n]") expect_match2(scode, "Xme_1 = meanme_1[1] + sdme_1[1] * zme_1;") - + # noise-free terms with grouping factors bform <- bf(y ~ me(x, xsd, ID) + me(z, xsd) + (me(x, xsd, ID) | ID)) scode <- make_stancode(bform, dat) @@ -1345,7 +1410,7 @@ expect_match2(scode, "Xme_1 = meanme_1[1] + sdme_1[1] * zme_1;") expect_match2(scode, "Xme_2 = meanme_2[1] + sdme_2[1] * zme_2;") expect_match2(scode, "(bsp[1] + r_1_2[J_1[n]]) * Xme_1[Jme_1[n]]") - + bform <- bform + set_mecor(FALSE) scode <- make_stancode(bform, dat) expect_match2(scode, "Xme_1 = meanme_1[1] + sdme_1[1] * zme_1;") @@ -1355,15 +1420,15 @@ dat <- data.frame(y = rnorm(10), g1 = sample(1:10, 10, TRUE), g2 = sample(1:10, 10, TRUE), w1 = rep(1, 10), w2 = rep(abs(rnorm(10)))) - expect_match2(make_stancode(y ~ (1|mm(g1, g2)), data = dat), + expect_match2(make_stancode(y ~ (1|mm(g1, g2)), data = dat), paste0(" W_1_1[n] * r_1_1[J_1_1[n]] * Z_1_1_1[n]", " + W_1_2[n] * r_1_1[J_1_2[n]] * Z_1_1_2[n]") ) - expect_match2(make_stancode(y ~ (1+w1|mm(g1,g2)), data = dat), + expect_match2(make_stancode(y ~ (1+w1|mm(g1,g2)), data = dat), paste0(" W_1_1[n] * r_1_2[J_1_1[n]] * Z_1_2_1[n]", " + W_1_2[n] * r_1_2[J_1_2[n]] * Z_1_2_2[n]") ) - expect_match2(make_stancode(y ~ (1+mmc(w1, w2)|mm(g1,g2)), data = dat), + expect_match2(make_stancode(y ~ (1+mmc(w1, w2)|mm(g1,g2)), data = dat), " W_1_2[n] * r_1_2[J_1_2[n]] * Z_1_2_2[n];" ) }) @@ -1378,8 +1443,8 @@ expect_match2(scode, "r_1_1 = (transpose(sd_1[1, Jby_1]) .* (z_1[1]));") scode <- make_stancode(y ~ x + (x | gr(g, by = z)), dat) expect_match2(scode, "r_1 = scale_r_cor_by(z_1, sd_1, L_1, Jby_1);") - expect_match2(scode, "target += student_t_lpdf(to_vector(sd_1) | 3, 0, 2.5);") - expect_match2(scode, "target += lkj_corr_cholesky_lpdf(L_1[5] | 1);") + expect_match2(scode, "lprior += student_t_lpdf(to_vector(sd_1) | 3, 0, 2.5)") + expect_match2(scode, "lprior += lkj_corr_cholesky_lpdf(L_1[5] | 1);") }) test_that("Group syntax | and || is handled correctly,", { @@ -1392,62 +1457,81 @@ }) test_that("predicting zi and hu works correctly", { - scode <- make_stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, + scode <- make_stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, family = "zero_inflated_poisson") - expect_match2(scode, + expect_match2(scode, "target += zero_inflated_poisson_log_logit_lpmf(Y[n] | mu[n], zi[n])" ) expect_true(!grepl("inv_logit\\(", scode)) expect_true(!grepl("exp(mu[n])", scode, fixed = TRUE)) - - scode <- make_stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, + + scode <- make_stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, family = zero_inflated_poisson(identity)) - expect_match2(scode, + expect_match2(scode, "target += zero_inflated_poisson_logit_lpmf(Y[n] | mu[n], zi[n])" ) - - scode <- make_stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, + + scode <- make_stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, family = "zero_inflated_binomial") - expect_match2(scode, + expect_match2(scode, "target += zero_inflated_binomial_blogit_logit_lpmf(Y[n] | trials[n], mu[n], zi[n])" ) expect_true(!grepl("inv_logit\\(", scode)) - + fam <- zero_inflated_binomial("probit", link_zi = "identity") - scode <- make_stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, - family = fam) - expect_match2(scode, + scode <- make_stancode( + bf(count ~ Trt, zi ~ Trt), epilepsy, family = fam, + prior = prior("", class = Intercept, dpar = zi, lb = 0, ub = 1) + ) + expect_match2(scode, "target += zero_inflated_binomial_lpmf(Y[n] | trials[n], mu[n], zi[n])" ) expect_match2(scode, "mu[n] = Phi(mu[n]);") - + + scode <- make_stancode(bf(count ~ Trt, zi ~ Trt), epilepsy, + family = "zero_inflated_beta_binomial") + expect_match2(scode, + paste("target += zero_inflated_beta_binomial_logit_lpmf(Y[n]", + "| trials[n], mu[n], phi, zi[n])")) + expect_match2(scode, "mu[n] = inv_logit(mu[n]);") scode <- make_stancode( - bf(count ~ Trt, zi ~ Trt), epilepsy, + bf(count ~ Trt, zi ~ Trt), epilepsy, + zero_inflated_beta_binomial("probit", link_zi = "identity"), + prior = prior("", class = Intercept, dpar = zi, lb = 0, ub = 1) + ) + expect_match2(scode, + paste("target += zero_inflated_beta_binomial_lpmf(Y[n]", + "| trials[n], mu[n], phi, zi[n])")) + expect_match2(scode, "mu[n] = Phi(mu[n]);") + + scode <- make_stancode( + bf(count ~ Trt, zi ~ Trt), epilepsy, family = zero_inflated_beta() ) expect_match2(scode, - "target += zero_inflated_beta_logit_lpdf(Y[n] | mu[n], phi, zi[n])" + "target += zero_inflated_beta_logit_lpdf(Y[n] | mu[n], phi, zi[n])" ) - - scode <- make_stancode(bf(count ~ Trt, hu ~ Trt), epilepsy, + + scode <- make_stancode(bf(count ~ Trt, hu ~ Trt), epilepsy, family = "hurdle_negbinomial") - expect_match2(scode, + expect_match2(scode, "target += hurdle_neg_binomial_log_logit_lpmf(Y[n] | mu[n], shape, hu[n])" ) expect_true(!grepl("inv_logit\\(", scode)) expect_true(!grepl("exp(mu[n])", scode, fixed = TRUE)) - - scode <- make_stancode(bf(count ~ Trt, hu ~ Trt), epilepsy, + + scode <- make_stancode(bf(count ~ Trt, hu ~ Trt), epilepsy, family = "hurdle_gamma") - expect_match2(scode, + expect_match2(scode, "target += hurdle_gamma_logit_lpdf(Y[n] | shape, mu[n], hu[n])" ) expect_true(!grepl("inv_logit\\(", scode)) expect_match2(scode, "mu[n] = shape * exp(-(mu[n]));") - + scode <- make_stancode( - bf(count ~ Trt, hu ~ Trt), epilepsy, - family = hurdle_gamma(link_hu = "identity") + bf(count ~ Trt, hu ~ Trt), epilepsy, + family = hurdle_gamma(link_hu = "identity"), + prior = prior("", class = Intercept, dpar = hu, lb = 0, ub = 1) ) expect_match2(scode, "target += hurdle_gamma_lpdf(Y[n] | shape, mu[n], hu[n])") expect_true(!grepl("inv_logit\\(", scode)) @@ -1456,26 +1540,26 @@ test_that("fixing auxiliary parameters is possible", { scode <- make_stancode(bf(y ~ 1, sigma = 0.5), data = list(y = rnorm(10))) - expect_match2(scode, "real sigma = 0.5;") + expect_match2(scode, "real sigma = 0.5;") }) test_that("Stan code of quantile regression models is correct", { data <- data.frame(y = rnorm(10), x = rnorm(10), c = 1) scode <- make_stancode(y ~ x, data, family = asym_laplace()) expect_match2(scode, "target += asym_laplace_lpdf(Y[n] | mu[n], sigma, quantile)") - + scode <- make_stancode(bf(y ~ x, quantile = 0.75), data, family = asym_laplace()) - expect_match2(scode, "real quantile = 0.75;") - + expect_match2(scode, "real quantile = 0.75;") + scode <- make_stancode(y | cens(c) ~ x, data, family = asym_laplace()) expect_match2(scode, "target += asym_laplace_lccdf(Y[n] | mu[n], sigma, quantile)") - + scode <- make_stancode(bf(y ~ x, sigma ~ x), data, family = asym_laplace()) expect_match2(scode, "target += asym_laplace_lpdf(Y[n] | mu[n], sigma[n], quantile)") - - scode <- make_stancode(bf(y ~ x, quantile = 0.75), data, + + scode <- make_stancode(bf(y ~ x, quantile = 0.75), data, family = brmsfamily("zero_inflated_asym_laplace")) - expect_match2(scode, + expect_match2(scode, "target += zero_inflated_asym_laplace_lpdf(Y[n] | mu[n], sigma, quantile, zi)" ) }) @@ -1484,16 +1568,16 @@ data <- data.frame(y = rpois(10, 1), x = rnorm(10), time = 1:10) scode <- make_stancode(y | rate(time) ~ x, data, poisson()) expect_match2(scode, "target += poisson_log_lpmf(Y | mu + log_denom);") - + scode <- make_stancode(y | rate(time) ~ x, data, poisson("identity")) expect_match2(scode, "target += poisson_lpmf(Y | mu .* denom);") - + scode <- make_stancode(y | rate(time) ~ x, data, negbinomial()) expect_match2(scode, "target += neg_binomial_2_log_lpmf(Y | mu + log_denom, shape * denom);") - + scode <- make_stancode(y | rate(time) ~ x, data, brmsfamily("negbinomial2")) expect_match2(scode, "target += neg_binomial_2_log_lpmf(Y | mu + log_denom, inv(sigma) * denom);") - + scode <- make_stancode(y | rate(time) + cens(1) ~ x, data, geometric()) expect_match2(scode, "target += neg_binomial_2_lpmf(Y[n] | mu[n] * denom[n], 1 * denom[n]);") }) @@ -1503,16 +1587,16 @@ scode <- make_stancode(y ~ x, data, gen_extreme_value()) expect_match2(scode, "target += gen_extreme_value_lpdf(Y[n] | mu[n], sigma, xi)") expect_match2(scode, "xi = scale_xi(tmp_xi, Y, mu, sigma)") - + scode <- make_stancode(bf(y ~ x, sigma ~ x), data, gen_extreme_value()) expect_match2(scode, "xi = scale_xi_vector(tmp_xi, Y, mu, sigma)") - + scode <- make_stancode(bf(y ~ x, xi ~ x), data, gen_extreme_value()) expect_match2(scode, "xi[n] = expm1(xi[n])") - + scode <- make_stancode(bf(y ~ x, xi = 0), data, gen_extreme_value()) expect_match2(scode, "real xi = 0; // shape parameter") - + scode <- make_stancode(y | cens(c) ~ x, data, gen_extreme_value()) expect_match2(scode, "target += gen_extreme_value_lccdf(Y[n] | mu[n], sigma, xi)") }) @@ -1523,9 +1607,9 @@ scode <- make_stancode(bform, data, brmsfamily("cox")) expect_match2(scode, "target += cox_log_lpdf(Y[n] | mu[n], bhaz[n], cbhaz[n]);") expect_match2(scode, "vector[N] cbhaz = Zcbhaz * sbhaz;") - expect_match2(scode, "target += dirichlet_lpdf(sbhaz | con_sbhaz);") + expect_match2(scode, "lprior += dirichlet_lpdf(sbhaz | con_sbhaz);") expect_match2(scode, "simplex[Kbhaz] sbhaz;") - + scode <- make_stancode(bform, data, brmsfamily("cox", "identity")) expect_match2(scode, "target += cox_lccdf(Y[n] | mu[n], bhaz[n], cbhaz[n]);") }) @@ -1548,84 +1632,84 @@ prior <- prior(normal(0, 5), b) + prior(normal(0, 10), Intercept) scode <- make_stancode(y ~ x, data, prior = prior, sample_prior = "only") - expect_match2(scode, "target += normal_lpdf(Intercept | 0, 10)") + expect_match2(scode, "lprior += normal_lpdf(Intercept | 0, 10)") }) test_that("Stan code of mixture model is correct", { data <- data.frame(y = 1:10, x = rnorm(10), c = 1) scode <- make_stancode( - bf(y ~ x, sigma2 ~ x), data, + bf(y ~ x, sigma2 ~ x), data, family = mixture(gaussian, gaussian), sample_prior = TRUE ) expect_match2(scode, "ordered[2] ordered_Intercept;") expect_match2(scode, "Intercept_mu2 = ordered_Intercept[2];") - expect_match2(scode, "target += dirichlet_lpdf(theta | con_theta);") + expect_match2(scode, "lprior += dirichlet_lpdf(theta | con_theta);") expect_match2(scode, "ps[1] = log(theta1) + normal_lpdf(Y[n] | mu1[n], sigma1);") expect_match2(scode, "ps[2] = log(theta2) + normal_lpdf(Y[n] | mu2[n], sigma2[n]);") expect_match2(scode, "target += log_sum_exp(ps);") expect_match2(scode, "simplex[2] prior_theta = dirichlet_rng(con_theta);") - + data$z <- abs(data$y) - scode <- make_stancode(bf(z | weights(c) ~ x, shape1 ~ x, theta1 = 1, theta2 = 2), + scode <- make_stancode(bf(z | weights(c) ~ x, shape1 ~ x, theta1 = 1, theta2 = 2), data = data, mixture(Gamma("log"), weibull)) expect_match(scode, "data \\{[^\\}]*real theta1;") expect_match(scode, "data \\{[^\\}]*real theta2;") expect_match2(scode, "ps[1] = log(theta1) + gamma_lpdf(Y[n] | shape1[n], mu1[n]);") expect_match2(scode, "target += weights[n] * log_sum_exp(ps);") - - scode <- make_stancode(bf(abs(y) | se(c) ~ x), data = data, + + scode <- make_stancode(bf(abs(y) | se(c) ~ x), data = data, mixture(gaussian, student)) expect_match2(scode, "ps[1] = log(theta1) + normal_lpdf(Y[n] | mu1[n], se[n]);") expect_match2(scode, "ps[2] = log(theta2) + student_t_lpdf(Y[n] | nu2, mu2[n], se[n]);") - + fam <- mixture(gaussian, student, exgaussian) scode <- make_stancode(bf(y ~ x), data = data, family = fam) expect_match(scode, "parameters \\{[^\\}]*real Intercept_mu3;") - expect_match2(scode, + expect_match2(scode, "ps[2] = log(theta2) + student_t_lpdf(Y[n] | nu2, mu2[n], sigma2);" ) - expect_match2(scode, + expect_match2(scode, "ps[3] = log(theta3) + exp_mod_normal_lpdf(Y[n] | mu3[n] - beta3, sigma3, inv(beta3));" ) - - scode <- make_stancode(bf(y ~ x, theta1 ~ x, theta3 ~ x), + + scode <- make_stancode(bf(y ~ x, theta1 ~ x, theta3 ~ x), data = data, family = fam) expect_match2(scode, "log_sum_exp_theta = log(exp(theta1[n]) + exp(theta2[n]) + exp(theta3[n]));") expect_match2(scode, "theta2 = rep_vector(0.0, N);") expect_match2(scode, "theta3[n] = theta3[n] - log_sum_exp_theta;") expect_match2(scode, "ps[1] = theta1[n] + normal_lpdf(Y[n] | mu1[n], sigma1);") - + fam <- mixture(cumulative, sratio) scode <- make_stancode(y ~ x, data, family = fam) expect_match2(scode, "ordered_logistic_lpmf(Y[n] | mu1[n], Intercept_mu1);") expect_match2(scode, "sratio_logit_lpmf(Y[n] | mu2[n], disc2, Intercept_mu2);") - + # censored mixture model fam <- mixture(gaussian, gaussian) scode <- make_stancode(y | cens(2, y2 = 2) ~ x, data, fam) - expect_match2(scode, + expect_match2(scode, "ps[2] = log(theta2) + normal_lccdf(Y[n] | mu2[n], sigma2);" ) expect_match2(scode, paste0( "ps[2] = log(theta2) + log_diff_exp(\n", " normal_lcdf(rcens[n] | mu2[n], sigma2)," )) - + # truncated mixture model scode <- make_stancode(y | trunc(3) ~ x, data, fam) expect_match2(scode, paste0( - "ps[1] = log(theta1) + normal_lpdf(Y[n] | mu1[n], sigma1) -\n", + "ps[1] = log(theta1) + normal_lpdf(Y[n] | mu1[n], sigma1) -\n", " normal_lccdf(lb[n] | mu1[n], sigma1);" )) - + # non-linear mixture model - bform <- bf(y ~ 1) + + bform <- bf(y ~ 1) + nlf(mu1 ~ eta^2) + nlf(mu2 ~ log(eta) + a) + lf(eta + a ~ x) + mixture(gaussian, nmix = 2) - bprior <- prior(normal(0, 1), nlpar = "eta") + + bprior <- prior(normal(0, 1), nlpar = "eta") + prior(normal(0, 1), nlpar = "a") scode <- make_stancode(bform, data = data, prior = bprior) expect_match2(scode, "mu1[n] = nlp_eta[n] ^ 2;") @@ -1634,54 +1718,54 @@ test_that("sparse matrix multiplication is applied correctly", { data <- data.frame(y = rnorm(10), x = rnorm(10)) - + # linear model scode <- make_stancode( - bf(y ~ x, sparse = TRUE) + lf(sigma ~ x, sparse = TRUE), + bf(y ~ x, sparse = TRUE) + lf(sigma ~ x, sparse = TRUE), data, prior = prior(normal(0, 5), coef = "Intercept") ) expect_match2(scode, "wX = csr_extract_w(X);") - expect_match2(scode, + expect_match2(scode, "mu = csr_matrix_times_vector(rows(X), cols(X), wX, vX, uX, b);" ) - expect_match2(scode, + expect_match2(scode, "uX_sigma[size(csr_extract_u(X_sigma))] = csr_extract_u(X_sigma);" ) expect_match2(scode, paste0( - "sigma = csr_matrix_times_vector(rows(X_sigma), cols(X_sigma), ", + "sigma = csr_matrix_times_vector(rows(X_sigma), cols(X_sigma), ", "wX_sigma, vX_sigma, uX_sigma, b_sigma);" ) ) - expect_match2(scode, "target += normal_lpdf(b[1] | 0, 5);") + expect_match2(scode, "lprior += normal_lpdf(b[1] | 0, 5);") expect_match2(scode, "target += normal_lpdf(Y | mu, sigma);") - + # non-linear model scode <- make_stancode( - bf(y ~ a, lf(a ~ x, sparse = TRUE), nl = TRUE), + bf(y ~ a, lf(a ~ x, sparse = TRUE), nl = TRUE), data, prior = prior(normal(0, 1), nlpar = a) ) - expect_match2(scode, + expect_match2(scode, "vX_a[size(csr_extract_v(X_a))] = csr_extract_v(X_a);" ) - expect_match2(scode, + expect_match2(scode, "nlp_a = csr_matrix_times_vector(rows(X_a), cols(X_a), wX_a, vX_a, uX_a, b_a);" ) }) test_that("QR decomposition is included in the Stan code", { data <- data.frame(y = rnorm(10), x1 = rnorm(10), x2 = rnorm(10)) - bform <- bf(y ~ x1 + x2, decomp = "QR") + + bform <- bf(y ~ x1 + x2, decomp = "QR") + lf(sigma ~ 0 + x1 + x2, decomp = "QR") - + # simple priors scode <- make_stancode(bform, data, prior = prior(normal(0, 2))) expect_match2(scode, "XQ = qr_thin_Q(Xc) * sqrt(N - 1);") expect_match2(scode, "b = XR_inv * bQ;") - expect_match2(scode, "target += normal_lpdf(bQ | 0, 2);") + expect_match2(scode, "lprior += normal_lpdf(bQ | 0, 2);") expect_match2(scode, "XQ * bQ") expect_match2(scode, "XR_sigma = qr_thin_R(X_sigma) / sqrt(N - 1);") - + # horseshoe prior scode <- make_stancode(bform, data, prior = prior(horseshoe(1))) expect_match2(scode, "target += std_normal_lpdf(zb);") @@ -1692,64 +1776,64 @@ set.seed(1234) dat <- data.frame(y = rnorm(40), x1 = rnorm(40), x2 = rnorm(40), z = factor(rep(3:6, each = 10))) - + prior <- prior(gamma(0.1, 0.1), sdgp) - scode <- make_stancode(y ~ gp(x1) + gp(x2, by = x1, gr = FALSE), + scode <- make_stancode(y ~ gp(x1) + gp(x2, by = x1, gr = FALSE), dat, prior = prior) - expect_match2(scode, "target += inv_gamma_lpdf(lscale_1[1]") - expect_match2(scode, "target += gamma_lpdf(sdgp_1 | 0.1, 0.1)") + expect_match2(scode, "lprior += inv_gamma_lpdf(lscale_1[1]") + expect_match2(scode, "lprior += gamma_lpdf(sdgp_1 | 0.1, 0.1)") expect_match2(scode, "gp_pred_2 = gp(Xgp_2, sdgp_2[1], lscale_2[1], zgp_2);") expect_match2(scode, "Cgp_2 .* gp_pred_2;") - + prior <- prior + prior(normal(0, 1), lscale, coef = gpx1) - scode <- make_stancode(y ~ gp(x1) + gp(x2, by = x1, gr = TRUE), + scode <- make_stancode(y ~ gp(x1) + gp(x2, by = x1, gr = TRUE), data = dat, prior = prior) - expect_match2(scode, "target += normal_lpdf(lscale_1[1][1] | 0, 1)") + expect_match2(scode, "lprior += normal_lpdf(lscale_1[1][1] | 0, 1)") expect_match2(scode, "gp_pred_2 = gp(Xgp_2, sdgp_2[1], lscale_2[1], zgp_2);") expect_match2(scode, "+ Cgp_2 .* gp_pred_2[Jgp_2]") - + # non-isotropic GP scode <- make_stancode(y ~ gp(x1, x2, by = z, iso = FALSE), data = dat) - expect_match2(scode, "target += inv_gamma_lpdf(lscale_1[1][2]") - expect_match2(scode, "target += inv_gamma_lpdf(lscale_1[4][2]") - + expect_match2(scode, "lprior += inv_gamma_lpdf(lscale_1[1][2]") + expect_match2(scode, "lprior += inv_gamma_lpdf(lscale_1[4][2]") + # Suppress Stan parser warnings that can currently not be avoided - scode <- make_stancode(y ~ gp(x1, x2) + gp(x1, by = z, gr = FALSE), + scode <- make_stancode(y ~ gp(x1, x2) + gp(x1, by = z, gr = FALSE), dat, silent = TRUE) expect_match2(scode, "gp(Xgp_1, sdgp_1[1], lscale_1[1], zgp_1)") expect_match2(scode, "mu[Igp_2_2] += Cgp_2_2 .* gp_pred_2_2;") - + # approximate GPS scode <- make_stancode( - y ~ gp(x1, k = 10, c = 5/4) + gp(x2, by = x1, k = 10, c = 5/4), + y ~ gp(x1, k = 10, c = 5/4) + gp(x2, by = x1, k = 10, c = 5/4), data = dat ) - expect_match2(scode, "target += inv_gamma_lpdf(lscale_1") - expect_match2(scode, + expect_match2(scode, "lprior += inv_gamma_lpdf(lscale_1") + expect_match2(scode, "rgp_1 = sqrt(spd_cov_exp_quad(slambda_1, sdgp_1[1], lscale_1[1])) .* zgp_1;" ) expect_match2(scode, "Cgp_2 .* gp_pred_2[Jgp_2]") - + prior <- c(prior(normal(0, 10), lscale, coef = gpx1, nlpar = a), prior(gamma(0.1, 0.1), sdgp, nlpar = a), prior(normal(0, 1), b, nlpar = a)) - scode <- make_stancode(bf(y ~ a, a ~ gp(x1), nl = TRUE), + scode <- make_stancode(bf(y ~ a, a ~ gp(x1), nl = TRUE), data = dat, prior = prior) - expect_match2(scode, "target += normal_lpdf(lscale_a_1[1][1] | 0, 10)") - expect_match2(scode, "target += gamma_lpdf(sdgp_a_1 | 0.1, 0.1)") + expect_match2(scode, "lprior += normal_lpdf(lscale_a_1[1][1] | 0, 10)") + expect_match2(scode, "lprior += gamma_lpdf(sdgp_a_1 | 0.1, 0.1)") expect_match2(scode, "gp(Xgp_a_1, sdgp_a_1[1], lscale_a_1[1], zgp_a_1)") - + prior <- prior(gamma(2, 2), lscale, coef = gpx1z5, nlpar = "a") scode <- make_stancode(bf(y ~ a, a ~ gp(x1, by = z, gr = TRUE), nl = TRUE), data = dat, prior = prior, silent = TRUE) - expect_match2(scode, + expect_match2(scode, "nlp_a[Igp_a_1_1] += Cgp_a_1_1 .* gp_pred_a_1_1[Jgp_a_1_1];" ) expect_match2(scode, "gp(Xgp_a_1_3, sdgp_a_1[3], lscale_a_1[3], zgp_a_1_3)") - expect_match2(scode, "target += gamma_lpdf(lscale_a_1[3][1] | 2, 2);") + expect_match2(scode, "lprior += gamma_lpdf(lscale_a_1[3][1] | 2, 2);") expect_match2(scode, "target += std_normal_lpdf(zgp_a_1_3);") - - # test warnings + + # test warnings prior <- prior(normal(0, 1), lscale) expect_warning( make_stancode(y ~ gp(x1), data = dat, prior = prior), @@ -1762,45 +1846,45 @@ dat <- data.frame(y = rnorm(10), x = rnorm(10)) W <- matrix(0, nrow = 10, ncol = 10) dat2 <- list(W = W) - + scode <- make_stancode( y ~ x + sar(W), data = dat, prior = prior(normal(0.5, 1), lagsar), data2 = dat2 ) - expect_match2(scode, + expect_match2(scode, "target += normal_lagsar_lpdf(Y | mu, sigma, lagsar, Msar, eigenMsar)" ) - expect_match2(scode, "target += normal_lpdf(lagsar | 0.5, 1)") - + expect_match2(scode, "lprior += normal_lpdf(lagsar | 0.5, 1)") + scode <- make_stancode( - y ~ x + sar(W, type = "lag"), + y ~ x + sar(W, type = "lag"), data = dat, family = student(), data2 = dat2 ) - expect_match2(scode, + expect_match2(scode, "target += student_t_lagsar_lpdf(Y | nu, mu, sigma, lagsar, Msar, eigenMsar)" ) - + scode <- make_stancode(y ~ x + sar(W, type = "error"), data = dat, data2 = dat2) - expect_match2(scode, + expect_match2(scode, "target += normal_errorsar_lpdf(Y | mu, sigma, errorsar, Msar, eigenMsar)" ) - + scode <- make_stancode( - y ~ x + sar(W, "error"), data = dat, family = student(), + y ~ x + sar(W, "error"), data = dat, family = student(), prior = prior(beta(2, 3), errorsar), data2 = dat2 ) - expect_match2(scode, + expect_match2(scode, "target += student_t_errorsar_lpdf(Y | nu, mu, sigma, errorsar, Msar, eigenMsar)" ) - expect_match2(scode, "target += beta_lpdf(errorsar | 2, 3)") - + expect_match2(scode, "lprior += beta_lpdf(errorsar | 2, 3)") + expect_error( make_stancode(bf(y ~ sar(W), sigma ~ x), data = dat), - "SAR models are not implemented when predicting 'sigma'" + "SAR models are not implemented when predicting 'sigma'" ) }) @@ -1809,12 +1893,13 @@ edges <- cbind(1:10, 10:1) W <- matrix(0, nrow = 10, ncol = 10) for (i in seq_len(nrow(edges))) { - W[edges[i, 1], edges[i, 2]] <- 1 + W[edges[i, 1], edges[i, 2]] <- 1 } rownames(W) <- seq_len(nrow(W)) dat2 <- list(W = W) - + scode <- make_stancode(y ~ x + car(W), dat, data2 = dat2) + expect_match2(scode, "real car;") expect_match2(scode, "real sparse_car_lpdf(vector phi") expect_match2(scode, "target += sparse_car_lpdf(") expect_match2(scode, "mu[n] += rcar[Jloc[n]]") @@ -1824,23 +1909,23 @@ expect_match2(scode, "target += sparse_icar_lpdf(") expect_match2(scode, "mu[n] += rcar[Jloc[n]]") expect_match2(scode, "rcar[Nloc] = - sum(zcar)") - + scode <- make_stancode(y ~ x + car(W, type = "icar"), dat, data2 = dat2) expect_match2(scode, "target += -0.5 * dot_self(zcar[edges1] - zcar[edges2])") expect_match2(scode, "target += normal_lpdf(sum(zcar) | 0, 0.001 * Nloc)") expect_match2(scode, "mu[n] += rcar[Jloc[n]]") expect_match2(scode, "rcar = zcar * sdcar") - + scode <- make_stancode(y ~ x + car(W, type = "bym2"), dat, data2 = dat2) expect_match2(scode, "target += -0.5 * dot_self(zcar[edges1] - zcar[edges2])") expect_match2(scode, "target += normal_lpdf(sum(zcar) | 0, 0.001 * Nloc)") expect_match2(scode, "mu[n] += rcar[Jloc[n]]") - expect_match2(scode, "target += beta_lpdf(rhocar | 1, 1)") + expect_match2(scode, "lprior += beta_lpdf(rhocar | 1, 1)") expect_match2(scode, paste0( - "rcar = (sqrt(1 - rhocar) * nszcar + ", + "rcar = (sqrt(1 - rhocar) * nszcar + ", "sqrt(rhocar * inv(car_scale)) * zcar) * sdcar" )) - + # apply a CAR term on a distributional parameter other than 'mu' scode <- make_stancode(bf(y ~ x, sigma ~ car(W)), dat, data2 = dat2) expect_match2(scode, "real sparse_car_lpdf(vector phi") @@ -1854,16 +1939,16 @@ expect_match2(scode, "delta = alpha / sqrt(1 + alpha^2);") expect_match2(scode, "omega = sigma / sqrt(1 - sqrt(2 / pi())^2 * delta^2);") expect_match2(scode, "mu[n] = mu[n] - omega * delta * sqrt(2 / pi());") - + scode <- make_stancode(bf(y ~ x, sigma ~ x), dat, skew_normal()) expect_match2(scode, "omega[n] = sigma[n] / sqrt(1 - sqrt(2 / pi())^2 * delta^2);") expect_match2(scode, "mu[n] = mu[n] - omega[n] * delta * sqrt(2 / pi());") - + scode <- make_stancode(bf(y | se(x) ~ x, alpha ~ x), dat, skew_normal()) expect_match2(scode, "delta[n] = alpha[n] / sqrt(1 + alpha[n]^2);") expect_match2(scode, "omega[n] = se[n] / sqrt(1 - sqrt(2 / pi())^2 * delta[n]^2);") expect_match2(scode, "mu[n] = mu[n] - omega[n] * delta[n] * sqrt(2 / pi());") - + scode <- make_stancode(y ~ x, dat, mixture(skew_normal, nmix = 2)) expect_match2(scode, "omega1 = sigma1 / sqrt(1 - sqrt(2 / pi())^2 * delta1^2);") expect_match2(scode, "mu2[n] = mu2[n] - omega2 * delta2 * sqrt(2 / pi());") @@ -1872,7 +1957,7 @@ test_that("Stan code for missing value terms works correctly", { dat = data.frame(y = rnorm(10), x = rnorm(10), g = 1:10, z = 1) dat$x[c(1, 3, 9)] <- NA - + bform <- bf(y ~ mi(x)*g) + bf(x | mi() ~ g) + set_rescor(FALSE) scode <- make_stancode(bform, dat) expect_match2(scode, "Yl_x[Jmi_x] = Ymi_x;") @@ -1881,46 +1966,46 @@ bform <- bf(y ~ mi(x) + (mi(x) | g)) + bf(x | mi() ~ 1) + set_rescor(FALSE) scode <- make_stancode(bform, dat) - expect_match2(scode, + expect_match2(scode, "(bsp_y[1] + r_1_y_2[J_1_y[n]]) * Yl_x[n] + r_1_y_1[J_1_y[n]] * Z_1_y_1[n];" ) - + bform <- bf(y ~ a, a ~ mi(x), nl = TRUE) + bf(x | mi() ~ 1) + set_rescor(FALSE) bprior <- prior(normal(0, 1), nlpar = "a", resp = "y") scode <- make_stancode(bform, dat, prior = bprior) expect_match2(scode, "nlp_y_a[n] += (bsp_y_a[1]) * Yl_x[n];") - expect_match2(scode, "target += normal_lpdf(bsp_y_a | 0, 1);") - + expect_match2(scode, "lprior += normal_lpdf(bsp_y_a | 0, 1);") + bform <- bf(y ~ mi(x)*mo(g)) + bf(x | mi() ~ 1) + set_rescor(FALSE) scode <- make_stancode(bform, dat) expect_match2(scode, "(bsp_y[3]) * Yl_x[n] * mo(simo_y_2, Xmo_y_2[n]);") - + bform <- bf(y ~ 1, sigma ~ 1) + bf(x | mi() ~ 1) + set_rescor(TRUE) scode <- make_stancode(bform, dat) expect_match2(scode, "Yl[n][2] = Yl_x[n];") expect_match2(scode, "sigma[n] = transpose([sigma_y[n], sigma_x]);") expect_match2(scode, "LSigma[n] = diag_pre_multiply(sigma[n], Lrescor);") - + bform <- bf(x | mi() ~ y, family = "lognormal") scode <- make_stancode(bform, dat) expect_match2(scode, "vector[Nmi] Ymi;") - - bform <- bf(y ~ I(log(mi(x))) * g) + + + bform <- bf(y ~ I(log(mi(x))) * g) + bf(x | mi() + trunc(lb = 1) ~ y, family = "lognormal") scode <- make_stancode(bform, dat) expect_match2(scode, "vector[Nmi_x] Ymi_x;") - expect_match2(scode, - "(bsp_y[1]) * (log(Yl_x[n])) + (bsp_y[2]) * (log(Yl_x[n])) * Csp_y_1[n]" + expect_match2(scode, + "(bsp_y[1]) * (log(Yl_x[n])) + (bsp_y[2]) * (log(Yl_x[n])) * Csp_y_1[n]" ) - - bform <- bf(y ~ mi(x)*g) + + + bform <- bf(y ~ mi(x)*g) + bf(x | mi() + cens(z) ~ y, family = "beta") scode <- make_stancode(bform, dat) expect_match2(scode, "vector[Nmi_x] Ymi_x;") - expect_match2(scode, + expect_match2(scode, "target += beta_lpdf(Yl_x[n] | mu_x[n] * phi_x, (1 - mu_x[n]) * phi_x);" ) - + bform <- bf(y | mi() ~ mi(x), shape ~ mi(x), family=weibull()) + bf(x| mi() ~ z, family=gaussian()) + set_rescor(FALSE) scode <- make_stancode(bform, data = dat) @@ -1934,7 +2019,7 @@ bform <- bf(y ~ mi(x_x)*g) + bf(x_x | mi(g) ~ 1) + set_rescor(FALSE) scode <- make_stancode(bform, dat, sample_prior = "yes") expect_match2(scode, "target += normal_lpdf(Yl_xx | mu_xx, sigma_xx)") - expect_match2(scode, + expect_match2(scode, "target += normal_lpdf(Y_xx[Jme_xx] | Yl_xx[Jme_xx], noise_xx[Jme_xx])" ) expect_match2(scode, "vector[N_xx] Yl_xx;") @@ -1947,8 +2032,8 @@ g1 = sample(1:5, 10, TRUE), s = c(FALSE, rep(TRUE, 9)) ) - - bform <- bf(y ~ mi(x, idx = g1)*mi(z)) + + + bform <- bf(y ~ mi(x, idx = g1)*mi(z)) + bf(x | mi() + index(g2) + subset(s) ~ 1) + bf(z | mi() ~ s) + set_rescor(FALSE) @@ -1966,7 +2051,7 @@ ) expect_match2(scode, "mu[n] = inv_logit(mu[n]);") expect_match2(scode, "target += discrete_weibull_lpmf(Y[n] | mu[n], shape);") - + scode <- make_stancode( count ~ zAge + zBase * Trt + (1|patient), data = epilepsy, family = brmsfamily("com_poisson") @@ -1978,78 +2063,78 @@ bprior <- prior(normal(mean_intercept, 10), class = "Intercept") mean_intercept <- 5 stanvars <- stanvar(mean_intercept) - scode <- make_stancode(count ~ Trt, data = epilepsy, + scode <- make_stancode(count ~ Trt, data = epilepsy, prior = bprior, stanvars = stanvars) expect_match2(scode, "real mean_intercept;") - + # define a multi_normal prior with known covariance matrix bprior <- prior(multi_normal(M, V), class = "b") stanvars <- stanvar(rep(0, 2), "M", scode = "vector[K] M;") + - stanvar(diag(2), "V", scode = "matrix[K, K] V;") + stanvar(diag(2), "V", scode = "matrix[K, K] V;") scode <- make_stancode(count ~ Trt + zBase, epilepsy, prior = bprior, stanvars = stanvars) expect_match2(scode, "vector[K] M;") expect_match2(scode, "matrix[K, K] V;") - + # define a hierarchical prior on the regression coefficients bprior <- set_prior("normal(0, tau)", class = "b") + set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) - stanvars <- stanvar(scode = "real tau;", + stanvars <- stanvar(scode = "real tau;", block = "parameters") scode <- make_stancode(count ~ Trt + zBase, epilepsy, prior = bprior, stanvars = stanvars) expect_match2(scode, "real tau;") - expect_match2(scode, "target += normal_lpdf(b | 0, tau);") - + expect_match2(scode, "lprior += normal_lpdf(b | 0, tau);") + # ensure that variables are passed to the likelihood of a threaded model foo <- 0.5 stanvars <- stanvar(foo) + - stanvar(scode = "real tau;", + stanvar(scode = "real tau;", block = "parameters", pll_args = "real tau") scode <- make_stancode(count ~ 1, data = epilepsy, family = poisson(), stanvars = stanvars, threads = threading(2), parse = FALSE) - expect_match2(scode, + expect_match2(scode, "partial_log_lik_lpmf(int[] seq, int start, int end, data int[] Y, real Intercept, data real foo, real tau)" ) - expect_match2(scode, + expect_match2(scode, "reduce_sum(partial_log_lik_lpmf, seq, grainsize, Y, Intercept, foo, tau)" ) - + # specify Stan code in the likelihood part of the model block stanvars <- stanvar(scode = "mu += 1.0;", block = "likelihood", position = "start") - scode <- make_stancode(count ~ Trt + (1|patient), data = epilepsy, + scode <- make_stancode(count ~ Trt + (1|patient), data = epilepsy, stanvars = stanvars) expect_match2(scode, "mu += 1.0;") - + stanvars <- stanvar(scode = "mu += 1.0;", block = "likelihood", position = "start") scode <- make_stancode(count ~ Trt + (1|patient), data = epilepsy, stanvars = stanvars, threads = 2, parse = FALSE) expect_match2(scode, "mu += 1.0;") - - + + # add transformation at the end of a block - stanvars <- stanvar(scode = "r_1_1 = r_1_1 * 2;", + stanvars <- stanvar(scode = "r_1_1 = r_1_1 * 2;", block = "tparameters", position = "end") scode <- make_stancode(count ~ Trt + (1 | patient), epilepsy, stanvars = stanvars) - expect_match2(scode, "r_1_1 = (sd_1[1] * (z_1[1]));\n r_1_1 = r_1_1 * 2;") - + expect_match2(scode, "r_1_1 = r_1_1 * 2;\n}") + # use the non-centered parameterization for 'b' # unofficial feature not supported anymore for the time being # bprior <- set_prior("target += normal_lpdf(zb | 0, 1)", check = FALSE) + # set_prior("target += normal_lpdf(tau | 0, 10)", check = FALSE) # stanvars <- stanvar(scode = "vector[Kc] zb;", block = "parameters") + # stanvar(scode = "real tau;", block = "parameters") + - # stanvar(scode = "vector[Kc] b = zb * tau;", + # stanvar(scode = "vector[Kc] b = zb * tau;", # block="tparameters", name = "b") - # scode <- make_stancode(count ~ Trt, epilepsy, + # scode <- make_stancode(count ~ Trt, epilepsy, # prior = bprior, stanvars = stanvars) # expect_match2(scode, "vector[Kc] b = zb * tau;") - + # stanvars <- stanvar(scode = "vector[Ksp] zbsp;", block = "parameters") + # stanvar(scode = "real tau;", block = "parameters") + - # stanvar(scode = "vector[Ksp] bsp = zbsp * tau;", + # stanvar(scode = "vector[Ksp] bsp = zbsp * tau;", # block = "tparameters", name = "bsp") # scode <- make_stancode(count ~ mo(Base), epilepsy, stanvars = stanvars) # expect_match2(scode, "vector[Ksp] bsp = zbsp * tau;") @@ -2057,33 +2142,33 @@ test_that("custom families are handled correctly", { dat <- data.frame(size = 10, y = sample(0:10, 20, TRUE), x = rnorm(20)) - + # define a custom beta-binomial family - log_lik_beta_binomial2 <- function(i, draws) { - mu <- draws$dpars$mu[, i] - tau <- draws$dpars$tau - trials <- draws$data$vint1[i] - y <- draws$data$Y[i] + log_lik_beta_binomial2 <- function(i, prep) { + mu <- prep$dpars$mu[, i] + tau <- prep$dpars$tau + trials <- prep$data$vint1[i] + y <- prep$data$Y[i] beta_binomial2_lpmf(y, mu, tau, trials) } - posterior_predict_beta_binomial2 <- function(i, draws, ...) { - mu <- draws$dpars$mu[, i] - tau <- draws$dpars$tau - trials <- draws$data$vint1[i] + posterior_predict_beta_binomial2 <- function(i, prep, ...) { + mu <- prep$dpars$mu[, i] + tau <- prep$dpars$tau + trials <- prep$data$vint1[i] beta_binomial2_rng(mu, tau, trials) } - posterior_epred_beta_binomial2 <- function(draws) { - mu <- draws$dpars$mu - trials <- draws$data$vint1 + posterior_epred_beta_binomial2 <- function(prep) { + mu <- prep$dpars$mu + trials <- prep$data$vint1 trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) mu * trials } beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "tau"), - links = c("logit", "log"), + links = c("logit", "log"), lb = c(NA, 0), - type = "int", + type = "int", vars = c("vint1[n]", "vreal1[n]"), log_lik = log_lik_beta_binomial2, posterior_epred = posterior_epred_beta_binomial2, @@ -2101,37 +2186,37 @@ " stanvars <- stanvar(scode = stan_funs, block = "functions") scode <- make_stancode( - y | vint(size) + vreal(size) ~ x, data = dat, family = beta_binomial2, + y | vint(size) + vreal(size) ~ x, data = dat, family = beta_binomial2, prior = prior(gamma(0.1, 0.1), class = "tau"), stanvars = stanvars ) expect_match2(scode, "int vint1[N];") expect_match2(scode, "real tau;") expect_match2(scode, "mu[n] = inv_logit(mu[n]);") - expect_match2(scode, "target += gamma_lpdf(tau | 0.1, 0.1);") - expect_match2(scode, + expect_match2(scode, "lprior += gamma_lpdf(tau | 0.1, 0.1);") + expect_match2(scode, "target += beta_binomial2_lpmf(Y[n] | mu[n], tau, vint1[n], vreal1[n]);" ) - + scode <- make_stancode( - bf(y | vint(size) + vreal(size) ~ x, tau ~ x), + bf(y | vint(size) + vreal(size) ~ x, tau ~ x), data = dat, family = beta_binomial2, stanvars = stanvars ) expect_match2(scode, "tau[n] = exp(tau[n]);") - expect_match2(scode, + expect_match2(scode, "target += beta_binomial2_lpmf(Y[n] | mu[n], tau[n], vint1[n], vreal1[n]);" ) - + # check custom families in mixture models scode <- make_stancode( - y | vint(size) + vreal(size) + trials(size) ~ x, data = dat, - family = mixture(binomial, beta_binomial2), + y | vint(size) + vreal(size) + trials(size) ~ x, data = dat, + family = mixture(binomial, beta_binomial2), stanvars = stanvars ) - expect_match2(scode, + expect_match2(scode, "log(theta2) + beta_binomial2_lpmf(Y[n] | mu2[n], tau2, vint1[n], vreal1[n]);" ) - + # check custom families in multivariate models bform <- bf( y | vint(size) + vreal(size) + trials(size) ~ x, @@ -2141,14 +2226,14 @@ expect_match2(scode, "target += beta_binomial2_lpmf(Y_y[n] | mu_y[n], tau_y, vint1_y[n], vreal1_y[n]);" ) - + # check vectorized custom families beta_binomial2_vec <- custom_family( "beta_binomial2_vec", dpars = c("mu", "tau"), - links = c("logit", "log"), + links = c("logit", "log"), lb = c(NA, 0), - type = "int", + type = "int", vars = c("vint1", "vreal1"), loop = FALSE ) @@ -2162,12 +2247,12 @@ " stanvars <- stanvar(scode = stan_funs_vec, block = "functions") scode <- make_stancode( - y | vint(size) + vreal(size) ~ x, data = dat, - family = beta_binomial2_vec, + y | vint(size) + vreal(size) ~ x, data = dat, + family = beta_binomial2_vec, prior = prior(gamma(0.1, 0.1), class = "tau"), stanvars = stanvars ) - expect_match2(scode, + expect_match2(scode, "target += beta_binomial2_vec_lpmf(Y | mu, tau, vint1, vreal1);" ) }) @@ -2185,18 +2270,18 @@ scode <- make_stancode(count ~ Trt + (1|gr(patient, dist = "st")), epilepsy) expect_match2(scode, "dfm_1 = sqrt(df_1 * udf_1);") expect_match2(scode, "dfm_1 .* (sd_1[1] * (z_1[1]));") - expect_match2(scode, "target += gamma_lpdf(df_1 | 2, 0.1);") + expect_match2(scode, "lprior += gamma_lpdf(df_1 | 2, 0.1)") expect_match2(scode, "target += inv_chi_square_lpdf(udf_1 | df_1);") - + bprior <- prior(normal(20, 5), class = df, group = patient) scode <- make_stancode( - count ~ Trt + (Trt|gr(patient, dist = "st")), + count ~ Trt + (Trt|gr(patient, dist = "st")), epilepsy, prior = bprior ) expect_match2(scode, "r_1 = rep_matrix(dfm_1, M_1) .* scale_r_cor(z_1, sd_1, L_1);" ) - expect_match2(scode, "target += normal_lpdf(df_1 | 20, 5);") + expect_match2(scode, "lprior += normal_lpdf(df_1 | 20, 5)") }) test_that("centering design matrices can be changed correctly", { @@ -2206,8 +2291,8 @@ prior = prior(normal(0,1), coef = Intercept) ) expect_match2(scode, "mu = X * b;") - expect_match2(scode, "target += normal_lpdf(b[1] | 0, 1);") - + expect_match2(scode, "lprior += normal_lpdf(b[1] | 0, 1);") + bform <- bf(y ~ eta, nl = TRUE) + lf(eta ~ x, center = TRUE) scode <- make_stancode(bform, data = dat) expect_match2(scode, "nlp_eta = Intercept_eta + Xc_eta * b_eta;") @@ -2234,75 +2319,77 @@ prior = bprior, sample_prior = TRUE ) - expect_match2(scode, "prior_sd_1_1 = normal_rng(0,0.1);") - expect_match2(scode, "prior_sd_1_2 = normal_rng(0,0.01);") + expect_match2(scode, "prior_sd_1__1 = normal_rng(0,0.1);") + expect_match2(scode, "prior_sd_1__2 = normal_rng(0,0.01);") }) test_that("threaded Stan code is correct", { + # tests require cmdstanr which is not yet on CRAN + skip_on_cran() + + # only run if cmdstan >= 2.29 can be found on the system + # otherwise the canonicalized code will cause test failures + cmdstan_version <- try(cmdstanr::cmdstan_version(), silent = TRUE) + found_cmdstan <- !is(cmdstan_version, "try-error") + skip_if_not(found_cmdstan && cmdstan_version >= "2.29.0") + options(brms.backend = "cmdstanr") + dat <- data.frame( count = rpois(236, lambda = 20), visit = rep(1:4, each = 59), patient = factor(rep(1:59, 4)), - Age = rnorm(236), + Age = rnorm(236), Trt = factor(sample(0:1, 236, TRUE)), AgeSD = abs(rnorm(236, 1)), Exp = sample(1:5, 236, TRUE), volume = rnorm(236), gender = factor(c(rep("m", 30), rep("f", 29))) ) - - # only parse models if cmdstan can be found on the system - cmdstan_version <- try(cmdstanr::cmdstan_version(), silent = TRUE) - found_cmdstan <- !is(cmdstan_version, "try-error") - options( - brms.parse_stancode = found_cmdstan && not_cran, - brms.backend = "cmdstanr" - ) + threads <- threading(2, grainsize = 20) - bform <- bf( count ~ Trt*Age + mo(Exp) + s(Age) + offset(Age) + (1+Trt|visit), sigma ~ Trt + gp(Age) + gp(volume, by = Trt) ) scode <- make_stancode(bform, dat, family = student(), threads = threads) - expect_match2(scode, "real partial_log_lik_lpmf(int[] seq, int start,") - expect_match2(scode, "mu[n] += (bsp[1]) * mo(simo_1, Xmo_1[nn])") - expect_match2(scode, "ptarget += student_t_lpdf(Y[start:end] | nu, mu, sigma);") - expect_match2(scode, "+ gp_pred_sigma_1[Jgp_sigma_1[start:end]]") + expect_match2(scode, "real partial_log_lik_lpmf(array[] int seq, int start,") + expect_match2(scode, "mu[n] += bsp[1] * mo(simo_1, Xmo_1[nn])") + expect_match2(scode, "ptarget += student_t_lpdf(Y[start : end] | nu, mu, sigma);") + expect_match2(scode, "+ gp_pred_sigma_1[Jgp_sigma_1[start : end]]") expect_match2(scode, ".* gp_pred_sigma_2_1[Jgp_sigma_2_1[which_gp_sigma_2_1]];") expect_match2(scode, "sigma[start_at_one(Igp_sigma_2_2[which_gp_sigma_2_2], start)] +=") expect_match2(scode, "target += reduce_sum(partial_log_lik_lpmf, seq, grainsize, Y,") - + scode <- make_stancode( - visit ~ cs(Trt) + Age, dat, family = sratio(), + visit ~ cs(Trt) + Age, dat, family = sratio(), threads = threads, ) - expect_match2(scode, "matrix[N, nthres] mucs = Xcs[start:end] * bcs;") - expect_match2(scode, - "ptarget += sratio_logit_lpmf(Y[nn] | mu[n], disc, Intercept - transpose(mucs[n]));" - ) - + expect_match2(scode, "matrix[N, nthres] mucs = Xcs[start : end] * bcs;") + expect_match2(scode, + "ptarget += sratio_logit_lpmf(Y[nn] | mu[n], disc, Intercept") + expect_match2(scode, " - transpose(mucs[n]));") + scode <- make_stancode( bf(visit ~ a * Trt ^ b, a ~ mo(Exp), b ~ s(Age), nl = TRUE), - data = dat, family = Gamma("log"), + data = dat, family = Gamma("log"), prior = set_prior("normal(0, 1)", nlpar = c("a", "b")), threads = threads ) expect_match2(scode, "mu[n] = shape * exp(-(nlp_a[n] * C_1[nn] ^ nlp_b[n]));") - expect_match2(scode, "ptarget += gamma_lpdf(Y[start:end] | shape, mu);") - + expect_match2(scode, "ptarget += gamma_lpdf(Y[start : end] | shape, mu);") + bform <- bf(mvbind(count, Exp) ~ Trt) + set_rescor(TRUE) scode <- make_stancode(bform, dat, gaussian(), threads = threads) - expect_match2(scode, "ptarget += multi_normal_cholesky_lpdf(Y[start:end] | Mu, LSigma);") - + expect_match2(scode, "ptarget += multi_normal_cholesky_lpdf(Y[start : end] | Mu, LSigma);") + bform <- bf(brms::mvbind(count, Exp) ~ Trt) + set_rescor(FALSE) scode <- make_stancode(bform, dat, gaussian(), threads = threads) - expect_match2(scode, "target += reduce_sum(partial_log_lik_lpmf_count, seq_count,") - expect_match2(scode, "target += reduce_sum(partial_log_lik_lpmf_Exp, seq_Exp,") - expect_match2(scode, - "ptarget += normal_id_glm_lpdf(Y_Exp[start:end] | Xc_Exp[start:end], Intercept_Exp, b_Exp, sigma_Exp);" + expect_match2(scode, "target += reduce_sum(partial_log_lik_count_lpmf, seq_count,") + expect_match2(scode, "target += reduce_sum(partial_log_lik_Exp_lpmf, seq_Exp,") + expect_match2(scode, + "ptarget += normal_id_glm_lpdf(Y_Exp[start : end] | Xc_Exp[start : end], Intercept_Exp, b_Exp, sigma_Exp);" ) - + scode <- make_stancode( visit ~ Trt, dat, family = mixture(poisson(), nmix = 2), threads = threading(4, grainsize = 10, static = TRUE) @@ -2313,14 +2400,16 @@ }) test_that("Un-normalized Stan code is correct", { - # only parse models if cmdstan >= 2.25 can be found on the system + # tests require cmdstanr which is not yet on CRAN + skip_on_cran() + + # only run if cmdstan >= 2.29 can be found on the system + # otherwise the canonicalized code will cause test failures cmdstan_version <- try(cmdstanr::cmdstan_version(), silent = TRUE) found_cmdstan <- !is(cmdstan_version, "try-error") - options( - brms.parse_stancode = found_cmdstan && cmdstan_version >= "2.25" && not_cran, - brms.backend = "cmdstanr" - ) - + skip_if_not(found_cmdstan && cmdstan_version >= "2.29.0") + options(brms.backend = "cmdstanr") + scode <- make_stancode( count ~ zAge + zBase * Trt + (1|patient) + (1|obs), data = epilepsy, family = poisson(), @@ -2329,9 +2418,9 @@ normalize = FALSE ) expect_match2(scode, "target += poisson_log_glm_lupmf(Y | Xc, mu, b);") - expect_match2(scode, "target += student_t_lupdf(b | 5, 0, 10);") - expect_match2(scode, "target += student_t_lupdf(Intercept | 3, 1.4, 2.5);") - expect_match2(scode, "target += cauchy_lupdf(sd_1 | 0, 2);") + expect_match2(scode, "lprior += student_t_lupdf(b | 5, 0, 10);") + expect_match2(scode, "lprior += student_t_lupdf(Intercept | 3, 1.4, 2.5);") + expect_match2(scode, "lprior += cauchy_lupdf(sd_1 | 0, 2);") expect_match2(scode, "target += std_normal_lupdf(z_1[1]);") scode <- make_stancode( @@ -2341,11 +2430,12 @@ prior(cauchy(0,2), class = sd), normalize = FALSE, threads = threading(2) ) - expect_match2(scode, "target += reduce_sum(partial_log_lik_lpmf, seq, grainsize, Y, Xc, b, Intercept, J_1, Z_1_1, r_1_1, J_2, Z_2_1, r_2_1);") - expect_match2(scode, "ptarget += poisson_log_glm_lupmf(Y[start:end] | Xc[start:end], mu, b);") - expect_match2(scode, "target += student_t_lupdf(b | 5, 0, 10);") - expect_match2(scode, "target += student_t_lupdf(Intercept | 3, 1.4, 2.5);") - expect_match2(scode, "target += cauchy_lupdf(sd_1 | 0, 2);") + expect_match2(scode, "target += reduce_sum(partial_log_lik_lpmf, seq, grainsize, Y, Xc, b,") + expect_match2(scode, " Intercept, J_1, Z_1_1, r_1_1, J_2, Z_2_1, r_2_1);") + expect_match2(scode, "ptarget += poisson_log_glm_lupmf(Y[start : end] | Xc[start : end], mu, b);") + expect_match2(scode, "lprior += student_t_lupdf(b | 5, 0, 10);") + expect_match2(scode, "lprior += student_t_lupdf(Intercept | 3, 1.4, 2.5);") + expect_match2(scode, "lprior += cauchy_lupdf(sd_1 | 0, 2);") expect_match2(scode, "target += std_normal_lupdf(z_1[1]);") # Check that brms custom distributions stay normalized @@ -2354,7 +2444,8 @@ data = inhaler, family = sratio("cloglog"), normalize = FALSE ) - expect_match2(scode, "target += sratio_cloglog_lpmf(Y[n] | mu[n], disc, Intercept - transpose(mucs[n]));") + expect_match2(scode, "target += sratio_cloglog_lpmf(Y[n] | mu[n], disc, Intercept") + expect_match2(scode, " - transpose(mucs[n]));") # Check that user-specified custom distributions stay normalized dat <- data.frame(size = 10, y = sample(0:10, 20, TRUE), x = rnorm(20)) @@ -2362,9 +2453,9 @@ beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "tau"), - links = c("logit", "log"), + links = c("logit", "log"), lb = c(NA, 0), - type = "int", + type = "int", vars = c("vint1[n]", "vreal1[n]"), ) @@ -2377,7 +2468,7 @@ stanvars <- stanvar(scode = stan_funs, block = "functions") scode <- make_stancode( - y | vint(size) + vreal(size) ~ x, data = dat, family = beta_binomial2, + y | vint(size) + vreal(size) ~ x, data = dat, family = beta_binomial2, prior = prior(gamma(0.1, 0.1), class = "tau"), stanvars = stanvars, normalize = FALSE, backend = "cmdstanr" ) @@ -2385,6 +2476,48 @@ expect_match2(scode, "gamma_lupdf(tau | 0.1, 0.1);") }) +test_that("Canonicalizing Stan code is correct", { + # tests require cmdstanr which is not yet on CRAN + skip_on_cran() + + # only run if cmdstan >= 2.29 can be found on the system + # otherwise the canonicalized code will cause test failures + cmdstan_version <- try(cmdstanr::cmdstan_version(), silent = TRUE) + found_cmdstan <- !is(cmdstan_version, "try-error") + skip_if_not(found_cmdstan && cmdstan_version >= "2.29.0") + options(brms.backend = "cmdstanr") + + scode <- make_stancode( + count ~ zAge + zBase * Trt + (1|patient) + (1|obs), + data = epilepsy, family = poisson(), + prior = prior(student_t(5,0,10), class = b) + + prior(cauchy(0,2), class = sd), + normalize = FALSE + ) + expect_match2(scode, "array[M_1] vector[N_1] z_1;") + expect_match2(scode, "array[M_2] vector[N_2] z_2;") + + model <- " + data { + int a[5]; + real b[5]; + vector[5] c[4]; + } + parameters { + real d[5]; + vector[5] e[4]; + } + " + stan_file <- cmdstanr::write_stan_file(model) + canonicalized_code <- .canonicalize_stan_model(stan_file, overwrite_file = FALSE) + expect_match2(canonicalized_code, "array[5] int a;") + expect_match2(canonicalized_code, "array[5] real b;") + expect_match2(canonicalized_code, "array[4] vector[5] c;") + expect_match2(canonicalized_code, "array[5] real d;") + expect_match2(canonicalized_code, "array[4] vector[5] e;") + +}) + test_that("Normalizing Stan code works correctly", { expect_equal( normalize_stancode("// a\nb;\n b + c = 4; // kde\ndata"), diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.make_standata.R r-cran-brms-2.17.0/tests/testthat/tests.make_standata.R --- r-cran-brms-2.16.3/tests/testthat/tests.make_standata.R 2021-09-20 10:28:22.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.make_standata.R 2022-04-09 09:34:51.000000000 +0000 @@ -2,26 +2,26 @@ test_that(paste("make_standata returns correct data names ", "for fixed and random effects"), { - expect_equal(names(make_standata(rating ~ treat + period + carry + expect_equal(names(make_standata(rating ~ treat + period + carry + (1|subject), data = inhaler)), c("N", "Y", "K", "X", "Z_1_1", "J_1", "N_1", "M_1", "NC_1", "prior_only")) - expect_equal(names(make_standata(rating ~ treat + period + carry + expect_equal(names(make_standata(rating ~ treat + period + carry + (1+treat|id|subject), data = inhaler, family = "categorical")), - c("N", "Y", "ncat", "K_mu2", "X_mu2", "Z_1_mu2_1", + c("N", "Y", "ncat", "K_mu2", "X_mu2", "Z_1_mu2_1", "Z_1_mu2_2", "K_mu3", "X_mu3", "Z_1_mu3_3", "Z_1_mu3_4", "K_mu4", "X_mu4", "Z_1_mu4_5", "Z_1_mu4_6", "J_1", "N_1", "M_1", "NC_1", "prior_only")) - expect_equal(names(make_standata(rating ~ treat + period + carry + expect_equal(names(make_standata(rating ~ treat + period + carry + (1+treat|subject), data = inhaler)), c("N", "Y", "K", "X", "Z_1_1", "Z_1_2", "J_1", "N_1", "M_1", "NC_1", "prior_only")) - + dat <- data.frame(y = 1:10, g = 1:10, h = 11:10, x = rep(0,10)) expect_equal(names(make_standata(y ~ x + (1|g) + (1|h), dat, "poisson")), c("N", "Y", "K", "X", "Z_1_1", "Z_2_1", - "J_1", "J_2", "N_1", "M_1", "NC_1", "N_2", "M_2", "NC_2", + "J_1", "J_2", "N_1", "M_1", "NC_1", "N_2", "M_2", "NC_2", "prior_only")) expect_true(all(c("Z_1_1", "Z_1_2", "Z_2_1", "Z_2_2") %in% names(make_standata(y ~ x + (1+x|g/h), dat)))) @@ -29,33 +29,33 @@ make_standata(y ~ x + (1+x|g) + (1+x|h), dat)) }) -test_that(paste("make_standata handles variables used as fixed effects", +test_that(paste("make_standata handles variables used as fixed effects", "and grouping factors at the same time"), { data <- data.frame(y = 1:9, x = factor(rep(c("a","b","c"), 3))) standata <- make_standata(y ~ x + (1|x), data = data) expect_equal(colnames(standata$X), c("Intercept", "xb", "xc")) expect_equal(standata$J_1, as.array(rep(1:3, 3))) - standata2 <- make_standata(y ~ x + (1|x), data = data, + standata2 <- make_standata(y ~ x + (1|x), data = data, control = list(not4stan = TRUE)) expect_equal(colnames(standata2$X), c("Intercept", "xb", "xc")) }) test_that("make_standata returns correct data names for addition terms", { - dat <- data.frame(y = 1:10, w = 1:10, t = 1:10, x = rep(0,10), + dat <- data.frame(y = 1:10, w = 1:10, t = 1:10, x = rep(0,10), c = sample(-1:1,10,TRUE)) - expect_equal(names(make_standata(y | se(w) ~ x, dat, gaussian())), + expect_equal(names(make_standata(y | se(w) ~ x, dat, gaussian())), c("N", "Y", "se", "K", "X", "sigma", "prior_only")) - expect_equal(names(make_standata(y | weights(w) ~ x, dat, "gaussian")), + expect_equal(names(make_standata(y | weights(w) ~ x, dat, "gaussian")), c("N", "Y", "weights", "K", "X", "prior_only")) - expect_equal(names(make_standata(y | cens(c) ~ x, dat, "student")), + expect_equal(names(make_standata(y | cens(c) ~ x, dat, "student")), c("N", "Y", "cens", "K", "X", "prior_only")) - expect_equal(names(make_standata(y | trials(t) ~ x, dat, "binomial")), + expect_equal(names(make_standata(y | trials(t) ~ x, dat, "binomial")), c("N", "Y", "trials", "K", "X", "prior_only")) - expect_equal(names(make_standata(y | trials(10) ~ x, dat, "binomial")), + expect_equal(names(make_standata(y | trials(10) ~ x, dat, "binomial")), c("N", "Y", "trials", "K", "X", "prior_only")) expect_equal(names(make_standata(y | thres(11) ~ x, dat, "acat")), c("N", "Y", "nthres", "K", "X", "disc", "prior_only")) - expect_equal(names(make_standata(y | thres(10) ~ x, dat, cumulative())), + expect_equal(names(make_standata(y | thres(10) ~ x, dat, cumulative())), c("N", "Y", "nthres", "K", "X", "disc", "prior_only")) sdata <- make_standata(y | trunc(0,20) ~ x, dat, "gaussian") expect_true(all(sdata$lb == 0) && all(sdata$ub == 20)) @@ -63,32 +63,36 @@ expect_true(all(all(sdata$ub == 21:30))) }) -test_that(paste("make_standata accepts correct response variables", +test_that(paste("make_standata accepts correct response variables", "depending on the family"), { - expect_equal(make_standata(y ~ 1, data = data.frame(y = seq(-9.9,0,0.1)), + expect_equal(make_standata(y ~ 1, data = data.frame(y = seq(-9.9,0,0.1)), family = "student")$Y, as.array(seq(-9.9,0,0.1))) - expect_equal(make_standata(y | trials(10) ~ 1, data = data.frame(y = 1:10), + expect_equal(make_standata(y | trials(10) ~ 1, data = data.frame(y = 1:10), family = "binomial")$Y, as.array(1:10)) - expect_equal(make_standata(y ~ 1, data = data.frame(y = 10:20), + expect_equal(make_standata(y ~ 1, data = data.frame(y = 10:20), family = "poisson")$Y, as.array(10:20)) - expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(-c(1:2),5)), + expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(-c(1:2),5)), family = "bernoulli")$Y, as.array(rep(1:0,5))) expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(c(TRUE, FALSE),5)), family = "bernoulli")$Y, as.array(rep(1:0,5))) - expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(1:10,5)), + expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(1,5)), + family = "bernoulli")$Y, as.array(rep(1, 5))) + expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(0,5)), + family = "bernoulli")$Y, as.array(rep(0, 5))) + expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(1:10,5)), family = "categorical")$Y, as.array(rep(1:10,5))) - expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(11:20,5)), + expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(11:20,5)), family = "categorical")$Y, as.array(rep(1:10,5))) - expect_equal(make_standata(y ~ 1, data = data.frame(y = factor(rep(11:20,5))), + expect_equal(make_standata(y ~ 1, data = data.frame(y = factor(rep(11:20,5))), family = "categorical")$Y, as.array(rep(1:10,5))) - expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(1:10,5)), + expect_equal(make_standata(y ~ 1, data = data.frame(y = rep(1:10,5)), family = "cumulative")$Y, as.array(rep(1:10,5))) dat <- data.frame(y = factor(rep(-4:5,5), order = TRUE)) - expect_equal(make_standata(y ~ 1, data = dat, family = "acat")$Y, + expect_equal(make_standata(y ~ 1, data = dat, family = "acat")$Y, as.array(rep(1:10,5))) - expect_equal(make_standata(y ~ 1, data = data.frame(y = seq(1,10,0.1)), + expect_equal(make_standata(y ~ 1, data = data.frame(y = seq(1,10,0.1)), family = "exponential")$Y, as.array(seq(1,10,0.1))) - + dat <- data.frame(y1 = 1:10, y2 = 11:20, x = rep(0,10)) form <- bf(mvbind(y1, y2) ~ x) + set_rescor(TRUE) sdata <- make_standata(form, data = dat) @@ -96,24 +100,24 @@ expect_equal(sdata$Y_y2, as.array(11:20)) }) -test_that(paste("make_standata rejects incorrect response variables", +test_that(paste("make_standata rejects incorrect response variables", "depending on the family"), { - expect_error(make_standata(y ~ 1, data = data.frame(y = factor(1:10)), + expect_error(make_standata(y ~ 1, data = data.frame(y = factor(1:10)), family = "student"), "Family 'student' requires numeric responses") - expect_error(make_standata(y ~ 1, data = data.frame(y = -5:5), + expect_error(make_standata(y ~ 1, data = data.frame(y = -5:5), family = "geometric"), "Family 'geometric' requires response greater than or equal to 0") - expect_error(make_standata(y ~ 1, data = data.frame(y = -1:1), + expect_error(make_standata(y ~ 1, data = data.frame(y = -1:1), family = "bernoulli"), "contain only two different values") - expect_error(make_standata(y ~ 1, data = data.frame(y = factor(-1:1)), + expect_error(make_standata(y ~ 1, data = data.frame(y = factor(-1:1)), family = "cratio"), "Family 'cratio' requires either positive integers or ordered factors") - expect_error(make_standata(y ~ 1, data = data.frame(y = rep(0.5:7.5), 2), + expect_error(make_standata(y ~ 1, data = data.frame(y = rep(0.5:7.5), 2), family = "sratio"), "Family 'sratio' requires either positive integers or ordered factors") - expect_error(make_standata(y ~ 1, data = data.frame(y = rep(-7.5:7.5), 2), + expect_error(make_standata(y ~ 1, data = data.frame(y = rep(-7.5:7.5), 2), family = "gamma"), "Family 'gamma' requires response greater than 0") expect_error(make_standata(y ~ 1, data = data.frame(y = c(0.1, 0.5, 1)), @@ -128,94 +132,94 @@ }) test_that("make_standata suggests using family bernoulli if appropriate", { - expect_message(make_standata(y | trials(1) ~ 1, data = list(y = rep(0:1,5)), + expect_message(make_standata(y | trials(1) ~ 1, data = list(y = rep(0:1,5)), family = "binomial"), "family 'bernoulli' might be a more efficient choice.") - expect_message(make_standata(y ~ 1, data = data.frame(y = rep(1:2, 5)), + expect_message(make_standata(y ~ 1, data = data.frame(y = rep(1:2, 5)), family = "acat"), "family 'bernoulli' might be a more efficient choice.") - expect_message(make_standata(y ~ 1, data = data.frame(y = rep(0:1,5)), + expect_message(make_standata(y ~ 1, data = data.frame(y = rep(0:1,5)), family = "categorical"), "family 'bernoulli' might be a more efficient choice.") }) test_that("make_standata returns correct values for addition terms", { - dat <- data.frame(y = rnorm(9), s = 1:9, w = 1:9, c1 = rep(-1:1, 3), + dat <- data.frame(y = rnorm(9), s = 1:9, w = 1:9, c1 = rep(-1:1, 3), c2 = rep(c("left","none","right"), 3), c3 = c(rep(c(TRUE, FALSE), 4), FALSE), c4 = c(sample(-1:1, 5, TRUE), rep(2, 4)), t = 11:19) - expect_equivalent(make_standata(y | se(s) ~ 1, data = dat)$se, + expect_equivalent(make_standata(y | se(s) ~ 1, data = dat)$se, as.array(1:9)) - expect_equal(make_standata(y | weights(w) ~ 1, data = dat)$weights, + expect_equal(make_standata(y | weights(w) ~ 1, data = dat)$weights, as.array(1:9)) - expect_equal(make_standata(y | cens(c1) ~ 1, data = dat)$cens, + expect_equal(make_standata(y | cens(c1) ~ 1, data = dat)$cens, as.array(rep(-1:1, 3))) expect_equal(make_standata(y | cens(c2) ~ 1, data = dat)$cens, as.array(rep(-1:1, 3))) - expect_equal(make_standata(y | cens(c3) ~ 1, data = dat)$cens, + expect_equal(make_standata(y | cens(c3) ~ 1, data = dat)$cens, as.array(c(rep(1:0, 4), 0))) - expect_equal(make_standata(y | cens(c4, y + 2) ~ 1, data = dat)$rcens, + expect_equal(make_standata(y | cens(c4, y + 2) ~ 1, data = dat)$rcens, as.array(c(rep(0, 5), dat$y[6:9] + 2))) sdata <- suppressWarnings(make_standata(s ~ 1, dat, family = "binomial")) expect_equal(sdata$trials, as.array(rep(9, 9))) - expect_equal(make_standata(s | trials(10) ~ 1, dat, - family = "binomial")$trials, + expect_equal(make_standata(s | trials(10) ~ 1, dat, + family = "binomial")$trials, as.array(rep(10, 9))) - expect_equal(make_standata(s | trials(t) ~ 1, data = dat, - family = "binomial")$trials, + expect_equal(make_standata(s | trials(t) ~ 1, data = dat, + family = "binomial")$trials, as.array(11:19)) - expect_equal(SW(make_standata(s | cat(19) ~ 1, data = dat, - family = "cumulative"))$nthres, + expect_equal(SW(make_standata(s | cat(19) ~ 1, data = dat, + family = "cumulative"))$nthres, 18) }) test_that("make_standata rejects incorrect addition terms", { - dat <- data.frame(y = rnorm(9), s = -(1:9), w = -(1:9), + dat <- data.frame(y = rnorm(9), s = -(1:9), w = -(1:9), c = rep(-2:0, 3), t = 9:1, z = 1:9) - expect_error(make_standata(y | se(s) ~ 1, data = dat), + expect_error(make_standata(y | se(s) ~ 1, data = dat), "Standard errors must be non-negative") - expect_error(make_standata(y | weights(w) ~ 1, data = dat), + expect_error(make_standata(y | weights(w) ~ 1, data = dat), "Weights must be non-negative") expect_error(make_standata(y | cens(c) ~ 1, data = dat)) - expect_error(make_standata(z | trials(t) ~ 1, data = dat, + expect_error(make_standata(z | trials(t) ~ 1, data = dat, family = "binomial"), "Number of trials is smaller than the number of events") }) test_that("make_standata handles multivariate models", { dat <- data.frame( - y1 = 1:10, y2 = 11:20, + y1 = 1:10, y2 = 11:20, x = rep(0, 10), g = rep(1:2, 5), censi = sample(0:1, 10, TRUE), tim = 10:1, w = 1:10 ) - + form <- bf(mvbind(y1, y2) | weights(w) ~ x) + set_rescor(TRUE) sdata <- make_standata(form, data = dat) expect_equal(sdata$Y_y1, as.array(dat$y1)) expect_equal(sdata$Y_y2, as.array(dat$y2)) expect_equal(sdata$weights_y1, as.array(1:10)) - - expect_error(make_standata(bf(mvbind(y1, y2, y2) ~ x) + set_resor(FALSE), + + expect_error(make_standata(bf(mvbind(y1, y2, y2) ~ x) + set_resor(FALSE), data = dat), "Cannot use the same response variable twice") - + form <- bf(mvbind(y1 / y2, y2, y1 * 3) ~ x) + set_rescor(FALSE) sdata <- make_standata(form, data = dat) expect_equal(sdata$Y_y1y2, as.array(dat$y1 / dat$y2)) - + sdata <- suppressWarnings( make_standata(mvbind(y1, y2) ~ x, dat, autocor = cor_ar(~ tim | g)) ) target1 <- c(seq(9, 1, -2), seq(10, 2, -2)) - expect_equal(sdata$Y_y1, as.array(target1)) + expect_equal(sdata$Y_y1, as.array(target1)) target2 <- c(seq(19, 11, -2), seq(20, 12, -2)) - expect_equal(sdata$Y_y2, as.array(target2)) - + expect_equal(sdata$Y_y2, as.array(target2)) + # models without residual correlations expect_warning( - bform <- bf(y1 | cens(censi) ~ x + y2 + (x|2|g)) + + bform <- bf(y1 | cens(censi) ~ x + y2 + (x|2|g)) + gaussian() + cor_ar() + (bf(x ~ 1) + mixture(poisson, nmix = 2)) + (bf(y2 ~ s(y2) + (1|2|g)) + skew_normal()), @@ -226,7 +230,7 @@ prior(dirichlet(2, 1), theta, resp = x) sdata <- make_standata(bform, dat, prior = bprior) sdata_names <- c( - "N", "J_1_y1", "cens_y1", "Kma_y1", "Z_1_y2_3", + "N", "J_1_y1", "cens_y1", "Kma_y1", "Z_1_y2_3", "Zs_y2_1_1", "Y_y2", "con_theta_x", "X_mu2_x" ) expect_true(all(sdata_names %in% names(sdata))) @@ -251,12 +255,12 @@ sub1 = 0, sub2 = 1 ) dat <- rbind(dat1, dat2) - - bform <- + + bform <- bf(y1 | subset(sub1) ~ x1*x3 + sin(x1), family = gaussian()) + bf(y2 | subset(sub2) ~ x2, family = gaussian()) + set_rescor(FALSE) - + sdata <- make_standata(bform, dat) nsub1 <- sum(dat$sub1) nsub2 <- sum(dat$sub2) @@ -268,29 +272,29 @@ test_that("make_standata returns correct data for ARMA terms", { dat <- data.frame(y = 1:10, x = rep(0, 10), tim = 10:1, g = rep(3:4, 5)) - + sdata <- make_standata(y ~ x + ma(tim, g), data = dat) expect_equal(sdata$J_lag, as.array(c(1, 1, 1, 1, 0, 1, 1, 1, 1, 0))) - + sdata <- make_standata(y ~ x + ar(tim, g, p = 2), data = dat) expect_equal(sdata$J_lag, as.array(c(1, 2, 2, 2, 0, 1, 2, 2, 2, 0))) - + sdata <- make_standata(y ~ x + ar(tim, g, cov = TRUE), data = dat) expect_equal(sdata$begin_tg, as.array(c(1, 6))) expect_equal(sdata$nobs_tg, as.array(c(5, 5))) - + bform <- bf(y ~ exp(b * x), b ~ 1, nl = TRUE, autocor = ~arma()) sdata <- make_standata(bform, dat) }) test_that("make_standata allows to retrieve the initial data order", { - dat <- data.frame(y1 = rnorm(100), y2 = rnorm(100), - id = sample(1:10, 100, TRUE), + dat <- data.frame(y1 = rnorm(100), y2 = rnorm(100), + id = sample(1:10, 100, TRUE), time = sample(1:100, 100)) # univariate model sdata1 <- make_standata(y1 ~ ar(time, id), data = dat, internal = TRUE) expect_equal(dat$y1, as.numeric(sdata1$Y[attr(sdata1, "old_order")])) - + # multivariate model form <- bf(mvbind(y1, y2) ~ ma(time, id)) + set_rescor(FALSE) sdata2 <- make_standata(form, data = dat, internal = TRUE) @@ -303,28 +307,28 @@ sdata <- make_standata(count ~ Trt + (1|gr(visit, cov = A)), data = epilepsy, data2 = list(A = A)) expect_equivalent(sdata$Lcov_1, t(chol(A))) - + B <- structure(diag(1:5), dimnames = list(c(1,5,2,4,3), NULL)) sdata <- make_standata(count ~ Trt + (1|gr(visit, cov = B)), data = epilepsy, data2 = list(B = B)) expect_equivalent(sdata$Lcov_1, t(chol(B[c(1,3,5,4), c(1,3,5,4)]))) - + B <- diag(1, 4) - expect_error(make_standata(count ~ Trt + (1|gr(visit, cov = B)), + expect_error(make_standata(count ~ Trt + (1|gr(visit, cov = B)), data = epilepsy, data2 = list(B = B)), "Row or column names are required") - + B <- structure(diag(1, 4), dimnames = list(2:5, NULL)) - expect_error(make_standata(count ~ Trt + (1|gr(visit, cov = B)), + expect_error(make_standata(count ~ Trt + (1|gr(visit, cov = B)), data = epilepsy, data2 = list(B = B)), "Levels of .* do not match") B <- A B[1,2] <- 0.5 - expect_error(make_standata(count ~ Trt + (1|gr(visit, cov = B)), + expect_error(make_standata(count ~ Trt + (1|gr(visit, cov = B)), data = epilepsy, data2 = list(B = B)), "must be symmetric") - + expect_warning( sdata <- make_standata(count ~ Trt + (1|visit), data = epilepsy, cov_ranef = list(visit = A)), @@ -340,16 +344,16 @@ ) bform <- bf(y ~ a - b^z, flist = flist, nl = TRUE) sdata <- make_standata(bform, data = dat) - expect_equal(names(sdata), - c("N", "Y", "C_1", "K_a", "X_a", "Z_1_a_1", - "K_b", "X_b", "Ksp_b", "Imo_b", "Xmo_b_1", "Jmo_b", - "con_simo_b_1", "Z_1_b_2", "J_1", "N_1", + expect_equal(names(sdata), + c("N", "Y", "C_1", "K_a", "X_a", "Z_1_a_1", + "K_b", "X_b", "Ksp_b", "Imo_b", "Xmo_b_1", "Jmo_b", + "con_simo_b_1", "Z_1_b_2", "J_1", "N_1", "M_1", "NC_1", "prior_only") ) expect_equal(colnames(sdata$X_a), c("Intercept", "x")) expect_equal(sdata$J_1, as.array(dat$g)) - - bform <- bf(y ~ x) + + + bform <- bf(y ~ x) + nlf(sigma ~ a1 * exp(-x/(a2 + z))) + lf(a1 ~ 1, a2 ~ z + (x|g)) + lf(alpha ~ x) @@ -369,17 +373,17 @@ expect_equivalent(sdata$Xmo_1, as.array(data$x1 - 1)) expect_equivalent(sdata$Xmo_2, as.array(as.numeric(data$x2) - 1)) expect_equal( - as.vector(unname(sdata$Jmo)), + as.vector(unname(sdata$Jmo)), rep(c(max(data$x1) - 1, length(unique(data$x2)) - 1), 4) ) expect_equal(sdata$con_simo_1, as.array(rep(1, 3))) - - prior <- set_prior("dirichlet(1:3)", coef = "mox11", + + prior <- set_prior("dirichlet(1:3)", coef = "mox11", class = "simo", dpar = "sigma") - sdata <- make_standata(bf(y ~ 1, sigma ~ mo(x1)), + sdata <- make_standata(bf(y ~ 1, sigma ~ mo(x1)), data = data, prior = prior) expect_equal(sdata$con_simo_sigma_1, as.array(1:3)) - + prior <- c( set_prior("normal(0,1)", class = "b", coef = "mox1"), set_prior("dirichlet(c(1, 0.5, 2))", class = "simo", coef = "mox11"), @@ -388,21 +392,21 @@ sdata <- make_standata(y ~ mo(x1)*mo(x2), data = data, prior = prior) expect_equal(sdata$con_simo_1, as.array(c(1, 0.5, 2))) expect_equal(sdata$con_simo_3, as.array(c(1, 0.5, 2))) - + # test issue #924 (conditional monotonicity) prior <- c(prior(dirichlet(c(1, 0.5, 2)), simo, coef = "v"), prior(dirichlet(c(1,3)), simo, coef = "w")) - sdata <- make_standata(y ~ y*mo(x1, id = "v")*mo(x2, id = "w"), + sdata <- make_standata(y ~ y*mo(x1, id = "v")*mo(x2, id = "w"), data, prior = prior) expect_equal(sdata$con_simo_1, as.array(c(1, 0.5, 2))) expect_equal(sdata$con_simo_2, as.array(c(1, 3))) expect_true(!"sdata$con_simo_3" %in% names(sdata)) - + expect_error( make_standata(y ~ mo(z), data = data), "Monotonic predictors must be integers or ordered factors" ) - + prior <- c(set_prior("dirichlet(c(1,0.5,2))", class = "simo", coef = "mox21")) expect_error( make_standata(y ~ mo(x2), data = data, prior = prior), @@ -413,9 +417,9 @@ test_that("make_standata returns FCOR covariance matrices", { data <- data.frame(y = 1:5) data2 <- list(V = diag(5)) - expect_equal(make_standata(y ~ fcor(V), data, data2 = data2)$Mfcor, + expect_equal(make_standata(y ~ fcor(V), data, data2 = data2)$Mfcor, data2$V, check.attributes = FALSE) - + expect_warning( expect_error( make_standata(y~1, data, autocor = cor_fixed(diag(2))), @@ -433,43 +437,43 @@ expect_equal(as.vector(sdata$knots_2), 8) expect_equal(dim(sdata$Zs_1_1), c(10, 8)) expect_equal(dim(sdata$Zs_2_1), c(10, 8)) - + bform <- bf(y ~ lp, lp ~ s(x1) + z + s(x2, by = x3), nl = TRUE) sdata <- make_standata(bform, dat) expect_equal(sdata$nb_lp_1, 1) expect_equal(as.vector(sdata$knots_lp_2), 8) expect_equal(dim(sdata$Zs_lp_1_1), c(10, 8)) expect_equal(dim(sdata$Zs_lp_2_1), c(10, 8)) - + sdata <- make_standata(y ~ g + s(x2, by = g), data = dat) expect_true(all(c("knots_1", "knots_2") %in% names(sdata))) - + # test issue #562 dat$g <- as.character(dat$g) sdata <- make_standata(y ~ g + s(x2, by = g), data = dat) expect_true(all(c("knots_1", "knots_2") %in% names(sdata))) - + sdata <- make_standata(y ~ t2(x1, x2), data = dat) expect_equal(sdata$nb_1, 3) expect_equal(as.vector(sdata$knots_1), c(9, 6, 6)) expect_equal(dim(sdata$Zs_1_1), c(10, 9)) expect_equal(dim(sdata$Zs_1_3), c(10, 6)) - + expect_error(make_standata(y ~ te(x1, x2), data = dat), "smooths 'te' and 'ti' are not yet implemented") }) test_that("make_standata returns correct group ID data", { - form <- bf(count ~ Trt + (1+Trt|3|visit) + (1|patient), + form <- bf(count ~ Trt + (1+Trt|3|visit) + (1|patient), shape ~ (1|3|visit) + (Trt||patient)) sdata <- make_standata(form, data = epilepsy, family = negbinomial()) - expect_true(all(c("Z_1_1", "Z_2_2", "Z_3_shape_1", "Z_2_shape_3") %in% + expect_true(all(c("Z_1_1", "Z_2_2", "Z_3_shape_1", "Z_2_shape_3") %in% names(sdata))) - + form <- bf(count ~ a, sigma ~ (1|3|visit) + (Trt||patient), a ~ Trt + (1+Trt|3|visit) + (1|patient), nl = TRUE) sdata <- make_standata(form, data = epilepsy, family = student()) - expect_true(all(c("Z_1_sigma_1", "Z_2_a_3", "Z_2_sigma_1", + expect_true(all(c("Z_1_sigma_1", "Z_2_a_3", "Z_2_sigma_1", "Z_3_a_1") %in% names(sdata))) }) @@ -477,32 +481,32 @@ dat <- data.frame(y = 10:1, x = 1:10) sdata <- make_standata(y ~ 0 + x, data = dat) expect_equal(unname(sdata$X[, 1]), dat$x) - + sdata <- make_standata(y ~ x, dat, cumulative(), control = list(not4stan = TRUE)) expect_equal(unname(sdata$X[, 1]), dat$x) - + sdata <- make_standata(y ~ 0 + Intercept + x, data = dat) expect_equal(unname(sdata$X), cbind(1, dat$x)) }) test_that("make_standata handles category specific effects", { - sdata <- make_standata(rating ~ period + carry + cse(treat), + sdata <- make_standata(rating ~ period + carry + cse(treat), data = inhaler, family = sratio()) expect_equivalent(sdata$Xcs, matrix(inhaler$treat)) - sdata <- make_standata(rating ~ period + carry + cs(treat) + (cs(1)|subject), + sdata <- make_standata(rating ~ period + carry + cs(treat) + (cs(1)|subject), data = inhaler, family = acat()) expect_equivalent(sdata$Z_1_3, as.array(rep(1, nrow(inhaler)))) - sdata <- make_standata(rating ~ period + carry + (cs(treat)|subject), + sdata <- make_standata(rating ~ period + carry + (cs(treat)|subject), data = inhaler, family = cratio()) expect_equivalent(sdata$Z_1_4, as.array(inhaler$treat)) expect_warning( make_standata(rating ~ 1 + cs(treat), data = inhaler, - family = "cumulative"), + family = "cumulative"), "Category specific effects for this family should be considered experimental" ) - expect_error(make_standata(rating ~ 1 + (treat + cs(1)|subject), - data = inhaler, family = "cratio"), + expect_error(make_standata(rating ~ 1 + (treat + cs(1)|subject), + data = inhaler, family = "cratio"), "category specific effects in separate group-level terms") }) @@ -526,7 +530,7 @@ ID = rep(1:5, each = N / 5) ) sdata <- make_standata( - bf(y ~ me(x, xsd)*me(z, zsd)*x, sigma ~ me(x, xsd)), + bf(y ~ me(x, xsd)*me(z, zsd)*x, sigma ~ me(x, xsd)), data = dat ) expect_equal(sdata$Xn_1, as.array(dat$x)) @@ -538,15 +542,15 @@ test_that("make_standata handles noise-free terms with grouping factors", { dat <- data.frame( - y = rnorm(10), - x1 = rep(1:5, each = 2), + y = rnorm(10), + x1 = rep(1:5, each = 2), sdx = rep(1:5, each = 2), g = rep(c("b", "c", "a", "d", 1), each = 2) ) sdata <- make_standata(y ~ me(x1, sdx, gr = g), dat) expect_equal(unname(sdata$Xn_1), as.array(c(5, 3, 1, 2, 4))) expect_equal(unname(sdata$noise_1), as.array(c(5, 3, 1, 2, 4))) - + dat$sdx[2] <- 10 expect_error( make_standata(y ~ me(x1, sdx, gr = g), dat), @@ -562,16 +566,16 @@ sdata <- make_standata(bform, dat) expect_equal(sdata$Jmi_x, as.array(miss)) expect_true(all(is.infinite(sdata$Y_x[miss]))) - + # dots in variable names are correctly handled #452 dat$x.2 <- dat$x bform <- bf(y ~ mi(x.2)*g) + bf(x.2 | mi() ~ g) + set_rescor(FALSE) sdata <- make_standata(bform, dat) expect_equal(sdata$Jmi_x, as.array(miss)) - + dat$z <- rbeta(10, 1, 1) dat$z[miss] <- NA - bform <- bf(exp(y) ~ mi(z)*g) + bf(z | mi() ~ g, family = Beta()) + + bform <- bf(exp(y) ~ mi(z)*g) + bf(z | mi() ~ g, family = Beta()) + set_rescor(FALSE) sdata <- make_standata(bform, dat) expect_equal(sdata$Jmi_z, as.array(miss)) @@ -588,46 +592,47 @@ expect_true(all(is.infinite(sdata$noise_x[miss]))) }) -test_that("make_standata handles mi terms with 'subset'", { +test_that("make_standata handles 'mi' terms with 'subset'", { dat <- data.frame( - y = rnorm(10), x = c(rnorm(9), NA), z = rnorm(10), + y = rnorm(10), x = c(rnorm(9), NA), z = rnorm(10), g1 = sample(1:5, 10, TRUE), g2 = 10:1, g3 = 1:10, s = c(FALSE, rep(TRUE, 9)) ) - - bform <- bf(y ~ mi(x, idx = g1)) + + + bform <- bf(y ~ mi(x, idx = g1)) + bf(x | mi() + index(g2) + subset(s) ~ 1) + set_rescor(FALSE) sdata <- make_standata(bform, dat) expect_true(all(sdata$idxl_y_x_1 %in% 9:5)) - + # test a bunch of errors - bform <- bf(y ~ mi(x, idx = g1)) + - bf(x | mi() + index(g3) + subset(s) ~ 1) + - set_rescor(FALSE) - expect_error(make_standata(bform, dat), - "Could not match all indices in response 'x'" - ) - - bform <- bf(y ~ mi(x, idx = g1)) + + # fails on CRAN for some reason + # bform <- bf(y ~ mi(x, idx = g1)) + + # bf(x | mi() + index(g3) + subset(s) ~ 1) + + # set_rescor(FALSE) + # expect_error(make_standata(bform, dat), + # "Could not match all indices in response 'x'" + # ) + + bform <- bf(y ~ mi(x, idx = g1)) + bf(x | mi() + subset(s) ~ 1) + set_rescor(FALSE) - expect_error(make_standata(bform, dat), - "Response 'x' needs to have an 'index' addition term" + expect_error(make_standata(bform, dat), + "Response 'x' needs to have an 'index' addition term" ) - - bform <- bf(y ~ mi(x)) + + + bform <- bf(y ~ mi(x)) + bf(x | mi() + subset(s) + index(g2) ~ 1) + set_rescor(FALSE) - expect_error(make_standata(bform, dat), + expect_error(make_standata(bform, dat), "mi() terms of subsetted variables require the 'idx' argument", fixed = TRUE ) - - bform <- bf(y | mi() ~ mi(x, idx = g1)) + + + bform <- bf(y | mi() ~ mi(x, idx = g1)) + bf(x | mi() + subset(s) + index(g2) ~ mi(y)) + set_rescor(FALSE) - expect_error(make_standata(bform, dat), + expect_error(make_standata(bform, dat), "mi() terms in subsetted formulas require the 'idx' argument", fixed = TRUE ) @@ -645,15 +650,15 @@ # this checks whether combintation of factor levels works as intended expect_equal(sdata$J_1_1, as.array(c(6, 5, 4, 3, 2, 1, 7, 7, 7, 7))) expect_equal(sdata$J_1_2, as.array(c(8, 1, 2, 3, 4, 5, 6, 9, 10, 7))) - + sdata <- make_standata(y ~ (1|mm(g1,g2, weights = cbind(w1, w2))), dat) expect_equal(sdata$W_1_1, as.array(dat$w1 / (dat$w1 + dat$w2))) - + # tests mmc terms sdata <- make_standata(y ~ (1+mmc(w1, w2)|mm(g1,g2)), data = dat) expect_equal(unname(sdata$Z_1_2_1), as.array(dat$w1)) expect_equal(unname(sdata$Z_1_2_2), as.array(dat$w2)) - + expect_error( make_standata(y ~ (mmc(w1, w2, y)|mm(g1,g2)), data = dat), "Invalid term 'mmc(w1, w2, y)':", fixed = TRUE @@ -662,7 +667,7 @@ make_standata(y ~ (mmc(w1, w2)*y|mm(g1,g2)), data = dat), "The term 'mmc(w1, w2):y' is invalid", fixed = TRUE ) - + # tests if ":" works in multi-membership models sdata <- make_standata(y ~ (1|mm(w1:g1,w1:g2)), dat) expect_true(all(c("J_1_1", "J_1_2") %in% names(sdata))) @@ -685,11 +690,11 @@ sdata <- make_standata(y ~ x + (x | gr(g, by = z)), dat) expect_equal(sdata$Nby_1, 5) expect_equal(sdata$Jby_1, as.array(c(2, 2, 1, 1, 5, 4, 4, 5, 3, 3))) - + sdata <- make_standata(y ~ x + (x | mm(g, g2, by = cbind(z, z2))), dat) expect_equal(sdata$Nby_1, 5) expect_equal(sdata$Jby_1, as.array(c(2, 2, 1, 1, 5, 4, 4, 5, 3, 3))) - + expect_error(make_standata(y ~ x + (1|gr(g, by = z3)), dat), "Some levels of 'g' correspond to multiple levels of 'z3'") }) @@ -710,16 +715,16 @@ test_that("Cell-mean coding can be disabled", { df <- data.frame(y = 1:10, g = rep(c("a", "b"), 5)) - bform <- bf(y ~ g) + - lf(disc ~ 0 + g + (0 + g | y), cmc = FALSE) + + bform <- bf(y ~ g) + + lf(disc ~ 0 + g + (0 + g | y), cmc = FALSE) + cumulative() - + sdata <- make_standata(bform, df) target <- matrix(rep(0:1, 5), dimnames = list(1:10, "gb")) expect_equal(sdata$X_disc, target) expect_equal(unname(sdata$Z_1_disc_1), as.array(rep(0:1, 5))) expect_true(!"Z_1_disc_2" %in% names(sdata)) - + bform <- bf(y ~ 0 + g + (1 | y), cmc = FALSE) sdata <- make_standata(bform, df) expect_equal(sdata$X, target) @@ -742,11 +747,11 @@ expect_equal(sdata$con_theta, as.array(c(1, 1))) expect_equal(dim(sdata$X_mu1), c(10, 1)) expect_equal(dim(sdata$X_mu2), c(10, 2)) - + form <- bf(y ~ x, family = mixture(gaussian, gaussian)) sdata <- make_standata(form, data, prior = prior(dirichlet(10, 2), theta)) expect_equal(sdata$con_theta, as.array(c(10, 2))) - + form <- bf(y ~ x, theta1 = 1, theta2 = 3, family = mixture(gaussian, gaussian)) sdata <- make_standata(form, data) expect_equal(sdata$theta1, 1/4) @@ -757,15 +762,15 @@ dat <- data.frame(y = rnorm(10), x1 = rnorm(10), z = factor(c(2, 2, 2, 3, 4, rep(5, 5)))) sdata <- make_standata(y ~ gp(x1), dat) - expect_equal(max(sdata$Xgp_1) - min(sdata$Xgp_1), 1) + expect_equal(max(sdata$Xgp_1) - min(sdata$Xgp_1), 1) sdata <- make_standata(y ~ gp(x1, scale = FALSE), dat) expect_equal(max(sdata$Xgp_1) - min(sdata$Xgp_1), max(dat$x1) - min(dat$x1)) - + sdata <- SW(make_standata(y ~ gp(x1, by = z, gr = TRUE, scale = FALSE), dat)) expect_equal(sdata$Igp_1_2, as.array(4)) expect_equal(sdata$Jgp_1_4, as.array(1:5)) expect_equal(sdata$Igp_1_4, as.array(6:10)) - + sdata <- SW(make_standata(y ~ gp(x1, by = y, gr = TRUE), dat)) expect_equal(sdata$Cgp_1, as.array(dat$y)) }) @@ -773,12 +778,12 @@ test_that("make_standata includes data for approximate Gaussian processes", { dat <- data.frame(y = rnorm(10), x1 = sample(1:10, 10), z = factor(c(2, 2, 2, 3, 4, rep(5, 5)))) - + sdata <- make_standata(y ~ gp(x1, k = 5, c = 5/4), dat) expect_equal(sdata$NBgp_1, 5) expect_equal(dim(sdata$Xgp_1), c(10, 5)) expect_equal(dim(sdata$slambda_1), c(5, 1)) - + sdata <- SW(make_standata(y ~ gp(x1, by = z, k = 5, c = 5/4, scale = FALSE), dat)) expect_equal(sdata$Igp_1_2, as.array(4)) expect_equal(sdata$Cgp_1_2, as.array(1)) @@ -789,10 +794,10 @@ dat <- data.frame(y = rnorm(10), x = rnorm(10)) W <- matrix(0, nrow = 10, ncol = 10) dat2 <- list(W = W) - + sdata <- make_standata(y ~ x + sar(W), data = dat, data2 = dat2) expect_equal(dim(sdata$M), rep(nrow(W), 2)) - + dat2 <- list(W = matrix(0, 2, 2)) expect_error( make_standata(y ~ x + sar(W), data = dat, data2 = dat2), @@ -805,39 +810,39 @@ edges <- cbind(1:10, 10:1) W <- matrix(0, nrow = 10, ncol = 10) for (i in seq_len(nrow(edges))) { - W[edges[i, 1], edges[i, 2]] <- 1 + W[edges[i, 1], edges[i, 2]] <- 1 } rownames(W) <- 1:nrow(W) dat2 <- list(W = W) - + sdata <- make_standata(y ~ x + car(W, gr = obs), dat, data2 = dat2) expect_equal(sdata$Nloc, 10) expect_equal(unname(sdata$Nneigh), rep(1, 10)) expect_equal(unname(sdata$edges1), as.array(10:6)) expect_equal(unname(sdata$edges2), as.array(1:5)) - + sdata_old <- SW(make_standata(y ~ x, dat, autocor = cor_car(W))) expect_equal(sdata, sdata_old) - + rownames(dat2$W) <- c("a", 2:9, "b") dat$group <- rep(c("a", "b"), each = 5) sdata <- make_standata(y ~ x + car(W, gr = group), dat, data2 = dat2) expect_equal(sdata$Nloc, 2) expect_equal(sdata$edges1, as.array(2)) expect_equal(sdata$edges2, as.array(1)) - - sdata <- make_standata(y ~ x + car(W, group, type = "bym2"), + + sdata <- make_standata(y ~ x + car(W, group, type = "bym2"), data = dat, data2 = dat2) expect_equal(length(sdata$car_scale), 1L) - + dat2$W[1, 10] <- 4 dat2$W[10, 1] <- 4 - expect_message(make_standata(y ~ car(W, gr = group), dat, data2 = dat2), + expect_message(make_standata(y ~ car(W, gr = group), dat, data2 = dat2), "Converting all non-zero values in 'M' to 1") - + # test error messages rownames(dat2$W) <- c(1:9, "a") - expect_error(make_standata(y ~ car(W, gr = group), dat, data2 = dat2), + expect_error(make_standata(y ~ car(W, gr = group), dat, data2 = dat2), "Row names of 'M' for CAR terms do not match") rownames(dat2$W) <- NULL expect_error(make_standata(y ~ car(W, gr = group), dat, data2 = dat2), @@ -852,35 +857,35 @@ test_that("make_standata includes data of special priors", { dat <- data.frame(y = 1:10, x1 = rnorm(10), x2 = rnorm(10)) - + # horseshoe prior hs <- horseshoe(7, scale_global = 2, df_global = 3, df_slab = 6, scale_slab = 3) - sdata <- make_standata(y ~ x1*x2, data = dat, + sdata <- make_standata(y ~ x1*x2, data = dat, prior = set_prior(hs)) expect_equal(sdata$hs_df, 7) expect_equal(sdata$hs_df_global, 3) expect_equal(sdata$hs_df_slab, 6) expect_equal(sdata$hs_scale_global, 2) expect_equal(sdata$hs_scale_slab, 3) - + hs <- horseshoe(par_ratio = 0.1) sdata <- make_standata(y ~ x1*x2, data = dat, prior = set_prior(hs)) expect_equal(sdata$hs_scale_global, 0.1 / sqrt(nrow(dat))) - + # R2D2 prior sdata <- make_standata(y ~ x1*x2, data = dat, prior = prior(R2D2(0.5, 10))) expect_equal(sdata$R2D2_mean_R2, 0.5) expect_equal(sdata$R2D2_prec_R2, 10) expect_equal(sdata$R2D2_cons_D2, as.array(rep(1, 3))) - + # lasso prior sdata <- make_standata(y ~ x1*x2, data = dat, prior = prior(lasso(2, scale = 10))) expect_equal(sdata$lasso_df, 2) expect_equal(sdata$lasso_scale, 10) - + # horseshoe and lasso prior applied in a non-linear model hs_a1 <- horseshoe(7, scale_global = 2, df_global = 3) lasso_a2 <- lasso(2, scale = 10) @@ -904,14 +909,14 @@ bprior <- prior(normal(mean_intercept, 10), class = "Intercept") mean_intercept <- 5 stanvars <- stanvar(mean_intercept) - sdata <- make_standata(count ~ Trt, data = epilepsy, + sdata <- make_standata(count ~ Trt, data = epilepsy, prior = bprior, stanvars = stanvars) expect_equal(sdata$mean_intercept, 5) - + # define a multi_normal prior with known covariance matrix bprior <- prior(multi_normal(M, V), class = "b") stanvars <- stanvar(rep(0, 2), "M", scode = " vector[K] M;") + - stanvar(diag(2), "V", scode = " matrix[K, K] V;") + stanvar(diag(2), "V", scode = " matrix[K, K] V;") sdata <- make_standata(count ~ Trt + zBase, epilepsy, prior = bprior, stanvars = stanvars) expect_equal(sdata$M, rep(0, 2)) @@ -923,14 +928,14 @@ beta_binomial2 <- custom_family( "beta_binomial2", dpars = c("mu", "tau"), - links = c("logit", "log"), + links = c("logit", "log"), lb = c(NA, 0), - type = "int", + type = "int", vars = c("vint1[n]", "vreal1[n]") ) sdata <- make_standata( - y | vint(size) + vreal(x, size) ~ 1, - data = dat, family = beta_binomial2, + y | vint(size) + vreal(x, size) ~ 1, + data = dat, family = beta_binomial2, ) expect_equal(sdata$vint1, as.array(rep(10, 20))) expect_equal(sdata$vreal1, as.array(dat$x)) @@ -959,22 +964,22 @@ dat$y <- with(dat, cbind(y1, y2, y3)) dat$t <- with(dat, cbind(t1, t2, t3)) dat$size <- rowSums(dat$t) - + sdata <- make_standata(t | trials(size) ~ x, dat, multinomial()) expect_equal(sdata$trials, as.array(dat$size)) expect_equal(sdata$ncat, 3) expect_equal(sdata$Y, unname(dat$t)) - + sdata <- make_standata(y ~ x, data = dat, family = dirichlet()) expect_equal(sdata$ncat, 3) expect_equal(sdata$Y, unname(dat$y)) - + expect_error( make_standata(t | trials(10) ~ x, data = dat, family = multinomial()), "Number of trials does not match the number of events" ) expect_error(make_standata(t ~ x, data = dat, family = dirichlet()), - "Response values in dirichlet models must sum to 1") + "Response values in simplex models must sum to 1") }) test_that("make_standata handles cox models correctly", { @@ -985,7 +990,7 @@ expect_equal(dim(sdata$Zbhaz), c(100, 5)) expect_equal(dim(sdata$Zcbhaz), c(100, 5)) expect_equal(sdata$con_sbhaz, as.array(rep(3, 5))) - + sdata <- make_standata(bform, data, brmsfamily("cox", bhaz = list(df = 6))) expect_equal(dim(sdata$Zbhaz), c(100, 6)) expect_equal(dim(sdata$Zcbhaz), c(100, 6)) @@ -1004,30 +1009,30 @@ th = rep(5:6, each = 5), x = rnorm(10) ) - + # thresholds without a grouping factor sdata <- make_standata(y ~ x, dat, cumulative()) expect_equal(sdata$nthres, 4) - + sdata <- make_standata(y | thres(5) ~ x, dat, cumulative()) expect_equal(sdata$nthres, 5) - + expect_error( make_standata(y | thres(th) ~ x, dat, cumulative()), "Number of thresholds needs to be a single value" ) - + # thresholds with a grouping factor sdata <- make_standata(y | thres(th, gr) ~ x, dat, cumulative()) expect_equal(sdata$nthres, as.array(c(5, 6))) expect_equal(sdata$ngrthres, 2) expect_equal(unname(sdata$Jthres[1, ]), c(1, 5)) expect_equal(unname(sdata$Jthres[10, ]), c(6, 11)) - + sdata <- make_standata(y | thres(gr = gr) ~ x, dat, cumulative()) expect_equal(sdata$nthres, as.array(c(4, 3))) expect_equal(sdata$ngrthres, 2) - + sdata <- make_standata(y | thres(6, gr = gr) ~ x, dat, cumulative()) expect_equal(sdata$nthres, as.array(c(6, 6))) expect_equal(sdata$ngrthres, 2) @@ -1048,7 +1053,7 @@ } out } - sdata <- make_standata(y ~ foo(x1, x2, x3, idx = id), data = dat, + sdata <- make_standata(y ~ foo(x1, x2, x3, idx = id), data = dat, data2 = list(id = c(3, 1))) target <- c("Intercept", "foox1x2x3idxEQidx3", "foox1x2x3idxEQidx1") expect_equal(colnames(sdata$X), target) @@ -1063,7 +1068,7 @@ sdata <- make_standata(y | cens(ce, y2 = y2) ~ 1, data = dat) expect_equal(sdata$N, 10L) expect_equal(sdata$rcens[1], 0) - + dat$ce[1] <- 2 expect_error( make_standata(y | cens(ce, y2 = y2) ~ 1, data = dat), diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.misc.R r-cran-brms-2.17.0/tests/testthat/tests.misc.R --- r-cran-brms-2.16.3/tests/testthat/tests.misc.R 2020-10-08 07:00:48.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.misc.R 2022-03-13 16:10:29.000000000 +0000 @@ -5,8 +5,8 @@ x <- rnorm(10) expect_equal(p(x, i = 3), x[3]) A <- matrix(x, nrow = 5) - expect_equal(p(A, i = 3), A[3, , drop = FALSE]) - expect_equal(p(A, i = 2, row = FALSE), A[, 2, drop = FALSE]) + expect_equal(p(A, i = 3), A[3, , drop = FALSE]) + expect_equal(p(A, i = 2, row = FALSE), A[, 2, drop = FALSE]) }) test_that("rmNULL removes all NULL entries", { @@ -18,20 +18,20 @@ test_that("rename returns an error on duplicated names", { expect_error(rename(c(letters[1:4],"a()","a["), check_dup = TRUE), fixed = TRUE, - paste("Internal renaming led to duplicated names.", + paste("Internal renaming led to duplicated names.", "\nOccured for: 'a', 'a()', 'a['")) expect_error(rename(c("aDb","a/b","b"), check_dup = TRUE), fixed = TRUE, - paste("Internal renaming led to duplicated names.", + paste("Internal renaming led to duplicated names.", "\nOccured for: 'aDb', 'a/b'")) expect_error(rename(c("log(a,b)","logab","bac","ba"), check_dup = TRUE), fixed = TRUE, - paste("Internal renaming led to duplicated names.", + paste("Internal renaming led to duplicated names.", "\nOccured for: 'log(a,b)', 'logab'")) }) test_that("rename perform correct renaming", { names <- c("acd", "a[23]", "b__") expect_equal( - rename(names, c("[", "]", "__"), c(".", ".", ":")), + rename(names, c("[", "]", "__"), c(".", ".", ":")), c("acd", "a.23.", "b:") ) expect_equal( @@ -44,11 +44,11 @@ x <- list(a = "a <- ", b = "b <- ") y <- list(b = "cauchy(1,2)", c = "normal(0,1)", a = "gamma(1,1)") expect_equal(collapse_lists(list()), list()) - expect_equal(collapse_lists(x, y), - list(a = "a <- gamma(1,1)", b = "b <- cauchy(1,2)", + expect_equal(collapse_lists(x, y), + list(a = "a <- gamma(1,1)", b = "b <- cauchy(1,2)", c = "normal(0,1)")) expect_equal(collapse_lists(ls = list(c(x, c = "c <- "), y)), - list(a = "a <- gamma(1,1)", b = "b <- cauchy(1,2)", + list(a = "a <- gamma(1,1)", b = "b <- cauchy(1,2)", c = "c <- normal(0,1)")) }) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.posterior_epred.R r-cran-brms-2.17.0/tests/testthat/tests.posterior_epred.R --- r-cran-brms-2.16.3/tests/testthat/tests.posterior_epred.R 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.posterior_epred.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,211 +1,225 @@ -context("Tests for posterior_epred helper functions") - -# to reduce testing time on CRAN -skip_on_cran() - -test_that("posterior_epred helper functions run without errors", { - # actually run posterior_epred.brmsfit that call the helper functions - fit <- brms:::rename_pars(brms:::brmsfit_example1) - add_dummy_draws <- brms:::add_dummy_draws - fit <- add_dummy_draws(fit, "shape", dist = "exp") - fit <- add_dummy_draws(fit, "alpha", dist = "norm") - fit <- add_dummy_draws(fit, "hu", dist = "beta", shape1 = 1, shape2 = 1) - fit <- add_dummy_draws(fit, "zi", dist = "beta", shape1 = 1, shape2 = 1) - fit <- add_dummy_draws(fit, "quantile", dist = "beta", shape1 = 2, shape2 = 1) - fit <- add_dummy_draws(fit, "xi", dist = "unif", min = -1, max = 0.5) - fit <- add_dummy_draws(fit, "ndt", dist = "exp") - fit$formula$formula <- update(fit$formula$formula, .~. - arma(visit, patient)) - prep <- brms:::prepare_predictions(fit) - prep$dpars$mu <- brms:::get_dpar(prep, "mu") - prep$dpars$sigma <- brms:::get_dpar(prep, "sigma") - prep$dpars$nu <- brms:::get_dpar(prep, "nu") - ndraws <- ndraws(fit) - nobs <- nobs(fit) - - # test preparation of truncated models - prep$data$lb <- 0 - prep$data$ub <- 200 - mu <- brms:::posterior_epred_trunc(prep) - expect_equal(dim(mu), c(ndraws, nobs)) - - # pseudo log-normal model - fit$family <- fit$formula$family <- lognormal() - expect_equal(dim(posterior_epred(fit, summary = FALSE)), - c(ndraws, nobs)) - - # pseudo shifted log-normal model - fit$family <- fit$formula$family <- shifted_lognormal() - expect_equal(dim(posterior_epred(fit, summary = FALSE)), - c(ndraws, nobs)) - - # pseudo skew-normal model - fit$family <- fit$formula$family <- skew_normal() - expect_equal(dim(posterior_epred(fit, summary = FALSE)), - c(ndraws, nobs)) - - # pseudo asym_laplace model - fit$family <- fit$formula$family <- asym_laplace() - expect_equal(dim(posterior_epred(fit, summary = FALSE)), - c(ndraws, nobs)) - - # pseudo zero_inflated_asym_laplace model - fit$family <- fit$formula$family <- brmsfamily("zero_inflated_asym_laplace") - expect_equal(dim(posterior_epred(fit, summary = FALSE)), - c(ndraws, nobs)) - - # pseudo gen_extreme_value model - fit$family <- fit$formula$family <- gen_extreme_value() - expect_equal(dim(posterior_epred(fit, summary = FALSE)), - c(ndraws, nobs)) - - # pseudo weibull model - fit$formula$pforms <- NULL - fit$family <- fit$formula$family <- weibull() - expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) - - # pseudo binomial model - fit$autocor <- brms:::cor_empty() - fit$family <- fit$formula$family <- binomial() - expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) - - # pseudo hurdle poisson model - fit$family <- fit$formula$family <- hurdle_poisson() - fit$formula <- bf(count ~ Trt*Age + mo(Exp) + offset(Age) + (1+Trt|visit), - family = family(fit)) - expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) - - # pseudo zero-inflated poisson model - fit$family <- fit$formula$family <- zero_inflated_poisson() - expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) - - # pseudo custom model - posterior_epred_test <- function(prep) { - prep$dpars$mu - } - fit$family <- fit$formula$family <- custom_family( - "test", dpars = "mu", links = c("logit"), - type = "int", vars = "trials[n]" - ) - expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) - - # truncated continuous models - prep$dpars$shape <- c(as.matrix(fit, variable = "shape")) - mu <- brms:::posterior_epred_trunc_gaussian(prep, lb = 0, ub = 10) - expect_equal(dim(mu), c(ndraws, nobs)) - - mu <- brms:::posterior_epred_trunc_student(prep, lb = -Inf, ub = 15) - expect_equal(dim(mu), c(ndraws, nobs)) - - mu <- brms:::posterior_epred_trunc_lognormal(prep, lb = 2, ub = 15) - expect_equal(dim(mu), c(ndraws, nobs)) - - prep$dpars$mu <- exp(prep$dpars$mu) - mu <- brms:::posterior_epred_trunc_gamma(prep, lb = 1, ub = 7) - expect_equal(dim(mu), c(ndraws, nobs)) - - mu <- brms:::posterior_epred_trunc_exponential(prep, lb = 0, ub = Inf) - expect_equal(dim(mu), c(ndraws, nobs)) - - mu <- SW(brms:::posterior_epred_trunc_weibull(prep, lb = -Inf, ub = Inf)) - expect_equal(dim(mu), c(ndraws, nobs)) - - # truncated discrete models - data <- list(Y = sample(100, 10), trials = 1:10, N = 10) - lb <- matrix(0, nrow = ndraws, ncol = nobs) - ub <- matrix(100, nrow = ndraws, ncol = nobs) - mu <- brms:::posterior_epred_trunc_poisson(prep, lb = lb, ub = ub) - expect_equal(dim(mu), c(ndraws, nobs)) - - mu <- brms:::posterior_epred_trunc_negbinomial(prep, lb = lb, ub = ub) - expect_equal(dim(mu), c(ndraws, nobs)) - - mu <- brms:::posterior_epred_trunc_negbinomial2(prep, lb = lb, ub = ub) - expect_equal(dim(mu), c(ndraws, nobs)) - - mu <- brms:::posterior_epred_trunc_geometric(prep, lb = lb, ub = ub) - expect_equal(dim(mu), c(ndraws, nobs)) - - prep$data$trials <- 120 - lb <- matrix(-Inf, nrow = ndraws, ncol = nobs) - prep$dpars$mu <- brms:::ilink(prep$dpars$mu, "logit") - mu <- brms:::posterior_epred_trunc_binomial(prep, lb = lb, ub = ub) - expect_equal(dim(mu), c(ndraws, nobs)) -}) - -test_that("posterior_epred_lagsar runs without errors", { - prep <- list( - dpars = list(mu = matrix(rnorm(30), nrow = 3)), - ac = list( - lagsar = matrix(c(0.3, 0.5, 0.7)), - Msar = matrix(1:100, 10, 10) - ), - ndraws = 3, - nobs = 10, - family = gaussian() - ) - mu_new <- brms:::posterior_epred_lagsar(prep) - expect_equal(dim(mu_new), dim(prep$dpars$mu)) - expect_true(!identical(mu_new, prep$dpars$mu)) -}) - -test_that("posterior_epred for advanced count data distributions runs without errors", { - ns <- 15 - nobs <- 5 - ncat <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = array(rbeta(ns*nobs, 2, 2), dim = c(ns, nobs)), - shape = array(rexp(ns*nobs, 3), dim = c(ns, nobs)) - ) - prep$family <- brmsfamily("discrete_weibull") - pred <- suppressWarnings(brms:::posterior_epred_discrete_weibull(prep)) - expect_equal(dim(pred), c(ns, nobs)) - - prep$family <- brmsfamily("com_poisson") - pred <- suppressWarnings(brms:::posterior_epred_com_poisson(prep)) - expect_equal(dim(pred), c(ns, nobs)) -}) - -test_that("posterior_epred for multinomial and dirichlet models runs without errors", { - ns <- 15 - nobs <- 8 - ncat <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu1 = array(rnorm(ns*nobs), dim = c(ns, nobs)), - mu2 = array(rnorm(ns*nobs), dim = c(ns, nobs)) - ) - prep$data <- list(ncat = ncat, trials = sample(1:20, nobs)) - - prep$family <- multinomial() - pred <- brms:::posterior_epred_multinomial(prep = prep) - expect_equal(dim(pred), c(ns, nobs, ncat)) - - prep$family <- dirichlet() - pred <- brms:::posterior_epred_dirichlet(prep = prep) - expect_equal(dim(pred), c(ns, nobs, ncat)) - - prep$family <- brmsfamily("dirichlet2") - prep$dpars$mu1 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) - prep$dpars$mu2 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) - prep$dpars$mu3 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) - pred <- brms:::posterior_epred_dirichlet2(prep = prep) - expect_equal(dim(pred), c(ns, nobs, ncat)) -}) - -test_that("posterior_epred() can be reproduced by using d()", { - fit4 <- rename_pars(brms:::brmsfit_example4) - epred4 <- posterior_epred(fit4) - - eta4 <- posterior_linpred(fit4) - bprep4 <- prepare_predictions(fit4) - thres4 <- bprep4$thres$thres - disc4 <- bprep4$dpars$disc$fe$b %*% t(bprep4$dpars$disc$fe$X) - disc4 <- exp(disc4) - epred4_ch <- aperm(sapply(seq_len(dim(eta4)[2]), function(i) { - dsratio(seq_len(ncol(thres4) + 1), eta4[, i, ], thres4, disc4[, i]) - }, simplify = "array"), perm = c(1, 3, 2)) - - expect_equivalent(epred4, epred4_ch) -}) - +context("Tests for posterior_epred helper functions") + +# to reduce testing time on CRAN +skip_on_cran() + +test_that("posterior_epred helper functions run without errors", { + # actually run posterior_epred.brmsfit that call the helper functions + fit <- brms:::rename_pars(brms:::brmsfit_example1) + add_dummy_draws <- brms:::add_dummy_draws + fit <- add_dummy_draws(fit, "shape", dist = "exp") + fit <- add_dummy_draws(fit, "alpha", dist = "norm") + fit <- add_dummy_draws(fit, "hu", dist = "beta", shape1 = 1, shape2 = 1) + fit <- add_dummy_draws(fit, "phi", dist = "beta", shape1 = 1, shape2 = 1) + fit <- add_dummy_draws(fit, "zi", dist = "beta", shape1 = 1, shape2 = 1) + fit <- add_dummy_draws(fit, "quantile", dist = "beta", shape1 = 2, shape2 = 1) + fit <- add_dummy_draws(fit, "xi", dist = "unif", min = -1, max = 0.5) + fit <- add_dummy_draws(fit, "ndt", dist = "exp") + fit$formula$formula <- update(fit$formula$formula, .~. - arma(visit, patient)) + prep <- brms:::prepare_predictions(fit) + prep$dpars$mu <- brms:::get_dpar(prep, "mu") + prep$dpars$sigma <- brms:::get_dpar(prep, "sigma") + prep$dpars$nu <- brms:::get_dpar(prep, "nu") + ndraws <- ndraws(fit) + nobs <- nobs(fit) + + # test preparation of truncated models + prep$data$lb <- 0 + prep$data$ub <- 200 + mu <- brms:::posterior_epred_trunc(prep) + expect_equal(dim(mu), c(ndraws, nobs)) + + # pseudo log-normal model + fit$family <- fit$formula$family <- lognormal() + expect_equal(dim(posterior_epred(fit, summary = FALSE)), + c(ndraws, nobs)) + + # pseudo shifted log-normal model + fit$family <- fit$formula$family <- shifted_lognormal() + expect_equal(dim(posterior_epred(fit, summary = FALSE)), + c(ndraws, nobs)) + + # pseudo skew-normal model + fit$family <- fit$formula$family <- skew_normal() + expect_equal(dim(posterior_epred(fit, summary = FALSE)), + c(ndraws, nobs)) + + # pseudo asym_laplace model + fit$family <- fit$formula$family <- asym_laplace() + expect_equal(dim(posterior_epred(fit, summary = FALSE)), + c(ndraws, nobs)) + + # pseudo zero_inflated_asym_laplace model + fit$family <- fit$formula$family <- brmsfamily("zero_inflated_asym_laplace") + expect_equal(dim(posterior_epred(fit, summary = FALSE)), + c(ndraws, nobs)) + + # pseudo gen_extreme_value model + fit$family <- fit$formula$family <- gen_extreme_value() + expect_equal(dim(posterior_epred(fit, summary = FALSE)), + c(ndraws, nobs)) + + # pseudo weibull model + fit$formula$pforms <- NULL + fit$family <- fit$formula$family <- weibull() + expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) + + # pseudo binomial model + fit$autocor <- brms:::cor_empty() + fit$family <- fit$formula$family <- binomial() + expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) + + # pseudo beta-binomial model + fit$family <- fit$formula$family <- beta_binomial() + expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) + + # pseudo zero inflated binomial model + fit$family <- fit$formula$family <- zero_inflated_binomial() + expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) + + # pseudo zero inflated beta binomial model + fit$family <- fit$formula$family <- zero_inflated_beta_binomial() + expect_equal(dim(SW(posterior_epred(fit, summary = FALSE))), c(ndraws, nobs)) + + # pseudo hurdle poisson model + fit$family <- fit$formula$family <- hurdle_poisson() + fit$formula <- bf(count ~ Trt*Age + mo(Exp) + offset(Age) + (1+Trt|visit), + family = family(fit)) + expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) + + # pseudo zero-inflated poisson model + fit$family <- fit$formula$family <- zero_inflated_poisson() + expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) + + # pseudo custom model + posterior_epred_test <- function(prep) { + prep$dpars$mu + } + fit$family <- fit$formula$family <- custom_family( + "test", dpars = "mu", links = c("logit"), + type = "int", vars = "trials[n]" + ) + expect_equal(dim(posterior_epred(fit, summary = FALSE)), c(ndraws, nobs)) + + # truncated continuous models + prep$dpars$shape <- c(as.matrix(fit, variable = "shape")) + mu <- brms:::posterior_epred_trunc_gaussian(prep, lb = 0, ub = 10) + expect_equal(dim(mu), c(ndraws, nobs)) + + mu <- brms:::posterior_epred_trunc_student(prep, lb = -Inf, ub = 15) + expect_equal(dim(mu), c(ndraws, nobs)) + + mu <- brms:::posterior_epred_trunc_lognormal(prep, lb = 2, ub = 15) + expect_equal(dim(mu), c(ndraws, nobs)) + + prep$dpars$mu <- exp(prep$dpars$mu) + mu <- brms:::posterior_epred_trunc_gamma(prep, lb = 1, ub = 7) + expect_equal(dim(mu), c(ndraws, nobs)) + + mu <- brms:::posterior_epred_trunc_exponential(prep, lb = 0, ub = Inf) + expect_equal(dim(mu), c(ndraws, nobs)) + + mu <- SW(brms:::posterior_epred_trunc_weibull(prep, lb = -Inf, ub = Inf)) + expect_equal(dim(mu), c(ndraws, nobs)) + + # truncated discrete models + data <- list(Y = sample(100, 10), trials = 1:10, N = 10) + lb <- matrix(0, nrow = ndraws, ncol = nobs) + ub <- matrix(100, nrow = ndraws, ncol = nobs) + mu <- brms:::posterior_epred_trunc_poisson(prep, lb = lb, ub = ub) + expect_equal(dim(mu), c(ndraws, nobs)) + + mu <- brms:::posterior_epred_trunc_negbinomial(prep, lb = lb, ub = ub) + expect_equal(dim(mu), c(ndraws, nobs)) + + mu <- brms:::posterior_epred_trunc_negbinomial2(prep, lb = lb, ub = ub) + expect_equal(dim(mu), c(ndraws, nobs)) + + mu <- brms:::posterior_epred_trunc_geometric(prep, lb = lb, ub = ub) + expect_equal(dim(mu), c(ndraws, nobs)) + + prep$data$trials <- 120 + lb <- matrix(-Inf, nrow = ndraws, ncol = nobs) + prep$dpars$mu <- brms:::inv_link(prep$dpars$mu, "logit") + mu <- brms:::posterior_epred_trunc_binomial(prep, lb = lb, ub = ub) + expect_equal(dim(mu), c(ndraws, nobs)) +}) + +test_that("posterior_epred_lagsar runs without errors", { + prep <- list( + dpars = list(mu = matrix(rnorm(30), nrow = 3)), + ac = list( + lagsar = matrix(c(0.3, 0.5, 0.7)), + Msar = matrix(1:100, 10, 10) + ), + ndraws = 3, + nobs = 10, + family = gaussian() + ) + mu_new <- brms:::posterior_epred_lagsar(prep) + expect_equal(dim(mu_new), dim(prep$dpars$mu)) + expect_true(!identical(mu_new, prep$dpars$mu)) +}) + +test_that("posterior_epred for advanced count data distributions runs without errors", { + ns <- 15 + nobs <- 5 + ncat <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = array(rbeta(ns*nobs, 2, 2), dim = c(ns, nobs)), + shape = array(rexp(ns*nobs, 3), dim = c(ns, nobs)) + ) + prep$family <- brmsfamily("discrete_weibull") + pred <- suppressWarnings(brms:::posterior_epred_discrete_weibull(prep)) + expect_equal(dim(pred), c(ns, nobs)) + + prep$family <- brmsfamily("com_poisson") + pred <- suppressWarnings(brms:::posterior_epred_com_poisson(prep)) + expect_equal(dim(pred), c(ns, nobs)) +}) + +test_that("posterior_epred for multinomial and dirichlet models runs without errors", { + ns <- 15 + nobs <- 8 + ncat <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu1 = array(rnorm(ns*nobs), dim = c(ns, nobs)), + mu2 = array(rnorm(ns*nobs), dim = c(ns, nobs)) + ) + prep$data <- list(ncat = ncat, trials = sample(1:20, nobs)) + prep$refcat <- 1 + + prep$family <- multinomial() + pred <- brms:::posterior_epred_multinomial(prep = prep) + expect_equal(dim(pred), c(ns, nobs, ncat)) + + prep$family <- dirichlet() + pred <- brms:::posterior_epred_dirichlet(prep = prep) + expect_equal(dim(pred), c(ns, nobs, ncat)) + + prep$family <- brmsfamily("dirichlet2") + prep$dpars$mu1 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) + prep$dpars$mu2 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) + prep$dpars$mu3 <- array(rexp(ns*nobs, 1), dim = c(ns, nobs)) + pred <- brms:::posterior_epred_dirichlet2(prep = prep) + expect_equal(dim(pred), c(ns, nobs, ncat)) +}) + +test_that("posterior_epred() can be reproduced by using d()", { + fit4 <- rename_pars(brms:::brmsfit_example4) + epred4 <- posterior_epred(fit4) + + eta4 <- posterior_linpred(fit4) + bprep4 <- prepare_predictions(fit4) + thres4 <- bprep4$thres$thres + disc4 <- bprep4$dpars$disc$fe$b %*% t(bprep4$dpars$disc$fe$X) + disc4 <- exp(disc4) + epred4_ch <- aperm(sapply(seq_len(dim(eta4)[2]), function(i) { + dsratio(seq_len(ncol(thres4) + 1), eta4[, i, ], thres4, disc4[, i]) + }, simplify = "array"), perm = c(1, 3, 2)) + + expect_equivalent(epred4, epred4_ch) +}) + diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.posterior_predict.R r-cran-brms-2.17.0/tests/testthat/tests.posterior_predict.R --- r-cran-brms-2.16.3/tests/testthat/tests.posterior_predict.R 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.posterior_predict.R 2022-04-08 12:23:23.000000000 +0000 @@ -1,390 +1,410 @@ -context("Tests for posterior_predict helper functions") - -test_that("posterior_predict for location shift models runs without errors", { - ns <- 30 - nobs <- 10 - prep <- structure(list(ndraws = ns), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rchisq(ns, 3), nu = rgamma(ns, 4) - ) - i <- sample(nobs, 1) - - pred <- brms:::posterior_predict_gaussian(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_student(i, prep = prep) - expect_equal(length(pred), ns) -}) - -test_that("posterior_predict for various skewed models runs without errors", { - ns <- 50 - nobs <- 2 - prep <- structure(list(ndraws = ns), class = "brmsprep") - prep$dpars <- list( - sigma = rchisq(ns, 3), beta = rchisq(ns, 3), - mu = matrix(rnorm(ns * nobs), ncol = nobs), - alpha = rnorm(ns), ndt = 1 - ) - pred <- brms:::posterior_predict_lognormal(1, prep = prep) - expect_equal(length(pred), ns) - pred <- brms:::posterior_predict_shifted_lognormal(1, prep = prep) - expect_equal(length(pred), ns) - pred <- brms:::posterior_predict_exgaussian(1, prep = prep) - expect_equal(length(pred), ns) - pred <- brms:::posterior_predict_skew_normal(1, prep = prep) - expect_equal(length(pred), ns) -}) - -test_that("posterior_predict for aysm_laplace models runs without errors", { - ns <- 50 - prep <- structure(list(ndraws = ns), class = "brmsprep") - prep$dpars <- list( - sigma = rchisq(ns, 3), - quantile = rbeta(ns, 2, 1), - mu = matrix(rnorm(ns*2), ncol = 2), - zi = rbeta(ns, 10, 10) - ) - pred <- brms:::posterior_predict_asym_laplace(1, prep = prep) - expect_equal(length(pred), ns) - pred <- brms:::posterior_predict_zero_inflated_asym_laplace(1, prep = prep) - expect_equal(length(pred), ns) -}) - -test_that("posterior_predict for multivariate linear models runs without errors", { - ns <- 10 - nvars <- 3 - ncols <- 4 - nobs <- nvars * ncols - Sigma = array(cov(matrix(rnorm(300), ncol = 3)), dim = c(3, 3, 10)) - prep <- structure(list(ndraws = ns), class = "mvbrmsprep") - prep$mvpars <- list( - Mu = array(rnorm(ns*nobs*nvars), dim = c(ns, nobs, nvars)), - Sigma = aperm(Sigma, c(3, 1, 2)) - ) - prep$dpars <- list(nu = rgamma(ns, 5)) - prep$data <- list(N = nobs, N_trait = ncols) - - pred <- brms:::posterior_predict_gaussian_mv(1, prep = prep) - expect_equal(dim(pred), c(ns, nvars)) - - pred <- brms:::posterior_predict_student_mv(2, prep = prep) - expect_equal(dim(pred), c(ns, nvars)) -}) - -test_that("posterior_predict for ARMA covariance models runs without errors", { - ns <- 20 - nobs <- 15 - prep <- structure(list(ndraws = ns), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns*nobs), ncol = nobs), - sigma = rchisq(ns, 3), - nu = rgamma(ns, 5) - ) - prep$ac <- list( - ar = matrix(rbeta(ns, 0.5, 0.5), ncol = 1), - ma = matrix(rnorm(ns, 0.2, 1), ncol = 1), - begin_tg = c(1, 5, 12), end_tg = c(4, 11, 15) - ) - prep$data <- list(se = rgamma(ns, 10)) - - prep$family$fun <- "gaussian_time" - pred <- brms:::posterior_predict_gaussian_time(1, prep = prep) - expect_equal(length(pred), ns * 4) - - prep$family$fun <- "student_time" - pred <- brms:::posterior_predict_student_time(2, prep = prep) - expect_equal(length(pred), ns * 7) -}) - -test_that("loglik for SAR models runs without errors", { - ns = 3 - prep <- structure(list(ndraws = ns, nobs = 10), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(30), nrow = ns), - nu = rep(2, ns), - sigma = rep(10, ns) - ) - prep$ac <- list(lagsar = matrix(c(0.3, 0.5, 0.7)), Msar = diag(10)) - - pred <- brms:::posterior_predict_gaussian_lagsar(1, prep = prep) - expect_equal(dim(pred), c(3, 10)) - pred <- brms:::posterior_predict_student_lagsar(1, prep = prep) - expect_equal(dim(pred), c(3, 10)) - - prep$ac$errorsar <- prep$ac$lagsar - prep$ac$lagsar <- NULL - pred <- brms:::posterior_predict_gaussian_errorsar(1, prep = prep) - expect_equal(dim(pred), c(3, 10)) - pred <- brms:::posterior_predict_student_errorsar(1, prep = prep) - expect_equal(dim(pred), c(3, 10)) -}) - -test_that("posterior_predict for FCOR models runs without errors", { - ns <- 3 - nobs <- 10 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(nobs * ns), nrow = ns), - sigma = rep(1, ns), nu = rep(2, ns) - ) - prep$ac <- list(Mfcor = diag(nobs)) - pred <- brms:::posterior_predict_gaussian_fcor(1, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) - pred <- brms:::posterior_predict_student_fcor(1, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) -}) - -test_that("posterior_predict for count and survival models runs without errors", { - ns <- 25 - nobs <- 10 - trials <- sample(10:30, nobs, replace = TRUE) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - eta = matrix(rnorm(ns*nobs), ncol = nobs), - shape = rgamma(ns, 4), xi = 0 - ) - prep$dpars$nu <- prep$dpars$sigma <- prep$dpars$shape + 1 - prep$data <- list(trials = trials) - i <- sample(nobs, 1) - - prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) - pred <- brms:::posterior_predict_binomial(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_discrete_weibull(i, prep = prep) - expect_equal(length(pred), ns) - - prep$dpars$mu <- exp(prep$dpars$eta) - pred <- brms:::posterior_predict_poisson(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_negbinomial(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_negbinomial2(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_geometric(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_com_poisson(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_exponential(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_gamma(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_frechet(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_inverse.gaussian(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_gen_extreme_value(i, prep = prep) - expect_equal(length(pred), ns) - - prep$family$link <- "log" - pred <- brms:::posterior_predict_weibull(i, prep = prep) - expect_equal(length(pred), ns) -}) - -test_that("posterior_predict for bernoulli and beta models works correctly", { - ns <- 17 - nobs <- 10 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = brms:::inv_logit(matrix(rnorm(ns * nobs * 2), ncol = 2 * nobs)), - phi = rgamma(ns, 4) - ) - i <- sample(1:nobs, 1) - - pred <- brms:::posterior_predict_bernoulli(i, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_beta(i, prep = prep) - expect_equal(length(pred), ns) -}) - -test_that("posterior_predict for circular models runs without errors", { - ns <- 15 - nobs <- 10 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = 2 * atan(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), - kappa = rgamma(ns, 4) - ) - i <- sample(seq_len(nobs), 1) - pred <- brms:::posterior_predict_von_mises(i, prep = prep) - expect_equal(length(pred), ns) -}) - -test_that("posterior_predict for zero-inflated and hurdle models runs without erros", { - ns <- 50 - nobs <- 8 - trials <- sample(10:30, nobs, replace = TRUE) - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - eta = matrix(rnorm(ns * nobs * 2), ncol = nobs * 2), - shape = rgamma(ns, 4), phi = rgamma(ns, 1), - zi = rbeta(ns, 1, 1), coi = rbeta(ns, 5, 7) - ) - prep$dpars$hu <- prep$dpars$zoi <- prep$dpars$zi - prep$data <- list(trials = trials) - - prep$dpars$mu <- exp(prep$dpars$eta) - pred <- brms:::posterior_predict_hurdle_poisson(1, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_hurdle_negbinomial(2, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_hurdle_gamma(5, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_zero_inflated_poisson(3, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_zero_inflated_negbinomial(6, prep = prep) - expect_equal(length(pred), ns) - - prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) - pred <- brms:::posterior_predict_zero_inflated_binomial(4, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_zero_inflated_beta(8, prep = prep) - expect_equal(length(pred), ns) - - pred <- brms:::posterior_predict_zero_one_inflated_beta(7, prep = prep) - expect_equal(length(pred), ns) -}) - -test_that("posterior_predict for ordinal models runs without erros", { - ns <- 50 - nobs <- 8 - nthres <- 3 - ncat <- nthres + 1 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = array(rnorm(ns * nobs), dim = c(ns, nobs)), - disc = rexp(ns) - ) - prep$thres$thres <- array(0, dim = c(ns, nthres)) - prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) - prep$family$link <- "logit" - - prep$family$family <- "cumulative" - pred <- sapply(1:nobs, brms:::posterior_predict_cumulative, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) - - prep$family$family <- "sratio" - pred <- sapply(1:nobs, brms:::posterior_predict_sratio, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) - - prep$family$family <- "cratio" - pred <- sapply(1:nobs, brms:::posterior_predict_cratio, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) - - prep$family$family <- "acat" - pred <- sapply(1:nobs, brms:::posterior_predict_acat, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) - - prep$family$link <- "probit" - pred <- sapply(1:nobs, brms:::posterior_predict_acat, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) -}) - -test_that("posterior_predict for categorical and related models runs without erros", { - set.seed(1234) - ns <- 50 - nobs <- 8 - ncat <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu1 = array(rnorm(ns*nobs, 0, 0.1), dim = c(ns, nobs)), - mu2 = array(rnorm(ns*nobs, 0, 0.1), dim = c(ns, nobs)) - ) - prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) - prep$family <- categorical() - pred <- sapply(1:nobs, brms:::posterior_predict_categorical, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) - - prep$data$trials <- sample(1:20, nobs) - prep$family <- multinomial() - pred <- brms:::posterior_predict_multinomial(i = sample(1:nobs, 1), prep = prep) - expect_equal(dim(pred), c(ns, ncat)) - - prep$dpars$phi <- rexp(ns, 1) - prep$family <- dirichlet() - pred <- brms:::posterior_predict_dirichlet(i = sample(1:nobs, 1), prep = prep) - expect_equal(dim(pred), c(ns, ncat)) - expect_equal(rowSums(pred), rep(1, nrow(pred))) - - prep$family <- brmsfamily("dirichlet2") - prep$dpars$mu1 <- rexp(ns, 10) - prep$dpars$mu2 <- rexp(ns, 10) - prep$dpars$mu3 <- rexp(ns, 10) - pred <- brms:::posterior_predict_dirichlet2(i = sample(1:nobs, 1), prep = prep) - expect_equal(dim(pred), c(ns, ncat)) - expect_equal(rowSums(pred), rep(1, nrow(pred))) -}) - -test_that("truncated posterior_predict run without errors", { - ns <- 30 - nobs <- 15 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - sigma = rchisq(ns, 3) - ) - - prep$data <- list(lb = sample(-(4:7), nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_gaussian, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) - - prep$dpars$mu <- exp(prep$dpars$mu) - prep$data <- list(ub = sample(70:80, nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) - - prep$data <- list(lb = rep(0, nobs), ub = sample(70:75, nobs, TRUE)) - pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) - expect_equal(dim(pred), c(ns, nobs)) -}) - -test_that("posterior_predict for the wiener diffusion model runs without errors", { - skip("skip as long as RWiener fails on R-devel for 3.6.0") - ns <- 5 - nobs <- 3 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rnorm(ns * nobs), ncol = nobs), - bs = rchisq(ns, 3), ndt = rep(0.5, ns), - bias = rbeta(ns, 1, 1) - ) - prep$data <- list(Y = abs(rnorm(ns)) + 0.5, dec = c(1, 0, 1)) - i <- sample(1:nobs, 1) - expect_equal(nrow(brms:::posterior_predict_wiener(i, prep)), ns) -}) - -test_that("posterior_predict_custom runs without errors", { - ns <- 15 - nobs <- 10 - prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") - prep$dpars <- list( - mu = matrix(rbeta(ns * nobs * 2, 1, 1), ncol = nobs * 2) - ) - prep$data <- list(trials = rep(1, nobs)) - prep$family <- custom_family( - "beta_binomial2", dpars = c("mu", "tau"), - links = c("logit", "log"), lb = c(NA, 0), - type = "int", vars = "trials[n]" - ) - posterior_predict_beta_binomial2 <- function(i, prep) { - mu <- prep$dpars$mu[, i] - rbinom(prep$ndraws, size = prep$data$trials[i], prob = mu) - } - expect_equal(length(brms:::posterior_predict_custom(sample(1:nobs, 1), prep)), ns) -}) +context("Tests for posterior_predict helper functions") + +test_that("posterior_predict for location shift models runs without errors", { + ns <- 30 + nobs <- 10 + prep <- structure(list(ndraws = ns), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rchisq(ns, 3), nu = rgamma(ns, 4) + ) + i <- sample(nobs, 1) + + pred <- brms:::posterior_predict_gaussian(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_student(i, prep = prep) + expect_equal(length(pred), ns) +}) + +test_that("posterior_predict for various skewed models runs without errors", { + ns <- 50 + nobs <- 2 + prep <- structure(list(ndraws = ns), class = "brmsprep") + prep$dpars <- list( + sigma = rchisq(ns, 3), beta = rchisq(ns, 3), + mu = matrix(rnorm(ns * nobs), ncol = nobs), + alpha = rnorm(ns), ndt = 1 + ) + pred <- brms:::posterior_predict_lognormal(1, prep = prep) + expect_equal(length(pred), ns) + pred <- brms:::posterior_predict_shifted_lognormal(1, prep = prep) + expect_equal(length(pred), ns) + pred <- brms:::posterior_predict_exgaussian(1, prep = prep) + expect_equal(length(pred), ns) + pred <- brms:::posterior_predict_skew_normal(1, prep = prep) + expect_equal(length(pred), ns) +}) + +test_that("posterior_predict for aysm_laplace models runs without errors", { + ns <- 50 + prep <- structure(list(ndraws = ns), class = "brmsprep") + prep$dpars <- list( + sigma = rchisq(ns, 3), + quantile = rbeta(ns, 2, 1), + mu = matrix(rnorm(ns*2), ncol = 2), + zi = rbeta(ns, 10, 10) + ) + pred <- brms:::posterior_predict_asym_laplace(1, prep = prep) + expect_equal(length(pred), ns) + pred <- brms:::posterior_predict_zero_inflated_asym_laplace(1, prep = prep) + expect_equal(length(pred), ns) +}) + +test_that("posterior_predict for multivariate linear models runs without errors", { + ns <- 10 + nvars <- 3 + ncols <- 4 + nobs <- nvars * ncols + Sigma = array(cov(matrix(rnorm(300), ncol = 3)), dim = c(3, 3, 10)) + prep <- structure(list(ndraws = ns), class = "mvbrmsprep") + prep$mvpars <- list( + Mu = array(rnorm(ns*nobs*nvars), dim = c(ns, nobs, nvars)), + Sigma = aperm(Sigma, c(3, 1, 2)) + ) + prep$dpars <- list(nu = rgamma(ns, 5)) + prep$data <- list(N = nobs, N_trait = ncols) + + pred <- brms:::posterior_predict_gaussian_mv(1, prep = prep) + expect_equal(dim(pred), c(ns, nvars)) + + pred <- brms:::posterior_predict_student_mv(2, prep = prep) + expect_equal(dim(pred), c(ns, nvars)) +}) + +test_that("posterior_predict for ARMA covariance models runs without errors", { + ns <- 20 + nobs <- 15 + prep <- structure(list(ndraws = ns), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns*nobs), ncol = nobs), + sigma = rchisq(ns, 3), + nu = rgamma(ns, 5) + ) + prep$ac <- list( + ar = matrix(rbeta(ns, 0.5, 0.5), ncol = 1), + ma = matrix(rnorm(ns, 0.2, 1), ncol = 1), + begin_tg = c(1, 5, 12), end_tg = c(4, 11, 15) + ) + prep$data <- list(se = rgamma(ns, 10)) + + prep$family$fun <- "gaussian_time" + pred <- brms:::posterior_predict_gaussian_time(1, prep = prep) + expect_equal(length(pred), ns * 4) + + prep$family$fun <- "student_time" + pred <- brms:::posterior_predict_student_time(2, prep = prep) + expect_equal(length(pred), ns * 7) +}) + +test_that("loglik for SAR models runs without errors", { + ns = 3 + prep <- structure(list(ndraws = ns, nobs = 10), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(30), nrow = ns), + nu = rep(2, ns), + sigma = rep(10, ns) + ) + prep$ac <- list(lagsar = matrix(c(0.3, 0.5, 0.7)), Msar = diag(10)) + + pred <- brms:::posterior_predict_gaussian_lagsar(1, prep = prep) + expect_equal(dim(pred), c(3, 10)) + pred <- brms:::posterior_predict_student_lagsar(1, prep = prep) + expect_equal(dim(pred), c(3, 10)) + + prep$ac$errorsar <- prep$ac$lagsar + prep$ac$lagsar <- NULL + pred <- brms:::posterior_predict_gaussian_errorsar(1, prep = prep) + expect_equal(dim(pred), c(3, 10)) + pred <- brms:::posterior_predict_student_errorsar(1, prep = prep) + expect_equal(dim(pred), c(3, 10)) +}) + +test_that("posterior_predict for FCOR models runs without errors", { + ns <- 3 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(nobs * ns), nrow = ns), + sigma = rep(1, ns), nu = rep(2, ns) + ) + prep$ac <- list(Mfcor = diag(nobs)) + pred <- brms:::posterior_predict_gaussian_fcor(1, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) + pred <- brms:::posterior_predict_student_fcor(1, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) +}) + +test_that("posterior_predict for count and survival models runs without errors", { + ns <- 25 + nobs <- 10 + trials <- sample(10:30, nobs, replace = TRUE) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + eta = matrix(rnorm(ns * nobs), ncol = nobs), + shape = rgamma(ns, 4), xi = 0, phi = rgamma(ns, 1) + ) + prep$dpars$nu <- prep$dpars$sigma <- prep$dpars$shape + 1 + prep$data <- list(trials = trials) + i <- sample(nobs, 1) + + prep$dpars$mu <- brms:::inv_cloglog(prep$dpars$eta) + pred <- brms:::posterior_predict_binomial(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_beta_binomial(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_discrete_weibull(i, prep = prep) + expect_equal(length(pred), ns) + + prep$dpars$mu <- exp(prep$dpars$eta) + pred <- brms:::posterior_predict_poisson(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_negbinomial(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_negbinomial2(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_geometric(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_com_poisson(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_exponential(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_gamma(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_frechet(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_inverse.gaussian(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_gen_extreme_value(i, prep = prep) + expect_equal(length(pred), ns) + + prep$family$link <- "log" + pred <- brms:::posterior_predict_weibull(i, prep = prep) + expect_equal(length(pred), ns) +}) + +test_that("posterior_predict for bernoulli and beta models works correctly", { + ns <- 17 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = brms:::inv_logit(matrix(rnorm(ns * nobs * 2), ncol = 2 * nobs)), + phi = rgamma(ns, 4) + ) + i <- sample(1:nobs, 1) + + pred <- brms:::posterior_predict_bernoulli(i, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_beta(i, prep = prep) + expect_equal(length(pred), ns) +}) + +test_that("posterior_predict for circular models runs without errors", { + ns <- 15 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = 2 * atan(matrix(rnorm(ns * nobs * 2), ncol = nobs * 2)), + kappa = rgamma(ns, 4) + ) + i <- sample(seq_len(nobs), 1) + pred <- brms:::posterior_predict_von_mises(i, prep = prep) + expect_equal(length(pred), ns) +}) + +test_that("posterior_predict for zero-inflated and hurdle models runs without erros", { + ns <- 50 + nobs <- 8 + trials <- sample(10:30, nobs, replace = TRUE) + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + eta = matrix(rnorm(ns * nobs * 2), ncol = nobs * 2), + shape = rgamma(ns, 4), phi = rgamma(ns, 1), + zi = rbeta(ns, 1, 1), coi = rbeta(ns, 5, 7) + ) + prep$dpars$hu <- prep$dpars$zoi <- prep$dpars$zi + prep$data <- list(trials = trials) + + prep$dpars$mu <- exp(prep$dpars$eta) + pred <- brms:::posterior_predict_hurdle_poisson(1, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_hurdle_negbinomial(2, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_hurdle_gamma(5, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_zero_inflated_poisson(3, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_zero_inflated_negbinomial(6, prep = prep) + expect_equal(length(pred), ns) + + prep$dpars$mu <- brms:::inv_logit(prep$dpars$eta) + pred <- brms:::posterior_predict_zero_inflated_binomial(4, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_zero_inflated_beta_binomial(6, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_zero_inflated_beta(8, prep = prep) + expect_equal(length(pred), ns) + + pred <- brms:::posterior_predict_zero_one_inflated_beta(7, prep = prep) + expect_equal(length(pred), ns) +}) + +test_that("posterior_predict for ordinal models runs without erros", { + ns <- 50 + nobs <- 8 + nthres <- 3 + ncat <- nthres + 1 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = array(rnorm(ns * nobs), dim = c(ns, nobs)), + disc = rexp(ns) + ) + prep$thres$thres <- array(0, dim = c(ns, nthres)) + prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) + prep$family$link <- "logit" + + prep$family$family <- "cumulative" + pred <- sapply(1:nobs, brms:::posterior_predict_cumulative, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) + + prep$family$family <- "sratio" + pred <- sapply(1:nobs, brms:::posterior_predict_sratio, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) + + prep$family$family <- "cratio" + pred <- sapply(1:nobs, brms:::posterior_predict_cratio, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) + + prep$family$family <- "acat" + pred <- sapply(1:nobs, brms:::posterior_predict_acat, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) + + prep$family$link <- "probit" + pred <- sapply(1:nobs, brms:::posterior_predict_acat, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) +}) + +test_that("posterior_predict for categorical and related models runs without erros", { + set.seed(1234) + ns <- 50 + nobs <- 8 + ncat <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu1 = array(rnorm(ns*nobs, 0, 0.1), dim = c(ns, nobs)), + mu2 = array(rnorm(ns*nobs, 0, 0.1), dim = c(ns, nobs)) + ) + prep$data <- list(Y = rep(1:ncat, 2), ncat = ncat) + prep$family <- categorical() + prep$refcat <- 1 + pred <- sapply(1:nobs, brms:::posterior_predict_categorical, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) + + prep$data$trials <- sample(1:20, nobs) + prep$family <- multinomial() + pred <- brms:::posterior_predict_multinomial(i = sample(1:nobs, 1), prep = prep) + expect_equal(dim(pred), c(ns, ncat)) + + prep$dpars$phi <- rexp(ns, 1) + prep$family <- dirichlet() + pred <- brms:::posterior_predict_dirichlet(i = sample(1:nobs, 1), prep = prep) + expect_equal(dim(pred), c(ns, ncat)) + expect_equal(rowSums(pred), rep(1, nrow(pred))) + + prep$family <- brmsfamily("dirichlet2") + prep$dpars$mu1 <- rexp(ns, 10) + prep$dpars$mu2 <- rexp(ns, 10) + prep$dpars$mu3 <- rexp(ns, 10) + pred <- brms:::posterior_predict_dirichlet2(i = sample(1:nobs, 1), prep = prep) + expect_equal(dim(pred), c(ns, ncat)) + expect_equal(rowSums(pred), rep(1, nrow(pred))) + + prep$family <- brmsfamily("logistic_normal") + prep$dpars <- list( + mu2 = rnorm(ns), + mu3 = rnorm(ns), + sigma2 = rexp(ns, 10), + sigma3 = rexp(ns, 10) + ) + prep$lncor <- rbeta(ns, 2, 1) + pred <- brms:::posterior_predict_logistic_normal(i = sample(1:nobs, 1), prep = prep) + expect_equal(dim(pred), c(ns, ncat)) + expect_equal(rowSums(pred), rep(1, nrow(pred))) +}) + +test_that("truncated posterior_predict run without errors", { + ns <- 30 + nobs <- 15 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + sigma = rchisq(ns, 3) + ) + prep$refcat <- 1 + + prep$data <- list(lb = sample(-(4:7), nobs, TRUE)) + pred <- sapply(1:nobs, brms:::posterior_predict_gaussian, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) + + prep$dpars$mu <- exp(prep$dpars$mu) + prep$data <- list(ub = sample(70:80, nobs, TRUE)) + pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) + + prep$data <- list(lb = rep(0, nobs), ub = sample(70:75, nobs, TRUE)) + pred <- sapply(1:nobs, brms:::posterior_predict_poisson, prep = prep) + expect_equal(dim(pred), c(ns, nobs)) +}) + +test_that("posterior_predict for the wiener diffusion model runs without errors", { + skip("skip as long as RWiener fails on R-devel for 3.6.0") + ns <- 5 + nobs <- 3 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rnorm(ns * nobs), ncol = nobs), + bs = rchisq(ns, 3), ndt = rep(0.5, ns), + bias = rbeta(ns, 1, 1) + ) + prep$data <- list(Y = abs(rnorm(ns)) + 0.5, dec = c(1, 0, 1)) + i <- sample(1:nobs, 1) + expect_equal(nrow(brms:::posterior_predict_wiener(i, prep)), ns) +}) + +test_that("posterior_predict_custom runs without errors", { + ns <- 15 + nobs <- 10 + prep <- structure(list(ndraws = ns, nobs = nobs), class = "brmsprep") + prep$dpars <- list( + mu = matrix(rbeta(ns * nobs * 2, 1, 1), ncol = nobs * 2) + ) + prep$data <- list(trials = rep(1, nobs)) + prep$family <- custom_family( + "beta_binomial2", dpars = c("mu", "tau"), + links = c("logit", "log"), lb = c(NA, 0), + type = "int", vars = "trials[n]" + ) + posterior_predict_beta_binomial2 <- function(i, prep) { + mu <- prep$dpars$mu[, i] + rbinom(prep$ndraws, size = prep$data$trials[i], prob = mu) + } + expect_equal(length(brms:::posterior_predict_custom(sample(1:nobs, 1), prep)), ns) +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.priors.R r-cran-brms-2.17.0/tests/testthat/tests.priors.R --- r-cran-brms-2.16.3/tests/testthat/tests.priors.R 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.priors.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,130 +1,130 @@ -# most tests of prior related stuff can be found in tests.make_stancode.R -context("Tests for prior generating functions") - -test_that("get_prior finds all classes for which priors can be specified", { - expect_equal( - sort( - get_prior( - count ~ zBase * Trt + (1|patient) + (1+Trt|visit), - data = epilepsy, family = "poisson" - )$class - ), - sort(c(rep("b", 4), c("cor", "cor"), "Intercept", rep("sd", 6))) - ) - expect_equal( - sort( - get_prior( - rating ~ treat + period + cse(carry), data = inhaler, - family = sratio(threshold = "equidistant") - )$class - ), - sort(c(rep("b", 4), "delta", rep("Intercept", 1))) - ) -}) - -test_that("set_prior allows arguments to be vectors", { - bprior <- set_prior("normal(0, 2)", class = c("b", "sd")) - expect_is(bprior, "brmsprior") - expect_equal(bprior$prior, rep("normal(0, 2)", 2)) - expect_equal(bprior$class, c("b", "sd")) -}) - -test_that("print for class brmsprior works correctly", { - expect_output(print(set_prior("normal(0,1)")), fixed = TRUE, - "b ~ normal(0,1)") - expect_output(print(set_prior("normal(0,1)", coef = "x")), - "b_x ~ normal(0,1)", fixed = TRUE) - expect_output(print(set_prior("cauchy(0,1)", class = "sd", group = "x")), - "sd_x ~ cauchy(0,1)", fixed = TRUE) - expect_output(print(set_prior("target += normal_lpdf(x | 0,1))", check = FALSE)), - "target += normal_lpdf(x | 0,1))", fixed = TRUE) -}) - -test_that("get_prior returns correct nlpar names for random effects pars", { - # reported in issue #47 - data <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:2, 5)) - gp <- get_prior(bf(y ~ a - b^x, a + b ~ (1+x|g), nl = TRUE), - data = data) - expect_equal(sort(unique(gp$nlpar)), c("", "a", "b")) -}) - -test_that("get_prior returns correct fixed effect names for GAMMs", { - dat <- data.frame(y = rnorm(10), x = rnorm(10), - z = rnorm(10), g = rep(1:2, 5)) - prior <- get_prior(y ~ z + s(x) + (1|g), data = dat) - expect_equal(prior[prior$class == "b", ]$coef, - c("", "sx_1", "z")) - prior <- get_prior(bf(y ~ lp, lp ~ z + s(x) + (1|g), nl = TRUE), - data = dat) - expect_equal(prior[prior$class == "b", ]$coef, - c("", "Intercept", "sx_1", "z")) -}) - -test_that("get_prior returns correct prior names for auxiliary parameters", { - dat <- data.frame(y = rnorm(10), x = rnorm(10), - z = rnorm(10), g = rep(1:2, 5)) - prior <- get_prior(bf(y ~ 1, phi ~ z + (1|g)), data = dat, family = Beta()) - prior <- prior[prior$dpar == "phi", ] - pdata <- data.frame(class = c("b", "b", "Intercept", rep("sd", 3)), - coef = c("", "z", "", "", "", "Intercept"), - group = c(rep("", 4), "g", "g"), - stringsAsFactors = FALSE) - pdata <- pdata[with(pdata, order(class, group, coef)), ] - expect_equivalent(prior[, c("class", "coef", "group")], pdata) -}) - -test_that("get_prior returns correct priors for multivariate models", { - dat <- data.frame(y1 = rnorm(10), y2 = c(1, rep(1:3, 3)), - x = rnorm(10), g = rep(1:2, 5)) - bform <- bf(mvbind(y1, y2) ~ x + (x|ID1|g)) + set_rescor(TRUE) - - # check global priors - prior <- get_prior(bform, dat, family = gaussian()) - expect_equal(prior[prior$resp == "y1" & prior$class == "b", "coef"], c("", "x")) - expect_equal(prior[prior$class == "rescor", "prior"], "lkj(1)") - - # check family and autocor specific priors - family <- list(gaussian, Beta()) - bform <- bf(y1 ~ x + (x|ID1|g) + ar()) + bf(y2 ~ 1) - prior <- get_prior(bform, dat, family = family) - expect_true(any(with(prior, class == "sigma" & resp == "y1"))) - expect_true(any(with(prior, class == "ar" & resp == "y1"))) - expect_true(any(with(prior, class == "phi" & resp == "y2"))) - expect_true(!any(with(prior, class == "ar" & resp == "y2"))) -}) - -test_that("get_prior returns correct priors for categorical models", { - # check global priors - dat <- data.frame(y2 = c(1, rep(1:3, 3)), x = rnorm(10), g = rep(1:2, 5)) - prior <- get_prior(y2 ~ x + (x|ID1|g), data = dat, family = categorical()) - expect_equal(prior[prior$dpar == "mu2" & prior$class == "b", "coef"], c("", "x")) -}) - -test_that("set_prior alias functions produce equivalent results", { - expect_equal(set_prior("normal(0, 1)", class = "sd"), - prior(normal(0, 1), class = sd)) - expect_equal(set_prior("normal(0, 1)", class = "sd", nlpar = "a"), - prior(normal(0, 1), class = "sd", nlpar = a)) - expect_equal(set_prior("normal(0, 1)", class = "sd", nlpar = "a"), - prior_(~normal(0, 1), class = ~sd, nlpar = quote(a))) - expect_equal(set_prior("normal(0, 1)", class = "sd"), - prior_string("normal(0, 1)", class = "sd")) -}) - -test_that("external interface of validate_prior works correctly", { - prior1 <- prior(normal(0,10), class = b) + - prior(cauchy(0,2), class = sd) - prior1 <- validate_prior( - prior1, count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson() - ) - expect_true(all(c("b", "Intercept", "sd") %in% prior1$class)) - expect_equal(nrow(prior1), 9) -}) - -test_that("overall intercept priors are adjusted for the intercept", { - dat <- data.frame(y = rep(c(1, 3), each = 5), off = 10) - prior1 <- get_prior(y ~ 1 + offset(off), dat) - int_prior <- prior1$prior[prior1$class == "Intercept"] - expect_equal(int_prior, "student_t(3, -8, 2.5)") -}) +# most tests of prior related stuff can be found in tests.make_stancode.R +context("Tests for prior generating functions") + +test_that("get_prior finds all classes for which priors can be specified", { + expect_equal( + sort( + get_prior( + count ~ zBase * Trt + (1|patient) + (1+Trt|visit), + data = epilepsy, family = "poisson" + )$class + ), + sort(c(rep("b", 4), c("cor", "cor"), "Intercept", rep("sd", 6))) + ) + expect_equal( + sort( + get_prior( + rating ~ treat + period + cse(carry), data = inhaler, + family = sratio(threshold = "equidistant") + )$class + ), + sort(c(rep("b", 4), "delta", rep("Intercept", 1))) + ) +}) + +test_that("set_prior allows arguments to be vectors", { + bprior <- set_prior("normal(0, 2)", class = c("b", "sd")) + expect_is(bprior, "brmsprior") + expect_equal(bprior$prior, rep("normal(0, 2)", 2)) + expect_equal(bprior$class, c("b", "sd")) +}) + +test_that("print for class brmsprior works correctly", { + expect_output(print(set_prior("normal(0,1)")), fixed = TRUE, + "b ~ normal(0,1)") + expect_output(print(set_prior("normal(0,1)", coef = "x")), + "b_x ~ normal(0,1)", fixed = TRUE) + expect_output(print(set_prior("cauchy(0,1)", class = "sd", group = "x")), + "sd_x ~ cauchy(0,1)", fixed = TRUE) + expect_output(print(set_prior("target += normal_lpdf(x | 0,1))", check = FALSE)), + "target += normal_lpdf(x | 0,1))", fixed = TRUE) +}) + +test_that("get_prior returns correct nlpar names for random effects pars", { + # reported in issue #47 + data <- data.frame(y = rnorm(10), x = rnorm(10), g = rep(1:2, 5)) + gp <- get_prior(bf(y ~ a - b^x, a + b ~ (1+x|g), nl = TRUE), + data = data) + expect_equal(sort(unique(gp$nlpar)), c("", "a", "b")) +}) + +test_that("get_prior returns correct fixed effect names for GAMMs", { + dat <- data.frame(y = rnorm(10), x = rnorm(10), + z = rnorm(10), g = rep(1:2, 5)) + prior <- get_prior(y ~ z + s(x) + (1|g), data = dat) + expect_equal(prior[prior$class == "b", ]$coef, + c("", "sx_1", "z")) + prior <- get_prior(bf(y ~ lp, lp ~ z + s(x) + (1|g), nl = TRUE), + data = dat) + expect_equal(prior[prior$class == "b", ]$coef, + c("", "Intercept", "sx_1", "z")) +}) + +test_that("get_prior returns correct prior names for auxiliary parameters", { + dat <- data.frame(y = rnorm(10), x = rnorm(10), + z = rnorm(10), g = rep(1:2, 5)) + prior <- get_prior(bf(y ~ 1, phi ~ z + (1|g)), data = dat, family = Beta()) + prior <- prior[prior$dpar == "phi", ] + pdata <- data.frame(class = c("b", "b", "Intercept", rep("sd", 3)), + coef = c("", "z", "", "", "", "Intercept"), + group = c(rep("", 4), "g", "g"), + stringsAsFactors = FALSE) + pdata <- pdata[with(pdata, order(class, group, coef)), ] + expect_equivalent(prior[, c("class", "coef", "group")], pdata) +}) + +test_that("get_prior returns correct priors for multivariate models", { + dat <- data.frame(y1 = rnorm(10), y2 = c(1, rep(1:3, 3)), + x = rnorm(10), g = rep(1:2, 5)) + bform <- bf(mvbind(y1, y2) ~ x + (x|ID1|g)) + set_rescor(TRUE) + + # check global priors + prior <- get_prior(bform, dat, family = gaussian()) + expect_equal(prior[prior$resp == "y1" & prior$class == "b", "coef"], c("", "x")) + expect_equal(prior[prior$class == "rescor", "prior"], "lkj(1)") + + # check family and autocor specific priors + family <- list(gaussian, Beta()) + bform <- bf(y1 ~ x + (x|ID1|g) + ar()) + bf(y2 ~ 1) + prior <- get_prior(bform, dat, family = family) + expect_true(any(with(prior, class == "sigma" & resp == "y1"))) + expect_true(any(with(prior, class == "ar" & resp == "y1"))) + expect_true(any(with(prior, class == "phi" & resp == "y2"))) + expect_true(!any(with(prior, class == "ar" & resp == "y2"))) +}) + +test_that("get_prior returns correct priors for categorical models", { + # check global priors + dat <- data.frame(y2 = c(1, rep(1:3, 3)), x = rnorm(10), g = rep(1:2, 5)) + prior <- get_prior(y2 ~ x + (x|ID1|g), data = dat, family = categorical()) + expect_equal(prior[prior$dpar == "mu2" & prior$class == "b", "coef"], c("", "x")) +}) + +test_that("set_prior alias functions produce equivalent results", { + expect_equal(set_prior("normal(0, 1)", class = "sd"), + prior(normal(0, 1), class = sd)) + expect_equal(set_prior("normal(0, 1)", class = "sd", nlpar = "a"), + prior(normal(0, 1), class = "sd", nlpar = a)) + expect_equal(set_prior("normal(0, 1)", class = "sd", nlpar = "a"), + prior_(~normal(0, 1), class = ~sd, nlpar = quote(a))) + expect_equal(set_prior("normal(0, 1)", class = "sd"), + prior_string("normal(0, 1)", class = "sd")) +}) + +test_that("external interface of validate_prior works correctly", { + prior1 <- prior(normal(0,10), class = b) + + prior(cauchy(0,2), class = sd) + prior1 <- validate_prior( + prior1, count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson() + ) + expect_true(all(c("b", "Intercept", "sd") %in% prior1$class)) + expect_equal(nrow(prior1), 9) +}) + +test_that("overall intercept priors are adjusted for the intercept", { + dat <- data.frame(y = rep(c(1, 3), each = 5), off = 10) + prior1 <- get_prior(y ~ 1 + offset(off), dat) + int_prior <- prior1$prior[prior1$class == "Intercept"] + expect_equal(int_prior, "student_t(3, -8, 2.5)") +}) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.rename_pars.R r-cran-brms-2.17.0/tests/testthat/tests.rename_pars.R --- r-cran-brms-2.16.3/tests/testthat/tests.rename_pars.R 2020-10-08 07:01:42.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.rename_pars.R 2022-03-13 16:10:29.000000000 +0000 @@ -2,8 +2,8 @@ test_that("make_index_names returns correct 1 and 2 dimensional indices", { expect_equal(make_index_names(rownames = 1:2), c("[1]", "[2]")) - expect_equal(make_index_names(rownames = 1:2, colnames = 1:3, dim = 1), + expect_equal(make_index_names(rownames = 1:2, colnames = 1:3, dim = 1), c("[1]", "[2]")) - expect_equal(make_index_names(rownames = c("a","b"), colnames = 1:3, dim = 2), + expect_equal(make_index_names(rownames = c("a","b"), colnames = 1:3, dim = 2), c("[a,1]", "[b,1]", "[a,2]", "[b,2]", "[a,3]", "[b,3]")) }) diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.restructure.R r-cran-brms-2.17.0/tests/testthat/tests.restructure.R --- r-cran-brms-2.16.3/tests/testthat/tests.restructure.R 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.restructure.R 2022-03-13 16:10:29.000000000 +0000 @@ -1,191 +1,191 @@ -context("Tests for restructuring of old brmsfit objects") - -test_that("restructure can be run without error", { - # This test does not check if old models can really be restructured - # since restructure is called with an already up-to-date model. - fit2 <- brms:::rename_pars(brms:::brmsfit_example2) - fit2$version <- NULL - fit2$exclude <- c("L_1", "zs_1") - expect_warning( - fit2_up <- restructure(fit2), - "Models fitted with brms < 1.0 are no longer offically supported" - ) - expect_is(fit2_up, "brmsfit") -}) - -test_that("restructure_formula_v1 works correctly", { - form <- structure( - y ~ x + z, sigma = sigma ~ x, - class = c("brmsformula", "formula") - ) - form <- brms:::restructure_formula_v1(form) - expect_equal(form$formula, y ~ x + z) - expect_equal(form$pforms, list(sigma = sigma ~ x)) - expect_true(!attr(form$formula, "nl")) - - form <- structure( - y ~ a * exp(-b * x), - nonlinear = list(a = a ~ x, b = b ~ 1), - class = c("brmsformula", "formula") - ) - form <- brms:::restructure_formula_v1(form) - expect_equal(form$formula, y ~ a * exp(-b * x)) - expect_equal(form$pforms, list(a = a ~ x, b = b ~ 1)) - expect_true(attr(form$formula, "nl")) -}) - -test_that("change_prior returns expected lists", { - pars <- c("b", "b_1", "bp", "bp_1", "prior_b", "prior_b_1", - "prior_b_3", "sd_x[1]", "prior_bp_1") - expect_equivalent( - brms:::change_prior( - class = "b", pars = pars, names = c("x1", "x3", "x2") - ), - list(list(pos = 6, fnames = "prior_b_x1"), - list(pos = 7, fnames = "prior_b_x2")) - ) - expect_equivalent( - brms:::change_prior( - class = "bp", pars = pars, - names = c("x1", "x2"), new_class = "b" - ), - list(list(pos = 9, fnames = "prior_b_x1"))) -}) - -test_that("change_old_re and change_old_re2 return expected lists", { - data <- data.frame(y = rnorm(10), x = rnorm(10), g = 1:10) - bterms <- brmsterms(bf(y ~ a, a ~ x + (1+x|g), - family = gaussian(), nl = TRUE)) - ranef <- brms:::tidy_ranef(bterms, data = data) - target <- list( - list(pos = c(rep(FALSE, 2), TRUE, rep(FALSE, 22)), - oldname = "sd_a_g_Intercept", pnames = "sd_g_a_Intercept", - fnames = "sd_g_a_Intercept", dims = numeric(0)), - list(pos = c(rep(FALSE, 3), TRUE, rep(FALSE, 21)), - oldname = "sd_a_g_x", pnames = "sd_g_a_x", - fnames = "sd_g_a_x", dims = numeric(0)), - list(pos = c(rep(FALSE, 4), TRUE, rep(FALSE, 20)), - oldname = "cor_a_g_Intercept_x", pnames = "cor_g_a_Intercept_a_x", - fnames = "cor_g_a_Intercept_a_x", dims = numeric(0)), - list(pos = c(rep(FALSE, 5), rep(TRUE, 20)), oldname = "r_a_g", - pnames = "r_g_a", - fnames = c(paste0("r_g_a[", 1:10, ",Intercept]"), - paste0("r_g_a[", 1:10, ",x]")), - dims = c(10, 2))) - - pars <- c("b_a_Intercept", "b_a_x", "sd_a_g_Intercept", "sd_a_g_x", - "cor_a_g_Intercept_x", paste0("r_a_g[", 1:10, ",Intercept]"), - paste0("r_a_g[", 1:10, ",x]")) - dims <- list("sd_a_g_Intercept" = numeric(0), "sd_a_g_x" = numeric(0), - "cor_a_g_Intercept_x" = numeric(0), "r_a_g" = c(10, 2)) - expect_equivalent(brms:::change_old_re(ranef, pars = pars, dims = dims), target) - - target <- list( - list(pos = c(rep(FALSE, 2), TRUE, rep(FALSE, 22)), - oldname = "sd_g_a_Intercept", pnames = "sd_g__a_Intercept", - fnames = "sd_g__a_Intercept", dims = numeric(0)), - list(pos = c(rep(FALSE, 3), TRUE, rep(FALSE, 21)), - oldname = "sd_g_a_x", pnames = "sd_g__a_x", - fnames = "sd_g__a_x", dims = numeric(0)), - list(pos = c(rep(FALSE, 4), TRUE, rep(FALSE, 20)), - oldname = "cor_g_a_Intercept_a_x", pnames = "cor_g__a_Intercept__a_x", - fnames = "cor_g__a_Intercept__a_x", dims = numeric(0)), - list(pos = c(rep(FALSE, 5), rep(TRUE, 20)), oldname = "r_g_a", - pnames = "r_g__a", - fnames = c(paste0("r_g__a[", 1:10, ",Intercept]"), - paste0("r_g__a[", 1:10, ",x]")), - dims = c(10, 2))) - - pars <- c("b_a_Intercept", "b_a_x", "sd_g_a_Intercept", "sd_g_a_x", - "cor_g_a_Intercept_a_x", paste0("r_g_a[", 1:10, ",Intercept]"), - paste0("r_g_a[", 1:10, ",x]")) - dims <- list("sd_g_a_Intercept" = numeric(0), "sd_g_a_x" = numeric(0), - "cor_g_a_Intercept_a_x" = numeric(0), "r_g_a" = c(10, 2)) - expect_equivalent(brms:::change_old_re2(ranef, pars = pars, dims = dims), target) -}) - -test_that("change_old_sm return expected lists", { - target <- list( - list(pos = c(FALSE, TRUE, rep(FALSE, 15)), - oldname = "sds_sx1kEQ9", - pnames = "sds_sx1_1", - fnames = "sds_sx1_1", - dims = numeric(0)), - list(pos = c(rep(FALSE, 8), rep(TRUE, 9)), - oldname = "s_sx1kEQ9", - pnames = "s_sx1_1", - fnames = paste0("s_sx1_1[", 1:9, "]"), - dims = 9), - list(pos = c(TRUE, rep(FALSE, 16)), - oldname = "sds_sigma_t2x0", - pnames = "sds_sigma_t2x0_1", - fnames = "sds_sigma_t2x0_1", - dims = numeric(0)), - list(pos = c(FALSE, FALSE, rep(TRUE, 6), rep(FALSE, 9)), - oldname = "s_sigma_t2x0", - pnames = "s_sigma_t2x0_1", - fnames = paste0("s_sigma_t2x0_1[", 1:6, "]"), - dims = 6) - ) - pars <- c("sds_sigma_t2x0", "sds_sx1kEQ9", - paste0("s_sigma_t2x0[", 1:6, "]"), - paste0("s_sx1kEQ9[", 1:9, "]")) - dims <- list(sds_sigma_t2x0 = numeric(0), sds_sx1kEQ9 = numeric(0), - s_sigma_t2x0 = 6, s_sx1kEQ9 = 9) - bterms <- brmsterms(bf(y ~ s(x1, k = 9), sigma ~ t2(x0)), family = gaussian()) - dat <- data.frame(y = rnorm(100), x1 = rnorm(100), x0 = rnorm(100)) - expect_equivalent(brms:::change_old_sm(bterms, dat, pars, dims), target) -}) - -test_that("change_old_mo returns expected lists", { - bterms <- brmsterms(bf(y ~ mo(x), sigma ~ mo(x)), family = gaussian()) - data <- data.frame(y = rnorm(10), x = rep(1:5, 2)) - pars <- c( - "bmo_x", "bmo_sigma_x", - paste0("simplex_x[", 1:5, "]"), - paste0("simplex_sigma_x[", 1:5, "]") - ) - target <- list( - list( - pos = c(TRUE, rep(FALSE, 11)), - fnames = "bmo_mox" - ), - list( - pos = c(FALSE, FALSE, rep(TRUE, 5), rep(FALSE, 5)), - fnames = paste0("simo_mox1[", 1:5, "]") - ), - list( - pos = c(FALSE, TRUE, rep(FALSE, 10)), - fnames = "bmo_sigma_mox" - ), - list( - pos = c(rep(FALSE, 7), rep(TRUE, 5)), - fnames = paste0("simo_sigma_mox1[", 1:5, "]") - ) - ) - expect_equivalent(brms:::change_old_mo(bterms, data, pars), target) -}) - -test_that("change_old_categorical works correctly", { - dat <- data.frame( - y = rep(c("cat1", "cat2", "cat3"), 3), - x = rnorm(9) - ) - fam <- categorical() - fam$dpars <- c("mucat2", "mucat3") - bterms <- brmsterms(bf(y ~ x) + fam) - pars <- c("b_cat2_Intercept", "b_cat3_Intercept", - "b_cat2_x", "b_cat3_x") - res <- brms:::change_old_categorical(bterms, dat, pars) - target <- list( - list( - pos = rep(TRUE, 4), - fnames = c( - "b_mucat2_Intercept", "b_mucat3_Intercept", - "b_mucat2_x", "b_mucat3_x" - ) - ) - ) - expect_equivalent(res, target) -}) - +context("Tests for restructuring of old brmsfit objects") + +test_that("restructure can be run without error", { + # This test does not check if old models can really be restructured + # since restructure is called with an already up-to-date model. + fit2 <- brms:::rename_pars(brms:::brmsfit_example2) + fit2$version <- NULL + fit2$exclude <- c("L_1", "zs_1") + expect_warning( + fit2_up <- restructure(fit2), + "Models fitted with brms < 1.0 are no longer offically supported" + ) + expect_is(fit2_up, "brmsfit") +}) + +test_that("restructure_formula_v1 works correctly", { + form <- structure( + y ~ x + z, sigma = sigma ~ x, + class = c("brmsformula", "formula") + ) + form <- brms:::restructure_formula_v1(form) + expect_equal(form$formula, y ~ x + z) + expect_equal(form$pforms, list(sigma = sigma ~ x)) + expect_true(!attr(form$formula, "nl")) + + form <- structure( + y ~ a * exp(-b * x), + nonlinear = list(a = a ~ x, b = b ~ 1), + class = c("brmsformula", "formula") + ) + form <- brms:::restructure_formula_v1(form) + expect_equal(form$formula, y ~ a * exp(-b * x)) + expect_equal(form$pforms, list(a = a ~ x, b = b ~ 1)) + expect_true(attr(form$formula, "nl")) +}) + +test_that("change_prior returns expected lists", { + pars <- c("b", "b_1", "bp", "bp_1", "prior_b", "prior_b__1", + "prior_b__3", "sd_x[1]", "prior_bp__1") + expect_equivalent( + brms:::change_prior( + class = "b", pars = pars, names = c("x1", "x3", "x2") + ), + list(list(pos = 6, fnames = "prior_b_x1"), + list(pos = 7, fnames = "prior_b_x2")) + ) + expect_equivalent( + brms:::change_prior( + class = "bp", pars = pars, + names = c("x1", "x2"), new_class = "b" + ), + list(list(pos = 9, fnames = "prior_b_x1"))) +}) + +test_that("change_old_re and change_old_re2 return expected lists", { + data <- data.frame(y = rnorm(10), x = rnorm(10), g = 1:10) + bterms <- brmsterms(bf(y ~ a, a ~ x + (1+x|g), + family = gaussian(), nl = TRUE)) + ranef <- brms:::tidy_ranef(bterms, data = data) + target <- list( + list(pos = c(rep(FALSE, 2), TRUE, rep(FALSE, 22)), + oldname = "sd_a_g_Intercept", pnames = "sd_g_a_Intercept", + fnames = "sd_g_a_Intercept", dims = numeric(0)), + list(pos = c(rep(FALSE, 3), TRUE, rep(FALSE, 21)), + oldname = "sd_a_g_x", pnames = "sd_g_a_x", + fnames = "sd_g_a_x", dims = numeric(0)), + list(pos = c(rep(FALSE, 4), TRUE, rep(FALSE, 20)), + oldname = "cor_a_g_Intercept_x", pnames = "cor_g_a_Intercept_a_x", + fnames = "cor_g_a_Intercept_a_x", dims = numeric(0)), + list(pos = c(rep(FALSE, 5), rep(TRUE, 20)), oldname = "r_a_g", + pnames = "r_g_a", + fnames = c(paste0("r_g_a[", 1:10, ",Intercept]"), + paste0("r_g_a[", 1:10, ",x]")), + dims = c(10, 2))) + + pars <- c("b_a_Intercept", "b_a_x", "sd_a_g_Intercept", "sd_a_g_x", + "cor_a_g_Intercept_x", paste0("r_a_g[", 1:10, ",Intercept]"), + paste0("r_a_g[", 1:10, ",x]")) + dims <- list("sd_a_g_Intercept" = numeric(0), "sd_a_g_x" = numeric(0), + "cor_a_g_Intercept_x" = numeric(0), "r_a_g" = c(10, 2)) + expect_equivalent(brms:::change_old_re(ranef, pars = pars, dims = dims), target) + + target <- list( + list(pos = c(rep(FALSE, 2), TRUE, rep(FALSE, 22)), + oldname = "sd_g_a_Intercept", pnames = "sd_g__a_Intercept", + fnames = "sd_g__a_Intercept", dims = numeric(0)), + list(pos = c(rep(FALSE, 3), TRUE, rep(FALSE, 21)), + oldname = "sd_g_a_x", pnames = "sd_g__a_x", + fnames = "sd_g__a_x", dims = numeric(0)), + list(pos = c(rep(FALSE, 4), TRUE, rep(FALSE, 20)), + oldname = "cor_g_a_Intercept_a_x", pnames = "cor_g__a_Intercept__a_x", + fnames = "cor_g__a_Intercept__a_x", dims = numeric(0)), + list(pos = c(rep(FALSE, 5), rep(TRUE, 20)), oldname = "r_g_a", + pnames = "r_g__a", + fnames = c(paste0("r_g__a[", 1:10, ",Intercept]"), + paste0("r_g__a[", 1:10, ",x]")), + dims = c(10, 2))) + + pars <- c("b_a_Intercept", "b_a_x", "sd_g_a_Intercept", "sd_g_a_x", + "cor_g_a_Intercept_a_x", paste0("r_g_a[", 1:10, ",Intercept]"), + paste0("r_g_a[", 1:10, ",x]")) + dims <- list("sd_g_a_Intercept" = numeric(0), "sd_g_a_x" = numeric(0), + "cor_g_a_Intercept_a_x" = numeric(0), "r_g_a" = c(10, 2)) + expect_equivalent(brms:::change_old_re2(ranef, pars = pars, dims = dims), target) +}) + +test_that("change_old_sm return expected lists", { + target <- list( + list(pos = c(FALSE, TRUE, rep(FALSE, 15)), + oldname = "sds_sx1kEQ9", + pnames = "sds_sx1_1", + fnames = "sds_sx1_1", + dims = numeric(0)), + list(pos = c(rep(FALSE, 8), rep(TRUE, 9)), + oldname = "s_sx1kEQ9", + pnames = "s_sx1_1", + fnames = paste0("s_sx1_1[", 1:9, "]"), + dims = 9), + list(pos = c(TRUE, rep(FALSE, 16)), + oldname = "sds_sigma_t2x0", + pnames = "sds_sigma_t2x0_1", + fnames = "sds_sigma_t2x0_1", + dims = numeric(0)), + list(pos = c(FALSE, FALSE, rep(TRUE, 6), rep(FALSE, 9)), + oldname = "s_sigma_t2x0", + pnames = "s_sigma_t2x0_1", + fnames = paste0("s_sigma_t2x0_1[", 1:6, "]"), + dims = 6) + ) + pars <- c("sds_sigma_t2x0", "sds_sx1kEQ9", + paste0("s_sigma_t2x0[", 1:6, "]"), + paste0("s_sx1kEQ9[", 1:9, "]")) + dims <- list(sds_sigma_t2x0 = numeric(0), sds_sx1kEQ9 = numeric(0), + s_sigma_t2x0 = 6, s_sx1kEQ9 = 9) + bterms <- brmsterms(bf(y ~ s(x1, k = 9), sigma ~ t2(x0)), family = gaussian()) + dat <- data.frame(y = rnorm(100), x1 = rnorm(100), x0 = rnorm(100)) + expect_equivalent(brms:::change_old_sm(bterms, dat, pars, dims), target) +}) + +test_that("change_old_mo returns expected lists", { + bterms <- brmsterms(bf(y ~ mo(x), sigma ~ mo(x)), family = gaussian()) + data <- data.frame(y = rnorm(10), x = rep(1:5, 2)) + pars <- c( + "bmo_x", "bmo_sigma_x", + paste0("simplex_x[", 1:5, "]"), + paste0("simplex_sigma_x[", 1:5, "]") + ) + target <- list( + list( + pos = c(TRUE, rep(FALSE, 11)), + fnames = "bmo_mox" + ), + list( + pos = c(FALSE, FALSE, rep(TRUE, 5), rep(FALSE, 5)), + fnames = paste0("simo_mox1[", 1:5, "]") + ), + list( + pos = c(FALSE, TRUE, rep(FALSE, 10)), + fnames = "bmo_sigma_mox" + ), + list( + pos = c(rep(FALSE, 7), rep(TRUE, 5)), + fnames = paste0("simo_sigma_mox1[", 1:5, "]") + ) + ) + expect_equivalent(brms:::change_old_mo(bterms, data, pars), target) +}) + +test_that("change_old_categorical works correctly", { + dat <- data.frame( + y = rep(c("cat1", "cat2", "cat3"), 3), + x = rnorm(9) + ) + fam <- categorical() + fam$dpars <- c("mucat2", "mucat3") + bterms <- brmsterms(bf(y ~ x) + fam) + pars <- c("b_cat2_Intercept", "b_cat3_Intercept", + "b_cat2_x", "b_cat3_x") + res <- brms:::change_old_categorical(bterms, dat, pars) + target <- list( + list( + pos = rep(TRUE, 4), + fnames = c( + "b_mucat2_Intercept", "b_mucat3_Intercept", + "b_mucat2_x", "b_mucat3_x" + ) + ) + ) + expect_equivalent(res, target) +}) + diff -Nru r-cran-brms-2.16.3/tests/testthat/tests.stan_functions.R r-cran-brms-2.17.0/tests/testthat/tests.stan_functions.R --- r-cran-brms-2.16.3/tests/testthat/tests.stan_functions.R 2020-10-08 07:02:17.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat/tests.stan_functions.R 2022-03-13 16:10:29.000000000 +0000 @@ -4,36 +4,36 @@ # for some reason expose_stan_functions doesn't work within R CMD CHECK skip_if_not(exists("new_stan_functions", asNamespace("brms"))) rstan::expose_stan_functions(brms:::new_stan_functions) - + # ARMA matrix generating functions - cov_ar1_R <- get_cov_matrix_ar1(ar = matrix(0.5), sigma = 2, + cov_ar1_R <- get_cov_matrix_ar1(ar = matrix(0.5), sigma = 2, se2 = 0, nrows = 3)[1, , ] expect_equal(cov_matrix_ar1(0.5, 2, 3), cov_ar1_R) - cov_ma1_R <- matrix(get_cov_matrix_ma1(ma = matrix(-0.3), sigma = 3, + cov_ma1_R <- matrix(get_cov_matrix_ma1(ma = matrix(-0.3), sigma = 3, se2 = 0, nrows = 1)[1, , ]) expect_equal(cov_matrix_ma1(-0.3, 3, 1), cov_ma1_R) - cov_arma1_R <- get_cov_matrix_arma1(ar = matrix(-0.5), ma = matrix(0.7), + cov_arma1_R <- get_cov_matrix_arma1(ar = matrix(-0.5), ma = matrix(0.7), sigma = 4, se2 = 0, nrows = 5)[1, , ] expect_equal(cov_matrix_arma1(-0.5, 0.7, 4, 5), cov_arma1_R) - + # log-likelihood functions for covariance models y <- rnorm(9) eta <- rnorm(9) - ll_stan <- normal_cov_lpdf(y, eta = eta, se2 = 1:9, I = 2, - begin = c(1, 5), end = c(4, 9), nobs = c(4, 5), + ll_stan <- normal_cov_lpdf(y, eta = eta, se2 = 1:9, I = 2, + begin = c(1, 5), end = c(4, 9), nobs = c(4, 5), res_cov_matrix = cov_arma1_R) ll_R <- c(dmulti_normal(y[1:4], eta[1:4], cov_arma1_R[1:4, 1:4] + diag(1:4)), dmulti_normal(y[5:9], eta[5:9], cov_arma1_R[1:5, 1:5] + diag(5:9))) expect_equal(ll_stan, sum(ll_R)) - ll_stan <- student_t_cov_lpdf(y, nu = 10, eta = eta, se2 = 1:9, I = 2, + ll_stan <- student_t_cov_lpdf(y, nu = 10, eta = eta, se2 = 1:9, I = 2, begin = c(1, 5), end = c(4, 9), nobs = c(4, 5), res_cov_matrix = cov_arma1_R) - ll_R <- c(dmulti_student(y[1:4], df = 10, mu = eta[1:4], + ll_R <- c(dmulti_student(y[1:4], df = 10, mu = eta[1:4], Sigma = cov_arma1_R[1:4, 1:4] + diag(1:4)), - dmulti_student(y[5:9], df = 10, mu = eta[5:9], + dmulti_student(y[5:9], df = 10, mu = eta[5:9], Sigma = cov_arma1_R[1:5, 1:5] + diag(5:9))) expect_equal(ll_stan, sum(ll_R)) - + # inverse gaussian functions shape <- rgamma(1, 20, 1) mu <- 20 @@ -43,13 +43,13 @@ expect_equal(inv_gaussian_lcdf(y, mu, shape, log(y), sqrt(y)), pinvgauss(y, mean = mu, shape = shape, log = TRUE)) expect_equal(inv_gaussian_lccdf(y, mu, shape, log(y), sqrt(y)), - log(1 - pinvgauss(y, mean = mu, shape = shape))) + log(1 - pinvgauss(y, mean = mu, shape = shape))) mu <- 18:22 y <- statmod::rinvgauss(5, mean = mu, shape = shape) expect_equal(inv_gaussian_vector_lpdf(y, mu, shape, sum(log(y)), sqrt(y)), sum(dinvgauss(y, mean = mu, shape = shape, log = TRUE))) - + # exgaussian functions beta <- rgamma(1, 1, 0.1) sigma <- rgamma(1, 10, 0.1) @@ -60,9 +60,9 @@ expect_equal(exgaussian_lcdf(y, mu, sigma, beta), pexgaussian(y, mu, sigma, beta, log = TRUE)) expect_equal(exgaussian_lccdf(y, mu, sigma, beta), - pexgaussian(y, mu, sigma, beta, + pexgaussian(y, mu, sigma, beta, lower.tail = FALSE, log = TRUE)) - + # asym_laplace functions mu <- 10 quantile <- rbeta(1, 2, 1) @@ -73,9 +73,9 @@ expect_equal(asym_laplace_lcdf(y, mu, sigma, quantile), pasym_laplace(y, mu, sigma, quantile, log = TRUE)) expect_equal(asym_laplace_lccdf(y, mu, sigma, quantile), - pasym_laplace(y, mu, sigma, quantile, + pasym_laplace(y, mu, sigma, quantile, lower.tail = FALSE, log = TRUE)) - + # wiener diffusion model functions alpha = 2 tau = 0.5 @@ -84,86 +84,86 @@ y <- rWiener(1, alpha, tau, beta, delta) y$resp <- ifelse(y$resp == "lower", 0, 1) expect_equal(wiener_diffusion_lpdf(y$q, y$resp, alpha, tau, beta, delta), - dWiener(y$q, alpha, tau, beta, delta, + dWiener(y$q, alpha, tau, beta, delta, resp = y$resp, log = TRUE)) - + # zero-inflated and hurdle log-densities - draws <- draws2 <- list(eta = matrix(rnorm(4), ncol = 4), + draws <- draws2 <- list(eta = matrix(rnorm(4), ncol = 4), shape = 2, phi = 2, sigma = 2) draws$data <- list(Y = c(0, 10), N_trait = 2, max_obs = 15) draws2$data <- list(Y = c(0, 0.5), N_trait = 2) for (i in seq_along(draws$data$Y)) { - eta_zi_args <- list(y = draws$data$Y[i], eta = draws$eta[i], + eta_zi_args <- list(y = draws$data$Y[i], eta = draws$eta[i], eta_zi = draws$eta[i+2]) zi_args <- list(y = draws$data$Y[i], eta = draws$eta[i], zi = inv_logit(eta_zi_args$eta_zi)) - eta_hu_args <- list(y = draws$data$Y[i], eta = draws$eta[i], + eta_hu_args <- list(y = draws$data$Y[i], eta = draws$eta[i], eta_hu = draws$eta[i+2]) hu_args <- list(y = draws$data$Y[i], eta = draws$eta[i], hu = inv_logit(eta_hu_args$eta_hu)) draws$f$link <- "log" - + expect_equal(do.call(zero_inflated_poisson_lpmf, zi_args), loglik_zero_inflated_poisson(i, draws)) expect_equal(do.call(zero_inflated_poisson_logit_lpmf, eta_zi_args), loglik_zero_inflated_poisson(i, draws)) - - expect_equal(do.call(zero_inflated_neg_binomial_lpmf, + + expect_equal(do.call(zero_inflated_neg_binomial_lpmf, c(zi_args, shape = draws$shape)), loglik_zero_inflated_negbinomial(i, draws)) - expect_equal(do.call(zero_inflated_neg_binomial_logit_lpmf, + expect_equal(do.call(zero_inflated_neg_binomial_logit_lpmf, c(eta_zi_args, shape = draws$shape)), loglik_zero_inflated_negbinomial(i, draws)) - + expect_equal(do.call(hurdle_poisson_lpmf, hu_args), loglik_hurdle_poisson(i, draws)) expect_equal(do.call(hurdle_poisson_logit_lpmf, eta_hu_args), loglik_hurdle_poisson(i, draws)) - - expect_equal(do.call(hurdle_neg_binomial_lpmf, + + expect_equal(do.call(hurdle_neg_binomial_lpmf, c(hu_args, shape = draws$shape)), loglik_hurdle_negbinomial(i, draws)) - expect_equal(do.call(hurdle_neg_binomial_logit_lpmf, + expect_equal(do.call(hurdle_neg_binomial_logit_lpmf, c(eta_hu_args, shape = draws$shape)), loglik_hurdle_negbinomial(i, draws)) - - expect_equal(do.call(hurdle_gamma_lpdf, + + expect_equal(do.call(hurdle_gamma_lpdf, c(hu_args, shape = draws$shape)), loglik_hurdle_gamma(i, draws)) - expect_equal(do.call(hurdle_gamma_logit_lpdf, + expect_equal(do.call(hurdle_gamma_logit_lpdf, c(eta_hu_args, shape = draws$shape)), loglik_hurdle_gamma(i, draws)) - + draws$f$link <- "identity" - expect_equal(do.call(hurdle_lognormal_lpdf, + expect_equal(do.call(hurdle_lognormal_lpdf, c(hu_args, sigma = draws$sigma)), loglik_hurdle_lognormal(i, draws)) - expect_equal(do.call(hurdle_lognormal_logit_lpdf, + expect_equal(do.call(hurdle_lognormal_logit_lpdf, c(eta_hu_args, sigma = draws$sigma)), loglik_hurdle_lognormal(i, draws)) - + draws$f$link <- "logit" - expect_equal(do.call(zero_inflated_binomial_lpmf, + expect_equal(do.call(zero_inflated_binomial_lpmf, c(zi_args, trials = draws$data$max_obs)), loglik_zero_inflated_binomial(i, draws)) - expect_equal(do.call(zero_inflated_binomial_logit_lpmf, + expect_equal(do.call(zero_inflated_binomial_logit_lpmf, c(eta_zi_args, trials = draws$data$max_obs)), loglik_zero_inflated_binomial(i, draws)) - + # zero_inflated_beta requires Y to be in (0,1) draws2$f$link <- "logit" - eta_zi_args <- list(y = draws2$data$Y[i], eta = draws$eta[i], + eta_zi_args <- list(y = draws2$data$Y[i], eta = draws$eta[i], eta_zi = draws$eta[i+2]) zi_args <- list(y = draws2$data$Y[i], eta = draws$eta[i], zi = inv_logit(eta_zi_args$eta_zi)) - expect_equal(do.call(zero_inflated_beta_lpdf, + expect_equal(do.call(zero_inflated_beta_lpdf, c(zi_args, phi = draws$phi)), loglik_zero_inflated_beta(i, draws2)) - expect_equal(do.call(zero_inflated_beta_logit_lpdf, + expect_equal(do.call(zero_inflated_beta_logit_lpdf, c(eta_zi_args, phi = draws$phi)), loglik_zero_inflated_beta(i, draws2)) } - + # ordinal log-densities eta <- rnorm(1) etap <- array(rnorm(6), dim = c(2, 1, 3)) @@ -186,24 +186,24 @@ draws$f$link <- "cauchit" expect_equal(acat_lpmf(draws$data$Y, eta, etap[1, , ], thres), loglik_acat(1, draws)[1]) - + # kronecker product A <- matrix(c(3, 2, 1, 2, 4, 1, 1, 1, 5), nrow = 3) B <- matrix(c(3, 2, 2, 4), nrow = 2) sd <- c(2, 7) expect_equal(t(chol(base::kronecker(A, diag(sd) %*% B %*% diag(sd)))), kronecker(t(chol(A)), diag(sd) %*% t(chol(B)))) - + # as_matrix - expect_equal(as_matrix(1:28, 4, 7), + expect_equal(as_matrix(1:28, 4, 7), rbind(1:7, 8:14, 15:21, 22:28)) expect_equal(as_matrix(1:28, 3, 4), rbind(1:4, 5:8, 9:12)) - + # cauchit and cloglog link - expect_equal(inv_cauchit(1.5), pcauchy(1.5)) + expect_equal(inv_cauchit(1.5), pcauchy(1.5)) expect_equal(cauchit(0.7), qcauchy(0.7)) expect_equal(cloglog(0.2), link(0.2, "cloglog")) - + # monotonic # slightly arkward way to call this function to make sure # is doesn't conflict with the brms R function of the same name diff -Nru r-cran-brms-2.16.3/tests/testthat.R r-cran-brms-2.17.0/tests/testthat.R --- r-cran-brms-2.16.3/tests/testthat.R 2018-02-01 15:52:41.000000000 +0000 +++ r-cran-brms-2.17.0/tests/testthat.R 2021-12-20 13:50:54.000000000 +0000 @@ -1,4 +1,4 @@ -library(testthat) -library(brms) - -test_check("brms") +library(testthat) +library(brms) + +test_check("brms") diff -Nru r-cran-brms-2.16.3/vignettes/brms_customfamilies.Rmd r-cran-brms-2.17.0/vignettes/brms_customfamilies.Rmd --- r-cran-brms-2.16.3/vignettes/brms_customfamilies.Rmd 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_customfamilies.Rmd 2022-04-11 07:20:51.000000000 +0000 @@ -1,341 +1,342 @@ ---- -title: "Define Custom Response Distributions with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Define Custom Response Distributions with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -The **brms** package comes with a lot of built-in response distributions -- -usually called *families* in R -- to specify among others linear, count data, -survival, response times, or ordinal models (see `help(brmsfamily)` for an -overview). Despite supporting over two dozen families, there is still a long -list of distributions, which are not natively supported. The present vignette -will explain how to specify such *custom families* in **brms**. By doing that, -users can benefit from the modeling flexibility and post-processing options of -**brms** even when using self-defined response distributions. -If you have built a custom family that you want to make available to other -users, you can submit a pull request to this -[GitHub repository](https://github.com/paul-buerkner/custom-brms-families). - -## A Case Study - -As a case study, we will use the `cbpp` data of the **lme4** package, which -describes the development of the CBPP disease of cattle in Africa. The data set -contains four variables: `period` (the time period), `herd` (a factor -identifying the cattle herd), `incidence` (number of new disease cases for a -given herd and time period), as well as `size` (the herd size at the beginning -of a given time period). - -```{r cbpp} -data("cbpp", package = "lme4") -head(cbpp) -``` - -In a first step, we will be predicting `incidence` using a simple binomial -model, which will serve as our baseline model. For observed number of events $y$ -(`incidence` in our case) and total number of trials $T$ (`size`), the -probability mass function of the binomial distribution is defined as - -$$ -P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} -$$ - -where $p$ is the event probability. In the classical binomial model, we will -directly predict $p$ on the logit-scale, which means that for each observation -$i$ we compute the success probability $p_i$ as - -$$ -p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} -$$ - -where $\eta_i$ is the linear predictor term of observation $i$ (see -`vignette("brms_overview")` for more details on linear predictors in **brms**). -Predicting `incidence` by `period` and a varying intercept of `herd` is straight -forward in **brms**: - -```{r fit1, results='hide'} -fit1 <- brm(incidence | trials(size) ~ period + (1|herd), - data = cbpp, family = binomial()) -``` - -In the summary output, we see that the incidence probability varies -substantially over herds, but reduces over the course of the time as indicated -by the negative coefficients of `period`. - -```{r fit1_summary} -summary(fit1) -``` - -A drawback of the binomial model is that -- after taking into account the linear -predictor -- its variance is fixed to $\text{Var}(y_i) = T_i p_i (1 - p_i)$. All -variance exceeding this value cannot be not taken into account by the model. -There are multiple ways of dealing with this so called *overdispersion* and the -solution described below will serve as an illustrative example of how to define -custom families in **brms**. - - -## The Beta-Binomial Distribution - -The *beta-binomial* model is a generalization of the *binomial* model -with an additional parameter to account for overdispersion. In the beta-binomial -model, we do not predict the binomial probability $p_i$ directly, but assume it -to be beta distributed with hyperparameters $\alpha > 0$ and $\beta > 0$: - -$$ -p_i \sim \text{Beta}(\alpha_i, \beta_i) -$$ - -The $\alpha$ and $\beta$ parameters are both hard to interpret and generally -not recommended for use in regression models. Thus, we will apply a different -parameterization with parameters $\mu \in [0, 1]$ and $\phi > 0$, which we will -call $\text{Beta2}$: - -$$ -\text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) -$$ - -The parameters $\mu$ and $\phi$ specify the mean and precision parameter, -respectively. By defining - -$$ -\mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} -$$ - -we still predict the expected probability by means of our transformed linear -predictor (as in the original binomial model), but account for potential -overdispersion via the parameter $\phi$. - - -## Fitting Custom Family Models - -The beta-binomial distribution is not natively supported in **brms** and so we -will have to define it ourselves using the `custom_family` function. This -function requires the family's name, the names of its parameters (`mu` and `phi` -in our case), corresponding link functions (only applied if parameters are -predicted), their theoretical lower and upper bounds (only applied if parameters -are not predicted), information on whether the distribution is discrete or -continuous, and finally, whether additional non-parameter variables need to be -passed to the distribution. For our beta-binomial example, this results in the -following custom family: - -```{r beta_binomial2} -beta_binomial2 <- custom_family( - "beta_binomial2", dpars = c("mu", "phi"), - links = c("logit", "log"), lb = c(NA, 0), - type = "int", vars = "vint1[n]" -) -``` - -The name `vint1` for the variable containing the number of trials is not chosen -arbitrarily as we will see below. Next, we have to provide the relevant **Stan** -functions if the distribution is not defined in **Stan** itself. For the -`beta_binomial2` distribution, this is straight forward since the ordinal -`beta_binomial` distribution is already implemented. - -```{r stan_funs} -stan_funs <- " - real beta_binomial2_lpmf(int y, real mu, real phi, int T) { - return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); - } - int beta_binomial2_rng(real mu, real phi, int T) { - return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); - } -" -``` - -For the model fitting, we will only need `beta_binomial2_lpmf`, but -`beta_binomial2_rng` will come in handy when it comes to post-processing. -We define: - -```{r stanvars} -stanvars <- stanvar(scode = stan_funs, block = "functions") -``` - -To provide information about the number of trials (an integer variable), we are -going to use the addition argument `vint()`, which can only be used in custom -families. Similarly, if we needed to include additional vectors of real data, we -would use `vreal()`. Actually, for this particular example, we could more -elegantly apply the addition argument `trials()` instead of `vint()`as in the -basic binomial model. However, since the present vignette is meant to give a -general overview of the topic, we will go with the more general method. - -We now have all components together to fit our custom beta-binomial model: - -```{r fit2, results='hide'} -fit2 <- brm( - incidence | vint(size) ~ period + (1|herd), data = cbpp, - family = beta_binomial2, stanvars = stanvars -) -``` - -The summary output reveals that the uncertainty in the coefficients of `period` -is somewhat larger than in the basic binomial model, which is the result of -including the overdispersion parameter `phi` in the model. Apart from that, the -results looks pretty similar. - -```{r summary_fit2} -summary(fit2) -``` - - -## Post-Processing Custom Family Models - -Some post-processing methods such as `summary` or `plot` work out of the box for -custom family models. However, there are three particularly important methods, -which require additional input by the user. These are `posterior_epred`, -`posterior_predict` and `log_lik` computing predicted mean values, predicted -response values, and log-likelihood values, respectively. They are not only -relevant for their own sake, but also provide the basis of many other -post-processing methods. For instance, we may be interested in comparing the fit -of the binomial model with that of the beta-binomial model by means of -approximate leave-one-out cross-validation implemented in method `loo`, which in -turn requires `log_lik` to be working. - -The `log_lik` function of a family should be named `log_lik_` and -have the two arguments `i` (indicating observations) and `prep`. You don't have -to worry too much about how `prep` is created (if you are interested, check -out the `prepare_predictions` function). Instead, all you need to know is -that parameters are stored in slot `dpars` and data are stored in slot `data`. -Generally, parameters take on the form of a $S \times N$ matrix (with $S =$ -number of posterior draws and $N =$ number of observations) if they are -predicted (as is `mu` in our example) and a vector of size $N$ if the are not -predicted (as is `phi`). - -We could define the complete log-likelihood function in R directly, or we can -expose the self-defined **Stan** functions and apply them. The latter approach -is usually more convenient, but the former is more stable and the only option -when implementing custom families in other R packages building upon **brms**. -For the purpose of the present vignette, we will go with the latter approach. - -```{r} -expose_functions(fit2, vectorize = TRUE) -``` - -and define the required `log_lik` functions with a few lines of code. - -```{r log_lik} -log_lik_beta_binomial2 <- function(i, prep) { - mu <- brms::get_dpar(prep, "mu", i = i) - phi <- brms::get_dpar(prep, "phi", i = i) - trials <- prep$data$vint1[i] - y <- prep$data$Y[i] - beta_binomial2_lpmf(y, mu, phi, trials) -} -``` - -The `get_dpar` function will do the necessary transformations to handle both -the case when the distributional parameters are predicted separately for each -row and when they are the same for the whole fit. - -With that being done, all of the post-processing methods requiring `log_lik` -will work as well. For instance, model comparison can simply be performed via - -```{r loo} -loo(fit1, fit2) -``` - -Since larger `ELPD` values indicate better fit, we see that the beta-binomial -model fits somewhat better, although the corresponding standard error reveals -that the difference is not that substantial. - -Next, we will define the function necessary for the `posterior_predict` method: - -```{r posterior_predict} -posterior_predict_beta_binomial2 <- function(i, prep, ...) { - mu <- brms::get_dpar(prep, "mu", i = i) - phi <- brms::get_dpar(prep, "phi", i = i) - trials <- prep$data$vint1[i] - beta_binomial2_rng(mu, phi, trials) -} -``` - -The `posterior_predict` function looks pretty similar to the corresponding -`log_lik` function, except that we are now creating random draws of the -response instead of log-likelihood values. Again, we are using an exposed -**Stan** function for convenience. Make sure to add a `...` argument to your -`posterior_predict` function even if you are not using it, since some families -require additional arguments. With `posterior_predict` to be working, we can -engage for instance in posterior-predictive checking: - -```{r pp_check} -pp_check(fit2) -``` - -When defining the `posterior_epred` function, you have to keep in mind that it -has only a `prep` argument and should compute the mean response values for all -observations at once. Since the mean of the beta-binomial distribution is -$\text{E}(y) = \mu T$ definition of the corresponding `posterior_epred` function -is not too complicated, but we need to get the dimension of parameters and data -in line. - -```{r posterior_epred} -posterior_epred_beta_binomial2 <- function(prep) { - mu <- brms::get_dpar(prep, "mu") - trials <- prep$data$vint1 - trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) - mu * trials -} -``` - -A post-processing method relying directly on `posterior_epred` is -`conditional_effects`, which allows to visualize effects of predictors. - -```{r conditional_effects} -conditional_effects(fit2, conditions = data.frame(size = 1)) -``` - -For ease of interpretation we have set `size` to 1 so that the y-axis of the -above plot indicates probabilities. - - -## Turning a Custom Family into a Native Family - -Family functions built natively into **brms** are safer to use and more -convenient, as they require much less user input. If you think that your custom -family is general enough to be useful to other users, please feel free to open -an issue on [GitHub](https://github.com/paul-buerkner/brms/issues) so that we -can discuss all the details. Provided that we agree it makes sense to implement -your family natively in brms, the following steps are required (`foo` is a -placeholder for the family name): - -* In `family-lists.R`, add function `.family_foo` which should contain basic -information about your family (you will find lots of examples for other families -there). -* In `families.R`, add family function `foo` which should be a simple wrapper -around `.brmsfamily`. -* In `stan-likelihood.R`, add function `stan_log_lik_foo` which provides the -likelihood of the family in Stan language. -* If necessary, add self-defined Stan functions in separate files under -`inst/chunks`. -* Add functions `posterior_predict_foo`, `posterior_epred_foo` and `log_lik_foo` -to `posterior_predict.R`, `posterior_epred.R` and `log_lik.R`, respectively. -* If necessary, add distribution functions to `distributions.R`. +--- +title: "Define Custom Response Distributions with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Define Custom Response Distributions with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +The **brms** package comes with a lot of built-in response distributions -- +usually called *families* in R -- to specify among others linear, count data, +survival, response times, or ordinal models (see `help(brmsfamily)` for an +overview). Despite supporting over two dozen families, there is still a long +list of distributions, which are not natively supported. The present vignette +will explain how to specify such *custom families* in **brms**. By doing that, +users can benefit from the modeling flexibility and post-processing options of +**brms** even when using self-defined response distributions. +If you have built a custom family that you want to make available to other +users, you can submit a pull request to this +[GitHub repository](https://github.com/paul-buerkner/custom-brms-families). + +## A Case Study + +As a case study, we will use the `cbpp` data of the **lme4** package, which +describes the development of the CBPP disease of cattle in Africa. The data set +contains four variables: `period` (the time period), `herd` (a factor +identifying the cattle herd), `incidence` (number of new disease cases for a +given herd and time period), as well as `size` (the herd size at the beginning +of a given time period). + +```{r cbpp} +data("cbpp", package = "lme4") +head(cbpp) +``` + +In a first step, we will be predicting `incidence` using a simple binomial +model, which will serve as our baseline model. For observed number of events $y$ +(`incidence` in our case) and total number of trials $T$ (`size`), the +probability mass function of the binomial distribution is defined as + +$$ +P(y | T, p) = \binom{T}{y} p^{y} (1 - p)^{N-y} +$$ + +where $p$ is the event probability. In the classical binomial model, we will +directly predict $p$ on the logit-scale, which means that for each observation +$i$ we compute the success probability $p_i$ as + +$$ +p_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} +$$ + +where $\eta_i$ is the linear predictor term of observation $i$ (see +`vignette("brms_overview")` for more details on linear predictors in **brms**). +Predicting `incidence` by `period` and a varying intercept of `herd` is straight +forward in **brms**: + +```{r fit1, results='hide'} +fit1 <- brm(incidence | trials(size) ~ period + (1|herd), + data = cbpp, family = binomial()) +``` + +In the summary output, we see that the incidence probability varies +substantially over herds, but reduces over the course of the time as indicated +by the negative coefficients of `period`. + +```{r fit1_summary} +summary(fit1) +``` + +A drawback of the binomial model is that -- after taking into account the linear +predictor -- its variance is fixed to $\text{Var}(y_i) = T_i p_i (1 - p_i)$. All +variance exceeding this value cannot be not taken into account by the model. +There are multiple ways of dealing with this so called *overdispersion* and the +solution described below will serve as an illustrative example of how to define +custom families in **brms**. + + +## The Beta-Binomial Distribution + +The *beta-binomial* model is a generalization of the *binomial* model +with an additional parameter to account for overdispersion. In the beta-binomial +model, we do not predict the binomial probability $p_i$ directly, but assume it +to be beta distributed with hyperparameters $\alpha > 0$ and $\beta > 0$: + +$$ +p_i \sim \text{Beta}(\alpha_i, \beta_i) +$$ + +The $\alpha$ and $\beta$ parameters are both hard to interpret and generally +not recommended for use in regression models. Thus, we will apply a different +parameterization with parameters $\mu \in [0, 1]$ and $\phi > 0$, which we will +call $\text{Beta2}$: + +$$ +\text{Beta2}(\mu, \phi) = \text{Beta}(\mu \phi, (1-\mu) \phi) +$$ + +The parameters $\mu$ and $\phi$ specify the mean and precision parameter, +respectively. By defining + +$$ +\mu_i = \frac{\exp(\eta_i)}{1 + \exp(\eta_i)} +$$ + +we still predict the expected probability by means of our transformed linear +predictor (as in the original binomial model), but account for potential +overdispersion via the parameter $\phi$. + + +## Fitting Custom Family Models + +The beta-binomial distribution is natively supported in **brms** nowadays, but +we will still use it as an example to define it ourselves via the +`custom_family` function. This function requires the family's name, the names of +its parameters (`mu` and `phi` in our case), corresponding link functions (only +applied if parameters are predicted), their theoretical lower and upper bounds +(only applied if parameters are not predicted), information on whether the +distribution is discrete or continuous, and finally, whether additional +non-parameter variables need to be passed to the distribution. For our +beta-binomial example, this results in the following custom family: + +```{r beta_binomial2} +beta_binomial2 <- custom_family( + "beta_binomial2", dpars = c("mu", "phi"), + links = c("logit", "log"), + lb = c(0, 0), ub = c(1, NA), + type = "int", vars = "vint1[n]" +) +``` + +The name `vint1` for the variable containing the number of trials is not chosen +arbitrarily as we will see below. Next, we have to provide the relevant **Stan** +functions if the distribution is not defined in **Stan** itself. For the +`beta_binomial2` distribution, this is straight forward since the ordinal +`beta_binomial` distribution is already implemented. + +```{r stan_funs} +stan_funs <- " + real beta_binomial2_lpmf(int y, real mu, real phi, int T) { + return beta_binomial_lpmf(y | T, mu * phi, (1 - mu) * phi); + } + int beta_binomial2_rng(real mu, real phi, int T) { + return beta_binomial_rng(T, mu * phi, (1 - mu) * phi); + } +" +``` + +For the model fitting, we will only need `beta_binomial2_lpmf`, but +`beta_binomial2_rng` will come in handy when it comes to post-processing. +We define: + +```{r stanvars} +stanvars <- stanvar(scode = stan_funs, block = "functions") +``` + +To provide information about the number of trials (an integer variable), we are +going to use the addition argument `vint()`, which can only be used in custom +families. Similarly, if we needed to include additional vectors of real data, we +would use `vreal()`. Actually, for this particular example, we could more +elegantly apply the addition argument `trials()` instead of `vint()`as in the +basic binomial model. However, since the present vignette is meant to give a +general overview of the topic, we will go with the more general method. + +We now have all components together to fit our custom beta-binomial model: + +```{r fit2, results='hide'} +fit2 <- brm( + incidence | vint(size) ~ period + (1|herd), data = cbpp, + family = beta_binomial2, stanvars = stanvars +) +``` + +The summary output reveals that the uncertainty in the coefficients of `period` +is somewhat larger than in the basic binomial model, which is the result of +including the overdispersion parameter `phi` in the model. Apart from that, the +results looks pretty similar. + +```{r summary_fit2} +summary(fit2) +``` + + +## Post-Processing Custom Family Models + +Some post-processing methods such as `summary` or `plot` work out of the box for +custom family models. However, there are three particularly important methods, +which require additional input by the user. These are `posterior_epred`, +`posterior_predict` and `log_lik` computing predicted mean values, predicted +response values, and log-likelihood values, respectively. They are not only +relevant for their own sake, but also provide the basis of many other +post-processing methods. For instance, we may be interested in comparing the fit +of the binomial model with that of the beta-binomial model by means of +approximate leave-one-out cross-validation implemented in method `loo`, which in +turn requires `log_lik` to be working. + +The `log_lik` function of a family should be named `log_lik_` and +have the two arguments `i` (indicating observations) and `prep`. You don't have +to worry too much about how `prep` is created (if you are interested, check +out the `prepare_predictions` function). Instead, all you need to know is +that parameters are stored in slot `dpars` and data are stored in slot `data`. +Generally, parameters take on the form of a $S \times N$ matrix (with $S =$ +number of posterior draws and $N =$ number of observations) if they are +predicted (as is `mu` in our example) and a vector of size $N$ if the are not +predicted (as is `phi`). + +We could define the complete log-likelihood function in R directly, or we can +expose the self-defined **Stan** functions and apply them. The latter approach +is usually more convenient, but the former is more stable and the only option +when implementing custom families in other R packages building upon **brms**. +For the purpose of the present vignette, we will go with the latter approach. + +```{r} +expose_functions(fit2, vectorize = TRUE) +``` + +and define the required `log_lik` functions with a few lines of code. + +```{r log_lik} +log_lik_beta_binomial2 <- function(i, prep) { + mu <- brms::get_dpar(prep, "mu", i = i) + phi <- brms::get_dpar(prep, "phi", i = i) + trials <- prep$data$vint1[i] + y <- prep$data$Y[i] + beta_binomial2_lpmf(y, mu, phi, trials) +} +``` + +The `get_dpar` function will do the necessary transformations to handle both +the case when the distributional parameters are predicted separately for each +row and when they are the same for the whole fit. + +With that being done, all of the post-processing methods requiring `log_lik` +will work as well. For instance, model comparison can simply be performed via + +```{r loo} +loo(fit1, fit2) +``` + +Since larger `ELPD` values indicate better fit, we see that the beta-binomial +model fits somewhat better, although the corresponding standard error reveals +that the difference is not that substantial. + +Next, we will define the function necessary for the `posterior_predict` method: + +```{r posterior_predict} +posterior_predict_beta_binomial2 <- function(i, prep, ...) { + mu <- brms::get_dpar(prep, "mu", i = i) + phi <- brms::get_dpar(prep, "phi", i = i) + trials <- prep$data$vint1[i] + beta_binomial2_rng(mu, phi, trials) +} +``` + +The `posterior_predict` function looks pretty similar to the corresponding +`log_lik` function, except that we are now creating random draws of the +response instead of log-likelihood values. Again, we are using an exposed +**Stan** function for convenience. Make sure to add a `...` argument to your +`posterior_predict` function even if you are not using it, since some families +require additional arguments. With `posterior_predict` to be working, we can +engage for instance in posterior-predictive checking: + +```{r pp_check} +pp_check(fit2) +``` + +When defining the `posterior_epred` function, you have to keep in mind that it +has only a `prep` argument and should compute the mean response values for all +observations at once. Since the mean of the beta-binomial distribution is +$\text{E}(y) = \mu T$ definition of the corresponding `posterior_epred` function +is not too complicated, but we need to get the dimension of parameters and data +in line. + +```{r posterior_epred} +posterior_epred_beta_binomial2 <- function(prep) { + mu <- brms::get_dpar(prep, "mu") + trials <- prep$data$vint1 + trials <- matrix(trials, nrow = nrow(mu), ncol = ncol(mu), byrow = TRUE) + mu * trials +} +``` + +A post-processing method relying directly on `posterior_epred` is +`conditional_effects`, which allows to visualize effects of predictors. + +```{r conditional_effects} +conditional_effects(fit2, conditions = data.frame(size = 1)) +``` + +For ease of interpretation we have set `size` to 1 so that the y-axis of the +above plot indicates probabilities. + + +## Turning a Custom Family into a Native Family + +Family functions built natively into **brms** are safer to use and more +convenient, as they require much less user input. If you think that your custom +family is general enough to be useful to other users, please feel free to open +an issue on [GitHub](https://github.com/paul-buerkner/brms/issues) so that we +can discuss all the details. Provided that we agree it makes sense to implement +your family natively in brms, the following steps are required (`foo` is a +placeholder for the family name): + +* In `family-lists.R`, add function `.family_foo` which should contain basic +information about your family (you will find lots of examples for other families +there). +* In `families.R`, add family function `foo` which should be a simple wrapper +around `.brmsfamily`. +* In `stan-likelihood.R`, add function `stan_log_lik_foo` which provides the +likelihood of the family in Stan language. +* If necessary, add self-defined Stan functions in separate files under +`inst/chunks`. +* Add functions `posterior_predict_foo`, `posterior_epred_foo` and `log_lik_foo` +to `posterior_predict.R`, `posterior_epred.R` and `log_lik.R`, respectively. +* If necessary, add distribution functions to `distributions.R`. diff -Nru r-cran-brms-2.16.3/vignettes/brms_distreg.Rmd r-cran-brms-2.17.0/vignettes/brms_distreg.Rmd --- r-cran-brms-2.16.3/vignettes/brms_distreg.Rmd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_distreg.Rmd 2022-04-11 07:20:41.000000000 +0000 @@ -1,254 +1,254 @@ ---- -title: "Estimating Distributional Models with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Distributional Models with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -This vignette provides an introduction on how to fit distributional regression -models with **brms**. We use the term *distributional model* to refer to a -model, in which we can specify predictor terms for all parameters of the assumed -response distribution. In the vast majority of regression model implementations, -only the location parameter (usually the mean) of the response distribution -depends on the predictors and corresponding regression parameters. Other -parameters (e.g., scale or shape parameters) are estimated as auxiliary -parameters assuming them to be constant across observations. This assumption is -so common that most researchers applying regression models are often (in my -experience) not aware of the possibility of relaxing it. This is understandable -insofar as relaxing this assumption drastically increase model complexity and -thus makes models hard to fit. Fortunately, **brms** uses **Stan** on the -backend, which is an incredibly flexible and powerful tool for estimating -Bayesian models so that model complexity is much less of an issue. - -Suppose we have a normally distributed response variable. Then, in basic linear -regression, we specify a predictor term $\eta_{\mu}$ for the mean parameter -$\mu$ of the normal distribution. The second parameter of the normal -distribution -- the residual standard deviation $\sigma$ -- is assumed to be -constant across observations. We estimate $\sigma$ but do not try to *predict* -it. In a distributional model, however, we do exactly this by specifying a -predictor term $\eta_{\sigma}$ for $\sigma$ in addition to the predictor term -$\eta_{\mu}$. Ignoring group-level effects for the moment, the linear predictor -of a parameter $\theta$ for observation $n$ has the form - -$$\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}$$ -where $x_{\theta i n}$ denotes the value of the $i$th predictor of parameter -$\theta$ for observation $n$ and $b_{\theta i}$ is the $i$th regression -coefficient of parameter $\theta$. A distributional normal model with response -variable $y$ can then be written as - -$$y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)$$ -We used the exponential function around $\eta_{\sigma}$ to reflect that $\sigma$ -constitutes a standard deviation and thus only takes on positive values, while a -linear predictor can be any real number. - -## A simple distributional model - -Unequal variance models are possibly the most simple, but nevertheless very -important application of distributional models. Suppose we have two groups of -patients: One group receives a treatment (e.g., an antidepressive drug) and -another group receives placebo. Since the treatment may not work equally well -for all patients, the symptom variance of the treatment group may be larger than -the symptom variance of the placebo group after some weeks of treatment. For -simplicity, assume that we only investigate the post-treatment values. - -```{r} -group <- rep(c("treat", "placebo"), each = 30) -symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) -dat1 <- data.frame(group, symptom_post) -head(dat1) -``` - -The following model estimates the effect of `group` on both the mean and the -residual standard deviation of the normal response distribution. - -```{r, results='hide'} -fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), - data = dat1, family = gaussian()) -``` - -Useful summary statistics and plots can be obtained via - -```{r, results='hide'} -summary(fit1) -plot(fit1, N = 2, ask = FALSE) -plot(conditional_effects(fit1), points = TRUE) -``` - -The population-level effect `sigma_grouptreat`, which is the contrast of the two -residual standard deviations on the log-scale, reveals that the variances of -both groups are indeed different. This impression is confirmed when looking at -the `conditional_effects` of `group`. Going one step further, we can compute the -residual standard deviations on the original scale using the `hypothesis` -method. - -```{r} -hyp <- c("exp(sigma_Intercept) = 0", - "exp(sigma_Intercept + sigma_grouptreat) = 0") -hypothesis(fit1, hyp) -``` - -We may also directly compare them and plot the posterior distribution of their -difference. - -```{r} -hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" -(hyp <- hypothesis(fit1, hyp)) -plot(hyp, chars = NULL) -``` - -Indeed, the residual standard deviation of the treatment group seems to larger -than that of the placebo group. Moreover the magnitude of this difference is -pretty similar to what we expected due to the values we put into the data -simulations. - -## Zero-Inflated Models - -Another important application of the distributional regression framework are so -called zero-inflated models. These models are helpful whenever there are more -zeros in the response variable than one would naturally expect. For example, if -one seeks to predict the number of cigarettes people smoke per day and also -includes non-smokers, there will be a huge amount of zeros which, when not -modeled appropriately, can seriously distort parameter estimates. Here, we -consider an example dealing with the number of fish caught by various groups of -people. On the UCLA website -(\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), -the data are described as follows: "The state wildlife biologists want to model -how many fish are being caught by fishermen at a state park. Visitors are asked -how long they stayed, how many people were in the group, were there children in -the group and how many fish were caught. Some visitors do not fish, but there is -no data on whether a person fished or not. Some visitors who did fish did not -catch any fish so there are excess zeros in the data because of the people that -did not fish." - -```{r} -zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") -head(zinb) -``` - -As predictors we choose the number of people per group, the number of children, -as well as whether the group consists of campers. Many groups may not even try -catching any fish at all (thus leading to many zero responses) and so we fit a -zero-inflated Poisson model to the data. For now, we assume a constant -zero-inflation probability across observations. - -```{r, results='hide'} -fit_zinb1 <- brm(count ~ persons + child + camper, - data = zinb, family = zero_inflated_poisson()) -``` - -Again, we summarize the results using the usual methods. - -```{r} -summary(fit_zinb1) -plot(conditional_effects(fit_zinb1), ask = FALSE) -``` - -According to the parameter estimates, larger groups catch more fish, campers -catch more fish than non-campers, and groups with more children catch less fish. -The zero-inflation probability `zi` is pretty large with a mean of 41%. Please -note that the probability of catching no fish is actually higher than 41%, but -parts of this probability are already modeled by the Poisson distribution itself -(hence the name zero-*inflation*). If you want to treat all zeros as originating -from a separate process, you can use hurdle models instead (not shown here). - -Now, we try to additionally predict the zero-inflation probability by the number -of children. The underlying reasoning is that we expect groups with more -children to not even try catching fish. Most children are just terribly bad at -waiting for hours until something happens. From a purely statistical -perspective, zero-inflated (and hurdle) distributions are a mixture of two -processes and predicting both parts of the model is natural and often very -reasonable to make full use of the data. - -```{r, results='hide'} -fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), - data = zinb, family = zero_inflated_poisson()) -``` - -```{r} -summary(fit_zinb2) -plot(conditional_effects(fit_zinb2), ask = FALSE) -``` - -To transform the linear predictor of `zi` into a probability, **brms** applies -the logit-link: - -$$logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}$$ - -The logit-link takes values within $[0, 1]$ and returns values on the real line. -Thus, it allows the transition between probabilities and linear predictors. - -According to the model, trying to fish with children not only decreases the -overall number fish caught (as implied by the Poisson part of the model) but -also drastically increases your change of catching no fish at all (as implied by -the zero-inflation part) most likely because groups with more children are not -even trying. - -## Additive Distributional Models - -In the examples so far, we did not have multilevel data and thus did not fully -use the capabilities of the distributional regression framework of **brms**. In -the example presented below, we will not only show how to deal with multilevel -data in distributional models, but also how to incorporate smooth terms (i.e., -splines) into the model. In many applications, we have no or only a very vague -idea how the relationship between a predictor and the response looks like. A -very flexible approach to tackle this problems is to use splines and let them -figure out the form of the relationship. For illustration purposes, we simulate -some data with the **mgcv** package, which is also used in **brms** to prepare -smooth terms. - -```{r} -dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) -head(dat_smooth[, 1:6]) -``` - -The data contains the predictors `x0` to `x3` as well as the grouping factor -`fac` indicating the nested structure of the data. We predict the response -variable `y` using smooth terms of `x1` and `x2` and a varying intercept of -`fac`. In addition, we assume the residual standard deviation `sigma` to vary by -a smoothing term of `x0` and a varying intercept of `fac`. - -```{r, results='hide'} -fit_smooth1 <- brm( - bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), - data = dat_smooth, family = gaussian(), - chains = 2, control = list(adapt_delta = 0.95) -) -``` - -```{r} -summary(fit_smooth1) -plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) -``` - -This model is likely an overkill for the data at hand, but nicely demonstrates -the ease with which one can specify complex models with **brms** and to fit them -using **Stan** on the backend. +--- +title: "Estimating Distributional Models with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Distributional Models with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +This vignette provides an introduction on how to fit distributional regression +models with **brms**. We use the term *distributional model* to refer to a +model, in which we can specify predictor terms for all parameters of the assumed +response distribution. In the vast majority of regression model implementations, +only the location parameter (usually the mean) of the response distribution +depends on the predictors and corresponding regression parameters. Other +parameters (e.g., scale or shape parameters) are estimated as auxiliary +parameters assuming them to be constant across observations. This assumption is +so common that most researchers applying regression models are often (in my +experience) not aware of the possibility of relaxing it. This is understandable +insofar as relaxing this assumption drastically increase model complexity and +thus makes models hard to fit. Fortunately, **brms** uses **Stan** on the +backend, which is an incredibly flexible and powerful tool for estimating +Bayesian models so that model complexity is much less of an issue. + +Suppose we have a normally distributed response variable. Then, in basic linear +regression, we specify a predictor term $\eta_{\mu}$ for the mean parameter +$\mu$ of the normal distribution. The second parameter of the normal +distribution -- the residual standard deviation $\sigma$ -- is assumed to be +constant across observations. We estimate $\sigma$ but do not try to *predict* +it. In a distributional model, however, we do exactly this by specifying a +predictor term $\eta_{\sigma}$ for $\sigma$ in addition to the predictor term +$\eta_{\mu}$. Ignoring group-level effects for the moment, the linear predictor +of a parameter $\theta$ for observation $n$ has the form + +$$\eta_{\theta n} = \sum_{i = 1}^{K_{\theta}} b_{\theta i} x_{\theta i n}$$ +where $x_{\theta i n}$ denotes the value of the $i$th predictor of parameter +$\theta$ for observation $n$ and $b_{\theta i}$ is the $i$th regression +coefficient of parameter $\theta$. A distributional normal model with response +variable $y$ can then be written as + +$$y_n \sim \mathcal{N}\left(\eta_{\mu n}, \, \exp(\eta_{\sigma n}) \right)$$ +We used the exponential function around $\eta_{\sigma}$ to reflect that $\sigma$ +constitutes a standard deviation and thus only takes on positive values, while a +linear predictor can be any real number. + +## A simple distributional model + +Unequal variance models are possibly the most simple, but nevertheless very +important application of distributional models. Suppose we have two groups of +patients: One group receives a treatment (e.g., an antidepressive drug) and +another group receives placebo. Since the treatment may not work equally well +for all patients, the symptom variance of the treatment group may be larger than +the symptom variance of the placebo group after some weeks of treatment. For +simplicity, assume that we only investigate the post-treatment values. + +```{r} +group <- rep(c("treat", "placebo"), each = 30) +symptom_post <- c(rnorm(30, mean = 1, sd = 2), rnorm(30, mean = 0, sd = 1)) +dat1 <- data.frame(group, symptom_post) +head(dat1) +``` + +The following model estimates the effect of `group` on both the mean and the +residual standard deviation of the normal response distribution. + +```{r, results='hide'} +fit1 <- brm(bf(symptom_post ~ group, sigma ~ group), + data = dat1, family = gaussian()) +``` + +Useful summary statistics and plots can be obtained via + +```{r, results='hide'} +summary(fit1) +plot(fit1, N = 2, ask = FALSE) +plot(conditional_effects(fit1), points = TRUE) +``` + +The population-level effect `sigma_grouptreat`, which is the contrast of the two +residual standard deviations on the log-scale, reveals that the variances of +both groups are indeed different. This impression is confirmed when looking at +the `conditional_effects` of `group`. Going one step further, we can compute the +residual standard deviations on the original scale using the `hypothesis` +method. + +```{r} +hyp <- c("exp(sigma_Intercept) = 0", + "exp(sigma_Intercept + sigma_grouptreat) = 0") +hypothesis(fit1, hyp) +``` + +We may also directly compare them and plot the posterior distribution of their +difference. + +```{r} +hyp <- "exp(sigma_Intercept + sigma_grouptreat) > exp(sigma_Intercept)" +(hyp <- hypothesis(fit1, hyp)) +plot(hyp, chars = NULL) +``` + +Indeed, the residual standard deviation of the treatment group seems to larger +than that of the placebo group. Moreover the magnitude of this difference is +pretty similar to what we expected due to the values we put into the data +simulations. + +## Zero-Inflated Models + +Another important application of the distributional regression framework are so +called zero-inflated models. These models are helpful whenever there are more +zeros in the response variable than one would naturally expect. For example, if +one seeks to predict the number of cigarettes people smoke per day and also +includes non-smokers, there will be a huge amount of zeros which, when not +modeled appropriately, can seriously distort parameter estimates. Here, we +consider an example dealing with the number of fish caught by various groups of +people. On the UCLA website +(\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), +the data are described as follows: "The state wildlife biologists want to model +how many fish are being caught by fishermen at a state park. Visitors are asked +how long they stayed, how many people were in the group, were there children in +the group and how many fish were caught. Some visitors do not fish, but there is +no data on whether a person fished or not. Some visitors who did fish did not +catch any fish so there are excess zeros in the data because of the people that +did not fish." + +```{r} +zinb <- read.csv("https://paul-buerkner.github.io/data/fish.csv") +head(zinb) +``` + +As predictors we choose the number of people per group, the number of children, +as well as whether the group consists of campers. Many groups may not even try +catching any fish at all (thus leading to many zero responses) and so we fit a +zero-inflated Poisson model to the data. For now, we assume a constant +zero-inflation probability across observations. + +```{r, results='hide'} +fit_zinb1 <- brm(count ~ persons + child + camper, + data = zinb, family = zero_inflated_poisson()) +``` + +Again, we summarize the results using the usual methods. + +```{r} +summary(fit_zinb1) +plot(conditional_effects(fit_zinb1), ask = FALSE) +``` + +According to the parameter estimates, larger groups catch more fish, campers +catch more fish than non-campers, and groups with more children catch less fish. +The zero-inflation probability `zi` is pretty large with a mean of 41%. Please +note that the probability of catching no fish is actually higher than 41%, but +parts of this probability are already modeled by the Poisson distribution itself +(hence the name zero-*inflation*). If you want to treat all zeros as originating +from a separate process, you can use hurdle models instead (not shown here). + +Now, we try to additionally predict the zero-inflation probability by the number +of children. The underlying reasoning is that we expect groups with more +children to not even try catching fish. Most children are just terribly bad at +waiting for hours until something happens. From a purely statistical +perspective, zero-inflated (and hurdle) distributions are a mixture of two +processes and predicting both parts of the model is natural and often very +reasonable to make full use of the data. + +```{r, results='hide'} +fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), + data = zinb, family = zero_inflated_poisson()) +``` + +```{r} +summary(fit_zinb2) +plot(conditional_effects(fit_zinb2), ask = FALSE) +``` + +To transform the linear predictor of `zi` into a probability, **brms** applies +the logit-link: + +$$logit(zi) = \log\left(\frac{zi}{1-zi}\right) = \eta_{zi}$$ + +The logit-link takes values within $[0, 1]$ and returns values on the real line. +Thus, it allows the transition between probabilities and linear predictors. + +According to the model, trying to fish with children not only decreases the +overall number fish caught (as implied by the Poisson part of the model) but +also drastically increases your change of catching no fish at all (as implied by +the zero-inflation part) most likely because groups with more children are not +even trying. + +## Additive Distributional Models + +In the examples so far, we did not have multilevel data and thus did not fully +use the capabilities of the distributional regression framework of **brms**. In +the example presented below, we will not only show how to deal with multilevel +data in distributional models, but also how to incorporate smooth terms (i.e., +splines) into the model. In many applications, we have no or only a very vague +idea how the relationship between a predictor and the response looks like. A +very flexible approach to tackle this problems is to use splines and let them +figure out the form of the relationship. For illustration purposes, we simulate +some data with the **mgcv** package, which is also used in **brms** to prepare +smooth terms. + +```{r} +dat_smooth <- mgcv::gamSim(eg = 6, n = 200, scale = 2, verbose = FALSE) +head(dat_smooth[, 1:6]) +``` + +The data contains the predictors `x0` to `x3` as well as the grouping factor +`fac` indicating the nested structure of the data. We predict the response +variable `y` using smooth terms of `x1` and `x2` and a varying intercept of +`fac`. In addition, we assume the residual standard deviation `sigma` to vary by +a smoothing term of `x0` and a varying intercept of `fac`. + +```{r, results='hide'} +fit_smooth1 <- brm( + bf(y ~ s(x1) + s(x2) + (1|fac), sigma ~ s(x0) + (1|fac)), + data = dat_smooth, family = gaussian(), + chains = 2, control = list(adapt_delta = 0.95) +) +``` + +```{r} +summary(fit_smooth1) +plot(conditional_effects(fit_smooth1), points = TRUE, ask = FALSE) +``` + +This model is likely an overkill for the data at hand, but nicely demonstrates +the ease with which one can specify complex models with **brms** and to fit them +using **Stan** on the backend. diff -Nru r-cran-brms-2.16.3/vignettes/brms_families.Rmd r-cran-brms-2.17.0/vignettes/brms_families.Rmd --- r-cran-brms-2.16.3/vignettes/brms_families.Rmd 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_families.Rmd 2022-04-08 11:57:41.000000000 +0000 @@ -1,332 +1,349 @@ ---- -title: "Parameterization of Response Distributions in brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Parameterization of Response Distributions in brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} ---- - -The purpose of this vignette is to discuss the parameterizations of the families -(i.e., response distributions) used in brms. For a more general overview of -the package see `vignette("brms_overview")`. - -## Notation - -Throughout this vignette, we denote values of the response variable as $y$, a -density function as $f$, and use $\mu$ to refer to the main model parameter, -which is usually the mean of the response distribution or some closely related -quantity. In a regression framework, $\mu$ is not estimated directly but -computed as $\mu = g(\eta)$, where $\eta$ is a predictor term (see -`help(brmsformula)` for details) and $g$ is the response function (i.e., -inverse of the link function). - -## Location shift models - -The density of the **gaussian** family is given by -$$ -f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) -$$ - -where $\sigma$ is the residual standard deviation. The density of the -**student** family is given by -$$ -f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} -$$ - -$\Gamma$ denotes the gamma function and $\nu > 1$ are the degrees of freedom. As -$\nu \rightarrow \infty$, the student distribution becomes the gaussian -distribution. The density of the **skew_normal** family is given by -$$ -f(y) = \frac{1}{\sqrt{2\pi}\sigma} - \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) -\left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) -$$ - -where $\xi$ is the location parameter, $\omega$ is the positive scale parameter, -$\alpha$ the skewness parameter, and $\text{erf}$ denotes the error function of -the gaussian distribution. To parameterize the skew-normal distribution in terms -of the mean $\mu$ and standard deviation $\sigma$, $\omega$ and $\xi$ are -computed as -$$ -\omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} -$$ - -$$ -\xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} -$$ - -If $\alpha = 0$, the skew-normal distribution becomes the gaussian distribution. -For location shift models, $y$ can be any real value. - -## Binary and count data models - -The density of the **binomial** family is given by -$$ -f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} -$$ -where $N$ is the number of trials and $y \in \{0, ... , N\}$. When all -$N$ are $1$ (i.e., $y \in \{0,1\}$), the **bernoulli** distribution for binary -data arises. - -For $y \in \mathbb{N}_0$, the density of the **poisson** family is given by -$$ -f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) -$$ -The density of the **negbinomial** (negative binomial) family is -$$ -f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} -\left(\frac{\phi}{\mu + \phi}\right)^\phi -$$ -where $\phi$ is a positive precision parameter. For $\phi \rightarrow \infty$, -the negative binomial distribution becomes the poisson distribution. The density -of the **geometric** family arises if $\phi$ is set to $1$. - - - -## Time-to-event models - -With time-to-event models we mean all models that are defined on the positive -reals only, that is $y \in \mathbb{R}^+$. The density of the **lognormal** -family is given by -$$ -f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) -$$ -where $\sigma$ is the residual standard deviation on the log-scale. -The density of the **Gamma** family is given by -$$ -f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} -\exp\left(-\frac{\alpha y}{\mu}\right) -$$ -where $\alpha$ is a positive shape parameter. The density of the **weibull** -family is given by -$$ -f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} -\exp\left(-\left(\frac{y}{s}\right)^\alpha\right) -$$ -where $\alpha$ is again a positive shape parameter and -$s = \mu / \Gamma(1 + 1 / \alpha)$ is the scale parameter to that $\mu$ -is the mean of the distribution. The **exponential** family arises if $\alpha$ -is set to $1$ for either the gamma or Weibull distribution. The density of the -**inverse.gaussian** family is given by -$$ -f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) -$$ -where $\alpha$ is a positive shape parameter. The **cox** family implements Cox -proportional hazards model which assumes a hazard function of the form $h(y) = -h_0(y) \mu$ with baseline hazard $h_0(y)$ expressed via M-splines (which -integrate to I-splines) in order to ensure monotonicity. The density of the cox -model is then given by -$$ -f(y) = h(y) S(y) -$$ -where $S(y)$ is the survival function implied by $h(y)$. - -## Extreme value models - -Modeling extremes requires special distributions. One may use the **weibull** -distribution (see above) or the **frechet** distribution with density -$$ -f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) -$$ -where $s = \mu / \Gamma(1 - 1 / \nu)$ is a positive scale parameter and -$\nu > 1$ is a shape parameter so that $\mu$ predicts the mean of the Frechet -distribution. A generalization of both distributions is the generalized extreme -value distribution (family **gen_extreme_value**) with density -$$ -f(y) = \frac{1}{\sigma} t(y)^{-1 - 1 / \xi} \exp(-t(y)) -$$ -where -$$ -t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} -$$ -with positive scale parameter $\sigma$ and shape parameter $\xi$. - -## Response time models - -One family that is especially suited to model reaction times is the -**exgaussian** ('exponentially modified Gaussian') family. Its density is given -by - -$$ -f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) -$$ -where $\beta$ is the scale (inverse rate) of the exponential component, $\xi$ is -the mean of the Gaussian component, $\sigma$ is the standard deviation of the -Gaussian component, and $\text{erfc}$ is the complementary error function. We -parameterize $\mu = \xi + \beta$ so that the main predictor term equals the -mean of the distribution. - -Another family well suited for modeling response times is the -**shifted_lognormal** distribution. It's density equals that of the -**lognormal** distribution except that the whole distribution is shifted to the -right by a positive parameter called *ndt* (for consistency with the **wiener** -diffusion model explained below). - -A family concerned with the combined modeling of reaction times and -corresponding binary responses is the **wiener** diffusion model. It has four -model parameters each with a natural interpretation. The parameter $\alpha > 0$ -describes the separation between two boundaries of the diffusion process, -$\tau > 0$ describes the non-decision time (e.g., due to image or motor processing), -$\beta \in [0, 1]$ describes the initial bias in favor of the upper alternative, -and $\delta \in \mathbb{R}$ describes the drift rate to the boundaries (a -positive value indicates a drift towards to upper boundary). The density for the -reaction time at the upper boundary is given by - -$$ -f(y) = \frac{\alpha}{(y-\tau)^3/2} -\exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) -\sum_{k = - \infty}^{\infty} (2k + \beta) -\phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) -$$ - -where $\phi(x)$ denotes the standard normal density function. The density at the -lower boundary can be obtained by substituting $1 - \beta$ for $\beta$ and -$-\delta$ for $\delta$ in the above equation. In brms the parameters -$\alpha$, $\tau$, and $\beta$ are modeled as auxiliary parameters named *bs* -('boundary separation'), *ndt* ('non-decision time'), and *bias* respectively, -whereas the drift rate $\delta$ is modeled via the ordinary model formula that -is as $\delta = \mu$. - -## Quantile regression - -Quantile regression is implemented via family **asym_laplace** (asymmetric -Laplace distribution) with density - -$$ -f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) -$$ -where $\rho_p$ is given by $\rho_p(x) = x (p - I_{x < 0})$ and $I_A$ is the -indicator function of set $A$. The parameter $\sigma$ is a positive scale -parameter and $p$ is the *quantile* parameter taking on values in $(0, 1)$. For -this distribution, we have $P(Y < g(\eta)) = p$. Thus, quantile regression can -be performed by fixing $p$ to the quantile to interest. - -## Probability models - -The density of the **Beta** family for $y \in (0,1)$ is given by -$$ -f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} -$$ -where $B$ is the beta function and $\phi$ is a positive precision parameter. -A multivariate generalization of the **Beta** family is the **dirichlet** family -with density -$$ -f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} - \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. -$$ -The **dirichlet** distribution is only implemented with the multivariate logit -link function so that -$$ -\mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} -$$ -For reasons of identifiability, $\eta_{1}$ is set to $0$. - -## Circular models - -The density of the **von_mises** family for $y \in (-\pi,\pi)$ is given by -$$ -f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} -$$ -where $I_0$ is the modified Bessel function of order 0 and $\kappa$ is -a positive precision parameter. - -## Ordinal and categorical models - -For ordinal and categorical models, $y$ is one of the categories $1, ..., K$. -The intercepts of ordinal models are called thresholds and are denoted as -$\tau_k$, with $k \in \{1, ..., K-1\}$, whereas $\eta$ does not contain a fixed -effects intercept. Note that the applied link functions $h$ are technically -distribution functions $\mathbb{R} \rightarrow [0,1]$. The density of the -**cumulative** family (implementing the most basic ordinal model) is given by -$$ -f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) -$$ - -The densities of the **sratio** (stopping ratio) and **cratio** (continuation -ratio) families are given by -$$ -f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) -$$ -and -$$ -f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) -$$ - -respectively. Note that both families are equivalent for symmetric link -functions such as logit or probit. The density of the **acat** (adjacent -category) family is given by -$$ -f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) - \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) - \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} -$$ -For the logit link, this can be simplified to -$$ -f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} - {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} -$$ -The linear predictor $\eta$ can be generalized to also depend on the category -$k$ for a subset of predictors. This leads to category specific -effects (for details on how to specify them see `help(brm)`). Note that -**cumulative** and **sratio** models use $\tau - \eta$, whereas **cratio** and -**acat** use $\eta - \tau$. This is done to ensure that larger values of $\eta$ -increase the probability of *higher* response categories. - -The **categorical** family is currently only implemented with the multivariate -logit link function and has density -$$ -f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} -$$ -Note that $\eta$ does also depend on the category $k$. For reasons of -identifiability, $\eta_{1}$ is set to $0$. A generalization of the -**categorical** family to more than one trial is the **multinomial** family with -density -$$ -f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} - \prod_{k=1}^K \mu_{k}^{y_{k}} -$$ -where, for each category, $\mu_{k}$ is estimated via the multivariate logit link -function shown above. - -## Zero-inflated and hurdle models - -**Zero-inflated** and **hurdle** families extend existing families by adding -special processes for responses that are zero. The density of a -**zero-inflated** family is given by -$$ -f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ -f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 -$$ -where $z$ denotes the zero-inflation probability. Currently implemented families -are **zero_inflated_poisson**, **zero_inflated_binomial**, -**zero_inflated_negbinomial**, and **zero_inflated_beta**. - -The density of a **hurdle** family is given by -$$ -f_z(y) = z \quad \text{if } y = 0 \\ -f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 -$$ -Currently implemented families are **hurdle_poisson**, **hurdle_negbinomial**, -**hurdle_gamma**, and **hurdle_lognormal**. - -The density of a **zero-one-inflated** family is given by -$$ -f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ -f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ -f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} -$$ -where $\alpha$ is the zero-one-inflation probability (i.e. the probability that -zero or one occurs) and $\gamma$ is the conditional one-inflation probability -(i.e. the probability that one occurs rather than zero). Currently implemented -families are **zero_one_inflated_beta**. +--- +title: "Parameterization of Response Distributions in brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Parameterization of Response Distributions in brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +--- + +The purpose of this vignette is to discuss the parameterizations of the families +(i.e., response distributions) used in brms. For a more general overview of +the package see `vignette("brms_overview")`. + +## Notation + +Throughout this vignette, we denote values of the response variable as $y$, a +density function as $f$, and use $\mu$ to refer to the main model parameter, +which is usually the mean of the response distribution or some closely related +quantity. In a regression framework, $\mu$ is not estimated directly but +computed as $\mu = g(\eta)$, where $\eta$ is a predictor term (see +`help(brmsformula)` for details) and $g$ is the response function (i.e., +inverse of the link function). + +## Location shift models + +The density of the **gaussian** family is given by +$$ +f(y) = \frac{1}{\sqrt{2\pi}\sigma} \exp\left(-\frac{1}{2}\left(\frac{y - \mu}{\sigma}\right)^2\right) +$$ + +where $\sigma$ is the residual standard deviation. The density of the +**student** family is given by +$$ +f(y) = \frac{\Gamma((\nu + 1)/2)}{\Gamma(\nu/2)} \frac{1}{\sqrt{\nu\pi}\sigma}\left(1 + \frac{1}{\nu} \left(\frac{y - \mu}{\sigma}\right)^2\right)^{-(\nu+1)/2} +$$ + +$\Gamma$ denotes the gamma function and $\nu > 1$ are the degrees of freedom. As +$\nu \rightarrow \infty$, the student distribution becomes the gaussian +distribution. The density of the **skew_normal** family is given by +$$ +f(y) = \frac{1}{\sqrt{2\pi}\omega} + \exp\left(-\frac{1}{2} \left(\frac{y - \xi}{\omega}\right)^2 \right) +\left(1 + \text{erf} \left( \alpha \left(\frac{y - \xi}{\omega \sqrt{2}} \right) \right) \right) +$$ + +where $\xi$ is the location parameter, $\omega$ is the positive scale parameter, +$\alpha$ the skewness parameter, and $\text{erf}$ denotes the error function of +the gaussian distribution. To parameterize the skew-normal distribution in terms +of the mean $\mu$ and standard deviation $\sigma$, $\omega$ and $\xi$ are +computed as +$$ +\omega = \frac{\sigma}{\sqrt{1 - \frac{2}{\pi} \frac{\alpha^2}{1 + \alpha^2}}} +$$ + +$$ +\xi = \mu - \omega \frac{\alpha}{\sqrt{1 + \alpha^2}} \sqrt{\frac{2}{\pi}} +$$ + +If $\alpha = 0$, the skew-normal distribution becomes the gaussian distribution. +For location shift models, $y$ can be any real value. + +## Binary and count data models + +The density of the **binomial** family is given by +$$ +f(y) = {N \choose y} \mu^{y} (1-\mu)^{N - y} +$$ +where $N$ is the number of trials and $y \in \{0, ... , N\}$. When all +$N$ are $1$ (i.e., $y \in \{0,1\}$), the **bernoulli** distribution for binary +data arises. + +For $y \in \mathbb{N}_0$, the density of the **poisson** family is given by +$$ +f(y) = \frac{\mu^{y}}{y!} \exp(-\mu) +$$ +The density of the **negbinomial** (negative binomial) family is +$$ +f(y) = {y + \phi - 1 \choose y} \left(\frac{\mu}{\mu + \phi}\right)^{y} +\left(\frac{\phi}{\mu + \phi}\right)^\phi +$$ +where $\phi$ is a positive precision parameter. For $\phi \rightarrow \infty$, +the negative binomial distribution becomes the poisson distribution. The density +of the **geometric** family arises if $\phi$ is set to $1$. + + + +## Time-to-event models + +With time-to-event models we mean all models that are defined on the positive +reals only, that is $y \in \mathbb{R}^+$. The density of the **lognormal** +family is given by +$$ +f(y) = \frac{1}{\sqrt{2\pi}\sigma y} \exp\left(-\frac{1}{2}\left(\frac{\log(y) - \mu}{\sigma}\right)^2\right) +$$ +where $\sigma$ is the residual standard deviation on the log-scale. +The density of the **Gamma** family is given by +$$ +f(y) = \frac{(\alpha / \mu)^\alpha}{\Gamma(\alpha)} y^{\alpha-1} +\exp\left(-\frac{\alpha y}{\mu}\right) +$$ +where $\alpha$ is a positive shape parameter. The density of the **weibull** +family is given by +$$ +f(y) = \frac{\alpha}{s} \left(\frac{y}{s}\right)^{\alpha-1} +\exp\left(-\left(\frac{y}{s}\right)^\alpha\right) +$$ +where $\alpha$ is again a positive shape parameter and +$s = \mu / \Gamma(1 + 1 / \alpha)$ is the scale parameter to that $\mu$ +is the mean of the distribution. The **exponential** family arises if $\alpha$ +is set to $1$ for either the gamma or Weibull distribution. The density of the +**inverse.gaussian** family is given by +$$ +f(y) = \left(\frac{\alpha}{2 \pi y^3}\right)^{1/2} \exp \left(\frac{-\alpha (y - \mu)^2}{2 \mu^2 y} \right) +$$ +where $\alpha$ is a positive shape parameter. The **cox** family implements Cox +proportional hazards model which assumes a hazard function of the form $h(y) = +h_0(y) \mu$ with baseline hazard $h_0(y)$ expressed via M-splines (which +integrate to I-splines) in order to ensure monotonicity. The density of the cox +model is then given by +$$ +f(y) = h(y) S(y) +$$ +where $S(y)$ is the survival function implied by $h(y)$. + +## Extreme value models + +Modeling extremes requires special distributions. One may use the **weibull** +distribution (see above) or the **frechet** distribution with density +$$ +f(y) = \frac{\nu}{s} \left(\frac{y}{s}\right)^{-1-\nu} \exp\left(-\left(\frac{y}{s}\right)^{-\nu}\right) +$$ +where $s = \mu / \Gamma(1 - 1 / \nu)$ is a positive scale parameter and +$\nu > 1$ is a shape parameter so that $\mu$ predicts the mean of the Frechet +distribution. A generalization of both distributions is the generalized extreme +value distribution (family **gen_extreme_value**) with density +$$ +f(y) = \frac{1}{\sigma} t(y)^{-1 - 1 / \xi} \exp(-t(y)) +$$ +where +$$ +t(y) = \left(1 + \xi \left(\frac{y - \mu}{\sigma} \right)\right)^{-1 / \xi} +$$ +with positive scale parameter $\sigma$ and shape parameter $\xi$. + +## Response time models + +One family that is especially suited to model reaction times is the +**exgaussian** ('exponentially modified Gaussian') family. Its density is given +by + +$$ +f(y) = \frac{1}{2 \beta} \exp\left(\frac{1}{2 \beta} \left(2\xi + \sigma^2 / \beta - 2 y \right) \right) \text{erfc}\left(\frac{\xi + \sigma^2 / \beta - y}{\sqrt{2} \sigma} \right) +$$ +where $\beta$ is the scale (inverse rate) of the exponential component, $\xi$ is +the mean of the Gaussian component, $\sigma$ is the standard deviation of the +Gaussian component, and $\text{erfc}$ is the complementary error function. We +parameterize $\mu = \xi + \beta$ so that the main predictor term equals the +mean of the distribution. + +Another family well suited for modeling response times is the +**shifted_lognormal** distribution. It's density equals that of the +**lognormal** distribution except that the whole distribution is shifted to the +right by a positive parameter called *ndt* (for consistency with the **wiener** +diffusion model explained below). + +A family concerned with the combined modeling of reaction times and +corresponding binary responses is the **wiener** diffusion model. It has four +model parameters each with a natural interpretation. The parameter $\alpha > 0$ +describes the separation between two boundaries of the diffusion process, +$\tau > 0$ describes the non-decision time (e.g., due to image or motor processing), +$\beta \in [0, 1]$ describes the initial bias in favor of the upper alternative, +and $\delta \in \mathbb{R}$ describes the drift rate to the boundaries (a +positive value indicates a drift towards to upper boundary). The density for the +reaction time at the upper boundary is given by + +$$ +f(y) = \frac{\alpha}{(y-\tau)^3/2} +\exp \! \left(- \delta \alpha \beta - \frac{\delta^2(y-\tau)}{2}\right) +\sum_{k = - \infty}^{\infty} (2k + \beta) +\phi \! \left(\frac{2k + \alpha \beta}{\sqrt{y - \tau}}\right) +$$ + +where $\phi(x)$ denotes the standard normal density function. The density at the +lower boundary can be obtained by substituting $1 - \beta$ for $\beta$ and +$-\delta$ for $\delta$ in the above equation. In brms the parameters +$\alpha$, $\tau$, and $\beta$ are modeled as auxiliary parameters named *bs* +('boundary separation'), *ndt* ('non-decision time'), and *bias* respectively, +whereas the drift rate $\delta$ is modeled via the ordinary model formula that +is as $\delta = \mu$. + +## Quantile regression + +Quantile regression is implemented via family **asym_laplace** (asymmetric +Laplace distribution) with density + +$$ +f(y) = \frac{p (1 - p)}{\sigma} \exp\left(-\rho_p\left(\frac{y - \mu}{\sigma}\right)\right) +$$ +where $\rho_p$ is given by $\rho_p(x) = x (p - I_{x < 0})$ and $I_A$ is the +indicator function of set $A$. The parameter $\sigma$ is a positive scale +parameter and $p$ is the *quantile* parameter taking on values in $(0, 1)$. For +this distribution, we have $P(Y < g(\eta)) = p$. Thus, quantile regression can +be performed by fixing $p$ to the quantile to interest. + +## Probability models + +The density of the **Beta** family for $y \in (0,1)$ is given by +$$ +f(y) = \frac{y^{\mu \phi - 1} (1-y)^{(1-\mu) \phi-1}}{B(\mu \phi, (1-\mu) \phi)} +$$ +where $B$ is the beta function and $\phi$ is a positive precision parameter. +A multivariate generalization of the **Beta** family is the **dirichlet** family +with density +$$ +f(y) = \frac{1}{B((\mu_{1}, \ldots, \mu_{K}) \phi)} + \prod_{k=1}^K y_{k}^{\mu_{k} \phi - 1}. +$$ +The **dirichlet** family is implemented with the multivariate logit +link function so that +$$ +\mu_{j} = \frac{\exp(\eta_{j})}{\sum_{k = 1}^{K} \exp(\eta_{k})} +$$ +For reasons of identifiability, $\eta_{\rm ref}$ is set to $0$, where ${\rm ref}$ +is one of the response categories chosen as reference. + +An alternative to the **dirichlet** family is the **logistic_normal** family +with density +$$ +f(y) = \frac{1}{\prod_{k=1}^K y_k} \times + \text{multivariate_normal}(\tilde{y} \, | \, \mu, \sigma, \Omega) +$$ +where $\tilde{y}$ is the multivariate logit transformed response +$$ +\tilde{y} = (\log(y_1 / y_{\rm ref}), \ldots, \log(y_{\rm ref-1} / y_{\rm ref}), + \log(y_{\rm ref+1} / y_{\rm ref}), \ldots, \log(y_K / y_{\rm ref})) +$$ +of dimension $K-1$ (excluding the reference category), which is modeled as +multivariate normally distributed with latent mean and standard deviation +vectors $\mu$ and $\sigma$, as well as correlation matrix $\Omega$. + + +## Circular models + +The density of the **von_mises** family for $y \in (-\pi,\pi)$ is given by +$$ +f(y) = \frac{\exp(\kappa \cos(y - \mu))}{2\pi I_0(\kappa)} +$$ +where $I_0$ is the modified Bessel function of order 0 and $\kappa$ is +a positive precision parameter. + +## Ordinal and categorical models + +For ordinal and categorical models, $y$ is one of the categories $1, ..., K$. +The intercepts of ordinal models are called thresholds and are denoted as +$\tau_k$, with $k \in \{1, ..., K-1\}$, whereas $\eta$ does not contain a fixed +effects intercept. Note that the applied link functions $h$ are technically +distribution functions $\mathbb{R} \rightarrow [0,1]$. The density of the +**cumulative** family (implementing the most basic ordinal model) is given by +$$ +f(y) = g(\tau_{y + 1} - \eta) - g(\tau_{y} - \eta) +$$ + +The densities of the **sratio** (stopping ratio) and **cratio** (continuation +ratio) families are given by +$$ +f(y) = g(\tau_{y + 1} - \eta) \prod_{k = 1}^{y} (1 - g(\tau_{k} - \eta)) +$$ +and +$$ +f(y) = (1 - g(\eta - \tau_{y + 1})) \prod_{k = 1}^{y} g(\eta - \tau_{k}) +$$ + +respectively. Note that both families are equivalent for symmetric link +functions such as logit or probit. The density of the **acat** (adjacent +category) family is given by +$$ +f(y) = \frac{\prod_{k=1}^{y} g(\eta - \tau_{k}) + \prod_{k=y+1}^K(1-g(\eta - \tau_{k}))}{\sum_{k=0}^K\prod_{j=1}^k g(\eta-\tau_{j}) + \prod_{j=k+1}^K(1-g(\eta - \tau_{j}))} +$$ +For the logit link, this can be simplified to +$$ +f(y) = \frac{\exp \left(\sum_{k=1}^{y} (\eta - \tau_{k}) \right)} + {\sum_{k=0}^K \exp\left(\sum_{j=1}^k (\eta - \tau_{j}) \right)} +$$ +The linear predictor $\eta$ can be generalized to also depend on the category +$k$ for a subset of predictors. This leads to category specific +effects (for details on how to specify them see `help(brm)`). Note that +**cumulative** and **sratio** models use $\tau - \eta$, whereas **cratio** and +**acat** use $\eta - \tau$. This is done to ensure that larger values of $\eta$ +increase the probability of *higher* response categories. + +The **categorical** family is currently only implemented with the multivariate +logit link function and has density +$$ +f(y) = \mu_{y} = \frac{\exp(\eta_{y})}{\sum_{k = 1}^{K} \exp(\eta_{k})} +$$ +Note that $\eta$ does also depend on the category $k$. For reasons of +identifiability, $\eta_{1}$ is set to $0$. A generalization of the +**categorical** family to more than one trial is the **multinomial** family with +density +$$ +f(y) = {N \choose y_{1}, y_{2}, \ldots, y_{K}} + \prod_{k=1}^K \mu_{k}^{y_{k}} +$$ +where, for each category, $\mu_{k}$ is estimated via the multivariate logit link +function shown above. + +## Zero-inflated and hurdle models + +**Zero-inflated** and **hurdle** families extend existing families by adding +special processes for responses that are zero. The density of a +**zero-inflated** family is given by +$$ +f_z(y) = z + (1 - z) f(0) \quad \text{if } y = 0 \\ +f_z(y) = (1 - z) f(y) \quad \text{if } y > 0 +$$ +where $z$ denotes the zero-inflation probability. Currently implemented families +are **zero_inflated_poisson**, **zero_inflated_binomial**, +**zero_inflated_negbinomial**, and **zero_inflated_beta**. + +The density of a **hurdle** family is given by +$$ +f_z(y) = z \quad \text{if } y = 0 \\ +f_z(y) = (1 - z) f(y) / (1 - f(0)) \quad \text{if } y > 0 +$$ +Currently implemented families are **hurdle_poisson**, **hurdle_negbinomial**, +**hurdle_gamma**, and **hurdle_lognormal**. + +The density of a **zero-one-inflated** family is given by +$$ +f_{\alpha, \gamma}(y) = \alpha (1 - \gamma) \quad \text{if } y = 0 \\ +f_{\alpha, \gamma}(y) = \alpha \gamma \quad \text{if } y = 1 \\ +f_{\alpha, \gamma}(y) = (1 - \alpha) f(y) \quad \text{if } y \notin \{0, 1\} +$$ +where $\alpha$ is the zero-one-inflation probability (i.e. the probability that +zero or one occurs) and $\gamma$ is the conditional one-inflation probability +(i.e. the probability that one occurs rather than zero). Currently implemented +families are **zero_one_inflated_beta**. diff -Nru r-cran-brms-2.16.3/vignettes/brms_missings.Rmd r-cran-brms-2.17.0/vignettes/brms_missings.Rmd --- r-cran-brms-2.16.3/vignettes/brms_missings.Rmd 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_missings.Rmd 2022-04-11 07:21:07.000000000 +0000 @@ -1,237 +1,237 @@ ---- -title: "Handle Missing Values with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Handle Missing Values with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -Many real world data sets contain missing values for various reasons. Generally, -we have quite a few options to handle those missing values. The easiest solution -is to remove all rows from the data set, where one or more variables are -missing. However, if values are not missing completely at random, this will -likely lead to bias in our analysis. Accordingly, we usually want to impute -missing values in one way or the other. Here, we will consider two very general -approaches using **brms**: (1) Impute missing values *before* the model fitting -with multiple imputation, and (2) impute missing values on the fly *during* -model fitting[^1]. As a simple example, we will use the `nhanes` data set, which -contains information on participants' `age`, `bmi` (body mass index), `hyp` -(hypertensive), and `chl` (total serum cholesterol). For the purpose of the -present vignette, we are primarily interested in predicting `bmi` by `age` and -`chl`. - -```{r} -data("nhanes", package = "mice") -head(nhanes) -``` - -## Imputation before model fitting - -There are many approaches allowing us to impute missing data before the actual -model fitting takes place. From a statistical perspective, multiple imputation -is one of the best solutions. Each missing value is not imputed once but -`m` times leading to a total of `m` fully imputed data sets. The model -can then be fitted to each of those data sets separately and results are pooled -across models, afterwards. One widely applied package for multiple imputation is -**mice** (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the -following in combination with **brms**. Here, we apply the default settings of -**mice**, which means that all variables will be used to impute missing values -in all other variables and imputation functions automatically chosen based on -the variables' characteristics. - -```{r} -library(mice) -imp <- mice(nhanes, m = 5, print = FALSE) -``` - -Now, we have `m = 5` imputed data sets stored within the `imp` object. In -practice, we will likely need more than `5` of those to accurately account for -the uncertainty induced by the missingness, perhaps even in the area of `100` -imputed data sets (Zhou & Reiter, 2010). Of course, this increases the -computational burden by a lot and so we stick to `m = 5` for the purpose of this -vignette. Regardless of the value of `m`, we can either extract those data sets -and then pass them to the actual model fitting function as a list of data -frames, or pass `imp` directly. The latter works because **brms** offers special -support for data imputed by **mice**. We will go with the latter approach, since -it is less typing. Fitting our model of interest with **brms** to the multiple -imputed data sets is straightforward. - -```{r, results = 'hide', message = FALSE} -fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) -``` - -The returned fitted model is an ordinary `brmsfit` object containing the -posterior draws of all `m` submodels. While pooling across models is not -necessarily straightforward in classical statistics, it is trivial in a Bayesian -framework. Here, pooling results of multiple imputed data sets is simply -achieved by combining the posterior draws of the submodels. Accordingly, all -post-processing methods can be used out of the box without having to worry about -pooling at all. - -```{r} -summary(fit_imp1) -``` - -In the summary output, we notice that some `Rhat` values are higher than $1.1$ -indicating possible convergence problems. For models based on multiple imputed -data sets, this is often a **false positive**: Chains of different submodels may -not overlay each other exactly, since there were fitted to different data. We -can see the chains on the right-hand side of - -```{r} -plot(fit_imp1, variable = "^b", regex = TRUE) -``` - -Such non-overlaying chains imply high `Rhat` values without there actually being -any convergence issue. Accordingly, we have to investigate the convergence of -the submodels separately, which we can do by looking at - -```{r} -round(fit_imp1$rhats, 2) -``` - -The convergence of each of the submodels looks good. Accordingly, we can proceed -with further post-processing and interpretation of the results. For instance, we -could investigate the combined effect of `age` and `chl`. - -```{r} -conditional_effects(fit_imp1, "age:chl") -``` - -To summarize, the advantages of multiple imputation are obvious: One can apply -it to all kinds of models, since model fitting functions do not need to know -that the data sets were imputed, beforehand. Also, we do not need to worry about -pooling across submodels when using fully Bayesian methods. The only drawback is -the amount of time required for model fitting. Estimating Bayesian models is -already quite slow with just a single data set and it only gets worse when -working with multiple imputation. - -### Compatibility with other multiple imputation packages - -**brms** offers built-in support for **mice** mainly because I use the latter in -some of my own research projects. Nevertheless, `brm_multiple` supports all -kinds of multiple imputation packages as it also accepts a *list* of data frames -as input for its `data` argument. Thus, you just need to extract the imputed -data frames in the form of a list, which can then be passed to `brm_multiple`. -Most multiple imputation packages have some built-in functionality for this -task. When using the **mi** package, for instance, you simply need to call the -`mi::complete` function to get the desired output. - -## Imputation during model fitting - -Imputation during model fitting is generally thought to be more complex than -imputation before model fitting, because one has to take care of everything -within one step. This remains true when imputing missing values with **brms**, -but possibly to a somewhat smaller degree. Consider again the `nhanes` data with -the goal to predict `bmi` by `age`, and `chl`. Since `age` contains no missing -values, we only have to take special care of `bmi` and `chl`. We need to tell -the model two things. (1) Which variables contain missing values and how they -should be predicted, as well as (2) which of these imputed variables should be -used as predictors. In **brms** we can do this as follows: - -```{r, results = 'hide', message = FALSE} -bform <- bf(bmi | mi() ~ age * mi(chl)) + - bf(chl | mi() ~ age) + set_rescor(FALSE) -fit_imp2 <- brm(bform, data = nhanes) -``` - -The model has become multivariate, as we no longer only predict `bmi` but also -`chl` (see `vignette("brms_multivariate")` for details about the multivariate -syntax of **brms**). We ensure that missings in both variables will be modeled -rather than excluded by adding `| mi()` on the left-hand side of the -formulas[^2]. We write `mi(chl)` on the right-hand side of the formula for `bmi` -to ensure that the estimated missing values of `chl` will be used in the -prediction of `bmi`. The summary is a bit more cluttered as we get coefficients -for both response variables, but apart from that we can interpret coefficients -in the usual way. - -```{r} -summary(fit_imp2) -conditional_effects(fit_imp2, "age:chl", resp = "bmi") -``` - -The results look pretty similar to those obtained from multiple imputation, but -be aware that this may not be generally the case. In multiple imputation, the -default is to impute all variables based on all other variables, while in the -'one-step' approach, we have to explicitly specify the variables used in the -imputation. Thus, arguably, multiple imputation is easier to apply. An obvious -advantage of the 'one-step' approach is that the model needs to be fitted only -once instead of `m` times. Also, within the **brms** framework, we can use -multilevel structure and complex non-linear relationships for the imputation of -missing values, which is not achieved as easily in standard multiple imputation -software. On the downside, it is currently not possible to impute discrete -variables, because **Stan** (the engine behind **brms**) does not allow -estimating discrete parameters. - -### Combining measurement error and missing values - -Missing value terms in **brms** cannot only handle missing values but also -measurement error, or arbitrary combinations of the two. In fact, we can think -of a missing value as a value with infinite measurement error. Thus, `mi` terms -are a natural (and somewhat more verbose) generalization of the now soft deprecated -`me` terms. Suppose we had measured the variable `chl` with some known error: - -```{r} -nhanes$se <- rexp(nrow(nhanes), 2) -``` - -Then we can go ahead an include this information into the model as follows: - -```{r, results = 'hide', message = FALSE, eval = FALSE} -bform <- bf(bmi | mi() ~ age * mi(chl)) + - bf(chl | mi(se) ~ age) + set_rescor(FALSE) -fit_imp3 <- brm(bform, data = nhanes) -``` - -Summarizing and post-processing the model continues to work as usual. - - -[^1]: Actually, there is a third approach that only applies to missings in -response variables. If we want to impute missing responses, we just fit the -model using the observed responses and than impute the missings *after* fitting -the model by means of posterior prediction. That is, we supply the predictor -values corresponding to missing responses to the `predict` method. - -[^2]: We don't really need this for `bmi`, since `bmi` is not used as a -predictor for another variable. Accordingly, we could also -- and equivalently --- impute missing values of `bmi` *after* model fitting by means of posterior -prediction. - -## References - -Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by -chained equations in R. *Journal of Statistical Software*, 1-68. -doi.org/10.18637/jss.v045.i03 - -Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple -Imputation. *The American Statistician*, 64(2), 159-163. -doi.org/10.1198/tast.2010.09109 +--- +title: "Handle Missing Values with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Handle Missing Values with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +Many real world data sets contain missing values for various reasons. Generally, +we have quite a few options to handle those missing values. The easiest solution +is to remove all rows from the data set, where one or more variables are +missing. However, if values are not missing completely at random, this will +likely lead to bias in our analysis. Accordingly, we usually want to impute +missing values in one way or the other. Here, we will consider two very general +approaches using **brms**: (1) Impute missing values *before* the model fitting +with multiple imputation, and (2) impute missing values on the fly *during* +model fitting[^1]. As a simple example, we will use the `nhanes` data set, which +contains information on participants' `age`, `bmi` (body mass index), `hyp` +(hypertensive), and `chl` (total serum cholesterol). For the purpose of the +present vignette, we are primarily interested in predicting `bmi` by `age` and +`chl`. + +```{r} +data("nhanes", package = "mice") +head(nhanes) +``` + +## Imputation before model fitting + +There are many approaches allowing us to impute missing data before the actual +model fitting takes place. From a statistical perspective, multiple imputation +is one of the best solutions. Each missing value is not imputed once but +`m` times leading to a total of `m` fully imputed data sets. The model +can then be fitted to each of those data sets separately and results are pooled +across models, afterwards. One widely applied package for multiple imputation is +**mice** (Buuren & Groothuis-Oudshoorn, 2010) and we will use it in the +following in combination with **brms**. Here, we apply the default settings of +**mice**, which means that all variables will be used to impute missing values +in all other variables and imputation functions automatically chosen based on +the variables' characteristics. + +```{r} +library(mice) +imp <- mice(nhanes, m = 5, print = FALSE) +``` + +Now, we have `m = 5` imputed data sets stored within the `imp` object. In +practice, we will likely need more than `5` of those to accurately account for +the uncertainty induced by the missingness, perhaps even in the area of `100` +imputed data sets (Zhou & Reiter, 2010). Of course, this increases the +computational burden by a lot and so we stick to `m = 5` for the purpose of this +vignette. Regardless of the value of `m`, we can either extract those data sets +and then pass them to the actual model fitting function as a list of data +frames, or pass `imp` directly. The latter works because **brms** offers special +support for data imputed by **mice**. We will go with the latter approach, since +it is less typing. Fitting our model of interest with **brms** to the multiple +imputed data sets is straightforward. + +```{r, results = 'hide', message = FALSE} +fit_imp1 <- brm_multiple(bmi ~ age*chl, data = imp, chains = 2) +``` + +The returned fitted model is an ordinary `brmsfit` object containing the +posterior draws of all `m` submodels. While pooling across models is not +necessarily straightforward in classical statistics, it is trivial in a Bayesian +framework. Here, pooling results of multiple imputed data sets is simply +achieved by combining the posterior draws of the submodels. Accordingly, all +post-processing methods can be used out of the box without having to worry about +pooling at all. + +```{r} +summary(fit_imp1) +``` + +In the summary output, we notice that some `Rhat` values are higher than $1.1$ +indicating possible convergence problems. For models based on multiple imputed +data sets, this is often a **false positive**: Chains of different submodels may +not overlay each other exactly, since there were fitted to different data. We +can see the chains on the right-hand side of + +```{r} +plot(fit_imp1, variable = "^b", regex = TRUE) +``` + +Such non-overlaying chains imply high `Rhat` values without there actually being +any convergence issue. Accordingly, we have to investigate the convergence of +the submodels separately, which we can do by looking at + +```{r} +round(fit_imp1$rhats, 2) +``` + +The convergence of each of the submodels looks good. Accordingly, we can proceed +with further post-processing and interpretation of the results. For instance, we +could investigate the combined effect of `age` and `chl`. + +```{r} +conditional_effects(fit_imp1, "age:chl") +``` + +To summarize, the advantages of multiple imputation are obvious: One can apply +it to all kinds of models, since model fitting functions do not need to know +that the data sets were imputed, beforehand. Also, we do not need to worry about +pooling across submodels when using fully Bayesian methods. The only drawback is +the amount of time required for model fitting. Estimating Bayesian models is +already quite slow with just a single data set and it only gets worse when +working with multiple imputation. + +### Compatibility with other multiple imputation packages + +**brms** offers built-in support for **mice** mainly because I use the latter in +some of my own research projects. Nevertheless, `brm_multiple` supports all +kinds of multiple imputation packages as it also accepts a *list* of data frames +as input for its `data` argument. Thus, you just need to extract the imputed +data frames in the form of a list, which can then be passed to `brm_multiple`. +Most multiple imputation packages have some built-in functionality for this +task. When using the **mi** package, for instance, you simply need to call the +`mi::complete` function to get the desired output. + +## Imputation during model fitting + +Imputation during model fitting is generally thought to be more complex than +imputation before model fitting, because one has to take care of everything +within one step. This remains true when imputing missing values with **brms**, +but possibly to a somewhat smaller degree. Consider again the `nhanes` data with +the goal to predict `bmi` by `age`, and `chl`. Since `age` contains no missing +values, we only have to take special care of `bmi` and `chl`. We need to tell +the model two things. (1) Which variables contain missing values and how they +should be predicted, as well as (2) which of these imputed variables should be +used as predictors. In **brms** we can do this as follows: + +```{r, results = 'hide', message = FALSE} +bform <- bf(bmi | mi() ~ age * mi(chl)) + + bf(chl | mi() ~ age) + set_rescor(FALSE) +fit_imp2 <- brm(bform, data = nhanes) +``` + +The model has become multivariate, as we no longer only predict `bmi` but also +`chl` (see `vignette("brms_multivariate")` for details about the multivariate +syntax of **brms**). We ensure that missings in both variables will be modeled +rather than excluded by adding `| mi()` on the left-hand side of the +formulas[^2]. We write `mi(chl)` on the right-hand side of the formula for `bmi` +to ensure that the estimated missing values of `chl` will be used in the +prediction of `bmi`. The summary is a bit more cluttered as we get coefficients +for both response variables, but apart from that we can interpret coefficients +in the usual way. + +```{r} +summary(fit_imp2) +conditional_effects(fit_imp2, "age:chl", resp = "bmi") +``` + +The results look pretty similar to those obtained from multiple imputation, but +be aware that this may not be generally the case. In multiple imputation, the +default is to impute all variables based on all other variables, while in the +'one-step' approach, we have to explicitly specify the variables used in the +imputation. Thus, arguably, multiple imputation is easier to apply. An obvious +advantage of the 'one-step' approach is that the model needs to be fitted only +once instead of `m` times. Also, within the **brms** framework, we can use +multilevel structure and complex non-linear relationships for the imputation of +missing values, which is not achieved as easily in standard multiple imputation +software. On the downside, it is currently not possible to impute discrete +variables, because **Stan** (the engine behind **brms**) does not allow +estimating discrete parameters. + +### Combining measurement error and missing values + +Missing value terms in **brms** cannot only handle missing values but also +measurement error, or arbitrary combinations of the two. In fact, we can think +of a missing value as a value with infinite measurement error. Thus, `mi` terms +are a natural (and somewhat more verbose) generalization of the now soft deprecated +`me` terms. Suppose we had measured the variable `chl` with some known error: + +```{r} +nhanes$se <- rexp(nrow(nhanes), 2) +``` + +Then we can go ahead an include this information into the model as follows: + +```{r, results = 'hide', message = FALSE, eval = FALSE} +bform <- bf(bmi | mi() ~ age * mi(chl)) + + bf(chl | mi(se) ~ age) + set_rescor(FALSE) +fit_imp3 <- brm(bform, data = nhanes) +``` + +Summarizing and post-processing the model continues to work as usual. + + +[^1]: Actually, there is a third approach that only applies to missings in +response variables. If we want to impute missing responses, we just fit the +model using the observed responses and than impute the missings *after* fitting +the model by means of posterior prediction. That is, we supply the predictor +values corresponding to missing responses to the `predict` method. + +[^2]: We don't really need this for `bmi`, since `bmi` is not used as a +predictor for another variable. Accordingly, we could also -- and equivalently +-- impute missing values of `bmi` *after* model fitting by means of posterior +prediction. + +## References + +Buuren, S. V. & Groothuis-Oudshoorn, K. (2010). mice: Multivariate imputation by +chained equations in R. *Journal of Statistical Software*, 1-68. +doi.org/10.18637/jss.v045.i03 + +Zhou, X. & Reiter, J. P. (2010). A Note on Bayesian Inference After Multiple +Imputation. *The American Statistician*, 64(2), 159-163. +doi.org/10.1198/tast.2010.09109 diff -Nru r-cran-brms-2.16.3/vignettes/brms_monotonic.Rmd r-cran-brms-2.17.0/vignettes/brms_monotonic.Rmd --- r-cran-brms-2.16.3/vignettes/brms_monotonic.Rmd 2021-08-26 17:47:36.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_monotonic.Rmd 2022-04-11 07:21:15.000000000 +0000 @@ -1,234 +1,234 @@ ---- -title: "Estimating Monotonic Effects with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Monotonic Effects with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -This vignette is about monotonic effects, a special way of handling discrete -predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in -review). A predictor, which we want to model as monotonic (i.e., having a -monotonically increasing or decreasing relationship with the response), must -either be integer valued or an ordered factor. As opposed to a continuous -predictor, predictor categories (or integers) are not assumed to be equidistant -with respect to their effect on the response variable. Instead, the distance -between adjacent predictor categories (or integers) is estimated from the data -and may vary across categories. This is realized by parameterizing as follows: -One parameter, $b$, takes care of the direction and size of the effect similar -to an ordinary regression parameter. If the monotonic effect is used in a linear -model, $b$ can be interpreted as the expected average difference between two -adjacent categories of the ordinal predictor. An additional parameter vector, -$\zeta$, estimates the normalized distances between consecutive predictor -categories which thus defines the shape of the monotonic effect. For a single -monotonic predictor, $x$, the linear predictor term of observation $n$ looks as -follows: - -$$\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i$$ - -The parameter $b$ can take on any real value, while $\zeta$ is a simplex, which -means that it satisfies $\zeta_i \in [0,1]$ and $\sum_{i = 1}^D \zeta_i = 1$ -with $D$ being the number of elements of $\zeta$. Equivalently, $D$ is the -number of categories (or highest integer in the data) minus 1, since we start -counting categories from zero to simplify the notation. - -## A Simple Monotonic Model - -A main application of monotonic effects are ordinal predictors that can be -modeled this way without falsely treating them either as continuous or as -unordered categorical predictors. In Psychology, for instance, this kind of data -is omnipresent in the form of Likert scale items, which are often treated as -being continuous for convenience without ever testing this assumption. As an -example, suppose we are interested in the relationship of yearly income (in $) -and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, -people are not asked for the exact income. Instead, they are asked to rank -themselves in one of certain classes, say: 'below 20k', 'between 20k and 40k', -'between 40k and 100k' and 'above 100k'. We use some simulated data for -illustration purposes. - -```{r} -income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") -income <- factor(sample(income_options, 100, TRUE), - levels = income_options, ordered = TRUE) -mean_ls <- c(30, 60, 70, 75) -ls <- mean_ls[income] + rnorm(100, sd = 7) -dat <- data.frame(income, ls) -``` - -We now proceed with analyzing the data modeling `income` as a monotonic effect. - -```{r, results='hide'} -fit1 <- brm(ls ~ mo(income), data = dat) -``` - -The summary methods yield - -```{r} -summary(fit1) -plot(fit1, variable = "simo", regex = TRUE) -plot(conditional_effects(fit1)) -``` - -The distributions of the simplex parameter of `income`, as shown in the `plot` -method, demonstrate that the largest difference (about 70% of the difference -between minimum and maximum category) is between the first two categories. - -Now, let's compare of monotonic model with two common alternative models. (a) -Assume `income` to be continuous: - -```{r, results='hide'} -dat$income_num <- as.numeric(dat$income) -fit2 <- brm(ls ~ income_num, data = dat) -``` - -```{r} -summary(fit2) -``` - -or (b) Assume `income` to be an unordered factor: - -```{r, results='hide'} -contrasts(dat$income) <- contr.treatment(4) -fit3 <- brm(ls ~ income, data = dat) -``` - -```{r} -summary(fit3) -``` - -We can easily compare the fit of the three models using leave-one-out -cross-validation. - -```{r} -loo(fit1, fit2, fit3) -``` - -The monotonic model fits better than the continuous model, which is not -surprising given that the relationship between `income` and `ls` is non-linear. -The monotonic and the unordered factor model have almost identical fit in this -example, but this may not be the case for other data sets. - -## Setting Prior Distributions - -In the previous monotonic model, we have implicitly assumed that all differences -between adjacent categories were a-priori the same, or formulated correctly, had -the same prior distribution. In the following, we want to show how to change -this assumption. The canonical prior distribution of a simplex parameter is the -Dirichlet distribution, a multivariate generalization of the beta distribution. -It is non-zero for all valid simplexes (i.e., $\zeta_i \in [0,1]$ and $\sum_{i = -1}^D \zeta_i = 1$) and zero otherwise. The Dirichlet prior has a single -parameter $\alpha$ of the same length as $\zeta$. The higher $\alpha_i$ the -higher the a-priori probability of higher values of $\zeta_i$. Suppose that, -before looking at the data, we expected that the same amount of additional money -matters more for people who generally have less money. This translates into a -higher a-priori values of $\zeta_1$ (difference between 'below_20' and -'20_to_40') and hence into higher values of $\alpha_1$. We choose $\alpha_1 = 2$ -and $\alpha_2 = \alpha_3 = 1$, the latter being the default value of $\alpha$. -To fit the model we write: - -```{r, results='hide'} -prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") -fit4 <- brm(ls ~ mo(income), data = dat, - prior = prior4, sample_prior = TRUE) -``` - -The `1` at the end of `"moincome1"` may appear strange when first working with -monotonic effects. However, it is necessary as one monotonic term may be -associated with multiple simplex parameters, if interactions of multiple -monotonic variables are included in the model. - -```{r} -summary(fit4) -``` - -We have used `sample_prior = TRUE` to also obtain draws from the prior -distribution of `simo_moincome1` so that we can visualized it. - -```{r} -plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) -``` - -As is visible in the plots, `simo_moincome1[1]` was a-priori on average twice as -high as `simo_moincome1[2]` and `simo_moincome1[3]` as a result of setting -$\alpha_1$ to 2. - -## Modeling interactions of monotonic variables - -Suppose, we have additionally asked participants for their age. - -```{r} -dat$age <- rnorm(100, mean = 40, sd = 10) -``` - -We are not only interested in the main effect of age but also in the interaction -of income and age. Interactions with monotonic variables can be specified in the -usual way using the `*` operator: - -```{r, results='hide'} -fit5 <- brm(ls ~ mo(income)*age, data = dat) -``` - -```{r} -summary(fit5) -conditional_effects(fit5, "income:age") -``` - -## Modelling Monotonic Group-Level Effects - -Suppose that the 100 people in our sample data were drawn from 10 different -cities; 10 people per city. Thus, we add an identifier for `city` to the data -and add some city-related variation to `ls`. - -```{r} -dat$city <- rep(1:10, each = 10) -var_city <- rnorm(10, sd = 10) -dat$ls <- dat$ls + var_city[dat$city] -``` - -With the following code, we fit a multilevel model assuming the intercept and -the effect of `income` to vary by city: - -```{r, results='hide'} -fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) -``` - -```{r} -summary(fit6) -``` - -reveals that the effect of `income` varies only little across cities. For the -present data, this is not overly surprising given that, in the data simulations, -we assumed `income` to have the same effect across cities. - -## References - -Bürkner P. C. & Charpentier, E. (in review). [Monotonic Effects: A Principled -Approach for Including Ordinal Predictors in Regression Models](https://psyarxiv.com/9qkhj/). *PsyArXiv preprint*. +--- +title: "Estimating Monotonic Effects with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Monotonic Effects with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +This vignette is about monotonic effects, a special way of handling discrete +predictors that are on an ordinal or higher scale (Bürkner & Charpentier, in +review). A predictor, which we want to model as monotonic (i.e., having a +monotonically increasing or decreasing relationship with the response), must +either be integer valued or an ordered factor. As opposed to a continuous +predictor, predictor categories (or integers) are not assumed to be equidistant +with respect to their effect on the response variable. Instead, the distance +between adjacent predictor categories (or integers) is estimated from the data +and may vary across categories. This is realized by parameterizing as follows: +One parameter, $b$, takes care of the direction and size of the effect similar +to an ordinary regression parameter. If the monotonic effect is used in a linear +model, $b$ can be interpreted as the expected average difference between two +adjacent categories of the ordinal predictor. An additional parameter vector, +$\zeta$, estimates the normalized distances between consecutive predictor +categories which thus defines the shape of the monotonic effect. For a single +monotonic predictor, $x$, the linear predictor term of observation $n$ looks as +follows: + +$$\eta_n = b D \sum_{i = 1}^{x_n} \zeta_i$$ + +The parameter $b$ can take on any real value, while $\zeta$ is a simplex, which +means that it satisfies $\zeta_i \in [0,1]$ and $\sum_{i = 1}^D \zeta_i = 1$ +with $D$ being the number of elements of $\zeta$. Equivalently, $D$ is the +number of categories (or highest integer in the data) minus 1, since we start +counting categories from zero to simplify the notation. + +## A Simple Monotonic Model + +A main application of monotonic effects are ordinal predictors that can be +modeled this way without falsely treating them either as continuous or as +unordered categorical predictors. In Psychology, for instance, this kind of data +is omnipresent in the form of Likert scale items, which are often treated as +being continuous for convenience without ever testing this assumption. As an +example, suppose we are interested in the relationship of yearly income (in $) +and life satisfaction measured on an arbitrary scale from 0 to 100. Usually, +people are not asked for the exact income. Instead, they are asked to rank +themselves in one of certain classes, say: 'below 20k', 'between 20k and 40k', +'between 40k and 100k' and 'above 100k'. We use some simulated data for +illustration purposes. + +```{r} +income_options <- c("below_20", "20_to_40", "40_to_100", "greater_100") +income <- factor(sample(income_options, 100, TRUE), + levels = income_options, ordered = TRUE) +mean_ls <- c(30, 60, 70, 75) +ls <- mean_ls[income] + rnorm(100, sd = 7) +dat <- data.frame(income, ls) +``` + +We now proceed with analyzing the data modeling `income` as a monotonic effect. + +```{r, results='hide'} +fit1 <- brm(ls ~ mo(income), data = dat) +``` + +The summary methods yield + +```{r} +summary(fit1) +plot(fit1, variable = "simo", regex = TRUE) +plot(conditional_effects(fit1)) +``` + +The distributions of the simplex parameter of `income`, as shown in the `plot` +method, demonstrate that the largest difference (about 70% of the difference +between minimum and maximum category) is between the first two categories. + +Now, let's compare of monotonic model with two common alternative models. (a) +Assume `income` to be continuous: + +```{r, results='hide'} +dat$income_num <- as.numeric(dat$income) +fit2 <- brm(ls ~ income_num, data = dat) +``` + +```{r} +summary(fit2) +``` + +or (b) Assume `income` to be an unordered factor: + +```{r, results='hide'} +contrasts(dat$income) <- contr.treatment(4) +fit3 <- brm(ls ~ income, data = dat) +``` + +```{r} +summary(fit3) +``` + +We can easily compare the fit of the three models using leave-one-out +cross-validation. + +```{r} +loo(fit1, fit2, fit3) +``` + +The monotonic model fits better than the continuous model, which is not +surprising given that the relationship between `income` and `ls` is non-linear. +The monotonic and the unordered factor model have almost identical fit in this +example, but this may not be the case for other data sets. + +## Setting Prior Distributions + +In the previous monotonic model, we have implicitly assumed that all differences +between adjacent categories were a-priori the same, or formulated correctly, had +the same prior distribution. In the following, we want to show how to change +this assumption. The canonical prior distribution of a simplex parameter is the +Dirichlet distribution, a multivariate generalization of the beta distribution. +It is non-zero for all valid simplexes (i.e., $\zeta_i \in [0,1]$ and $\sum_{i = +1}^D \zeta_i = 1$) and zero otherwise. The Dirichlet prior has a single +parameter $\alpha$ of the same length as $\zeta$. The higher $\alpha_i$ the +higher the a-priori probability of higher values of $\zeta_i$. Suppose that, +before looking at the data, we expected that the same amount of additional money +matters more for people who generally have less money. This translates into a +higher a-priori values of $\zeta_1$ (difference between 'below_20' and +'20_to_40') and hence into higher values of $\alpha_1$. We choose $\alpha_1 = 2$ +and $\alpha_2 = \alpha_3 = 1$, the latter being the default value of $\alpha$. +To fit the model we write: + +```{r, results='hide'} +prior4 <- prior(dirichlet(c(2, 1, 1)), class = "simo", coef = "moincome1") +fit4 <- brm(ls ~ mo(income), data = dat, + prior = prior4, sample_prior = TRUE) +``` + +The `1` at the end of `"moincome1"` may appear strange when first working with +monotonic effects. However, it is necessary as one monotonic term may be +associated with multiple simplex parameters, if interactions of multiple +monotonic variables are included in the model. + +```{r} +summary(fit4) +``` + +We have used `sample_prior = TRUE` to also obtain draws from the prior +distribution of `simo_moincome1` so that we can visualized it. + +```{r} +plot(fit4, variable = "prior_simo", regex = TRUE, N = 3) +``` + +As is visible in the plots, `simo_moincome1[1]` was a-priori on average twice as +high as `simo_moincome1[2]` and `simo_moincome1[3]` as a result of setting +$\alpha_1$ to 2. + +## Modeling interactions of monotonic variables + +Suppose, we have additionally asked participants for their age. + +```{r} +dat$age <- rnorm(100, mean = 40, sd = 10) +``` + +We are not only interested in the main effect of age but also in the interaction +of income and age. Interactions with monotonic variables can be specified in the +usual way using the `*` operator: + +```{r, results='hide'} +fit5 <- brm(ls ~ mo(income)*age, data = dat) +``` + +```{r} +summary(fit5) +conditional_effects(fit5, "income:age") +``` + +## Modelling Monotonic Group-Level Effects + +Suppose that the 100 people in our sample data were drawn from 10 different +cities; 10 people per city. Thus, we add an identifier for `city` to the data +and add some city-related variation to `ls`. + +```{r} +dat$city <- rep(1:10, each = 10) +var_city <- rnorm(10, sd = 10) +dat$ls <- dat$ls + var_city[dat$city] +``` + +With the following code, we fit a multilevel model assuming the intercept and +the effect of `income` to vary by city: + +```{r, results='hide'} +fit6 <- brm(ls ~ mo(income)*age + (mo(income) | city), data = dat) +``` + +```{r} +summary(fit6) +``` + +reveals that the effect of `income` varies only little across cities. For the +present data, this is not overly surprising given that, in the data simulations, +we assumed `income` to have the same effect across cities. + +## References + +Bürkner P. C. & Charpentier, E. (in review). [Monotonic Effects: A Principled +Approach for Including Ordinal Predictors in Regression Models](https://psyarxiv.com/9qkhj/). *PsyArXiv preprint*. diff -Nru r-cran-brms-2.16.3/vignettes/brms_multilevel.ltx r-cran-brms-2.17.0/vignettes/brms_multilevel.ltx --- r-cran-brms-2.16.3/vignettes/brms_multilevel.ltx 2020-07-08 07:08:39.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_multilevel.ltx 2022-03-13 16:10:29.000000000 +0000 @@ -1,679 +1,679 @@ -\documentclass[article, nojss]{jss} - -%\VignetteIndexEntry{Multilevel Models with brms} -%\VignetteEngine{R.rsp::tex} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% almost as usual -\author{Paul-Christian B\"urkner} -\title{Advanced Bayesian Multilevel Modeling with the \proglang{R} Package \pkg{brms}} - -%% for pretty printing and a nice hypersummary also set: -\Plainauthor{Paul-Christian B\"urkner} %% comma-separated -\Plaintitle{Advanced Bayesian Multilevel Modeling with the R Package brms} %% without formatting -\Shorttitle{Advanced Bayesian Multilevel Modeling with \pkg{brms}} %% a short title (if necessary) - -%% an abstract and keywords -\Abstract{ - The \pkg{brms} package allows R users to easily specify a wide range of Bayesian single-level and multilevel models, which are fitted with the probabilistic programming language \proglang{Stan} behind the scenes. Several response distributions are supported, of which all parameters (e.g., location, scale, and shape) can be predicted at the same time thus allowing for distributional regression. Non-linear relationships may be specified using non-linear predictor terms or semi-parametric approaches such as splines or Gaussian processes. Multivariate models, in which each response variable can be predicted using the above mentioned options, can be fitted as well. To make all of these modeling options possible in a multilevel framework, \pkg{brms} provides an intuitive and powerful formula syntax, which extends the well known formula syntax of \pkg{lme4}. The purpose of the present paper is to introduce this syntax in detail and to demonstrate its usefulness with four examples, each showing other relevant aspects of the syntax. If you use \pkg{brms}, please cite this article as published in the R Journal \citep{brms2}. -} -\Keywords{Bayesian inference, multilevel models, distributional regression, MCMC, \proglang{Stan}, \proglang{R}} -\Plainkeywords{Bayesian inference, multilevel models, distributional regression, MCMC, Stan, R} %% without formatting -%% at least one keyword must be supplied - -%% publication information -%% NOTE: Typically, this can be left commented and will be filled out by the technical editor -%% \Volume{50} -%% \Issue{9} -%% \Month{June} -%% \Year{2012} -%% \Submitdate{2012-06-04} -%% \Acceptdate{2012-06-04} - -%% The address of (at least) one author should be given -%% in the following format: -\Address{ - Paul-Christian B\"urkner\\ - E-mail: \email{paul.buerkner@gmail.com}\\ - URL: \url{https://paul-buerkner.github.io} -} -%% It is also possible to add a telephone and fax number -%% before the e-mail in the following format: -%% Telephone: +43/512/507-7103 -%% Fax: +43/512/507-2851 - - -%% for those who use Sweave please include the following line (with % symbols): -%% need no \usepackage{Sweave.sty} - -%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\begin{document} - -%% include your article here, just as usual -%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. - -\section{Introduction} - -Multilevel models (MLMs) offer great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for R have been developed to fit MLMs. Usually, however, the functionality of these implementations is limited insofar as it is only possible to predict the mean of the response distribution. Other parameters of the response distribution, such as the residual standard deviation in linear models, are assumed constant across observations, which may be violated in many applications. Accordingly, it is desirable to allow for prediction of \emph{all} response parameters at the same time. Models doing exactly that are often referred to as \emph{distributional models} or more verbosely \emph{models for location, scale and shape} \citep{rigby2005}. Another limitation of basic MLMs is that they only allow for linear predictor terms. While linear predictor terms already offer good flexibility, they are of limited use when relationships are inherently non-linear. Such non-linearity can be handled in at least two ways: (1) by fully specifying a non-linear predictor term with corresponding parameters each of which can be predicted using MLMs \citep{lindstrom1990}, or (2) estimating the form of the non-linear relationship on the fly using splines \citep{wood2004} or Gaussian processes \citep{rasmussen2006}. The former are often simply called \emph{non-linear models}, while models applying splines are referred to as \emph{generalized additive models} (GAMs; \citeauthor{hastie1990}, \citeyear{hastie1990}). - -Combining all of these modeling options into one framework is a complex task, both conceptually and with regard to model fitting. Maximum likelihood methods, which are typically applied in classical 'frequentist' statistics, can reach their limits at some point and fully Bayesian methods become the go-to solutions to fit such complex models \citep{gelman2014}. In addition to being more flexible, the Bayesian framework comes with other advantages, for instance, the ability to derive probability statements for every quantity of interest or explicitly incorporating prior knowledge about parameters into the model. The former is particularly relevant in non-linear models, for which classical approaches struggle more often than not in propagating all the uncertainty in the parameter estimates to non-linear functions such as out-of-sample predictions. - -Possibly the most powerful program for performing full Bayesian inference available to date is Stan \citep{stanM2017, carpenter2017}. It implements Hamiltonian Monte Carlo \citep{duane1987, neal2011, betancourt2014} and its extension, the No-U-Turn (NUTS) Sampler \citep{hoffman2014}. These algorithms converge much more quickly than other Markov-Chain Monte-Carlo (MCMC) algorithms especially for high-dimensional models \citep{hoffman2014, betancourt2014, betancourt2017}. An excellent non-mathematical introduction to Hamiltonian Monte Carlo can be found in \citet{betancourt2017}. - -Stan comes with its own programming language, allowing for great modeling flexibility \cite{stanM2017, carpenter2017}). Many researchers may still be hesitent to use Stan directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error-prone process even for researchers familiar with Bayesian inference. The \pkg{brms} package \citep{brms1}, presented in this paper, aims to remove these hurdles for a wide range of regression models by allowing the user to benefit from the merits of Stan by using extended \pkg{lme4}-like \citep{bates2015} formula syntax, with which many R users are familiar with. It offers much more than writing efficient and human-readable Stan code: \pkg{brms} comes with many post-processing and visualization functions, for instance to perform posterior predictive checks, leave-one-out cross-validation, visualization of estimated effects, and prediction of new data. The overarching aim is to have one general framework for regression modeling, which offers everything required to successfully apply regression models to complex data. To date, it already replaces and extends the functionality of dozens of other R packages, each of which is restricted to specific regression models\footnote{Unfortunately, due to the implementation via Stan, it is not easily possible for users to define their own response distributions and run them via \pkg{brms}. If you feel that a response distribution is missing in \pkg{brms}, please open an issue on GitHub (\url{https://github.com/paul-buerkner/brms}).}. - -The purpose of the present article is to provide an introduction of the advanced multilevel formula syntax implemented in \pkg{brms}, which allows to fit a wide and growing range of non-linear distributional multilevel models. A general overview of the package is already given in \citet{brms1}. Accordingly, the present article focuses on more recent developments. We begin by explaining the underlying structure of distributional models. Next, the formula syntax of \pkg{lme4} and its extensions implemented in \pkg{brms} are explained. Four examples that demonstrate the use of the new syntax are discussed in detail. Afterwards, the functionality of \pkg{brms} is compared with that of \pkg{rstanarm} \citep{rstanarm2017} and \pkg{MCMCglmm} \citep{hadfield2010}. We end by describing future plans for extending the package. - -\section{Model description} -\label{model} - -The core of models implemented in \pkg{brms} is the prediction of the response $y$ through predicting all parameters $\theta_p$ of the response distribution $D$, which is also called the model \code{family} in many R packages. We write -$$y_i \sim D(\theta_{1i}, \theta_{2i}, ...)$$ -to stress the dependency on the $i\textsuperscript{th}$ observation. Every parameter $\theta_p$ may be regressed on its own predictor term $\eta_p$ transformed by the inverse link function $f_p$ that is $\theta_{pi} = f_p(\eta_{pi})$\footnote{A parameter can also be assumed constant across observations so that a linear predictor is not required.}. Such models are typically refered to as \emph{distributional models}\footnote{The models described in \citet{brms1} are a sub-class of the here described models.}. Details about the parameterization of each \code{family} are given in \code{vignette("brms\_families")}. - -Suppressing the index $p$ for simplicity, a predictor term $\eta$ can generally be written as -$$ -\eta = \mathbf{X} \beta + \mathbf{Z} u + \sum_{k = 1}^K s_k(x_k) -$$ -In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The terms $s_k(x_k)$ symbolize optional smooth functions of unspecified form based on covariates $x_k$ fitted via splines (see \citet{wood2011} for the underlying implementation in the \pkg{mgcv} package) or Gaussian processes \citep{williams1996}. The response $y$ as well as $\mathbf{X}$, $\mathbf{Z}$, and $x_k$ make up the data, whereas $\beta$, $u$, and the smooth functions $s_k$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects, but I avoid theses terms following the recommendations of \citet{gelmanMLM2006}. Details about prior distributions of $\beta$ and $u$ can be found in \citet{brms1} and under \code{help("set\_prior")}. - -As an alternative to the strictly additive formulation described above, predictor terms may also have any form specifiable in Stan. We call it a \emph{non-linear} predictor and write -$$\eta = f(c_1, c_2, ..., \phi_1, \phi_2, ...)$$ -The structure of the function $f$ is given by the user, $c_r$ are known or observed covariates, and $\phi_s$ are non-linear parameters each having its own linear predictor term $\eta_{\phi_s}$ of the form specified above. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves. A frequentist implementation of such models, which inspired the non-linear syntax in \pkg{brms}, can be found in the \pkg{nlme} package \citep{nlme2016}. - -\section{Extended multilevel formula syntax} -\label{formula_syntax} - -The formula syntax applied in \pkg{brms} builds upon the syntax of the R package \pkg{lme4} \citep{bates2015}. First, we will briefly explain the \pkg{lme4} syntax used to specify multilevel models and then introduce certain extensions that allow to specify much more complicated models in \pkg{brms}. An \pkg{lme4} formula has the general form - -\begin{Sinput} -response ~ pterms + (gterms | group) -\end{Sinput} -The \code{pterms} part contains the population-level effects that are assumed to be the same across obervations. The \code{gterms} part contains so called group-level effects that are assumed to vary accross grouping variables specified in \code{group}. Multiple grouping factors each with multiple group-level effects are possible. Usually, \code{group} contains only a single variable name pointing to a factor, but you may also use \code{g1:g2} or \code{g1/g2}, if both \code{g1} and \code{g2} are suitable grouping factors. The \code{:} operator creates a new grouping factor that consists of the combined levels of \code{g1} and \code{g2} (you could think of this as pasting the levels of both factors together). The \code{/} operator indicates nested grouping structures and expands one grouping factor into two or more when using multiple \code{/} within one term. If, for instance, you write \code{(1 | g1/g2)}, it will be expanded to \code{(1 | g1) + (1 | g1:g2)}. Instead of \code{|} you may use \code{||} in grouping terms to prevent group-level correlations from being modeled. This may be useful in particular when modeling so many group-level effects that convergence of the fitting algorithms becomes an issue due to model complexity. One limitation of the \code{||} operator in \pkg{lme4} is that it only splits up terms so that columns of the design matrix originating from the same term are still modeled as correlated (e.g., when coding a categorical predictor; see the \code{mixed} function of the \pkg{afex} package by \citet{afex2015} for a way to avoid this behavior). - -While intuitive and visually appealing, the classic \pkg{lme4} syntax is not flexible enough to allow for specifying the more complex models supported by \pkg{brms}. In non-linear or distributional models, for instance, multiple parameters are predicted, each having their own population and group-level effects. Hence, multiple formulas are necessary to specify such models\footnote{Actually, it is possible to specify multiple model parts within one formula using interactions terms for instance as implemented in \pkg{MCMCglmm} \citep{hadfield2010}. However, this syntax is limited in flexibility and requires a rather deep understanding of the way R parses formulas, thus often being confusing to users.}. Then, however, specifying group-level effects of the same grouping factor to be correlated \emph{across} formulas becomes complicated. The solution implemented in \pkg{brms} (and currently unique to it) is to expand the \code{|} operator into \code{||}, where \code{} can be any value. Group-level terms with the same \code{ID} will then be modeled as correlated if they share same grouping factor(s)\footnote{It might even be further extended to \code{|fun()|}, where \code{fun} defines the type of correlation structure, defaulting to unstructured that is estimating the full correlation matrix. The \code{fun} argument is not yet supported by \pkg{brms} but could be supported in the future if other correlation structures, such as compound symmetry or Toeplitz, turn out to have reasonable practical applications and effective implementations in Stan.}. For instance, if the terms \code{(x1|ID|g1)} and \code{(x2|ID|g1)} appear somewhere in the same or different formulas passed to \pkg{brms}, they will be modeled as correlated. - -Further extensions of the classical \pkg{lme4} syntax refer to the \code{group} part. It is rather limited in its flexibility since only variable names combined by \code{:} or \code{/} are supported. We propose two extensions of this syntax: Firstly, \code{group} can generally be split up in its terms so that, say, \code{(1 | g1 + g2)} is expanded to \code{(1 | g1) + (1 | g2)}. This is fully consistent with the way \code{/} is handled so it provides a natural generalization to the existing syntax. Secondly, there are some special grouping structures that cannot be expressed by simply combining grouping variables. For instance, multi-membership models cannot be expressed this way. To overcome this limitation, we propose wrapping terms in \code{group} within special functions that allow specifying alternative grouping structures: \code{(gterms | fun(group))}. In \pkg{brms}, there are currently two such functions implemented, namely \code{gr} for the default behavior and \code{mm} for multi-membership terms. To be compatible with the original syntax and to keep formulas short, \code{gr} is automatically added internally if none of these functions is specified. - -While some non-linear relationships, such as quadratic relationships, can be expressed within the basic R formula syntax, other more complicated ones cannot. For this reason, it is possible in \pkg{brms} to fully specify non-linear predictor terms similar to how it is done in \pkg{nlme}, but fully compatible with the extended multilevel syntax described above. Suppose, for instance, we want to model the non-linear growth curve -$$ -y = b_1 (1 - \exp(-(x / b_2)^{b_3}) -$$ -between $y$ and $x$ with parameters $b_1$, $b_2$, and $b_3$ (see Example 3 in this paper for an implementation of this model with real data). Furthermore, we want all three parameters to vary by a grouping variable $g$ and model those group-level effects as correlated. Additionally $b_1$ should be predicted by a covariate $z$. We can express this in \pkg{brms} using multiple formulas, one for the non-linear model itself and one per non-linear parameter: -\begin{Sinput} -y ~ b1 * (1 - exp(-(x / b2) ^ b3) -b1 ~ z + (1|ID|g) -b2 ~ (1|ID|g) -b3 ~ (1|ID|g) -\end{Sinput} -The first formula will not be evaluated using standard R formula parsing, but instead taken literally. In contrast, the formulas for the non-linear parameters will be evaluated in the usual way and are compatible with all terms supported by \pkg{brms}. Note that we have used the above described ID-syntax to model group-level effects as correlated across formulas. - -There are other syntax extensions implemented in \pkg{brms} that do not directly target grouping terms. Firstly, there are terms formally included in the \code{pterms} part that are handled separately. The most prominent examples are smooth terms specified through the \code{s} and \code{t2} functions of the \pkg{mgcv} package \citep{wood2011}. Other examples are category specific effects \code{cs}, monotonic effects \code{mo}, noise-free effects \code{me}, or Gaussian process terms \code{gp}. The former is explained in \citet{brms1}, while the latter three are documented in \code{help(brmsformula)}. Internally, these terms are extracted from \code{pterms} and not included in the construction of the population-level design matrix. Secondly, making use of the fact that \code{|} is unused on the left-hand side of $\sim$ in formula, additional information on the response variable may be specified via -\begin{Sinput} -response | aterms ~ -\end{Sinput} -The \code{aterms} part may contain multiple terms of the form \code{fun()} separated by \code{+} each providing special information on the response variable. This allows among others to weight observations, provide known standard errors for meta-analysis, or model censored or truncated data. -As it is not the main topic of the present paper, we refer to \code{help("brmsformula")} and \code{help("addition-terms")} for more details. - -To set up the model formulas and combine them into one object, \pkg{brms} defines the \code{brmsformula} (or short \code{bf}) function. Its output can then be passed to the \code{parse\_bf} function, which splits up the formulas in separate parts and prepares them for the generation of design matrices and related data. Other packages may re-use these functions in their own routines making it easier to offer support for the above described multilevel syntax. - -\section{Examples} - -The idea of \pkg{brms} is to provide one unified framework for multilevel regression models in R. As such, the above described formula syntax in all of its variations can be applied in combination with all response distributions supported by \pkg{brms} (currently about 35 response distributions are supported; see \code{help("brmsfamily")} and \code{vignette("brms\_families")} for an overview). - -In this section, we will discuss four examples in detail, each focusing on certain aspects of the syntax. They are chosen to provide a broad overview of the modeling options. The first is about the number of fish caught be different groups of people. It does not actually contain any multilevel structure, but helps in understanding how to set up formulas for different model parts. The second example is about housing rents in Munich. We model the data using splines and a distributional regression approach. The third example is about cumulative insurance loss payments across several years, which is fitted using a rather complex non-linear multilevel model. Finally, the fourth example is about the performance of school children, who change school during the year, thus requiring a multi-membership model. - -Despite not being covered in the four examples, there are a few more modeling options that we want to briefly describe. First, \pkg{brms} allows fitting so called phylogenetic models. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. Species are not independent as they come from the same phylogenetic tree, implying that different levels of the same grouping-factor (i.e., species) are likely correlated. There is a whole vignette dedicated to this topic, which can be found via \code{vignette("brms\_phylogenetics")}. Second, there is a canonical way to handle ordinal predictors, without falsely assuming they are either categorical or continuous. We call them monotonic effects and discuss them in \code{vignette("brms\_monotonic")}. Last but not least, it is possible to account for measurement error in both response and predictor variables. This is often ignored in applied regression modeling \citep{westfall2016}, although measurement error is very common in all scientific fields making use of observational data. There is no vignette yet covering this topic, but one will be added in the future. In the meantime, \code{help("brmsformula")} is the best place to start learning about such models as well as about other details of the \pkg{brms} formula syntax. - -\subsection{Example 1: Catching fish} - -An important application of the distributional regression framework of \pkg{brms} are so called zero-inflated and hurdle models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), the data are described as follows: ``The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.'' - -\begin{Sinput} -zinb <- read.csv("http://stats.idre.ucla.edu/stat/data/fish.csv") -zinb$camper <- factor(zinb$camper, labels = c("no", "yes")) -head(zinb) -\end{Sinput} - -\begin{Sinput} - nofish livebait camper persons child xb zg count -1 1 0 no 1 0 -0.8963146 3.0504048 0 -2 0 1 yes 1 0 -0.5583450 1.7461489 0 -3 0 1 no 1 0 -0.4017310 0.2799389 0 -4 0 1 yes 2 1 -0.9562981 -0.6015257 0 -5 0 1 no 1 0 0.4368910 0.5277091 1 -6 0 1 yes 4 2 1.3944855 -0.7075348 0 -\end{Sinput} -As predictors we choose the number of people per group, the number of children, as well as whether or not the group consists of campers. Many groups may not catch any fish just because they do not try and so we fit a zero-inflated Poisson model. For now, we assume a constant zero-inflation probability across observations. - -\begin{Sinput} -fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, - family = zero_inflated_poisson("log")) -\end{Sinput} -The model is readily summarized via - -\begin{Sinput} -summary(fit_zinb1) -\end{Sinput} - -\begin{Sinput} - Family: zero_inflated_poisson (log) -Formula: count ~ persons + child + camper - Data: zinb (Number of observations: 250) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: Not computed - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept -1.01 0.17 -1.34 -0.67 2171 1 -persons 0.87 0.04 0.79 0.96 2188 1 -child -1.36 0.09 -1.55 -1.18 1790 1 -camper 0.80 0.09 0.62 0.98 2950 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -zi 0.41 0.04 0.32 0.49 2409 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} -A graphical summary is available through - -\begin{Sinput} -conditional_effects(fit_zinb1) -\end{Sinput} -\begin{figure}[ht] - \centering - \includegraphics[width=0.99\textwidth,keepaspectratio]{me_zinb1.pdf} - \caption{Conditional effects plots of the \code{fit\_zinb1} model.} - \label{me_zinb1} -\end{figure} -(see Figure \ref{me_zinb1}). In fact, the \code{conditional\_effects} method turned out to be so powerful in visualizing effects of predictors that I am using it almost as frequently as \code{summary}. According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability \code{zi} is pretty large with a mean of 41\%. Please note that the probability of catching no fish is actually higher than 41\%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-\emph{inflation}). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here). - -Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish, since children often lack the patience required for fishing. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data. - -\begin{Sinput} -fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), - data = zinb, family = zero_inflated_poisson()) -\end{Sinput} -To transform the linear predictor of \code{zi} into a probability, \pkg{brms} applies the logit-link, which takes values within $[0, 1]$ and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors. - -\begin{Sinput} -summary(fit_zinb2) -\end{Sinput} - -\begin{Sinput} - Family: zero_inflated_poisson (log) -Formula: count ~ persons + child + camper - zi ~ child - Data: zinb (Number of observations: 250) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: Not computed - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept -1.07 0.18 -1.43 -0.73 2322 1 -persons 0.89 0.05 0.80 0.98 2481 1 -child -1.17 0.10 -1.37 -1.00 2615 1 -camper 0.78 0.10 0.60 0.96 3270 1 -zi_Intercept -0.95 0.27 -1.52 -0.48 2341 1 -zi_child 1.21 0.28 0.69 1.79 2492 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} - -According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your chance of catching no fish at all (as implied by the zero-inflation part), possibly because groups with more children spend less time or no time at all fishing. Comparing model fit via leave-one-out cross validation as implemented in the \pkg{loo} package \citep{loo2016, vehtari2016}. - -\begin{Sinput} -LOO(fit_zinb1, fit_zinb2) -\end{Sinput} - -\begin{Sinput} - LOOIC SE -fit_zinb1 1639.52 363.30 -fit_zinb2 1621.35 362.39 -fit_zinb1 - fit_zinb2 18.16 15.71 -\end{Sinput} -reveals that the second model using the number of children to predict both model parts has better fit. However, when considering the standard error of the \code{LOOIC} difference, improvement in model fit is apparently modest and not substantial. More examples of distributional model can be found in \code{vignette("brms\_distreg")}. - -\subsection{Example 2: Housing rents} - -In their book about regression modeling, \citet{fahrmeir2013} use an example about the housing rents in Munich from 1999. The data contains information about roughly 3000 apartments including among others the absolute rent (\code{rent}), rent per square meter (\code{rentsqm}), size of the apartment (\code{area}), construction year (\code{yearc}), and the district in Munich (\code{district}), where the apartment is located. The data can be found in the \pkg{gamlss.data} package \citep{gamlss.data}: - -\begin{Sinput} -data("rent99", package = "gamlss.data") -head(rent99) -\end{Sinput} - -\begin{Sinput} - rent rentsqm area yearc location bath kitchen cheating district -1 109.9487 4.228797 26 1918 2 0 0 0 916 -2 243.2820 8.688646 28 1918 2 0 0 1 813 -3 261.6410 8.721369 30 1918 1 0 0 1 611 -4 106.4103 3.547009 30 1918 2 0 0 0 2025 -5 133.3846 4.446154 30 1918 2 0 0 1 561 -6 339.0256 11.300851 30 1918 2 0 0 1 541 -\end{Sinput} -Here, we aim at predicting the rent per square meter with the size of the apartment as well as the construction year, while taking the district of Munich into account. As the effect of both predictors on the rent is of unknown non-linear form, we model these variables using a bivariate tensor spline \citep{wood2013}. The district is accounted for via a varying intercept. - -\begin{Sinput} -fit_rent1 <- brm(rentsqm ~ t2(area, yearc) + (1|district), data = rent99, - chains = 2, cores = 2) -\end{Sinput} -We fit the model using just two chains (instead of the default of four chains) on two processor cores to reduce the model fitting time for the purpose of the present paper. In general, using the default option of four chains (or more) is recommended. - -\begin{Sinput} -summary(fit_rent1) -\end{Sinput} - -\begin{Sinput} - Family: gaussian(identity) -Formula: rentsqm ~ t2(area, yearc) + (1 | district) - Data: rent99 (Number of observations: 3082) -Samples: 2 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 2000 - ICs: LOO = NA; WAIC = NA; R2 = NA - -Smooth Terms: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sds(t2areayearc_1) 4.93 2.32 1.61 10.77 1546 1.00 -sds(t2areayearc_2) 5.78 2.87 1.58 13.15 1175 1.00 -sds(t2areayearc_3) 8.09 3.19 3.66 16.22 1418 1.00 - -Group-Level Effects: -~district (Number of levels: 336) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 0.60 0.06 0.48 0.73 494 1.01 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept 7.80 0.11 7.59 8.02 2000 1.00 -t2areayearc_1 -1.00 0.09 -1.15 -0.83 2000 1.00 -t2areayearc_2 0.75 0.17 0.43 1.09 2000 1.00 -t2areayearc_3 -0.07 0.16 -0.40 0.24 1579 1.00 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sigma 1.95 0.03 1.90 2.01 2000 1.00 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} -For models including splines, the output of \code{summary} is not tremendously helpful, but we get at least some information. Firstly, the credible intervals of the standard deviations of the coefficients forming the splines (under \code{'Smooth Terms'}) are sufficiently far away from zero to indicate non-linearity in the (combined) effect of \code{area} and \code{yearc}. Secondly, even after controlling for these predictors, districts still vary with respect to rent per square meter by a sizable amount as visible under \code{'Group-Level Effects'} in the output. To further understand the effect of the predictor, we apply graphical methods: - -\begin{Sinput} -conditional_effects(fit_rent1, surface = TRUE) -\end{Sinput} -In Figure \ref{me_rent1}, the conditional effects of both predictors are displayed, while the respective other predictor is fixed at its mean. In Figure \ref{me_rent2}, the combined effect is shown, clearly demonstrating an interaction between the variables. In particular, housing rents appear to be highest for small and relatively new apartments. - -\begin{figure}[ht] - \centering - \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent1.pdf} - \caption{Conditional effects plots of the \code{fit\_rent1} model for single predictors.} - \label{me_rent1} -\end{figure} - -\begin{figure}[ht] - \centering - \includegraphics[width=0.7\textwidth,keepaspectratio]{me_rent2.pdf} - \caption{Surface plot of the \code{fit\_rent1} model for the combined effect of \code{area} and \code{yearc}.} - \label{me_rent2} -\end{figure} - -In the above example, we only considered the mean of the response distribution to vary by \code{area} and \code{yearc}, but this my not necessarily reasonable assumption, as the variation of the response might vary with these variables as well. Accordingly, we fit splines and effects of district for both the location and the scale parameter, which is called \code{sigma} in Gaussian models. - -\begin{Sinput} -bform <- bf(rentsqm ~ t2(area, yearc) + (1|ID1|district), - sigma ~ t2(area, yearc) + (1|ID1|district)) -fit_rent2 <- brm(bform, data = rent99, chains = 2, cores = 2) -\end{Sinput} -If not otherwise specified, \code{sigma} is predicted on the log-scale to ensure it is positive no matter how the predictor term looks like. Instead of \code{(1|district)} as in the previous model, we now use \code{(1|ID1|district)} in both formulas. This results in modeling the varying intercepts of both model parts as correlated (see the description of the ID-syntax above). The group-level part of the \code{summary} output looks as follows: - -\begin{Sinput} -Group-Level Effects: -~district (Number of levels: 336) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 0.60 0.06 0.49 0.73 744 1.00 -sd(sigma_Intercept) 0.11 0.02 0.06 0.15 751 1.00 -cor(Intercept,sigma_Intercept) 0.72 0.17 0.35 0.98 648 1.00 -\end{Sinput} -As visible from the positive correlation of the intercepts, districts with overall higher rent per square meter have higher variation at the same time. Lastly, we want to turn our attention to the splines. While \code{conditional\_effects} is used to visualize effects of predictors on the expected response, \code{conditional\_smooths} is used to show just the spline parts of the model: - -\begin{Sinput} -conditional_smooths(fit_rent2) -\end{Sinput} -The plot on the left-hand side of Figure \ref{me_rent3} resembles the one in Figure \ref{me_rent2}, but the scale is different since only the spline is plotted. The right-hand side of \ref{me_rent3} shows the spline for \code{sigma}. Since we apply the log-link on \code{sigma} by default the spline is on the log-scale as well. As visible in the plot, the variation in the rent per square meter is highest for relatively small and old apartments, while the variation is smallest for medium to large apartments build around the 1960s. - -\begin{figure}[ht] - \centering - \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent3.pdf} - \caption{Plots showing the smooth terms of the \code{fit\_rent2} model.} - \label{me_rent3} -\end{figure} - - -\subsection{Example 3: Insurance loss payments} - -On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see \url{http://www.magesblog.com/2015/11/loss-developments-via-growth-curves-and.html}). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows: - -$$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ -$$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ - -The cumulative insurance payments $cum$ will grow over time, and we model this dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters $\theta$ and $\omega$, which are responsible for the growth of the cumulative loss and are for now assumed to be the same across years. We load the data - -\begin{Sinput} -url <- paste0("https://raw.githubusercontent.com/mages/", - "diesunddas/master/Data/ClarkTriangle.csv") -loss <- read.csv(url) -head(loss) -\end{Sinput} - -\begin{Sinput} - AY dev cum -1 1991 6 357.848 -2 1991 18 1124.788 -3 1991 30 1735.330 -4 1991 42 2182.708 -5 1991 54 2745.596 -6 1991 66 3319.994 -\end{Sinput} -and translate the proposed model into a non-linear \pkg{brms} model. - -\begin{Sinput} -nlform <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), - ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE) - -nlprior <- c(prior(normal(5000, 1000), nlpar = "ult"), - prior(normal(1, 2), nlpar = "omega"), - prior(normal(45, 10), nlpar = "theta")) - -fit_loss1 <- brm(formula = nlform, data = loss, family = gaussian(), - prior = nlprior, control = list(adapt_delta = 0.9)) -\end{Sinput} - -In the above functions calls, quite a few things are going on. The formulas are wrapped in \code{bf} to combine them into one object. The first formula specifies the non-linear model. We set argument \code{nl = TRUE} so that \pkg{brms} takes this formula literally and instead of using standard R formula parsing. We specify one additional formula per non-linear parameter (a) to clarify what variables are covariates and what are parameters and (b) to specify the predictor term for the parameters. We estimate a group-level effect of accident year (variable \code{AY}) for the ultimate loss \code{ult}. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in the case of \code{ult}, contains only a varying intercept for year. Both \code{omega} and \code{theta} are assumed to be constant across observations so we just fit a population-level intercept. - -Priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. Otherwise, we may observe that different Markov chains converge to different parameter regions as multiple posterior distribution are equally plausible. Setting prior distributions is a difficult task especially in non-linear models. It requires some experience and knowledge both about the model that is being fitted and about the data at hand. Additionally, there is more to keep in mind to optimize the sampler's performance: Firstly, using non- or weakly informative priors in non-linear models often leads to problems even if the model is generally identified. For instance, if a zero-centered and reasonably wide prior such as \code{normal(0, 10000)} it set on \code{ult}, there is little information about \code{theta} and \code{omega} for samples of \code{ult} being close to zero, which may lead to convergence problems. Secondly, Stan works best when parameters are roughly on the same order of magnitude \citep{stan2017}. In the present example, \code{ult} is of three orders larger than \code{omega}. Still, the sampler seems to work quite well, but this may not be true for other models. One solution is to rescale parameters before model fitting. For instance, for the present example, one could have downscaled \code{ult} by replacing it with \code{ult * 1000} and correspondingly the \code{normal(5000, 1000)} prior with \code{normal(5, 1)}. - -In the \code{control} argument we increase \code{adapt\_delta} to get rid of a few divergent transitions (cf. \citeauthor{stan2017}, \citeyear{stan2017}; \citeauthor{brms1}, \citeyear{brms1}). Again the model is summarized via - -\begin{Sinput} -summary(fit_loss1) -\end{Sinput} - -\begin{Sinput} - Family: gaussian (identity) -Formula: cum ~ ult * (1 - exp(-(dev / theta)^omega)) - ult ~ 1 + (1 | AY) - omega ~ 1 - theta ~ 1 - Data: loss (Number of observations: 55) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: Not computed - -Group-Level Effects: -~AY (Number of levels: 10) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(ult_Intercept) 745.74 231.31 421.05 1306.04 916 1 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -ult_Intercept 5273.70 292.34 4707.11 5852.28 798 1 -omega_Intercept 1.34 0.05 1.24 1.43 2167 1 -theta_Intercept 46.07 2.09 42.38 50.57 1896 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sigma 139.93 15.52 113.6 175.33 2358 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} -as well as - -\begin{Sinput} -conditional_effects(fit_loss1) -\end{Sinput} -\begin{figure}[ht] - \centering - \includegraphics[width=0.7\textwidth,keepaspectratio]{me_loss1.pdf} - \caption{Conditional effects plots of the \code{fit\_loss1} model.} - \label{me_loss1} -\end{figure} -(see Figure \ref{me_loss1}). We can also visualize the cumulative insurance loss over time separately for each year. - -\begin{Sinput} -conditions <- data.frame(AY = unique(loss$AY)) -rownames(conditions) <- unique(loss$AY) -me_year <- conditional_effects(fit_loss1, conditions = conditions, - re_formula = NULL, method = "predict") -plot(me_year, ncol = 5, points = TRUE) -\end{Sinput} -\begin{figure}[ht] - \centering - \includegraphics[width=0.99\textwidth,keepaspectratio]{me_loss1_year.pdf} - \caption{Conditional effects plots of the \code{fit\_loss1} model separately for each accident year.} - \label{me_loss1_year} -\end{figure} -(see Figure \ref{me_loss1_year}). It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. - -In the above model, we considered \code{omega} and \code{delta} to be constant across years, which may not necessarily be true. We can easily investigate this by fitting varying intercepts for all three non-linear parameters also estimating group-level correlation using the above introduced \code{ID} syntax. - -\begin{Sinput} -nlform2 <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), - ult ~ 1 + (1|ID1|AY), omega ~ 1 + (1|ID1|AY), - theta ~ 1 + (1|ID1|AY), nl = TRUE) - -fit_loss2 <- update(fit_loss1, formula = nlform2, - control = list(adapt_delta = 0.90)) -\end{Sinput} -We could have also specified all predictor terms more conveniently within one formula as -\begin{Sinput} -ult + omega + theta ~ 1 + (1|ID1|AY) -\end{Sinput} -because the structure of the predictor terms is identical. To compare model fit, we perform leave-one-out cross-validation. - -\begin{Sinput} -LOO(fit_loss1, fit_loss2) -\end{Sinput} - -\begin{Sinput} - LOOIC SE -fit_loss1 715.44 19.24 -fit_loss2 720.60 19.85 -fit_loss1 - fit_loss2 -5.15 5.34 -\end{Sinput} - -Since smaller values indicate better expected out-of-sample predictions and thus better model fit, the simpler model that only has a varying intercept over parameter \code{ult} is preferred. This may not be overly surprising, given that three varying intercepts as well as three group-level correlations are probably overkill for data containing only 55 observations. Nevertheless, it nicely demonstrates how to apply the \code{ID} syntax in practice. More examples of non-linear models can be found in \code{vignette("brms\_nonlinear")}. - -\subsection{Example 4: Performance of school children} - -Suppose that we want to predict the performance of students in the final exams at the end of the year. There are many variables to consider, but one important factor will clearly be school membership. Schools might differ in the ratio of teachers and students, the general quality of teaching, in the cognitive ability of the students they draw, or other factors we are not aware of that induce dependency among students of the same school. Thus, it is advised to apply a multilevel modeling techniques including school membership as a group-level term. Of course, we should account for class membership and other levels of the educational hierarchy as well, but for the purpose of the present example, we will focus on schools only. Usually, accounting for school membership is pretty-straight forward by simply adding a varying intercept to the formula: \code{(1 | school)}. However, a non-negligible number of students might change schools during the year. This would result in a situation where one student is a member of multiple schools and so we need a multi-membership model. Setting up such a model not only requires information on the different schools students attend during the year, but also the amount of time spend at each school. The latter can be used to weight the influence each school has on its students, since more time attending a school will likely result in greater influence. For now, let us assume that students change schools maximally once a year and spend equal time at each school. We will later see how to relax these assumptions. - -Real educational data are usually relatively large and complex so that we simulate our own data for the purpose of this tutorial paper. We simulate 10 schools and 1000 students, with each school having the same expected number of 100 students. We model 10\% of students as changing schools. - -\begin{Sinput} -data_mm <- sim_multi_mem(nschools = 10, nstudents = 1000, change = 0.1) -head(data_mm) -\end{Sinput} - -\begin{Sinput} - s1 s2 w1 w2 y -1 8 9 0.5 0.5 16.27422 -2 10 9 0.5 0.5 18.71387 -3 5 3 0.5 0.5 23.65319 -4 3 5 0.5 0.5 22.35204 -5 5 3 0.5 0.5 16.38019 -6 10 6 0.5 0.5 17.63494 -\end{Sinput} -The code of function \code{sim\_multi\_mem} can be found in the online supplement of the present paper. For reasons of better illustration, students changing schools appear in the first rows of the data. Data of students being only at a single school looks as follows: - -\begin{Sinput} -data_mm[101:106, ] -\end{Sinput} - -\begin{Sinput} - s1 s2 w1 w2 y -101 2 2 0.5 0.5 27.247851 -102 9 9 0.5 0.5 24.041427 -103 4 4 0.5 0.5 12.575001 -104 2 2 0.5 0.5 21.203644 -105 4 4 0.5 0.5 12.856166 -106 4 4 0.5 0.5 9.740174 -\end{Sinput} -Thus, school variables are identical, but we still have to specify both in order to pass the data appropriately. Incorporating no other predictors into the model for simplicity, a multi-membership model is specified as - -\begin{Sinput} -fit_mm <- brm(y ~ 1 + (1 | mm(s1, s2)), data = data_mm) -\end{Sinput} -The only new syntax element is that multiple grouping factors (\code{s1} and \code{s2}) are wrapped in \code{mm}. Everything else remains exactly the same. Note that we did not specify the relative weights of schools for each student and thus, by default, equal weights are assumed. - -\begin{Sinput} -summary(fit_mm) -\end{Sinput} - -\begin{Sinput} - Family: gaussian (identity) -Formula: y ~ 1 + (1 | mm(s1, s2)) - Data: data_mm (Number of observations: 1000) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: Not computed - -Group-Level Effects: -~mms1s2 (Number of levels: 10) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 2.76 0.82 1.69 4.74 682 1.01 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept 19 0.93 17.06 20.8 610 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sigma 3.58 0.08 3.43 3.75 2117 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Sinput} - -With regard to the assumptions made in the above example, it is unlikely that all children who change schools stay in both schools equally long. To relax this assumption, we have to specify weights. First, we amend the simulated data to contain non-equal weights for students changing schools. For all other students, weighting does of course not matter as they stay in the same school anyway. - -\begin{Sinput} -data_mm[1:100, "w1"] <- runif(100, 0, 1) -data_mm[1:100, "w2"] <- 1 - data_mm[1:100, "w1"] -head(data_mm) -\end{Sinput} - -\begin{Sinput} - s1 s2 w1 w2 y -1 8 9 0.3403258 0.65967423 16.27422 -2 10 9 0.1771435 0.82285652 18.71387 -3 5 3 0.9059811 0.09401892 23.65319 -4 3 5 0.4432007 0.55679930 22.35204 -5 5 3 0.8052026 0.19479738 16.38019 -6 10 6 0.5610243 0.43897567 17.63494 -\end{Sinput} -Incorporating these weights into the model is straight forward. - -\begin{Sinput} -fit_mm2 <- brm(y ~ 1 + (1 | mm(s1, s2, weights = cbind(w1, w2))), - data = data_mm) -\end{Sinput} -The summary output is similar to the previous, so we do not show it here. The second assumption that students change schools only once a year, may also easily be relaxed by providing more than two grouping factors, say, \code{mm(s1, s2, s3)}. - -\section{Comparison between packages} - -Over the years, many R packages have been developed that implement MLMs, each being more or less general in their supported models. In \cite{brms1}, I compared \pkg{brms} with \pkg{lme4} \citep{bates2015}, \pkg{MCMCglmm} \citep{hadfield2010}, \pkg{rstanarm} \citep{rstanarm2017}, and \pkg{rethinking} \citep{mcelreath2017}. Since then, quite a few new features have been added in particular to \pkg{brms} and \pkg{rstanarm}. Accordingly, in the present paper, I will update these comparisons, but focus on \pkg{brms}, \pkg{rstanarm}, and \pkg{MCMCglmm} as the possibly most important R packages implementing Bayesian MLMs. While \pkg{brms} and \pkg{rstanarm} are both based on the probabilistic programming language \pkg{Stan}, \pkg{MCMCglmm} implements its own custom MCMC algorithm. Modeling options and other important information of these packages are summarized in Table~\ref{comparison} and will be discussed in detail below. - -Regarding general model classes, all three packages support the most common types such as linear, count data and certain survival models. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. Additionally, they offer support for zero-inflated and hurdle models to account for access zeros in the data (see Example 1 above). For survival / time-to-event models, \pkg{rstanarm} offers great flexibility via the \code{stan\_jm} function, which allows for complex association structures between time-to-event data and one or more models of longitudinal covariates (for details see \url{https://cran.r-project.org/web/packages/rstanarm/vignettes/jm.html}). Model classes currently specific to \pkg{brms} are robust linear models using Student's t-distribution (family \code{student}) as well as response times models via the exponentially modified Gaussian (family \code{exgaussian}) distribution or the Wiener diffusion model (family \code{wiener}). The latter allows to simultaneously model dichotomous decisions and their corresponding response times (for a detailed example see \url{http://singmann.org/wiener-model-analysis-with-brms-part-i/}). - -All three packages offer many additional modeling options, with \pkg{brms} currently having the greatest flexibility (see Table~\ref{comparison} for a summary). Moreover, the packages differ in the general framework, in which they are implemented: \pkg{brms} and \pkg{MCMCglmm} each come with a single model fitting function (\code{brm} and \code{MCMCglmm} respectively), through which all of their models can be specified. Further, their framework allows to seamlessly combine most modeling options with each other in the same model. In contrast, the approach of \pkg{rstanarm} is to emulate existing functions of other packages. This has the advantage of an easier transition between classical and Bayesian models, since the syntax used to specify models stays the same. However, it comes with the main disadvantage that many modeling options cannot be used in combination within the same model. - -Information criteria are available in all three packages. The advantages of WAIC and LOO implemented in \pkg{brms} and \pkg{rstanarm}, are their less restrictive assumptions and that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the packages, \pkg{brms} offers a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, I believe that the way priors are specified in \pkg{brms} is more intuitive as it is directly evident what prior is actually applied. In \pkg{brms}, Bayes factors are available both via Savage-Dickey ratios \citep{wagenmakers2010} and bridge-sampling \citep{bridgesampling2017}, while \pkg{rstanarm} allows for the latter option. For a detailed comparison with respect to sampling efficiency, see \cite{brms1}. - - -\begin{table}[hbtp] -\centering -\begin{tabular}{llll} - & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline -\\ [-1.5ex] -\parbox{6cm}{\textbf{Model classes}} & & & \\ [1ex] -Linear models & yes & yes & yes \\ -Robust linear models & yes & no & no \\ -Count data models & yes & yes & yes \\ -Survival models & yes & yes$^1$ & yes \\ -Response times models & yes & no & no \\ -Beta models & yes & yes & no \\ -Categorical models & yes & yes$^2$ & yes \\ -Multinomial models & no & no & yes \\ -Ordinal models & various & cumulative$^2$ & cumulative \\ -Zero-inflated and hurdle models & yes & no & yes \\ \hline -\\ [-1.5ex] -\parbox{5cm}{\textbf{Modeling options}} & & & \\ [1ex] -Variable link functions & various & various & no \\ -Multilevel structures & yes & yes & yes \\ -Multi-membership & yes & no & yes \\ -Multivariate responses & yes & yes$^3$ & yes \\ -Non-linear predictors & yes & limited$^4$ & no \\ -Distributional regression & yes & no & no \\ -Finite mixtures & yes & no & no \\ -Splines (additive models) & yes & yes & yes \\ -Gaussian Processes & yes & no & no \\ -Temporal autocorrelation & yes & yes$^{2, 5}$ & no \\ -Spatial autocorrelation & yes & yes$^{2, 5}$ & no \\ -Monotonic effects & yes & no & no \\ -Category specific effects & yes & no & no \\ -Measurement error & yes & no & no \\ -Weights & yes & yes & no \\ -Offset & yes & yes & using priors \\ -Censored data & yes & yes$^1$ & yes \\ -Truncated data & yes & no & no \\ -Customized covariances & yes & no & yes \\ -Missing value imputation & no & no & no \\ \hline -\\ [-1.5ex] -\textbf{Bayesian specifics} & & & \\ [1ex] -Population-level priors & flexible & flexible & normal \\ -Group-level priors & normal & normal & normal \\ -Covariance priors & flexible & restricted$^6$ & restricted$^7$ \\ -Bayes factors & yes & yes$^8$ & no \\ -Parallelization & yes & yes & no \\ \hline -\\ [-1.5ex] -\textbf{Other} & & & \\ [1ex] -Estimator & HMC, NUTS & HMC, NUTS & MH, Gibbs$^9$ \\ -Information criterion & WAIC, LOO & WAIC, LOO & DIC \\ -C++ compiler required & yes & no & no \\ \hline -\end{tabular} -\caption{ -Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{MCMCglmm} packages. Notes: (1) Advanced functionality available via \code{stan\_jm}. (2) No group-level terms and related functionality allowed. (3) Cannot be combined with other modeling options such as splines. (4) Functionality limited to linear Gaussian models and certein pre-specified non-linear functions. (5) Functionality available only on GitHub branches (\url{https://github.com/stan-dev/rstanarm}). (6) For details see \cite{hadfield2010}. (7) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}. (8) Available via the \pkg{bridgesampling} package \citep{bridgesampling2017}. (9) Estimator consists of a combination of both algorithms. -} -\label{comparison} -\end{table} - -\section{Conclusion} - -The present paper is meant to introduce R users and developers to the extended \pkg{lme4} formula syntax applied in \pkg{brms}. Only a subset of modeling options were discussed in detail, which ensured the paper was not too broad. For some of the more basic models that \pkg{brms} can fit, see \citet{brms1}. Many more examples can be found in the growing number of vignettes accompanying the package (see \code{vignette(package = "brms")} for an overview). - -To date, \pkg{brms} is already one of the most flexible R packages when it comes to regression modeling. However, for the future, there are quite a few more features that I am planning to implement (see \url{https://github.com/paul-buerkner/brms/issues} for the current list of issues). In addition to smaller, incremental updates, I have two specific features in mind: (1) latent variables estimated via confirmatory factor analysis and (2) missing value imputation. I receive ideas and suggestions from users almost every day -- for which I am always grateful -- and so the list of features that will be implemented in the proceeding versions of \pkg{brms} will continue to grow. - -\section*{Acknowledgments} - -First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language Stan, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Furthermore, I want to thank Heinz Holling, Donald Williams and Ruben Arslan for valuable comments on earlier versions of the paper. I also would like to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. - -\bibliography{citations_multilevel} - -\end{document} +\documentclass[article, nojss]{jss} + +%\VignetteIndexEntry{Multilevel Models with brms} +%\VignetteEngine{R.rsp::tex} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% almost as usual +\author{Paul-Christian B\"urkner} +\title{Advanced Bayesian Multilevel Modeling with the \proglang{R} Package \pkg{brms}} + +%% for pretty printing and a nice hypersummary also set: +\Plainauthor{Paul-Christian B\"urkner} %% comma-separated +\Plaintitle{Advanced Bayesian Multilevel Modeling with the R Package brms} %% without formatting +\Shorttitle{Advanced Bayesian Multilevel Modeling with \pkg{brms}} %% a short title (if necessary) + +%% an abstract and keywords +\Abstract{ + The \pkg{brms} package allows R users to easily specify a wide range of Bayesian single-level and multilevel models, which are fitted with the probabilistic programming language \proglang{Stan} behind the scenes. Several response distributions are supported, of which all parameters (e.g., location, scale, and shape) can be predicted at the same time thus allowing for distributional regression. Non-linear relationships may be specified using non-linear predictor terms or semi-parametric approaches such as splines or Gaussian processes. Multivariate models, in which each response variable can be predicted using the above mentioned options, can be fitted as well. To make all of these modeling options possible in a multilevel framework, \pkg{brms} provides an intuitive and powerful formula syntax, which extends the well known formula syntax of \pkg{lme4}. The purpose of the present paper is to introduce this syntax in detail and to demonstrate its usefulness with four examples, each showing other relevant aspects of the syntax. If you use \pkg{brms}, please cite this article as published in the R Journal \citep{brms2}. +} +\Keywords{Bayesian inference, multilevel models, distributional regression, MCMC, \proglang{Stan}, \proglang{R}} +\Plainkeywords{Bayesian inference, multilevel models, distributional regression, MCMC, Stan, R} %% without formatting +%% at least one keyword must be supplied + +%% publication information +%% NOTE: Typically, this can be left commented and will be filled out by the technical editor +%% \Volume{50} +%% \Issue{9} +%% \Month{June} +%% \Year{2012} +%% \Submitdate{2012-06-04} +%% \Acceptdate{2012-06-04} + +%% The address of (at least) one author should be given +%% in the following format: +\Address{ + Paul-Christian B\"urkner\\ + E-mail: \email{paul.buerkner@gmail.com}\\ + URL: \url{https://paul-buerkner.github.io} +} +%% It is also possible to add a telephone and fax number +%% before the e-mail in the following format: +%% Telephone: +43/512/507-7103 +%% Fax: +43/512/507-2851 + + +%% for those who use Sweave please include the following line (with % symbols): +%% need no \usepackage{Sweave.sty} + +%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{document} + +%% include your article here, just as usual +%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. + +\section{Introduction} + +Multilevel models (MLMs) offer great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for R have been developed to fit MLMs. Usually, however, the functionality of these implementations is limited insofar as it is only possible to predict the mean of the response distribution. Other parameters of the response distribution, such as the residual standard deviation in linear models, are assumed constant across observations, which may be violated in many applications. Accordingly, it is desirable to allow for prediction of \emph{all} response parameters at the same time. Models doing exactly that are often referred to as \emph{distributional models} or more verbosely \emph{models for location, scale and shape} \citep{rigby2005}. Another limitation of basic MLMs is that they only allow for linear predictor terms. While linear predictor terms already offer good flexibility, they are of limited use when relationships are inherently non-linear. Such non-linearity can be handled in at least two ways: (1) by fully specifying a non-linear predictor term with corresponding parameters each of which can be predicted using MLMs \citep{lindstrom1990}, or (2) estimating the form of the non-linear relationship on the fly using splines \citep{wood2004} or Gaussian processes \citep{rasmussen2006}. The former are often simply called \emph{non-linear models}, while models applying splines are referred to as \emph{generalized additive models} (GAMs; \citeauthor{hastie1990}, \citeyear{hastie1990}). + +Combining all of these modeling options into one framework is a complex task, both conceptually and with regard to model fitting. Maximum likelihood methods, which are typically applied in classical 'frequentist' statistics, can reach their limits at some point and fully Bayesian methods become the go-to solutions to fit such complex models \citep{gelman2014}. In addition to being more flexible, the Bayesian framework comes with other advantages, for instance, the ability to derive probability statements for every quantity of interest or explicitly incorporating prior knowledge about parameters into the model. The former is particularly relevant in non-linear models, for which classical approaches struggle more often than not in propagating all the uncertainty in the parameter estimates to non-linear functions such as out-of-sample predictions. + +Possibly the most powerful program for performing full Bayesian inference available to date is Stan \citep{stanM2017, carpenter2017}. It implements Hamiltonian Monte Carlo \citep{duane1987, neal2011, betancourt2014} and its extension, the No-U-Turn (NUTS) Sampler \citep{hoffman2014}. These algorithms converge much more quickly than other Markov-Chain Monte-Carlo (MCMC) algorithms especially for high-dimensional models \citep{hoffman2014, betancourt2014, betancourt2017}. An excellent non-mathematical introduction to Hamiltonian Monte Carlo can be found in \citet{betancourt2017}. + +Stan comes with its own programming language, allowing for great modeling flexibility \cite{stanM2017, carpenter2017}). Many researchers may still be hesitent to use Stan directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error-prone process even for researchers familiar with Bayesian inference. The \pkg{brms} package \citep{brms1}, presented in this paper, aims to remove these hurdles for a wide range of regression models by allowing the user to benefit from the merits of Stan by using extended \pkg{lme4}-like \citep{bates2015} formula syntax, with which many R users are familiar with. It offers much more than writing efficient and human-readable Stan code: \pkg{brms} comes with many post-processing and visualization functions, for instance to perform posterior predictive checks, leave-one-out cross-validation, visualization of estimated effects, and prediction of new data. The overarching aim is to have one general framework for regression modeling, which offers everything required to successfully apply regression models to complex data. To date, it already replaces and extends the functionality of dozens of other R packages, each of which is restricted to specific regression models\footnote{Unfortunately, due to the implementation via Stan, it is not easily possible for users to define their own response distributions and run them via \pkg{brms}. If you feel that a response distribution is missing in \pkg{brms}, please open an issue on GitHub (\url{https://github.com/paul-buerkner/brms}).}. + +The purpose of the present article is to provide an introduction of the advanced multilevel formula syntax implemented in \pkg{brms}, which allows to fit a wide and growing range of non-linear distributional multilevel models. A general overview of the package is already given in \citet{brms1}. Accordingly, the present article focuses on more recent developments. We begin by explaining the underlying structure of distributional models. Next, the formula syntax of \pkg{lme4} and its extensions implemented in \pkg{brms} are explained. Four examples that demonstrate the use of the new syntax are discussed in detail. Afterwards, the functionality of \pkg{brms} is compared with that of \pkg{rstanarm} \citep{rstanarm2017} and \pkg{MCMCglmm} \citep{hadfield2010}. We end by describing future plans for extending the package. + +\section{Model description} +\label{model} + +The core of models implemented in \pkg{brms} is the prediction of the response $y$ through predicting all parameters $\theta_p$ of the response distribution $D$, which is also called the model \code{family} in many R packages. We write +$$y_i \sim D(\theta_{1i}, \theta_{2i}, ...)$$ +to stress the dependency on the $i\textsuperscript{th}$ observation. Every parameter $\theta_p$ may be regressed on its own predictor term $\eta_p$ transformed by the inverse link function $f_p$ that is $\theta_{pi} = f_p(\eta_{pi})$\footnote{A parameter can also be assumed constant across observations so that a linear predictor is not required.}. Such models are typically refered to as \emph{distributional models}\footnote{The models described in \citet{brms1} are a sub-class of the here described models.}. Details about the parameterization of each \code{family} are given in \code{vignette("brms\_families")}. + +Suppressing the index $p$ for simplicity, a predictor term $\eta$ can generally be written as +$$ +\eta = \mathbf{X} \beta + \mathbf{Z} u + \sum_{k = 1}^K s_k(x_k) +$$ +In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The terms $s_k(x_k)$ symbolize optional smooth functions of unspecified form based on covariates $x_k$ fitted via splines (see \citet{wood2011} for the underlying implementation in the \pkg{mgcv} package) or Gaussian processes \citep{williams1996}. The response $y$ as well as $\mathbf{X}$, $\mathbf{Z}$, and $x_k$ make up the data, whereas $\beta$, $u$, and the smooth functions $s_k$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects, but I avoid theses terms following the recommendations of \citet{gelmanMLM2006}. Details about prior distributions of $\beta$ and $u$ can be found in \citet{brms1} and under \code{help("set\_prior")}. + +As an alternative to the strictly additive formulation described above, predictor terms may also have any form specifiable in Stan. We call it a \emph{non-linear} predictor and write +$$\eta = f(c_1, c_2, ..., \phi_1, \phi_2, ...)$$ +The structure of the function $f$ is given by the user, $c_r$ are known or observed covariates, and $\phi_s$ are non-linear parameters each having its own linear predictor term $\eta_{\phi_s}$ of the form specified above. In fact, we should think of non-linear parameters as placeholders for linear predictor terms rather than as parameters themselves. A frequentist implementation of such models, which inspired the non-linear syntax in \pkg{brms}, can be found in the \pkg{nlme} package \citep{nlme2016}. + +\section{Extended multilevel formula syntax} +\label{formula_syntax} + +The formula syntax applied in \pkg{brms} builds upon the syntax of the R package \pkg{lme4} \citep{bates2015}. First, we will briefly explain the \pkg{lme4} syntax used to specify multilevel models and then introduce certain extensions that allow to specify much more complicated models in \pkg{brms}. An \pkg{lme4} formula has the general form + +\begin{Sinput} +response ~ pterms + (gterms | group) +\end{Sinput} +The \code{pterms} part contains the population-level effects that are assumed to be the same across obervations. The \code{gterms} part contains so called group-level effects that are assumed to vary accross grouping variables specified in \code{group}. Multiple grouping factors each with multiple group-level effects are possible. Usually, \code{group} contains only a single variable name pointing to a factor, but you may also use \code{g1:g2} or \code{g1/g2}, if both \code{g1} and \code{g2} are suitable grouping factors. The \code{:} operator creates a new grouping factor that consists of the combined levels of \code{g1} and \code{g2} (you could think of this as pasting the levels of both factors together). The \code{/} operator indicates nested grouping structures and expands one grouping factor into two or more when using multiple \code{/} within one term. If, for instance, you write \code{(1 | g1/g2)}, it will be expanded to \code{(1 | g1) + (1 | g1:g2)}. Instead of \code{|} you may use \code{||} in grouping terms to prevent group-level correlations from being modeled. This may be useful in particular when modeling so many group-level effects that convergence of the fitting algorithms becomes an issue due to model complexity. One limitation of the \code{||} operator in \pkg{lme4} is that it only splits up terms so that columns of the design matrix originating from the same term are still modeled as correlated (e.g., when coding a categorical predictor; see the \code{mixed} function of the \pkg{afex} package by \citet{afex2015} for a way to avoid this behavior). + +While intuitive and visually appealing, the classic \pkg{lme4} syntax is not flexible enough to allow for specifying the more complex models supported by \pkg{brms}. In non-linear or distributional models, for instance, multiple parameters are predicted, each having their own population and group-level effects. Hence, multiple formulas are necessary to specify such models\footnote{Actually, it is possible to specify multiple model parts within one formula using interactions terms for instance as implemented in \pkg{MCMCglmm} \citep{hadfield2010}. However, this syntax is limited in flexibility and requires a rather deep understanding of the way R parses formulas, thus often being confusing to users.}. Then, however, specifying group-level effects of the same grouping factor to be correlated \emph{across} formulas becomes complicated. The solution implemented in \pkg{brms} (and currently unique to it) is to expand the \code{|} operator into \code{||}, where \code{} can be any value. Group-level terms with the same \code{ID} will then be modeled as correlated if they share same grouping factor(s)\footnote{It might even be further extended to \code{|fun()|}, where \code{fun} defines the type of correlation structure, defaulting to unstructured that is estimating the full correlation matrix. The \code{fun} argument is not yet supported by \pkg{brms} but could be supported in the future if other correlation structures, such as compound symmetry or Toeplitz, turn out to have reasonable practical applications and effective implementations in Stan.}. For instance, if the terms \code{(x1|ID|g1)} and \code{(x2|ID|g1)} appear somewhere in the same or different formulas passed to \pkg{brms}, they will be modeled as correlated. + +Further extensions of the classical \pkg{lme4} syntax refer to the \code{group} part. It is rather limited in its flexibility since only variable names combined by \code{:} or \code{/} are supported. We propose two extensions of this syntax: Firstly, \code{group} can generally be split up in its terms so that, say, \code{(1 | g1 + g2)} is expanded to \code{(1 | g1) + (1 | g2)}. This is fully consistent with the way \code{/} is handled so it provides a natural generalization to the existing syntax. Secondly, there are some special grouping structures that cannot be expressed by simply combining grouping variables. For instance, multi-membership models cannot be expressed this way. To overcome this limitation, we propose wrapping terms in \code{group} within special functions that allow specifying alternative grouping structures: \code{(gterms | fun(group))}. In \pkg{brms}, there are currently two such functions implemented, namely \code{gr} for the default behavior and \code{mm} for multi-membership terms. To be compatible with the original syntax and to keep formulas short, \code{gr} is automatically added internally if none of these functions is specified. + +While some non-linear relationships, such as quadratic relationships, can be expressed within the basic R formula syntax, other more complicated ones cannot. For this reason, it is possible in \pkg{brms} to fully specify non-linear predictor terms similar to how it is done in \pkg{nlme}, but fully compatible with the extended multilevel syntax described above. Suppose, for instance, we want to model the non-linear growth curve +$$ +y = b_1 (1 - \exp(-(x / b_2)^{b_3}) +$$ +between $y$ and $x$ with parameters $b_1$, $b_2$, and $b_3$ (see Example 3 in this paper for an implementation of this model with real data). Furthermore, we want all three parameters to vary by a grouping variable $g$ and model those group-level effects as correlated. Additionally $b_1$ should be predicted by a covariate $z$. We can express this in \pkg{brms} using multiple formulas, one for the non-linear model itself and one per non-linear parameter: +\begin{Sinput} +y ~ b1 * (1 - exp(-(x / b2) ^ b3) +b1 ~ z + (1|ID|g) +b2 ~ (1|ID|g) +b3 ~ (1|ID|g) +\end{Sinput} +The first formula will not be evaluated using standard R formula parsing, but instead taken literally. In contrast, the formulas for the non-linear parameters will be evaluated in the usual way and are compatible with all terms supported by \pkg{brms}. Note that we have used the above described ID-syntax to model group-level effects as correlated across formulas. + +There are other syntax extensions implemented in \pkg{brms} that do not directly target grouping terms. Firstly, there are terms formally included in the \code{pterms} part that are handled separately. The most prominent examples are smooth terms specified through the \code{s} and \code{t2} functions of the \pkg{mgcv} package \citep{wood2011}. Other examples are category specific effects \code{cs}, monotonic effects \code{mo}, noise-free effects \code{me}, or Gaussian process terms \code{gp}. The former is explained in \citet{brms1}, while the latter three are documented in \code{help(brmsformula)}. Internally, these terms are extracted from \code{pterms} and not included in the construction of the population-level design matrix. Secondly, making use of the fact that \code{|} is unused on the left-hand side of $\sim$ in formula, additional information on the response variable may be specified via +\begin{Sinput} +response | aterms ~ +\end{Sinput} +The \code{aterms} part may contain multiple terms of the form \code{fun()} separated by \code{+} each providing special information on the response variable. This allows among others to weight observations, provide known standard errors for meta-analysis, or model censored or truncated data. +As it is not the main topic of the present paper, we refer to \code{help("brmsformula")} and \code{help("addition-terms")} for more details. + +To set up the model formulas and combine them into one object, \pkg{brms} defines the \code{brmsformula} (or short \code{bf}) function. Its output can then be passed to the \code{parse\_bf} function, which splits up the formulas in separate parts and prepares them for the generation of design matrices and related data. Other packages may re-use these functions in their own routines making it easier to offer support for the above described multilevel syntax. + +\section{Examples} + +The idea of \pkg{brms} is to provide one unified framework for multilevel regression models in R. As such, the above described formula syntax in all of its variations can be applied in combination with all response distributions supported by \pkg{brms} (currently about 35 response distributions are supported; see \code{help("brmsfamily")} and \code{vignette("brms\_families")} for an overview). + +In this section, we will discuss four examples in detail, each focusing on certain aspects of the syntax. They are chosen to provide a broad overview of the modeling options. The first is about the number of fish caught be different groups of people. It does not actually contain any multilevel structure, but helps in understanding how to set up formulas for different model parts. The second example is about housing rents in Munich. We model the data using splines and a distributional regression approach. The third example is about cumulative insurance loss payments across several years, which is fitted using a rather complex non-linear multilevel model. Finally, the fourth example is about the performance of school children, who change school during the year, thus requiring a multi-membership model. + +Despite not being covered in the four examples, there are a few more modeling options that we want to briefly describe. First, \pkg{brms} allows fitting so called phylogenetic models. These models are relevant in evolutionary biology when data of many species are analyzed at the same time. Species are not independent as they come from the same phylogenetic tree, implying that different levels of the same grouping-factor (i.e., species) are likely correlated. There is a whole vignette dedicated to this topic, which can be found via \code{vignette("brms\_phylogenetics")}. Second, there is a canonical way to handle ordinal predictors, without falsely assuming they are either categorical or continuous. We call them monotonic effects and discuss them in \code{vignette("brms\_monotonic")}. Last but not least, it is possible to account for measurement error in both response and predictor variables. This is often ignored in applied regression modeling \citep{westfall2016}, although measurement error is very common in all scientific fields making use of observational data. There is no vignette yet covering this topic, but one will be added in the future. In the meantime, \code{help("brmsformula")} is the best place to start learning about such models as well as about other details of the \pkg{brms} formula syntax. + +\subsection{Example 1: Catching fish} + +An important application of the distributional regression framework of \pkg{brms} are so called zero-inflated and hurdle models. These models are helpful whenever there are more zeros in the response variable than one would naturally expect. Here, we consider an example dealing with the number of fish caught by various groups of people. On the UCLA website (\url{https://stats.idre.ucla.edu/stata/dae/zero-inflated-poisson-regression}), the data are described as follows: ``The state wildlife biologists want to model how many fish are being caught by fishermen at a state park. Visitors are asked how long they stayed, how many people were in the group, were there children in the group and how many fish were caught. Some visitors do not fish, but there is no data on whether a person fished or not. Some visitors who did fish did not catch any fish so there are excess zeros in the data because of the people that did not fish.'' + +\begin{Sinput} +zinb <- read.csv("http://stats.idre.ucla.edu/stat/data/fish.csv") +zinb$camper <- factor(zinb$camper, labels = c("no", "yes")) +head(zinb) +\end{Sinput} + +\begin{Sinput} + nofish livebait camper persons child xb zg count +1 1 0 no 1 0 -0.8963146 3.0504048 0 +2 0 1 yes 1 0 -0.5583450 1.7461489 0 +3 0 1 no 1 0 -0.4017310 0.2799389 0 +4 0 1 yes 2 1 -0.9562981 -0.6015257 0 +5 0 1 no 1 0 0.4368910 0.5277091 1 +6 0 1 yes 4 2 1.3944855 -0.7075348 0 +\end{Sinput} +As predictors we choose the number of people per group, the number of children, as well as whether or not the group consists of campers. Many groups may not catch any fish just because they do not try and so we fit a zero-inflated Poisson model. For now, we assume a constant zero-inflation probability across observations. + +\begin{Sinput} +fit_zinb1 <- brm(count ~ persons + child + camper, data = zinb, + family = zero_inflated_poisson("log")) +\end{Sinput} +The model is readily summarized via + +\begin{Sinput} +summary(fit_zinb1) +\end{Sinput} + +\begin{Sinput} + Family: zero_inflated_poisson (log) +Formula: count ~ persons + child + camper + Data: zinb (Number of observations: 250) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: Not computed + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept -1.01 0.17 -1.34 -0.67 2171 1 +persons 0.87 0.04 0.79 0.96 2188 1 +child -1.36 0.09 -1.55 -1.18 1790 1 +camper 0.80 0.09 0.62 0.98 2950 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +zi 0.41 0.04 0.32 0.49 2409 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} +A graphical summary is available through + +\begin{Sinput} +conditional_effects(fit_zinb1) +\end{Sinput} +\begin{figure}[ht] + \centering + \includegraphics[width=0.99\textwidth,keepaspectratio]{me_zinb1.pdf} + \caption{Conditional effects plots of the \code{fit\_zinb1} model.} + \label{me_zinb1} +\end{figure} +(see Figure \ref{me_zinb1}). In fact, the \code{conditional\_effects} method turned out to be so powerful in visualizing effects of predictors that I am using it almost as frequently as \code{summary}. According to the parameter estimates, larger groups catch more fish, campers catch more fish than non-campers, and groups with more children catch less fish. The zero-inflation probability \code{zi} is pretty large with a mean of 41\%. Please note that the probability of catching no fish is actually higher than 41\%, but parts of this probability are already modeled by the Poisson distribution itself (hence the name zero-\emph{inflation}). If you want to treat all zeros as originating from a separate process, you can use hurdle models instead (not shown here). + +Now, we try to additionally predict the zero-inflation probability by the number of children. The underlying reasoning is that we expect groups with more children to not even try catching fish, since children often lack the patience required for fishing. From a purely statistical perspective, zero-inflated (and hurdle) distributions are a mixture of two processes and predicting both parts of the model is natural and often very reasonable to make full use of the data. + +\begin{Sinput} +fit_zinb2 <- brm(bf(count ~ persons + child + camper, zi ~ child), + data = zinb, family = zero_inflated_poisson()) +\end{Sinput} +To transform the linear predictor of \code{zi} into a probability, \pkg{brms} applies the logit-link, which takes values within $[0, 1]$ and returns values on the real line. Thus, it allows the transition between probabilities and linear predictors. + +\begin{Sinput} +summary(fit_zinb2) +\end{Sinput} + +\begin{Sinput} + Family: zero_inflated_poisson (log) +Formula: count ~ persons + child + camper + zi ~ child + Data: zinb (Number of observations: 250) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: Not computed + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept -1.07 0.18 -1.43 -0.73 2322 1 +persons 0.89 0.05 0.80 0.98 2481 1 +child -1.17 0.10 -1.37 -1.00 2615 1 +camper 0.78 0.10 0.60 0.96 3270 1 +zi_Intercept -0.95 0.27 -1.52 -0.48 2341 1 +zi_child 1.21 0.28 0.69 1.79 2492 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} + +According to the model, trying to fish with children not only decreases the overall number fish caught (as implied by the Poisson part of the model) but also drastically increases your chance of catching no fish at all (as implied by the zero-inflation part), possibly because groups with more children spend less time or no time at all fishing. Comparing model fit via leave-one-out cross validation as implemented in the \pkg{loo} package \citep{loo2016, vehtari2016}. + +\begin{Sinput} +LOO(fit_zinb1, fit_zinb2) +\end{Sinput} + +\begin{Sinput} + LOOIC SE +fit_zinb1 1639.52 363.30 +fit_zinb2 1621.35 362.39 +fit_zinb1 - fit_zinb2 18.16 15.71 +\end{Sinput} +reveals that the second model using the number of children to predict both model parts has better fit. However, when considering the standard error of the \code{LOOIC} difference, improvement in model fit is apparently modest and not substantial. More examples of distributional model can be found in \code{vignette("brms\_distreg")}. + +\subsection{Example 2: Housing rents} + +In their book about regression modeling, \citet{fahrmeir2013} use an example about the housing rents in Munich from 1999. The data contains information about roughly 3000 apartments including among others the absolute rent (\code{rent}), rent per square meter (\code{rentsqm}), size of the apartment (\code{area}), construction year (\code{yearc}), and the district in Munich (\code{district}), where the apartment is located. The data can be found in the \pkg{gamlss.data} package \citep{gamlss.data}: + +\begin{Sinput} +data("rent99", package = "gamlss.data") +head(rent99) +\end{Sinput} + +\begin{Sinput} + rent rentsqm area yearc location bath kitchen cheating district +1 109.9487 4.228797 26 1918 2 0 0 0 916 +2 243.2820 8.688646 28 1918 2 0 0 1 813 +3 261.6410 8.721369 30 1918 1 0 0 1 611 +4 106.4103 3.547009 30 1918 2 0 0 0 2025 +5 133.3846 4.446154 30 1918 2 0 0 1 561 +6 339.0256 11.300851 30 1918 2 0 0 1 541 +\end{Sinput} +Here, we aim at predicting the rent per square meter with the size of the apartment as well as the construction year, while taking the district of Munich into account. As the effect of both predictors on the rent is of unknown non-linear form, we model these variables using a bivariate tensor spline \citep{wood2013}. The district is accounted for via a varying intercept. + +\begin{Sinput} +fit_rent1 <- brm(rentsqm ~ t2(area, yearc) + (1|district), data = rent99, + chains = 2, cores = 2) +\end{Sinput} +We fit the model using just two chains (instead of the default of four chains) on two processor cores to reduce the model fitting time for the purpose of the present paper. In general, using the default option of four chains (or more) is recommended. + +\begin{Sinput} +summary(fit_rent1) +\end{Sinput} + +\begin{Sinput} + Family: gaussian(identity) +Formula: rentsqm ~ t2(area, yearc) + (1 | district) + Data: rent99 (Number of observations: 3082) +Samples: 2 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 2000 + ICs: LOO = NA; WAIC = NA; R2 = NA + +Smooth Terms: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sds(t2areayearc_1) 4.93 2.32 1.61 10.77 1546 1.00 +sds(t2areayearc_2) 5.78 2.87 1.58 13.15 1175 1.00 +sds(t2areayearc_3) 8.09 3.19 3.66 16.22 1418 1.00 + +Group-Level Effects: +~district (Number of levels: 336) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 0.60 0.06 0.48 0.73 494 1.01 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept 7.80 0.11 7.59 8.02 2000 1.00 +t2areayearc_1 -1.00 0.09 -1.15 -0.83 2000 1.00 +t2areayearc_2 0.75 0.17 0.43 1.09 2000 1.00 +t2areayearc_3 -0.07 0.16 -0.40 0.24 1579 1.00 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sigma 1.95 0.03 1.90 2.01 2000 1.00 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} +For models including splines, the output of \code{summary} is not tremendously helpful, but we get at least some information. Firstly, the credible intervals of the standard deviations of the coefficients forming the splines (under \code{'Smooth Terms'}) are sufficiently far away from zero to indicate non-linearity in the (combined) effect of \code{area} and \code{yearc}. Secondly, even after controlling for these predictors, districts still vary with respect to rent per square meter by a sizable amount as visible under \code{'Group-Level Effects'} in the output. To further understand the effect of the predictor, we apply graphical methods: + +\begin{Sinput} +conditional_effects(fit_rent1, surface = TRUE) +\end{Sinput} +In Figure \ref{me_rent1}, the conditional effects of both predictors are displayed, while the respective other predictor is fixed at its mean. In Figure \ref{me_rent2}, the combined effect is shown, clearly demonstrating an interaction between the variables. In particular, housing rents appear to be highest for small and relatively new apartments. + +\begin{figure}[ht] + \centering + \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent1.pdf} + \caption{Conditional effects plots of the \code{fit\_rent1} model for single predictors.} + \label{me_rent1} +\end{figure} + +\begin{figure}[ht] + \centering + \includegraphics[width=0.7\textwidth,keepaspectratio]{me_rent2.pdf} + \caption{Surface plot of the \code{fit\_rent1} model for the combined effect of \code{area} and \code{yearc}.} + \label{me_rent2} +\end{figure} + +In the above example, we only considered the mean of the response distribution to vary by \code{area} and \code{yearc}, but this my not necessarily reasonable assumption, as the variation of the response might vary with these variables as well. Accordingly, we fit splines and effects of district for both the location and the scale parameter, which is called \code{sigma} in Gaussian models. + +\begin{Sinput} +bform <- bf(rentsqm ~ t2(area, yearc) + (1|ID1|district), + sigma ~ t2(area, yearc) + (1|ID1|district)) +fit_rent2 <- brm(bform, data = rent99, chains = 2, cores = 2) +\end{Sinput} +If not otherwise specified, \code{sigma} is predicted on the log-scale to ensure it is positive no matter how the predictor term looks like. Instead of \code{(1|district)} as in the previous model, we now use \code{(1|ID1|district)} in both formulas. This results in modeling the varying intercepts of both model parts as correlated (see the description of the ID-syntax above). The group-level part of the \code{summary} output looks as follows: + +\begin{Sinput} +Group-Level Effects: +~district (Number of levels: 336) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 0.60 0.06 0.49 0.73 744 1.00 +sd(sigma_Intercept) 0.11 0.02 0.06 0.15 751 1.00 +cor(Intercept,sigma_Intercept) 0.72 0.17 0.35 0.98 648 1.00 +\end{Sinput} +As visible from the positive correlation of the intercepts, districts with overall higher rent per square meter have higher variation at the same time. Lastly, we want to turn our attention to the splines. While \code{conditional\_effects} is used to visualize effects of predictors on the expected response, \code{conditional\_smooths} is used to show just the spline parts of the model: + +\begin{Sinput} +conditional_smooths(fit_rent2) +\end{Sinput} +The plot on the left-hand side of Figure \ref{me_rent3} resembles the one in Figure \ref{me_rent2}, but the scale is different since only the spline is plotted. The right-hand side of \ref{me_rent3} shows the spline for \code{sigma}. Since we apply the log-link on \code{sigma} by default the spline is on the log-scale as well. As visible in the plot, the variation in the rent per square meter is highest for relatively small and old apartments, while the variation is smallest for medium to large apartments build around the 1960s. + +\begin{figure}[ht] + \centering + \includegraphics[width=0.99\textwidth,keepaspectratio]{me_rent3.pdf} + \caption{Plots showing the smooth terms of the \code{fit\_rent2} model.} + \label{me_rent3} +\end{figure} + + +\subsection{Example 3: Insurance loss payments} + +On his blog, Markus Gesmann predicts the growth of cumulative insurance loss payments over time, originated from different origin years (see \url{http://www.magesblog.com/2015/11/loss-developments-via-growth-curves-and.html}). We will use a slightly simplified version of his model for demonstration purposes here. It looks as follows: + +$$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ +$$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ + +The cumulative insurance payments $cum$ will grow over time, and we model this dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be estimated) ultimate loss of accident each year. It constitutes a non-linear parameter in our framework along with the parameters $\theta$ and $\omega$, which are responsible for the growth of the cumulative loss and are for now assumed to be the same across years. We load the data + +\begin{Sinput} +url <- paste0("https://raw.githubusercontent.com/mages/", + "diesunddas/master/Data/ClarkTriangle.csv") +loss <- read.csv(url) +head(loss) +\end{Sinput} + +\begin{Sinput} + AY dev cum +1 1991 6 357.848 +2 1991 18 1124.788 +3 1991 30 1735.330 +4 1991 42 2182.708 +5 1991 54 2745.596 +6 1991 66 3319.994 +\end{Sinput} +and translate the proposed model into a non-linear \pkg{brms} model. + +\begin{Sinput} +nlform <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), + ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, nl = TRUE) + +nlprior <- c(prior(normal(5000, 1000), nlpar = "ult"), + prior(normal(1, 2), nlpar = "omega"), + prior(normal(45, 10), nlpar = "theta")) + +fit_loss1 <- brm(formula = nlform, data = loss, family = gaussian(), + prior = nlprior, control = list(adapt_delta = 0.9)) +\end{Sinput} + +In the above functions calls, quite a few things are going on. The formulas are wrapped in \code{bf} to combine them into one object. The first formula specifies the non-linear model. We set argument \code{nl = TRUE} so that \pkg{brms} takes this formula literally and instead of using standard R formula parsing. We specify one additional formula per non-linear parameter (a) to clarify what variables are covariates and what are parameters and (b) to specify the predictor term for the parameters. We estimate a group-level effect of accident year (variable \code{AY}) for the ultimate loss \code{ult}. This also shows nicely how a non-linear parameter is actually a placeholder for a linear predictor, which in the case of \code{ult}, contains only a varying intercept for year. Both \code{omega} and \code{theta} are assumed to be constant across observations so we just fit a population-level intercept. + +Priors on population-level effects are required and, for the present model, are actually mandatory to ensure identifiability. Otherwise, we may observe that different Markov chains converge to different parameter regions as multiple posterior distribution are equally plausible. Setting prior distributions is a difficult task especially in non-linear models. It requires some experience and knowledge both about the model that is being fitted and about the data at hand. Additionally, there is more to keep in mind to optimize the sampler's performance: Firstly, using non- or weakly informative priors in non-linear models often leads to problems even if the model is generally identified. For instance, if a zero-centered and reasonably wide prior such as \code{normal(0, 10000)} it set on \code{ult}, there is little information about \code{theta} and \code{omega} for samples of \code{ult} being close to zero, which may lead to convergence problems. Secondly, Stan works best when parameters are roughly on the same order of magnitude \citep{stan2017}. In the present example, \code{ult} is of three orders larger than \code{omega}. Still, the sampler seems to work quite well, but this may not be true for other models. One solution is to rescale parameters before model fitting. For instance, for the present example, one could have downscaled \code{ult} by replacing it with \code{ult * 1000} and correspondingly the \code{normal(5000, 1000)} prior with \code{normal(5, 1)}. + +In the \code{control} argument we increase \code{adapt\_delta} to get rid of a few divergent transitions (cf. \citeauthor{stan2017}, \citeyear{stan2017}; \citeauthor{brms1}, \citeyear{brms1}). Again the model is summarized via + +\begin{Sinput} +summary(fit_loss1) +\end{Sinput} + +\begin{Sinput} + Family: gaussian (identity) +Formula: cum ~ ult * (1 - exp(-(dev / theta)^omega)) + ult ~ 1 + (1 | AY) + omega ~ 1 + theta ~ 1 + Data: loss (Number of observations: 55) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: Not computed + +Group-Level Effects: +~AY (Number of levels: 10) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(ult_Intercept) 745.74 231.31 421.05 1306.04 916 1 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +ult_Intercept 5273.70 292.34 4707.11 5852.28 798 1 +omega_Intercept 1.34 0.05 1.24 1.43 2167 1 +theta_Intercept 46.07 2.09 42.38 50.57 1896 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sigma 139.93 15.52 113.6 175.33 2358 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} +as well as + +\begin{Sinput} +conditional_effects(fit_loss1) +\end{Sinput} +\begin{figure}[ht] + \centering + \includegraphics[width=0.7\textwidth,keepaspectratio]{me_loss1.pdf} + \caption{Conditional effects plots of the \code{fit\_loss1} model.} + \label{me_loss1} +\end{figure} +(see Figure \ref{me_loss1}). We can also visualize the cumulative insurance loss over time separately for each year. + +\begin{Sinput} +conditions <- data.frame(AY = unique(loss$AY)) +rownames(conditions) <- unique(loss$AY) +me_year <- conditional_effects(fit_loss1, conditions = conditions, + re_formula = NULL, method = "predict") +plot(me_year, ncol = 5, points = TRUE) +\end{Sinput} +\begin{figure}[ht] + \centering + \includegraphics[width=0.99\textwidth,keepaspectratio]{me_loss1_year.pdf} + \caption{Conditional effects plots of the \code{fit\_loss1} model separately for each accident year.} + \label{me_loss1_year} +\end{figure} +(see Figure \ref{me_loss1_year}). It is evident that there is some variation in cumulative loss across accident years, for instance due to natural disasters happening only in certain years. Further, we see that the uncertainty in the predicted cumulative loss is larger for later years with fewer available data points. + +In the above model, we considered \code{omega} and \code{delta} to be constant across years, which may not necessarily be true. We can easily investigate this by fitting varying intercepts for all three non-linear parameters also estimating group-level correlation using the above introduced \code{ID} syntax. + +\begin{Sinput} +nlform2 <- bf(cum ~ ult * (1 - exp(-(dev / theta)^omega)), + ult ~ 1 + (1|ID1|AY), omega ~ 1 + (1|ID1|AY), + theta ~ 1 + (1|ID1|AY), nl = TRUE) + +fit_loss2 <- update(fit_loss1, formula = nlform2, + control = list(adapt_delta = 0.90)) +\end{Sinput} +We could have also specified all predictor terms more conveniently within one formula as +\begin{Sinput} +ult + omega + theta ~ 1 + (1|ID1|AY) +\end{Sinput} +because the structure of the predictor terms is identical. To compare model fit, we perform leave-one-out cross-validation. + +\begin{Sinput} +LOO(fit_loss1, fit_loss2) +\end{Sinput} + +\begin{Sinput} + LOOIC SE +fit_loss1 715.44 19.24 +fit_loss2 720.60 19.85 +fit_loss1 - fit_loss2 -5.15 5.34 +\end{Sinput} + +Since smaller values indicate better expected out-of-sample predictions and thus better model fit, the simpler model that only has a varying intercept over parameter \code{ult} is preferred. This may not be overly surprising, given that three varying intercepts as well as three group-level correlations are probably overkill for data containing only 55 observations. Nevertheless, it nicely demonstrates how to apply the \code{ID} syntax in practice. More examples of non-linear models can be found in \code{vignette("brms\_nonlinear")}. + +\subsection{Example 4: Performance of school children} + +Suppose that we want to predict the performance of students in the final exams at the end of the year. There are many variables to consider, but one important factor will clearly be school membership. Schools might differ in the ratio of teachers and students, the general quality of teaching, in the cognitive ability of the students they draw, or other factors we are not aware of that induce dependency among students of the same school. Thus, it is advised to apply a multilevel modeling techniques including school membership as a group-level term. Of course, we should account for class membership and other levels of the educational hierarchy as well, but for the purpose of the present example, we will focus on schools only. Usually, accounting for school membership is pretty-straight forward by simply adding a varying intercept to the formula: \code{(1 | school)}. However, a non-negligible number of students might change schools during the year. This would result in a situation where one student is a member of multiple schools and so we need a multi-membership model. Setting up such a model not only requires information on the different schools students attend during the year, but also the amount of time spend at each school. The latter can be used to weight the influence each school has on its students, since more time attending a school will likely result in greater influence. For now, let us assume that students change schools maximally once a year and spend equal time at each school. We will later see how to relax these assumptions. + +Real educational data are usually relatively large and complex so that we simulate our own data for the purpose of this tutorial paper. We simulate 10 schools and 1000 students, with each school having the same expected number of 100 students. We model 10\% of students as changing schools. + +\begin{Sinput} +data_mm <- sim_multi_mem(nschools = 10, nstudents = 1000, change = 0.1) +head(data_mm) +\end{Sinput} + +\begin{Sinput} + s1 s2 w1 w2 y +1 8 9 0.5 0.5 16.27422 +2 10 9 0.5 0.5 18.71387 +3 5 3 0.5 0.5 23.65319 +4 3 5 0.5 0.5 22.35204 +5 5 3 0.5 0.5 16.38019 +6 10 6 0.5 0.5 17.63494 +\end{Sinput} +The code of function \code{sim\_multi\_mem} can be found in the online supplement of the present paper. For reasons of better illustration, students changing schools appear in the first rows of the data. Data of students being only at a single school looks as follows: + +\begin{Sinput} +data_mm[101:106, ] +\end{Sinput} + +\begin{Sinput} + s1 s2 w1 w2 y +101 2 2 0.5 0.5 27.247851 +102 9 9 0.5 0.5 24.041427 +103 4 4 0.5 0.5 12.575001 +104 2 2 0.5 0.5 21.203644 +105 4 4 0.5 0.5 12.856166 +106 4 4 0.5 0.5 9.740174 +\end{Sinput} +Thus, school variables are identical, but we still have to specify both in order to pass the data appropriately. Incorporating no other predictors into the model for simplicity, a multi-membership model is specified as + +\begin{Sinput} +fit_mm <- brm(y ~ 1 + (1 | mm(s1, s2)), data = data_mm) +\end{Sinput} +The only new syntax element is that multiple grouping factors (\code{s1} and \code{s2}) are wrapped in \code{mm}. Everything else remains exactly the same. Note that we did not specify the relative weights of schools for each student and thus, by default, equal weights are assumed. + +\begin{Sinput} +summary(fit_mm) +\end{Sinput} + +\begin{Sinput} + Family: gaussian (identity) +Formula: y ~ 1 + (1 | mm(s1, s2)) + Data: data_mm (Number of observations: 1000) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: Not computed + +Group-Level Effects: +~mms1s2 (Number of levels: 10) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 2.76 0.82 1.69 4.74 682 1.01 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept 19 0.93 17.06 20.8 610 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sigma 3.58 0.08 3.43 3.75 2117 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Sinput} + +With regard to the assumptions made in the above example, it is unlikely that all children who change schools stay in both schools equally long. To relax this assumption, we have to specify weights. First, we amend the simulated data to contain non-equal weights for students changing schools. For all other students, weighting does of course not matter as they stay in the same school anyway. + +\begin{Sinput} +data_mm[1:100, "w1"] <- runif(100, 0, 1) +data_mm[1:100, "w2"] <- 1 - data_mm[1:100, "w1"] +head(data_mm) +\end{Sinput} + +\begin{Sinput} + s1 s2 w1 w2 y +1 8 9 0.3403258 0.65967423 16.27422 +2 10 9 0.1771435 0.82285652 18.71387 +3 5 3 0.9059811 0.09401892 23.65319 +4 3 5 0.4432007 0.55679930 22.35204 +5 5 3 0.8052026 0.19479738 16.38019 +6 10 6 0.5610243 0.43897567 17.63494 +\end{Sinput} +Incorporating these weights into the model is straight forward. + +\begin{Sinput} +fit_mm2 <- brm(y ~ 1 + (1 | mm(s1, s2, weights = cbind(w1, w2))), + data = data_mm) +\end{Sinput} +The summary output is similar to the previous, so we do not show it here. The second assumption that students change schools only once a year, may also easily be relaxed by providing more than two grouping factors, say, \code{mm(s1, s2, s3)}. + +\section{Comparison between packages} + +Over the years, many R packages have been developed that implement MLMs, each being more or less general in their supported models. In \cite{brms1}, I compared \pkg{brms} with \pkg{lme4} \citep{bates2015}, \pkg{MCMCglmm} \citep{hadfield2010}, \pkg{rstanarm} \citep{rstanarm2017}, and \pkg{rethinking} \citep{mcelreath2017}. Since then, quite a few new features have been added in particular to \pkg{brms} and \pkg{rstanarm}. Accordingly, in the present paper, I will update these comparisons, but focus on \pkg{brms}, \pkg{rstanarm}, and \pkg{MCMCglmm} as the possibly most important R packages implementing Bayesian MLMs. While \pkg{brms} and \pkg{rstanarm} are both based on the probabilistic programming language \pkg{Stan}, \pkg{MCMCglmm} implements its own custom MCMC algorithm. Modeling options and other important information of these packages are summarized in Table~\ref{comparison} and will be discussed in detail below. + +Regarding general model classes, all three packages support the most common types such as linear, count data and certain survival models. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. Additionally, they offer support for zero-inflated and hurdle models to account for access zeros in the data (see Example 1 above). For survival / time-to-event models, \pkg{rstanarm} offers great flexibility via the \code{stan\_jm} function, which allows for complex association structures between time-to-event data and one or more models of longitudinal covariates (for details see \url{https://cran.r-project.org/web/packages/rstanarm/vignettes/jm.html}). Model classes currently specific to \pkg{brms} are robust linear models using Student's t-distribution (family \code{student}) as well as response times models via the exponentially modified Gaussian (family \code{exgaussian}) distribution or the Wiener diffusion model (family \code{wiener}). The latter allows to simultaneously model dichotomous decisions and their corresponding response times (for a detailed example see \url{http://singmann.org/wiener-model-analysis-with-brms-part-i/}). + +All three packages offer many additional modeling options, with \pkg{brms} currently having the greatest flexibility (see Table~\ref{comparison} for a summary). Moreover, the packages differ in the general framework, in which they are implemented: \pkg{brms} and \pkg{MCMCglmm} each come with a single model fitting function (\code{brm} and \code{MCMCglmm} respectively), through which all of their models can be specified. Further, their framework allows to seamlessly combine most modeling options with each other in the same model. In contrast, the approach of \pkg{rstanarm} is to emulate existing functions of other packages. This has the advantage of an easier transition between classical and Bayesian models, since the syntax used to specify models stays the same. However, it comes with the main disadvantage that many modeling options cannot be used in combination within the same model. + +Information criteria are available in all three packages. The advantages of WAIC and LOO implemented in \pkg{brms} and \pkg{rstanarm}, are their less restrictive assumptions and that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the packages, \pkg{brms} offers a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, I believe that the way priors are specified in \pkg{brms} is more intuitive as it is directly evident what prior is actually applied. In \pkg{brms}, Bayes factors are available both via Savage-Dickey ratios \citep{wagenmakers2010} and bridge-sampling \citep{bridgesampling2017}, while \pkg{rstanarm} allows for the latter option. For a detailed comparison with respect to sampling efficiency, see \cite{brms1}. + + +\begin{table}[hbtp] +\centering +\begin{tabular}{llll} + & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline +\\ [-1.5ex] +\parbox{6cm}{\textbf{Model classes}} & & & \\ [1ex] +Linear models & yes & yes & yes \\ +Robust linear models & yes & no & no \\ +Count data models & yes & yes & yes \\ +Survival models & yes & yes$^1$ & yes \\ +Response times models & yes & no & no \\ +Beta models & yes & yes & no \\ +Categorical models & yes & yes$^2$ & yes \\ +Multinomial models & no & no & yes \\ +Ordinal models & various & cumulative$^2$ & cumulative \\ +Zero-inflated and hurdle models & yes & no & yes \\ \hline +\\ [-1.5ex] +\parbox{5cm}{\textbf{Modeling options}} & & & \\ [1ex] +Variable link functions & various & various & no \\ +Multilevel structures & yes & yes & yes \\ +Multi-membership & yes & no & yes \\ +Multivariate responses & yes & yes$^3$ & yes \\ +Non-linear predictors & yes & limited$^4$ & no \\ +Distributional regression & yes & no & no \\ +Finite mixtures & yes & no & no \\ +Splines (additive models) & yes & yes & yes \\ +Gaussian Processes & yes & no & no \\ +Temporal autocorrelation & yes & yes$^{2, 5}$ & no \\ +Spatial autocorrelation & yes & yes$^{2, 5}$ & no \\ +Monotonic effects & yes & no & no \\ +Category specific effects & yes & no & no \\ +Measurement error & yes & no & no \\ +Weights & yes & yes & no \\ +Offset & yes & yes & using priors \\ +Censored data & yes & yes$^1$ & yes \\ +Truncated data & yes & no & no \\ +Customized covariances & yes & no & yes \\ +Missing value imputation & no & no & no \\ \hline +\\ [-1.5ex] +\textbf{Bayesian specifics} & & & \\ [1ex] +Population-level priors & flexible & flexible & normal \\ +Group-level priors & normal & normal & normal \\ +Covariance priors & flexible & restricted$^6$ & restricted$^7$ \\ +Bayes factors & yes & yes$^8$ & no \\ +Parallelization & yes & yes & no \\ \hline +\\ [-1.5ex] +\textbf{Other} & & & \\ [1ex] +Estimator & HMC, NUTS & HMC, NUTS & MH, Gibbs$^9$ \\ +Information criterion & WAIC, LOO & WAIC, LOO & DIC \\ +C++ compiler required & yes & no & no \\ \hline +\end{tabular} +\caption{ +Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{MCMCglmm} packages. Notes: (1) Advanced functionality available via \code{stan\_jm}. (2) No group-level terms and related functionality allowed. (3) Cannot be combined with other modeling options such as splines. (4) Functionality limited to linear Gaussian models and certein pre-specified non-linear functions. (5) Functionality available only on GitHub branches (\url{https://github.com/stan-dev/rstanarm}). (6) For details see \cite{hadfield2010}. (7) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}. (8) Available via the \pkg{bridgesampling} package \citep{bridgesampling2017}. (9) Estimator consists of a combination of both algorithms. +} +\label{comparison} +\end{table} + +\section{Conclusion} + +The present paper is meant to introduce R users and developers to the extended \pkg{lme4} formula syntax applied in \pkg{brms}. Only a subset of modeling options were discussed in detail, which ensured the paper was not too broad. For some of the more basic models that \pkg{brms} can fit, see \citet{brms1}. Many more examples can be found in the growing number of vignettes accompanying the package (see \code{vignette(package = "brms")} for an overview). + +To date, \pkg{brms} is already one of the most flexible R packages when it comes to regression modeling. However, for the future, there are quite a few more features that I am planning to implement (see \url{https://github.com/paul-buerkner/brms/issues} for the current list of issues). In addition to smaller, incremental updates, I have two specific features in mind: (1) latent variables estimated via confirmatory factor analysis and (2) missing value imputation. I receive ideas and suggestions from users almost every day -- for which I am always grateful -- and so the list of features that will be implemented in the proceeding versions of \pkg{brms} will continue to grow. + +\section*{Acknowledgments} + +First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language Stan, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Furthermore, I want to thank Heinz Holling, Donald Williams and Ruben Arslan for valuable comments on earlier versions of the paper. I also would like to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. + +\bibliography{citations_multilevel} + +\end{document} diff -Nru r-cran-brms-2.16.3/vignettes/brms_multivariate.Rmd r-cran-brms-2.17.0/vignettes/brms_multivariate.Rmd --- r-cran-brms-2.16.3/vignettes/brms_multivariate.Rmd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_multivariate.Rmd 2022-04-11 07:21:22.000000000 +0000 @@ -1,193 +1,195 @@ ---- -title: "Estimating Multivariate Models with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Multivariate Models with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -In the present vignette, we want to discuss how to specify multivariate multilevel models using **brms**. We call a model *multivariate* if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the `tarsus` length as well as the `back` color of chicks. Half of the brood were put into another `fosternest`, while the other half stayed in the fosternest of their own `dam`. This allows to separate genetic from environmental factors. Additionally, we have information about the `hatchdate` and `sex` of the chicks (the latter being known for 94\% of the animals). - -```{r data} -data("BTdata", package = "MCMCglmm") -head(BTdata) -``` - -## Basic Multivariate Models - -We begin with a relatively simple multivariate normal model. - -```{r fit1, message=FALSE, warning=FALSE, results='hide'} -fit1 <- brm( - mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam), - data = BTdata, chains = 2, cores = 2 -) -``` - -As can be seen in the model code, we have used `mvbind` notation to tell -**brms** that both `tarsus` and `back` are separate response variables. The term -`(1|p|fosternest)` indicates a varying intercept over `fosternest`. By writing -`|p|` in between we indicate that all varying effects of `fosternest` should be -modeled as correlated. This makes sense since we actually have two model parts, -one for `tarsus` and one for `back`. The indicator `p` is arbitrary and can be -replaced by other symbols that comes into your mind (for details about the -multilevel syntax of **brms**, see `help("brmsformula")` and -`vignette("brms_multilevel")`). Similarly, the term `(1|q|dam)` indicates -correlated varying effects of the genetic mother of the chicks. Alternatively, -we could have also modeled the genetic similarities through pedigrees and -corresponding relatedness matrices, but this is not the focus of this vignette -(please see `vignette("brms_phylogenetics")`). The model results are readily -summarized via - -```{r summary1, warning=FALSE} -fit1 <- add_criterion(fit1, "loo") -summary(fit1) -``` - -The summary output of multivariate models closely resembles those of univariate -models, except that the parameters now have the corresponding response variable -as prefix. Within dams, tarsus length and back color seem to be negatively -correlated, while within fosternests the opposite is true. This indicates -differential effects of genetic and environmental factors on these two -characteristics. Further, the small residual correlation `rescor(tarsus, back)` -on the bottom of the output indicates that there is little unmodeled dependency -between tarsus length and back color. Although not necessary at this point, we -have already computed and stored the LOO information criterion of `fit1`, which -we will use for model comparisons. Next, let's take a look at some -posterior-predictive checks, which give us a first impression of the model fit. - -```{r pp_check1, message=FALSE} -pp_check(fit1, resp = "tarsus") -pp_check(fit1, resp = "back") -``` - -This looks pretty solid, but we notice a slight unmodeled left skewness in the -distribution of `tarsus`. We will come back to this later on. Next, we want to -investigate how much variation in the response variables can be explained by our -model and we use a Bayesian generalization of the $R^2$ coefficient. - -```{r R2_1} -bayes_R2(fit1) -``` - -Clearly, there is much variation in both animal characteristics that we can not -explain, but apparently we can explain more of the variation in tarsus length -than in back color. - -## More Complex Multivariate Models - -Now, suppose we only want to control for `sex` in `tarsus` but not in `back` and -vice versa for `hatchdate`. Not that this is particular reasonable for the -present example, but it allows us to illustrate how to specify different -formulas for different response variables. We can no longer use `mvbind` syntax -and so we have to use a more verbose approach: - -```{r fit2, message=FALSE, warning=FALSE, results='hide'} -bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) -bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) -fit2 <- brm(bf_tarsus + bf_back, data = BTdata, chains = 2, cores = 2) -``` - -Note that we have literally *added* the two model parts via the `+` operator, -which is in this case equivalent to writing `mvbf(bf_tarsus, bf_back)`. See -`help("brmsformula")` and `help("mvbrmsformula")` for more details about this -syntax. Again, we summarize the model first. - -```{r summary2, warning=FALSE} -fit2 <- add_criterion(fit2, "loo") -summary(fit2) -``` - -Let's find out, how model fit changed due to excluding certain effects from the -initial model: - -```{r loo12} -loo(fit1, fit2) -``` - -Apparently, there is no noteworthy difference in the model fit. Accordingly, we -do not really need to model `sex` and `hatchdate` for both response variables, -but there is also no harm in including them (so I would probably just include -them). - -To give you a glimpse of the capabilities of **brms**' multivariate syntax, we -change our model in various directions at the same time. Remember the slight -left skewness of `tarsus`, which we will now model by using the `skew_normal` -family instead of the `gaussian` family. Since we do not have a multivariate -normal (or student-t) model, anymore, estimating residual correlations is no -longer possible. We make this explicit using the `set_rescor` function. Further, -we investigate if the relationship of `back` and `hatchdate` is really linear as -previously assumed by fitting a non-linear spline of `hatchdate`. On top of it, -we model separate residual variances of `tarsus` for male and female chicks. - -```{r fit3, message=FALSE, warning=FALSE, results='hide'} -bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + - lf(sigma ~ 0 + sex) + skew_normal() -bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + - gaussian() - -fit3 <- brm( - bf_tarsus + bf_back + set_rescor(FALSE), - data = BTdata, chains = 2, cores = 2, - control = list(adapt_delta = 0.95) -) -``` - -Again, we summarize the model and look at some posterior-predictive checks. - -```{r summary3, warning=FALSE} -fit3 <- add_criterion(fit3, "loo") -summary(fit3) -``` - -We see that the (log) residual standard deviation of `tarsus` is somewhat larger -for chicks whose sex could not be identified as compared to male or female -chicks. Further, we see from the negative `alpha` (skewness) parameter of -`tarsus` that the residuals are indeed slightly left-skewed. Lastly, running - -```{r me3} -conditional_effects(fit3, "hatchdate", resp = "back") -``` - -reveals a non-linear relationship of `hatchdate` on the `back` color, which -seems to change in waves over the course of the hatch dates. - -There are many more modeling options for multivariate models, which are not -discussed in this vignette. Examples include autocorrelation structures, -Gaussian processes, or explicit non-linear predictors (e.g., see -`help("brmsformula")` or `vignette("brms_multilevel")`). In fact, nearly all the -flexibility of univariate models is retained in multivariate models. - -## References - -Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic -gambit: phenotypic, genetic and environmental correlations of colour. -*Journal of Evolutionary Biology*, 20(2), 549-557. +--- +title: "Estimating Multivariate Models with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Multivariate Models with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +In the present vignette, we want to discuss how to specify multivariate multilevel models using **brms**. We call a model *multivariate* if it contains multiple response variables, each being predicted by its own set of predictors. Consider an example from biology. Hadfield, Nutall, Osorio, and Owens (2007) analyzed data of the Eurasian blue tit (https://en.wikipedia.org/wiki/Eurasian_blue_tit). They predicted the `tarsus` length as well as the `back` color of chicks. Half of the brood were put into another `fosternest`, while the other half stayed in the fosternest of their own `dam`. This allows to separate genetic from environmental factors. Additionally, we have information about the `hatchdate` and `sex` of the chicks (the latter being known for 94\% of the animals). + +```{r data} +data("BTdata", package = "MCMCglmm") +head(BTdata) +``` + +## Basic Multivariate Models + +We begin with a relatively simple multivariate normal model. + +```{r fit1, message=FALSE, warning=FALSE, results='hide'} +bform1 <- + bf(mvbind(tarsus, back) ~ sex + hatchdate + (1|p|fosternest) + (1|q|dam)) + + set_rescor(TRUE) + +fit1 <- brm(bform1, data = BTdata, chains = 2, cores = 2) +``` + +As can be seen in the model code, we have used `mvbind` notation to tell +**brms** that both `tarsus` and `back` are separate response variables. The term +`(1|p|fosternest)` indicates a varying intercept over `fosternest`. By writing +`|p|` in between we indicate that all varying effects of `fosternest` should be +modeled as correlated. This makes sense since we actually have two model parts, +one for `tarsus` and one for `back`. The indicator `p` is arbitrary and can be +replaced by other symbols that comes into your mind (for details about the +multilevel syntax of **brms**, see `help("brmsformula")` and +`vignette("brms_multilevel")`). Similarly, the term `(1|q|dam)` indicates +correlated varying effects of the genetic mother of the chicks. Alternatively, +we could have also modeled the genetic similarities through pedigrees and +corresponding relatedness matrices, but this is not the focus of this vignette +(please see `vignette("brms_phylogenetics")`). The model results are readily +summarized via + +```{r summary1, warning=FALSE} +fit1 <- add_criterion(fit1, "loo") +summary(fit1) +``` + +The summary output of multivariate models closely resembles those of univariate +models, except that the parameters now have the corresponding response variable +as prefix. Within dams, tarsus length and back color seem to be negatively +correlated, while within fosternests the opposite is true. This indicates +differential effects of genetic and environmental factors on these two +characteristics. Further, the small residual correlation `rescor(tarsus, back)` +on the bottom of the output indicates that there is little unmodeled dependency +between tarsus length and back color. Although not necessary at this point, we +have already computed and stored the LOO information criterion of `fit1`, which +we will use for model comparisons. Next, let's take a look at some +posterior-predictive checks, which give us a first impression of the model fit. + +```{r pp_check1, message=FALSE} +pp_check(fit1, resp = "tarsus") +pp_check(fit1, resp = "back") +``` + +This looks pretty solid, but we notice a slight unmodeled left skewness in the +distribution of `tarsus`. We will come back to this later on. Next, we want to +investigate how much variation in the response variables can be explained by our +model and we use a Bayesian generalization of the $R^2$ coefficient. + +```{r R2_1} +bayes_R2(fit1) +``` + +Clearly, there is much variation in both animal characteristics that we can not +explain, but apparently we can explain more of the variation in tarsus length +than in back color. + +## More Complex Multivariate Models + +Now, suppose we only want to control for `sex` in `tarsus` but not in `back` and +vice versa for `hatchdate`. Not that this is particular reasonable for the +present example, but it allows us to illustrate how to specify different +formulas for different response variables. We can no longer use `mvbind` syntax +and so we have to use a more verbose approach: + +```{r fit2, message=FALSE, warning=FALSE, results='hide'} +bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) +bf_back <- bf(back ~ hatchdate + (1|p|fosternest) + (1|q|dam)) +fit2 <- brm(bf_tarsus + bf_back + set_rescor(TRUE), + data = BTdata, chains = 2, cores = 2) +``` + +Note that we have literally *added* the two model parts via the `+` operator, +which is in this case equivalent to writing `mvbf(bf_tarsus, bf_back)`. See +`help("brmsformula")` and `help("mvbrmsformula")` for more details about this +syntax. Again, we summarize the model first. + +```{r summary2, warning=FALSE} +fit2 <- add_criterion(fit2, "loo") +summary(fit2) +``` + +Let's find out, how model fit changed due to excluding certain effects from the +initial model: + +```{r loo12} +loo(fit1, fit2) +``` + +Apparently, there is no noteworthy difference in the model fit. Accordingly, we +do not really need to model `sex` and `hatchdate` for both response variables, +but there is also no harm in including them (so I would probably just include +them). + +To give you a glimpse of the capabilities of **brms**' multivariate syntax, we +change our model in various directions at the same time. Remember the slight +left skewness of `tarsus`, which we will now model by using the `skew_normal` +family instead of the `gaussian` family. Since we do not have a multivariate +normal (or student-t) model, anymore, estimating residual correlations is no +longer possible. We make this explicit using the `set_rescor` function. Further, +we investigate if the relationship of `back` and `hatchdate` is really linear as +previously assumed by fitting a non-linear spline of `hatchdate`. On top of it, +we model separate residual variances of `tarsus` for male and female chicks. + +```{r fit3, message=FALSE, warning=FALSE, results='hide'} +bf_tarsus <- bf(tarsus ~ sex + (1|p|fosternest) + (1|q|dam)) + + lf(sigma ~ 0 + sex) + skew_normal() +bf_back <- bf(back ~ s(hatchdate) + (1|p|fosternest) + (1|q|dam)) + + gaussian() + +fit3 <- brm( + bf_tarsus + bf_back + set_rescor(FALSE), + data = BTdata, chains = 2, cores = 2, + control = list(adapt_delta = 0.95) +) +``` + +Again, we summarize the model and look at some posterior-predictive checks. + +```{r summary3, warning=FALSE} +fit3 <- add_criterion(fit3, "loo") +summary(fit3) +``` + +We see that the (log) residual standard deviation of `tarsus` is somewhat larger +for chicks whose sex could not be identified as compared to male or female +chicks. Further, we see from the negative `alpha` (skewness) parameter of +`tarsus` that the residuals are indeed slightly left-skewed. Lastly, running + +```{r me3} +conditional_effects(fit3, "hatchdate", resp = "back") +``` + +reveals a non-linear relationship of `hatchdate` on the `back` color, which +seems to change in waves over the course of the hatch dates. + +There are many more modeling options for multivariate models, which are not +discussed in this vignette. Examples include autocorrelation structures, +Gaussian processes, or explicit non-linear predictors (e.g., see +`help("brmsformula")` or `vignette("brms_multilevel")`). In fact, nearly all the +flexibility of univariate models is retained in multivariate models. + +## References + +Hadfield JD, Nutall A, Osorio D, Owens IPF (2007). Testing the phenotypic +gambit: phenotypic, genetic and environmental correlations of colour. +*Journal of Evolutionary Biology*, 20(2), 549-557. diff -Nru r-cran-brms-2.16.3/vignettes/brms_nonlinear.Rmd r-cran-brms-2.17.0/vignettes/brms_nonlinear.Rmd --- r-cran-brms-2.16.3/vignettes/brms_nonlinear.Rmd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_nonlinear.Rmd 2022-04-11 07:21:28.000000000 +0000 @@ -1,331 +1,331 @@ ---- -title: "Estimating Non-Linear Models with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Non-Linear Models with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -This vignette provides an introduction on how to fit non-linear multilevel -models with **brms**. Non-linear models are incredibly flexible and powerful, -but require much more care with respect to model specification and priors than -typical generalized linear models. Ignoring group-level effects for the moment, -the predictor term $\eta_n$ of a generalized linear model for observation $n$ -can be written as follows: - -$$\eta_n = \sum_{i = 1}^K b_i x_{ni}$$ - -where $b_i$ is the regression coefficient of predictor $i$ and $x_{ni}$ is the -data of predictor $i$ for observation $n$. This also compromises interaction -terms and various other data transformations. However, the structure of $\eta_n$ -is always linear in the sense that the regression coefficients $b_i$ are -multiplied by some predictor values and then summed up. This implies that the -hypothetical predictor term - -$$\eta_n = b_1 \exp(b_2 x_n)$$ - -would *not* be a *linear* predictor anymore and we could not fit it using -classical techniques of generalized linear models. We thus need a more general -model class, which we will call *non-linear* models. Note that the term -'non-linear' does not say anything about the assumed distribution of the -response variable. In particular it does not mean 'not normally distributed' as -we can apply non-linear predictor terms to all kinds of response distributions -(for more details on response distributions available in **brms** see -`vignette("brms_families")`). - -## A Simple Non-Linear Model - -We begin with a simple example using simulated data. - -```{r} -b <- c(2, 0.75) -x <- rnorm(100) -y <- rnorm(100, mean = b[1] * exp(b[2] * x)) -dat1 <- data.frame(x, y) -``` - -As stated above, we cannot use a generalized linear model to estimate $b$ so we -go ahead an specify a non-linear model. - -```{r, results='hide'} -prior1 <- prior(normal(1, 2), nlpar = "b1") + - prior(normal(0, 2), nlpar = "b2") -fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), - data = dat1, prior = prior1) -``` - -When looking at the above code, the first thing that becomes obvious is that we -changed the `formula` syntax to display the non-linear formula including -predictors (i.e., `x`) and parameters (i.e., `b1` and `b2`) wrapped in a call to -`bf`. This stands in contrast to classical **R** formulas, where only predictors -are given and parameters are implicit. The argument `b1 + b2 ~ 1` serves two -purposes. First, it provides information, which variables in `formula` are -parameters, and second, it specifies the linear predictor terms for each -parameter. In fact, we should think of non-linear parameters as placeholders for -linear predictor terms rather than as parameters themselves (see also the -following examples). In the present case, we have no further variables to -predict `b1` and `b2` and thus we just fit intercepts that represent our -estimates of $b_1$ and $b_2$ in the model equation above. The formula `b1 + b2 ~ -1` is a short form of `b1 ~ 1, b2 ~ 1` that can be used if multiple non-linear -parameters share the same formula. Setting `nl = TRUE` tells **brms** that the -formula should be treated as non-linear. - -In contrast to generalized linear models, priors on population-level parameters -(i.e., 'fixed effects') are often mandatory to identify a non-linear model. -Thus, **brms** requires the user to explicitly specify these priors. In the -present example, we used a `normal(1, 2)` prior on (the population-level -intercept of) `b1`, while we used a `normal(0, 2)` prior on (the -population-level intercept of) `b2`. Setting priors is a non-trivial task in all -kinds of models, especially in non-linear models, so you should always invest -some time to think of appropriate priors. Quite often, you may be forced to -change your priors after fitting a non-linear model for the first time, when you -observe different MCMC chains converging to different posterior regions. This is -a clear sign of an identification problem and one solution is to set stronger -(i.e., more narrow) priors. - -To obtain summaries of the fitted model, we apply - -```{r} -summary(fit1) -plot(fit1) -plot(conditional_effects(fit1), points = TRUE) -``` - -The `summary` method reveals that we were able to recover the true parameter -values pretty nicely. According to the `plot` method, our MCMC chains have -converged well and to the same posterior. The `conditional_effects` method -visualizes the model-implied (non-linear) regression line. - -We might be also interested in comparing our non-linear model to a classical -linear model. - -```{r, results='hide'} -fit2 <- brm(y ~ x, data = dat1) -``` - -```{r} -summary(fit2) -``` - -To investigate and compare model fit, we can apply graphical posterior -predictive checks, which make use of the **bayesplot** package on the backend. - -```{r} -pp_check(fit1) -pp_check(fit2) -``` - -We can also easily compare model fit using leave-one-out cross-validation. - -```{r} -loo(fit1, fit2) -``` - -Since smaller `LOOIC` values indicate better model fit, it is immediately -evident that the non-linear model fits the data better, which is of course not -too surprising since we simulated the data from exactly that model. - -## A Real-World Non-Linear model - -On his blog, Markus Gesmann predicts the growth of cumulative insurance loss -payments over time, originated from different origin years (see -https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). -We will use a slightly simplified version of his model for demonstration -purposes here. It looks as follows: - -$$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ -$$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ - -The cumulative insurance payments $cum$ will grow over time, and we model this -dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be -estimated) ultimate loss of accident each year. It constitutes a non-linear -parameter in our framework along with the parameters $\theta$ and $\omega$, -which are responsible for the growth of the cumulative loss and are assumed to -be the same across years. The data is already shipped with brms. - -```{r} -data(loss) -head(loss) -``` - -and translate the proposed model into a non-linear **brms** model. - -```{r, results='hide'} -fit_loss <- brm( - bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), - ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, - nl = TRUE), - data = loss, family = gaussian(), - prior = c( - prior(normal(5000, 1000), nlpar = "ult"), - prior(normal(1, 2), nlpar = "omega"), - prior(normal(45, 10), nlpar = "theta") - ), - control = list(adapt_delta = 0.9) -) -``` - -We estimate a group-level effect of accident year (variable `AY`) for the -ultimate loss `ult`. This also shows nicely how a non-linear parameter is -actually a placeholder for a linear predictor, which in case of `ult`, contains -only an varying intercept over year. Again, priors on population-level effects -are required and, for the present model, are actually mandatory to ensure -identifiability. We summarize the model using well known methods. - -```{r} -summary(fit_loss) -plot(fit_loss, N = 3, ask = FALSE) -conditional_effects(fit_loss) -``` - -Next, we show marginal effects separately for each year. - -```{r} -conditions <- data.frame(AY = unique(loss$AY)) -rownames(conditions) <- unique(loss$AY) -me_loss <- conditional_effects( - fit_loss, conditions = conditions, - re_formula = NULL, method = "predict" -) -plot(me_loss, ncol = 5, points = TRUE) -``` - -It is evident that there is some variation in cumulative loss across accident -years, for instance due to natural disasters happening only in certain years. -Further, we see that the uncertainty in the predicted cumulative loss is larger -for later years with fewer available data points. For a more detailed discussion -of this data set, see Section 4.5 in Gesmann & Morris (2020). - -## Advanced Item-Response Models - -As a third example, we want to show how to model more advanced item-response -models using the non-linear model framework of **brms**. For simplicity, suppose -we have a single forced choice item with three alternatives of which only one is -correct. Our response variable is whether a person answers the item correctly -(1) or not (0). Person are assumed to vary in their ability to answer the item -correctly. However, every person has a 33% chance of getting the item right just -by guessing. We thus simulate some data to reflect this situation. - -```{r} -inv_logit <- function(x) 1 / (1 + exp(-x)) -ability <- rnorm(300) -p <- 0.33 + 0.67 * inv_logit(ability) -answer <- ifelse(runif(300, 0, 1) < p, 1, 0) -dat_ir <- data.frame(ability, answer) -``` - -The most basic item-response model is equivalent to a simple logistic regression -model. - -```{r, results='hide'} -fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) -``` - -However, this model completely ignores the guessing probability and will thus -likely come to biased estimates and predictions. - -```{r} -summary(fit_ir1) -plot(conditional_effects(fit_ir1), points = TRUE) -``` - -A more sophisticated approach incorporating the guessing probability looks as -follows: - -```{r, results='hide'} -fit_ir2 <- brm( - bf(answer ~ 0.33 + 0.67 * inv_logit(eta), - eta ~ ability, nl = TRUE), - data = dat_ir, family = bernoulli("identity"), - prior = prior(normal(0, 5), nlpar = "eta") -) -``` - -It is very important to set the link function of the `bernoulli` family to -`identity` or else we will apply two link functions. This is because our -non-linear predictor term already contains the desired link function (`0.33 + -0.67 * inv_logit`), but the `bernoulli` family applies the default `logit` link -on top of it. This will of course lead to strange and uninterpretable results. -Thus, please make sure that you set the link function to `identity`, whenever -your non-linear predictor term already contains the desired link function. - -```{r} -summary(fit_ir2) -plot(conditional_effects(fit_ir2), points = TRUE) -``` - -Comparing model fit via leave-one-out cross-validation - -```{r} -loo(fit_ir1, fit_ir2) -``` - -shows that both model fit the data equally well, but remember that predictions -of the first model might still be misleading as they may well be below the -guessing probability for low ability values. Now, suppose that we don't know the -guessing probability and want to estimate it from the data. This can easily be -done changing the previous model just a bit. - -```{r, results='hide'} -fit_ir3 <- brm( - bf(answer ~ guess + (1 - guess) * inv_logit(eta), - eta ~ 0 + ability, guess ~ 1, nl = TRUE), - data = dat_ir, family = bernoulli("identity"), - prior = c( - prior(normal(0, 5), nlpar = "eta"), - prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) - ) -) -``` - -Here, we model the guessing probability as a non-linear parameter making sure -that it cannot exceed the interval $[0, 1]$. We did not estimate an intercept -for `eta`, as this will lead to a bias in the estimated guessing parameter (try -it out; this is an excellent example of how careful one has to be in non-linear -models). - -```{r} -summary(fit_ir3) -plot(fit_ir3) -plot(conditional_effects(fit_ir3), points = TRUE) -``` - -The results show that we are able to recover the simulated model parameters with -this non-linear model. Of course, real item-response data have multiple items so -that accounting for item and person variability (e.g., using a multilevel model -with varying intercepts) becomes necessary as we have multiple observations per -item and person. Luckily, this can all be done within the non-linear framework -of **brms** and I hope that this vignette serves as a good starting point. - -## References - -Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. -*CAS Research Papers*. +--- +title: "Estimating Non-Linear Models with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Non-Linear Models with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +This vignette provides an introduction on how to fit non-linear multilevel +models with **brms**. Non-linear models are incredibly flexible and powerful, +but require much more care with respect to model specification and priors than +typical generalized linear models. Ignoring group-level effects for the moment, +the predictor term $\eta_n$ of a generalized linear model for observation $n$ +can be written as follows: + +$$\eta_n = \sum_{i = 1}^K b_i x_{ni}$$ + +where $b_i$ is the regression coefficient of predictor $i$ and $x_{ni}$ is the +data of predictor $i$ for observation $n$. This also comprises interaction +terms and various other data transformations. However, the structure of $\eta_n$ +is always linear in the sense that the regression coefficients $b_i$ are +multiplied by some predictor values and then summed up. This implies that the +hypothetical predictor term + +$$\eta_n = b_1 \exp(b_2 x_n)$$ + +would *not* be a *linear* predictor anymore and we could not fit it using +classical techniques of generalized linear models. We thus need a more general +model class, which we will call *non-linear* models. Note that the term +'non-linear' does not say anything about the assumed distribution of the +response variable. In particular it does not mean 'not normally distributed' as +we can apply non-linear predictor terms to all kinds of response distributions +(for more details on response distributions available in **brms** see +`vignette("brms_families")`). + +## A Simple Non-Linear Model + +We begin with a simple example using simulated data. + +```{r} +b <- c(2, 0.75) +x <- rnorm(100) +y <- rnorm(100, mean = b[1] * exp(b[2] * x)) +dat1 <- data.frame(x, y) +``` + +As stated above, we cannot use a generalized linear model to estimate $b$ so we +go ahead an specify a non-linear model. + +```{r, results='hide'} +prior1 <- prior(normal(1, 2), nlpar = "b1") + + prior(normal(0, 2), nlpar = "b2") +fit1 <- brm(bf(y ~ b1 * exp(b2 * x), b1 + b2 ~ 1, nl = TRUE), + data = dat1, prior = prior1) +``` + +When looking at the above code, the first thing that becomes obvious is that we +changed the `formula` syntax to display the non-linear formula including +predictors (i.e., `x`) and parameters (i.e., `b1` and `b2`) wrapped in a call to +`bf`. This stands in contrast to classical **R** formulas, where only predictors +are given and parameters are implicit. The argument `b1 + b2 ~ 1` serves two +purposes. First, it provides information, which variables in `formula` are +parameters, and second, it specifies the linear predictor terms for each +parameter. In fact, we should think of non-linear parameters as placeholders for +linear predictor terms rather than as parameters themselves (see also the +following examples). In the present case, we have no further variables to +predict `b1` and `b2` and thus we just fit intercepts that represent our +estimates of $b_1$ and $b_2$ in the model equation above. The formula `b1 + b2 ~ +1` is a short form of `b1 ~ 1, b2 ~ 1` that can be used if multiple non-linear +parameters share the same formula. Setting `nl = TRUE` tells **brms** that the +formula should be treated as non-linear. + +In contrast to generalized linear models, priors on population-level parameters +(i.e., 'fixed effects') are often mandatory to identify a non-linear model. +Thus, **brms** requires the user to explicitly specify these priors. In the +present example, we used a `normal(1, 2)` prior on (the population-level +intercept of) `b1`, while we used a `normal(0, 2)` prior on (the +population-level intercept of) `b2`. Setting priors is a non-trivial task in all +kinds of models, especially in non-linear models, so you should always invest +some time to think of appropriate priors. Quite often, you may be forced to +change your priors after fitting a non-linear model for the first time, when you +observe different MCMC chains converging to different posterior regions. This is +a clear sign of an identification problem and one solution is to set stronger +(i.e., more narrow) priors. + +To obtain summaries of the fitted model, we apply + +```{r} +summary(fit1) +plot(fit1) +plot(conditional_effects(fit1), points = TRUE) +``` + +The `summary` method reveals that we were able to recover the true parameter +values pretty nicely. According to the `plot` method, our MCMC chains have +converged well and to the same posterior. The `conditional_effects` method +visualizes the model-implied (non-linear) regression line. + +We might be also interested in comparing our non-linear model to a classical +linear model. + +```{r, results='hide'} +fit2 <- brm(y ~ x, data = dat1) +``` + +```{r} +summary(fit2) +``` + +To investigate and compare model fit, we can apply graphical posterior +predictive checks, which make use of the **bayesplot** package on the backend. + +```{r} +pp_check(fit1) +pp_check(fit2) +``` + +We can also easily compare model fit using leave-one-out cross-validation. + +```{r} +loo(fit1, fit2) +``` + +Since smaller `LOOIC` values indicate better model fit, it is immediately +evident that the non-linear model fits the data better, which is of course not +too surprising since we simulated the data from exactly that model. + +## A Real-World Non-Linear model + +On his blog, Markus Gesmann predicts the growth of cumulative insurance loss +payments over time, originated from different origin years (see +https://www.magesblog.com/post/2015-11-03-loss-developments-via-growth-curves-and/). +We will use a slightly simplified version of his model for demonstration +purposes here. It looks as follows: + +$$cum_{AY, dev} \sim N(\mu_{AY, dev}, \sigma)$$ +$$\mu_{AY, dev} = ult_{AY} \left(1 - \exp\left(- \left( \frac{dev}{\theta} \right)^\omega \right) \right)$$ + +The cumulative insurance payments $cum$ will grow over time, and we model this +dependency using the variable $dev$. Further, $ult_{AY}$ is the (to be +estimated) ultimate loss of accident each year. It constitutes a non-linear +parameter in our framework along with the parameters $\theta$ and $\omega$, +which are responsible for the growth of the cumulative loss and are assumed to +be the same across years. The data is already shipped with brms. + +```{r} +data(loss) +head(loss) +``` + +and translate the proposed model into a non-linear **brms** model. + +```{r, results='hide'} +fit_loss <- brm( + bf(cum ~ ult * (1 - exp(-(dev/theta)^omega)), + ult ~ 1 + (1|AY), omega ~ 1, theta ~ 1, + nl = TRUE), + data = loss, family = gaussian(), + prior = c( + prior(normal(5000, 1000), nlpar = "ult"), + prior(normal(1, 2), nlpar = "omega"), + prior(normal(45, 10), nlpar = "theta") + ), + control = list(adapt_delta = 0.9) +) +``` + +We estimate a group-level effect of accident year (variable `AY`) for the +ultimate loss `ult`. This also shows nicely how a non-linear parameter is +actually a placeholder for a linear predictor, which in case of `ult`, contains +only an varying intercept over year. Again, priors on population-level effects +are required and, for the present model, are actually mandatory to ensure +identifiability. We summarize the model using well known methods. + +```{r} +summary(fit_loss) +plot(fit_loss, N = 3, ask = FALSE) +conditional_effects(fit_loss) +``` + +Next, we show marginal effects separately for each year. + +```{r} +conditions <- data.frame(AY = unique(loss$AY)) +rownames(conditions) <- unique(loss$AY) +me_loss <- conditional_effects( + fit_loss, conditions = conditions, + re_formula = NULL, method = "predict" +) +plot(me_loss, ncol = 5, points = TRUE) +``` + +It is evident that there is some variation in cumulative loss across accident +years, for instance due to natural disasters happening only in certain years. +Further, we see that the uncertainty in the predicted cumulative loss is larger +for later years with fewer available data points. For a more detailed discussion +of this data set, see Section 4.5 in Gesmann & Morris (2020). + +## Advanced Item-Response Models + +As a third example, we want to show how to model more advanced item-response +models using the non-linear model framework of **brms**. For simplicity, suppose +we have a single forced choice item with three alternatives of which only one is +correct. Our response variable is whether a person answers the item correctly +(1) or not (0). Person are assumed to vary in their ability to answer the item +correctly. However, every person has a 33% chance of getting the item right just +by guessing. We thus simulate some data to reflect this situation. + +```{r} +inv_logit <- function(x) 1 / (1 + exp(-x)) +ability <- rnorm(300) +p <- 0.33 + 0.67 * inv_logit(ability) +answer <- ifelse(runif(300, 0, 1) < p, 1, 0) +dat_ir <- data.frame(ability, answer) +``` + +The most basic item-response model is equivalent to a simple logistic regression +model. + +```{r, results='hide'} +fit_ir1 <- brm(answer ~ ability, data = dat_ir, family = bernoulli()) +``` + +However, this model completely ignores the guessing probability and will thus +likely come to biased estimates and predictions. + +```{r} +summary(fit_ir1) +plot(conditional_effects(fit_ir1), points = TRUE) +``` + +A more sophisticated approach incorporating the guessing probability looks as +follows: + +```{r, results='hide'} +fit_ir2 <- brm( + bf(answer ~ 0.33 + 0.67 * inv_logit(eta), + eta ~ ability, nl = TRUE), + data = dat_ir, family = bernoulli("identity"), + prior = prior(normal(0, 5), nlpar = "eta") +) +``` + +It is very important to set the link function of the `bernoulli` family to +`identity` or else we will apply two link functions. This is because our +non-linear predictor term already contains the desired link function (`0.33 + +0.67 * inv_logit`), but the `bernoulli` family applies the default `logit` link +on top of it. This will of course lead to strange and uninterpretable results. +Thus, please make sure that you set the link function to `identity`, whenever +your non-linear predictor term already contains the desired link function. + +```{r} +summary(fit_ir2) +plot(conditional_effects(fit_ir2), points = TRUE) +``` + +Comparing model fit via leave-one-out cross-validation + +```{r} +loo(fit_ir1, fit_ir2) +``` + +shows that both model fit the data equally well, but remember that predictions +of the first model might still be misleading as they may well be below the +guessing probability for low ability values. Now, suppose that we don't know the +guessing probability and want to estimate it from the data. This can easily be +done changing the previous model just a bit. + +```{r, results='hide'} +fit_ir3 <- brm( + bf(answer ~ guess + (1 - guess) * inv_logit(eta), + eta ~ 0 + ability, guess ~ 1, nl = TRUE), + data = dat_ir, family = bernoulli("identity"), + prior = c( + prior(normal(0, 5), nlpar = "eta"), + prior(beta(1, 1), nlpar = "guess", lb = 0, ub = 1) + ) +) +``` + +Here, we model the guessing probability as a non-linear parameter making sure +that it cannot exceed the interval $[0, 1]$. We did not estimate an intercept +for `eta`, as this will lead to a bias in the estimated guessing parameter (try +it out; this is an excellent example of how careful one has to be in non-linear +models). + +```{r} +summary(fit_ir3) +plot(fit_ir3) +plot(conditional_effects(fit_ir3), points = TRUE) +``` + +The results show that we are able to recover the simulated model parameters with +this non-linear model. Of course, real item-response data have multiple items so +that accounting for item and person variability (e.g., using a multilevel model +with varying intercepts) becomes necessary as we have multiple observations per +item and person. Luckily, this can all be done within the non-linear framework +of **brms** and I hope that this vignette serves as a good starting point. + +## References + +Gesmann M. & Morris J. (2020). Hierarchical Compartmental Reserving Models. +*CAS Research Papers*. diff -Nru r-cran-brms-2.16.3/vignettes/brms_overview.ltx r-cran-brms-2.17.0/vignettes/brms_overview.ltx --- r-cran-brms-2.16.3/vignettes/brms_overview.ltx 2020-07-08 07:08:40.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_overview.ltx 2022-03-13 16:10:29.000000000 +0000 @@ -1,522 +1,522 @@ -\documentclass[article, nojss]{jss} - -%\VignetteIndexEntry{Overview of the brms Package} -%\VignetteEngine{R.rsp::tex} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%% almost as usual -\author{Paul-Christian B\"urkner} -\title{\pkg{brms}: An \proglang{R} Package for Bayesian Multilevel Models using \pkg{Stan}} - -%% for pretty printing and a nice hypersummary also set: -\Plainauthor{Paul-Christian B\"urkner} %% comma-separated -\Plaintitle{brms: An R Package for Bayesian Multilevel Models using Stan} %% without formatting -\Shorttitle{\pkg{brms}: Bayesian Multilevel Models using Stan} %% a short title (if necessary) - -%% an abstract and keywords -\Abstract{ - The \pkg{brms} package implements Bayesian multilevel models in \proglang{R} using the probabilistic programming language \pkg{Stan}. A wide range of distributions and link functions are supported, allowing users to fit -- among others -- linear, robust linear, binomial, Poisson, survival, response times, ordinal, quantile, zero-inflated, hurdle, and even non-linear models all in a multilevel context. Further modeling options include autocorrelation of the response variable, user defined covariance structures, censored data, as well as meta-analytic standard errors. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. In addition, model fit can easily be assessed and compared using posterior-predictive checks and leave-one-out cross-validation. If you use \pkg{brms}, please cite this article as published in the Journal of Statistical Software \citep{brms1}. -} -\Keywords{Bayesian inference, multilevel model, ordinal data, MCMC, \proglang{Stan}, \proglang{R}} -\Plainkeywords{Bayesian inference, multilevel model, ordinal data, MCMC, Stan, R} %% without formatting -%% at least one keyword must be supplied - -%% publication information -%% NOTE: Typically, this can be left commented and will be filled out by the technical editor -%% \Volume{50} -%% \Issue{9} -%% \Month{June} -%% \Year{2012} -%% \Submitdate{2012-06-04} -%% \Acceptdate{2012-06-04} - -%% The address of (at least) one author should be given -%% in the following format: -\Address{ - Paul-Christian B\"urkner\\ - E-mail: \email{paul.buerkner@gmail.com}\\ - URL: \url{https://paul-buerkner.github.io} -} -%% It is also possible to add a telephone and fax number -%% before the e-mail in the following format: -%% Telephone: +43/512/507-7103 -%% Fax: +43/512/507-2851 - - -%% for those who use Sweave please include the following line (with % symbols): -%% need no \usepackage{Sweave.sty} - -%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\begin{document} - -%% include your article here, just as usual -%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. - -\section{Introduction} - -Multilevel models (MLMs) offer a great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow the modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for \proglang{R} \citep{Rcore2015} have been developed to fit MLMs. Possibly the most widely known package in this area is \pkg{lme4} \citep{bates2015}, which uses maximum likelihood or restricted maximum likelihood methods for model fitting. Although alternative Bayesian methods have several advantages over frequentist approaches (e.g., the possibility of explicitly incorporating prior knowledge about parameters into the model), their practical use was limited for a long time because the posterior distributions of more complex models (such as MLMs) could not be found analytically. Markov chain Monte Carlo (MCMC) algorithms allowing to draw random samples from the posterior were not available or too time-consuming. In the last few decades, however, this has changed with the development of new algorithms and the rapid increase of general computing power. Today, several software packages implement these techniques, for instance \pkg{WinBugs} \citep{lunn2000, spiegelhalter2003}, \pkg{OpenBugs} \citep{spiegelhalter2007}, \pkg{JAGS} \citep{plummer2013}, \pkg{MCMCglmm} \citep{hadfield2010} and \pkg{Stan} \citep{stan2017, carpenter2017} to mention only a few. With the exception of the latter, all of these programs are primarily using combinations of Metropolis-Hastings updates \citep{metropolis1953,hastings1970} and Gibbs-sampling \citep{geman1984,gelfand1990}, sometimes also coupled with slice-sampling \citep{damien1999,neal2003}. One of the main problems of these algorithms is their rather slow convergence for high-dimensional models with correlated parameters \citep{neal2011,hoffman2014,gelman2014}. Furthermore, Gibbs-sampling requires priors to be conjugate to the likelihood of parameters in order to work efficiently \citep{gelman2014}, thus reducing the freedom of the researcher in choosing a prior that reflects his or her beliefs. In contrast, \pkg{Stan} implements Hamiltonian Monte Carlo \citep{duane1987, neal2011} and its extension, the No-U-Turn Sampler (NUTS) \citep{hoffman2014}. These algorithms converge much more quickly especially for high-dimensional models regardless of whether the priors are conjugate or not \citep{hoffman2014}. - -Similar to software packages like \pkg{WinBugs}, \pkg{Stan} comes with its own programming language, allowing for great modeling flexibility (cf., \citeauthor{stanM2017} \citeyear{stanM2017}; \citeauthor{carpenter2017} \citeyear{carpenter2017}). Many researchers may still hesitate to use \pkg{Stan} directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error prone process even for researchers familiar with Bayesian inference. The package \pkg{brms}, presented in this paper, aims at closing this gap (at least for MLMs) allowing the user to benefit from the merits of \pkg{Stan} only by using simple, \pkg{lme4}-like formula syntax. \pkg{brms} supports a wide range of distributions and link functions, allows for multiple grouping factors each with multiple group-level effects, autocorrelation of the response variable, user defined covariance structures, as well as flexible and explicit prior specifications. - -The purpose of the present article is to provide a general overview of the \pkg{brms} package (version 0.10.0). We begin by explaining the underlying structure of MLMs. Next, the software is introduced in detail using recurrence times of infection in kidney patients \citep{mcgilchrist1991} and ratings of inhaler instructions \citep{ezzet1991} as examples. We end by comparing \pkg{brms} to other \proglang{R} packages implementing MLMs and describe future plans for extending the package. - -\section{Model description} -\label{model} - -The core of every MLM is the prediction of the response $y$ through the linear combination $\eta$ of predictors transformed by the inverse link function $f$ assuming a certain distribution $D$ for $y$. We write -$$y_i \sim D(f(\eta_i), \theta)$$ -to stress the dependency on the $i\textsuperscript{th}$ data point. In many \proglang{R} packages, $D$ is also called the `family' and we will use this term in the following. The parameter $\theta$ describes additional family specific parameters that typically do not vary across data points, such as the standard deviation $\sigma$ in normal models or the shape $\alpha$ in Gamma or negative binomial models. The linear predictor can generally be written as -$$\eta = \mathbf{X} \beta + \mathbf{Z} u$$ -In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The response $y$ as well as $\mathbf{X}$ and $\mathbf{Z}$ make up the data, whereas $\beta$, $u$, and $\theta$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects. However, we avoid these terms in the present paper following the recommendations of \cite{gelmanMLM2006}, as they are not used unambiguously in the literature. Also, we want to make explicit that $u$ is a model parameter in the same manner as $\beta$ so that uncertainty in its estimates can be naturally evaluated. In fact, this is an important advantage of Bayesian MCMC methods as compared to maximum likelihood approaches, which do not treat $u$ as a parameter, but assume that it is part of the error term instead (cf., \citeauthor{fox2011}, \citeyear{fox2011}). - -Except for linear models, we do not incorporate an additional error term for every observation by default. If desired, such an error term can always be modeled using a grouping factor with as many levels as observations in the data. - -\subsection{Prior distributions} - -\subsubsection{Regression parameters at population-level} - -In \pkg{brms}, population-level parameters are not restricted to have normal priors. Instead, every parameter can have every one-dimensional prior implemented in \pkg{Stan}, for instance uniform, Cauchy or even Gamma priors. As a negative side effect of this flexibility, correlations between them cannot be modeled as parameters. If desired, point estimates of the correlations can be obtained after sampling has been done. By default, population level parameters have an improper flat prior over the reals. - -\subsubsection{Regression parameters at group-level} - -The group-level parameters $u$ are assumed to come from a multivariate normal distribution with mean zero and unknown covariance matrix $\mathbf{\Sigma}$: -$$u \sim N(0, \mathbf{\Sigma})$$ -As is generally the case, covariances between group-level parameters of different grouping factors are assumed to be zero. This implies that $\mathbf{Z}$ and $u$ can be split up into several matrices $\mathbf{Z_k}$ and parameter vectors $u_k$, where $k$ indexes grouping factors, so that the model can be simplified to -$$u_k \sim N(0, \mathbf{\Sigma_k})$$ -Usually, but not always, we can also assume group-level parameters associated with different levels (indexed by $j$) of the same grouping factor to be independent leading to -$$u_{kj} \sim N(0, \mathbf{V_k})$$ -The covariance matrices $\mathbf{V_k}$ are modeled as parameters. In most packages, an Inverse-Wishart distribution is used as a prior for $\mathbf{V_k}$. This is mostly because its conjugacy leads to good properties of Gibbs-Samplers \citep{gelman2014}. However, there are good arguments against the Inverse-Wishart prior \citep{natarajan2000, kass2006}. The NUTS-Sampler implemented in \pkg{Stan} does not require priors to be conjugate. This advantage is utilized in \pkg{brms}: $\mathbf{V_k}$ is parameterized in terms of a correlation matrix $\mathbf{\Omega_k}$ and a vector of standard deviations $\sigma_k$ through -$$\mathbf{V_k} = \mathbf{D}(\sigma_k) \mathbf{\Omega_k} \mathbf{D}(\sigma_k)$$ -where $\mathbf{D}(\sigma_k)$ denotes the diagonal matrix with diagonal elements $\sigma_k$. Priors are then specified for the parameters on the right hand side of the equation. For $\mathbf{\Omega_k}$, we use the LKJ-Correlation prior with parameter $\zeta > 0$ by \cite{lewandowski2009}\footnote{Internally, the Cholesky factor of the correlation matrix is used, as it is more efficient and numerically stable.}: -$$\mathbf{\Omega_k} \sim \mathrm{LKJ}(\zeta)$$ -The expected value of the LKJ-prior is the identity matrix (implying correlations of zero) for any positive value of $\zeta$, which can be interpreted like the shape parameter of a symmetric beta distribution \citep{stanM2017}. If $\zeta = 1$ (the default in \pkg{brms}) the density is uniform over correlation matrices of the respective dimension. If $\zeta > 1$, the identity matrix is the mode of the prior, with a sharper peak in the density for larger values of $\zeta$. If $0 < \zeta < 1$ the prior is U-shaped having a trough at the identity matrix, which leads to higher probabilities for non-zero correlations. For every element of $\sigma_k$, any prior can be applied that is defined on the non-negative reals only. As default in \pkg{brms}, we use a half Student-t prior with 3 degrees of freedom. This prior often leads to better convergence of the models than a half Cauchy prior, while still being relatively weakly informative. - -Sometimes -- for instance when modeling pedigrees -- different levels of the same grouping factor cannot be assumed to be independent. In this case, the covariance matrix of $u_k$ becomes -$$\mathbf{\Sigma_k} = \mathbf{V_k} \otimes \mathbf{A_k}$$ -where $\mathbf{A_k}$ is the known covariance matrix between levels and $\otimes$ is the Kronecker product. - -\subsubsection{Family specific parameters} - -For some families, additional parameters need to be estimated. In the current section, we only name the most important ones. Normal and Student's distributions need the parameter $\sigma$ to account for residual error variance. By default, $\sigma$ has a half Cauchy prior with a scale parameter that depends on the standard deviation of the response variable to remain only weakly informative regardless of response variable's scaling. Furthermore, Student's distributions needs the parameter $\nu$ representing the degrees of freedom. By default, $\nu$ has a wide gamma prior as proposed by \cite{juarez2010}. Gamma, Weibull, and negative binomial distributions need the shape parameter $\alpha$ that also has a wide gamma prior by default. - -\section{Parameter estimation} - -The \pkg{brms} package does not fit models itself but uses \pkg{Stan} on the back-end. Accordingly, all samplers implemented in \pkg{Stan} can be used to fit \pkg{brms} models. Currently, these are the static Hamiltonian Monte-Carlo (HMC) Sampler sometimes also referred to as Hybrid Monte-Carlo \citep{neal2011, neal2003, duane1987} and its extension the No-U-Turn Sampler (NUTS) by \cite{hoffman2014}. HMC-like algorithms produce samples that are much less autocorrelated than those of other samplers such as the random-walk Metropolis algorithm \citep{hoffman2014, Creutz1988}. The main drawback of this increased efficiency is the need to calculate the gradient of the log-posterior, which can be automated using algorithmic differentiation \citep{griewank2008} but is still a time-consuming process for more complex models. Thus, using HMC leads to higher quality samples but takes more time per sample than other algorithms typically applied. Another drawback of HMC is the need to pre-specify at least two parameters, which are both critical for the performance of HMC. The NUTS Sampler allows setting these parameters automatically thus eliminating the need for any hand-tuning, while still being at least as efficient as a well tuned HMC \citep{hoffman2014}. For more details on the sampling algorithms applied in \pkg{Stan}, see the \pkg{Stan} user's manual \citep{stanM2017} as well as \cite{hoffman2014}. - -In addition to the estimation of model parameters, \pkg{brms} allows drawing samples from the posterior predictive distribution as well as from the pointwise log-likelihood. Both can be used to assess model fit. The former allows a comparison between the actual response $y$ and the response $\hat{y}$ predicted by the model. The pointwise log-likelihood can be used, among others, to calculate the widely applicable information criterion (WAIC) proposed by \cite{watanabe2010} and leave-one-out cross-validation (LOO; \citealp{gelfand1992}; \citealp{vehtari2015}; see also \citealp{ionides2008}) both allowing to compare different models applied to the same data (lower WAICs and LOOs indicate better model fit). The WAIC can be viewed as an improvement of the popular deviance information criterion (DIC), which has been criticized by several authors (\citealp{vehtari2015}; \citealp{plummer2008}; \citealp{vanderlinde2005}; see also the discussion at the end of the original DIC paper by \citealp{spiegelhalter2002}) in part because of problems arising from fact that the DIC is only a point estimate. In \pkg{brms}, WAIC and LOO are implemented using the \pkg{loo} package \citep{loo2016} also following the recommendations of \cite{vehtari2015}. - -\section{Software} -\label{software} - -The \pkg{brms} package provides functions for fitting MLMs using \pkg{Stan} for full Bayesian inference. To install the latest release version of \pkg{brms} from CRAN, type \code{install.packages("brms")} within \proglang{R}. The current developmental version can be downloaded from GitHub via -\begin{Sinput} -devtools::install_github("paul-buerkner/brms") -\end{Sinput} -Additionally, a \proglang{C++} compiler is required. This is because \pkg{brms} internally creates \pkg{Stan} code, which is translated to \proglang{C++} and compiled afterwards. The program \pkg{Rtools} \citep{Rtools2015} comes with a \proglang{C++} compiler for Windows\footnote{During the installation process, there is an option to change the system \code{PATH}. Please make sure to check this options, because otherwise \pkg{Rtools} will not be available within \proglang{R}.}. -On OS X, one should use \pkg{Xcode} \citep{Xcode2015} from the App Store. To check whether the compiler can be called within \proglang{R}, run \code{system("g++ -v")} when using \pkg{Rtools} or \code{system("clang++ -v")} when using \pkg{Xcode}. If no warning occurs and a few lines of difficult to read system code are printed out, the compiler should work correctly. For more detailed instructions on how to get the compilers running, see the prerequisites section on \url{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}. - -Models are fitted in \pkg{brms} using the following procedure, which is also summarized in Figure~\ref{flowchart}. First, the user specifies the model using the \code{brm} function in a way typical for most model fitting \proglang{R} functions, that is by defining \code{formula}, \code{data}, and \code{family}, as well as some other optional arguments. Second, this information is processed and the \code{make_stancode} and \code{make_standata} functions are called. The former generates the model code in \pkg{Stan} language and the latter prepares the data for use in \pkg{Stan}. These two are the mandatory parts of every \pkg{Stan} model and without \pkg{brms}, users would have to specify them themselves. Third, \pkg{Stan} code and data as well as additional arguments (such as the number of iterations and chains) are passed to functions of the \pkg{rstan} package (the \proglang{R} interface of \pkg{Stan}; \citeauthor{stan2017}, \citeyear{stan2017}). Fourth, the model is fitted by \pkg{Stan} after translating and compiling it in \proglang{C++}. Fifth, after the model has been fitted and returned by \pkg{rstan}, the fitted model object is post-processed in \pkg{brms} among others by renaming the model parameters to be understood by the user. Sixth, the results can be investigated in \proglang{R} using various methods such as \code{summary}, \code{plot}, or \code{predict} (for a complete list of methods type \code{methods(class = "brmsfit")}). - -\begin{figure}[ht] - \centering - \includegraphics[height = 0.4\textheight, keepaspectratio]{flowchart.pdf} - \caption{High level description of the model fitting procedure used in \pkg{brms}.} - \label{flowchart} -\end{figure} - -\subsection{A worked example} - -In the following, we use an example about the recurrence time of an infection in kidney patients initially published by \cite{mcgilchrist1991}. The data set consists of 76 entries of 7 variables: -\begin{Sinput} -R> library("brms") -R> data("kidney") -R> head(kidney, n = 3) -\end{Sinput} -\begin{Soutput} - time censored patient recur age sex disease -1 8 0 1 1 28 male other -2 23 0 2 1 48 female GN -3 22 0 3 1 32 male other -\end{Soutput} -Variable \code{time} represents the recurrence time of the infection, -\code{censored} indicates if \code{time} is right censored (\code{1}) or not censored (\code{0}), variable \code{patient} is the patient id, and -\code{recur} indicates if it is the first or second recurrence in that patient. Finally, variables \code{age}, \code{sex}, and \code{disease} make up the predictors. - -\subsection[Fitting models with brms]{Fitting models with \pkg{brms}} - -The core of the \pkg{brms} package is the \code{brm} function and we will explain its argument structure using the example above. Suppose we want to predict the (possibly censored) recurrence time using a log-normal model, in which the intercept as well as the effect of \code{age} is nested within patients. Then, we may use the following code: -\begin{Sinput} -fit1 <- brm(formula = time | cens(censored) ~ age * sex + disease - + (1 + age|patient), - data = kidney, family = lognormal(), - prior = c(set_prior("normal(0,5)", class = "b"), - set_prior("cauchy(0,2)", class = "sd"), - set_prior("lkj(2)", class = "cor")), - warmup = 1000, iter = 2000, chains = 4, - control = list(adapt_delta = 0.95)) -\end{Sinput} - -\subsection[formula: Information on the response and predictors]{\code{formula}: Information on the response and predictors} - -Without doubt, \code{formula} is the most complicated argument, as it contains information on the response variable as well as on predictors at different levels of the model. Everything before the $\sim$ sign relates to the response part of \code{formula}. In the usual and most simple case, this is just one variable name (e.g., \code{time}). However, to incorporate additional information about the response, one can add one or more terms of the form \code{| fun(variable)}. \code{fun} may be one of a few functions defined internally in \pkg{brms} and \code{variable} corresponds to a variable in the data set supplied by the user. In this example, \code{cens} makes up the internal function that handles censored data, and \code{censored} is the variable that contains information on the censoring. Other available functions in this context are \code{weights} and \code{disp} to allow different sorts of weighting, \code{se} to specify known standard errors primarily for meta-analysis, \code{trunc} to define truncation boundaries, \code{trials} for binomial models\footnote{In functions such as \code{glm} or \code{glmer}, the binomial response is typically passed as \code{cbind(success, failure)}. In \pkg{brms}, the equivalent syntax is \code{success | trials(success + failure)}.}, and \code{cat} to specify the number of categories for ordinal models. - -Everything on the right side of $\sim$ specifies predictors. Here, the syntax exactly matches that of \pkg{lme4}. For both, population-level and group-level terms, the \code{+} is used to separate different effects from each other. Group-level terms are of the form \code{(coefs | group)}, where \code{coefs} contains one or more variables whose effects are assumed to vary with the levels of the grouping factor given in \code{group}. Multiple grouping factors each with multiple group-level coefficients are possible. In the present example, only one group-level term is specified in which \code{1 + age} are the coefficients varying with the grouping factor \code{patient}. This implies that the intercept of the model as well as the effect of age is supposed to vary between patients. By default, group-level coefficients within a grouping factor are assumed to be correlated. Correlations can be set to zero by using the \code{(coefs || group)} syntax\footnote{In contrast to \pkg{lme4}, the \code{||} operator in \pkg{brms} splits up the design matrix computed from \code{coefs} instead of decomposing \code{coefs} in its terms. This implies that columns of the design matrix originating from the same factor are also assumed to be uncorrelated, whereas \pkg{lme4} estimates the correlations in this case. For a way to achieve \pkg{brms}-like behavior with \pkg{lme4}, see the \code{mixed} function of the \pkg{afex} package by \cite{afex2015}.}. Everything on the right side of \code{formula} that is not recognized as part of a group-level term is treated as a population-level effect. In this example, the population-level effects are \code{age}, \code{sex}, and \code{disease}. - -\subsection[family: Distribution of the response variable]{\code{family}: Distribution of the response variable} - -Argument \code{family} should usually be a family function, a call to a family function or a character string naming the family. If not otherwise specified, default link functions are applied. \pkg{brms} comes with a large variety of families. Linear and robust linear regression can be performed using the \code{gaussian} or \code{student} family combined with the \code{identity} link. For dichotomous and categorical data, families \code{bernoulli}, \code{binomial}, and \code{categorical} combined with the \code{logit} link, by default, are perfectly suited. Families \code{poisson}, \code{negbinomial}, and \code{geometric} allow for modeling count data. Families \code{lognormal}, \code{Gamma}, \code{exponential}, and \code{weibull} can be used (among others) for survival regression. Ordinal regression can be performed using the families \code{cumulative}, \code{cratio}, \code{sratio}, and \code{acat}. Finally, families \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, \code{zero_inflated_beta}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, and \code{hurdle_gamma} can be used to adequately model excess zeros in the response. In our example, we use \code{family = lognormal()} implying a log-normal ``survival'' model for the response variable \code{time}. - -\subsection[prior: Prior distributions of model parameters]{\code{prior}: Prior distributions of model parameters} - -Every population-level effect has its corresponding regression parameter. These parameters are named as \code{b\_}, where \code{} represents the name of the corresponding population-level effect. The default prior is an improper flat prior over the reals. Suppose, for instance, that we want to set a normal prior with mean \code{0} and standard deviation \code{10} on the effect of \code{age} and a Cauchy prior with location \code{1} and scale \code{2} on \code{sexfemale}\footnote{When factors are used as predictors, parameter names will depend on the factor levels. To get an overview of all parameters and parameter classes for which priors can be specified, use function \code{get\_prior}. For the present example, \code{get\_prior(time | cens(censored) $\sim$ age * sex + disease + (1 + age|patient), data = kidney, family = lognormal())} does the desired.}. Then, we may write -\begin{Sinput} -prior <- c(set_prior("normal(0,10)", class = "b", coef = "age"), - set_prior("cauchy(1,2)", class = "b", coef = "sexfemale")) -\end{Sinput} -To put the same prior (e.g., a normal prior) on all population-level effects at once, we may write as a shortcut \code{set_prior("normal(0,10)", class = "b")}. This also leads to faster sampling, because priors can be vectorized in this case. Note that we could also omit the \code{class} argument for population-level effects, as it is the default class in \code{set_prior}. - -A special shrinkage prior to be applied on population-level effects is the horseshoe prior \citep{carvalho2009, carvalho2010}. It is symmetric around zero with fat tails and an infinitely large spike at zero. This makes it ideal for sparse models that have many regression coefficients, although only a minority of them is non-zero. The horseshoe prior can be applied on all population-level effects at once (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. -The $1$ implies that the Student-$t$ prior of the local shrinkage parameters has 1 degrees of freedom. In \pkg{brms} it is possible to increase the degrees of freedom (which will often improve convergence), although the prior no longer resembles a horseshoe in this case\footnote{This class of priors is often referred to as hierarchical shrinkage family, which contains the original horseshoe prior as a special case.}. For more details see \cite{carvalho2009, carvalho2010}. - -Each group-level effect of each grouping factor has a standard deviation parameter, which is restricted to be non-negative and, by default, has a half Student-$t$ prior with $3$ degrees of freedom and a scale parameter that is minimally $10$. For non-ordinal models, \pkg{brms} tries to evaluate if the scale is large enough to be considered only weakly informative for the model at hand by comparing it with the standard deviation of the response after applying the link function. If this is not the case, it will increase the scale based on the aforementioned standard deviation\footnote{Changing priors based on the data is not truly Bayesian and might rightly be criticized. However, it helps avoiding the problem of too informative default priors without always forcing users to define their own priors. The latter would also be problematic as not all users can be expected to be well educated Bayesians and reasonable default priors will help them a lot in using Bayesian methods.}. \pkg{Stan} implicitly defines a half Student-$t$ prior by using a Student-$t$ prior on a restricted parameter \citep{stanM2017}. For other reasonable priors on standard deviations see \cite{gelman2006}. In \pkg{brms}, standard deviation parameters are named as \code{sd\_\_} so that \code{sd\_patient\_Intercept} and \code{sd\_patient\_age} are the parameter names in the example. If desired, it is possible to set a different prior on each parameter, but statements such as \code{set_prior("student_t(3,0,5)", class = "sd", group = "patient")} or even \code{set_prior("student_t(3,0,5)", class = "sd")} may also be used and are again faster because of vectorization. - -If there is more than one group-level effect per grouping factor, correlations between group-level effects are estimated. As mentioned in Section~\ref{model}, the LKJ-Correlation prior with parameter $\zeta > 0$ \citep{lewandowski2009} is used for this purpose. In \pkg{brms}, this prior is abbreviated as \code{"lkj(zeta)"} and correlation matrix parameters are named as \code{cor\_}, (e.g., \code{cor_patient}), so that \code{set_prior("lkj(2)", class = "cor", group = "patient")} is a valid statement. To set the same prior on every correlation matrix in the model, \code{set_prior("lkj(2)", class = "cor")} is also allowed, but does not come with any efficiency increases. - -Other model parameters such as the residual standard deviation \code{sigma} in normal models or the \code{shape} in Gamma models have their priors defined in the same way, where each of them is treated as having its own parameter class. A complete overview on possible prior distributions is given in the \pkg{Stan} user's manual \citep{stanM2017}. Note that \pkg{brms} does not thoroughly check if the priors are written in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their syntactical correctness when the model is parsed to \proglang{C++} and return an error if they are not. This, however, does not imply that priors are always meaningful if they are accepted by \pkg{Stan}. Although \pkg{brms} tries to find common problems (e.g., setting bounded priors on unbounded parameters), there is no guarantee that the defined priors are reasonable for the model. - -\subsection[control Adjusting the sampling behavior of Stan]{\code{control}: Adjusting the sampling behavior of \pkg{Stan}} - -In addition to choosing the number of iterations, warmup samples, and chains, users can control the behavior of the NUTS sampler by using the \code{control} argument. The most important reason to use \code{control} is to decrease (or eliminate at best) the number of divergent transitions that cause a bias in the obtained posterior samples. Whenever you see the warning \code{"There were x divergent transitions after warmup."}, you should really think about increasing \code{adapt_delta}. To do this, write \code{control = list(adapt_delta = )}, where \code{} should usually be a value between \code{0.8} (current default) and \code{1}. Increasing \code{adapt_delta} will slow down the sampler but will decrease the number of divergent transitions threatening the validity of your posterior samples. - -Another problem arises when the depth of the tree being evaluated in each iteration is exceeded. This is less common than having divergent transitions, but may also bias the posterior samples. When it happens, \pkg{Stan} will throw out a warning suggesting to increase \code{max_treedepth}, which can be accomplished by writing \code{control = list(max_treedepth = )} with a positive integer \code{} that should usually be larger than the current default of \code{10}. - -\subsection{Analyzing the results} - -The example model \code{fit1} is fitted using 4 chains, each with 2000 iterations of which the first 1000 are warmup to calibrate the sampler, leading to a total of 4000 posterior samples\footnote{To save time, chains may also run in parallel when using argument \code{cluster}.}. For researchers familiar with Gibbs or Metropolis-Hastings sampling, this number may seem far too small to achieve good convergence and reasonable results, especially for multilevel models. However, as \pkg{brms} utilizes the NUTS sampler \citep{hoffman2014} implemented in \pkg{Stan}, even complex models can often be fitted with not more than a few thousand samples. Of course, every iteration is more computationally intensive and time-consuming than the iterations of other algorithms, but the quality of the samples (i.e., the effective sample size per iteration) is usually higher. - -After the posterior samples have been computed, the \code{brm} function returns an \proglang{R} object, containing (among others) the fully commented model code in \pkg{Stan} language, the data to fit the model, and the posterior samples themselves. The model code and data for the present example can be extracted through \code{stancode(fit1)} and \code{standata(fit1)} respectively\footnote{Both model code and data may be amended and used to fit new models. That way, \pkg{brms} can also serve as a good starting point in building more complicated models in \pkg{Stan}, directly.}. A model summary is readily available using - -\begin{Sinput} -R> summary(fit1, waic = TRUE) -\end{Sinput} -\begin{Soutput} - Family: lognormal (identity) -Formula: time | cens(censored) ~ age * sex + disease + (1 + age | patient) - Data: kidney (Number of observations: 76) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: 673.51 - -Group-Level Effects: -~patient (Number of levels: 38) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 0.40 0.28 0.01 1.01 1731 1 -sd(age) 0.01 0.01 0.00 0.02 1137 1 -cor(Intercept,age) -0.13 0.46 -0.88 0.76 3159 1 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept 2.73 0.96 0.82 4.68 2139 1 -age 0.01 0.02 -0.03 0.06 1614 1 -sexfemale 2.42 1.13 0.15 4.64 2065 1 -diseaseGN -0.40 0.53 -1.45 0.64 2664 1 -diseaseAN -0.52 0.50 -1.48 0.48 2713 1 -diseasePKD 0.60 0.74 -0.86 2.02 2968 1 -age:sexfemale -0.02 0.03 -0.07 0.03 1956 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sigma 1.15 0.13 0.91 1.44 4000 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Soutput} - -On the top of the output, some general information on the model is given, such as family, formula, number of iterations and chains, as well as the WAIC. Next, group-level effects are displayed separately for each grouping factor in terms of standard deviations and correlations between group-level effects. On the bottom of the output, population-level effects are displayed. If incorporated, autocorrelation and family specific parameters (e.g., the residual standard deviation \code{sigma}) are also given. - -In general, every parameter is summarized using the mean (\code{Estimate}) and the standard deviation (\code{Est.Error}) of the posterior distribution as well as two-sided 95\% Credible intervals (\code{l-95\% CI} and \code{u-95\% CI}) based on quantiles. -The \code{Eff.Sample} value is an estimation of the effective sample size; that is the number of independent samples from the posterior distribution that would be expected to yield the same standard error of the posterior mean as is obtained from the dependent samples returned by the MCMC algorithm. The \code{Rhat} value provides information on the convergence of the algorithm (cf., \citeauthor{gelman1992}, \citeyear{gelman1992}). If \code{Rhat} is considerably greater than 1 (i.e., $> 1.1$), the chains have not yet converged and it is necessary to run more iterations and/or set stronger priors. - -To visually investigate the chains as well as the posterior distribution, the \code{plot} method can be used (see Figure~\ref{kidney_plot}). An even more detailed investigation can be achieved by applying the \pkg{shinystan} package \citep{gabry2015} through method \code{launch_shiny}. With respect to the above summary, \code{sexfemale} seems to be the only population-level effect with considerable influence on the response. Because the mean of \code{sexfemale} is positive, the model predicts longer periods without an infection for females than for males. Effects of population-level predictors can also be visualized with the \code{conditional_effects} method (see Figure~\ref{kidney_conditional_effects}). - -\begin{figure}[ht] - \centering - \includegraphics[width=0.95\textwidth]{kidney_plot.pdf} - \caption{Trace and Density plots of all relevant parameters of the kidney model discussed in Section~\ref{software}.} - \label{kidney_plot} -\end{figure} - -\begin{figure}[ht] - \centering - \includegraphics[height=0.90\textheight]{kidney_conditional_effects.pdf} - \caption{Conditional effects plots of all population-level predictors of the kidney model discussed in Section~\ref{software}.} - \label{kidney_conditional_effects} -\end{figure} - -Looking at the group-level effects, the standard deviation parameter of \code{age} is suspiciously small. To test whether it is smaller than the standard deviation parameter of \code{Intercept}, we apply the \code{hypothesis} method: -\begin{Sinput} -R> hypothesis(fit1, "Intercept - age > 0", class = "sd", group = "patient") -\end{Sinput} -\begin{Soutput} -Hypothesis Tests for class sd_patient: - Estimate Est.Error l-95% CI u-95% CI Evid.Ratio -Intercept-age > 0 0.39 0.27 0.03 Inf 67.97 * ---- -'*': The expected value under the hypothesis lies outside the 95% CI. -\end{Soutput} -The one-sided 95\% credibility interval does not contain zero, thus indicating that the standard deviations differ from each other in the expected direction. In accordance with this finding, the \code{Evid.Ratio} shows that the hypothesis being tested (i.e., \code{Intercept - age > 0}) is about $68$ times more likely than the alternative hypothesis \code{Intercept - age < 0}. It is important to note that this kind of comparison is not easily possible when applying frequentist methods, because in this case only point estimates are available for group-level standard deviations and correlations. - -When looking at the correlation between both group-level effects, its distribution displayed in Figure~\ref{kidney_plot} and the 95\% credibility interval in the summary output appear to be rather wide. This indicates that there is not enough evidence in the data to reasonably estimate the correlation. Together, the small standard deviation of \code{age} and the uncertainty in the correlation raise the question if \code{age} should be modeled as a group specific term at all. To answer this question, we fit another model without this term: -\begin{Sinput} -R> fit2 <- update(fit1, formula. = ~ . - (1 + age|patient) + (1|patient)) -\end{Sinput} - -A good way to compare both models is leave-one-out cross-validation (LOO)\footnote{The WAIC is an approximation of LOO that is faster and easier to compute. However, according to \cite{vehtari2015}, LOO may be the preferred method to perform model comparisons.}, which can be called in \pkg{brms} using -\begin{Sinput} -R> LOO(fit1, fit2) -\end{Sinput} -\begin{Soutput} - LOOIC SE -fit1 675.45 45.18 -fit2 674.17 45.06 -fit1 - fit2 1.28 0.99 -\end{Soutput} -In the output, the LOO information criterion for each model as well as the difference of the LOOs each with its corresponding standard error is shown. Both LOO and WAIC are approximately normal if the number of observations is large so that the standard errors can be very helpful in evaluating differences in the information criteria. However, for small sample sizes, standard errors should be interpreted with care \citep{vehtari2015}. For the present example, it is immediately evident that both models have very similar fit, indicating that there is little benefit in adding group specific coefficients for \code{age}. - -\subsection{Modeling ordinal data} - -In the following, we want to briefly discuss a second example to demonstrate the capabilities of \pkg{brms} in handling ordinal data. \cite{ezzet1991} analyze data from a two-treatment, two-period crossover trial to compare 2 inhalation devices for delivering the drug salbutamol in 286 asthma patients. Patients were asked to rate the clarity of leaflet instructions accompanying each device, using a four-point ordinal scale. Ratings are predicted by \code{treat} to indicate which of the two inhaler devices was used, \code{period} to indicate the time of administration, and \code{carry} to model possible carry over effects. -\begin{Sinput} -R> data("inhaler") -R> head(inhaler, n = 1) -\end{Sinput} -\begin{Soutput} - subject rating treat period carry -1 1 1 0.5 0.5 0 -\end{Soutput} - -Typically, the ordinal response is assumed to originate from the categorization of a latent continuous variable. That is there are $K$ latent thresholds (model intercepts), which partition the continuous scale into the $K + 1$ observable, ordered categories. Following this approach leads to the cumulative or graded-response model \citep{samejima1969} for ordinal data implemented in many \proglang{R} packages. In \pkg{brms}, it is available via family \code{cumulative}. Fitting the cumulative model to the inhaler data, also incorporating an intercept varying by subjects, may look this: -\begin{Sinput} -fit3 <- brm(formula = rating ~ treat + period + carry + (1|subject), - data = inhaler, family = cumulative) -\end{Sinput} -While the support for ordinal data in most \proglang{R} packages ends here\footnote{Exceptions known to us are the packages \pkg{ordinal} \citep{christensen2015} and \pkg{VGAM} \citep{yee2010}. The former supports only cumulative models but with different modeling option for the thresholds. The latter supports all four ordinal families also implemented in \pkg{brms} as well as category specific effects but no group-specific effects.}, \pkg{brms} allows changes to this basic model in at least three ways. First of all, three additional ordinal families are implemented. Families \code{sratio} (stopping ratio) and \code{cratio} (continuation ratio) are so called sequential models \citep{tutz1990}. Both are equivalent to each other for symmetric link functions such as \code{logit} but will differ for asymmetric ones such as \code{cloglog}. The fourth ordinal family is \code{acat} (adjacent category) also known as partial credits model \citep{masters1982, andrich1978a}. Second, restrictions to the thresholds can be applied. By default, thresholds are ordered for family \code{cumulative} or are completely free to vary for the other families. This is indicated by argument \code{threshold = "flexible"} (default) in \code{brm}. Using \code{threshold = "equidistant"} forces the distance between two adjacent thresholds to be the same, that is -$$\tau_k = \tau_1 + (k-1)\delta$$ -for thresholds $\tau_k$ and distance $\delta$ (see also \citealp{andrich1978b}; \citealp{andrich1978a}; \citealp{andersen1977}). -Third, the assumption that predictors have constant effects across categories may be relaxed for non-cumulative ordinal models \citep{vanderark2001, tutz2000} leading to category specific effects. For instance, variable \code{treat} may -only have an impact on the decision between category 3 and 4, but not on the lower categories. Without using category specific effects, such a pattern would remain invisible. - -To illustrate all three modeling options at once, we fit a (hardly theoretically justified) stopping ratio model with equidistant thresholds and category specific effects for variable \code{treat} on which we apply an informative prior. -\begin{Sinput} -fit4 <- brm(formula = rating ~ period + carry + cs(treat) + (1|subject), - data = inhaler, family = sratio, threshold = "equidistant", - prior = set_prior("normal(-1,2)", coef = "treat")) -\end{Sinput} -Note that priors are defined on category specific effects in the same way as for other population-level effects. A model summary can be obtained in the same way as before: -\begin{Sinput} -R> summary(fit4, waic = TRUE) -\end{Sinput} -\begin{Soutput} - Family: sratio (logit) -Formula: rating ~ period + carry + cs(treat) + (1 | subject) - Data: inhaler (Number of observations: 572) -Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; - total post-warmup samples = 4000 - WAIC: 911.9 - -Group-Level Effects: -~subject (Number of levels: 286) - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -sd(Intercept) 1.05 0.23 0.56 1.5 648 1 - -Population-Level Effects: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -Intercept[1] 0.72 0.13 0.48 0.99 2048 1 -Intercept[2] 2.67 0.35 2.00 3.39 969 1 -Intercept[3] 4.62 0.66 3.36 5.95 1037 1 -period 0.25 0.18 -0.09 0.61 4000 1 -carry -0.26 0.22 -0.70 0.17 1874 1 -treat[1] -0.96 0.30 -1.56 -0.40 1385 1 -treat[2] -0.65 0.49 -1.60 0.27 4000 1 -treat[3] -2.65 1.21 -5.00 -0.29 4000 1 - -Family Specific Parameters: - Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat -delta 1.95 0.32 1.33 2.6 1181 1 - -Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample -is a crude measure of effective sample size, and Rhat is the potential -scale reduction factor on split chains (at convergence, Rhat = 1). -\end{Soutput} -Trace and density plots of the model parameters as produced by \code{plot(fit4)} can be found in Figure~\ref{inhaler_plot}. We see that three intercepts (thresholds) and three effects of \code{treat} have been estimated, because a four-point scale was used for the ratings. The treatment effect seems to be strongest between category 3 and 4. At the same time, however, the credible interval is also much larger. In fact, the intervals of all three effects of \code{treat} are highly overlapping, which indicates that there is not enough evidence in the data to support category specific effects. On the bottom of the output, parameter \code{delta} specifies the distance between two adjacent thresholds and indeed the intercepts differ from each other by the magnitude of \code{delta}. - -\begin{figure}[ht] - \centering - \includegraphics[width=0.95\textwidth]{inhaler_plot.pdf} - \caption{Trace and Density plots of all relevant parameters of the inhaler model discussed in Section~\ref{software}.} - \label{inhaler_plot} -\end{figure} - - -\section[Comparison]{Comparison between packages} - -Over the years, many \proglang{R} packages have been developed that implement MLMs, each being more or less general in their supported models. Comparing all of them to \pkg{brms} would be too extensive and barely helpful for the purpose of the present paper. Accordingly, we concentrate on a comparison with four packages. These are \pkg{lme4} \citep{bates2015} and \pkg{MCMCglmm} \citep{hadfield2010}, which are possibly the most general and widely applied \proglang{R} packages for MLMs, as well as \pkg{rstanarm} \citep{rstanarm2016} and \pkg{rethinking} \citep{mcelreath2016}, which are both based on \pkg{Stan}. As opposed to the other packages, \pkg{rethinking} was primarily written for teaching purposes and requires the user to specify the full model explicitly using its own simplified \pkg{BUGS}-like syntax thus helping users to better understand the models that are fitted to their data. - -Regarding model families, all five packages support the most common types such as linear and binomial models as well as Poisson models for count data. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. In addition, \pkg{brms} supports robust linear regression using Student's distribution, which is also implemented on a GitHub branch of \pkg{rstanarm}. \pkg{MCMCglmm} allows fitting multinomial models that are currently not available in the other packages. - -Generalizing classical MLMs, \pkg{brms} and \pkg{MCMCglmm} allow fiting zero-inflated and hurdle models dealing with excess zeros in the response. Furthermore, \pkg{brms} supports non-linear models similar to the \pkg{nlme} package \citep{nlme2016} providing great flexibility but also requiring more care to produce reasonable results. Another flexible model class are generalized additive mixed models \citep{hastie1990,wood2011,zuur2014}, which can be fitted with \pkg{brms} and \pkg{rstanarm}. - -In all five packages, there are quite a few additional modeling options. Variable link functions can be specified in all packages except for \pkg{MCMCglmm}, in which only one link is available per family. \pkg{MCMCglmm} generally supports multivariate responses using data in wide format, whereas \pkg{brms} currently only offers this option for families \code{gaussian} and \code{student}. It should be noted that it is always possible to transform data from wide to long format for compatibility with the other packages. Autocorrelation of the response can only be fitted in \pkg{brms}, which supports auto-regressive as well as moving-average effects. For ordinal models in \pkg{brms}, effects of predictors may vary across different levels of the response as explained in the inhaler example. A feature currently exclusive to \pkg{rethinking} is the possibility to impute missing values in the predictor variables. - -Information criteria are available in all three packages. The advantage of WAIC and LOO implemented in \pkg{brms}, \pkg{rstanarm}, and \pkg{rethinking} is that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the Bayesian packages, \pkg{brms} and \pkg{rethinking} offer a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, we believe that the way priors are specified in \pkg{brms} and \pkg{rethinking} is more intuitive as it is directly evident what prior is actually applied. A more detailed comparison of the packages can be found in Table~\ref{comparison1} and Table~\ref{comparison2}. To facilitate the understanding of the model formulation in \pkg{brms}, Table~\ref{syntax} shows \pkg{lme4} function calls to fit sample models along with the equivalent \pkg{brms} syntax. - -So far the focus was only on capabilities. Another important topic is speed, especially for more complex models. Of course, \pkg{lme4} is usually much faster than the other packages as it uses maximum likelihood methods instead of MCMC algorithms, which are slower by design. To compare the efficiency of the four Bayesian packages, we fitted multilevel models on real data sets using the minimum effective sample size divided by sampling time as a measure of sampling efficiency. One should always aim at running multiple chains as one cannot be sure that a single chain really explores the whole posterior distribution. However, as \pkg{MCMCglmm} does not come with a built-in option to run multiple chains, we used only a single chain to fit the models after making sure that it leads to the same results as multiple chains. The \proglang{R} code allowing to replicate the results is available as supplemental material. - -The first thing that becomes obvious when fitting the models is that \pkg{brms} and \pkg{rethinking} need to compile the \proglang{C++} model before actually fitting it, because the \pkg{Stan} code being parsed to \proglang{C++} is generated on the fly based on the user's input. Compilation takes about a half to one minute depending on the model complexity and computing power of the machine. This is not required by \pkg{rstanarm} and \pkg{MCMCglmm}, although the former is also based on \pkg{Stan}, as compilation takes place only once at installation time. While the latter approach saves the compilation time, the former is more flexible when it comes to model specification. For small and simple models, compilation time dominates the overall computation time, but for larger and more complex models, sampling will take several minutes or hours so that one minute more or less will not really matter, anymore. Accordingly, the following comparisons do not include the compilation time. - -In models containing only group-specific intercepts, \pkg{MCMCglmm} is usually more efficient than the \pkg{Stan} packages. However, when also estimating group-specific slopes, \pkg{MCMCglmm} falls behind the other packages and quite often refuses to sample at all unless one carefully specifies informative priors. Note that these results are obtained by running only a single chain. For all three \pkg{Stan} packages, sampling efficiency can easily be increased by running multiple chains in parallel. Comparing the \pkg{Stan} packages to each other, \pkg{brms} is usually most efficient for models with group-specific terms, whereas \pkg{rstanarm} tends to be roughly $50\%$ to $75\%$ as efficient at least for the analyzed data sets. The efficiency of \pkg{rethinking} is more variable depending on the model formulation and data, sometimes being slightly ahead of the other two packages, but usually being considerably less efficient. Generally, \pkg{rethinking} loses efficiency for models with many population-level effects presumably because one cannot use design matrices and vectorized prior specifications for population-level parameters. Note that it was not possible to specify the exact same priors across packages due to varying parameterizations. Of course, efficiency depends heavily on the model, chosen priors, and data at hand so that the present results should not be over-interpreted. - -\begin{table}[hbtp] -\centering -\begin{tabular}{llll} - & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{lme4}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline -\\ [-1.5ex] -\parbox{6cm}{Supported model types:} & & & \\ [1ex] -Linear models & yes & yes & yes \\ -Robust linear models & yes & no & no \\ -Binomial models & yes & yes & yes \\ -Categorical models & yes & no & yes \\ -Multinomial models & no & no & yes \\ -Count data models & yes & yes & yes \\ -Survival models & yes$^1$ & yes & yes \\ -Ordinal models & various & no & cumulative \\ -Zero-inflated and hurdle models & yes & no & yes \\ -Generalized additive models & yes & no & no \\ -Non-linear models & yes & no & no \\ \hline -\\ [-1.5ex] -\parbox{5cm}{Additional modeling options:} & & & \\ [1ex] -Variable link functions & various & various & no \\ -Weights & yes & yes & no \\ -Offset & yes & yes & using priors \\ -Multivariate responses & limited & no & yes \\ -Autocorrelation effects & yes & no & no \\ -Category specific effects & yes & no & no \\ -Standard errors for meta-analysis & yes & no & yes \\ -Censored data & yes & no & yes \\ -Truncated data & yes & no & no \\ -Customized covariances & yes & no & yes \\ -Missing value imputation & no & no & no \\ \hline -\\ [-1.5ex] -Bayesian specifics: & & & \\ [1ex] -parallelization & yes & -- & no \\ -population-level priors & flexible & --$^3$ & normal \\ -group-level priors & normal & --$^3$ & normal \\ -covariance priors & flexible & --$^3$ & restricted$^4$ \\ \hline -\\ [-1.5ex] -Other: & & & \\ [1ex] -Estimator & HMC, NUTS & ML, REML & MH, Gibbs$^2$ \\ -Information criterion & WAIC, LOO & AIC, BIC & DIC \\ -\proglang{C++} compiler required & yes & no & no \\ -Modularized & no & yes & no \\ \hline -\end{tabular} -\caption{Comparison of the capabilities of the \pkg{brms}, \pkg{lme4} and \pkg{MCMCglmm} package. Notes: (1) Weibull family only available in \pkg{brms}. (2) Estimator consists of a combination of both algorithms. (3) Priors may be imposed using the \pkg{blme} package \citep{chung2013}. (4) For details see \cite{hadfield2010}.} -\label{comparison1} -\end{table} - - -\begin{table}[hbtp] -\centering -\begin{tabular}{llll} - & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{rethinking}} \\ \hline -\\ [-1.5ex] -\parbox{6cm}{Supported model types:} & & & \\ [1ex] -Linear models & yes & yes & yes \\ -Robust linear models & yes & yes$^1$ & no \\ -Binomial models & yes & yes & yes \\ -Categorical models & yes & no & no \\ -Multinomial models & no & no & no \\ -Count data models & yes & yes & yes \\ -Survival models & yes$^2$ & yes & yes \\ -Ordinal models & various & cumulative$^3$ & no \\ -Zero-inflated and hurdle models & yes & no & no \\ -Generalized additive models & yes & yes & no \\ -Non-linear models & yes & no & limited$^4$ \\ \hline -\\ [-1.5ex] -\parbox{5cm}{Additional modeling options:} & & & \\ [1ex] -Variable link functions & various & various & various \\ -Weights & yes & yes & no \\ -Offset & yes & yes & yes \\ -Multivariate responses & limited & no & no \\ -Autocorrelation effects & yes & no & no \\ -Category specific effects & yes & no & no \\ -Standard errors for meta-analysis & yes & no & no \\ -Censored data & yes & no & no \\ -Truncated data & yes & no & yes \\ -Customized covariances & yes & no & no \\ -Missing value imputation & no & no & yes \\ \hline -\\ [-1.5ex] -Bayesian specifics: & & & \\ [1ex] -parallelization & yes & yes & yes \\ -population-level priors & flexible & normal, Student-t & flexible \\ -group-level priors & normal & normal & normal \\ -covariance priors & flexible & restricted$^5$ & flexible \\ \hline -\\ [-1.5ex] -Other: & & & \\ [1ex] -Estimator & HMC, NUTS & HMC, NUTS & HMC, NUTS \\ -Information criterion & WAIC, LOO & AIC, LOO & AIC, LOO \\ -\proglang{C++} compiler required & yes & no & yes \\ -Modularized & no & no & no \\ \hline -\end{tabular} -\caption{Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{rethinking} package. Notes: (1) Currently only implemented on a branch on GitHub. (2) Weibull family only available in \pkg{brms}. (3) No group-level terms allowed. (4) The parser is mainly written for linear models but also accepts some non-linear model specifications. (5) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}.} -\label{comparison2} -\end{table} - - -\begin{table}[hbtp] -\centering -%\renewcommand{\arraystretch}{2} -\begin{tabular}{ll} - Dataset & \parbox{10cm}{Function call} \\ \hline -\\ [-1.5ex] -\parbox{2cm}{cake} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{lmer(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{5ex} data = cake)}} \\ [3ex] -\pkg{brms} & \parbox{13cm}{\code{brm(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{4ex} data = cake)}} \\ [2ex] \hline -\\ [-1.5ex] -\parbox{2cm}{sleepstudy} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{lmer(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [1.5ex] -\pkg{brms} & \parbox{13cm}{\code{brm(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [2ex] \hline -\\ [-1.5ex] -\parbox{2cm}{cbpp$^1$} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{glmer(cbind(incidence, size - incidence) $\sim$ period + (1 | herd), \\ \hspace*{6ex} family = binomial("logit"), data = cbpp)}} \\ [3ex] -\pkg{brms} & \parbox{13cm}{\code{brm(incidence | trials(size) $\sim$ period + (1 | herd), \\ \hspace*{4ex} family = binomial("logit"), data = cbpp)}} \\ [2ex] \hline -\\ [-1.5ex] -\parbox{2cm}{grouseticks$^1$} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{glmer(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{6ex} family = poisson("log"), data = grouseticks)}} \\ [3ex] -\pkg{brms} & \parbox{13cm}{\code{brm(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{4ex} family = poisson("log"), data = grouseticks)}} \\ [2ex] \hline -\\ [-1ex] -\parbox{2cm}{VerbAgg$^2$} & \\ [1ex] -\pkg{lme4} & \parbox{13cm}{\code{glmer(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{6ex} + (1|item), family = binomial, data = VerbAgg)}} \\ [3ex] -\pkg{brms} & \parbox{13cm}{\code{brm(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{4ex} + (1|item), family = bernoulli, data = VerbAgg)}} \\ [2ex] \hline -\\ [-1.5ex] -\end{tabular} -\caption{Comparison of the model syntax of \pkg{lme4} and \pkg{brms} using data sets included in \pkg{lme4}. Notes: (1) Default links are used to that the link argument may be omitted. (2) Fitting this model takes some time. A proper prior on the population-level effects (e.g., \code{prior = set\_prior("normal(0,5)")}) may help in increasing sampling speed.} -\label{syntax} -\end{table} - -\section{Conclusion} -The present paper is meant to provide a general overview on the \proglang{R} package \pkg{brms} implementing MLMs using the probabilistic programming language \pkg{Stan} for full Bayesian inference. Although only a small selection of the modeling options available in \pkg{brms} are discussed in detail, I hope that this article can serve as a good starting point to further explore the capabilities of the package. - -For the future, I have several plans on how to improve the functionality of \pkg{brms}. I want to include multivariate models that can handle multiple response variables coming from different distributions as well as new correlation structures for instance for spatial data. Similarily, distributional regression models as well as mixture response distributions appear to be valuable extensions of the package. I am always grateful for any suggestions and ideas regarding new features. - -\section*{Acknowledgments} - -First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language \pkg{Stan}, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Two anonymous reviewers provided very detailed and thoughtful suggestions to substantially improve both the package and the paper. Furthermore, Prof. Philipp Doebler and Prof. Heinz Holling have given valuable feedback on earlier versions of the paper. Lastly, I want to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. - -\bibliography{citations_overview} - -\end{document} +\documentclass[article, nojss]{jss} + +%\VignetteIndexEntry{Overview of the brms Package} +%\VignetteEngine{R.rsp::tex} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% declarations for jss.cls %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%% almost as usual +\author{Paul-Christian B\"urkner} +\title{\pkg{brms}: An \proglang{R} Package for Bayesian Multilevel Models using \pkg{Stan}} + +%% for pretty printing and a nice hypersummary also set: +\Plainauthor{Paul-Christian B\"urkner} %% comma-separated +\Plaintitle{brms: An R Package for Bayesian Multilevel Models using Stan} %% without formatting +\Shorttitle{\pkg{brms}: Bayesian Multilevel Models using Stan} %% a short title (if necessary) + +%% an abstract and keywords +\Abstract{ + The \pkg{brms} package implements Bayesian multilevel models in \proglang{R} using the probabilistic programming language \pkg{Stan}. A wide range of distributions and link functions are supported, allowing users to fit -- among others -- linear, robust linear, binomial, Poisson, survival, response times, ordinal, quantile, zero-inflated, hurdle, and even non-linear models all in a multilevel context. Further modeling options include autocorrelation of the response variable, user defined covariance structures, censored data, as well as meta-analytic standard errors. Prior specifications are flexible and explicitly encourage users to apply prior distributions that actually reflect their beliefs. In addition, model fit can easily be assessed and compared using posterior-predictive checks and leave-one-out cross-validation. If you use \pkg{brms}, please cite this article as published in the Journal of Statistical Software \citep{brms1}. +} +\Keywords{Bayesian inference, multilevel model, ordinal data, MCMC, \proglang{Stan}, \proglang{R}} +\Plainkeywords{Bayesian inference, multilevel model, ordinal data, MCMC, Stan, R} %% without formatting +%% at least one keyword must be supplied + +%% publication information +%% NOTE: Typically, this can be left commented and will be filled out by the technical editor +%% \Volume{50} +%% \Issue{9} +%% \Month{June} +%% \Year{2012} +%% \Submitdate{2012-06-04} +%% \Acceptdate{2012-06-04} + +%% The address of (at least) one author should be given +%% in the following format: +\Address{ + Paul-Christian B\"urkner\\ + E-mail: \email{paul.buerkner@gmail.com}\\ + URL: \url{https://paul-buerkner.github.io} +} +%% It is also possible to add a telephone and fax number +%% before the e-mail in the following format: +%% Telephone: +43/512/507-7103 +%% Fax: +43/512/507-2851 + + +%% for those who use Sweave please include the following line (with % symbols): +%% need no \usepackage{Sweave.sty} + +%% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\begin{document} + +%% include your article here, just as usual +%% Note that you should use the \pkg{}, \proglang{} and \code{} commands. + +\section{Introduction} + +Multilevel models (MLMs) offer a great flexibility for researchers across sciences \citep{brown2015, demidenko2013, gelmanMLM2006, pinheiro2006}. They allow the modeling of data measured on different levels at the same time -- for instance data of students nested within classes and schools -- thus taking complex dependency structures into account. It is not surprising that many packages for \proglang{R} \citep{Rcore2015} have been developed to fit MLMs. Possibly the most widely known package in this area is \pkg{lme4} \citep{bates2015}, which uses maximum likelihood or restricted maximum likelihood methods for model fitting. Although alternative Bayesian methods have several advantages over frequentist approaches (e.g., the possibility of explicitly incorporating prior knowledge about parameters into the model), their practical use was limited for a long time because the posterior distributions of more complex models (such as MLMs) could not be found analytically. Markov chain Monte Carlo (MCMC) algorithms allowing to draw random samples from the posterior were not available or too time-consuming. In the last few decades, however, this has changed with the development of new algorithms and the rapid increase of general computing power. Today, several software packages implement these techniques, for instance \pkg{WinBugs} \citep{lunn2000, spiegelhalter2003}, \pkg{OpenBugs} \citep{spiegelhalter2007}, \pkg{JAGS} \citep{plummer2013}, \pkg{MCMCglmm} \citep{hadfield2010} and \pkg{Stan} \citep{stan2017, carpenter2017} to mention only a few. With the exception of the latter, all of these programs are primarily using combinations of Metropolis-Hastings updates \citep{metropolis1953,hastings1970} and Gibbs-sampling \citep{geman1984,gelfand1990}, sometimes also coupled with slice-sampling \citep{damien1999,neal2003}. One of the main problems of these algorithms is their rather slow convergence for high-dimensional models with correlated parameters \citep{neal2011,hoffman2014,gelman2014}. Furthermore, Gibbs-sampling requires priors to be conjugate to the likelihood of parameters in order to work efficiently \citep{gelman2014}, thus reducing the freedom of the researcher in choosing a prior that reflects his or her beliefs. In contrast, \pkg{Stan} implements Hamiltonian Monte Carlo \citep{duane1987, neal2011} and its extension, the No-U-Turn Sampler (NUTS) \citep{hoffman2014}. These algorithms converge much more quickly especially for high-dimensional models regardless of whether the priors are conjugate or not \citep{hoffman2014}. + +Similar to software packages like \pkg{WinBugs}, \pkg{Stan} comes with its own programming language, allowing for great modeling flexibility (cf., \citeauthor{stanM2017} \citeyear{stanM2017}; \citeauthor{carpenter2017} \citeyear{carpenter2017}). Many researchers may still hesitate to use \pkg{Stan} directly, as every model has to be written, debugged and possibly also optimized. This may be a time-consuming and error prone process even for researchers familiar with Bayesian inference. The package \pkg{brms}, presented in this paper, aims at closing this gap (at least for MLMs) allowing the user to benefit from the merits of \pkg{Stan} only by using simple, \pkg{lme4}-like formula syntax. \pkg{brms} supports a wide range of distributions and link functions, allows for multiple grouping factors each with multiple group-level effects, autocorrelation of the response variable, user defined covariance structures, as well as flexible and explicit prior specifications. + +The purpose of the present article is to provide a general overview of the \pkg{brms} package (version 0.10.0). We begin by explaining the underlying structure of MLMs. Next, the software is introduced in detail using recurrence times of infection in kidney patients \citep{mcgilchrist1991} and ratings of inhaler instructions \citep{ezzet1991} as examples. We end by comparing \pkg{brms} to other \proglang{R} packages implementing MLMs and describe future plans for extending the package. + +\section{Model description} +\label{model} + +The core of every MLM is the prediction of the response $y$ through the linear combination $\eta$ of predictors transformed by the inverse link function $f$ assuming a certain distribution $D$ for $y$. We write +$$y_i \sim D(f(\eta_i), \theta)$$ +to stress the dependency on the $i\textsuperscript{th}$ data point. In many \proglang{R} packages, $D$ is also called the `family' and we will use this term in the following. The parameter $\theta$ describes additional family specific parameters that typically do not vary across data points, such as the standard deviation $\sigma$ in normal models or the shape $\alpha$ in Gamma or negative binomial models. The linear predictor can generally be written as +$$\eta = \mathbf{X} \beta + \mathbf{Z} u$$ +In this equation, $\beta$ and $u$ are the coefficients at population-level and group-level respectively and $\mathbf{X}, \mathbf{Z}$ are the corresponding design matrices. The response $y$ as well as $\mathbf{X}$ and $\mathbf{Z}$ make up the data, whereas $\beta$, $u$, and $\theta$ are the model parameters being estimated. The coefficients $\beta$ and $u$ may be more commonly known as fixed and random effects. However, we avoid these terms in the present paper following the recommendations of \cite{gelmanMLM2006}, as they are not used unambiguously in the literature. Also, we want to make explicit that $u$ is a model parameter in the same manner as $\beta$ so that uncertainty in its estimates can be naturally evaluated. In fact, this is an important advantage of Bayesian MCMC methods as compared to maximum likelihood approaches, which do not treat $u$ as a parameter, but assume that it is part of the error term instead (cf., \citeauthor{fox2011}, \citeyear{fox2011}). + +Except for linear models, we do not incorporate an additional error term for every observation by default. If desired, such an error term can always be modeled using a grouping factor with as many levels as observations in the data. + +\subsection{Prior distributions} + +\subsubsection{Regression parameters at population-level} + +In \pkg{brms}, population-level parameters are not restricted to have normal priors. Instead, every parameter can have every one-dimensional prior implemented in \pkg{Stan}, for instance uniform, Cauchy or even Gamma priors. As a negative side effect of this flexibility, correlations between them cannot be modeled as parameters. If desired, point estimates of the correlations can be obtained after sampling has been done. By default, population level parameters have an improper flat prior over the reals. + +\subsubsection{Regression parameters at group-level} + +The group-level parameters $u$ are assumed to come from a multivariate normal distribution with mean zero and unknown covariance matrix $\mathbf{\Sigma}$: +$$u \sim N(0, \mathbf{\Sigma})$$ +As is generally the case, covariances between group-level parameters of different grouping factors are assumed to be zero. This implies that $\mathbf{Z}$ and $u$ can be split up into several matrices $\mathbf{Z_k}$ and parameter vectors $u_k$, where $k$ indexes grouping factors, so that the model can be simplified to +$$u_k \sim N(0, \mathbf{\Sigma_k})$$ +Usually, but not always, we can also assume group-level parameters associated with different levels (indexed by $j$) of the same grouping factor to be independent leading to +$$u_{kj} \sim N(0, \mathbf{V_k})$$ +The covariance matrices $\mathbf{V_k}$ are modeled as parameters. In most packages, an Inverse-Wishart distribution is used as a prior for $\mathbf{V_k}$. This is mostly because its conjugacy leads to good properties of Gibbs-Samplers \citep{gelman2014}. However, there are good arguments against the Inverse-Wishart prior \citep{natarajan2000, kass2006}. The NUTS-Sampler implemented in \pkg{Stan} does not require priors to be conjugate. This advantage is utilized in \pkg{brms}: $\mathbf{V_k}$ is parameterized in terms of a correlation matrix $\mathbf{\Omega_k}$ and a vector of standard deviations $\sigma_k$ through +$$\mathbf{V_k} = \mathbf{D}(\sigma_k) \mathbf{\Omega_k} \mathbf{D}(\sigma_k)$$ +where $\mathbf{D}(\sigma_k)$ denotes the diagonal matrix with diagonal elements $\sigma_k$. Priors are then specified for the parameters on the right hand side of the equation. For $\mathbf{\Omega_k}$, we use the LKJ-Correlation prior with parameter $\zeta > 0$ by \cite{lewandowski2009}\footnote{Internally, the Cholesky factor of the correlation matrix is used, as it is more efficient and numerically stable.}: +$$\mathbf{\Omega_k} \sim \mathrm{LKJ}(\zeta)$$ +The expected value of the LKJ-prior is the identity matrix (implying correlations of zero) for any positive value of $\zeta$, which can be interpreted like the shape parameter of a symmetric beta distribution \citep{stanM2017}. If $\zeta = 1$ (the default in \pkg{brms}) the density is uniform over correlation matrices of the respective dimension. If $\zeta > 1$, the identity matrix is the mode of the prior, with a sharper peak in the density for larger values of $\zeta$. If $0 < \zeta < 1$ the prior is U-shaped having a trough at the identity matrix, which leads to higher probabilities for non-zero correlations. For every element of $\sigma_k$, any prior can be applied that is defined on the non-negative reals only. As default in \pkg{brms}, we use a half Student-t prior with 3 degrees of freedom. This prior often leads to better convergence of the models than a half Cauchy prior, while still being relatively weakly informative. + +Sometimes -- for instance when modeling pedigrees -- different levels of the same grouping factor cannot be assumed to be independent. In this case, the covariance matrix of $u_k$ becomes +$$\mathbf{\Sigma_k} = \mathbf{V_k} \otimes \mathbf{A_k}$$ +where $\mathbf{A_k}$ is the known covariance matrix between levels and $\otimes$ is the Kronecker product. + +\subsubsection{Family specific parameters} + +For some families, additional parameters need to be estimated. In the current section, we only name the most important ones. Normal and Student's distributions need the parameter $\sigma$ to account for residual error variance. By default, $\sigma$ has a half Cauchy prior with a scale parameter that depends on the standard deviation of the response variable to remain only weakly informative regardless of response variable's scaling. Furthermore, Student's distributions needs the parameter $\nu$ representing the degrees of freedom. By default, $\nu$ has a wide gamma prior as proposed by \cite{juarez2010}. Gamma, Weibull, and negative binomial distributions need the shape parameter $\alpha$ that also has a wide gamma prior by default. + +\section{Parameter estimation} + +The \pkg{brms} package does not fit models itself but uses \pkg{Stan} on the back-end. Accordingly, all samplers implemented in \pkg{Stan} can be used to fit \pkg{brms} models. Currently, these are the static Hamiltonian Monte-Carlo (HMC) Sampler sometimes also referred to as Hybrid Monte-Carlo \citep{neal2011, neal2003, duane1987} and its extension the No-U-Turn Sampler (NUTS) by \cite{hoffman2014}. HMC-like algorithms produce samples that are much less autocorrelated than those of other samplers such as the random-walk Metropolis algorithm \citep{hoffman2014, Creutz1988}. The main drawback of this increased efficiency is the need to calculate the gradient of the log-posterior, which can be automated using algorithmic differentiation \citep{griewank2008} but is still a time-consuming process for more complex models. Thus, using HMC leads to higher quality samples but takes more time per sample than other algorithms typically applied. Another drawback of HMC is the need to pre-specify at least two parameters, which are both critical for the performance of HMC. The NUTS Sampler allows setting these parameters automatically thus eliminating the need for any hand-tuning, while still being at least as efficient as a well tuned HMC \citep{hoffman2014}. For more details on the sampling algorithms applied in \pkg{Stan}, see the \pkg{Stan} user's manual \citep{stanM2017} as well as \cite{hoffman2014}. + +In addition to the estimation of model parameters, \pkg{brms} allows drawing samples from the posterior predictive distribution as well as from the pointwise log-likelihood. Both can be used to assess model fit. The former allows a comparison between the actual response $y$ and the response $\hat{y}$ predicted by the model. The pointwise log-likelihood can be used, among others, to calculate the widely applicable information criterion (WAIC) proposed by \cite{watanabe2010} and leave-one-out cross-validation (LOO; \citealp{gelfand1992}; \citealp{vehtari2015}; see also \citealp{ionides2008}) both allowing to compare different models applied to the same data (lower WAICs and LOOs indicate better model fit). The WAIC can be viewed as an improvement of the popular deviance information criterion (DIC), which has been criticized by several authors (\citealp{vehtari2015}; \citealp{plummer2008}; \citealp{vanderlinde2005}; see also the discussion at the end of the original DIC paper by \citealp{spiegelhalter2002}) in part because of problems arising from fact that the DIC is only a point estimate. In \pkg{brms}, WAIC and LOO are implemented using the \pkg{loo} package \citep{loo2016} also following the recommendations of \cite{vehtari2015}. + +\section{Software} +\label{software} + +The \pkg{brms} package provides functions for fitting MLMs using \pkg{Stan} for full Bayesian inference. To install the latest release version of \pkg{brms} from CRAN, type \code{install.packages("brms")} within \proglang{R}. The current developmental version can be downloaded from GitHub via +\begin{Sinput} +devtools::install_github("paul-buerkner/brms") +\end{Sinput} +Additionally, a \proglang{C++} compiler is required. This is because \pkg{brms} internally creates \pkg{Stan} code, which is translated to \proglang{C++} and compiled afterwards. The program \pkg{Rtools} \citep{Rtools2015} comes with a \proglang{C++} compiler for Windows\footnote{During the installation process, there is an option to change the system \code{PATH}. Please make sure to check this options, because otherwise \pkg{Rtools} will not be available within \proglang{R}.}. +On OS X, one should use \pkg{Xcode} \citep{Xcode2015} from the App Store. To check whether the compiler can be called within \proglang{R}, run \code{system("g++ -v")} when using \pkg{Rtools} or \code{system("clang++ -v")} when using \pkg{Xcode}. If no warning occurs and a few lines of difficult to read system code are printed out, the compiler should work correctly. For more detailed instructions on how to get the compilers running, see the prerequisites section on \url{https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started}. + +Models are fitted in \pkg{brms} using the following procedure, which is also summarized in Figure~\ref{flowchart}. First, the user specifies the model using the \code{brm} function in a way typical for most model fitting \proglang{R} functions, that is by defining \code{formula}, \code{data}, and \code{family}, as well as some other optional arguments. Second, this information is processed and the \code{make_stancode} and \code{make_standata} functions are called. The former generates the model code in \pkg{Stan} language and the latter prepares the data for use in \pkg{Stan}. These two are the mandatory parts of every \pkg{Stan} model and without \pkg{brms}, users would have to specify them themselves. Third, \pkg{Stan} code and data as well as additional arguments (such as the number of iterations and chains) are passed to functions of the \pkg{rstan} package (the \proglang{R} interface of \pkg{Stan}; \citeauthor{stan2017}, \citeyear{stan2017}). Fourth, the model is fitted by \pkg{Stan} after translating and compiling it in \proglang{C++}. Fifth, after the model has been fitted and returned by \pkg{rstan}, the fitted model object is post-processed in \pkg{brms} among others by renaming the model parameters to be understood by the user. Sixth, the results can be investigated in \proglang{R} using various methods such as \code{summary}, \code{plot}, or \code{predict} (for a complete list of methods type \code{methods(class = "brmsfit")}). + +\begin{figure}[ht] + \centering + \includegraphics[height = 0.4\textheight, keepaspectratio]{flowchart.pdf} + \caption{High level description of the model fitting procedure used in \pkg{brms}.} + \label{flowchart} +\end{figure} + +\subsection{A worked example} + +In the following, we use an example about the recurrence time of an infection in kidney patients initially published by \cite{mcgilchrist1991}. The data set consists of 76 entries of 7 variables: +\begin{Sinput} +R> library("brms") +R> data("kidney") +R> head(kidney, n = 3) +\end{Sinput} +\begin{Soutput} + time censored patient recur age sex disease +1 8 0 1 1 28 male other +2 23 0 2 1 48 female GN +3 22 0 3 1 32 male other +\end{Soutput} +Variable \code{time} represents the recurrence time of the infection, +\code{censored} indicates if \code{time} is right censored (\code{1}) or not censored (\code{0}), variable \code{patient} is the patient id, and +\code{recur} indicates if it is the first or second recurrence in that patient. Finally, variables \code{age}, \code{sex}, and \code{disease} make up the predictors. + +\subsection[Fitting models with brms]{Fitting models with \pkg{brms}} + +The core of the \pkg{brms} package is the \code{brm} function and we will explain its argument structure using the example above. Suppose we want to predict the (possibly censored) recurrence time using a log-normal model, in which the intercept as well as the effect of \code{age} is nested within patients. Then, we may use the following code: +\begin{Sinput} +fit1 <- brm(formula = time | cens(censored) ~ age * sex + disease + + (1 + age|patient), + data = kidney, family = lognormal(), + prior = c(set_prior("normal(0,5)", class = "b"), + set_prior("cauchy(0,2)", class = "sd"), + set_prior("lkj(2)", class = "cor")), + warmup = 1000, iter = 2000, chains = 4, + control = list(adapt_delta = 0.95)) +\end{Sinput} + +\subsection[formula: Information on the response and predictors]{\code{formula}: Information on the response and predictors} + +Without doubt, \code{formula} is the most complicated argument, as it contains information on the response variable as well as on predictors at different levels of the model. Everything before the $\sim$ sign relates to the response part of \code{formula}. In the usual and most simple case, this is just one variable name (e.g., \code{time}). However, to incorporate additional information about the response, one can add one or more terms of the form \code{| fun(variable)}. \code{fun} may be one of a few functions defined internally in \pkg{brms} and \code{variable} corresponds to a variable in the data set supplied by the user. In this example, \code{cens} makes up the internal function that handles censored data, and \code{censored} is the variable that contains information on the censoring. Other available functions in this context are \code{weights} and \code{disp} to allow different sorts of weighting, \code{se} to specify known standard errors primarily for meta-analysis, \code{trunc} to define truncation boundaries, \code{trials} for binomial models\footnote{In functions such as \code{glm} or \code{glmer}, the binomial response is typically passed as \code{cbind(success, failure)}. In \pkg{brms}, the equivalent syntax is \code{success | trials(success + failure)}.}, and \code{cat} to specify the number of categories for ordinal models. + +Everything on the right side of $\sim$ specifies predictors. Here, the syntax exactly matches that of \pkg{lme4}. For both, population-level and group-level terms, the \code{+} is used to separate different effects from each other. Group-level terms are of the form \code{(coefs | group)}, where \code{coefs} contains one or more variables whose effects are assumed to vary with the levels of the grouping factor given in \code{group}. Multiple grouping factors each with multiple group-level coefficients are possible. In the present example, only one group-level term is specified in which \code{1 + age} are the coefficients varying with the grouping factor \code{patient}. This implies that the intercept of the model as well as the effect of age is supposed to vary between patients. By default, group-level coefficients within a grouping factor are assumed to be correlated. Correlations can be set to zero by using the \code{(coefs || group)} syntax\footnote{In contrast to \pkg{lme4}, the \code{||} operator in \pkg{brms} splits up the design matrix computed from \code{coefs} instead of decomposing \code{coefs} in its terms. This implies that columns of the design matrix originating from the same factor are also assumed to be uncorrelated, whereas \pkg{lme4} estimates the correlations in this case. For a way to achieve \pkg{brms}-like behavior with \pkg{lme4}, see the \code{mixed} function of the \pkg{afex} package by \cite{afex2015}.}. Everything on the right side of \code{formula} that is not recognized as part of a group-level term is treated as a population-level effect. In this example, the population-level effects are \code{age}, \code{sex}, and \code{disease}. + +\subsection[family: Distribution of the response variable]{\code{family}: Distribution of the response variable} + +Argument \code{family} should usually be a family function, a call to a family function or a character string naming the family. If not otherwise specified, default link functions are applied. \pkg{brms} comes with a large variety of families. Linear and robust linear regression can be performed using the \code{gaussian} or \code{student} family combined with the \code{identity} link. For dichotomous and categorical data, families \code{bernoulli}, \code{binomial}, and \code{categorical} combined with the \code{logit} link, by default, are perfectly suited. Families \code{poisson}, \code{negbinomial}, and \code{geometric} allow for modeling count data. Families \code{lognormal}, \code{Gamma}, \code{exponential}, and \code{weibull} can be used (among others) for survival regression. Ordinal regression can be performed using the families \code{cumulative}, \code{cratio}, \code{sratio}, and \code{acat}. Finally, families \code{zero_inflated_poisson}, \code{zero_inflated_negbinomial}, \code{zero_inflated_binomial}, \code{zero_inflated_beta}, \code{hurdle_poisson}, \code{hurdle_negbinomial}, and \code{hurdle_gamma} can be used to adequately model excess zeros in the response. In our example, we use \code{family = lognormal()} implying a log-normal ``survival'' model for the response variable \code{time}. + +\subsection[prior: Prior distributions of model parameters]{\code{prior}: Prior distributions of model parameters} + +Every population-level effect has its corresponding regression parameter. These parameters are named as \code{b\_}, where \code{} represents the name of the corresponding population-level effect. The default prior is an improper flat prior over the reals. Suppose, for instance, that we want to set a normal prior with mean \code{0} and standard deviation \code{10} on the effect of \code{age} and a Cauchy prior with location \code{1} and scale \code{2} on \code{sexfemale}\footnote{When factors are used as predictors, parameter names will depend on the factor levels. To get an overview of all parameters and parameter classes for which priors can be specified, use function \code{get\_prior}. For the present example, \code{get\_prior(time | cens(censored) $\sim$ age * sex + disease + (1 + age|patient), data = kidney, family = lognormal())} does the desired.}. Then, we may write +\begin{Sinput} +prior <- c(set_prior("normal(0,10)", class = "b", coef = "age"), + set_prior("cauchy(1,2)", class = "b", coef = "sexfemale")) +\end{Sinput} +To put the same prior (e.g., a normal prior) on all population-level effects at once, we may write as a shortcut \code{set_prior("normal(0,10)", class = "b")}. This also leads to faster sampling, because priors can be vectorized in this case. Note that we could also omit the \code{class} argument for population-level effects, as it is the default class in \code{set_prior}. + +A special shrinkage prior to be applied on population-level effects is the horseshoe prior \citep{carvalho2009, carvalho2010}. It is symmetric around zero with fat tails and an infinitely large spike at zero. This makes it ideal for sparse models that have many regression coefficients, although only a minority of them is non-zero. The horseshoe prior can be applied on all population-level effects at once (excluding the intercept) by using \code{set_prior("horseshoe(1)")}. +The $1$ implies that the Student-$t$ prior of the local shrinkage parameters has 1 degrees of freedom. In \pkg{brms} it is possible to increase the degrees of freedom (which will often improve convergence), although the prior no longer resembles a horseshoe in this case\footnote{This class of priors is often referred to as hierarchical shrinkage family, which contains the original horseshoe prior as a special case.}. For more details see \cite{carvalho2009, carvalho2010}. + +Each group-level effect of each grouping factor has a standard deviation parameter, which is restricted to be non-negative and, by default, has a half Student-$t$ prior with $3$ degrees of freedom and a scale parameter that is minimally $10$. For non-ordinal models, \pkg{brms} tries to evaluate if the scale is large enough to be considered only weakly informative for the model at hand by comparing it with the standard deviation of the response after applying the link function. If this is not the case, it will increase the scale based on the aforementioned standard deviation\footnote{Changing priors based on the data is not truly Bayesian and might rightly be criticized. However, it helps avoiding the problem of too informative default priors without always forcing users to define their own priors. The latter would also be problematic as not all users can be expected to be well educated Bayesians and reasonable default priors will help them a lot in using Bayesian methods.}. \pkg{Stan} implicitly defines a half Student-$t$ prior by using a Student-$t$ prior on a restricted parameter \citep{stanM2017}. For other reasonable priors on standard deviations see \cite{gelman2006}. In \pkg{brms}, standard deviation parameters are named as \code{sd\_\_} so that \code{sd\_patient\_Intercept} and \code{sd\_patient\_age} are the parameter names in the example. If desired, it is possible to set a different prior on each parameter, but statements such as \code{set_prior("student_t(3,0,5)", class = "sd", group = "patient")} or even \code{set_prior("student_t(3,0,5)", class = "sd")} may also be used and are again faster because of vectorization. + +If there is more than one group-level effect per grouping factor, correlations between group-level effects are estimated. As mentioned in Section~\ref{model}, the LKJ-Correlation prior with parameter $\zeta > 0$ \citep{lewandowski2009} is used for this purpose. In \pkg{brms}, this prior is abbreviated as \code{"lkj(zeta)"} and correlation matrix parameters are named as \code{cor\_}, (e.g., \code{cor_patient}), so that \code{set_prior("lkj(2)", class = "cor", group = "patient")} is a valid statement. To set the same prior on every correlation matrix in the model, \code{set_prior("lkj(2)", class = "cor")} is also allowed, but does not come with any efficiency increases. + +Other model parameters such as the residual standard deviation \code{sigma} in normal models or the \code{shape} in Gamma models have their priors defined in the same way, where each of them is treated as having its own parameter class. A complete overview on possible prior distributions is given in the \pkg{Stan} user's manual \citep{stanM2017}. Note that \pkg{brms} does not thoroughly check if the priors are written in correct \pkg{Stan} language. Instead, \pkg{Stan} will check their syntactical correctness when the model is parsed to \proglang{C++} and return an error if they are not. This, however, does not imply that priors are always meaningful if they are accepted by \pkg{Stan}. Although \pkg{brms} tries to find common problems (e.g., setting bounded priors on unbounded parameters), there is no guarantee that the defined priors are reasonable for the model. + +\subsection[control Adjusting the sampling behavior of Stan]{\code{control}: Adjusting the sampling behavior of \pkg{Stan}} + +In addition to choosing the number of iterations, warmup samples, and chains, users can control the behavior of the NUTS sampler by using the \code{control} argument. The most important reason to use \code{control} is to decrease (or eliminate at best) the number of divergent transitions that cause a bias in the obtained posterior samples. Whenever you see the warning \code{"There were x divergent transitions after warmup."}, you should really think about increasing \code{adapt_delta}. To do this, write \code{control = list(adapt_delta = )}, where \code{} should usually be a value between \code{0.8} (current default) and \code{1}. Increasing \code{adapt_delta} will slow down the sampler but will decrease the number of divergent transitions threatening the validity of your posterior samples. + +Another problem arises when the depth of the tree being evaluated in each iteration is exceeded. This is less common than having divergent transitions, but may also bias the posterior samples. When it happens, \pkg{Stan} will throw out a warning suggesting to increase \code{max_treedepth}, which can be accomplished by writing \code{control = list(max_treedepth = )} with a positive integer \code{} that should usually be larger than the current default of \code{10}. + +\subsection{Analyzing the results} + +The example model \code{fit1} is fitted using 4 chains, each with 2000 iterations of which the first 1000 are warmup to calibrate the sampler, leading to a total of 4000 posterior samples\footnote{To save time, chains may also run in parallel when using argument \code{cluster}.}. For researchers familiar with Gibbs or Metropolis-Hastings sampling, this number may seem far too small to achieve good convergence and reasonable results, especially for multilevel models. However, as \pkg{brms} utilizes the NUTS sampler \citep{hoffman2014} implemented in \pkg{Stan}, even complex models can often be fitted with not more than a few thousand samples. Of course, every iteration is more computationally intensive and time-consuming than the iterations of other algorithms, but the quality of the samples (i.e., the effective sample size per iteration) is usually higher. + +After the posterior samples have been computed, the \code{brm} function returns an \proglang{R} object, containing (among others) the fully commented model code in \pkg{Stan} language, the data to fit the model, and the posterior samples themselves. The model code and data for the present example can be extracted through \code{stancode(fit1)} and \code{standata(fit1)} respectively\footnote{Both model code and data may be amended and used to fit new models. That way, \pkg{brms} can also serve as a good starting point in building more complicated models in \pkg{Stan}, directly.}. A model summary is readily available using + +\begin{Sinput} +R> summary(fit1, waic = TRUE) +\end{Sinput} +\begin{Soutput} + Family: lognormal (identity) +Formula: time | cens(censored) ~ age * sex + disease + (1 + age | patient) + Data: kidney (Number of observations: 76) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: 673.51 + +Group-Level Effects: +~patient (Number of levels: 38) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 0.40 0.28 0.01 1.01 1731 1 +sd(age) 0.01 0.01 0.00 0.02 1137 1 +cor(Intercept,age) -0.13 0.46 -0.88 0.76 3159 1 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept 2.73 0.96 0.82 4.68 2139 1 +age 0.01 0.02 -0.03 0.06 1614 1 +sexfemale 2.42 1.13 0.15 4.64 2065 1 +diseaseGN -0.40 0.53 -1.45 0.64 2664 1 +diseaseAN -0.52 0.50 -1.48 0.48 2713 1 +diseasePKD 0.60 0.74 -0.86 2.02 2968 1 +age:sexfemale -0.02 0.03 -0.07 0.03 1956 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sigma 1.15 0.13 0.91 1.44 4000 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Soutput} + +On the top of the output, some general information on the model is given, such as family, formula, number of iterations and chains, as well as the WAIC. Next, group-level effects are displayed separately for each grouping factor in terms of standard deviations and correlations between group-level effects. On the bottom of the output, population-level effects are displayed. If incorporated, autocorrelation and family specific parameters (e.g., the residual standard deviation \code{sigma}) are also given. + +In general, every parameter is summarized using the mean (\code{Estimate}) and the standard deviation (\code{Est.Error}) of the posterior distribution as well as two-sided 95\% Credible intervals (\code{l-95\% CI} and \code{u-95\% CI}) based on quantiles. +The \code{Eff.Sample} value is an estimation of the effective sample size; that is the number of independent samples from the posterior distribution that would be expected to yield the same standard error of the posterior mean as is obtained from the dependent samples returned by the MCMC algorithm. The \code{Rhat} value provides information on the convergence of the algorithm (cf., \citeauthor{gelman1992}, \citeyear{gelman1992}). If \code{Rhat} is considerably greater than 1 (i.e., $> 1.1$), the chains have not yet converged and it is necessary to run more iterations and/or set stronger priors. + +To visually investigate the chains as well as the posterior distribution, the \code{plot} method can be used (see Figure~\ref{kidney_plot}). An even more detailed investigation can be achieved by applying the \pkg{shinystan} package \citep{gabry2015} through method \code{launch_shiny}. With respect to the above summary, \code{sexfemale} seems to be the only population-level effect with considerable influence on the response. Because the mean of \code{sexfemale} is positive, the model predicts longer periods without an infection for females than for males. Effects of population-level predictors can also be visualized with the \code{conditional_effects} method (see Figure~\ref{kidney_conditional_effects}). + +\begin{figure}[ht] + \centering + \includegraphics[width=0.95\textwidth]{kidney_plot.pdf} + \caption{Trace and Density plots of all relevant parameters of the kidney model discussed in Section~\ref{software}.} + \label{kidney_plot} +\end{figure} + +\begin{figure}[ht] + \centering + \includegraphics[height=0.90\textheight]{kidney_conditional_effects.pdf} + \caption{Conditional effects plots of all population-level predictors of the kidney model discussed in Section~\ref{software}.} + \label{kidney_conditional_effects} +\end{figure} + +Looking at the group-level effects, the standard deviation parameter of \code{age} is suspiciously small. To test whether it is smaller than the standard deviation parameter of \code{Intercept}, we apply the \code{hypothesis} method: +\begin{Sinput} +R> hypothesis(fit1, "Intercept - age > 0", class = "sd", group = "patient") +\end{Sinput} +\begin{Soutput} +Hypothesis Tests for class sd_patient: + Estimate Est.Error l-95% CI u-95% CI Evid.Ratio +Intercept-age > 0 0.39 0.27 0.03 Inf 67.97 * +--- +'*': The expected value under the hypothesis lies outside the 95% CI. +\end{Soutput} +The one-sided 95\% credibility interval does not contain zero, thus indicating that the standard deviations differ from each other in the expected direction. In accordance with this finding, the \code{Evid.Ratio} shows that the hypothesis being tested (i.e., \code{Intercept - age > 0}) is about $68$ times more likely than the alternative hypothesis \code{Intercept - age < 0}. It is important to note that this kind of comparison is not easily possible when applying frequentist methods, because in this case only point estimates are available for group-level standard deviations and correlations. + +When looking at the correlation between both group-level effects, its distribution displayed in Figure~\ref{kidney_plot} and the 95\% credibility interval in the summary output appear to be rather wide. This indicates that there is not enough evidence in the data to reasonably estimate the correlation. Together, the small standard deviation of \code{age} and the uncertainty in the correlation raise the question if \code{age} should be modeled as a group specific term at all. To answer this question, we fit another model without this term: +\begin{Sinput} +R> fit2 <- update(fit1, formula. = ~ . - (1 + age|patient) + (1|patient)) +\end{Sinput} + +A good way to compare both models is leave-one-out cross-validation (LOO)\footnote{The WAIC is an approximation of LOO that is faster and easier to compute. However, according to \cite{vehtari2015}, LOO may be the preferred method to perform model comparisons.}, which can be called in \pkg{brms} using +\begin{Sinput} +R> LOO(fit1, fit2) +\end{Sinput} +\begin{Soutput} + LOOIC SE +fit1 675.45 45.18 +fit2 674.17 45.06 +fit1 - fit2 1.28 0.99 +\end{Soutput} +In the output, the LOO information criterion for each model as well as the difference of the LOOs each with its corresponding standard error is shown. Both LOO and WAIC are approximately normal if the number of observations is large so that the standard errors can be very helpful in evaluating differences in the information criteria. However, for small sample sizes, standard errors should be interpreted with care \citep{vehtari2015}. For the present example, it is immediately evident that both models have very similar fit, indicating that there is little benefit in adding group specific coefficients for \code{age}. + +\subsection{Modeling ordinal data} + +In the following, we want to briefly discuss a second example to demonstrate the capabilities of \pkg{brms} in handling ordinal data. \cite{ezzet1991} analyze data from a two-treatment, two-period crossover trial to compare 2 inhalation devices for delivering the drug salbutamol in 286 asthma patients. Patients were asked to rate the clarity of leaflet instructions accompanying each device, using a four-point ordinal scale. Ratings are predicted by \code{treat} to indicate which of the two inhaler devices was used, \code{period} to indicate the time of administration, and \code{carry} to model possible carry over effects. +\begin{Sinput} +R> data("inhaler") +R> head(inhaler, n = 1) +\end{Sinput} +\begin{Soutput} + subject rating treat period carry +1 1 1 0.5 0.5 0 +\end{Soutput} + +Typically, the ordinal response is assumed to originate from the categorization of a latent continuous variable. That is there are $K$ latent thresholds (model intercepts), which partition the continuous scale into the $K + 1$ observable, ordered categories. Following this approach leads to the cumulative or graded-response model \citep{samejima1969} for ordinal data implemented in many \proglang{R} packages. In \pkg{brms}, it is available via family \code{cumulative}. Fitting the cumulative model to the inhaler data, also incorporating an intercept varying by subjects, may look this: +\begin{Sinput} +fit3 <- brm(formula = rating ~ treat + period + carry + (1|subject), + data = inhaler, family = cumulative) +\end{Sinput} +While the support for ordinal data in most \proglang{R} packages ends here\footnote{Exceptions known to us are the packages \pkg{ordinal} \citep{christensen2015} and \pkg{VGAM} \citep{yee2010}. The former supports only cumulative models but with different modeling option for the thresholds. The latter supports all four ordinal families also implemented in \pkg{brms} as well as category specific effects but no group-specific effects.}, \pkg{brms} allows changes to this basic model in at least three ways. First of all, three additional ordinal families are implemented. Families \code{sratio} (stopping ratio) and \code{cratio} (continuation ratio) are so called sequential models \citep{tutz1990}. Both are equivalent to each other for symmetric link functions such as \code{logit} but will differ for asymmetric ones such as \code{cloglog}. The fourth ordinal family is \code{acat} (adjacent category) also known as partial credits model \citep{masters1982, andrich1978a}. Second, restrictions to the thresholds can be applied. By default, thresholds are ordered for family \code{cumulative} or are completely free to vary for the other families. This is indicated by argument \code{threshold = "flexible"} (default) in \code{brm}. Using \code{threshold = "equidistant"} forces the distance between two adjacent thresholds to be the same, that is +$$\tau_k = \tau_1 + (k-1)\delta$$ +for thresholds $\tau_k$ and distance $\delta$ (see also \citealp{andrich1978b}; \citealp{andrich1978a}; \citealp{andersen1977}). +Third, the assumption that predictors have constant effects across categories may be relaxed for non-cumulative ordinal models \citep{vanderark2001, tutz2000} leading to category specific effects. For instance, variable \code{treat} may +only have an impact on the decision between category 3 and 4, but not on the lower categories. Without using category specific effects, such a pattern would remain invisible. + +To illustrate all three modeling options at once, we fit a (hardly theoretically justified) stopping ratio model with equidistant thresholds and category specific effects for variable \code{treat} on which we apply an informative prior. +\begin{Sinput} +fit4 <- brm(formula = rating ~ period + carry + cs(treat) + (1|subject), + data = inhaler, family = sratio, threshold = "equidistant", + prior = set_prior("normal(-1,2)", coef = "treat")) +\end{Sinput} +Note that priors are defined on category specific effects in the same way as for other population-level effects. A model summary can be obtained in the same way as before: +\begin{Sinput} +R> summary(fit4, waic = TRUE) +\end{Sinput} +\begin{Soutput} + Family: sratio (logit) +Formula: rating ~ period + carry + cs(treat) + (1 | subject) + Data: inhaler (Number of observations: 572) +Samples: 4 chains, each with iter = 2000; warmup = 1000; thin = 1; + total post-warmup samples = 4000 + WAIC: 911.9 + +Group-Level Effects: +~subject (Number of levels: 286) + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +sd(Intercept) 1.05 0.23 0.56 1.5 648 1 + +Population-Level Effects: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +Intercept[1] 0.72 0.13 0.48 0.99 2048 1 +Intercept[2] 2.67 0.35 2.00 3.39 969 1 +Intercept[3] 4.62 0.66 3.36 5.95 1037 1 +period 0.25 0.18 -0.09 0.61 4000 1 +carry -0.26 0.22 -0.70 0.17 1874 1 +treat[1] -0.96 0.30 -1.56 -0.40 1385 1 +treat[2] -0.65 0.49 -1.60 0.27 4000 1 +treat[3] -2.65 1.21 -5.00 -0.29 4000 1 + +Family Specific Parameters: + Estimate Est.Error l-95% CI u-95% CI Eff.Sample Rhat +delta 1.95 0.32 1.33 2.6 1181 1 + +Samples were drawn using sampling(NUTS). For each parameter, Eff.Sample +is a crude measure of effective sample size, and Rhat is the potential +scale reduction factor on split chains (at convergence, Rhat = 1). +\end{Soutput} +Trace and density plots of the model parameters as produced by \code{plot(fit4)} can be found in Figure~\ref{inhaler_plot}. We see that three intercepts (thresholds) and three effects of \code{treat} have been estimated, because a four-point scale was used for the ratings. The treatment effect seems to be strongest between category 3 and 4. At the same time, however, the credible interval is also much larger. In fact, the intervals of all three effects of \code{treat} are highly overlapping, which indicates that there is not enough evidence in the data to support category specific effects. On the bottom of the output, parameter \code{delta} specifies the distance between two adjacent thresholds and indeed the intercepts differ from each other by the magnitude of \code{delta}. + +\begin{figure}[ht] + \centering + \includegraphics[width=0.95\textwidth]{inhaler_plot.pdf} + \caption{Trace and Density plots of all relevant parameters of the inhaler model discussed in Section~\ref{software}.} + \label{inhaler_plot} +\end{figure} + + +\section[Comparison]{Comparison between packages} + +Over the years, many \proglang{R} packages have been developed that implement MLMs, each being more or less general in their supported models. Comparing all of them to \pkg{brms} would be too extensive and barely helpful for the purpose of the present paper. Accordingly, we concentrate on a comparison with four packages. These are \pkg{lme4} \citep{bates2015} and \pkg{MCMCglmm} \citep{hadfield2010}, which are possibly the most general and widely applied \proglang{R} packages for MLMs, as well as \pkg{rstanarm} \citep{rstanarm2016} and \pkg{rethinking} \citep{mcelreath2016}, which are both based on \pkg{Stan}. As opposed to the other packages, \pkg{rethinking} was primarily written for teaching purposes and requires the user to specify the full model explicitly using its own simplified \pkg{BUGS}-like syntax thus helping users to better understand the models that are fitted to their data. + +Regarding model families, all five packages support the most common types such as linear and binomial models as well as Poisson models for count data. Currently, \pkg{brms} and \pkg{MCMCglmm} provide more flexibility when modeling categorical and ordinal data. In addition, \pkg{brms} supports robust linear regression using Student's distribution, which is also implemented on a GitHub branch of \pkg{rstanarm}. \pkg{MCMCglmm} allows fitting multinomial models that are currently not available in the other packages. + +Generalizing classical MLMs, \pkg{brms} and \pkg{MCMCglmm} allow fiting zero-inflated and hurdle models dealing with excess zeros in the response. Furthermore, \pkg{brms} supports non-linear models similar to the \pkg{nlme} package \citep{nlme2016} providing great flexibility but also requiring more care to produce reasonable results. Another flexible model class are generalized additive mixed models \citep{hastie1990,wood2011,zuur2014}, which can be fitted with \pkg{brms} and \pkg{rstanarm}. + +In all five packages, there are quite a few additional modeling options. Variable link functions can be specified in all packages except for \pkg{MCMCglmm}, in which only one link is available per family. \pkg{MCMCglmm} generally supports multivariate responses using data in wide format, whereas \pkg{brms} currently only offers this option for families \code{gaussian} and \code{student}. It should be noted that it is always possible to transform data from wide to long format for compatibility with the other packages. Autocorrelation of the response can only be fitted in \pkg{brms}, which supports auto-regressive as well as moving-average effects. For ordinal models in \pkg{brms}, effects of predictors may vary across different levels of the response as explained in the inhaler example. A feature currently exclusive to \pkg{rethinking} is the possibility to impute missing values in the predictor variables. + +Information criteria are available in all three packages. The advantage of WAIC and LOO implemented in \pkg{brms}, \pkg{rstanarm}, and \pkg{rethinking} is that their standard errors can be easily estimated to get a better sense of the uncertainty in the criteria. Comparing the prior options of the Bayesian packages, \pkg{brms} and \pkg{rethinking} offer a little more flexibility than \pkg{MCMCglmm} and \pkg{rstanarm}, as virtually any prior distribution can be applied on population-level effects as well as on the standard deviations of group-level effects. In addition, we believe that the way priors are specified in \pkg{brms} and \pkg{rethinking} is more intuitive as it is directly evident what prior is actually applied. A more detailed comparison of the packages can be found in Table~\ref{comparison1} and Table~\ref{comparison2}. To facilitate the understanding of the model formulation in \pkg{brms}, Table~\ref{syntax} shows \pkg{lme4} function calls to fit sample models along with the equivalent \pkg{brms} syntax. + +So far the focus was only on capabilities. Another important topic is speed, especially for more complex models. Of course, \pkg{lme4} is usually much faster than the other packages as it uses maximum likelihood methods instead of MCMC algorithms, which are slower by design. To compare the efficiency of the four Bayesian packages, we fitted multilevel models on real data sets using the minimum effective sample size divided by sampling time as a measure of sampling efficiency. One should always aim at running multiple chains as one cannot be sure that a single chain really explores the whole posterior distribution. However, as \pkg{MCMCglmm} does not come with a built-in option to run multiple chains, we used only a single chain to fit the models after making sure that it leads to the same results as multiple chains. The \proglang{R} code allowing to replicate the results is available as supplemental material. + +The first thing that becomes obvious when fitting the models is that \pkg{brms} and \pkg{rethinking} need to compile the \proglang{C++} model before actually fitting it, because the \pkg{Stan} code being parsed to \proglang{C++} is generated on the fly based on the user's input. Compilation takes about a half to one minute depending on the model complexity and computing power of the machine. This is not required by \pkg{rstanarm} and \pkg{MCMCglmm}, although the former is also based on \pkg{Stan}, as compilation takes place only once at installation time. While the latter approach saves the compilation time, the former is more flexible when it comes to model specification. For small and simple models, compilation time dominates the overall computation time, but for larger and more complex models, sampling will take several minutes or hours so that one minute more or less will not really matter, anymore. Accordingly, the following comparisons do not include the compilation time. + +In models containing only group-specific intercepts, \pkg{MCMCglmm} is usually more efficient than the \pkg{Stan} packages. However, when also estimating group-specific slopes, \pkg{MCMCglmm} falls behind the other packages and quite often refuses to sample at all unless one carefully specifies informative priors. Note that these results are obtained by running only a single chain. For all three \pkg{Stan} packages, sampling efficiency can easily be increased by running multiple chains in parallel. Comparing the \pkg{Stan} packages to each other, \pkg{brms} is usually most efficient for models with group-specific terms, whereas \pkg{rstanarm} tends to be roughly $50\%$ to $75\%$ as efficient at least for the analyzed data sets. The efficiency of \pkg{rethinking} is more variable depending on the model formulation and data, sometimes being slightly ahead of the other two packages, but usually being considerably less efficient. Generally, \pkg{rethinking} loses efficiency for models with many population-level effects presumably because one cannot use design matrices and vectorized prior specifications for population-level parameters. Note that it was not possible to specify the exact same priors across packages due to varying parameterizations. Of course, efficiency depends heavily on the model, chosen priors, and data at hand so that the present results should not be over-interpreted. + +\begin{table}[hbtp] +\centering +\begin{tabular}{llll} + & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{lme4}} & \parbox{2cm}{\pkg{MCMCglmm}} \\ \hline +\\ [-1.5ex] +\parbox{6cm}{Supported model types:} & & & \\ [1ex] +Linear models & yes & yes & yes \\ +Robust linear models & yes & no & no \\ +Binomial models & yes & yes & yes \\ +Categorical models & yes & no & yes \\ +Multinomial models & no & no & yes \\ +Count data models & yes & yes & yes \\ +Survival models & yes$^1$ & yes & yes \\ +Ordinal models & various & no & cumulative \\ +Zero-inflated and hurdle models & yes & no & yes \\ +Generalized additive models & yes & no & no \\ +Non-linear models & yes & no & no \\ \hline +\\ [-1.5ex] +\parbox{5cm}{Additional modeling options:} & & & \\ [1ex] +Variable link functions & various & various & no \\ +Weights & yes & yes & no \\ +Offset & yes & yes & using priors \\ +Multivariate responses & limited & no & yes \\ +Autocorrelation effects & yes & no & no \\ +Category specific effects & yes & no & no \\ +Standard errors for meta-analysis & yes & no & yes \\ +Censored data & yes & no & yes \\ +Truncated data & yes & no & no \\ +Customized covariances & yes & no & yes \\ +Missing value imputation & no & no & no \\ \hline +\\ [-1.5ex] +Bayesian specifics: & & & \\ [1ex] +parallelization & yes & -- & no \\ +population-level priors & flexible & --$^3$ & normal \\ +group-level priors & normal & --$^3$ & normal \\ +covariance priors & flexible & --$^3$ & restricted$^4$ \\ \hline +\\ [-1.5ex] +Other: & & & \\ [1ex] +Estimator & HMC, NUTS & ML, REML & MH, Gibbs$^2$ \\ +Information criterion & WAIC, LOO & AIC, BIC & DIC \\ +\proglang{C++} compiler required & yes & no & no \\ +Modularized & no & yes & no \\ \hline +\end{tabular} +\caption{Comparison of the capabilities of the \pkg{brms}, \pkg{lme4} and \pkg{MCMCglmm} package. Notes: (1) Weibull family only available in \pkg{brms}. (2) Estimator consists of a combination of both algorithms. (3) Priors may be imposed using the \pkg{blme} package \citep{chung2013}. (4) For details see \cite{hadfield2010}.} +\label{comparison1} +\end{table} + + +\begin{table}[hbtp] +\centering +\begin{tabular}{llll} + & \parbox{2cm}{\pkg{brms}} & \parbox{2cm}{\pkg{rstanarm}} & \parbox{2cm}{\pkg{rethinking}} \\ \hline +\\ [-1.5ex] +\parbox{6cm}{Supported model types:} & & & \\ [1ex] +Linear models & yes & yes & yes \\ +Robust linear models & yes & yes$^1$ & no \\ +Binomial models & yes & yes & yes \\ +Categorical models & yes & no & no \\ +Multinomial models & no & no & no \\ +Count data models & yes & yes & yes \\ +Survival models & yes$^2$ & yes & yes \\ +Ordinal models & various & cumulative$^3$ & no \\ +Zero-inflated and hurdle models & yes & no & no \\ +Generalized additive models & yes & yes & no \\ +Non-linear models & yes & no & limited$^4$ \\ \hline +\\ [-1.5ex] +\parbox{5cm}{Additional modeling options:} & & & \\ [1ex] +Variable link functions & various & various & various \\ +Weights & yes & yes & no \\ +Offset & yes & yes & yes \\ +Multivariate responses & limited & no & no \\ +Autocorrelation effects & yes & no & no \\ +Category specific effects & yes & no & no \\ +Standard errors for meta-analysis & yes & no & no \\ +Censored data & yes & no & no \\ +Truncated data & yes & no & yes \\ +Customized covariances & yes & no & no \\ +Missing value imputation & no & no & yes \\ \hline +\\ [-1.5ex] +Bayesian specifics: & & & \\ [1ex] +parallelization & yes & yes & yes \\ +population-level priors & flexible & normal, Student-t & flexible \\ +group-level priors & normal & normal & normal \\ +covariance priors & flexible & restricted$^5$ & flexible \\ \hline +\\ [-1.5ex] +Other: & & & \\ [1ex] +Estimator & HMC, NUTS & HMC, NUTS & HMC, NUTS \\ +Information criterion & WAIC, LOO & AIC, LOO & AIC, LOO \\ +\proglang{C++} compiler required & yes & no & yes \\ +Modularized & no & no & no \\ \hline +\end{tabular} +\caption{Comparison of the capabilities of the \pkg{brms}, \pkg{rstanarm} and \pkg{rethinking} package. Notes: (1) Currently only implemented on a branch on GitHub. (2) Weibull family only available in \pkg{brms}. (3) No group-level terms allowed. (4) The parser is mainly written for linear models but also accepts some non-linear model specifications. (5) For details see \url{https://github.com/stan-dev/rstanarm/wiki/Prior-distributions}.} +\label{comparison2} +\end{table} + + +\begin{table}[hbtp] +\centering +%\renewcommand{\arraystretch}{2} +\begin{tabular}{ll} + Dataset & \parbox{10cm}{Function call} \\ \hline +\\ [-1.5ex] +\parbox{2cm}{cake} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{lmer(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{5ex} data = cake)}} \\ [3ex] +\pkg{brms} & \parbox{13cm}{\code{brm(angle $\sim$ recipe * temperature + (1|recipe:replicate), \\ \hspace*{4ex} data = cake)}} \\ [2ex] \hline +\\ [-1.5ex] +\parbox{2cm}{sleepstudy} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{lmer(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [1.5ex] +\pkg{brms} & \parbox{13cm}{\code{brm(Reaction $\sim$ Days + (Days|Subject), data = sleepstudy)}} \\ [2ex] \hline +\\ [-1.5ex] +\parbox{2cm}{cbpp$^1$} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{glmer(cbind(incidence, size - incidence) $\sim$ period + (1 | herd), \\ \hspace*{6ex} family = binomial("logit"), data = cbpp)}} \\ [3ex] +\pkg{brms} & \parbox{13cm}{\code{brm(incidence | trials(size) $\sim$ period + (1 | herd), \\ \hspace*{4ex} family = binomial("logit"), data = cbpp)}} \\ [2ex] \hline +\\ [-1.5ex] +\parbox{2cm}{grouseticks$^1$} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{glmer(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{6ex} family = poisson("log"), data = grouseticks)}} \\ [3ex] +\pkg{brms} & \parbox{13cm}{\code{brm(TICKS $\sim$ YEAR + HEIGHT + (1|BROOD) + (1|LOCATION), \\ \hspace*{4ex} family = poisson("log"), data = grouseticks)}} \\ [2ex] \hline +\\ [-1ex] +\parbox{2cm}{VerbAgg$^2$} & \\ [1ex] +\pkg{lme4} & \parbox{13cm}{\code{glmer(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{6ex} + (1|item), family = binomial, data = VerbAgg)}} \\ [3ex] +\pkg{brms} & \parbox{13cm}{\code{brm(r2 $\sim$ (Anger + Gender + btype + situ)\^{}2 + (1|id) \\ \hspace*{4ex} + (1|item), family = bernoulli, data = VerbAgg)}} \\ [2ex] \hline +\\ [-1.5ex] +\end{tabular} +\caption{Comparison of the model syntax of \pkg{lme4} and \pkg{brms} using data sets included in \pkg{lme4}. Notes: (1) Default links are used to that the link argument may be omitted. (2) Fitting this model takes some time. A proper prior on the population-level effects (e.g., \code{prior = set\_prior("normal(0,5)")}) may help in increasing sampling speed.} +\label{syntax} +\end{table} + +\section{Conclusion} +The present paper is meant to provide a general overview on the \proglang{R} package \pkg{brms} implementing MLMs using the probabilistic programming language \pkg{Stan} for full Bayesian inference. Although only a small selection of the modeling options available in \pkg{brms} are discussed in detail, I hope that this article can serve as a good starting point to further explore the capabilities of the package. + +For the future, I have several plans on how to improve the functionality of \pkg{brms}. I want to include multivariate models that can handle multiple response variables coming from different distributions as well as new correlation structures for instance for spatial data. Similarily, distributional regression models as well as mixture response distributions appear to be valuable extensions of the package. I am always grateful for any suggestions and ideas regarding new features. + +\section*{Acknowledgments} + +First of all, I would like to thank the Stan Development Team for creating the probabilistic programming language \pkg{Stan}, which is an incredibly powerful and flexible tool for performing full Bayesian inference. Without it, \pkg{brms} could not fit a single model. Two anonymous reviewers provided very detailed and thoughtful suggestions to substantially improve both the package and the paper. Furthermore, Prof. Philipp Doebler and Prof. Heinz Holling have given valuable feedback on earlier versions of the paper. Lastly, I want to thank the many users who reported bugs or had ideas for new features, thus helping to continuously improve \pkg{brms}. + +\bibliography{citations_overview} + +\end{document} diff -Nru r-cran-brms-2.16.3/vignettes/brms_phylogenetics.Rmd r-cran-brms-2.17.0/vignettes/brms_phylogenetics.Rmd --- r-cran-brms-2.16.3/vignettes/brms_phylogenetics.Rmd 2021-02-10 15:31:41.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_phylogenetics.Rmd 2022-04-11 07:21:34.000000000 +0000 @@ -1,365 +1,365 @@ ---- -title: "Estimating Phylogenetic Multilevel Models with brms" -author: "Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Estimating Phylogenetic Multilevel Models with brms} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(brms) -ggplot2::theme_set(theme_default()) -``` - -## Introduction - -In the present vignette, we want to discuss how to specify phylogenetic -multilevel models using **brms**. These models are relevant in evolutionary -biology when data of many species are analyzed at the same time. The usual -approach would be to model species as a grouping factor in a multilevel model -and estimate varying intercepts (and possibly also varying slopes) over species. -However, species are not independent as they come from the same phylogenetic -tree and we thus have to adjust our model to incorporate this dependency. The -examples discussed here are from chapter 11 of the book *Modern Phylogenetic -Comparative Methods and the application in Evolutionary Biology* (de Villemeruil -& Nakagawa, 2014). The necessary data can be downloaded from the corresponding -website (http://www.mpcm-evolution.com/). Some of these models may take a few -minutes to fit. - -## A Simple Phylogenetic Model - -Assume we have measurements of a phenotype, `phen` (say the body size), and a -`cofactor` variable (say the temperature of the environment). We prepare the -data using the following code. - -```{r} -phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") -data_simple <- read.table( - "https://paul-buerkner.github.io/data/data_simple.txt", - header = TRUE -) -head(data_simple) -``` - -The `phylo` object contains information on the relationship between species. -Using this information, we can construct a covariance matrix of species -(Hadfield & Nakagawa, 2010). - -```{r} -A <- ape::vcv.phylo(phylo) -``` - -Now we are ready to fit our first phylogenetic multilevel model: - -```{r, results='hide'} -model_simple <- brm( - phen ~ cofactor + (1|gr(phylo, cov = A)), - data = data_simple, - family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0, 10), "b"), - prior(normal(0, 50), "Intercept"), - prior(student_t(3, 0, 20), "sd"), - prior(student_t(3, 0, 20), "sigma") - ) -) -``` - -With the exception of `(1|gr(phylo, cov = A))` instead of `(1|phylo)` this is a -basic multilevel model with a varying intercept over species (`phylo` is an -indicator of species in this data set). However, by using `cov = A` in the `gr` -function, we make sure that species are correlated as specified by the -covariance matrix `A`. We pass `A` itself via the `data2` argument which can be -used for any kinds of data that does not fit into the regular structure of the -`data` argument. Setting priors is not required for achieving good convergence -for this model, but it improves sampling speed a bit. After fitting, the results -can be investigated in detail. - -```{r} -summary(model_simple) -plot(model_simple, N = 2, ask = FALSE) -plot(conditional_effects(model_simple), points = TRUE) -``` - -The so called phylogenetic signal (often symbolize by $\lambda$) can be computed -with the `hypothesis` method and is roughly $\lambda = 0.7$ for this example. - -```{r} -hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" -(hyp <- hypothesis(model_simple, hyp, class = NULL)) -plot(hyp) -``` - -Note that the phylogenetic signal is just a synonym of the intra-class -correlation (ICC) used in the context phylogenetic analysis. - - -## A Phylogenetic Model with Repeated Measurements - -Often, we have multiple observations per species and this allows to fit more -complicated phylogenetic models. - -```{r} -data_repeat <- read.table( - "https://paul-buerkner.github.io/data/data_repeat.txt", - header = TRUE -) -data_repeat$spec_mean_cf <- - with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) -head(data_repeat) -``` - -The variable `spec_mean_cf` just contains the mean of the cofactor for each -species. The code for the repeated measurement phylogenetic model looks as -follows: - -```{r, results='hide'} -model_repeat1 <- brm( - phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), - data = data_repeat, - family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0,10), "b"), - prior(normal(0,50), "Intercept"), - prior(student_t(3,0,20), "sd"), - prior(student_t(3,0,20), "sigma") - ), - sample_prior = TRUE, chains = 2, cores = 2, - iter = 4000, warmup = 1000 -) -``` - -The variables `phylo` and `species` are identical as they are both identifiers -of the species. However, we model the phylogenetic covariance only for `phylo` -and thus the `species` variable accounts for any specific effect that would be -independent of the phylogenetic relationship between species (e.g., -environmental or niche effects). Again we can obtain model summaries as well as -estimates of the phylogenetic signal. - -```{r} -summary(model_repeat1) -``` - -```{r} -hyp <- paste( - "sd_phylo__Intercept^2 /", - "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" -) -(hyp <- hypothesis(model_repeat1, hyp, class = NULL)) -plot(hyp) -``` - -So far, we have completely ignored the variability of the cofactor within -species. To incorporate this into the model, we define - -```{r} -data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf -``` - -and then fit it again using `within_spec_cf` as an additional predictor. - -```{r, results='hide'} -model_repeat2 <- update( - model_repeat1, formula = ~ . + within_spec_cf, - newdata = data_repeat, chains = 2, cores = 2, - iter = 4000, warmup = 1000 -) -``` - -The results are almost unchanged, with apparently no relationship between the -phenotype and the within species variance of `cofactor`. - -```{r} -summary(model_repeat2) -``` - -Also, the phylogenetic signal remains more or less the same. - -```{r} -hyp <- paste( - "sd_phylo__Intercept^2 /", - "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" -) -(hyp <- hypothesis(model_repeat2, hyp, class = NULL)) -``` - - -## A Phylogenetic Meta-Analysis - -Let's say we have Fisher's z-transformed correlation coefficients $Zr$ per -species along with corresponding sample sizes (e.g., correlations between male -coloration and reproductive success): - -```{r} -data_fisher <- read.table( - "https://paul-buerkner.github.io/data/data_effect.txt", - header = TRUE -) -data_fisher$obs <- 1:nrow(data_fisher) -head(data_fisher) -``` - -We assume the sampling variance to be known and as $V(Zr) = \frac{1}{N - 3}$ for -Fisher's values, where $N$ is the sample size per species. Incorporating the -known sampling variance into the model is straight forward. One has to keep in -mind though, that **brms** requires the sampling standard deviation (square root -of the variance) as input instead of the variance itself. The group-level effect -of `obs` represents the residual variance, which we have to model explicitly in -a meta-analytic model. - -```{r, results='hide'} -model_fisher <- brm( - Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), - data = data_fisher, family = gaussian(), - data2 = list(A = A), - prior = c( - prior(normal(0, 10), "Intercept"), - prior(student_t(3, 0, 10), "sd") - ), - control = list(adapt_delta = 0.95), - chains = 2, cores = 2, iter = 4000, warmup = 1000 -) -``` - -A summary of the fitted model is obtained via - -```{r} -summary(model_fisher) -plot(model_fisher) -``` - -The meta-analytic mean (i.e., the model intercept) is $0.16$ with a credible -interval of $[0.08, 0.25]$. Thus the mean correlation across species is positive -according to the model. - - -## A phylogenetic count-data model - -Suppose that we analyze a phenotype that consists of counts instead of being a -continuous variable. In such a case, the normality assumption will likely not be -justified and it is recommended to use a distribution explicitly suited for -count data, for instance the Poisson distribution. The following data set (again -retrieved from mpcm-evolution.org) provides an example. - -```{r} -data_pois <- read.table( - "https://paul-buerkner.github.io/data/data_pois.txt", - header = TRUE -) -data_pois$obs <- 1:nrow(data_pois) -head(data_pois) -``` - -As the Poisson distribution does not have a natural overdispersion parameter, we -model the residual variance via the group-level effects of `obs` (e.g., see -Lawless, 1987). - -```{r, results='hide'} -model_pois <- brm( - phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), - data = data_pois, family = poisson("log"), - data2 = list(A = A), - chains = 2, cores = 2, iter = 4000, - control = list(adapt_delta = 0.95) -) -``` - -Again, we obtain a summary of the fitted model via - -```{r} -summary(model_pois) -plot(conditional_effects(model_pois), points = TRUE) -``` - -Now, assume we ignore the fact that the phenotype is count data and fit a linear -normal model instead. - -```{r, results='hide'} -model_normal <- brm( - phen_pois ~ cofactor + (1|gr(phylo, cov = A)), - data = data_pois, family = gaussian(), - data2 = list(A = A), - chains = 2, cores = 2, iter = 4000, - control = list(adapt_delta = 0.95) -) -``` - -```{r} -summary(model_normal) -``` - -We see that `cofactor` has a positive relationship with the phenotype in both -models. One should keep in mind, though, that the estimates of the Poisson model -are on the log-scale, as we applied the canonical log-link function in this -example. Therefore, estimates are not comparable to a linear normal model even -if applied to the same data. What we can compare, however, is the model fit, for -instance graphically via posterior predictive checks. - -```{r} -pp_check(model_pois) -pp_check(model_normal) -``` - -Apparently, the distribution of the phenotype predicted by the Poisson model -resembles the original distribution of the phenotype pretty closely, while the -normal models fails to do so. We can also apply leave-one-out cross-validation -for direct numerical comparison of model fit. - -```{r} -loo(model_pois, model_normal) -``` - -Since smaller values of loo indicate better fit, it is again evident that the -Poisson model fits the data better than the normal model. Of course, the Poisson -model is not the only reasonable option here. For instance, you could use a -negative binomial model (via family `negative_binomial`), which already contains -an overdispersion parameter so that modeling a varying intercept of `obs` -becomes obsolete. - -## Phylogenetic models with multiple group-level effects - -In the above examples, we have only used a single group-level effect (i.e., a -varying intercept) for the phylogenetic grouping factors. In **brms**, it is -also possible to estimate multiple group-level effects (e.g., a varying -intercept and a varying slope) for these grouping factors. However, it requires -repeatedly computing Kronecker products of covariance matrices while fitting the -model. This will be very slow especially when the grouping factors have many -levels and matrices are thus large. - -## References - -de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for -comparative biology. In: -*Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice* -(ed. Garamszegi L.) Springer, New York. pp. 287-303. - -Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for -comparative biology: phylogenies, taxonomies, and multi-trait models for -continuous and categorical characters. *Journal of Evolutionary Biology*. 23. -494-508. - -Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. -*Canadian Journal of Statistics*, 15(3), 209-225. +--- +title: "Estimating Phylogenetic Multilevel Models with brms" +author: "Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Estimating Phylogenetic Multilevel Models with brms} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(brms) +ggplot2::theme_set(theme_default()) +``` + +## Introduction + +In the present vignette, we want to discuss how to specify phylogenetic +multilevel models using **brms**. These models are relevant in evolutionary +biology when data of many species are analyzed at the same time. The usual +approach would be to model species as a grouping factor in a multilevel model +and estimate varying intercepts (and possibly also varying slopes) over species. +However, species are not independent as they come from the same phylogenetic +tree and we thus have to adjust our model to incorporate this dependency. The +examples discussed here are from chapter 11 of the book *Modern Phylogenetic +Comparative Methods and the application in Evolutionary Biology* (de Villemeruil +& Nakagawa, 2014). The necessary data can be downloaded from the corresponding +website (https://www.mpcm-evolution.com/). Some of these models may take a few +minutes to fit. + +## A Simple Phylogenetic Model + +Assume we have measurements of a phenotype, `phen` (say the body size), and a +`cofactor` variable (say the temperature of the environment). We prepare the +data using the following code. + +```{r} +phylo <- ape::read.nexus("https://paul-buerkner.github.io/data/phylo.nex") +data_simple <- read.table( + "https://paul-buerkner.github.io/data/data_simple.txt", + header = TRUE +) +head(data_simple) +``` + +The `phylo` object contains information on the relationship between species. +Using this information, we can construct a covariance matrix of species +(Hadfield & Nakagawa, 2010). + +```{r} +A <- ape::vcv.phylo(phylo) +``` + +Now we are ready to fit our first phylogenetic multilevel model: + +```{r, results='hide'} +model_simple <- brm( + phen ~ cofactor + (1|gr(phylo, cov = A)), + data = data_simple, + family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0, 10), "b"), + prior(normal(0, 50), "Intercept"), + prior(student_t(3, 0, 20), "sd"), + prior(student_t(3, 0, 20), "sigma") + ) +) +``` + +With the exception of `(1|gr(phylo, cov = A))` instead of `(1|phylo)` this is a +basic multilevel model with a varying intercept over species (`phylo` is an +indicator of species in this data set). However, by using `cov = A` in the `gr` +function, we make sure that species are correlated as specified by the +covariance matrix `A`. We pass `A` itself via the `data2` argument which can be +used for any kinds of data that does not fit into the regular structure of the +`data` argument. Setting priors is not required for achieving good convergence +for this model, but it improves sampling speed a bit. After fitting, the results +can be investigated in detail. + +```{r} +summary(model_simple) +plot(model_simple, N = 2, ask = FALSE) +plot(conditional_effects(model_simple), points = TRUE) +``` + +The so called phylogenetic signal (often symbolize by $\lambda$) can be computed +with the `hypothesis` method and is roughly $\lambda = 0.7$ for this example. + +```{r} +hyp <- "sd_phylo__Intercept^2 / (sd_phylo__Intercept^2 + sigma^2) = 0" +(hyp <- hypothesis(model_simple, hyp, class = NULL)) +plot(hyp) +``` + +Note that the phylogenetic signal is just a synonym of the intra-class +correlation (ICC) used in the context phylogenetic analysis. + + +## A Phylogenetic Model with Repeated Measurements + +Often, we have multiple observations per species and this allows to fit more +complicated phylogenetic models. + +```{r} +data_repeat <- read.table( + "https://paul-buerkner.github.io/data/data_repeat.txt", + header = TRUE +) +data_repeat$spec_mean_cf <- + with(data_repeat, sapply(split(cofactor, phylo), mean)[phylo]) +head(data_repeat) +``` + +The variable `spec_mean_cf` just contains the mean of the cofactor for each +species. The code for the repeated measurement phylogenetic model looks as +follows: + +```{r, results='hide'} +model_repeat1 <- brm( + phen ~ spec_mean_cf + (1|gr(phylo, cov = A)) + (1|species), + data = data_repeat, + family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0,10), "b"), + prior(normal(0,50), "Intercept"), + prior(student_t(3,0,20), "sd"), + prior(student_t(3,0,20), "sigma") + ), + sample_prior = TRUE, chains = 2, cores = 2, + iter = 4000, warmup = 1000 +) +``` + +The variables `phylo` and `species` are identical as they are both identifiers +of the species. However, we model the phylogenetic covariance only for `phylo` +and thus the `species` variable accounts for any specific effect that would be +independent of the phylogenetic relationship between species (e.g., +environmental or niche effects). Again we can obtain model summaries as well as +estimates of the phylogenetic signal. + +```{r} +summary(model_repeat1) +``` + +```{r} +hyp <- paste( + "sd_phylo__Intercept^2 /", + "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" +) +(hyp <- hypothesis(model_repeat1, hyp, class = NULL)) +plot(hyp) +``` + +So far, we have completely ignored the variability of the cofactor within +species. To incorporate this into the model, we define + +```{r} +data_repeat$within_spec_cf <- data_repeat$cofactor - data_repeat$spec_mean_cf +``` + +and then fit it again using `within_spec_cf` as an additional predictor. + +```{r, results='hide'} +model_repeat2 <- update( + model_repeat1, formula = ~ . + within_spec_cf, + newdata = data_repeat, chains = 2, cores = 2, + iter = 4000, warmup = 1000 +) +``` + +The results are almost unchanged, with apparently no relationship between the +phenotype and the within species variance of `cofactor`. + +```{r} +summary(model_repeat2) +``` + +Also, the phylogenetic signal remains more or less the same. + +```{r} +hyp <- paste( + "sd_phylo__Intercept^2 /", + "(sd_phylo__Intercept^2 + sd_species__Intercept^2 + sigma^2) = 0" +) +(hyp <- hypothesis(model_repeat2, hyp, class = NULL)) +``` + + +## A Phylogenetic Meta-Analysis + +Let's say we have Fisher's z-transformed correlation coefficients $Zr$ per +species along with corresponding sample sizes (e.g., correlations between male +coloration and reproductive success): + +```{r} +data_fisher <- read.table( + "https://paul-buerkner.github.io/data/data_effect.txt", + header = TRUE +) +data_fisher$obs <- 1:nrow(data_fisher) +head(data_fisher) +``` + +We assume the sampling variance to be known and as $V(Zr) = \frac{1}{N - 3}$ for +Fisher's values, where $N$ is the sample size per species. Incorporating the +known sampling variance into the model is straight forward. One has to keep in +mind though, that **brms** requires the sampling standard deviation (square root +of the variance) as input instead of the variance itself. The group-level effect +of `obs` represents the residual variance, which we have to model explicitly in +a meta-analytic model. + +```{r, results='hide'} +model_fisher <- brm( + Zr | se(sqrt(1 / (N - 3))) ~ 1 + (1|gr(phylo, cov = A)) + (1|obs), + data = data_fisher, family = gaussian(), + data2 = list(A = A), + prior = c( + prior(normal(0, 10), "Intercept"), + prior(student_t(3, 0, 10), "sd") + ), + control = list(adapt_delta = 0.95), + chains = 2, cores = 2, iter = 4000, warmup = 1000 +) +``` + +A summary of the fitted model is obtained via + +```{r} +summary(model_fisher) +plot(model_fisher) +``` + +The meta-analytic mean (i.e., the model intercept) is $0.16$ with a credible +interval of $[0.08, 0.25]$. Thus the mean correlation across species is positive +according to the model. + + +## A phylogenetic count-data model + +Suppose that we analyze a phenotype that consists of counts instead of being a +continuous variable. In such a case, the normality assumption will likely not be +justified and it is recommended to use a distribution explicitly suited for +count data, for instance the Poisson distribution. The following data set (again +retrieved from mpcm-evolution.org) provides an example. + +```{r} +data_pois <- read.table( + "https://paul-buerkner.github.io/data/data_pois.txt", + header = TRUE +) +data_pois$obs <- 1:nrow(data_pois) +head(data_pois) +``` + +As the Poisson distribution does not have a natural overdispersion parameter, we +model the residual variance via the group-level effects of `obs` (e.g., see +Lawless, 1987). + +```{r, results='hide'} +model_pois <- brm( + phen_pois ~ cofactor + (1|gr(phylo, cov = A)) + (1|obs), + data = data_pois, family = poisson("log"), + data2 = list(A = A), + chains = 2, cores = 2, iter = 4000, + control = list(adapt_delta = 0.95) +) +``` + +Again, we obtain a summary of the fitted model via + +```{r} +summary(model_pois) +plot(conditional_effects(model_pois), points = TRUE) +``` + +Now, assume we ignore the fact that the phenotype is count data and fit a linear +normal model instead. + +```{r, results='hide'} +model_normal <- brm( + phen_pois ~ cofactor + (1|gr(phylo, cov = A)), + data = data_pois, family = gaussian(), + data2 = list(A = A), + chains = 2, cores = 2, iter = 4000, + control = list(adapt_delta = 0.95) +) +``` + +```{r} +summary(model_normal) +``` + +We see that `cofactor` has a positive relationship with the phenotype in both +models. One should keep in mind, though, that the estimates of the Poisson model +are on the log-scale, as we applied the canonical log-link function in this +example. Therefore, estimates are not comparable to a linear normal model even +if applied to the same data. What we can compare, however, is the model fit, for +instance graphically via posterior predictive checks. + +```{r} +pp_check(model_pois) +pp_check(model_normal) +``` + +Apparently, the distribution of the phenotype predicted by the Poisson model +resembles the original distribution of the phenotype pretty closely, while the +normal models fails to do so. We can also apply leave-one-out cross-validation +for direct numerical comparison of model fit. + +```{r} +loo(model_pois, model_normal) +``` + +Since smaller values of loo indicate better fit, it is again evident that the +Poisson model fits the data better than the normal model. Of course, the Poisson +model is not the only reasonable option here. For instance, you could use a +negative binomial model (via family `negative_binomial`), which already contains +an overdispersion parameter so that modeling a varying intercept of `obs` +becomes obsolete. + +## Phylogenetic models with multiple group-level effects + +In the above examples, we have only used a single group-level effect (i.e., a +varying intercept) for the phylogenetic grouping factors. In **brms**, it is +also possible to estimate multiple group-level effects (e.g., a varying +intercept and a varying slope) for these grouping factors. However, it requires +repeatedly computing Kronecker products of covariance matrices while fitting the +model. This will be very slow especially when the grouping factors have many +levels and matrices are thus large. + +## References + +de Villemeruil P. & Nakagawa, S. (2014) General quantitative genetic methods for +comparative biology. In: +*Modern phylogenetic comparative methods and their application in evolutionary biology: concepts and practice* +(ed. Garamszegi L.) Springer, New York. pp. 287-303. + +Hadfield, J. D. & Nakagawa, S. (2010) General quantitative genetic methods for +comparative biology: phylogenies, taxonomies, and multi-trait models for +continuous and categorical characters. *Journal of Evolutionary Biology*. 23. +494-508. + +Lawless, J. F. (1987). Negative binomial and mixed Poisson regression. +*Canadian Journal of Statistics*, 15(3), 209-225. diff -Nru r-cran-brms-2.16.3/vignettes/brms_threading.Rmd r-cran-brms-2.17.0/vignettes/brms_threading.Rmd --- r-cran-brms-2.16.3/vignettes/brms_threading.Rmd 2021-08-12 14:34:35.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/brms_threading.Rmd 2022-04-11 07:21:44.000000000 +0000 @@ -1,579 +1,579 @@ ---- -title: "Running brms models with within-chain parallelization" -author: "Sebastian Weber & Paul Bürkner" -date: "`r Sys.Date()`" -output: - rmarkdown::html_vignette: - toc: yes -vignette: > - %\VignetteIndexEntry{Running brms models with within-chain parallelization} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} -params: - EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") ---- - -```{r, SETTINGS-knitr, include=FALSE} -stopifnot(require(knitr)) -options(width = 90) -opts_chunk$set( - comment = NA, - message = FALSE, - warning = FALSE, - eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, - dev = "png", - dpi = 150, - fig.asp = 0.8, - fig.width = 5, - out.width = "60%", - fig.align = "center" -) -library(ggplot2) -library(brms) -theme_set(theme_default()) -``` - -```{r, fake-data-sim, include=FALSE, eval=TRUE} -set.seed(54647) -# number of observations -N <- 1E4 -# number of group levels -G <- round(N / 10) -# number of predictors -P <- 3 -# regression coefficients -beta <- rnorm(P) - -# sampled covariates, group means and fake data -fake <- matrix(rnorm(N * P), ncol = P) -dimnames(fake) <- list(NULL, paste0("x", 1:P)) - -# fixed effect part and sampled group membership -fake <- transform( - as.data.frame(fake), - theta = fake %*% beta, - g = sample.int(G, N, replace=TRUE) -) - -# add random intercept by group -fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") - -# linear predictor -fake <- transform(fake, mu = theta + eta) - -# sample Poisson data -fake <- transform(fake, y = rpois(N, exp(mu))) - -# shuffle order of data rows to ensure even distribution of computational effort -fake <- fake[sample.int(N, N),] - -# drop not needed row names -rownames(fake) <- NULL -``` - -```{r, model-poisson, include=FALSE} -model_poisson <- brm( - y ~ 1 + x1 + x2 + (1 | g), - data = fake, - family = poisson(), - iter = 500, # short sampling to speedup example - chains = 2, - prior = prior(normal(0,1), class = b) + - prior(constant(1), class = sd, group = g), - backend = "cmdstanr", - threads = threading(4) -) -``` - -```{r, benchmark, include=FALSE} -# Benchmarks given model with cross-product of tuning parameters CPU -# cores, grainsize and iterations. Models are run with either static -# or non-static scheduler and inits is set by default to 0 on the -# unconstrained scale. Function returns a data-frame with the -# cross-product of the tuning parameters and as result column the -# respective runtime. -benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, - static = FALSE) { - - winfo <- extract_warmup_info(model) - sims <- rstan::extract(model$fit) - init <- list(extract_draw(sims, 1)) - - scaling_model <- update( - model, refresh = 0, - threads = threading(1, grainsize = grainsize[1], static = static), - chains = 1, iter = 2, backend = "cmdstanr" - ) - - run_benchmark <- function(cores, size, iter) { - bench_fit <- update( - scaling_model, warmup=0, iter = iter, - chains = 1, seed = 1234, inits = init, refresh = 0, save_warmup=TRUE, - threads = threading(cores, grainsize = size, static = static), - inv_metric=winfo$inv_metric[[1]], - step_size=winfo$step_size[[1]], - adapt_engaged=FALSE - ) - lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) - elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) - - c(num_leapfrog=lf, runtime=elapsed) - } - - cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) - res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) - cbind(cases, as.data.frame(t(res))) -} - -benchmark_reference <- function(model, iter=100, inits=0) { - winfo <- extract_warmup_info(model) - sims <- rstan::extract(model$fit) - init <- list(extract_draw(sims, 1)) - - ref_model <- update( - model, refresh = 0, - threads = NULL, - chains = 1, iter = 2, backend = "cmdstanr" - ) - - run_benchmark_ref <- function(iter_bench) { - bench_fit <- update( - ref_model, warmup=0, iter = iter_bench, - chains = 1, seed = 1234, inits = init, refresh = 0, - inv_metric=winfo$inv_metric[[1]], - step_size=winfo$step_size[[1]], - adapt_engaged=FALSE - ) - - lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) - elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) - - c(num_leapfrog=lf, runtime=elapsed) - } - - ref <- sapply(iter, run_benchmark_ref) - ref <- cbind(as.data.frame(t(ref)), iter=iter) - ref -} - -extract_warmup_info <- function(bfit) { - adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") - step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) - inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) - list(step_size=step_size, inv_metric=inv_metric) -} - -extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE) - -``` - -## Introduction - -Full Bayesian inference is a computationally very demanding task and often we -wish to run our models faster in shorter walltime. With modern computers we -nowadays have multiple processors available on a given machine such that the use -of running the inference in parallel will shorten the overall walltime. While -between-chain parallelization is straightforward by merely launching multiple -chains at the same time, the use of within-chain parallelization is more -complicated in various ways. This vignette aims to introduce the user to -within-chain parallelization with **brms**, since its efficient use depends on -various aspects specific to the users model. - -## Quick summary - -Assuming you have a **brms** model which you wish to evaluate faster by using -more cores per chain, for example: - -```{r, eval=FALSE} -fit_serial <- brm( - count ~ zAge + zBase * Trt + (1|patient), - data = epilepsy, family = poisson(), - chains = 4, cores = 4, backend = "cmdstanr" -) -``` - -Then running this model with threading requires `cmdstanr` as backend and you -can simply add threading support to an existing model with the `update` -mechanism as: - -```{r, eval=FALSE} -fit_parallel <- update( - fit_serial, chains = 2, cores = 2, - backend = "cmdstanr", threads = threading(2) -) -``` - -The example above assumes that 4 cores are available which are best used without -within-chain parallelization by running 4 chains in parallel. When using within -chain parallelization it is still advisable to use just as many threads -*in total* as you have CPU cores. It's thus sensible in this case to reduce the -number of chains running in parallel to just 2, but allow each chain to use 2 -threads. Obviously this will reduce the number of iterations in the posterior -here as we assumed a fixed amount of 4 cores. - -- Only apply within-chain parallelization to large problems which take - more than a few minutes at least to calculate. The `epilepsy` - example above is actually too small to gain in speed (just a few seconds - per chain on this machine). -- Within-chain parallelization is less efficient than between-chain - parallelization. So only use within-chain parallelism if more CPUs - can be used to run the entire analysis. -- Due to details of the model and data-set, speedups with more cores - can be very limited. Not every model amends to within-chain - parallelization and an empirical evaluation is in some cases - advisable. -- Enabling threading *usually* slows down any model to some extent and - this slowdown must be offset by sufficient cores per chain in order - to really gain in execution speed. -- Doubling the execution speed with few cores is a lot easier than - obtaining larger speedups with even more cores. -- Models with computationally expensive likelihoods are easier to - parallelize than less expensive likelihoods. For example, the Poisson - distribution involves expensive $\log\Gamma$ functions whereas the - normal likelihood is very cheap to calculate in comparison. -- Models with many parameters (e.g., multilevel models) - carry a large overhead when running in parallel. -- With a larger overhead of the model, the likelihood must be - sufficiently expensive such that the relative computational cost of - likelihood to parallelization overhead is favorable. -- Avoid using hyper-threading, that is, only use as many threads as you - have physical cores available. -- Ensure that the data is randomly sorted such that consecutive - subsets of the data are roughly of the same computational effort. - -## Within-chain parallelization - -The within-chain parallelization implemented in **brms** is based on the -`reduce_sum` facility in Stan. The basic principle that `reduce_sum` uses is to -split a large summation into arbitrary smaller partial sums. Due to the -commutativity and associativity of the sum operation these smaller partial sums -can be evaluated in any order and in parallel from one another. **brms** -leverages `reduce_sum` to evaluate the log-likelihood of the model in parallel -as for example - -$$ -\begin{aligned} -l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ - &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). -\end{aligned} -$$ - -As a consequence, the within-chain parallelization requires mutually independent -log-likelihood terms which restricts its applicability to some degree. - -Furthermore, the within-chain parallelization is only applicable to the -evaluation of the data likelihood while all other parts of the model, for -example priors, will remain running serially. Thus, only a partial fraction of -the entire Stan model will run in parallel which limits the potential speedup -one may obtain. The theoretical speedup for a partially in parallel running -program is described by -[Amdahl‘s law](https://en.wikipedia.org/wiki/Amdahl%27s_law). -For example, with 90% of the computational load running in parallel one can -essentially double the execution speed with 2 cores while 8 cores may only -speedup the program by at most 5x. How large the computational cost of the -log-likelihood is in relation to the entire model is very dependent on the -model of the user. - -In practice, the speedups are even smaller than the theoretical speedups. This -is caused by the additional overhead implied by forming multiple smaller sums -than just one large one. For example, for each partial sum formed the entire -parameter vector $\theta$ has to be copied in memory for Stan to be able to -calculate the gradient of the log-likelihood. Hence, with more partial sums, -more copying is necessary as opposed to evaluating just one large sum. Whether -the additional copying is indeed relevant depends on the computational cost of -the log-likelihood of each term and the number of parameters. For a model with a -computationally cheap normal log-likelihood, this effect is more important than -for a model with a Poisson log-likelihood, and for multilevel models with many -parameters more copying is needed than for simpler regression models. It may -therefore be necessary to form sufficiently large partial sums to warrant an -efficient parallel execution. The size of the partial sums is referred to as the -`grainsize`, which is set to a reasonable default value. However, for some -models this tuning parameter requires some attention from the user for optimal -performance. - -Finally, it is important to note that by default the exact size and order of the -partial sums is not stable as it is adjusted to the load of the system. As a -result, exact numerical reproducibility is not guaranteed by default. In order -to warrant the same size and order of the partial sums, the `static` option must -be used and set to `TRUE`, which uses a deterministic scheduler for the parallel -work. - -## Example model - -As a toy demonstration, we use here a multilevel Poisson model. The model is a -varying intercept model with $`r N`$ data observation which are grouped into -$`r G`$ groups. Each data item has $`r P`$ continuous covariates. The -simulation code for the fake data can be found in the appendix and it's first -$10$ rows are: - -```{r} -kable(head(fake, 10), digits = 3) -``` - -The **brms** model fitting this data is: - -```{r, eval=FALSE} -<> -``` - -Here we have fixed the standard deviation of the between-group variation for the -intercept to the true value of $1$ as used in the simulation. This is to avoid -unfavorable geometry of the problem allowing us to concentrate on computational -aspects alone. - -The Poisson likelihood is a relatively expensive likelihood due to the use of -$\log\Gamma$ function as opposed to, for example, a normal likelihood which does -is by far less expensive operations. Moreover, this example is chosen in order -to demonstrate parallelization overhead implied by a large number of parameters. - -## Managing parallelization overhead - -As discussed above, the key mechanism to run Stan programs with parallelization -is to split the large sum over independent log likelihood terms into arbitrary -smaller *partial sums*. Creating more *partial sums* allows to increase -simultaneous parallel computations in a granular way, but at the same time -additional overhead is introduced through the requirement to copy the entire -parameter vector for each *partial sum* formed along with further overhead due -to splitting up a single large task into multiple smaller ones. - -By default, **brms** will choose a sensible `grainsize` which defines how large -a given *partial sum* will roughly be. The actual chunk size is automatically -tuned whenever the default non-static scheduler is used, which is the -recommended choice to start with. As noted before, only the static scheduler is -giving fully deterministic results since the chunk size and order of partial -sums will be the same during sampling. - -While we expect that the default `grainsize` in **brms** is reasonably good for -many models, it can improve performance if one tunes the `grainsize` -specifically to a given model and data-set. We suggest to increase successively -the number of chunks a given data set is split into with the static scheduler -and run this on a single core. This way one can control the number of -*partial sum* accurately and monitor the execution time as it increases. These -experiments are run with only a single chain and very short iteration numbers as -we are not interested in the statistical results, but rather aim to be able to -explore the tuning parameter space of the chunk size as quickly as possible. The -number of iterations needed to get reliable runtime estimates for a given chunk -size will depend on many details and the easiest way to determine this is to run -this benchmark with multiple number of iterations. Whenever their results match -approximately, then the iteration numbers are sufficient. In order to -decrease the variation between runs, we also fix the random seed, -initial value and the tuning parameters of the sampler (step size and -mass matrix). - -Below is an example R code demonstrating such a benchmark. The utility function -`benchmark_threading` is shown and explained in the appendix. - -```{r, chunking-scale, message=FALSE, warning=FALSE, results='hide'} -chunking_bench <- transform( - data.frame(chunks = 4^(0:3)), - grainsize = ceiling(N / chunks) -) - -iter_test <- c(10, 20, 40) # very short test runs -scaling_chunking <- benchmark_threading( - model_poisson, - cores = 1, - grainsize = chunking_bench$grainsize, # test various grainsizes - iter = iter_test, - static = TRUE # with static partitioner -) - -# run as reference the model *without* reduce_sum -ref <- benchmark_reference(model_poisson, iter_test) - -# for additional data munging please refer to the appendix -``` - -```{r, munge-chunking-scaling, include=FALSE} -scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") - -single_chunk <- transform( - subset(scaling_chunking, chunks == 1), - num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, - runtime_single = runtime, runtime = NULL, - grainsize = NULL, chunks=NULL -) - -scaling_chunking <- transform( - merge(scaling_chunking, single_chunk), - slowdown = runtime/runtime_single, - iter = factor(iter), - runtime_single = NULL -) - -ref <- transform(ref, iter=factor(iter)) -``` - -Graphically summarizing the results shows that with more than 8 chunks the -overhead is about 10% and increasing further with more chunks. For models -without many parameters, no such overhead should be observed. Furthermore, one -can see that 25 and 50 iterations give similar results implying that 25 -iterations suffice for stable runtime estimates for these (and the following) -benchmarks. The overhead of up to 20% in this example with 16 chunks may seem -large due to the scaling of the plot. One must not forget that when we start to -use more CPU cores, the overhead is easily offset, but it limits the maximal -speedup we can get. For example, some 2 units of computation become 2.4 units -due to the overhead such that on 2 cores we don't quite double the execution -speed, but rather get a 1.6x increase in speed instead of a 2x -speedup. - -Considering in addition the time per leapfrog step of the NUTS sampler -shows on an absolute scale similar information as before. The upside -of this representation is that we can visualize the slowdown in -relation to the program *without* `reduce_sum`. As we can see, the -additional overhead due to merely enabling `reduce_sum` is substantial -in this example. This is attributed in the specific example to the -large number of random effects. - -```{r} -ggplot(scaling_chunking) + - aes(chunks, slowdown, colour = iter, shape = iter) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_chunking$chunks) + - scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + - ggtitle("Slowdown with increasing number of chunks") - -ggplot(scaling_chunking) + - aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_chunking$chunks) + - scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + - geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + - ggtitle("Time per leapfrog step vs number of chunks", - "Dashed line is reference model without reduce_sum") + - ylab("Time per leapfrog step [ms]") - - -``` - -## Parallelization speedup - -In practice, we are often interested in so-called "hard-scaling" properties of -the parallelization system. That is, for a fixed problem size we would like to -know how much faster we can execute the Stan program with increasing number of -threads. As nowadays CPUs usually run with so-called hyper-threading, it is also -of interest if this technique is beneficial for Stan programs as well (spoiler -alert: it's not useful). As we have seen before, the `grainsize` can have an -impact on the performance and is as such a tuning parameter. Below we -demonstrate some exemplary R code which runs a benchmark with varying number of -CPU cores and varying number of `grainsize`s. - -```{r, speedup-scale, message=FALSE, warning=FALSE, results='hide'} -num_cpu <- parallel::detectCores(logical = FALSE) -num_cpu_logical <- parallel::detectCores(logical = TRUE) -grainsize_default <- ceiling(N / (2 * num_cpu)) -cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) -cores <- sort(unique(cores)) -grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) -grainsize <- round(grainsize) - -iter_scaling <- 20 -scaling_cores <- benchmark_threading( - model_poisson, - cores = cores, - grainsize = grainsize, - iter = iter_scaling, - static = FALSE -) - -single_core <- transform( - subset(scaling_cores, cores == 1), - runtime_single = runtime, - num_leapfrog=NULL, runtime=NULL, cores = NULL -) - -scaling_cores <- transform( - merge(scaling_cores, single_core), - speedup = runtime_single/runtime, - grainsize = factor(grainsize) -) -``` - -It is important to consider the absolute runtime and the relative speedup vs. -running on a single core. The relative speedup can be misleading if the single -core runtime is very slow in which case speed gains on more CPUs may look overly -good. Considering instead the absolute runtime avoids this problem. After -all, we are interested in the shortest walltime we can get rather than any -relative speedups. - -```{r} -ggplot(scaling_cores) + - aes(cores, runtime, shape = grainsize, color = grainsize) + - geom_vline(xintercept = num_cpu, linetype = 3) + - geom_line() + geom_point() + - scale_x_log10(breaks = scaling_cores$cores) + - scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + - theme(legend.position = c(0.85, 0.8)) + - geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + - ggtitle("Runtime with varying number of cores", - "Dashed line is reference model without reduce_sum") - -ggplot(scaling_cores) + - aes(cores, speedup, shape = grainsize, color = grainsize) + - geom_abline(slope = 1, intercept = 0, linetype = 2) + - geom_vline(xintercept = num_cpu, linetype = 3) + - geom_line() + geom_point() + - scale_x_log10(breaks=scaling_cores$cores) + - scale_y_log10(breaks=scaling_cores$cores) + - theme(aspect.ratio = 1) + - coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + - ggtitle("Relative speedup vs 1 core") -``` - -The vertical dotted line marks the physical number of CPU cores on the machine -this was run. The horizontal dashed line in the plot with absolute -runtime marks the respective runtime of the model *without* -`reduce_sum` and the dashed unity line in the plot with the relative -speedup marks the theoretical maximal speedup. We can see -that there is no further reduction in execution time when increasing the thread -count to be greater than the number of physical CPUs. Hence, the use of -hyper-threading is not helpful when aiming to maximize the speed of a Stan -program. Moreover, the use of threading outperforms the single core -runtime only when using more than 4 cores in this example. - -For this example, the shown `grainsize`s matter on some machines but -not on others, so your results may look quite different from what is shown here. -The overall speedups may not seem impressive in this case, which is attributed -in this case to the large number of parameters relative to the number of -observations. However, we can still outperform the single core -runtime when using many cores. Though the most important advantage of -threading is that with an increasing data set size, the user has the option to -use a brute-force approach to balance the increase in walltime needed. - -```{r} -kable(scaling_cores, digits = 2) -``` - -For a given Stan model one should usually choose the number of chains and the -number of threads per chain to be equal to the number of (physical) cores one -wishes to use. Only if different chains of the model have relatively different -execution times (which they should not have, but it occurs sometimes in -practice), then one may consider the use of hyper-threading. Doing so will share -the resources evenly across all chains and whenever the fastest chain finishes, -the freed resources can be given to the still running chains. - -## Appendix - -### Fake data simulation - -```{r, eval=FALSE} -<> -``` - -### Poisson example model - -```{r, eval=FALSE} -<> -``` - -### Threading benchmark function - -```{r, eval=FALSE} -<> -``` - -### Munging of slowdown with chunking data - -```{r, eval=FALSE} -<> -``` +--- +title: "Running brms models with within-chain parallelization" +author: "Sebastian Weber & Paul Bürkner" +date: "`r Sys.Date()`" +output: + rmarkdown::html_vignette: + toc: yes +vignette: > + %\VignetteIndexEntry{Running brms models with within-chain parallelization} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +params: + EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") +--- + +```{r, SETTINGS-knitr, include=FALSE} +stopifnot(require(knitr)) +options(width = 90) +opts_chunk$set( + comment = NA, + message = FALSE, + warning = FALSE, + eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, + dev = "jpeg", + dpi = 100, + fig.asp = 0.8, + fig.width = 5, + out.width = "60%", + fig.align = "center" +) +library(ggplot2) +library(brms) +theme_set(theme_default()) +``` + +```{r, fake-data-sim, include=FALSE, eval=TRUE} +set.seed(54647) +# number of observations +N <- 1E4 +# number of group levels +G <- round(N / 10) +# number of predictors +P <- 3 +# regression coefficients +beta <- rnorm(P) + +# sampled covariates, group means and fake data +fake <- matrix(rnorm(N * P), ncol = P) +dimnames(fake) <- list(NULL, paste0("x", 1:P)) + +# fixed effect part and sampled group membership +fake <- transform( + as.data.frame(fake), + theta = fake %*% beta, + g = sample.int(G, N, replace=TRUE) +) + +# add random intercept by group +fake <- merge(fake, data.frame(g = 1:G, eta = rnorm(G)), by = "g") + +# linear predictor +fake <- transform(fake, mu = theta + eta) + +# sample Poisson data +fake <- transform(fake, y = rpois(N, exp(mu))) + +# shuffle order of data rows to ensure even distribution of computational effort +fake <- fake[sample.int(N, N),] + +# drop not needed row names +rownames(fake) <- NULL +``` + +```{r, model-poisson, include=FALSE} +model_poisson <- brm( + y ~ 1 + x1 + x2 + (1 | g), + data = fake, + family = poisson(), + iter = 500, # short sampling to speedup example + chains = 2, + prior = prior(normal(0,1), class = b) + + prior(constant(1), class = sd, group = g), + backend = "cmdstanr", + threads = threading(4) +) +``` + +```{r, benchmark, include=FALSE} +# Benchmarks given model with cross-product of tuning parameters CPU +# cores, grainsize and iterations. Models are run with either static +# or non-static scheduler and initial values are set by default to 0 on the +# unconstrained scale. Function returns a data-frame with the +# cross-product of the tuning parameters and as result column the +# respective runtime. +benchmark_threading <- function(model, cores = 1, grainsize = 1, iter = 100, + static = FALSE) { + + winfo <- extract_warmup_info(model) + sims <- rstan::extract(model$fit) + init <- list(extract_draw(sims, 1)) + + scaling_model <- update( + model, refresh = 0, + threads = threading(1, grainsize = grainsize[1], static = static), + chains = 1, iter = 2, backend = "cmdstanr" + ) + + run_benchmark <- function(cores, size, iter) { + bench_fit <- update( + scaling_model, warmup=0, iter = iter, + chains = 1, seed = 1234, init = init, refresh = 0, save_warmup=TRUE, + threads = threading(cores, grainsize = size, static = static), + inv_metric=winfo$inv_metric[[1]], + step_size=winfo$step_size[[1]], + adapt_engaged=FALSE + ) + lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) + elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) + + c(num_leapfrog=lf, runtime=elapsed) + } + + cases <- expand.grid(cores = cores, grainsize = grainsize, iter = iter) + res <- with(cases, mapply(run_benchmark, cores, grainsize, iter)) + cbind(cases, as.data.frame(t(res))) +} + +benchmark_reference <- function(model, iter=100, init=0) { + winfo <- extract_warmup_info(model) + sims <- rstan::extract(model$fit) + init <- list(extract_draw(sims, 1)) + + ref_model <- update( + model, refresh = 0, + threads = NULL, + chains = 1, iter = 2, backend = "cmdstanr" + ) + + run_benchmark_ref <- function(iter_bench) { + bench_fit <- update( + ref_model, warmup=0, iter = iter_bench, + chains = 1, seed = 1234, init = init, refresh = 0, + inv_metric=winfo$inv_metric[[1]], + step_size=winfo$step_size[[1]], + adapt_engaged=FALSE + ) + + lf <- sum(subset(nuts_params(bench_fit, inc_warmup=TRUE), Parameter=="n_leapfrog__")$Value) + elapsed <- sum(colSums(rstan::get_elapsed_time(bench_fit$fit))) + + c(num_leapfrog=lf, runtime=elapsed) + } + + ref <- sapply(iter, run_benchmark_ref) + ref <- cbind(as.data.frame(t(ref)), iter=iter) + ref +} + +extract_warmup_info <- function(bfit) { + adapt <- lapply(rstan::get_adaptation_info(bfit$fit), strsplit, split="\\n") + step_size <- lapply(adapt, function(a) as.numeric(strsplit(a[[1]][[1]], " = ")[[1]][2])) + inv_metric <- lapply(adapt, function(a) as.numeric(strsplit(sub("^# ", "", a[[1]][[3]]), ", ")[[1]])) + list(step_size=step_size, inv_metric=inv_metric) +} + +extract_draw <- function(sims, draw) lapply(sims, abind::asub, idx=draw, dim=1, drop=FALSE) + +``` + +## Introduction + +Full Bayesian inference is a computationally very demanding task and often we +wish to run our models faster in shorter walltime. With modern computers we +nowadays have multiple processors available on a given machine such that the use +of running the inference in parallel will shorten the overall walltime. While +between-chain parallelization is straightforward by merely launching multiple +chains at the same time, the use of within-chain parallelization is more +complicated in various ways. This vignette aims to introduce the user to +within-chain parallelization with **brms**, since its efficient use depends on +various aspects specific to the users model. + +## Quick summary + +Assuming you have a **brms** model which you wish to evaluate faster by using +more cores per chain, for example: + +```{r, eval=FALSE} +fit_serial <- brm( + count ~ zAge + zBase * Trt + (1|patient), + data = epilepsy, family = poisson(), + chains = 4, cores = 4, backend = "cmdstanr" +) +``` + +Then running this model with threading requires `cmdstanr` as backend and you +can simply add threading support to an existing model with the `update` +mechanism as: + +```{r, eval=FALSE} +fit_parallel <- update( + fit_serial, chains = 2, cores = 2, + backend = "cmdstanr", threads = threading(2) +) +``` + +The example above assumes that 4 cores are available which are best used without +within-chain parallelization by running 4 chains in parallel. When using within +chain parallelization it is still advisable to use just as many threads +*in total* as you have CPU cores. It's thus sensible in this case to reduce the +number of chains running in parallel to just 2, but allow each chain to use 2 +threads. Obviously this will reduce the number of iterations in the posterior +here as we assumed a fixed amount of 4 cores. + +- Only apply within-chain parallelization to large problems which take + more than a few minutes at least to calculate. The `epilepsy` + example above is actually too small to gain in speed (just a few seconds + per chain on this machine). +- Within-chain parallelization is less efficient than between-chain + parallelization. So only use within-chain parallelism if more CPUs + can be used to run the entire analysis. +- Due to details of the model and data-set, speedups with more cores + can be very limited. Not every model amends to within-chain + parallelization and an empirical evaluation is in some cases + advisable. +- Enabling threading *usually* slows down any model to some extent and + this slowdown must be offset by sufficient cores per chain in order + to really gain in execution speed. +- Doubling the execution speed with few cores is a lot easier than + obtaining larger speedups with even more cores. +- Models with computationally expensive likelihoods are easier to + parallelize than less expensive likelihoods. For example, the Poisson + distribution involves expensive $\log\Gamma$ functions whereas the + normal likelihood is very cheap to calculate in comparison. +- Models with many parameters (e.g., multilevel models) + carry a large overhead when running in parallel. +- With a larger overhead of the model, the likelihood must be + sufficiently expensive such that the relative computational cost of + likelihood to parallelization overhead is favorable. +- Avoid using hyper-threading, that is, only use as many threads as you + have physical cores available. +- Ensure that the data is randomly sorted such that consecutive + subsets of the data are roughly of the same computational effort. + +## Within-chain parallelization + +The within-chain parallelization implemented in **brms** is based on the +`reduce_sum` facility in Stan. The basic principle that `reduce_sum` uses is to +split a large summation into arbitrary smaller partial sums. Due to the +commutativity and associativity of the sum operation these smaller partial sums +can be evaluated in any order and in parallel from one another. **brms** +leverages `reduce_sum` to evaluate the log-likelihood of the model in parallel +as for example + +$$ +\begin{aligned} +l(y|\theta) &= \sum_{i=1}^N l_i(y_i| \theta) \\ + &= \sum_{i=1}^{S_1} l_i(y_i| \theta) + \sum_{i=S_1+1}^N l_i(y_i| \theta). +\end{aligned} +$$ + +As a consequence, the within-chain parallelization requires mutually independent +log-likelihood terms which restricts its applicability to some degree. + +Furthermore, the within-chain parallelization is only applicable to the +evaluation of the data likelihood while all other parts of the model, for +example priors, will remain running serially. Thus, only a partial fraction of +the entire Stan model will run in parallel which limits the potential speedup +one may obtain. The theoretical speedup for a partially in parallel running +program is described by +[Amdahl‘s law](https://en.wikipedia.org/wiki/Amdahl%27s_law). +For example, with 90% of the computational load running in parallel one can +essentially double the execution speed with 2 cores while 8 cores may only +speedup the program by at most 5x. How large the computational cost of the +log-likelihood is in relation to the entire model is very dependent on the +model of the user. + +In practice, the speedups are even smaller than the theoretical speedups. This +is caused by the additional overhead implied by forming multiple smaller sums +than just one large one. For example, for each partial sum formed the entire +parameter vector $\theta$ has to be copied in memory for Stan to be able to +calculate the gradient of the log-likelihood. Hence, with more partial sums, +more copying is necessary as opposed to evaluating just one large sum. Whether +the additional copying is indeed relevant depends on the computational cost of +the log-likelihood of each term and the number of parameters. For a model with a +computationally cheap normal log-likelihood, this effect is more important than +for a model with a Poisson log-likelihood, and for multilevel models with many +parameters more copying is needed than for simpler regression models. It may +therefore be necessary to form sufficiently large partial sums to warrant an +efficient parallel execution. The size of the partial sums is referred to as the +`grainsize`, which is set to a reasonable default value. However, for some +models this tuning parameter requires some attention from the user for optimal +performance. + +Finally, it is important to note that by default the exact size and order of the +partial sums is not stable as it is adjusted to the load of the system. As a +result, exact numerical reproducibility is not guaranteed by default. In order +to warrant the same size and order of the partial sums, the `static` option must +be used and set to `TRUE`, which uses a deterministic scheduler for the parallel +work. + +## Example model + +As a toy demonstration, we use here a multilevel Poisson model. The model is a +varying intercept model with $`r N`$ data observation which are grouped into +$`r G`$ groups. Each data item has $`r P`$ continuous covariates. The +simulation code for the fake data can be found in the appendix and it's first +$10$ rows are: + +```{r} +kable(head(fake, 10), digits = 3) +``` + +The **brms** model fitting this data is: + +```{r, eval=FALSE} +<> +``` + +Here we have fixed the standard deviation of the between-group variation for the +intercept to the true value of $1$ as used in the simulation. This is to avoid +unfavorable geometry of the problem allowing us to concentrate on computational +aspects alone. + +The Poisson likelihood is a relatively expensive likelihood due to the use of +$\log\Gamma$ function as opposed to, for example, a normal likelihood which does +is by far less expensive operations. Moreover, this example is chosen in order +to demonstrate parallelization overhead implied by a large number of parameters. + +## Managing parallelization overhead + +As discussed above, the key mechanism to run Stan programs with parallelization +is to split the large sum over independent log likelihood terms into arbitrary +smaller *partial sums*. Creating more *partial sums* allows to increase +simultaneous parallel computations in a granular way, but at the same time +additional overhead is introduced through the requirement to copy the entire +parameter vector for each *partial sum* formed along with further overhead due +to splitting up a single large task into multiple smaller ones. + +By default, **brms** will choose a sensible `grainsize` which defines how large +a given *partial sum* will roughly be. The actual chunk size is automatically +tuned whenever the default non-static scheduler is used, which is the +recommended choice to start with. As noted before, only the static scheduler is +giving fully deterministic results since the chunk size and order of partial +sums will be the same during sampling. + +While we expect that the default `grainsize` in **brms** is reasonably good for +many models, it can improve performance if one tunes the `grainsize` +specifically to a given model and data-set. We suggest to increase successively +the number of chunks a given data set is split into with the static scheduler +and run this on a single core. This way one can control the number of +*partial sum* accurately and monitor the execution time as it increases. These +experiments are run with only a single chain and very short iteration numbers as +we are not interested in the statistical results, but rather aim to be able to +explore the tuning parameter space of the chunk size as quickly as possible. The +number of iterations needed to get reliable runtime estimates for a given chunk +size will depend on many details and the easiest way to determine this is to run +this benchmark with multiple number of iterations. Whenever their results match +approximately, then the iteration numbers are sufficient. In order to +decrease the variation between runs, we also fix the random seed, +initial value and the tuning parameters of the sampler (step size and +mass matrix). + +Below is an example R code demonstrating such a benchmark. The utility function +`benchmark_threading` is shown and explained in the appendix. + +```{r, chunking-scale, message=FALSE, warning=FALSE, results='hide'} +chunking_bench <- transform( + data.frame(chunks = 4^(0:3)), + grainsize = ceiling(N / chunks) +) + +iter_test <- c(10, 20, 40) # very short test runs +scaling_chunking <- benchmark_threading( + model_poisson, + cores = 1, + grainsize = chunking_bench$grainsize, # test various grainsizes + iter = iter_test, + static = TRUE # with static partitioner +) + +# run as reference the model *without* reduce_sum +ref <- benchmark_reference(model_poisson, iter_test) + +# for additional data munging please refer to the appendix +``` + +```{r, munge-chunking-scaling, include=FALSE} +scaling_chunking <- merge(scaling_chunking, chunking_bench, by = "grainsize") + +single_chunk <- transform( + subset(scaling_chunking, chunks == 1), + num_leapfrog_single = num_leapfrog, num_leapfrog = NULL, + runtime_single = runtime, runtime = NULL, + grainsize = NULL, chunks=NULL +) + +scaling_chunking <- transform( + merge(scaling_chunking, single_chunk), + slowdown = runtime/runtime_single, + iter = factor(iter), + runtime_single = NULL +) + +ref <- transform(ref, iter=factor(iter)) +``` + +Graphically summarizing the results shows that with more than 8 chunks the +overhead is about 10% and increasing further with more chunks. For models +without many parameters, no such overhead should be observed. Furthermore, one +can see that 25 and 50 iterations give similar results implying that 25 +iterations suffice for stable runtime estimates for these (and the following) +benchmarks. The overhead of up to 20% in this example with 16 chunks may seem +large due to the scaling of the plot. One must not forget that when we start to +use more CPU cores, the overhead is easily offset, but it limits the maximal +speedup we can get. For example, some 2 units of computation become 2.4 units +due to the overhead such that on 2 cores we don't quite double the execution +speed, but rather get a 1.6x increase in speed instead of a 2x +speedup. + +Considering in addition the time per leapfrog step of the NUTS sampler +shows on an absolute scale similar information as before. The upside +of this representation is that we can visualize the slowdown in +relation to the program *without* `reduce_sum`. As we can see, the +additional overhead due to merely enabling `reduce_sum` is substantial +in this example. This is attributed in the specific example to the +large number of random effects. + +```{r} +ggplot(scaling_chunking) + + aes(chunks, slowdown, colour = iter, shape = iter) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_chunking$chunks) + + scale_y_log10(breaks=seq(0.8, 2.5, by=0.1)) + + ggtitle("Slowdown with increasing number of chunks") + +ggplot(scaling_chunking) + + aes(chunks, 1E3 * runtime/num_leapfrog, colour = iter, shape=iter) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_chunking$chunks) + + scale_y_log10(breaks=seq(0.1, 2.0, by=0.1)) + + geom_hline(data=ref, aes(yintercept=1E3 * runtime/num_leapfrog, colour=iter), linetype=I(2)) + + ggtitle("Time per leapfrog step vs number of chunks", + "Dashed line is reference model without reduce_sum") + + ylab("Time per leapfrog step [ms]") + + +``` + +## Parallelization speedup + +In practice, we are often interested in so-called "hard-scaling" properties of +the parallelization system. That is, for a fixed problem size we would like to +know how much faster we can execute the Stan program with increasing number of +threads. As nowadays CPUs usually run with so-called hyper-threading, it is also +of interest if this technique is beneficial for Stan programs as well (spoiler +alert: it's not useful). As we have seen before, the `grainsize` can have an +impact on the performance and is as such a tuning parameter. Below we +demonstrate some exemplary R code which runs a benchmark with varying number of +CPU cores and varying number of `grainsize`s. + +```{r, speedup-scale, message=FALSE, warning=FALSE, results='hide'} +num_cpu <- parallel::detectCores(logical = FALSE) +num_cpu_logical <- parallel::detectCores(logical = TRUE) +grainsize_default <- ceiling(N / (2 * num_cpu)) +cores <- c(2^seq(0, floor(log2(num_cpu_logical))), num_cpu, num_cpu_logical) +cores <- sort(unique(cores)) +grainsize <- c(grainsize_default, grainsize_default/2, grainsize_default/4) +grainsize <- round(grainsize) + +iter_scaling <- 20 +scaling_cores <- benchmark_threading( + model_poisson, + cores = cores, + grainsize = grainsize, + iter = iter_scaling, + static = FALSE +) + +single_core <- transform( + subset(scaling_cores, cores == 1), + runtime_single = runtime, + num_leapfrog=NULL, runtime=NULL, cores = NULL +) + +scaling_cores <- transform( + merge(scaling_cores, single_core), + speedup = runtime_single/runtime, + grainsize = factor(grainsize) +) +``` + +It is important to consider the absolute runtime and the relative speedup vs. +running on a single core. The relative speedup can be misleading if the single +core runtime is very slow in which case speed gains on more CPUs may look overly +good. Considering instead the absolute runtime avoids this problem. After +all, we are interested in the shortest walltime we can get rather than any +relative speedups. + +```{r} +ggplot(scaling_cores) + + aes(cores, runtime, shape = grainsize, color = grainsize) + + geom_vline(xintercept = num_cpu, linetype = 3) + + geom_line() + geom_point() + + scale_x_log10(breaks = scaling_cores$cores) + + scale_y_log10(breaks=seq(0.1, 1.4, by=0.1)) + + theme(legend.position = c(0.85, 0.8)) + + geom_hline(data=subset(ref, iter==iter_scaling), aes(yintercept=runtime), linetype=I(2)) + + ggtitle("Runtime with varying number of cores", + "Dashed line is reference model without reduce_sum") + +ggplot(scaling_cores) + + aes(cores, speedup, shape = grainsize, color = grainsize) + + geom_abline(slope = 1, intercept = 0, linetype = 2) + + geom_vline(xintercept = num_cpu, linetype = 3) + + geom_line() + geom_point() + + scale_x_log10(breaks=scaling_cores$cores) + + scale_y_log10(breaks=scaling_cores$cores) + + theme(aspect.ratio = 1) + + coord_fixed(xlim = c(1, num_cpu_logical), ylim = c(1, num_cpu_logical)) + + ggtitle("Relative speedup vs 1 core") +``` + +The vertical dotted line marks the physical number of CPU cores on the machine +this was run. The horizontal dashed line in the plot with absolute +runtime marks the respective runtime of the model *without* +`reduce_sum` and the dashed unity line in the plot with the relative +speedup marks the theoretical maximal speedup. We can see +that there is no further reduction in execution time when increasing the thread +count to be greater than the number of physical CPUs. Hence, the use of +hyper-threading is not helpful when aiming to maximize the speed of a Stan +program. Moreover, the use of threading outperforms the single core +runtime only when using more than 4 cores in this example. + +For this example, the shown `grainsize`s matter on some machines but +not on others, so your results may look quite different from what is shown here. +The overall speedups may not seem impressive in this case, which is attributed +in this case to the large number of parameters relative to the number of +observations. However, we can still outperform the single core +runtime when using many cores. Though the most important advantage of +threading is that with an increasing data set size, the user has the option to +use a brute-force approach to balance the increase in walltime needed. + +```{r} +kable(scaling_cores, digits = 2) +``` + +For a given Stan model one should usually choose the number of chains and the +number of threads per chain to be equal to the number of (physical) cores one +wishes to use. Only if different chains of the model have relatively different +execution times (which they should not have, but it occurs sometimes in +practice), then one may consider the use of hyper-threading. Doing so will share +the resources evenly across all chains and whenever the fastest chain finishes, +the freed resources can be given to the still running chains. + +## Appendix + +### Fake data simulation + +```{r, eval=FALSE} +<> +``` + +### Poisson example model + +```{r, eval=FALSE} +<> +``` + +### Threading benchmark function + +```{r, eval=FALSE} +<> +``` + +### Munging of slowdown with chunking data + +```{r, eval=FALSE} +<> +``` diff -Nru r-cran-brms-2.16.3/vignettes/citations_multilevel.bib r-cran-brms-2.17.0/vignettes/citations_multilevel.bib --- r-cran-brms-2.16.3/vignettes/citations_multilevel.bib 2020-02-27 16:10:02.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/citations_multilevel.bib 2021-12-20 13:50:54.000000000 +0000 @@ -1,351 +1,351 @@ -% Encoding: UTF-8 -@Article{brms2, - title = {Advanced {Bayesian} Multilevel Modeling with the {R} Package {brms}}, - author = {Paul-Christian Bürkner}, - journal = {The R Journal}, - year = {2018}, - volume = {10}, - number = {1}, - pages = {395--411}, - doi = {10.32614/RJ-2018-017}, - encoding = {UTF-8}, -} - -@Article{vehtari2016, - author = {Vehtari, Aki and Gelman, Andrew and Gabry, Jonah}, - title = {Practical Bayesian Model Evaluation Using Leave-One-Out Cross-Validation and WAIC}, - journal = {Statistics and Computing}, - year = {2016}, - pages = {1--20}, - publisher = {Springer}, -} - -@Book{fahrmeir2013, - title = {Regression: models, methods and applications}, - publisher = {Springer Science \& Business Media}, - year = {2013}, - author = {Fahrmeir, Ludwig and Kneib, Thomas and Lang, Stefan and Marx, Brian}, -} - -@Manual{gamlss.data, - title = {gamlss.data: GAMLSS Data}, - author = {Mikis Stasinopoulos and Bob Rigby}, - year = {2016}, - note = {R package version 5.0-0}, - url = {https://CRAN.R-project.org/package=gamlss.data}, -} - -@Article{wood2013, - author = {Wood, Simon N and Scheipl, Fabian and Faraway, Julian J}, - title = {Straightforward intermediate rank tensor product smoothing in mixed models}, - journal = {Statistics and Computing}, - year = {2013}, - pages = {1--20}, - publisher = {Springer}, -} - -@Manual{mcelreath2017, - title = {rethinking: Statistical Rethinking Course and Book Package}, - author = {Richard McElreath}, - year = {2017}, - note = {R package version 1.59}, - owner = {Paul}, - timestamp = {2016.03.04}, - url = {https://github.com/rmcelreath/rethinking}, -} - -@Article{wagenmakers2010, - author = {Wagenmakers, Eric-Jan and Lodewyckx, Tom and Kuriyal, Himanshu and Grasman, Raoul}, - title = {Bayesian hypothesis testing for psychologists: A tutorial on the Savage--Dickey method}, - journal = {Cognitive psychology}, - year = {2010}, - volume = {60}, - number = {3}, - pages = {158--189}, - publisher = {Elsevier}, -} - -@Manual{bridgesampling2017, - title = {bridgesampling: Bridge Sampling for Marginal Likelihoods and Bayes Factors}, - author = {Quentin F. Gronau and Henrik Singmann}, - year = {2017}, - note = {R package version 0.4-0}, - url = {https://CRAN.R-project.org/package=bridgesampling}, -} - -@BOOK{brown2015, - title = {Applied Mixed Models in Medicine}, - publisher = {John Wiley \& Sons}, - year = {2015}, - author = {Brown, Helen and Prescott, Robin}, - owner = {Paul}, - timestamp = {2015.06.19} -} - -@Book{demidenko2013, - title = {Mixed Models: Theory and Applications with R}, - publisher = {John Wiley \& Sons}, - year = {2013}, - author = {Demidenko, Eugene}, - owner = {Paul}, - timestamp = {2015.06.19}, -} - -@Book{gelmanMLM2006, - title = {Data Analysis Using Regression and Multilevel/Hierarchical Models}, - publisher = {Cambridge University Press}, - year = {2006}, - author = {Gelman, Andrew and Hill, Jennifer}, - owner = {Paul}, - timestamp = {2016.02.21}, -} - -@Book{pinheiro2006, - title = {Mixed-Effects Models in S and S-PLUS}, - publisher = {Springer-Verlage Science \& Business Media}, - year = {2006}, - author = {Pinheiro, Jose and Bates, Douglas}, - owner = {Paul}, - timestamp = {2015.06.19}, -} - -@Article{rigby2005, - author = {Rigby, Robert A and Stasinopoulos, D Mikis}, - title = {Generalized Additive Models for Location, Scale and Shape}, - journal = {Journal of the Royal Statistical Society C (Applied Statistics)}, - year = {2005}, - volume = {54}, - number = {3}, - pages = {507--554}, - publisher = {Wiley Online Library}, -} - -@Article{lindstrom1990, - author = {Lindstrom, Mary J and Bates, Douglas M}, - title = {Nonlinear Mixed Effects Models for Repeated Measures Data}, - journal = {Biometrics}, - year = {1990}, - pages = {673--687}, - publisher = {JSTOR}, -} - -@Article{wood2004, - author = {Wood, Simon N}, - title = {Stable and Efficient Multiple Smoothing Parameter Estimation for Generalized Additive Models}, - journal = {Journal of the American Statistical Association}, - year = {2004}, - volume = {99}, - number = {467}, - pages = {673--686}, - publisher = {Taylor \& Francis}, -} - -@Article{rasmussen2006, - author = {Rasmussen, Carl Edward and Williams, C. K. I.}, - title = {Gaussian processes for machine learning}, - year = {2006}, - publisher = {Massachusetts Institute of Technology}, -} - -@BOOK{hastie1990, - title = {Generalized Additive Models}, - publisher = {CRC Press}, - year = {1990}, - author = {Hastie, Trevor J and Tibshirani, Robert J}, - volume = {43}, - owner = {Paul}, - timestamp = {2015.09.07} -} - -@BOOK{gelman2014, - title = {Bayesian Data Analysis}, - publisher = {Taylor \& Francis}, - year = {2014}, - author = {Gelman, Andrew and Carlin, John B and Stern, Hal S and Rubin, Donald - B}, - volume = {2}, - owner = {Paul}, - timestamp = {2015.06.20} -} - -@Manual{stanM2017, - title = {Stan Modeling Language: User's Guide and Reference Manual}, - author = {{Stan Development Team}}, - year = {2017}, - owner = {Paul}, - timestamp = {2015.06.18}, - url = {http://mc-stan.org/manual.html}, -} - -@Article{carpenter2017, - author = {Carpenter, B. and Gelman, A. and Hoffman, M. and Lee, D. and Goodrich, B. and Betancourt, M. and Brubaker, M. A. and Guo, J. and Li, P. and Ridell, A.}, - title = {Stan: A Probabilistic Programming Language}, - journal = {Journal of Statistical Software}, - year = {2017}, - owner = {Paul}, - timestamp = {2015.06.19}, -} - -@ARTICLE{duane1987, - author = {Duane, Simon and Kennedy, Anthony D and Pendleton, Brian J and Roweth, - Duncan}, - title = {Hybrid Monte Carlo}, - journal = {Physics Letters B}, - year = {1987}, - volume = {195}, - pages = {216--222}, - number = {2}, - owner = {Paul}, - publisher = {Elsevier}, - timestamp = {2015.06.19} -} - -@InBook{neal2011, - chapter = {MCMC Using Hamiltonian Dynamics}, - title = {Handbook of Markov Chain Monte Carlo}, - publisher = {CRC Press}, - year = {2011}, - author = {Neal, Radford M}, - volume = {2}, - owner = {Paul}, - timestamp = {2015.06.19}, -} - -@Article{betancourt2014, - author = {Betancourt, MJ and Byrne, Simon and Livingstone, Samuel and Girolami, Mark}, - title = {The Geometric Foundations of Hamiltonian Monte Carlo}, - journal = {arXiv preprint arXiv:1410.5110}, - year = {2014}, -} - -@ARTICLE{hoffman2014, - author = {Hoffman, Matthew D and Gelman, Andrew}, - title = {The No-U-Turn Sampler: Adaptively Setting Path Lengths in Hamiltonian - Monte Carlo}, - journal = {The Journal of Machine Learning Research}, - year = {2014}, - volume = {15}, - pages = {1593--1623}, - number = {1}, - owner = {Paul}, - publisher = {JMLR. org}, - timestamp = {2015.06.19} -} - -@Article{betancourt2017, - author = {Michael Betancourt}, - title = {A Conceptual Introduction to Hamiltonian Monte Carlo}, - journal = {arXiv preprint}, - year = {2017}, - url = {https://arxiv.org/pdf/1701.02434.pdf}, -} - -@ARTICLE{bates2015, - author = {Douglas Bates and Martin M{\"a}chler and Ben Bolker and Steve Walker}, - title = {Fitting Linear Mixed-Effects Models Using \pkg{lme4}}, - journal = {Journal of Statistical Software}, - year = {2015}, - volume = {67}, - pages = {1--48}, - number = {1}, - owner = {Paul}, - timestamp = {2015.11.13} -} - -@Article{hadfield2010, - author = {Hadfield, Jarrod D}, - title = {MCMC Methods for Multi-Response Generalized Linear Mixed Models: the \pkg{MCMCglmm} {R} Package}, - journal = {Journal of Statistical Software}, - year = {2010}, - volume = {33}, - number = {2}, - pages = {1--22}, - owner = {Paul}, - timestamp = {2015.06.18}, -} - -@Manual{rstanarm2017, - title = {rstanarm: {Bayesian} applied regression modeling via {Stan}.}, - author = {{Stan Development Team}}, - year = {2017}, - note = {R package version 2.17.2}, - url = {http://mc-stan.org/}, -} - -@Manual{afex2015, - title = {\pkg{afex}: Analysis of Factorial Experiments}, - author = {Henrik Singmann and Ben Bolker and Jake Westfall}, - year = {2015}, - note = {R package version 0.15-2}, - owner = {Paul}, - timestamp = {2016.02.13}, - url = {https://CRAN.R-project.org/package=afex}, -} - -@Article{brms1, - author = {Paul-Christian B\"urkner}, - title = {\pkg{brms}: An {R} Package for Bayesian Multilevel Models using Stan}, - journal = {Journal of Statistical Software}, - year = {2017}, - encoding = {UTF-8}, -} - -@Article{wood2011, - author = {Wood, Simon N}, - title = {Fast Stable Restricted Maximum Likelihood and Marginal Likelihood Estimation of Semiparametric Generalized Linear Models}, - journal = {Journal of the Royal Statistical Society: Series B (Statistical Methodology)}, - year = {2011}, - volume = {73}, - number = {1}, - pages = {3--36}, - publisher = {Wiley Online Library}, -} - -@InProceedings{williams1996, - author = {Williams, Christopher KI and Rasmussen, Carl Edward}, - title = {Gaussian processes for regression}, - booktitle = {Advances in neural information processing systems}, - year = {1996}, - pages = {514--520}, -} - -@MANUAL{nlme2016, - title = {\pkg{nlme}: Linear and Nonlinear Mixed Effects Models}, - author = {Jose Pinheiro and Douglas Bates and Saikat DebRoy and Deepayan Sarkar - and {R Core Team}}, - year = {2016}, - note = {R package version 3.1-124}, - owner = {Paul}, - timestamp = {2016.03.06}, - url = {http://CRAN.R-project.org/package=nlme} -} - -@Article{westfall2016, - author = {Westfall, Jacob and Yarkoni, Tal}, - title = {Statistically Controlling for Confounding Constructs is Harder than You Think}, - journal = {PloS one}, - year = {2016}, - volume = {11}, - number = {3}, - pages = {e0152719}, - publisher = {Public Library of Science}, -} - -@Manual{loo2016, - title = {\pkg{loo}: {E}fficient Leave-One-Out Cross-Validation and {WAIC} for {B}ayesian Models.}, - author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, - year = {2016}, - note = {R package version 1.0.0}, - url = {https://github.com/stan-dev/loo}, -} - -@Manual{stan2017, - title = {Stan: A C++ Library for Probability and Sampling, Version 2.17.0}, - author = {{Stan Development Team}}, - year = {2017}, - owner = {Paul}, - timestamp = {2015.06.18}, - url = {http://mc-stan.org/}, -} - -@Comment{jabref-meta: databaseType:bibtex;} +% Encoding: UTF-8 +@Article{brms2, + title = {Advanced {Bayesian} Multilevel Modeling with the {R} Package {brms}}, + author = {Paul-Christian Bürkner}, + journal = {The R Journal}, + year = {2018}, + volume = {10}, + number = {1}, + pages = {395--411}, + doi = {10.32614/RJ-2018-017}, + encoding = {UTF-8}, +} + +@Article{vehtari2016, + author = {Vehtari, Aki and Gelman, Andrew and Gabry, Jonah}, + title = {Practical Bayesian Model Evaluation Using Leave-One-Out Cross-Validation and WAIC}, + journal = {Statistics and Computing}, + year = {2016}, + pages = {1--20}, + publisher = {Springer}, +} + +@Book{fahrmeir2013, + title = {Regression: models, methods and applications}, + publisher = {Springer Science \& Business Media}, + year = {2013}, + author = {Fahrmeir, Ludwig and Kneib, Thomas and Lang, Stefan and Marx, Brian}, +} + +@Manual{gamlss.data, + title = {gamlss.data: GAMLSS Data}, + author = {Mikis Stasinopoulos and Bob Rigby}, + year = {2016}, + note = {R package version 5.0-0}, + url = {https://CRAN.R-project.org/package=gamlss.data}, +} + +@Article{wood2013, + author = {Wood, Simon N and Scheipl, Fabian and Faraway, Julian J}, + title = {Straightforward intermediate rank tensor product smoothing in mixed models}, + journal = {Statistics and Computing}, + year = {2013}, + pages = {1--20}, + publisher = {Springer}, +} + +@Manual{mcelreath2017, + title = {rethinking: Statistical Rethinking Course and Book Package}, + author = {Richard McElreath}, + year = {2017}, + note = {R package version 1.59}, + owner = {Paul}, + timestamp = {2016.03.04}, + url = {https://github.com/rmcelreath/rethinking}, +} + +@Article{wagenmakers2010, + author = {Wagenmakers, Eric-Jan and Lodewyckx, Tom and Kuriyal, Himanshu and Grasman, Raoul}, + title = {Bayesian hypothesis testing for psychologists: A tutorial on the Savage--Dickey method}, + journal = {Cognitive psychology}, + year = {2010}, + volume = {60}, + number = {3}, + pages = {158--189}, + publisher = {Elsevier}, +} + +@Manual{bridgesampling2017, + title = {bridgesampling: Bridge Sampling for Marginal Likelihoods and Bayes Factors}, + author = {Quentin F. Gronau and Henrik Singmann}, + year = {2017}, + note = {R package version 0.4-0}, + url = {https://CRAN.R-project.org/package=bridgesampling}, +} + +@BOOK{brown2015, + title = {Applied Mixed Models in Medicine}, + publisher = {John Wiley \& Sons}, + year = {2015}, + author = {Brown, Helen and Prescott, Robin}, + owner = {Paul}, + timestamp = {2015.06.19} +} + +@Book{demidenko2013, + title = {Mixed Models: Theory and Applications with R}, + publisher = {John Wiley \& Sons}, + year = {2013}, + author = {Demidenko, Eugene}, + owner = {Paul}, + timestamp = {2015.06.19}, +} + +@Book{gelmanMLM2006, + title = {Data Analysis Using Regression and Multilevel/Hierarchical Models}, + publisher = {Cambridge University Press}, + year = {2006}, + author = {Gelman, Andrew and Hill, Jennifer}, + owner = {Paul}, + timestamp = {2016.02.21}, +} + +@Book{pinheiro2006, + title = {Mixed-Effects Models in S and S-PLUS}, + publisher = {Springer-Verlage Science \& Business Media}, + year = {2006}, + author = {Pinheiro, Jose and Bates, Douglas}, + owner = {Paul}, + timestamp = {2015.06.19}, +} + +@Article{rigby2005, + author = {Rigby, Robert A and Stasinopoulos, D Mikis}, + title = {Generalized Additive Models for Location, Scale and Shape}, + journal = {Journal of the Royal Statistical Society C (Applied Statistics)}, + year = {2005}, + volume = {54}, + number = {3}, + pages = {507--554}, + publisher = {Wiley Online Library}, +} + +@Article{lindstrom1990, + author = {Lindstrom, Mary J and Bates, Douglas M}, + title = {Nonlinear Mixed Effects Models for Repeated Measures Data}, + journal = {Biometrics}, + year = {1990}, + pages = {673--687}, + publisher = {JSTOR}, +} + +@Article{wood2004, + author = {Wood, Simon N}, + title = {Stable and Efficient Multiple Smoothing Parameter Estimation for Generalized Additive Models}, + journal = {Journal of the American Statistical Association}, + year = {2004}, + volume = {99}, + number = {467}, + pages = {673--686}, + publisher = {Taylor \& Francis}, +} + +@Article{rasmussen2006, + author = {Rasmussen, Carl Edward and Williams, C. K. I.}, + title = {Gaussian processes for machine learning}, + year = {2006}, + publisher = {Massachusetts Institute of Technology}, +} + +@BOOK{hastie1990, + title = {Generalized Additive Models}, + publisher = {CRC Press}, + year = {1990}, + author = {Hastie, Trevor J and Tibshirani, Robert J}, + volume = {43}, + owner = {Paul}, + timestamp = {2015.09.07} +} + +@BOOK{gelman2014, + title = {Bayesian Data Analysis}, + publisher = {Taylor \& Francis}, + year = {2014}, + author = {Gelman, Andrew and Carlin, John B and Stern, Hal S and Rubin, Donald + B}, + volume = {2}, + owner = {Paul}, + timestamp = {2015.06.20} +} + +@Manual{stanM2017, + title = {Stan Modeling Language: User's Guide and Reference Manual}, + author = {{Stan Development Team}}, + year = {2017}, + owner = {Paul}, + timestamp = {2015.06.18}, + url = {http://mc-stan.org/manual.html}, +} + +@Article{carpenter2017, + author = {Carpenter, B. and Gelman, A. and Hoffman, M. and Lee, D. and Goodrich, B. and Betancourt, M. and Brubaker, M. A. and Guo, J. and Li, P. and Ridell, A.}, + title = {Stan: A Probabilistic Programming Language}, + journal = {Journal of Statistical Software}, + year = {2017}, + owner = {Paul}, + timestamp = {2015.06.19}, +} + +@ARTICLE{duane1987, + author = {Duane, Simon and Kennedy, Anthony D and Pendleton, Brian J and Roweth, + Duncan}, + title = {Hybrid Monte Carlo}, + journal = {Physics Letters B}, + year = {1987}, + volume = {195}, + pages = {216--222}, + number = {2}, + owner = {Paul}, + publisher = {Elsevier}, + timestamp = {2015.06.19} +} + +@InBook{neal2011, + chapter = {MCMC Using Hamiltonian Dynamics}, + title = {Handbook of Markov Chain Monte Carlo}, + publisher = {CRC Press}, + year = {2011}, + author = {Neal, Radford M}, + volume = {2}, + owner = {Paul}, + timestamp = {2015.06.19}, +} + +@Article{betancourt2014, + author = {Betancourt, MJ and Byrne, Simon and Livingstone, Samuel and Girolami, Mark}, + title = {The Geometric Foundations of Hamiltonian Monte Carlo}, + journal = {arXiv preprint arXiv:1410.5110}, + year = {2014}, +} + +@ARTICLE{hoffman2014, + author = {Hoffman, Matthew D and Gelman, Andrew}, + title = {The No-U-Turn Sampler: Adaptively Setting Path Lengths in Hamiltonian + Monte Carlo}, + journal = {The Journal of Machine Learning Research}, + year = {2014}, + volume = {15}, + pages = {1593--1623}, + number = {1}, + owner = {Paul}, + publisher = {JMLR. org}, + timestamp = {2015.06.19} +} + +@Article{betancourt2017, + author = {Michael Betancourt}, + title = {A Conceptual Introduction to Hamiltonian Monte Carlo}, + journal = {arXiv preprint}, + year = {2017}, + url = {https://arxiv.org/pdf/1701.02434.pdf}, +} + +@ARTICLE{bates2015, + author = {Douglas Bates and Martin M{\"a}chler and Ben Bolker and Steve Walker}, + title = {Fitting Linear Mixed-Effects Models Using \pkg{lme4}}, + journal = {Journal of Statistical Software}, + year = {2015}, + volume = {67}, + pages = {1--48}, + number = {1}, + owner = {Paul}, + timestamp = {2015.11.13} +} + +@Article{hadfield2010, + author = {Hadfield, Jarrod D}, + title = {MCMC Methods for Multi-Response Generalized Linear Mixed Models: the \pkg{MCMCglmm} {R} Package}, + journal = {Journal of Statistical Software}, + year = {2010}, + volume = {33}, + number = {2}, + pages = {1--22}, + owner = {Paul}, + timestamp = {2015.06.18}, +} + +@Manual{rstanarm2017, + title = {rstanarm: {Bayesian} applied regression modeling via {Stan}.}, + author = {{Stan Development Team}}, + year = {2017}, + note = {R package version 2.17.2}, + url = {http://mc-stan.org/}, +} + +@Manual{afex2015, + title = {\pkg{afex}: Analysis of Factorial Experiments}, + author = {Henrik Singmann and Ben Bolker and Jake Westfall}, + year = {2015}, + note = {R package version 0.15-2}, + owner = {Paul}, + timestamp = {2016.02.13}, + url = {https://CRAN.R-project.org/package=afex}, +} + +@Article{brms1, + author = {Paul-Christian B\"urkner}, + title = {\pkg{brms}: An {R} Package for Bayesian Multilevel Models using Stan}, + journal = {Journal of Statistical Software}, + year = {2017}, + encoding = {UTF-8}, +} + +@Article{wood2011, + author = {Wood, Simon N}, + title = {Fast Stable Restricted Maximum Likelihood and Marginal Likelihood Estimation of Semiparametric Generalized Linear Models}, + journal = {Journal of the Royal Statistical Society: Series B (Statistical Methodology)}, + year = {2011}, + volume = {73}, + number = {1}, + pages = {3--36}, + publisher = {Wiley Online Library}, +} + +@InProceedings{williams1996, + author = {Williams, Christopher KI and Rasmussen, Carl Edward}, + title = {Gaussian processes for regression}, + booktitle = {Advances in neural information processing systems}, + year = {1996}, + pages = {514--520}, +} + +@MANUAL{nlme2016, + title = {\pkg{nlme}: Linear and Nonlinear Mixed Effects Models}, + author = {Jose Pinheiro and Douglas Bates and Saikat DebRoy and Deepayan Sarkar + and {R Core Team}}, + year = {2016}, + note = {R package version 3.1-124}, + owner = {Paul}, + timestamp = {2016.03.06}, + url = {http://CRAN.R-project.org/package=nlme} +} + +@Article{westfall2016, + author = {Westfall, Jacob and Yarkoni, Tal}, + title = {Statistically Controlling for Confounding Constructs is Harder than You Think}, + journal = {PloS one}, + year = {2016}, + volume = {11}, + number = {3}, + pages = {e0152719}, + publisher = {Public Library of Science}, +} + +@Manual{loo2016, + title = {\pkg{loo}: {E}fficient Leave-One-Out Cross-Validation and {WAIC} for {B}ayesian Models.}, + author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, + year = {2016}, + note = {R package version 1.0.0}, + url = {https://github.com/stan-dev/loo}, +} + +@Manual{stan2017, + title = {Stan: A C++ Library for Probability and Sampling, Version 2.17.0}, + author = {{Stan Development Team}}, + year = {2017}, + owner = {Paul}, + timestamp = {2015.06.18}, + url = {http://mc-stan.org/}, +} + +@Comment{jabref-meta: databaseType:bibtex;} diff -Nru r-cran-brms-2.16.3/vignettes/citations_overview.bib r-cran-brms-2.17.0/vignettes/citations_overview.bib --- r-cran-brms-2.16.3/vignettes/citations_overview.bib 2020-02-27 16:10:02.000000000 +0000 +++ r-cran-brms-2.17.0/vignettes/citations_overview.bib 2021-12-20 13:50:54.000000000 +0000 @@ -1,847 +1,847 @@ -% Encoding: UTF-8 -@Article{brms1, - author = {Paul-Christian B\"urkner}, - title = {{brms}: An {R} Package for Bayesian Multilevel Models using Stan}, - journal = {Journal of Statistical Software}, - year = {2017}, - volume = {80}, - number = {1}, - pages = {1--28}, - encoding = {UTF-8}, - doi = {10.18637/jss.v080.i01} -} - -@BOOK{brown2015, - title = {Applied Mixed Models in Medicine}, - publisher = {John Wiley \& Sons}, - year = {2015}, - author = {Brown, Helen and Prescott, Robin}, - owner = {Paul}, - timestamp = {2015.06.19} -} - -@ARTICLE{lunn2000, - author = {Lunn, David J and Thomas, Andrew and Best, Nicky and Spiegelhalter, - David}, - title = {\pkg{WinBUGS} a Bayesian Modelling Framework: Concepts, Structure, - and Extensibility}, - journal = {Statistics and {C}omputing}, - year = {2000}, - volume = {10}, - pages = {325--337}, - number = {4}, - owner = {Paul}, - publisher = {Springer}, - timestamp = {2015.06.18} -} - -@MANUAL{spiegelhalter2003, - title = {\pkg{WinBUGS} Version - 1.4 User Manual}, - author = {Spiegelhalter, David and Thomas, Andrew and Best, Nicky and Lunn, - Dave}, - year = {2003}, - journal = {MRC Biostatistics Unit, Cambridge}, - owner = {Paul}, - publisher = {version}, - timestamp = {2015.06.18}, - url = {http://www.mrc-bsu.cam.ac.uk/bugs} -} - -@MANUAL{spiegelhalter2007, - title = {\pkg{OpenBUGS} User Manual, Version 3.0.2}, - author = {Spiegelhalter, D and Thomas, A and Best, N and Lunn, D}, - year = {2007}, - journal = {MRC Biostatistics Unit, Cambridge}, - owner = {Paul}, - timestamp = {2015.06.18} -} - -@MANUAL{plummer2013, - title = {\pkg{JAGS}: Just Another Gibs Sampler}, - author = {Plummer, Martyn}, - year = {2013}, - owner = {Paul}, - timestamp = {2015.01.20}, - url = {http://mcmc-jags.sourceforge.net/} -} - -@ARTICLE{hadfield2010, - author = {Hadfield, Jarrod D}, - title = {MCMC Methods for Multi-Response Generalized Linear Mixed Models: - the \pkg{MCMCglmm} \proglang{R} Package}, - journal = {Journal of Statistical Software}, - year = {2010}, - volume = {33}, - pages = {1--22}, - number = {2}, - owner = {Paul}, - timestamp = {2015.06.18} -} - -@Manual{stan2017, - title = {\proglang{Stan}: A \proglang{C++} Library for Probability and Sampling, Version 2.14.0}, - author = {{Stan Development Team}}, - year = {2017}, - owner = {Paul}, - timestamp = {2015.06.18}, - url = {http://mc-stan.org/}, -} - -@Article{carpenter2017, - author = {Carpenter, B. and Gelman, A. and Hoffman, M. and Lee, D. and Goodrich, B. and Betancourt, M. and Brubaker, M. A. and Guo, J. and Li, P. and Ridell, A.}, - title = {\proglang{Stan}: A Probabilistic Programming Language}, - journal = {Journal of Statistical Software}, - year = {2017}, - owner = {Paul}, - timestamp = {2015.06.19}, -} - -@ARTICLE{metropolis1953, - author = {Metropolis, Nicholas and Rosenbluth, Arianna W and Rosenbluth, Marshall - N and Teller, Augusta H and Teller, Edward}, - title = {Equation of State Calculations by Fast Computing Machines}, - journal = {The Journal of Chemical Physics}, - year = {1953}, - volume = {21}, - pages = {1087--1092}, - number = {6}, - owner = {Paul}, - publisher = {AIP Publishing}, - timestamp = {2015.06.19} -} - -@ARTICLE{hastings1970, - author = {Hastings, W Keith}, - title = {Monte Carlo Sampling Methods Using Markov Chains and their Applications}, - journal = {Biometrika}, - year = {1970}, - volume = {57}, - pages = {97--109}, - number = {1}, - owner = {Paul}, - publisher = {Biometrika Trust}, - timestamp = {2015.06.19} -} - -@ARTICLE{geman1984, - author = {Geman, Stuart and Geman, Donald}, - title = {Stochastic Relaxation, Gibbs Distributions, and the Bayesian Restoration - of Images}, - journal = {IEEE Transactions on Pattern Analysis and Machine Intelligence}, - year = {1984}, - pages = {721--741}, - number = {6}, - owner = {Paul}, - publisher = {IEEE}, - timestamp = {2015.06.19} -} - -@ARTICLE{gelfand1990, - author = {Gelfand, Alan E and Smith, Adrian FM}, - title = {Sampling-Based Approaches to Calculating Marginal Densities}, - journal = {Journal of the American Statistical Association}, - year = {1990}, - volume = {85}, - pages = {398--409}, - number = {410}, - owner = {Paul}, - publisher = {Taylor \& Francis Group}, - timestamp = {2015.06.19} -} - -@ARTICLE{damien1999, - author = {Damien, Paul and Wakefield, Jon and Walker, Stephen}, - title = {Gibbs Sampling for Bayesian Non-Conjugate and Hierarchical Models - by Using Auxiliary Variables}, - journal = {Journal of the Royal Statistical Society B, Statistical Methodology}, - year = {1999}, - pages = {331--344}, - owner = {Paul}, - publisher = {JSTOR}, - timestamp = {2015.06.19} -} - -@ARTICLE{neal2003, - author = {Neal, Radford M.}, - title = {Slice Sampling}, - journal = {The Annals of Statistics}, - year = {2003}, - pages = {705--741}, - owner = {Paul}, - publisher = {JSTOR}, - timestamp = {2015.06.19} -} - -@InBook{neal2011, - chapter = {MCMC Using Hamiltonian Dynamics}, - title = {Handbook of Markov Chain Monte Carlo}, - publisher = {CRC Press}, - year = {2011}, - author = {Neal, Radford M}, - volume = {2}, - owner = {Paul}, - timestamp = {2015.06.19}, -} - -@ARTICLE{hoffman2014, - author = {Hoffman, Matthew D and Gelman, Andrew}, - title = {The No-U-Turn Sampler: Adaptively Setting Path Lengths in Hamiltonian - Monte Carlo}, - journal = {The Journal of Machine Learning Research}, - year = {2014}, - volume = {15}, - pages = {1593--1623}, - number = {1}, - owner = {Paul}, - publisher = {JMLR. org}, - timestamp = {2015.06.19} -} - -@BOOK{gelman2014, - title = {Bayesian Data Analysis}, - publisher = {Taylor \& Francis}, - year = {2014}, - author = {Gelman, Andrew and Carlin, John B and Stern, Hal S and Rubin, Donald - B}, - volume = {2}, - owner = {Paul}, - timestamp = {2015.06.20} -} - -@Manual{stanM2017, - title = {\proglang{Stan} Modeling Language: User's Guide and Reference Manual}, - author = {{Stan Development Team}}, - year = {2017}, - owner = {Paul}, - timestamp = {2015.06.18}, - url = {http://mc-stan.org/manual.html}, -} - -@Article{rigby2005, - author = {Rigby, Robert A and Stasinopoulos, D Mikis}, - title = {Generalized Additive Models for Location, Scale and Shape}, - journal = {Journal of the Royal Statistical Society C (Applied Statistics)}, - year = {2005}, - volume = {54}, - number = {3}, - pages = {507--554}, - publisher = {Wiley Online Library}, -} - -@Article{lindstrom1990, - author = {Lindstrom, Mary J and Bates, Douglas M}, - title = {Nonlinear Mixed Effects Models for Repeated Measures Data}, - journal = {Biometrics}, - year = {1990}, - pages = {673--687}, - publisher = {JSTOR}, -} - -@Article{wood2004, - author = {Wood, Simon N}, - title = {Stable and Efficient Multiple Smoothing Parameter Estimation for Generalized Additive Models}, - journal = {Journal of the American Statistical Association}, - year = {2004}, - volume = {99}, - number = {467}, - pages = {673--686}, - publisher = {Taylor \& Francis}, -} - -@Article{rasmussen2006, - author = {Rasmussen, Carl Edward and Williams, C. K. I.}, - title = {Gaussian processes for machine learning}, - year = {2006}, - publisher = {Massachusetts Institute of Technology}, -} - -@Article{betancourt2014, - author = {Betancourt, MJ and Byrne, Simon and Livingstone, Samuel and Girolami, Mark}, - title = {The Geometric Foundations of Hamiltonian Monte Carlo}, - journal = {arXiv preprint arXiv:1410.5110}, - year = {2014}, -} - -@Article{betancourt2017, - author = {Michael Betancourt}, - title = {A Conceptual Introduction to Hamiltonian Monte Carlo}, - journal = {arXiv preprint}, - year = {2017}, - url = {https://arxiv.org/pdf/1701.02434.pdf}, -} - -@Manual{rstanarm2017, - title = {rstanarm: {Bayesian} applied regression modeling via {Stan}.}, - author = {{Stan Development Team}}, - year = {2017}, - note = {R package version 2.17.2}, - url = {http://mc-stan.org/}, -} - -@InProceedings{williams1996, - author = {Williams, Christopher KI and Rasmussen, Carl Edward}, - title = {Gaussian processes for regression}, - booktitle = {Advances in neural information processing systems}, - year = {1996}, - pages = {514--520}, -} - -@Article{westfall2016, - author = {Westfall, Jacob and Yarkoni, Tal}, - title = {Statistically Controlling for Confounding Constructs is Harder than You Think}, - journal = {PloS one}, - year = {2016}, - volume = {11}, - number = {3}, - pages = {e0152719}, - publisher = {Public Library of Science}, -} - -@BOOK{demidenko2013, - title = {Mixed Models: Theory and Applications with \proglang{R}}, - publisher = {John Wiley \& Sons}, - year = {2013}, - author = {Demidenko, Eugene}, - owner = {Paul}, - timestamp = {2015.06.19} -} - -@Book{pinheiro2006, - title = {Mixed-Effects Models in \proglang{S} and \proglang{S-PLUS}}, - publisher = {Springer-Verlage Science \& Business Media}, - year = {2006}, - author = {Pinheiro, Jose and Bates, Douglas}, - owner = {Paul}, - timestamp = {2015.06.19}, -} - -@MANUAL{Rcore2015, - title = {\proglang{R}: A Language and Environment for Statistical Computing}, - author = {{R Core Team}}, - organization = {\proglang{R} Foundation for Statistical Computing}, - address = {Vienna, Austria}, - year = {2015}, - owner = {Paul}, - timestamp = {2015.01.20}, - url = {http://www.R-project.org/} -} - -@ARTICLE{bates2015, - author = {Douglas Bates and Martin M{\"a}chler and Ben Bolker and Steve Walker}, - title = {Fitting Linear Mixed-Effects Models Using \pkg{lme4}}, - journal = {Journal of Statistical Software}, - year = {2015}, - volume = {67}, - pages = {1--48}, - number = {1}, - owner = {Paul}, - timestamp = {2015.11.13} -} - -@ARTICLE{mcgilchrist1991, - author = {McGilchrist, CA and Aisbett, CW}, - title = {Regression with Frailty in Survival Analysis}, - journal = {Biometrics}, - year = {1991}, - pages = {461--466}, - owner = {Paul}, - publisher = {JSTOR}, - timestamp = {2015.08.15} -} - -@ARTICLE{ezzet1991, - author = {Ezzet, Farkad and Whitehead, John}, - title = {A Random Effects Model for Ordinal Responses from a Crossover Trial}, - journal = {Statistics in Medicine}, - year = {1991}, - volume = {10}, - pages = {901--907}, - number = {6}, - owner = {Paul}, - publisher = {Wiley Online Library}, - timestamp = {2015.09.03} -} - -@Book{gelmanMLM2006, - title = {Data Analysis Using Regression and Multilevel/Hierarchical Models}, - publisher = {Cambridge University Press}, - year = {2006}, - author = {Gelman, Andrew and Hill, Jennifer}, - owner = {Paul}, - timestamp = {2016.02.21}, -} - -@Book{fox2011, - title = {An R companion to Applied Regression, Second Edition}, - publisher = {Sage}, - year = {2011}, - author = {Fox, John and Weisberg, Sanford}, -} - -@ARTICLE{lewandowski2009, - author = {Lewandowski, Daniel and Kurowicka, Dorota and Joe, Harry}, - title = {Generating Random Correlation Matrices Based on Vines and Extended - Onion Method}, - journal = {Journal of Multivariate Analysis}, - year = {2009}, - volume = {100}, - pages = {1989--2001}, - number = {9}, - owner = {Paul}, - publisher = {Elsevier}, - timestamp = {2015.07.23} -} - -@ARTICLE{juarez2010, - author = {Ju{\'a}rez, Miguel A and Steel, Mark FJ}, - title = {Model-Based Clustering of Non-Gaussian Panel Data Based on Skew-t - Distributions}, - journal = {Journal of Business \& Economic Statistics}, - year = {2010}, - volume = {28}, - pages = {52--66}, - number = {1}, - owner = {Paul}, - publisher = {Taylor \& Francis}, - timestamp = {2015.11.06} -} - -@ARTICLE{creutz1988, - author = {Creutz, Michael}, - title = {Global Monte Carlo Algorithms for Many-Fermion Systems}, - journal = {Physical Review D}, - year = {1988}, - volume = {38}, - pages = {1228}, - number = {4}, - owner = {Paul}, - publisher = {APS}, - timestamp = {2015.08.10} -} - -@BOOK{griewank2008, - title = {Evaluating Derivatives: Principles and Techniques of Algorithmic - Differentiation}, - publisher = {Siam}, - year = {2008}, - author = {Griewank, Andreas and Walther, Andrea}, - owner = {Paul}, - timestamp = {2015.08.10} -} - -@ARTICLE{watanabe2010, - author = {Watanabe, Sumio}, - title = {Asymptotic Equivalence of Bayes Cross Validation and Widely Applicable - Information Criterion in Singular Learning Theory}, - journal = {The Journal of Machine Learning Research}, - year = {2010}, - volume = {11}, - pages = {3571--3594}, - owner = {Paul}, - publisher = {JMLR. org}, - timestamp = {2015.08.10} -} - -@TECHREPORT{gelfand1992, - author = {Gelfand, Alan E and Dey, Dipak K and Chang, Hong}, - title = {Model Determination Using Predictive Distributions with Implementation - via Sampling-Based Methods}, - institution = {DTIC Document}, - year = {1992}, - owner = {Paul}, - timestamp = {2015.08.17} -} - -@ARTICLE{ionides2008, - author = {Ionides, Edward L}, - title = {Truncated Importance Sampling}, - journal = {Journal of Computational and Graphical Statistics}, - year = {2008}, - volume = {17}, - pages = {295--311}, - number = {2}, - owner = {Paul}, - publisher = {Taylor \& Francis}, - timestamp = {2015.08.17} -} - -@ARTICLE{vehtari2015, - author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, - title = {Efficient Implementation of Leave-One-Out Cross-Validation and WAIC - for Evaluating Fitted Bayesian Models}, - journal = {Unpublished manuscript}, - year = {2015}, - pages = {1--22}, - owner = {Paul}, - timestamp = {2015.08.26}, - url = {http://www.stat.columbia.edu/~gelman/research/unpublished/loo_stan.pdf} -} - -@ARTICLE{vanderlinde2005, - author = {van der Linde, Angelika}, - title = {DIC in Variable Selection}, - journal = {Statistica Neerlandica}, - year = {2005}, - volume = {59}, - pages = {45--56}, - number = {1}, - owner = {Paul}, - publisher = {Wiley Online Library}, - timestamp = {2015.08.10} -} - -@Manual{loo2016, - title = {\pkg{loo}: {E}fficient Leave-One-Out Cross-Validation and {WAIC} for {B}ayesian Models.}, - author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, - year = {2016}, - note = {R package version 1.0.0}, - url = {https://github.com/stan-dev/loo}, -} - -@MANUAL{Xcode2015, - title = {\pkg{Xcode} Software, Version~7}, - author = {{Apple Inc.}}, - address = {Cupertino, USA}, - year = {2015}, - owner = {Paul}, - timestamp = {2015.01.20}, - url = {https://developer.apple.com/xcode/} -} - -@Article{masters1982, - author = {Masters, Geoff N}, - title = {A {R}asch Model for Partial Credit Scoring}, - journal = {Psychometrika}, - year = {1982}, - volume = {47}, - number = {2}, - pages = {149--174}, - owner = {Paul}, - publisher = {Springer}, - timestamp = {2015.02.08}, -} - -@ARTICLE{tutz1990, - author = {Tutz, Gerhard}, - title = {Sequential Item Response Models with an Ordered Response}, - journal = {British Journal of Mathematical and Statistical Psychology}, - year = {1990}, - volume = {43}, - pages = {39--55}, - number = {1}, - owner = {Paul}, - publisher = {Wiley Online Library}, - timestamp = {2015.02.01} -} - -@ARTICLE{yee2010, - author = {Yee, Thomas W}, - title = {The \pkg{VGAM} Package for Categorical Data Analysis}, - journal = {Journal of Statistical Software}, - year = {2010}, - volume = {32}, - pages = {1--34}, - number = {10}, - owner = {Paul}, - timestamp = {2015.09.04} -} - -@ARTICLE{andrich1978b, - author = {Andrich, David}, - title = {Application of a Psychometric Rating Model to Ordered Categories - which are Scored with Successive Integers}, - journal = {Applied Psychological Measurement}, - year = {1978}, - volume = {2}, - pages = {581--594}, - number = {4}, - owner = {Paul}, - publisher = {Sage Publications}, - timestamp = {2015.01.27} -} - -@ARTICLE{andersen1977, - author = {Andersen, Erling B}, - title = {Sufficient Statistics and Latent Trait Models}, - journal = {Psychometrika}, - year = {1977}, - volume = {42}, - pages = {69--81}, - number = {1}, - owner = {Paul}, - publisher = {Springer}, - timestamp = {2015.01.27} -} - -@ARTICLE{vanderark2001, - author = {Van Der Ark, L Andries}, - title = {Relationships and Properties of Polytomous Item Response Theory Models}, - journal = {Applied Psychological Measurement}, - year = {2001}, - volume = {25}, - pages = {273--282}, - number = {3}, - owner = {Paul}, - publisher = {Sage Publications}, - timestamp = {2015.01.26} -} - -@Book{tutz2000, - title = {Die {A}nalyse {K}ategorialer {D}aten: {A}nwendungsorientierte {E}inf{\"u}hrung in {L}ogit-{M}odellierung und {K}ategoriale {R}egression}, - publisher = {Oldenbourg Verlag}, - year = {2000}, - author = {Tutz, Gerhard}, - owner = {Paul}, - timestamp = {2015.01.23}, -} - -@MANUAL{rstanarm2016, - title = {rstanarm: Bayesian Applied Regression Modeling via \pkg{Stan}}, - author = {Jonah Gabry and Ben Goodrich}, - year = {2016}, - note = {R package version 2.9.0-3}, - owner = {Paul}, - timestamp = {2016.03.04}, - url = {https://CRAN.R-project.org/package=rstanarm} -} - -@MANUAL{mcelreath2016, - title = {rethinking: Statistical Rethinking Course and Book Package}, - author = {Richard McElreath}, - year = {2016}, - note = {R package version 1.58}, - owner = {Paul}, - timestamp = {2016.03.04}, - url = {https://github.com/rmcelreath/rethinking} -} - -@MANUAL{nlme2016, - title = {\pkg{nlme}: Linear and Nonlinear Mixed Effects Models}, - author = {Jose Pinheiro and Douglas Bates and Saikat DebRoy and Deepayan Sarkar - and {R Core Team}}, - year = {2016}, - note = {R package version 3.1-124}, - owner = {Paul}, - timestamp = {2016.03.06}, - url = {http://CRAN.R-project.org/package=nlme} -} - -@BOOK{hastie1990, - title = {Generalized Additive Models}, - publisher = {CRC Press}, - year = {1990}, - author = {Hastie, Trevor J and Tibshirani, Robert J}, - volume = {43}, - owner = {Paul}, - timestamp = {2015.09.07} -} - -@Article{wood2011, - author = {Wood, Simon N}, - title = {Fast Stable Restricted Maximum Likelihood and Marginal Likelihood Estimation of Semiparametric Generalized Linear Models}, - journal = {Journal of the Royal Statistical Society: Series B (Statistical Methodology)}, - year = {2011}, - volume = {73}, - number = {1}, - pages = {3--36}, - publisher = {Wiley Online Library}, -} - -@BOOK{zuur2014, - title = {A beginner's Guide to Generalized Additive Models with \proglang{R}}, - publisher = {Highland Statistics Limited}, - year = {2014}, - author = {Zuur, Alain F}, - owner = {Paul}, - timestamp = {2016.03.04} -} - - -@ARTICLE{chung2013, - author = {Yeojin Chung and Sophia Rabe-Hesketh and Vincent Dorie and Andrew - Gelman and Jingchen Liu}, - title = {A nondegenerate penalized likelihood estimator for variance parameters - in multilevel models}, - journal = {Psychometrika}, - year = {2013}, - volume = {78}, - pages = {685--709}, - number = {4}, - owner = {Paul}, - publisher = {Springer}, - timestamp = {2016.02.22}, - url = {http://gllamm.org/} -} - -@ARTICLE{duane1987, - author = {Duane, Simon and Kennedy, Anthony D and Pendleton, Brian J and Roweth, - Duncan}, - title = {Hybrid Monte Carlo}, - journal = {Physics Letters B}, - year = {1987}, - volume = {195}, - pages = {216--222}, - number = {2}, - owner = {Paul}, - publisher = {Elsevier}, - timestamp = {2015.06.19} -} - -@ARTICLE{natarajan2000, - author = {Natarajan, Ranjini and Kass, Robert E}, - title = {Reference Bayesian Methods for Generalized Linear Mixed Models}, - journal = {Journal of the American Statistical Association}, - year = {2000}, - volume = {95}, - pages = {227--237}, - number = {449}, - owner = {Paul}, - publisher = {Taylor \& Francis}, - timestamp = {2015.07.23} -} - -@ARTICLE{kass2006, - author = {Kass, Robert E and Natarajan, Ranjini}, - title = {A Default Conjugate Prior for Variance Components in Generalized - Linear Mixed Models (Comment on Article by Browne and Draper)}, - journal = {Bayesian Analysis}, - year = {2006}, - volume = {1}, - pages = {535--542}, - number = {3}, - owner = {Paul}, - publisher = {International Society for Bayesian Analysis}, - timestamp = {2015.07.23} -} - -@ARTICLE{plummer2008, - author = {Plummer, Martyn}, - title = {Penalized Loss Functions for Bayesian Model Comparison}, - journal = {Biostatistics}, - year = {2008}, - owner = {Paul}, - publisher = {Biometrika Trust}, - timestamp = {2015.08.10} -} - -@ARTICLE{spiegelhalter2002, - author = {Spiegelhalter, David J and Best, Nicola G and Carlin, Bradley P and - Van Der Linde, Angelika}, - title = {Bayesian Measures of Model Complexity and Fit}, - journal = {Journal of the Royal Statistical Society B, Statistical Methodology}, - year = {2002}, - volume = {64}, - pages = {583--639}, - number = {4}, - owner = {Paul}, - publisher = {Wiley Online Library}, - timestamp = {2015.09.02} -} - -@MANUAL{Rtools2015, - title = {\pkg{Rtools} Software, Version~3.3}, - author = {{R Core Team}}, - organization = {\proglang{R} Foundation for Statistical Computing}, - address = {Vienna, Austria}, - year = {2015}, - owner = {Paul}, - timestamp = {2015.01.20}, - url = {https://cran.r-project.org/bin/windows/Rtools/} -} - -@Manual{afex2015, - title = {\pkg{afex}: Analysis of Factorial Experiments}, - author = {Henrik Singmann and Ben Bolker and Jake Westfall}, - year = {2015}, - note = {R package version 0.15-2}, - owner = {Paul}, - timestamp = {2016.02.13}, - url = {https://CRAN.R-project.org/package=afex}, -} - -@INPROCEEDINGS{carvalho2009, - author = {Carvalho, Carlos M and Polson, Nicholas G and Scott, James G}, - title = {Handling Sparsity via the Horseshoe}, - booktitle = {International Conference on Artificial Intelligence and Statistics}, - year = {2009}, - pages = {73--80}, - owner = {Paul}, - timestamp = {2015.11.09} -} - -@ARTICLE{carvalho2010, - author = {Carvalho, Carlos M and Polson, Nicholas G and Scott, James G}, - title = {The Horseshoe Estimator for Sparse Signals}, - journal = {Biometrika}, - year = {2010}, - pages = {1--16}, - owner = {Paul}, - publisher = {Biometrika Trust}, - timestamp = {2015.11.09} -} - -@ARTICLE{gelman2006, - author = {Gelman, Andrew}, - title = {Prior Distributions for Variance Parameters in Hierarchical Models}, - journal = {Bayesian Analysis}, - year = {2006}, - volume = {1}, - pages = {515--534}, - number = {3}, - owner = {Paul}, - publisher = {International Society for Bayesian Analysis}, - timestamp = {2015.07.15} -} - -@Article{gelman1992, - author = {Gelman, Andrew and Rubin, Donald B}, - title = {Inference from Iterative Simulation Using Multiple Sequences}, - journal = {Statistical Science}, - year = {1992}, - pages = {457--472}, - publisher = {JSTOR}, -} - -@MANUAL{gabry2015, - title = {\pkg{shinystan}: Interactive Visual and Numerical Diagnostics and - Posterior Analysis for Bayesian Models}, - author = {Jonah Gabry}, - year = {2015}, - note = {\proglang{R}~Package Version~2.0.0}, - owner = {Paul}, - timestamp = {2015.08.26}, - url = {http://CRAN.R-project.org/package=shinystan} -} - -@ARTICLE{samejima1969, - author = {Samejima, Fumiko}, - title = {Estimation of Latent Ability Using a Response Pattern of Graded Scores}, - journal = {Psychometrika Monograph Supplement}, - year = {1969}, - owner = {Paul}, - timestamp = {2015.01.27} -} - -@MISC{christensen2015, - author = {R. H. B. Christensen}, - title = {\pkg{ordinal} -- Regression Models for Ordinal Data}, - year = {2015}, - note = {\proglang{R} package version 2015.6-28. http://www.cran.r-project.org/package=ordinal/}, - owner = {Paul}, - timestamp = {2015.09.04} -} - -@ARTICLE{andrich1978a, - author = {Andrich, David}, - title = {A Rating Formulation for Ordered Response Categories}, - journal = {Psychometrika}, - year = {1978}, - volume = {43}, - pages = {561--573}, - number = {4}, - owner = {Paul}, - publisher = {Springer}, - timestamp = {2015.01.27} -} - -@Comment{jabref-meta: databaseType:bibtex;} +% Encoding: UTF-8 +@Article{brms1, + author = {Paul-Christian B\"urkner}, + title = {{brms}: An {R} Package for Bayesian Multilevel Models using Stan}, + journal = {Journal of Statistical Software}, + year = {2017}, + volume = {80}, + number = {1}, + pages = {1--28}, + encoding = {UTF-8}, + doi = {10.18637/jss.v080.i01} +} + +@BOOK{brown2015, + title = {Applied Mixed Models in Medicine}, + publisher = {John Wiley \& Sons}, + year = {2015}, + author = {Brown, Helen and Prescott, Robin}, + owner = {Paul}, + timestamp = {2015.06.19} +} + +@ARTICLE{lunn2000, + author = {Lunn, David J and Thomas, Andrew and Best, Nicky and Spiegelhalter, + David}, + title = {\pkg{WinBUGS} a Bayesian Modelling Framework: Concepts, Structure, + and Extensibility}, + journal = {Statistics and {C}omputing}, + year = {2000}, + volume = {10}, + pages = {325--337}, + number = {4}, + owner = {Paul}, + publisher = {Springer}, + timestamp = {2015.06.18} +} + +@MANUAL{spiegelhalter2003, + title = {\pkg{WinBUGS} Version - 1.4 User Manual}, + author = {Spiegelhalter, David and Thomas, Andrew and Best, Nicky and Lunn, + Dave}, + year = {2003}, + journal = {MRC Biostatistics Unit, Cambridge}, + owner = {Paul}, + publisher = {version}, + timestamp = {2015.06.18}, + url = {http://www.mrc-bsu.cam.ac.uk/bugs} +} + +@MANUAL{spiegelhalter2007, + title = {\pkg{OpenBUGS} User Manual, Version 3.0.2}, + author = {Spiegelhalter, D and Thomas, A and Best, N and Lunn, D}, + year = {2007}, + journal = {MRC Biostatistics Unit, Cambridge}, + owner = {Paul}, + timestamp = {2015.06.18} +} + +@MANUAL{plummer2013, + title = {\pkg{JAGS}: Just Another Gibs Sampler}, + author = {Plummer, Martyn}, + year = {2013}, + owner = {Paul}, + timestamp = {2015.01.20}, + url = {http://mcmc-jags.sourceforge.net/} +} + +@ARTICLE{hadfield2010, + author = {Hadfield, Jarrod D}, + title = {MCMC Methods for Multi-Response Generalized Linear Mixed Models: + the \pkg{MCMCglmm} \proglang{R} Package}, + journal = {Journal of Statistical Software}, + year = {2010}, + volume = {33}, + pages = {1--22}, + number = {2}, + owner = {Paul}, + timestamp = {2015.06.18} +} + +@Manual{stan2017, + title = {\proglang{Stan}: A \proglang{C++} Library for Probability and Sampling, Version 2.14.0}, + author = {{Stan Development Team}}, + year = {2017}, + owner = {Paul}, + timestamp = {2015.06.18}, + url = {http://mc-stan.org/}, +} + +@Article{carpenter2017, + author = {Carpenter, B. and Gelman, A. and Hoffman, M. and Lee, D. and Goodrich, B. and Betancourt, M. and Brubaker, M. A. and Guo, J. and Li, P. and Ridell, A.}, + title = {\proglang{Stan}: A Probabilistic Programming Language}, + journal = {Journal of Statistical Software}, + year = {2017}, + owner = {Paul}, + timestamp = {2015.06.19}, +} + +@ARTICLE{metropolis1953, + author = {Metropolis, Nicholas and Rosenbluth, Arianna W and Rosenbluth, Marshall + N and Teller, Augusta H and Teller, Edward}, + title = {Equation of State Calculations by Fast Computing Machines}, + journal = {The Journal of Chemical Physics}, + year = {1953}, + volume = {21}, + pages = {1087--1092}, + number = {6}, + owner = {Paul}, + publisher = {AIP Publishing}, + timestamp = {2015.06.19} +} + +@ARTICLE{hastings1970, + author = {Hastings, W Keith}, + title = {Monte Carlo Sampling Methods Using Markov Chains and their Applications}, + journal = {Biometrika}, + year = {1970}, + volume = {57}, + pages = {97--109}, + number = {1}, + owner = {Paul}, + publisher = {Biometrika Trust}, + timestamp = {2015.06.19} +} + +@ARTICLE{geman1984, + author = {Geman, Stuart and Geman, Donald}, + title = {Stochastic Relaxation, Gibbs Distributions, and the Bayesian Restoration + of Images}, + journal = {IEEE Transactions on Pattern Analysis and Machine Intelligence}, + year = {1984}, + pages = {721--741}, + number = {6}, + owner = {Paul}, + publisher = {IEEE}, + timestamp = {2015.06.19} +} + +@ARTICLE{gelfand1990, + author = {Gelfand, Alan E and Smith, Adrian FM}, + title = {Sampling-Based Approaches to Calculating Marginal Densities}, + journal = {Journal of the American Statistical Association}, + year = {1990}, + volume = {85}, + pages = {398--409}, + number = {410}, + owner = {Paul}, + publisher = {Taylor \& Francis Group}, + timestamp = {2015.06.19} +} + +@ARTICLE{damien1999, + author = {Damien, Paul and Wakefield, Jon and Walker, Stephen}, + title = {Gibbs Sampling for Bayesian Non-Conjugate and Hierarchical Models + by Using Auxiliary Variables}, + journal = {Journal of the Royal Statistical Society B, Statistical Methodology}, + year = {1999}, + pages = {331--344}, + owner = {Paul}, + publisher = {JSTOR}, + timestamp = {2015.06.19} +} + +@ARTICLE{neal2003, + author = {Neal, Radford M.}, + title = {Slice Sampling}, + journal = {The Annals of Statistics}, + year = {2003}, + pages = {705--741}, + owner = {Paul}, + publisher = {JSTOR}, + timestamp = {2015.06.19} +} + +@InBook{neal2011, + chapter = {MCMC Using Hamiltonian Dynamics}, + title = {Handbook of Markov Chain Monte Carlo}, + publisher = {CRC Press}, + year = {2011}, + author = {Neal, Radford M}, + volume = {2}, + owner = {Paul}, + timestamp = {2015.06.19}, +} + +@ARTICLE{hoffman2014, + author = {Hoffman, Matthew D and Gelman, Andrew}, + title = {The No-U-Turn Sampler: Adaptively Setting Path Lengths in Hamiltonian + Monte Carlo}, + journal = {The Journal of Machine Learning Research}, + year = {2014}, + volume = {15}, + pages = {1593--1623}, + number = {1}, + owner = {Paul}, + publisher = {JMLR. org}, + timestamp = {2015.06.19} +} + +@BOOK{gelman2014, + title = {Bayesian Data Analysis}, + publisher = {Taylor \& Francis}, + year = {2014}, + author = {Gelman, Andrew and Carlin, John B and Stern, Hal S and Rubin, Donald + B}, + volume = {2}, + owner = {Paul}, + timestamp = {2015.06.20} +} + +@Manual{stanM2017, + title = {\proglang{Stan} Modeling Language: User's Guide and Reference Manual}, + author = {{Stan Development Team}}, + year = {2017}, + owner = {Paul}, + timestamp = {2015.06.18}, + url = {http://mc-stan.org/manual.html}, +} + +@Article{rigby2005, + author = {Rigby, Robert A and Stasinopoulos, D Mikis}, + title = {Generalized Additive Models for Location, Scale and Shape}, + journal = {Journal of the Royal Statistical Society C (Applied Statistics)}, + year = {2005}, + volume = {54}, + number = {3}, + pages = {507--554}, + publisher = {Wiley Online Library}, +} + +@Article{lindstrom1990, + author = {Lindstrom, Mary J and Bates, Douglas M}, + title = {Nonlinear Mixed Effects Models for Repeated Measures Data}, + journal = {Biometrics}, + year = {1990}, + pages = {673--687}, + publisher = {JSTOR}, +} + +@Article{wood2004, + author = {Wood, Simon N}, + title = {Stable and Efficient Multiple Smoothing Parameter Estimation for Generalized Additive Models}, + journal = {Journal of the American Statistical Association}, + year = {2004}, + volume = {99}, + number = {467}, + pages = {673--686}, + publisher = {Taylor \& Francis}, +} + +@Article{rasmussen2006, + author = {Rasmussen, Carl Edward and Williams, C. K. I.}, + title = {Gaussian processes for machine learning}, + year = {2006}, + publisher = {Massachusetts Institute of Technology}, +} + +@Article{betancourt2014, + author = {Betancourt, MJ and Byrne, Simon and Livingstone, Samuel and Girolami, Mark}, + title = {The Geometric Foundations of Hamiltonian Monte Carlo}, + journal = {arXiv preprint arXiv:1410.5110}, + year = {2014}, +} + +@Article{betancourt2017, + author = {Michael Betancourt}, + title = {A Conceptual Introduction to Hamiltonian Monte Carlo}, + journal = {arXiv preprint}, + year = {2017}, + url = {https://arxiv.org/pdf/1701.02434.pdf}, +} + +@Manual{rstanarm2017, + title = {rstanarm: {Bayesian} applied regression modeling via {Stan}.}, + author = {{Stan Development Team}}, + year = {2017}, + note = {R package version 2.17.2}, + url = {http://mc-stan.org/}, +} + +@InProceedings{williams1996, + author = {Williams, Christopher KI and Rasmussen, Carl Edward}, + title = {Gaussian processes for regression}, + booktitle = {Advances in neural information processing systems}, + year = {1996}, + pages = {514--520}, +} + +@Article{westfall2016, + author = {Westfall, Jacob and Yarkoni, Tal}, + title = {Statistically Controlling for Confounding Constructs is Harder than You Think}, + journal = {PloS one}, + year = {2016}, + volume = {11}, + number = {3}, + pages = {e0152719}, + publisher = {Public Library of Science}, +} + +@BOOK{demidenko2013, + title = {Mixed Models: Theory and Applications with \proglang{R}}, + publisher = {John Wiley \& Sons}, + year = {2013}, + author = {Demidenko, Eugene}, + owner = {Paul}, + timestamp = {2015.06.19} +} + +@Book{pinheiro2006, + title = {Mixed-Effects Models in \proglang{S} and \proglang{S-PLUS}}, + publisher = {Springer-Verlage Science \& Business Media}, + year = {2006}, + author = {Pinheiro, Jose and Bates, Douglas}, + owner = {Paul}, + timestamp = {2015.06.19}, +} + +@MANUAL{Rcore2015, + title = {\proglang{R}: A Language and Environment for Statistical Computing}, + author = {{R Core Team}}, + organization = {\proglang{R} Foundation for Statistical Computing}, + address = {Vienna, Austria}, + year = {2015}, + owner = {Paul}, + timestamp = {2015.01.20}, + url = {http://www.R-project.org/} +} + +@ARTICLE{bates2015, + author = {Douglas Bates and Martin M{\"a}chler and Ben Bolker and Steve Walker}, + title = {Fitting Linear Mixed-Effects Models Using \pkg{lme4}}, + journal = {Journal of Statistical Software}, + year = {2015}, + volume = {67}, + pages = {1--48}, + number = {1}, + owner = {Paul}, + timestamp = {2015.11.13} +} + +@ARTICLE{mcgilchrist1991, + author = {McGilchrist, CA and Aisbett, CW}, + title = {Regression with Frailty in Survival Analysis}, + journal = {Biometrics}, + year = {1991}, + pages = {461--466}, + owner = {Paul}, + publisher = {JSTOR}, + timestamp = {2015.08.15} +} + +@ARTICLE{ezzet1991, + author = {Ezzet, Farkad and Whitehead, John}, + title = {A Random Effects Model for Ordinal Responses from a Crossover Trial}, + journal = {Statistics in Medicine}, + year = {1991}, + volume = {10}, + pages = {901--907}, + number = {6}, + owner = {Paul}, + publisher = {Wiley Online Library}, + timestamp = {2015.09.03} +} + +@Book{gelmanMLM2006, + title = {Data Analysis Using Regression and Multilevel/Hierarchical Models}, + publisher = {Cambridge University Press}, + year = {2006}, + author = {Gelman, Andrew and Hill, Jennifer}, + owner = {Paul}, + timestamp = {2016.02.21}, +} + +@Book{fox2011, + title = {An R companion to Applied Regression, Second Edition}, + publisher = {Sage}, + year = {2011}, + author = {Fox, John and Weisberg, Sanford}, +} + +@ARTICLE{lewandowski2009, + author = {Lewandowski, Daniel and Kurowicka, Dorota and Joe, Harry}, + title = {Generating Random Correlation Matrices Based on Vines and Extended + Onion Method}, + journal = {Journal of Multivariate Analysis}, + year = {2009}, + volume = {100}, + pages = {1989--2001}, + number = {9}, + owner = {Paul}, + publisher = {Elsevier}, + timestamp = {2015.07.23} +} + +@ARTICLE{juarez2010, + author = {Ju{\'a}rez, Miguel A and Steel, Mark FJ}, + title = {Model-Based Clustering of Non-Gaussian Panel Data Based on Skew-t + Distributions}, + journal = {Journal of Business \& Economic Statistics}, + year = {2010}, + volume = {28}, + pages = {52--66}, + number = {1}, + owner = {Paul}, + publisher = {Taylor \& Francis}, + timestamp = {2015.11.06} +} + +@ARTICLE{creutz1988, + author = {Creutz, Michael}, + title = {Global Monte Carlo Algorithms for Many-Fermion Systems}, + journal = {Physical Review D}, + year = {1988}, + volume = {38}, + pages = {1228}, + number = {4}, + owner = {Paul}, + publisher = {APS}, + timestamp = {2015.08.10} +} + +@BOOK{griewank2008, + title = {Evaluating Derivatives: Principles and Techniques of Algorithmic + Differentiation}, + publisher = {Siam}, + year = {2008}, + author = {Griewank, Andreas and Walther, Andrea}, + owner = {Paul}, + timestamp = {2015.08.10} +} + +@ARTICLE{watanabe2010, + author = {Watanabe, Sumio}, + title = {Asymptotic Equivalence of Bayes Cross Validation and Widely Applicable + Information Criterion in Singular Learning Theory}, + journal = {The Journal of Machine Learning Research}, + year = {2010}, + volume = {11}, + pages = {3571--3594}, + owner = {Paul}, + publisher = {JMLR. org}, + timestamp = {2015.08.10} +} + +@TECHREPORT{gelfand1992, + author = {Gelfand, Alan E and Dey, Dipak K and Chang, Hong}, + title = {Model Determination Using Predictive Distributions with Implementation + via Sampling-Based Methods}, + institution = {DTIC Document}, + year = {1992}, + owner = {Paul}, + timestamp = {2015.08.17} +} + +@ARTICLE{ionides2008, + author = {Ionides, Edward L}, + title = {Truncated Importance Sampling}, + journal = {Journal of Computational and Graphical Statistics}, + year = {2008}, + volume = {17}, + pages = {295--311}, + number = {2}, + owner = {Paul}, + publisher = {Taylor \& Francis}, + timestamp = {2015.08.17} +} + +@ARTICLE{vehtari2015, + author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, + title = {Efficient Implementation of Leave-One-Out Cross-Validation and WAIC + for Evaluating Fitted Bayesian Models}, + journal = {Unpublished manuscript}, + year = {2015}, + pages = {1--22}, + owner = {Paul}, + timestamp = {2015.08.26}, + url = {http://www.stat.columbia.edu/~gelman/research/unpublished/loo_stan.pdf} +} + +@ARTICLE{vanderlinde2005, + author = {van der Linde, Angelika}, + title = {DIC in Variable Selection}, + journal = {Statistica Neerlandica}, + year = {2005}, + volume = {59}, + pages = {45--56}, + number = {1}, + owner = {Paul}, + publisher = {Wiley Online Library}, + timestamp = {2015.08.10} +} + +@Manual{loo2016, + title = {\pkg{loo}: {E}fficient Leave-One-Out Cross-Validation and {WAIC} for {B}ayesian Models.}, + author = {Aki Vehtari and Andrew Gelman and Jonah Gabry}, + year = {2016}, + note = {R package version 1.0.0}, + url = {https://github.com/stan-dev/loo}, +} + +@MANUAL{Xcode2015, + title = {\pkg{Xcode} Software, Version~7}, + author = {{Apple Inc.}}, + address = {Cupertino, USA}, + year = {2015}, + owner = {Paul}, + timestamp = {2015.01.20}, + url = {https://developer.apple.com/xcode/} +} + +@Article{masters1982, + author = {Masters, Geoff N}, + title = {A {R}asch Model for Partial Credit Scoring}, + journal = {Psychometrika}, + year = {1982}, + volume = {47}, + number = {2}, + pages = {149--174}, + owner = {Paul}, + publisher = {Springer}, + timestamp = {2015.02.08}, +} + +@ARTICLE{tutz1990, + author = {Tutz, Gerhard}, + title = {Sequential Item Response Models with an Ordered Response}, + journal = {British Journal of Mathematical and Statistical Psychology}, + year = {1990}, + volume = {43}, + pages = {39--55}, + number = {1}, + owner = {Paul}, + publisher = {Wiley Online Library}, + timestamp = {2015.02.01} +} + +@ARTICLE{yee2010, + author = {Yee, Thomas W}, + title = {The \pkg{VGAM} Package for Categorical Data Analysis}, + journal = {Journal of Statistical Software}, + year = {2010}, + volume = {32}, + pages = {1--34}, + number = {10}, + owner = {Paul}, + timestamp = {2015.09.04} +} + +@ARTICLE{andrich1978b, + author = {Andrich, David}, + title = {Application of a Psychometric Rating Model to Ordered Categories + which are Scored with Successive Integers}, + journal = {Applied Psychological Measurement}, + year = {1978}, + volume = {2}, + pages = {581--594}, + number = {4}, + owner = {Paul}, + publisher = {Sage Publications}, + timestamp = {2015.01.27} +} + +@ARTICLE{andersen1977, + author = {Andersen, Erling B}, + title = {Sufficient Statistics and Latent Trait Models}, + journal = {Psychometrika}, + year = {1977}, + volume = {42}, + pages = {69--81}, + number = {1}, + owner = {Paul}, + publisher = {Springer}, + timestamp = {2015.01.27} +} + +@ARTICLE{vanderark2001, + author = {Van Der Ark, L Andries}, + title = {Relationships and Properties of Polytomous Item Response Theory Models}, + journal = {Applied Psychological Measurement}, + year = {2001}, + volume = {25}, + pages = {273--282}, + number = {3}, + owner = {Paul}, + publisher = {Sage Publications}, + timestamp = {2015.01.26} +} + +@Book{tutz2000, + title = {Die {A}nalyse {K}ategorialer {D}aten: {A}nwendungsorientierte {E}inf{\"u}hrung in {L}ogit-{M}odellierung und {K}ategoriale {R}egression}, + publisher = {Oldenbourg Verlag}, + year = {2000}, + author = {Tutz, Gerhard}, + owner = {Paul}, + timestamp = {2015.01.23}, +} + +@MANUAL{rstanarm2016, + title = {rstanarm: Bayesian Applied Regression Modeling via \pkg{Stan}}, + author = {Jonah Gabry and Ben Goodrich}, + year = {2016}, + note = {R package version 2.9.0-3}, + owner = {Paul}, + timestamp = {2016.03.04}, + url = {https://CRAN.R-project.org/package=rstanarm} +} + +@MANUAL{mcelreath2016, + title = {rethinking: Statistical Rethinking Course and Book Package}, + author = {Richard McElreath}, + year = {2016}, + note = {R package version 1.58}, + owner = {Paul}, + timestamp = {2016.03.04}, + url = {https://github.com/rmcelreath/rethinking} +} + +@MANUAL{nlme2016, + title = {\pkg{nlme}: Linear and Nonlinear Mixed Effects Models}, + author = {Jose Pinheiro and Douglas Bates and Saikat DebRoy and Deepayan Sarkar + and {R Core Team}}, + year = {2016}, + note = {R package version 3.1-124}, + owner = {Paul}, + timestamp = {2016.03.06}, + url = {http://CRAN.R-project.org/package=nlme} +} + +@BOOK{hastie1990, + title = {Generalized Additive Models}, + publisher = {CRC Press}, + year = {1990}, + author = {Hastie, Trevor J and Tibshirani, Robert J}, + volume = {43}, + owner = {Paul}, + timestamp = {2015.09.07} +} + +@Article{wood2011, + author = {Wood, Simon N}, + title = {Fast Stable Restricted Maximum Likelihood and Marginal Likelihood Estimation of Semiparametric Generalized Linear Models}, + journal = {Journal of the Royal Statistical Society: Series B (Statistical Methodology)}, + year = {2011}, + volume = {73}, + number = {1}, + pages = {3--36}, + publisher = {Wiley Online Library}, +} + +@BOOK{zuur2014, + title = {A beginner's Guide to Generalized Additive Models with \proglang{R}}, + publisher = {Highland Statistics Limited}, + year = {2014}, + author = {Zuur, Alain F}, + owner = {Paul}, + timestamp = {2016.03.04} +} + + +@ARTICLE{chung2013, + author = {Yeojin Chung and Sophia Rabe-Hesketh and Vincent Dorie and Andrew + Gelman and Jingchen Liu}, + title = {A nondegenerate penalized likelihood estimator for variance parameters + in multilevel models}, + journal = {Psychometrika}, + year = {2013}, + volume = {78}, + pages = {685--709}, + number = {4}, + owner = {Paul}, + publisher = {Springer}, + timestamp = {2016.02.22}, + url = {http://gllamm.org/} +} + +@ARTICLE{duane1987, + author = {Duane, Simon and Kennedy, Anthony D and Pendleton, Brian J and Roweth, + Duncan}, + title = {Hybrid Monte Carlo}, + journal = {Physics Letters B}, + year = {1987}, + volume = {195}, + pages = {216--222}, + number = {2}, + owner = {Paul}, + publisher = {Elsevier}, + timestamp = {2015.06.19} +} + +@ARTICLE{natarajan2000, + author = {Natarajan, Ranjini and Kass, Robert E}, + title = {Reference Bayesian Methods for Generalized Linear Mixed Models}, + journal = {Journal of the American Statistical Association}, + year = {2000}, + volume = {95}, + pages = {227--237}, + number = {449}, + owner = {Paul}, + publisher = {Taylor \& Francis}, + timestamp = {2015.07.23} +} + +@ARTICLE{kass2006, + author = {Kass, Robert E and Natarajan, Ranjini}, + title = {A Default Conjugate Prior for Variance Components in Generalized + Linear Mixed Models (Comment on Article by Browne and Draper)}, + journal = {Bayesian Analysis}, + year = {2006}, + volume = {1}, + pages = {535--542}, + number = {3}, + owner = {Paul}, + publisher = {International Society for Bayesian Analysis}, + timestamp = {2015.07.23} +} + +@ARTICLE{plummer2008, + author = {Plummer, Martyn}, + title = {Penalized Loss Functions for Bayesian Model Comparison}, + journal = {Biostatistics}, + year = {2008}, + owner = {Paul}, + publisher = {Biometrika Trust}, + timestamp = {2015.08.10} +} + +@ARTICLE{spiegelhalter2002, + author = {Spiegelhalter, David J and Best, Nicola G and Carlin, Bradley P and + Van Der Linde, Angelika}, + title = {Bayesian Measures of Model Complexity and Fit}, + journal = {Journal of the Royal Statistical Society B, Statistical Methodology}, + year = {2002}, + volume = {64}, + pages = {583--639}, + number = {4}, + owner = {Paul}, + publisher = {Wiley Online Library}, + timestamp = {2015.09.02} +} + +@MANUAL{Rtools2015, + title = {\pkg{Rtools} Software, Version~3.3}, + author = {{R Core Team}}, + organization = {\proglang{R} Foundation for Statistical Computing}, + address = {Vienna, Austria}, + year = {2015}, + owner = {Paul}, + timestamp = {2015.01.20}, + url = {https://cran.r-project.org/bin/windows/Rtools/} +} + +@Manual{afex2015, + title = {\pkg{afex}: Analysis of Factorial Experiments}, + author = {Henrik Singmann and Ben Bolker and Jake Westfall}, + year = {2015}, + note = {R package version 0.15-2}, + owner = {Paul}, + timestamp = {2016.02.13}, + url = {https://CRAN.R-project.org/package=afex}, +} + +@INPROCEEDINGS{carvalho2009, + author = {Carvalho, Carlos M and Polson, Nicholas G and Scott, James G}, + title = {Handling Sparsity via the Horseshoe}, + booktitle = {International Conference on Artificial Intelligence and Statistics}, + year = {2009}, + pages = {73--80}, + owner = {Paul}, + timestamp = {2015.11.09} +} + +@ARTICLE{carvalho2010, + author = {Carvalho, Carlos M and Polson, Nicholas G and Scott, James G}, + title = {The Horseshoe Estimator for Sparse Signals}, + journal = {Biometrika}, + year = {2010}, + pages = {1--16}, + owner = {Paul}, + publisher = {Biometrika Trust}, + timestamp = {2015.11.09} +} + +@ARTICLE{gelman2006, + author = {Gelman, Andrew}, + title = {Prior Distributions for Variance Parameters in Hierarchical Models}, + journal = {Bayesian Analysis}, + year = {2006}, + volume = {1}, + pages = {515--534}, + number = {3}, + owner = {Paul}, + publisher = {International Society for Bayesian Analysis}, + timestamp = {2015.07.15} +} + +@Article{gelman1992, + author = {Gelman, Andrew and Rubin, Donald B}, + title = {Inference from Iterative Simulation Using Multiple Sequences}, + journal = {Statistical Science}, + year = {1992}, + pages = {457--472}, + publisher = {JSTOR}, +} + +@MANUAL{gabry2015, + title = {\pkg{shinystan}: Interactive Visual and Numerical Diagnostics and + Posterior Analysis for Bayesian Models}, + author = {Jonah Gabry}, + year = {2015}, + note = {\proglang{R}~Package Version~2.0.0}, + owner = {Paul}, + timestamp = {2015.08.26}, + url = {http://CRAN.R-project.org/package=shinystan} +} + +@ARTICLE{samejima1969, + author = {Samejima, Fumiko}, + title = {Estimation of Latent Ability Using a Response Pattern of Graded Scores}, + journal = {Psychometrika Monograph Supplement}, + year = {1969}, + owner = {Paul}, + timestamp = {2015.01.27} +} + +@MISC{christensen2015, + author = {R. H. B. Christensen}, + title = {\pkg{ordinal} -- Regression Models for Ordinal Data}, + year = {2015}, + note = {\proglang{R} package version 2015.6-28. http://www.cran.r-project.org/package=ordinal/}, + owner = {Paul}, + timestamp = {2015.09.04} +} + +@ARTICLE{andrich1978a, + author = {Andrich, David}, + title = {A Rating Formulation for Ordered Response Categories}, + journal = {Psychometrika}, + year = {1978}, + volume = {43}, + pages = {561--573}, + number = {4}, + owner = {Paul}, + publisher = {Springer}, + timestamp = {2015.01.27} +} + +@Comment{jabref-meta: databaseType:bibtex;}