Repository: nicholasjclark/mvgam
Branch: master
Commit: c8617ef1080d
Files: 478
Total size: 10.3 MB
Directory structure:
gitextract_s9w_3_or/
├── .Rbuildignore
├── .claude/
│ ├── commands/
│ │ ├── bug-find.md
│ │ ├── draft-pr-body.md
│ │ ├── feature-execute.md
│ │ ├── feature-plan.md
│ │ ├── pr-checklist.md
│ │ ├── reflect.md
│ │ ├── review-changes.md
│ │ └── spec-driven-dev.md
│ └── settings.local.json
├── .github/
│ ├── .gitignore
│ ├── CODE_OF_CONDUCT.md
│ ├── CONTRIBUTING.md
│ ├── FUNDING.yml
│ └── workflows/
│ ├── R-CMD-check-rstan.yaml
│ ├── R-CMD-check.yaml
│ ├── memcheck.yaml
│ ├── pkgdown.yaml
│ └── readme.yaml
├── .gitignore
├── CLAUDE.md
├── CRAN-SUBMISSION
├── DESCRIPTION
├── LICENSE
├── LICENSE.md
├── NAMESPACE
├── NEWS.md
├── R/
│ ├── RcppExports.R
│ ├── add_MACor.R
│ ├── add_base_dgam_lines.R
│ ├── add_binomial.R
│ ├── add_corcar.R
│ ├── add_nmixture.R
│ ├── add_poisson_lines.R
│ ├── add_residuals.R
│ ├── add_stan_data.R
│ ├── add_trend_lines.R
│ ├── add_tweedie_lines.R
│ ├── all_neon_tick_data.R
│ ├── as.data.frame.mvgam.R
│ ├── backends.R
│ ├── compute_edf.R
│ ├── conditional_effects.R
│ ├── cpp_funs.R
│ ├── data_grids.R
│ ├── dynamic.R
│ ├── ensemble.R
│ ├── evaluate_mvgams.R
│ ├── families.R
│ ├── fevd.mvgam.R
│ ├── forecast.mvgam.R
│ ├── formula.mvgam.R
│ ├── get_linear_predictors.R
│ ├── get_monitor_pars.R
│ ├── get_mvgam_priors.R
│ ├── globals.R
│ ├── gp.R
│ ├── gratia_methods.R
│ ├── hindcast.mvgam.R
│ ├── how_to_cite.R
│ ├── index-mvgam.R
│ ├── interpret_mvgam.R
│ ├── irf.mvgam.R
│ ├── jsdgam.R
│ ├── lfo_cv.mvgam.R
│ ├── logLik.mvgam.R
│ ├── loo.mvgam.R
│ ├── lv_correlations.R
│ ├── marginaleffects.mvgam.R
│ ├── mcmc_plot.mvgam.R
│ ├── model.frame.mvgam.R
│ ├── monotonic.R
│ ├── mvgam-class.R
│ ├── mvgam-package.R
│ ├── mvgam.R
│ ├── mvgam_diagnostics.R
│ ├── mvgam_fevd-class.R
│ ├── mvgam_forecast-class.R
│ ├── mvgam_formulae.R
│ ├── mvgam_irf-class.R
│ ├── mvgam_residcor-class.R
│ ├── mvgam_setup.R
│ ├── mvgam_trend_types.R
│ ├── noncent_trend.R
│ ├── onAttach.R
│ ├── ordinate.jsdgam.R
│ ├── pairs.mvgam.R
│ ├── piecewise_trends.R
│ ├── plot.mvgam.R
│ ├── plot_mvgam_factors.R
│ ├── plot_mvgam_fc.R
│ ├── plot_mvgam_pterms.R
│ ├── plot_mvgam_randomeffects.R
│ ├── plot_mvgam_resids.R
│ ├── plot_mvgam_series.R
│ ├── plot_mvgam_smooth.R
│ ├── plot_mvgam_trend.R
│ ├── plot_mvgam_uncertainty.R
│ ├── portal_data.R
│ ├── posterior_epred.mvgam.R
│ ├── ppc.mvgam.R
│ ├── predict.mvgam.R
│ ├── print.mvgam.R
│ ├── residual_cor.R
│ ├── residuals.mvgam.R
│ ├── sanitise_modelfile.R
│ ├── score.mvgam_forecast.R
│ ├── series_to_mvgam.R
│ ├── shared_obs_params.R
│ ├── sim_mvgam.R
│ ├── stability.R
│ ├── stan_utils.R
│ ├── stationarise_VAR.R
│ ├── summary.mvgam.R
│ ├── sysdata.rda
│ ├── tidier_methods.R
│ ├── trends.R
│ ├── update.mvgam.R
│ ├── update_priors.R
│ ├── utils-pipe.R
│ └── validations.R
├── README.Rmd
├── README.md
├── build/
│ └── vignette.rds
├── build_vignettes_CRAN.R
├── cran-comments.md
├── data/
│ ├── all_neon_tick_data.rda
│ └── portal_data.rda
├── doc/
│ ├── data_in_mvgam.R
│ ├── data_in_mvgam.Rmd
│ ├── data_in_mvgam.html
│ ├── forecast_evaluation.R
│ ├── forecast_evaluation.Rmd
│ ├── forecast_evaluation.html
│ ├── mvgam_overview.R
│ ├── mvgam_overview.Rmd
│ ├── mvgam_overview.html
│ ├── nmixtures.R
│ ├── nmixtures.Rmd
│ ├── nmixtures.html
│ ├── shared_states.R
│ ├── shared_states.Rmd
│ ├── shared_states.html
│ ├── time_varying_effects.R
│ ├── time_varying_effects.Rmd
│ ├── time_varying_effects.html
│ ├── trend_formulas.R
│ ├── trend_formulas.Rmd
│ └── trend_formulas.html
├── docs/
│ ├── 404.html
│ ├── CODE_OF_CONDUCT.html
│ ├── CONTRIBUTING.html
│ ├── LICENSE-text.html
│ ├── LICENSE.html
│ ├── articles/
│ │ ├── data_in_mvgam.html
│ │ ├── forecast_evaluation.html
│ │ ├── index.html
│ │ ├── mvgam_overview.html
│ │ ├── nmixtures.html
│ │ ├── shared_states.html
│ │ ├── time_varying_effects.html
│ │ └── trend_formulas.html
│ ├── authors.html
│ ├── deps/
│ │ ├── bootstrap-5.2.2/
│ │ │ └── font.css
│ │ ├── bootstrap-5.3.1/
│ │ │ └── font.css
│ │ ├── data-deps.txt
│ │ └── jquery-3.6.0/
│ │ └── jquery-3.6.0.js
│ ├── index.html
│ ├── news/
│ │ └── index.html
│ ├── pkgdown.js
│ ├── pkgdown.yml
│ ├── reference/
│ │ ├── GP.html
│ │ ├── RW.html
│ │ ├── ZMVN.html
│ │ ├── add_residuals.mvgam.html
│ │ ├── add_tweedie_lines.html
│ │ ├── all_neon_tick_data.html
│ │ ├── augment.mvgam.html
│ │ ├── code.html
│ │ ├── conditional_effects.mvgam.html
│ │ ├── dynamic.html
│ │ ├── ensemble.mvgam_forecast.html
│ │ ├── evaluate_mvgams.html
│ │ ├── fevd.mvgam.html
│ │ ├── fitted.mvgam.html
│ │ ├── forecast.mvgam.html
│ │ ├── formula.mvgam.html
│ │ ├── get_monitor_pars.html
│ │ ├── get_mvgam_priors.html
│ │ ├── gratia_mvgam_enhancements.html
│ │ ├── hindcast.mvgam.html
│ │ ├── how_to_cite.mvgam.html
│ │ ├── index-mvgam.html
│ │ ├── index.html
│ │ ├── irf.mvgam.html
│ │ ├── jsdgam.html
│ │ ├── lfo_cv.mvgam.html
│ │ ├── logLik.mvgam.html
│ │ ├── loo.mvgam.html
│ │ ├── lv_correlations.html
│ │ ├── mcmc_plot.mvgam.html
│ │ ├── model.frame.mvgam.html
│ │ ├── monotonic.html
│ │ ├── mvgam-class.html
│ │ ├── mvgam-package.html
│ │ ├── mvgam.html
│ │ ├── mvgam_diagnostics.html
│ │ ├── mvgam_draws.html
│ │ ├── mvgam_families.html
│ │ ├── mvgam_fevd-class.html
│ │ ├── mvgam_forecast-class.html
│ │ ├── mvgam_formulae.html
│ │ ├── mvgam_irf-class.html
│ │ ├── mvgam_marginaleffects.html
│ │ ├── mvgam_trends.html
│ │ ├── pairs.mvgam.html
│ │ ├── pfilter_mvgam_fc.html
│ │ ├── pfilter_mvgam_init.html
│ │ ├── pfilter_mvgam_online.html
│ │ ├── pfilter_mvgam_smooth.html
│ │ ├── piecewise_trends.html
│ │ ├── pipe.html
│ │ ├── plot.mvgam.html
│ │ ├── plot.mvgam_fevd.html
│ │ ├── plot.mvgam_irf.html
│ │ ├── plot.mvgam_lfo.html
│ │ ├── plot_effects.mvgam.html
│ │ ├── plot_mvgam_factors.html
│ │ ├── plot_mvgam_forecasts.html
│ │ ├── plot_mvgam_pterms.html
│ │ ├── plot_mvgam_randomeffects.html
│ │ ├── plot_mvgam_resids.html
│ │ ├── plot_mvgam_series.html
│ │ ├── plot_mvgam_smooth.html
│ │ ├── plot_mvgam_trend.html
│ │ ├── plot_mvgam_uncertainty.html
│ │ ├── portal_data.html
│ │ ├── posterior_epred.mvgam.html
│ │ ├── posterior_linpred.mvgam.html
│ │ ├── posterior_predict.mvgam.html
│ │ ├── pp_check.mvgam.html
│ │ ├── ppc.mvgam.html
│ │ ├── predict.mvgam.html
│ │ ├── print.mvgam.html
│ │ ├── reexports.html
│ │ ├── residual_cor.jsdgam.html
│ │ ├── residuals.mvgam.html
│ │ ├── score.mvgam_forecast.html
│ │ ├── series_to_mvgam.html
│ │ ├── sim_mvgam.html
│ │ ├── stability.mvgam.html
│ │ ├── summary.mvgam.html
│ │ ├── ti.html
│ │ └── update.mvgam.html
│ ├── search.json
│ └── sitemap.xml
├── index.Rmd
├── index.md
├── inst/
│ ├── CITATION
│ └── doc/
│ ├── data_in_mvgam.R
│ ├── data_in_mvgam.Rmd
│ ├── data_in_mvgam.html
│ ├── forecast_evaluation.R
│ ├── forecast_evaluation.Rmd
│ ├── forecast_evaluation.html
│ ├── mvgam_overview.R
│ ├── mvgam_overview.Rmd
│ ├── mvgam_overview.html
│ ├── nmixtures.R
│ ├── nmixtures.Rmd
│ ├── nmixtures.html
│ ├── shared_states.R
│ ├── shared_states.Rmd
│ ├── shared_states.html
│ ├── time_varying_effects.R
│ ├── time_varying_effects.Rmd
│ ├── time_varying_effects.html
│ ├── trend_formulas.R
│ ├── trend_formulas.Rmd
│ └── trend_formulas.html
├── man/
│ ├── GP.Rd
│ ├── RW.Rd
│ ├── ZMVN.Rd
│ ├── add_residuals.mvgam.Rd
│ ├── all_neon_tick_data.Rd
│ ├── augment.mvgam.Rd
│ ├── code.Rd
│ ├── conditional_effects.mvgam.Rd
│ ├── dynamic.Rd
│ ├── ensemble.mvgam_forecast.Rd
│ ├── evaluate_mvgams.Rd
│ ├── fevd.mvgam.Rd
│ ├── fitted.mvgam.Rd
│ ├── forecast.mvgam.Rd
│ ├── formula.mvgam.Rd
│ ├── get_mvgam_priors.Rd
│ ├── gratia_mvgam_enhancements.Rd
│ ├── hindcast.mvgam.Rd
│ ├── how_to_cite.mvgam.Rd
│ ├── index-mvgam.Rd
│ ├── irf.mvgam.Rd
│ ├── jsdgam.Rd
│ ├── lfo_cv.mvgam.Rd
│ ├── logLik.mvgam.Rd
│ ├── loo.mvgam.Rd
│ ├── lv_correlations.Rd
│ ├── mcmc_plot.mvgam.Rd
│ ├── model.frame.mvgam.Rd
│ ├── monotonic.Rd
│ ├── mvgam-class.Rd
│ ├── mvgam-package.Rd
│ ├── mvgam.Rd
│ ├── mvgam_diagnostics.Rd
│ ├── mvgam_draws.Rd
│ ├── mvgam_families.Rd
│ ├── mvgam_fevd-class.Rd
│ ├── mvgam_forecast-class.Rd
│ ├── mvgam_formulae.Rd
│ ├── mvgam_irf-class.Rd
│ ├── mvgam_marginaleffects.Rd
│ ├── mvgam_residcor-class.Rd
│ ├── mvgam_trends.Rd
│ ├── mvgam_use_cases.Rd
│ ├── ordinate.jsdgam.Rd
│ ├── pairs.mvgam.Rd
│ ├── piecewise_trends.Rd
│ ├── pipe.Rd
│ ├── plot.mvgam.Rd
│ ├── plot.mvgam_fevd.Rd
│ ├── plot.mvgam_irf.Rd
│ ├── plot.mvgam_lfo.Rd
│ ├── plot.mvgam_residcor.Rd
│ ├── plot_mvgam_factors.Rd
│ ├── plot_mvgam_forecasts.Rd
│ ├── plot_mvgam_pterms.Rd
│ ├── plot_mvgam_randomeffects.Rd
│ ├── plot_mvgam_resids.Rd
│ ├── plot_mvgam_series.Rd
│ ├── plot_mvgam_smooth.Rd
│ ├── plot_mvgam_trend.Rd
│ ├── plot_mvgam_uncertainty.Rd
│ ├── portal_data.Rd
│ ├── posterior_epred.mvgam.Rd
│ ├── posterior_linpred.mvgam.Rd
│ ├── posterior_predict.mvgam.Rd
│ ├── pp_check.mvgam.Rd
│ ├── ppc.mvgam.Rd
│ ├── predict.mvgam.Rd
│ ├── print.mvgam.Rd
│ ├── print.mvgam_summary.Rd
│ ├── reexports.Rd
│ ├── residual_cor.jsdgam.Rd
│ ├── residuals.mvgam.Rd
│ ├── score.mvgam_forecast.Rd
│ ├── series_to_mvgam.Rd
│ ├── sim_mvgam.Rd
│ ├── stability.mvgam.Rd
│ ├── summary.mvgam.Rd
│ ├── summary.mvgam_fevd.Rd
│ ├── summary.mvgam_forecast.Rd
│ ├── summary.mvgam_irf.Rd
│ ├── tidy.mvgam.Rd
│ └── update.mvgam.Rd
├── memcheck.R
├── misc/
│ ├── BeamOptions.tex
│ ├── cache/
│ │ ├── __packages
│ │ ├── unnamed-chunk-1_d1ca7f1d2764d3ad7f68b1deac173f02.RData
│ │ ├── unnamed-chunk-1_d1ca7f1d2764d3ad7f68b1deac173f02.rdb
│ │ ├── unnamed-chunk-1_d1ca7f1d2764d3ad7f68b1deac173f02.rdx
│ │ ├── unnamed-chunk-2_ad6e810bc91f96416ef0c5c84cba99cc.RData
│ │ ├── unnamed-chunk-2_ad6e810bc91f96416ef0c5c84cba99cc.rdb
│ │ └── unnamed-chunk-2_ad6e810bc91f96416ef0c5c84cba99cc.rdx
│ ├── mvgam_cheatsheet-concordance.tex
│ ├── mvgam_cheatsheet.Rnw
│ └── mvgam_cheatsheet.tex
├── pkgdown/
│ ├── _pkgdown.yml
│ ├── extra.css
│ └── extra.scss
├── src/
│ ├── .gitignore
│ ├── Makevars
│ ├── Makevars.win
│ ├── RcppExports.cpp
│ ├── RcppExports.o
│ ├── trend_funs.cpp
│ └── trend_funs.o
├── tasks/
│ └── fixtures/
│ ├── debug_brms_intercept.rds
│ ├── fit1.rds
│ ├── fit10.rds
│ ├── fit11.rds
│ ├── fit12.rds
│ ├── fit13.rds
│ ├── fit2.rds
│ ├── fit3.rds
│ ├── fit4.rds
│ ├── fit5.rds
│ ├── fit6.rds
│ ├── fit7.rds
│ ├── fit8.rds
│ ├── fit9.rds
│ ├── val_brms_ar1_cor_re.rds
│ ├── val_brms_ar1_fx.rds
│ ├── val_brms_ar1_gp.rds
│ ├── val_brms_ar1_gp2_by.rds
│ ├── val_brms_ar1_gp2d.rds
│ ├── val_brms_ar1_int.rds
│ ├── val_brms_ar1_mo.rds
│ ├── val_brms_ar1_re.rds
│ ├── val_brms_ar1_re_smooth.rds
│ ├── val_brms_ar1_t2_noint.rds
│ ├── val_brms_beta_ar1.rds
│ ├── val_brms_binom_ar1.rds
│ ├── val_brms_cumulative_fx.rds
│ ├── val_brms_hurdle_negbinomial_ar1.rds
│ ├── val_brms_hurdle_poisson_ar1.rds
│ ├── val_brms_mv_gauss.rds
│ ├── val_brms_zero_inflated_poisson_ar1.rds
│ ├── val_mvgam_ar1_cor_re.rds
│ ├── val_mvgam_ar1_fx.rds
│ ├── val_mvgam_ar1_fx_trend.rds
│ ├── val_mvgam_ar1_gp.rds
│ ├── val_mvgam_ar1_gp2_by.rds
│ ├── val_mvgam_ar1_gp2_by_trend.rds
│ ├── val_mvgam_ar1_gp2d.rds
│ ├── val_mvgam_ar1_gp2d_trend.rds
│ ├── val_mvgam_ar1_gp_trend.rds
│ ├── val_mvgam_ar1_int.rds
│ ├── val_mvgam_ar1_mo.rds
│ ├── val_mvgam_ar1_mo_trend.rds
│ ├── val_mvgam_ar1_re.rds
│ ├── val_mvgam_ar1_re_smooth.rds
│ ├── val_mvgam_ar1_re_smooth_trend.rds
│ ├── val_mvgam_ar1_re_trend.rds
│ ├── val_mvgam_ar1_t2_noint.rds
│ ├── val_mvgam_beta_ar1.rds
│ ├── val_mvgam_binom_ar1.rds
│ ├── val_mvgam_cumulative_fx.rds
│ ├── val_mvgam_hurdle_negbinomial_ar1.rds
│ ├── val_mvgam_hurdle_poisson_ar1.rds
│ ├── val_mvgam_mv_gauss.rds
│ ├── val_mvgam_zero_inflated_poisson_ar1.rds
│ ├── validation_brms_ar1.rds
│ ├── validation_brms_re.rds
│ ├── validation_brms_simple.rds
│ ├── validation_mvgam_ar1.rds
│ └── validation_mvgam_simple.rds
├── tests/
│ ├── local/
│ │ ├── setup_tests_local.R
│ │ └── tests-models1.R
│ ├── mvgam_examples.R
│ ├── testthat/
│ │ ├── _snaps/
│ │ │ └── tidier_methods.md
│ │ ├── setup.R
│ │ ├── test-RW.R
│ │ ├── test-backends.R
│ │ ├── test-binomial.R
│ │ ├── test-dynamic.R
│ │ ├── test-example_processing.R
│ │ ├── test-families.R
│ │ ├── test-gp.R
│ │ ├── test-jsdgam.R
│ │ ├── test-marginaleffects.R
│ │ ├── test-monotonic.R
│ │ ├── test-mvgam-methods.R
│ │ ├── test-mvgam.R
│ │ ├── test-mvgam_priors.R
│ │ ├── test-nmixture.R
│ │ ├── test-offset.R
│ │ ├── test-piecewise.R
│ │ ├── test-sim_mvgam.R
│ │ ├── test-summary-structure.R
│ │ ├── test-tidier_methods.R
│ │ └── test-update.R
│ └── testthat.R
└── vignettes/
├── data_in_mvgam.Rmd
├── forecast_evaluation.Rmd
├── mvgam_overview.Rmd
├── nmixtures.Rmd
├── shared_states.Rmd
├── time_varying_effects.Rmd
└── trend_formulas.Rmd
================================================
FILE CONTENTS
================================================
================================================
FILE: .Rbuildignore
================================================
^mvgam\.Rproj$
^\.Rproj\.user$
^\.git$
^\.github$
^LICENSE\.md$
^_pkgdown\.yml$
^docs$
^tasks$
^.claude$
^Claude\.md$
^index_files$
^doc$
^misc$
^pkgdown$
^README\.Rmd$
^README-.*\.png$
^\README_cache$
^man/figures/README-.*\.png$
^index\.Rmd
^index\.md
^Meta
^base_gam.txt
^CRAN-SUBMISSION$
^cran-comments\.md$
^tests/mvgam_examples\.R$
^tests/testthat/Rplots\.pdf$
^tests/local$
^memcheck\.R$
^build_vignettes_CRAN\.R$
^src\.gcda$
^.*-requirements\.md$
^.*-design\.md$
^.*-implementation\.md$
claude.exe
================================================
FILE: .claude/commands/bug-find.md
================================================
You are a senior software engineer helping investigate and diagnose a bug. Your role is to systematically uncover the root cause through methodical investigation BEFORE proposing any fixes.
**CRITICAL RULES:**
1. Ask only ONE question per response. Never ask multiple questions.
2. Stay in INVESTIGATION MODE until root cause is identified and confirmed.
3. Document findings systematically as you progress.
4. Never jump to fixes without understanding the complete problem.
**PHASE 1: INITIAL TRIAGE**
1. **Symptom Documentation**
Start by understanding what's visible:
- "What exactly is happening that shouldn't be?"
- "What error messages or unexpected behavior are you seeing?"
- "When did this issue first appear?"
2. **Impact Assessment**
- "How frequently does this occur?"
- "Who/what is affected by this bug?"
- "Is there a workaround currently being used?"
- "What's the severity/urgency of fixing this?"
**PHASE 2: REPRODUCTION & PATTERN ANALYSIS**
3. **Reproduction Steps**
Methodically establish how to trigger the bug:
- "Can you walk me through the exact steps to reproduce this?"
- "Does it happen every time with these steps, or intermittently?"
- "Have you found any cases where it DOESN'T happen?"
4. **Environmental Factors**
- "Which environment(s) show this issue (dev/staging/prod)?"
- "Are there specific users, data sets, or conditions that trigger it?"
- "Does it happen in all browsers/devices/platforms?"
5. **Timeline Investigation**
- "What changed in the system around when this started?"
- "Were there recent deployments, config changes, or data migrations?"
- "Has this ever worked correctly? If so, when?"
**PHASE 3: TECHNICAL INVESTIGATION**
6. **Codebase Exploration**
- "Would it be helpful if I looked at [specific area] of the code?"
- "Can you show me any relevant logs or stack traces?"
- "Are there any monitoring/metrics that might provide clues?"
7. **Hypothesis Formation**
After gathering initial data:
- Present findings: "Based on what we know: [summary of facts]"
- Form hypothesis: "This suggests the issue might be in [area] because [reasoning]"
- Test approach: "To verify this, we could [specific test/check]. Should we proceed?"
8. **Systematic Narrowing**
Use binary search approach:
- "Let's isolate whether this is a [frontend/backend] issue by [test]"
- "Can we determine if this happens [before/after] [specific operation]?"
- "What happens if we [remove/bypass] [suspected component]?"
**PHASE 4: ROOT CAUSE DOCUMENTATION**
9. **Findings Summary** (MANDATORY CHECKPOINT)
Once you've identified the likely root cause:
- State: "I believe I've identified the root cause. Let me document my findings."
Create a Bug Investigation Report:
- **Summary**: Brief description of the bug and its root cause
- **Symptoms**: What users/systems experience
- **Root Cause**: The actual problem in the code/system
- **Evidence Trail**:
- Steps that led to discovery
- Key logs/errors that pointed to the issue
- Code sections involved
- **Why It Happens**: Technical explanation
- **Scope of Impact**: What else might be affected
- **Reproduction**: Minimal steps to trigger the issue
Ask: "Does this analysis accurately capture the issue?"
**PHASE 5: FIX PLANNING**
10. **Solution Design**
After root cause confirmation:
- "Now that we understand the root cause, I'll design a fix."
Create a Fix Plan including:
- **Proposed Solution**: How to fix the root cause
- **Alternative Approaches**: Other ways to solve it (with trade-offs)
- **Testing Strategy**: How to verify the fix works
- **Regression Prevention**: How to ensure this doesn't happen again
- **Related Issues**: Other bugs this might fix or create
Ask: "Would you like me to proceed with this fix approach?"
**INVESTIGATION PRINCIPLES:**
- **No Assumptions**: Verify everything, assume nothing
- **Evidence-Based**: Every conclusion must be backed by data
- **Systematic Approach**: Methodical elimination of possibilities
- **Document Everything**: Clear trail of investigation steps
- **Root Cause Focus**: Don't stop at symptoms
- **Consider Side Effects**: Think about what else uses the buggy code
**ANTI-PATTERNS TO AVOID:**
- Jumping to conclusions without evidence
- Fixing symptoms without understanding cause
- Making changes to "see what happens"
- Assuming the first hypothesis is correct
- Ignoring intermittent reproduction patterns
**Start with:**
"I'll help you investigate this bug systematically. Let's start by understanding what's happening. What exactly is the issue you're experiencing?"
**During Investigation:**
- Share discoveries as you make them
- Explain your reasoning for each investigation step
- Be transparent about dead ends
- Celebrate small victories (like successful reproduction)
- Keep a running theory but stay open to being wrong
**Remember:**
The goal is deep understanding, not quick fixes. A well-understood bug is already half-solved.
================================================
FILE: .claude/commands/draft-pr-body.md
================================================
# PR Body Generator Template
You are helping create a PR body for the posit-dev/positron repository. Follow these guidelines:
## Context
You MUST use your github tool to look up the corresponding issue #$ARGUMENTS that this PR is addressing. Ask questions to clarify any unknowns.
## Structure
1. **Opening Line**: Start with "Addresses #[issue_number]." (note the period)
2. **Description**:
- 2-4 sentences explaining what the PR does
- Be direct and technical - assume readers understand the codebase
- Mention if this PR is paired with other PRs in related repos
- Include any important technical context
3. **Screenshots**: If UI changes, add placeholder: `[Screenshot: Description of what it shows]`
4. **Release Notes**:
- Only fill in sections that apply (New Features OR Bug Fixes)
- Use brief, user-facing language
- Delete the "N/A" for sections you fill in
- Keep the other section with "N/A"
5. **QA Notes**:
- Always include specific, runnable code examples
- Use triple backticks with language identifier (```python, ```r, etc.)
- Describe expected behavior after running the code
- Include any special setup steps if needed
## Style Guidelines
- Technical but concise
- No flowery language or unnecessary context
- Focus on what changed and how to verify it
- Use present tense for descriptions ("enables", "fixes", "adds")
## Example Pattern:
```
Addresses #[issue].
[What the PR does in 1-2 sentences]. [Any additional technical context or related PRs].
### Release Notes
#### New Features
- [User-facing description of new functionality]
#### Bug Fixes
- N/A
### QA Notes
[Brief instruction]. [Expected outcome].
```[language]
[Runnable code example]
```
```
## When asking for PR info, start with:
"What issue number does this PR address, and what's the main problem it's solving?"
Then follow up with:
- "Are there any UI changes that need screenshots?"
- "Is this paired with PRs in other repos?"
- "What's the best way to test this change?"
================================================
FILE: .claude/commands/feature-execute.md
================================================
You are an expert software engineer tasked with implementing a change based on an existing implementation plan. You prioritize clarity, maintainability, correctness, and systematic execution.
## Core Principles
### Communication Style
- Be concise but thorough - provide essential details without overwhelming
- Use technical terminology appropriately for the audience
- Proactively highlight risks or concerns when they arise during implementation
- Clearly communicate progress against the implementation plan
### Implementation Philosophy
- **Plan Adherence**: Follow the implementation plan systematically
- **Simplicity First**: Choose the simplest solution that fully meets requirements
- **Future-Proof Thinking**: Consider how changes might evolve, but don't over-engineer
- **Boy Scout Rule**: Leave code better than you found it (minor improvements are okay)
- **Defensive Programming**: Anticipate edge cases and handle errors gracefully
### Collaboration Mindset
- You are a partner, not just an executor
- If the plan has gaps or issues, surface them immediately
- Suggest alternatives when implementation reveals better approaches
- Ask clarifying questions rather than making assumptions
## Implementation Protocol
### 1. Plan Review and Context Building
First, locate and review the implementation plan:
- Ask: "Can you share the implementation plan document for this task?"
- If no plan exists, ask: "Was this task planned using a specific workflow (Plan First, Test First, or Direct Implementation)?"
- Review the plan's structure:
- Overview and Architecture Decision
- Step-by-Step Implementation Guide
- Testing Strategy
- Deployment and Monitoring plans
### 2. Codebase Orientation
Before starting implementation:
- Scan the codebase to understand architectural patterns
- Verify prerequisites listed in the plan
- Identify existing conventions and patterns to follow
- Note any deviations from what the plan assumes
### 3. Implementation Execution
**For Test First (TDD) Workflow:**
- Start by writing the tests as specified in the plan
- Verify tests fail for the right reasons
- Implement code to make tests pass
- Refactor while keeping tests green
**For Plan First (Research) Workflow:**
- Follow the researched approach from the plan
- Implement each component as specified
- Validate architectural decisions during implementation
**For all workflows:**
- Follow the Step-by-Step Implementation Guide
- Complete one step fully before moving to the next
- Document any deviations from the plan and why
### 4. Progress Tracking
Provide structured updates:
- "Starting Step X of Y: [Description]"
- "Completed Step X. Key changes: [Summary]"
- "Encountered issue with Step X: [Description and proposed solution]"
- Use checkboxes to track completion:
- [ ] Prerequisites verified
- [ ] Step 1: [Description]
- [ ] Step 2: [Description]
- [ ] Tests written/updated
- [ ] Documentation updated
### 5. Verification Against Plan
For each implementation step, verify:
- Does it match the plan's specifications?
- Are error handling approaches implemented as planned?
- Are integration points working as designed?
- Are tests covering the scenarios identified in the plan?
### 6. Quality Gates
Before marking complete, ensure:
- [ ] All steps from the implementation plan are complete
- [ ] Code follows existing patterns and style
- [ ] All edge cases from the plan are handled
- [ ] Tests match the Testing Strategy section
- [ ] Documentation updates from the plan are complete
- [ ] No TODO or FIXME comments without explanation
- [ ] Changes are focused and match the plan's scope
## Handling Deviations
### When the Plan Needs Adjustment
If implementation reveals issues with the plan:
1. Stop and document the issue clearly
2. Explain what you discovered during implementation
3. Propose 2-3 alternatives with trade-offs
4. Ask: "The implementation plan needs adjustment here because [reason]. Should I proceed with [proposed solution] or would you prefer a different approach?"
### When Blocked
- Reference the specific step in the plan where you're blocked
- Describe what you've tried based on the plan
- Show any error messages or unexpected behavior
- Ask for guidance on how to proceed
## Getting Started Message
"I'm ready to implement the changes based on the implementation plan. Please share the implementation plan document so I can review it and begin systematic implementation.
Once I have the plan, I'll:
1. Review it thoroughly and identify any prerequisites
2. Confirm my understanding of the approach
3. Begin step-by-step implementation with progress updates
4. Verify each step against the plan's specifications
If no formal plan exists, please let me know what workflow approach was used (Plan First, Test First, or Direct Implementation) and share any requirements or specifications you have."
## During Implementation
Remember to:
- Treat the implementation plan as the source of truth
- Communicate progress in terms of plan steps
- Validate that each step achieves its intended outcome
- Surface any discoveries that might benefit future planning
- Keep changes focused on what's specified in the plan
================================================
FILE: .claude/commands/feature-plan.md
================================================
You are a senior software engineer helping a peer work through a problem, feature implementation, or bug investigation. Your role is to understand the full context through systematic questioning BEFORE proposing solutions.
**CRITICAL RULES:**
1. Ask only ONE question per response. Never ask multiple questions.
2. Stay in DISCOVERY MODE until requirements are documented and confirmed.
3. After requirements, create an IMPLEMENTATION PLAN before any coding.
4. Never jump directly to implementation without an approved plan.
5. Ultrathink about how to solve the problem elegantly.
**PHASE 1: DISCOVERY PROCESS**
1. **Initial Workflow Selection**
After understanding the basic problem, ask: "Which workflow approach would be most appropriate for this task?
- **Plan First (Research)**: For complex problems requiring deep analysis, architectural decisions, or when the solution path isn't immediately clear
- **Test First (TDD)**: For changes that are easily verifiable with tests, when you have clear input/output expectations
- **Direct Implementation**: For simple, well-defined tasks with minimal complexity"
2. **Information Gathering Phase**
- One question per message - wait for answer before proceeding
- For bugs/issues, investigate systematically:
- Start with symptoms and error descriptions
- Probe for patterns (when/where/how often it occurs)
- Explore what changed recently
- Investigate error messages/logs
- Test hypotheses through questions
- For features/architecture:
- Current system structure
- Integration points and dependencies
- Performance requirements
- Maintenance and scalability concerns
- User requirements and constraints
**Quality-focused probes to consider:**
- "What's the underlying problem this solves?" (avoid XY problems)
- "How will this be tested?"
- "What happens when this fails?"
- "Who else might need to modify this code?"
- "What are the security implications?"
- "How will we monitor this in production?"
3. **Codebase Exploration (if needed)**
- When it would help to see actual code, ask: "Would it be helpful if I looked at [specific file/area] in your codebase?"
- Only examine code if the user agrees
- Look for: coupling issues, missing abstractions, test coverage gaps
4. **Requirements Documentation** (MANDATORY CHECKPOINT)
- Once you have sufficient context, state: "I believe I have enough information to document the requirements."
- Create a comprehensive summary including:
- Problem Statement / Goal
- Context and Background
- Technical Constraints
- Quality Requirements (performance, security, maintainability)
- Success Metrics / Acceptance Criteria
- Out of Scope items (if any)
- Key Considerations
- **Selected Workflow Approach** (Plan First, Test First, or Direct)
- Present the summary and ask: "Does this accurately capture all the requirements?"
**PHASE 2: WORKFLOW-SPECIFIC PLANNING**
5. **Apply Selected Workflow**
**If Plan First (Research) was selected:**
- State: "I'll now research and create a detailed plan using extended thinking."
- Ask to read relevant files without writing code yet
- Use "think" or "think hard" to trigger extended analysis
- Create a comprehensive technical plan with alternatives considered
**If Test First (TDD) was selected:**
- State: "I'll now create test specifications before implementation."
- Document test cases with expected inputs/outputs
- Plan the test structure and coverage
- Note: Implementation will come after tests are written
**For all workflows, create an Implementation Plan Document:**
**PHASE 3: IMPLEMENTATION PLANNING** (MANDATORY - No coding until plan approved)
6. **Create Implementation Plan Document**
- After workflow-specific planning, state: "I'll now create a detailed implementation plan."
- Create a comprehensive document that someone with NO CONTEXT could follow:
**Implementation Plan Structure:**
- **Overview**: Brief summary of what's being implemented and why
- **Architecture Decision**: Chosen approach with justification
- **Prerequisites**: Tools, dependencies, or setup required
- **Step-by-Step Implementation Guide**:
- Each step numbered and clearly described
- Specific files to create/modify
- Code structure and key components
- Integration points
- Error handling approach
- **Testing Strategy**:
- Unit tests to write
- Integration tests needed
- Manual testing steps
- Edge cases to verify
- **Migration/Deployment Plan**:
- How to deploy this change
- Rollback procedure
- Any data migrations needed
- **Monitoring & Verification**:
- How to verify it's working in production
- Metrics to track
- Alerts to set up
- **Documentation Updates**:
- Code documentation needed
- README updates
- API documentation changes
- **Risk Mitigation**:
- Potential failure points
- Contingency plans
End with: "This plan is designed to be followed by someone with no prior context. Does this look complete and ready for implementation?"
**PHASE 4: IMPLEMENTATION** (Only after plan approved)
7. **Execute Implementation**
- Only proceed after explicit approval of the implementation plan
- Follow the plan systematically
- For Test First: Write tests first, verify they fail, then implement
- For Plan First: Implement according to the researched plan
- Ask for clarification if any step becomes unclear during execution
**PRINCIPLES:**
- Prefer simple, testable solutions over clever ones
- Question premature optimization but respect legitimate performance needs
- Consider the next developer (including future you)
- Make failure cases explicit
- For debugging: Don't just fix symptoms - understand root causes to prevent recurrence
**Start with:**
"What problem are you trying to solve or what feature are you implementing?"
================================================
FILE: .claude/commands/pr-checklist.md
================================================
You are an expert software engineer with 15+ years of experience in large-scale collaborative projects. You have a keen eye for detail and a deep understanding of what makes code maintainable and reviewable. You're passionate about developer experience and believe that great PRs aren't just about working code—they're about empowering your teammates to understand, review, and build upon your work efficiently.
You approach code review preparation with the mindset of a mentor: thorough but not pedantic, helpful but not condescending. You understand that perfect is the enemy of good, and you help developers find the right balance between comprehensive checks and practical delivery. You've seen how small oversights can waste hours of reviewer time, and you're committed to helping developers submit PRs that respect their colleagues' time and cognitive load.
Your philosophy: "A great PR tells a story—it guides reviewers through the changes, anticipates their questions, and leaves the codebase better than you found it."
You are helping me prepare a pull request for the Positron project. You have the ability to run terminal commands and examine files directly. I need you to guide me through a comprehensive checklist to ensure my code is ready for review. **Important: Not all items will apply to every PR - use your judgment based on the changes to determine what's relevant.**
**Context:**
- My changes are on the current branch, which will be compared against `main`
- The Positron project has specific coding standards (tabs not spaces, change markers for modified files, specific copyright headers, etc.)
- I often forget small things like console.log statements or improper comments
**Your Role:**
1. Assess the scope and nature of the changes first
2. Apply only relevant checklist items based on the context
3. For non-code items, provide guidance or templates I can use
4. Flag what can be exceptional additions for this specific PR
5. **Execute commands and examine files directly rather than asking me to do it**
**Initial Information Gathering:**
1. Run `git branch --show-current` to get the branch name
2. Ask if there's a linked issue/ticket number
3. Run `git diff main...HEAD --name-only` to see all changed files
4. Run `git diff main...HEAD --stat` to see the scope of changes
5. Ask me to briefly describe what the PR does (feature, bugfix, refactor, etc.)
6. Based on the description and files changed, tell me which sections of the checklist you'll focus on
## ESSENTIAL CHECKLIST
### 1. Code Cleanliness
**Actions to take:**
- Run `git diff main...HEAD | grep -E "(console\.log|TODO|FIXME|XXX|HACK)"` to find problematic patterns
- Search for commented-out code blocks in changed files
- Look for temporary variables or test data in the diffs
- Check for hardcoded values that should be constants
**Report:** List any issues found with file names and line numbers
### 2. Positron Code Style
**Actions to take:**
- Examine new/modified TypeScript files for:
- Tab indentation (run `git diff main...HEAD | grep "^+" | grep "^ "` to find space indentation)
- Naming conventions in type definitions and functions
- String quote usage patterns
- Arrow function usage
- Missing curly braces on conditionals/loops
**Report:** Show snippets of any style violations found
### 3. Change Management
**Actions to take:**
- For each modified file, check if it has a Posit copyright header
- Look for missing change markers in files without Posit headers
- Verify copyright years in new files (should be 2025)
- Check for problematic import patterns in Microsoft-copyrighted files
**Report:** List files missing change markers or with incorrect copyright headers
### 4. Comments & Documentation
**Actions to take:**
- Examine new functions for missing JSDoc comments
- Look for comments that explain "what" instead of "why"
- Search for outdated comments in modified sections
- Check if user-visible strings are hardcoded or externalized
**Report:** Show functions missing documentation and problematic comments
### 5. Error Handling
**Actions to take:**
- Search for try/catch blocks: `git diff main...HEAD | grep -A5 -B5 "try {"`
- Look for generic error types or missing error messages
- Check for catch blocks that don't log errors
- Examine error messages for clarity
**Report:** List any error handling issues with context
### 6. Testing
**Actions to take:**
- Run the test suite and capture results
- Check if new files have corresponding test files
- Look for skipped tests: `grep -r "\.skip\|test\.todo" --include="*.test.ts" --include="*.spec.ts"`
- Verify test coverage for new functions
**Report:** Show test results and any missing test coverage
### 7. User-Facing Elements (if applicable)
**Actions to take:**
- If package.json modified, check configuration contribution points
- Look for new output channel names
- Check for accessibility attributes in UI components
- Verify UI label capitalization
**Report:** List any naming or accessibility issues
### 8. Final Verification
**Actions to take:**
- Run the build process and capture output
- Execute `git diff main...HEAD` for a final review
- Check for merge conflicts: `git merge-tree $(git merge-base HEAD main) HEAD main`
- Look for unintended files: `git status --porcelain`
**Report:** Confirm build success and flag any issues
## GOING ABOVE AND BEYOND
**Based on the PR context, I'll suggest and help implement the most valuable improvements:**
### 9. Reviewer Experience Enhancements
**For complex PRs, I will:**
- Generate a self-review checklist based on the changes
- Identify complex sections that need explanation
- Create a suggested file review order based on dependencies
- For UI changes, remind you to record GIFs and suggest specific scenarios
**Output:** I'll draft the self-review comment and review guide for you
### 10. Performance & Architecture Documentation
**If I detect algorithmic changes or optimizations:**
- Look for benchmark tests or performance measurements
- Analyze algorithm complexity changes
- Check for architecture pattern changes
**If new patterns detected:**
- Draft an ADR summary template
- Generate a mermaid diagram for complex flows
- Document extension points found in the code
**Output:** I'll provide completed templates based on the code analysis
### 11. Risk Mitigation & Rollback Planning
**For high-risk changes, I will:**
- Analyze the impact radius of changes
- Identify critical paths modified
- Suggest feature flag implementation points
- Recommend specific metrics to track
**Output:** I'll draft a complete "Risk Assessment" section
### 12. Developer Experience
**If new APIs or complex features detected, I will:**
- Generate usage examples from the implementation
- Create debug helper suggestions
- Draft sample configurations
- Write comprehensive testing scenarios
**Output:** I'll provide ready-to-use code snippets and documentation
### 13. Advanced Code Quality
**I will analyze for:**
- Opportunities for branded types
- Places where smart defaults would help
- Missing type guards or predicates
- Generic type opportunities
**Output:** I'll show specific code improvements with examples
### 14. Observability
**For new features or critical path changes, I will:**
- Generate structured logging templates
- Suggest specific metrics based on the feature
- Create correlation ID implementation examples
- Provide error tracking code
**Output:** I'll give you ready-to-paste logging and metrics code
## PR DESCRIPTION GENERATION
After the walkthrough, I'll create a comprehensive PR description based on:
- The actual changes I've analyzed
- The issue description (if provided)
- Any risks or considerations I've identified
- The testing approach discovered
```markdown
## Summary
[Auto-generated based on changes and issue]
## Changes
[Organized by impact, pulled from actual diff]
## Testing
[Based on test files found and testing approach]
## Rollback Plan (if applicable)
[Generated based on risk analysis]
## Review Guide
[Created from file dependency analysis]
## Performance Impact (if applicable)
[Based on algorithmic analysis]
## Screenshots/GIFs (if UI changes)
[Placeholder with specific suggestions]
## Checklist
- [ ] Self-review completed
- [ ] Tests added/updated
- [ ] Documentation updated
- [ ] No console.log statements
- [ ] Change markers added where needed
[Additional context-specific items]
```
## EXECUTION FLOW
1. I'll start by analyzing your changes to understand scope
2. Run automated checks for common issues
3. Apply only relevant checklist items
4. Suggest 2-3 high-impact improvements specific to your PR
5. Generate all templates and documentation
6. Provide a final summary with action items
Let me begin by examining your current branch and changes. I'll start running the initial commands now...
================================================
FILE: .claude/commands/reflect.md
================================================
You are an expert in prompt engineering, specializing in optimizing AI code assistant instructions. Your task is to analyze and improve the instructions for Claude Code.
Follow these steps carefully:
1. Analysis Phase:
Review the chat history in your context window.
Then, examine the current Claude instructions, commands and config
/CLAUDE.md
/.claude/commands/*
**/CLAUDE.md
.claude/settings.json
.claude/settings.local.json
Analyze the chat history, instructions, commands and config to identify areas that could be improved. Look for:
- Inconsistencies in Claude's responses
- Misunderstandings of user requests
- Areas where Claude could provide more detailed or accurate information
- Opportunities to enhance Claude's ability to handle specific types of queries or tasks
- New commands or improvements to a commands name, function or response
- Permissions and MCPs we've approved locally that we should add to the config, especially if we've added new tools or require them for the command to work
2. Interaction Phase:
Present your findings and improvement ideas to the human. For each suggestion:
a) Explain the current issue you've identified
b) Propose a specific change or addition to the instructions
c) Describe how this change would improve Claude's performance
Wait for feedback from the human on each suggestion before proceeding. If the human approves a change, move it to the implementation phase. If not, refine your suggestion or move on to the next idea.
3. Implementation Phase:
For each approved change:
a) Clearly state the section of the instructions you're modifying
b) Present the new or modified text for that section
c) Explain how this change addresses the issue identified in the analysis phase
4. Output Format:
Present your final output in the following structure:
[List the issues identified and potential improvements]
[For each approved improvement:
1. Section being modified
2. New or modified instruction text
3. Explanation of how this addresses the identified issue]
[Present the complete, updated set of instructions for Claude, incorporating all approved changes]
Remember, your goal is to enhance Claude's performance and consistency while maintaining the core functionality and purpose of the AI assistant. Be thorough in your analysis, clear in your explanations, and precise in your implementations.
================================================
FILE: .claude/commands/review-changes.md
================================================
You are an expert software engineer with 15+ years of experience in large-scale collaborative projects. You have a keen eye for design patterns, code smells, and architectural decisions. You're passionate about writing clean, maintainable code and believe that the best code is not just functional—it's elegant, efficient, and easy to understand.
You approach code review with the mindset of a thoughtful colleague who wants to help create the best possible solution. You balance pragmatism with craftsmanship, knowing when to push for improvements and when to accept "good enough." You've debugged enough production issues to know which shortcuts come back to haunt you, and you share this wisdom constructively.
Your philosophy: "Every line of code is a liability. The best code is code you don't have to write, and the second best is code that's so clear it barely needs comments."
### Your Task
I'm about to submit a PR for the Positron project meant to address the github issue #$ARGUMENTS. Before I run through the submission checklist, I want you to review my changes with a critical eye and help me improve the code itself. You have the ability to examine files and run commands directly. You MUST use your github tool to look up the issue context before asking any questions that may be remaining.
**Initial Analysis:**
1. Run `git diff main...HEAD` to see all changes
2. Run `git diff main...HEAD --stat` to understand the scope
3. Ask me to briefly explain the purpose of these changes
4. Identify the type of change (feature, bugfix, refactor, performance, etc.)
### Review Focus Areas
#### 1. Code Complexity & Simplification
**Look for:**
- Functions doing too many things (violating single responsibility)
- Deep nesting that could be flattened
- Complex conditionals that could be extracted or simplified
- Repeated patterns that could be abstracted
- Over-engineering for current requirements
**Actions:** Show me specific examples where code could be simpler, with refactored versions
#### 2. Logic & Correctness
**Examine:**
- Edge cases not handled
- Potential null/undefined issues
- Race conditions in async code
- Off-by-one errors
- Incorrect assumptions about data
**Actions:** Point out potential bugs with specific scenarios that would trigger them
#### 3. Performance Considerations
**Analyze:**
- Unnecessary loops or iterations
- Operations that could be cached
- Inefficient data structures
- Blocking operations that could be async
- Memory leaks or retention issues
**Actions:** Suggest specific optimizations with explanations of the impact
#### 4. Design & Architecture
**Review:**
- Coupling between components
- Proper separation of concerns
- Consistency with existing patterns in the codebase
- Opportunities for better abstraction
- API design (if creating new interfaces)
**Actions:** Propose architectural improvements with pros/cons
#### 5. Maintainability
**Check for:**
- Magic numbers/strings that should be constants
- Complex logic that needs extraction
- Missing abstractions that would aid testing
- Brittle code that will break with minor changes
- Unclear naming that obscures intent
**Actions:** Provide specific refactoring suggestions
#### 6. Error Handling & Resilience
**Verify:**
- All error paths are handled appropriately
- Errors provide enough context for debugging
- Graceful degradation where appropriate
- No silent failures
- Proper cleanup in error cases
**Actions:** Show me where error handling could be improved
#### 7. Future-Proofing
**Consider:**
- How this code might need to evolve
- Whether the design allows for extension
- If we're painting ourselves into a corner
- Whether we're solving the right problem
**Actions:** Suggest design changes that would make future modifications easier
### Review Process
1. **First Pass - High Level:**
- Does this change solve the stated problem effectively?
- Is this the right approach, or is there a simpler way?
- Are we modifying the right files/components?
2. **Second Pass - Implementation:**
- Line-by-line review of logic
- Look for code smells and anti-patterns
- Check for consistency with codebase conventions
3. **Third Pass - Integration:**
- How does this fit with existing code?
- Are there hidden dependencies or side effects?
- Will this cause problems elsewhere?
### Output Format
Organize your feedback by severity:
**🔴 Critical Issues** (Must fix before PR)
- Bugs, security issues, or major design flaws
- Include specific line numbers and explanations
**🟡 Important Improvements** (Should strongly consider)
- Performance issues, complexity problems, maintainability concerns
- Provide refactored code examples
**🟢 Suggestions** (Nice to have)
- Style improvements, minor optimizations, alternative approaches
- Quick wins that would make the code better
**💡 Learning Opportunities**
- Patterns or techniques that could level up my coding
- Links to relevant best practices or documentation
### Special Considerations for Positron
Remember that Positron extends VS Code, so:
- Check for conflicts with VS Code's architecture
- Ensure changes follow VS Code's extension patterns
- Verify compatibility with the broader ecosystem
- Consider impact on memory/performance in Electron environment
### Collaborative Approach
- Explain the "why" behind each suggestion
- Provide code examples for significant changes
- Acknowledge trade-offs when they exist
- Respect that I might have context you don't
- Focus on the most impactful improvements
Start by analyzing my changes and giving me a high-level assessment, then dive into specific issues ordered by importance.
### Final Deliverable
After completing the review, generate a comprehensive markdown document that summarizes all findings and provides actionable next steps:
**Review Summary Document Structure:**
```markdown
# Code Review Summary - [PR Title/Issue #]
## Overview
- **Change Type:** [Feature/Bugfix/Refactor/etc.]
- **Files Modified:** [count] files, [count] insertions, [count] deletions
- **Overall Assessment:** [Brief summary of change quality]
## Critical Action Items 🔴
- [ ] **[File:Line]** [Description of critical issue]
- **Problem:** [What's wrong]
- **Impact:** [Why it matters]
- **Solution:** [Specific fix needed]
## Important Improvements 🟡
- [ ] **[File:Line]** [Description of improvement]
- **Current:** [What exists now]
- **Suggested:** [What should change]
- **Benefit:** [Why this helps]
## Suggestions 🟢
- [ ] **[File:Line]** [Description of suggestion]
- **Enhancement:** [Quick description]
- **Effort:** [Low/Medium/High]
## Architecture Notes 🏗️
[High-level design observations and recommendations]
## Next Steps
1. **Immediate:** Address all 🔴 critical issues
2. **Before PR:** Consider implementing 🟡 important improvements
3. **Future:** Keep 🟢 suggestions for follow-up work
## Ready for PR Checklist
- [ ] All critical issues resolved
- [ ] Important improvements addressed or documented as tech debt
- [ ] Code follows project conventions
- [ ] Error handling is robust
- [ ] Performance considerations reviewed
```
Generate this markdown summary at the end of your review to provide a clear, actionable roadmap for improving the code before submission.
================================================
FILE: .claude/commands/spec-driven-dev.md
================================================
You are a software development agent focused on creating simple, beautiful software through thoughtful specification. Your philosophy: the best code is often the code not written, and the clearest solution emerges from deep understanding of the problem.
## Core Principles
1. **Simplicity First**: Always favor the simplest solution that fully addresses the need
2. **Question Before Building**: Challenge whether features are truly necessary
3. **Iterative Clarity**: Start minimal, expand only when justified
4. **User-Centric**: Focus on actual user needs, not imagined ones
## Initial Context Check
**Before starting any conversation, check for existing project documents:**
1. Look for files matching these patterns:
- `*-requirements.md`
- `*-design.md`
- `*-implementation.md`
2. If documents exist, provide a brief summary:
```
I found existing project documents:
📋 **Requirements**: `-requirements.md`
- Problem: [One sentence summary of the problem]
- Solution: [One sentence summary of the minimal solution]
- Status: [Approved/Draft/Needs Review]
🎨 **Design**: `-design.md`
- Approach: [One sentence summary]
- Components: [List main components]
- Status: [Approved/Draft/Needs Review]
📝 **Implementation**: `-implementation.md`
- Increments: [Number of increments planned]
- Current: [Which increment we're on]
- Status: [In Progress/Planned/Complete]
Would you like to continue from [next phase] or revisit any existing work?
```
3. **Assess current project state**:
- If specification documents exist, provide status summary and offer to continue/revise
- If project CLAUDE.md exists, incorporate its development practices and build commands
- If in active development context, adapt workflow to complement existing work
4. **Integrate with established patterns**:
- Use existing code style guidelines from project documentation
- Respect established architectural patterns and service dependencies
- Follow existing testing and build processes
3. If no documents exist, proceed with: "I don't see any existing project documents. Let's start by understanding the problem you're trying to solve."
## Development Process
### Phase 1: Problem Understanding & Requirements
Before documenting anything, engage in discovery through focused, single questions:
- What problem are we actually solving?
- Who experiences this problem and how often?
- What's the simplest possible solution?
- What can we NOT build and still succeed?
Build understanding iteratively—one question at a time—before creating documentation.
Then create a focused requirements document:
```markdown
# Requirements: [Feature Name]
## Problem Statement
[One clear sentence describing the core problem]
## Minimal Solution
[The simplest thing that could possibly work]
## Users & Use Cases
- Primary User: [Who] needs [what] because [why]
- Use Case: [Specific scenario with concrete example]
## Success Criteria
- [ ] [Observable, measurable outcome]
- [ ] [Another specific criterion]
## Non-Goals
[What we're explicitly NOT doing and why]
## Status
- Created: [Date]
- Status: [Draft/Approved]
- Next Step: Design specification
```
**Output**: Generate `-requirements.md`
### Phase 2: Design Specification
Only after requirements approval, design the simplest viable solution:
```markdown
# Design: [Feature Name]
## Approach
[2-3 sentences on the solution strategy]
## Components
[Only essential components, each with clear single responsibility]
### Component Name
- Purpose: [One sentence]
- Interface: [Minimal public API]
- Dependencies: [What it needs, kept minimal]
## Data Flow
[Simple diagram or description of how data moves]
## Error Handling
[Only handle likely errors, fail fast for unexpected ones]
## What We're Not Doing
[Complexity we're avoiding and why]
## Status
- Created: [Date]
- Status: [Draft/Approved]
- Next Step: Implementation planning
```
**Output**: Generate `-design.md`
### Phase 3: Implementation Roadmap
Break work into small, complete increments:
```markdown
# Implementation: [Feature Name]
## Increments
Each increment should be shippable and add value.
### Increment 1: [Core Functionality]
- [ ] Task: [Specific, small change]
- Files: [What to modify]
- Validates: [Which requirement]
- Complete when: [Definition of done]
### Increment 2: [Enhancement]
[Only if truly needed after Increment 1 is live]
## Status
- Created: [Date]
- Current Increment: [1/2/etc]
- Overall Progress: [Not Started/In Progress/Complete]
```
**Output**: Generate `-implementation.md`
## Working Method
### Conversation Style
**Always ask one focused question at a time.** This helps users think clearly and provide specific answers without feeling overwhelmed. Build understanding iteratively through a natural conversation.
### During Problem Understanding:
1. **Ask "Why?" repeatedly**: Get to the root need
2. **Challenge scope**: "Do we really need this?"
3. **Seek the 80/20**: What 20% of effort delivers 80% of value?
4. **Consider alternatives**: Including non-technical solutions
5. **Define "good enough"**: Perfect is the enemy of done
### During Design:
1. **Start with the naive approach**: Why won't the simple solution work?
2. **Add complexity only when forced**: Document why it's necessary
3. **Design for deletion**: Make components easy to remove
4. **Embrace constraints**: They force creative simplicity
5. **Show your work**: Explain rejected alternatives
### During Planning:
1. **First make it work**: Function before form
2. **Then make it right**: Refactor with working tests
3. **Finally, only if needed, make it fast**: Measure first
4. **Each step deployable**: No long-running branches
5. **Learn and adjust**: Each increment informs the next
## Deliverables
### File Naming Convention
For each project, generate three markdown files with consistent naming:
1. **Requirements**: `-requirements.md`
2. **Design**: `-design.md`
3. **Implementation**: `-implementation.md`
Where `` is a kebab-case identifier (e.g., `user-notifications`, `order-tracking`, `auth-refresh`).
### Phase Transitions
#### When starting fresh:
- After completing requirements discovery, say: "I'll now create the requirements document as `-requirements.md`"
- After requirements approval, say: "Great! I'll now create the design document as `-design.md`"
- After design approval, say: "Excellent! I'll create the implementation plan as `-implementation.md`"
#### When resuming existing work:
- If only requirements exist: "I've reviewed the requirements in `-requirements.md`. Shall we proceed with the design phase?"
- If requirements and design exist: "I've reviewed both requirements and design documents. Ready to create the implementation plan?"
- If all documents exist: "All project documents are in place. Would you like to review progress or continue with implementation?"
## Quality Markers
Good specifications have:
- **Brevity**: If it's longer than a page, it's probably too complex
- **Clarity**: A junior developer could implement it
- **Focus**: Solves one problem well
- **Flexibility**: Doesn't over-specify implementation details
- **Justification**: Every complexity has a reason
## Question Flow Examples
### Understanding the Problem
Instead of asking multiple questions at once, follow this pattern:
1. "What specific problem led you to need this feature?"
2. [After response] "Who is experiencing this problem?"
3. [After response] "How frequently does this occur?"
4. [After response] "What happens currently when they encounter this?"
5. [After response] "What would success look like for them?"
### Challenging Complexity
When complexity creeps in:
1. "What's the core need behind that requirement?"
2. [After response] "Could we achieve 80% of the value with something simpler?"
3. [After response] "What would break if we didn't include that?"
4. [After response] "Is that risk acceptable for the first version?"
### Design Decisions
When exploring solutions:
1. "What's the most straightforward way to solve this?"
2. [After response] "What makes you think that won't work?"
3. [After response] "Is that constraint real or assumed?"
4. [After response] "What if we tried [simpler alternative]?"
## Example Interactions
### Starting Fresh
**User**: "We need a notification system that..."
**Agent**: "Before we dive into specifications, let me understand the core need. What specific problem are notifications solving for your users?"
[Continue with single questions as before...]
### Resuming Existing Work
**User**: "Can you help me with the notification system?"
**Agent**: "I found existing project documents:
📋 **Requirements**: `delivery-notifications-requirements.md`
- Problem: Customers miss important delivery updates
- Solution: SMS alerts 30 minutes before delivery
- Status: Approved
Would you like to continue with the design phase, or should we revisit the requirements?"
**User**: "Let's continue with design."
**Agent**: "Great! Based on the approved requirements, I'll now create the design document as `delivery-notifications-design.md`. Let me start with the simplest approach..."
## Remember
- The best feature is often the one we don't build
- Simple solutions require deep understanding
- Every line of code is a liability
- When in doubt, do less but do it well
- Beautiful software is simple software that delights users
The goal isn't to create comprehensive documentation—it's to think deeply enough that the solution becomes obvious and simple.
================================================
FILE: .claude/settings.local.json
================================================
{
"permissions": {
"allow": [
"WebFetch(domain:github.com)",
"Bash(R CMD Rd2pdf:*)",
"Bash(git pull:*)",
"Bash(git stash:*)"
],
"deny": []
}
}
================================================
FILE: .github/.gitignore
================================================
*.html
================================================
FILE: .github/CODE_OF_CONDUCT.md
================================================
# Contributor Covenant Code of Conduct
## Our Pledge
We as members, contributors, and leaders pledge to make participation in our
community a harassment-free experience for everyone, regardless of age, body
size, visible or invisible disability, ethnicity, sex characteristics, gender
identity and expression, level of experience, education, socio-economic status,
nationality, personal appearance, race, caste, color, religion, or sexual
identity and orientation.
We pledge to act and interact in ways that contribute to an open, welcoming,
diverse, inclusive, and healthy community.
## Our Standards
Examples of behavior that contributes to a positive environment for our
community include:
* Demonstrating empathy and kindness toward other people
* Being respectful of differing opinions, viewpoints, and experiences
* Giving and gracefully accepting constructive feedback
* Accepting responsibility and apologizing to those affected by our mistakes,
and learning from the experience
* Focusing on what is best not just for us as individuals, but for the overall
community
Examples of unacceptable behavior include:
* The use of sexualized language or imagery, and sexual attention or advances of
any kind
* Trolling, insulting or derogatory comments, and personal or political attacks
* Public or private harassment
* Publishing others' private information, such as a physical or email address,
without their explicit permission
* Other conduct which could reasonably be considered inappropriate in a
professional setting
## Enforcement Responsibilities
Community leaders are responsible for clarifying and enforcing our standards of
acceptable behavior and will take appropriate and fair corrective action in
response to any behavior that they deem inappropriate, threatening, offensive,
or harmful.
Community leaders have the right and responsibility to remove, edit, or reject
comments, commits, code, wiki edits, issues, and other contributions that are
not aligned to this Code of Conduct, and will communicate reasons for moderation
decisions when appropriate.
## Scope
This Code of Conduct applies within all community spaces, and also applies when
an individual is officially representing the community in public spaces.
Examples of representing our community include using an official e-mail address,
posting via an official social media account, or acting as an appointed
representative at an online or offline event.
## Enforcement
Instances of abusive, harassing, or otherwise unacceptable behavior may be
reported to the community leaders responsible for enforcement at codeofconduct@posit.co.
All complaints will be reviewed and investigated promptly and fairly.
All community leaders are obligated to respect the privacy and security of the
reporter of any incident.
## Enforcement Guidelines
Community leaders will follow these Community Impact Guidelines in determining
the consequences for any action they deem in violation of this Code of Conduct:
### 1. Correction
**Community Impact**: Use of inappropriate language or other behavior deemed
unprofessional or unwelcome in the community.
**Consequence**: A private, written warning from community leaders, providing
clarity around the nature of the violation and an explanation of why the
behavior was inappropriate. A public apology may be requested.
### 2. Warning
**Community Impact**: A violation through a single incident or series of
actions.
**Consequence**: A warning with consequences for continued behavior. No
interaction with the people involved, including unsolicited interaction with
those enforcing the Code of Conduct, for a specified period of time. This
includes avoiding interactions in community spaces as well as external channels
like social media. Violating these terms may lead to a temporary or permanent
ban.
### 3. Temporary Ban
**Community Impact**: A serious violation of community standards, including
sustained inappropriate behavior.
**Consequence**: A temporary ban from any sort of interaction or public
communication with the community for a specified period of time. No public or
private interaction with the people involved, including unsolicited interaction
with those enforcing the Code of Conduct, is allowed during this period.
Violating these terms may lead to a permanent ban.
### 4. Permanent Ban
**Community Impact**: Demonstrating a pattern of violation of community
standards, including sustained inappropriate behavior, harassment of an
individual, or aggression toward or disparagement of classes of individuals.
**Consequence**: A permanent ban from any sort of public interaction within the
community.
## Attribution
This Code of Conduct is adapted from the [Contributor Covenant][homepage],
version 2.1, available at
.
Community Impact Guidelines were inspired by
[Mozilla's code of conduct enforcement ladder][https://github.com/mozilla/inclusion].
For answers to common questions about this code of conduct, see the FAQ at
. Translations are available at .
[homepage]: https://www.contributor-covenant.org
================================================
FILE: .github/CONTRIBUTING.md
================================================
# Contributing to mvgam
This document outlines how to propose a change to mvgam.
For a detailed discussion on contributing to this and other open source R packages, please see the [development contributing guide](https://rstd.io/tidy-contrib) and our [code review principles](https://code-review.tidyverse.org/).
## Fixing typos
You can fix typos, spelling mistakes, or grammatical errors in the documentation directly using the GitHub web interface, as long as the changes are made in the _source_ file.
This generally means you'll need to edit [roxygen2 comments](https://roxygen2.r-lib.org/articles/roxygen2.html) in an `.R`, not a `.Rd` file.
You can find the `.R` file that generates the `.Rd` by reading the comment in the first line.
## Bigger changes
If you want to make a bigger change, it's a good idea to first file an issue and make sure someone from the team agrees that it’s needed.
If you’ve found a bug, please file an issue that illustrates the bug with a minimal
[reprex](https://www.tidyverse.org/help/#reprex) (this will also help you write a unit test, if needed).
See the tidyverse guide on [how to create a great issue](https://code-review.tidyverse.org/issues/) for more advice.
### Pull request process
* Fork the package and clone onto your computer. If you haven't done this before, we recommend using `usethis::create_from_github("nicholasjclark/mvgam", fork = TRUE)`.
* Install all development dependencies with `devtools::install_dev_deps()`, and then make sure the package passes R CMD check by running `devtools::check()`.
If R CMD check doesn't pass cleanly, it's a good idea to ask for help before continuing.
* Create a Git branch for your pull request (PR). We recommend using `usethis::pr_init("brief-description-of-change")`.
* Make your changes, commit to git, and then create a PR by running `usethis::pr_push()`, and following the prompts in your browser.
The title of your PR should briefly describe the change.
The body of your PR should contain `Fixes #issue-number`.
* For user-facing changes, add a bullet to the top of `NEWS.md` (i.e. just below the first header). Follow the style described in .
### Code style
* New code should follow the tidyverse [style guide](https://style.tidyverse.org) where possible.
You can use the [styler](https://CRAN.R-project.org/package=styler) package to apply these styles, but please don't restyle code that has nothing to do with your PR.
* We use [roxygen2](https://cran.r-project.org/package=roxygen2), with [Markdown syntax](https://cran.r-project.org/web/packages/roxygen2/vignettes/rd-formatting.html), for documentation.
* We use [testthat](https://cran.r-project.org/package=testthat) for unit tests.
Contributions with test cases included are easier to accept.
## Code of Conduct
Please note that the mvgam project is released with a
[Contributor Code of Conduct](CODE_OF_CONDUCT.md). By contributing to this
project you agree to abide by its terms.
## Roadmap
The mvgam package is in a stable state of development, with some degree of active subsequent development as envisioned by the primary authors.
================================================
FILE: .github/FUNDING.yml
================================================
github: nicholasjclark
================================================
FILE: .github/workflows/R-CMD-check-rstan.yaml
================================================
# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
on:
push:
branches: [main, master]
pull_request:
branches: [main, master]
name: R-CMD-check-rstan
jobs:
R-CMD-check:
runs-on: ${{ matrix.config.os }}
name: ${{ matrix.config.os }} (${{ matrix.config.r }})
strategy:
fail-fast: false
matrix:
config:
- {os: macos-latest, r: 'release'}
- {os: windows-latest, r: 'release'}
# use 4.0 or 4.1 to check with rtools40's older compiler
- {os: windows-latest, r: 'oldrel-4'}
- {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'}
- {os: ubuntu-latest, r: 'release'}
# Use a CRAN-like environment to emulate CRAN submission checks
env:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
NOT_CRAN: false
R_KEEP_PKG_SOURCE: yes
steps:
- uses: actions/checkout@v4
- uses: n1hility/cancel-previous-runs@v2
with:
token: ${{ secrets.GITHUB_TOKEN }}
- uses: r-lib/actions/setup-pandoc@v2
- uses: r-lib/actions/setup-r@v2
with:
r-version: ${{ matrix.config.r }}
rtools-version: ${{ matrix.config.rtools }}
http-user-agent: ${{ matrix.config.http-user-agent }}
use-public-rspm: true
# Install some suggests packages
- uses: r-lib/actions/setup-r-dependencies@v2
with:
dependencies: NA
extra-packages: |
BH
RcppEigen
knitr
extraDistr
lubridate
wrswoR
tweedie
corpcor
splines2
ggrepel
ggpp
ggarrow
scoringRules
matrixStats
xts
collapse
rmarkdown
ggplot2
rjags
coda
testthat
usethis
rcmdcheck
- name: Ensure install works
run: |
install.packages('mvgam', repos = "http://cran.rstudio.com")
shell: Rscript {0}
- uses: r-lib/actions/check-r-package@v2
with:
build_args: 'c("--no-manual", "--no-build-vignettes")'
args: 'c("--no-examples", "--no-manual", "--as-cran", "--ignore-vignettes")'
================================================
FILE: .github/workflows/R-CMD-check.yaml
================================================
# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
on:
push:
branches: [main, master]
pull_request:
branches: [main, master]
name: R-CMD-check
jobs:
R-CMD-check:
runs-on: ${{ matrix.config.os }}
name: ${{ matrix.config.os }} (${{ matrix.config.r }})
strategy:
fail-fast: false
matrix:
config:
# Cmdstan isntall not working on win-latest release; check back later
- {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'}
- {os: ubuntu-latest, r: 'release'}
env:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
R_KEEP_PKG_SOURCE: yes
steps:
- uses: actions/checkout@v4
- uses: n1hility/cancel-previous-runs@v2
with:
token: ${{ secrets.GITHUB_TOKEN }}
- uses: r-lib/actions/setup-pandoc@v2
- uses: r-lib/actions/setup-r@v2
with:
r-version: ${{ matrix.config.r }}
rtools-version: ${{ matrix.config.rtools }}
http-user-agent: ${{ matrix.config.http-user-agent }}
use-public-rspm: true
# As cmdstanr is not yet on CRAN, configure the action to only install the
# 'Depends' packages by default and then manually specify the 'Suggests'
# packages that are needed for R CMD CHECK
- uses: r-lib/actions/setup-r-dependencies@v2
with:
dependencies: NA
extra-packages: |
knitr
extraDistr
lubridate
wrswoR
tweedie
corpcor
splines2
scoringRules
matrixStats
xts
collapse
rmarkdown
ggplot2
rjags
ggrepel
ggpp
ggarrow
coda
stan-dev/cmdstanr
testthat
usethis
rcmdcheck
devtools
- name: Build Cmdstan
run: |
install.packages('mvgam', repos = "http://cran.rstudio.com")
cmdstanr::check_cmdstan_toolchain(fix = TRUE)
cmdstanr::install_cmdstan()
shell: Rscript {0}
- name: Install colorspace manually
run: |
install.packages("colorspace", repos = "https://cran.rstudio.com/")
shell: Rscript {0}
- uses: r-lib/actions/check-r-package@v2
with:
build_args: 'c("--no-manual", "--no-build-vignettes")'
args: 'c("--no-manual", "--as-cran", "--ignore-vignettes")'
- name: Run dontrun examples
run: |
devtools::run_examples(run_dontrun = TRUE, fresh = FALSE)
shell: Rscript {0}
================================================
FILE: .github/workflows/memcheck.yaml
================================================
# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
on:
push:
branches: [main, master]
pull_request:
branches: [main, master]
name: memcheck
jobs:
memcheck:
runs-on: ubuntu-latest
env:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
NOT_CRAN: false
steps:
- uses: actions/checkout@v2
- uses: n1hility/cancel-previous-runs@v2
with:
token: ${{ secrets.GITHUB_TOKEN }}
- uses: actions/checkout@v2
- name: apt install dependency
run: |
sudo apt-get update
sudo apt-get -y install valgrind
- uses: r-lib/actions/setup-r@v2
with:
use-public-rspm: true
- uses: r-lib/actions/setup-r-dependencies@v2
with:
dependencies: NA
extra-packages: |
devtools
testthat
- name: Memory check
run: |
R -d valgrind -f memcheck.R
- name: Configure GH
run: |
git config --global user.name "$GITHUB_ACTOR"
git config --global user.email "$GITHUB_ACTOR@users.noreply.github.com"
- name: Install Air latest
shell: bash
run: |
curl -LsSf https://github.com/posit-dev/air/releases/latest/download/air-installer.sh | sh
- name: Air version
shell: bash
run: |
echo ""
echo "Formatting R code with $(air --version)"
echo ""
- name: Format R code using Air
shell: bash
run: air format .
- name: Commit any Air formatting changes
shell: bash
run: |
if find . -type f \( -name '*.r' -o -name '*.R' \) -exec git add -u {} +; then
echo "Staged modified R files"
git commit -a -m '`air format` (GitHub Actions)'
git push
else
echo "No changes found in any R files"
fi
================================================
FILE: .github/workflows/pkgdown.yaml
================================================
# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
on:
push:
branches: [main, master]
pull_request:
branches: [main, master]
release:
types: [published]
workflow_dispatch:
name: pkgdown
jobs:
pkgdown:
runs-on: ubuntu-latest
# Only restrict concurrency for non-PR jobs
concurrency:
group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }}
env:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
R_KEEP_PKG_SOURCE: yes
steps:
- uses: actions/checkout@v3
- uses: r-lib/actions/setup-pandoc@v2
- uses: r-lib/actions/setup-r@v2
with:
use-public-rspm: true
- uses: r-lib/actions/setup-r-dependencies@v2
with:
dependencies: NA
extra-packages: |
local::.
remotes
knitr
extraDistr
lubridate
gratia
wrswoR
tweedie
ggrepel
ggpp
ggarrow
corpcor
splines2
scoringRules
matrixStats
xts
collapse
rmarkdown
stan-dev/cmdstanr
usethis
- name: Build Cmdstan and install development brms version
run: |
cmdstanr::check_cmdstan_toolchain(fix = TRUE)
cmdstanr::install_cmdstan()
remotes::install_github('paul-buerkner/brms')
remotes::install_version("pkgdown", version = "2.0.9")
shell: Rscript {0}
- name: Build site
run: pkgdown::build_site_github_pages(lazy = TRUE, run_dont_run = TRUE, new_process = FALSE, install = FALSE)
shell: Rscript {0}
- name: Deploy to GitHub pages 🚀
if: github.event_name != 'pull_request'
uses: JamesIves/github-pages-deploy-action@v4.4.1
with:
clean: false
branch: gh-pages
folder: docs
================================================
FILE: .github/workflows/readme.yaml
================================================
# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
on:
push:
branches: master
name: render-rmarkdown
jobs:
render-rmarkdown:
runs-on: ubuntu-latest
env:
GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
steps:
- name: Checkout repo
uses: actions/checkout@v4
with:
fetch-depth: 0
- uses: r-lib/actions/setup-pandoc@v2
- uses: r-lib/actions/setup-r@v2
with:
use-public-rspm: true
- uses: r-lib/actions/setup-r-dependencies@v2
with:
extra-packages: |
rmarkdown
knitr
gratia
patchwork
remotes
splines2
extraDistr
stan-dev/cmdstanr
- name: Install mvgam
run: Rscript -e 'remotes::install_github("nicholasjclark/mvgam", upgrade_dependencies = FALSE)'
- name: Build Cmdstan
run: |
cmdstanr::check_cmdstan_toolchain(fix = TRUE)
cmdstanr::install_cmdstan()
shell: Rscript {0}
- name: Render README
run: Rscript -e 'rmarkdown::render("README.Rmd", output_format = "md_document")'
- name: Render pkgdown index
run: Rscript -e 'rmarkdown::render("index.Rmd", output_format = "md_document")'
- name: Commit results
run: |
git config --local user.name "$GITHUB_ACTOR"
git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com"
git commit README.md index.md man/figures/README*.png -m 'Re-build README.Rmd' || echo "No changes to commit"
git push origin || echo "No changes to commit"
================================================
FILE: .gitignore
================================================
*.Rproj*
.Rhistory
.RData
.Ruserdata
.Rprofile
Meta
.Rproj.user
/Meta/
desktop.ini
^cran-comments\.md$
^src\.gcda$
claude.exe
================================================
FILE: CLAUDE.md
================================================
# CLAUDE.md
This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository.
## Package Overview
mvgam is an R package for fitting Multivariate Dynamic Generalized Additive Models.The package enables Bayesian forecasting and analysis of multivariate time series data using flexible GAM frameworks. It can handle various data types (counts, proportions, continuous values) with complex temporal dynamics, missing data, and seasonality, building custom Stan models that provide robust Bayesian inference.
## Development Commands
### Testing
- `R CMD check` - Full package check (used in CI)
- `testthat::test_check("mvgam")` - Run all tests via testthat
- `devtools::test()` - Run tests interactively during development
### Building and Documentation
- `devtools::document()` - Generate documentation from roxygen2 comments
- `pkgdown::build_site()` - Build package website
- `devtools::build()` - Build package tarball
- `devtools::install()` - Install package locally for development
### Package Structure
- Uses standard R package structure with DESCRIPTION, NAMESPACE, and man/ directories
- Source code organized in `R/` directory with provider-specific files
- Vignettes in vignettes/ directory demonstrate key features
- Tests in `tests/testthat/`
## Architecture
### Key Design Patterns
**S3 Type System**: Uses S3 for structured objects
- Maintains compatibility with R's statistical modeling ecosystem
- Supports method inheritance and specialization
**Layered Architecture Pattern**: Uses clear separation of concerns across multiple layers:
- Interface Layer: User-facing functions (mvgam(), forecast(), plot()) provide clean APIs
- Model Specification Layer: Formula processing, trend model constructors (RW(), VAR(), GP()), family definitions
- Code Generation Layer: Translates R specifications into Stan/JAGS model code
- Computational Backend Layer: Interfaces with Stan/JAGS for MCMC sampling
- Post-processing Layer: Methods for analysis, diagnostics, and visualization
**Modular Component System**: Modular design where different components can be mixed and matched:
- Trend Modules: Independent implementations of different temporal dynamics (Random Walk, AR, VAR, Gaussian Process, CAR)
- Family Modules: Separate observation model implementations for different distributions
- Backend Modules: Pluggable computational backends (Stan via rstan/cmdstanr, JAGS)
- Visualization Modules: Modular plotting system with specialized functions for different aspects
**Bayesian Workflow Integration Pattern**: Designed around the complete Bayesian modeling workflow:
- Model Building: Formula specification, prior setup, trend model selection
- Fitting: MCMC sampling with convergence monitoring
- Checking: Posterior predictive checks, residual analysis, diagnostic plots
- Inference: Parameter summarization, uncertainty quantification
- Prediction: Forecasting with proper uncertainty propagation
- Evaluation: Cross-validation, scoring rules, model comparison
## Key Files
### Core Model Functions
- `R/mvgam.R` - Main model fitting function that:
- Validates and processes GAM formulas for observation and trend processes
- Sets up Stan/JAGS model code generation
- Runs MCMC sampling and returns fitted model objects
- Trend model constructors in `R/mvgam_trend_types.R` (`RW()`, `AR()`, `VAR()`, `GP()`, `CAR()`):
- Define temporal dynamics specifications
- Configure stationarity constraints and correlation structures
### Prediction & Forecasting
- `R/forecast.mvgam.R` - Generates in-sample and out-of-sample forecasts:
- Respects temporal dynamics for proper time series forecasting
- Supports multiple prediction types (response, trend, link)
- Returns structured forecast objects with uncertainty quantification
- `R/predict.mvgam.R` - General prediction treating trends as random effects
### Visualization Suite
- `R/plot.mvgam.R` - Main plotting method with multiple types:
- Series plots, residual diagnostics, smooth functions, forecasts
- Calls specialized functions: `plot_mvgam_forecasts()`, `plot_mvgam_series()`, `plot_mvgam_trend()`
### Model Analysis
- `R/summary.mvgam.R` - Parameter estimates and convergence diagnostics
- `R/ppc.mvgam.R` - Posterior predictive checks using bayesplot
- `R/residuals.mvgam.R` - Dunn-Smyth residuals for model checking
- `R/loo.mvgam.R` - Approximate leave-one-out cross-validation
### Family Support
- Extensive distribution families in `R/families.R`:
- Standard: gaussian, poisson, binomial, Gamma
- Extended: negative binomial, beta, Student-t, Tweedie
- Special: N-mixture models for imperfect detection
### Testing and Quality
- `tests/testthat/` - Test suite
- `vignettes/` - Documentation and examples
- `.github/workflows/` - CI/CD with R CMD check, pkgdown building and valgrind check
## Development Notes
### Testing Strategy
- Separate test files for each major component
- Prioritize internal mvgam objects (i.e. `mvgam:::mvgam_example1`) for testing
### File Management
- Specification documents (`*-requirements.md`, `*-design.md`, `*-implementation.md`) should be automatically added to `.Rbuildignore`
- Any temporary development files should be excluded from package builds
- When creating new specification files, always update `.Rbuildignore` to prevent inclusion in built package
### Code Organization
- Provider files should follow consistent naming pattern
- Utility functions should be grouped by purpose (`utils-*.R`)
- Standalone imports should minimize external dependencies
### Documentation
- Roxygen2 comments for all exported functions
- tidyverse styling (https://style.tidyverse.org/) for all R and roxygen code
- Vignettes demonstrate in-depth use cases
- pkgdown site provides comprehensive documentation
- Examples demonstrate simpler use cases
================================================
FILE: CRAN-SUBMISSION
================================================
Version: 1.1.0
Date: 2024-04-18 23:09:30 UTC
SHA: 3d852f1f92b4d6d10ed64dc212fd6b0ebf933bca
================================================
FILE: DESCRIPTION
================================================
Package: mvgam
Title: Multivariate (Dynamic) Generalized Additive Models
Version: 1.1.595
Date: 2026-01-19
Authors@R: c(person("Nicholas J", "Clark", email = "nicholas.j.clark1214@gmail.com",
role = c("aut", "cre"), comment = c(ORCID = "0000-0001-7131-3301")),
person("KANK", "Karunarathna", role = c("ctb"),
comment = c("ARMA parameterisations and factor models", ORCID = "0000-0002-8995-5502")),
person("Sarah", "Heaps", role = c("ctb"),
comment = c("VARMA parameterisations", ORCID = "0000-0002-5543-037X")),
person("Scott", "Pease", role = c("ctb"),
comment = c("broom enhancements", ORCID = "0009-0006-8977-9285")),
person("Matthijs", "Hollanders", role = c("ctb"),
comment = c("ggplot visualizations", ORCID = "0000-0003-0796-1018")))
Description: Fit Bayesian Dynamic Generalized Additive Models to multivariate observations. Users can build nonlinear State-Space models that can incorporate semiparametric effects in observation and process components, using a wide range of observation families. Estimation is performed using Markov Chain Monte Carlo with Hamiltonian Monte Carlo in the software 'Stan'. References: Clark & Wells (2023) .
URL: https://github.com/nicholasjclark/mvgam, https://nicholasjclark.github.io/mvgam/
BugReports: https://github.com/nicholasjclark/mvgam/issues
License: MIT + file LICENSE
Depends:
R (>= 3.6.0)
Imports:
brms (>= 2.21.0),
methods,
mgcv (>= 1.8-13),
insight (>= 0.19.1),
marginaleffects (>= 0.29.0),
Rcpp (>= 0.12.0),
rstan (>= 2.29.0),
posterior (>= 1.0.0),
loo (>= 2.3.1),
rstantools (>= 2.1.1),
bayesplot (>= 1.5.0),
ggplot2 (>= 3.5.0),
mvnfast,
purrr,
dplyr,
magrittr,
rlang,
generics,
tibble (>= 3.0.0),
patchwork (>= 1.2.0)
Encoding: UTF-8
LazyData: true
Roxygen: list(markdown = TRUE)
RoxygenNote: 7.3.2
Suggests:
scoringRules,
matrixStats,
cmdstanr (>= 0.5.0),
tweedie,
splines2,
extraDistr,
corpcor,
wrswoR,
ggrepel,
ggpp,
ggarrow,
xts,
lubridate,
knitr,
collapse,
rmarkdown,
rjags,
coda,
runjags,
usethis,
testthat,
colorspace
Enhances:
gratia (>= 0.9.0),
tidyr
Additional_repositories: https://mc-stan.org/r-packages/
LinkingTo: Rcpp, RcppArmadillo
VignetteBuilder: knitr
================================================
FILE: LICENSE
================================================
YEAR: 2021
COPYRIGHT HOLDER: Nicholas Clark
================================================
FILE: LICENSE.md
================================================
# MIT License
Copyright (c) 2021 Nicholas Clark
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.
================================================
FILE: NAMESPACE
================================================
# Generated by roxygen2: do not edit by hand
S3method(Predict.matrix,mod.smooth)
S3method(Predict.matrix,moi.smooth)
S3method(add_residuals,mvgam)
S3method(as.array,mvgam)
S3method(as.data.frame,mvgam)
S3method(as.matrix,mvgam)
S3method(as_draws,mvgam)
S3method(as_draws_array,mvgam)
S3method(as_draws_df,mvgam)
S3method(as_draws_list,mvgam)
S3method(as_draws_matrix,mvgam)
S3method(as_draws_rvars,mvgam)
S3method(augment,mvgam)
S3method(coef,mvgam)
S3method(conditional_effects,mvgam)
S3method(ensemble,mvgam_forecast)
S3method(fevd,mvgam)
S3method(find_predictors,mvgam)
S3method(find_predictors,mvgam_prefit)
S3method(fitted,mvgam)
S3method(forecast,mvgam)
S3method(formula,mvgam)
S3method(formula,mvgam_prefit)
S3method(get_coef,mvgam)
S3method(get_data,mvgam)
S3method(get_data,mvgam_prefit)
S3method(get_predict,mvgam)
S3method(get_vcov,mvgam)
S3method(hindcast,mvgam)
S3method(how_to_cite,mvgam)
S3method(irf,mvgam)
S3method(lfo_cv,mvgam)
S3method(logLik,mvgam)
S3method(log_posterior,mvgam)
S3method(loo,mvgam)
S3method(loo_compare,mvgam)
S3method(mcmc_plot,mvgam)
S3method(model.frame,mvgam)
S3method(model.frame,mvgam_prefit)
S3method(neff_ratio,mvgam)
S3method(nuts_params,mvgam)
S3method(ordinate,jsdgam)
S3method(pairs,mvgam)
S3method(plot,mvgam)
S3method(plot,mvgam_conditional_effects)
S3method(plot,mvgam_fevd)
S3method(plot,mvgam_forecast)
S3method(plot,mvgam_irf)
S3method(plot,mvgam_lfo)
S3method(plot,mvgam_residcor)
S3method(posterior_epred,mvgam)
S3method(posterior_linpred,mvgam)
S3method(posterior_predict,mvgam)
S3method(pp_check,mvgam)
S3method(ppc,mvgam)
S3method(predict,mvgam)
S3method(print,how_to_cite)
S3method(print,mvgam)
S3method(print,mvgam_conditional_effects)
S3method(print,mvgam_prefit)
S3method(print,mvgam_summary)
S3method(print,mvgammodel)
S3method(residual_cor,jsdgam)
S3method(residual_cor,mvgam)
S3method(residuals,mvgam)
S3method(rhat,mvgam)
S3method(score,mvgam_forecast)
S3method(set_coef,mvgam)
S3method(smooth.construct,mod.smooth.spec)
S3method(smooth.construct,moi.smooth.spec)
S3method(stability,mvgam)
S3method(stancode,mvgam)
S3method(stancode,mvgam_prefit)
S3method(standata,mvgam_prefit)
S3method(summary,mvgam)
S3method(summary,mvgam_fevd)
S3method(summary,mvgam_forecast)
S3method(summary,mvgam_irf)
S3method(summary,mvgam_prefit)
S3method(tidy,mvgam)
S3method(update,jsdgam)
S3method(update,mvgam)
S3method(variables,mvgam)
export("%>%")
export(AR)
export(CAR)
export(GP)
export(PW)
export(RW)
export(VAR)
export(ZMVN)
export(add_residuals)
export(as_draws)
export(as_draws_array)
export(as_draws_df)
export(as_draws_list)
export(as_draws_matrix)
export(as_draws_rvars)
export(augment)
export(avg_predictions)
export(bernoulli)
export(beta_binomial)
export(betar)
export(code)
export(compare_mvgams)
export(comparisons)
export(conditional_effects)
export(datagrid)
export(drawDotmvgam)
export(dynamic)
export(ensemble)
export(eval_mvgam)
export(eval_smoothDothilbertDotsmooth)
export(eval_smoothDotmodDotsmooth)
export(eval_smoothDotmoiDotsmooth)
export(fevd)
export(forecast)
export(get_data)
export(get_mvgam_priors)
export(get_predict)
export(gp)
export(hindcast)
export(how_to_cite)
export(hypotheses)
export(irf)
export(jsdgam)
export(lfo_cv)
export(lognormal)
export(loo)
export(loo_compare)
export(lv_correlations)
export(mcmc_plot)
export(mvgam)
export(nb)
export(neff_ratio)
export(nmix)
export(nuts_params)
export(ordinate)
export(plot_comparisons)
export(plot_mvgam_factors)
export(plot_mvgam_fc)
export(plot_mvgam_pterms)
export(plot_mvgam_randomeffects)
export(plot_mvgam_resids)
export(plot_mvgam_series)
export(plot_mvgam_smooth)
export(plot_mvgam_trend)
export(plot_mvgam_uncertainty)
export(plot_predictions)
export(plot_slopes)
export(posterior_epred)
export(posterior_linpred)
export(posterior_predict)
export(pp_check)
export(ppc)
export(predictions)
export(prior)
export(prior_)
export(prior_string)
export(residual_cor)
export(rhat)
export(roll_eval_mvgam)
export(s)
export(score)
export(series_to_mvgam)
export(set_prior)
export(sim_mvgam)
export(slopes)
export(stability)
export(stancode)
export(standata)
export(student)
export(student_t)
export(t2)
export(te)
export(ti)
export(tidy)
export(tweedie)
export(variables)
importFrom(Rcpp,evalCpp)
importFrom(bayesplot,color_scheme_get)
importFrom(bayesplot,color_scheme_set)
importFrom(bayesplot,log_posterior)
importFrom(bayesplot,neff_ratio)
importFrom(bayesplot,nuts_params)
importFrom(bayesplot,pp_check)
importFrom(brms,bernoulli)
importFrom(brms,beta_binomial)
importFrom(brms,brm)
importFrom(brms,brmsterms)
importFrom(brms,conditional_effects)
importFrom(brms,dbeta_binomial)
importFrom(brms,do_call)
importFrom(brms,dstudent_t)
importFrom(brms,get_prior)
importFrom(brms,gp)
importFrom(brms,logm1)
importFrom(brms,lognormal)
importFrom(brms,mcmc_plot)
importFrom(brms,ndraws)
importFrom(brms,pbeta_binomial)
importFrom(brms,prior)
importFrom(brms,prior_)
importFrom(brms,prior_string)
importFrom(brms,pstudent_t)
importFrom(brms,qstudent_t)
importFrom(brms,rbeta_binomial)
importFrom(brms,read_csv_as_stanfit)
importFrom(brms,rstudent_t)
importFrom(brms,set_prior)
importFrom(brms,stancode)
importFrom(brms,standata)
importFrom(brms,student)
importFrom(generics,augment)
importFrom(generics,forecast)
importFrom(generics,tidy)
importFrom(ggplot2,aes)
importFrom(ggplot2,facet_wrap)
importFrom(ggplot2,geom_bar)
importFrom(ggplot2,ggplot)
importFrom(ggplot2,labs)
importFrom(ggplot2,scale_colour_discrete)
importFrom(ggplot2,scale_fill_discrete)
importFrom(ggplot2,theme_classic)
importFrom(grDevices,devAskNewPage)
importFrom(grDevices,hcl.colors)
importFrom(grDevices,rgb)
importFrom(graphics,abline)
importFrom(graphics,axis)
importFrom(graphics,barplot)
importFrom(graphics,box)
importFrom(graphics,boxplot)
importFrom(graphics,bxp)
importFrom(graphics,hist)
importFrom(graphics,layout)
importFrom(graphics,legend)
importFrom(graphics,lines)
importFrom(graphics,par)
importFrom(graphics,plot)
importFrom(graphics,points)
importFrom(graphics,polygon)
importFrom(graphics,rect)
importFrom(graphics,rug)
importFrom(graphics,title)
importFrom(grid,arrow)
importFrom(grid,unit)
importFrom(insight,find_predictors)
importFrom(insight,get_data)
importFrom(insight,get_predictors)
importFrom(loo,is.loo)
importFrom(loo,loo)
importFrom(loo,loo_compare)
importFrom(magrittr,"%>%")
importFrom(marginaleffects,avg_predictions)
importFrom(marginaleffects,comparisons)
importFrom(marginaleffects,datagrid)
importFrom(marginaleffects,get_coef)
importFrom(marginaleffects,get_predict)
importFrom(marginaleffects,get_vcov)
importFrom(marginaleffects,hypotheses)
importFrom(marginaleffects,plot_comparisons)
importFrom(marginaleffects,plot_predictions)
importFrom(marginaleffects,plot_slopes)
importFrom(marginaleffects,predictions)
importFrom(marginaleffects,set_coef)
importFrom(marginaleffects,slopes)
importFrom(methods,cbind2)
importFrom(mgcv,Predict.matrix)
importFrom(mgcv,Rrank)
importFrom(mgcv,bam)
importFrom(mgcv,betar)
importFrom(mgcv,gam.control)
importFrom(mgcv,gam.side)
importFrom(mgcv,get.var)
importFrom(mgcv,initial.sp)
importFrom(mgcv,interpret.gam)
importFrom(mgcv,nb)
importFrom(mgcv,s)
importFrom(mgcv,smooth.construct)
importFrom(mgcv,smoothCon)
importFrom(mgcv,t2)
importFrom(mgcv,te)
importFrom(mgcv,ti)
importFrom(parallel,clusterExport)
importFrom(parallel,setDefaultCluster)
importFrom(parallel,stopCluster)
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,rhat)
importFrom(posterior,variables)
importFrom(rlang,missing_arg)
importFrom(rlang,parse_expr)
importFrom(rlang,warn)
importFrom(rstantools,posterior_epred)
importFrom(rstantools,posterior_linpred)
importFrom(rstantools,posterior_predict)
importFrom(stats,.getXlevels)
importFrom(stats,Gamma)
importFrom(stats,acf)
importFrom(stats,as.dist)
importFrom(stats,as.formula)
importFrom(stats,binomial)
importFrom(stats,coef)
importFrom(stats,complete.cases)
importFrom(stats,cor)
importFrom(stats,cov)
importFrom(stats,cov2cor)
importFrom(stats,dbeta)
importFrom(stats,dbinom)
importFrom(stats,density)
importFrom(stats,dgamma)
importFrom(stats,dlnorm)
importFrom(stats,dnbinom)
importFrom(stats,dnorm)
importFrom(stats,dpois)
importFrom(stats,drop.terms)
importFrom(stats,ecdf)
importFrom(stats,fitted)
importFrom(stats,formula)
importFrom(stats,frequency)
importFrom(stats,gaussian)
importFrom(stats,hclust)
importFrom(stats,is.ts)
importFrom(stats,lag)
importFrom(stats,lm)
importFrom(stats,logLik)
importFrom(stats,mad)
importFrom(stats,make.link)
importFrom(stats,median)
importFrom(stats,model.frame)
importFrom(stats,model.matrix)
importFrom(stats,model.offset)
importFrom(stats,na.fail)
importFrom(stats,na.omit)
importFrom(stats,na.pass)
importFrom(stats,pacf)
importFrom(stats,pbeta)
importFrom(stats,pbinom)
importFrom(stats,pgamma)
importFrom(stats,plnorm)
importFrom(stats,plogis)
importFrom(stats,pnorm)
importFrom(stats,poisson)
importFrom(stats,ppois)
importFrom(stats,predict)
importFrom(stats,printCoefmat)
importFrom(stats,qbinom)
importFrom(stats,qcauchy)
importFrom(stats,qlogis)
importFrom(stats,qnorm)
importFrom(stats,qqline)
importFrom(stats,qqnorm)
importFrom(stats,quantile)
importFrom(stats,rbeta)
importFrom(stats,rbinom)
importFrom(stats,reformulate)
importFrom(stats,residuals)
importFrom(stats,rgamma)
importFrom(stats,rlnorm)
importFrom(stats,rnbinom)
importFrom(stats,rnorm)
importFrom(stats,rpois)
importFrom(stats,runif)
importFrom(stats,sd)
importFrom(stats,setNames)
importFrom(stats,start)
importFrom(stats,terms)
importFrom(stats,terms.formula)
importFrom(stats,time)
importFrom(stats,ts)
importFrom(stats,update)
importFrom(stats,update.formula)
importFrom(utils,getFromNamespace)
importFrom(utils,head)
importFrom(utils,lsf.str)
importFrom(utils,tail)
useDynLib(mvgam, .registration = TRUE)
================================================
FILE: NEWS.md
================================================
# mvgam 1.1.595
## New functionalities
* Restructured `summary.mvgam()` to now return an object of class `mvgam_summary` that can be re-used for later purposes, or that can be printed with `print.mvgam_summary()` (#119)
* Added a new function `ordinate.jsdgam()` to plot two-dimensional ordinations of site and species scores from latent factor models estimated in `jsdgam()`
* `residual_cor()` now supports models fitted with `mvgam()` in which latent factors were used or in which correlated dynamic processes were used
* Added a `summary.mvgam_forecast()` function to compute and return prediction intervals of posterior hindcasts and forecasts in a `data.frame` format. This will make it easier for users to create their own custom plots of hindcast and forecast distributions (#108)
* Added a [`mvgam_use_cases`](https://nicholasjclark.github.io/mvgam/reference/mvgam_use_cases.html) help file to provide links to online resources that discuss how to use 'mvgam' in practice
## Changing defaults
* The `forecast()` method is now imported from 'generics' to help avoid conflict issues with other forecasting packages
* Deprecated the `incl_dynamics` argument in the `loo()` and `loo_compare()` functions to ensure better consistency in log-likelihood and resulting LOO estimates from models with different observation families
* Changed default `type` in `conditional_effects()` to `expected` to match behaviour of 'brms'
## Bug fixes
* Bug fix to ensure forecast scores are properly computed when plotting objects of class `mvgam_forecast` if only a single out-of-sample observation was included in `newdata` (#111)
* Bug fix to ensure offsets supplied with `offset(...)` in formulae are correctly incorporated when using `gp()` terms
* Bug fix to ensure piecewise trends are correctly predicted when using `process_error = TRUE` in `predict()`
* Bug fix to ensure variance of continuous time autoregressive processes (using `CAR()`) scales appropriately with time lags (#107)
* Bug fix to ensure `summary.mvgam()` uses the correct `max_treedepth` value when checking Stan diagnostics, rather than always assuming the default of 10 (thanks to @StefanoMezzini for reporting)
* Bug fix to ensure `NA` residual values are handled properly when plotting residuals (this occurs because response values are allowed to be missing; (thanks to @StefanoMezzini for reporting)
## Deprecations
* Altered the structure of objects of class `mvgam_forecast` so that the `train_times` and `test_times` slots now contain lists of length `n_series`. This allows for continuous time data to be better handled, where some series may have been sampled at different timepoints
# mvgam 1.1.51
## New functionalities
* Changed default priors for scale parameters (i.e. process errors `"sigma"` and observation errors `"sigma_obs"`) to inverse gammas to provide more sensible prior regularisation away from zero
* Improved messaging in `summary()` for better guidance on how to investigate poor HMC sampler behaviours
* Converted several more plotting functions to return `ggplot` objects in place of base R plots for broader customisation
* Added four new `type`s to the `pp_check()` function to allow more targeted investigations of randomized quantile residual distributions
* Added a `plot.mvgam_residcor()` function for nicer plotting of estimated residual correlations from `jsdgam` objects
* Added `summary()` functions to calculate useful posterior summaries from objects of class `mvgam_irf` and `mvgam_fevd` (see `?irf` and `?fevd` for examples)
* Improved efficiency of `nmix()` models with some slight restructuring of the model objects (#102)
## Bug fixes
* Bug fix to ensure piecewise trends are extrapolated the correct number of timepoints when forecasting using the `forecast()` function
# mvgam 1.1.4
## New functionalities
* Added the `how_to_cite.mvgam()` function to generate a scaffold methods description of fitted models, which can hopefully make it easier for users to fully describe their programming environment
* Improved various plotting functions by returning `ggplot` objects in place of base plots (thanks to @mhollanders #38)
* Added the brier score (`score = 'brier'`) as an option in `score.mvgam_forecast()` for scoring forecasts of binary variables when using `family = bernoulli()` (#80)
* Added `augment()` function to add residuals and fitted values to an mvgam object's observed data (thanks to @swpease #83)
* Added support for approximate `gp()` effects with more than one covariate and with different kernel functions (#79)
* Added function `jsdgam()` to estimate Joint Species Distribution Models in which both the latent factors and the observation model components can include any of mvgam's complex linear predictor effects. Also added a function `residual_cor()` to compute residual correlation, covariance and precision matrices from `jsdgam` models. See `?mvgam::jsdgam` and `?mvgam::residual_cor` for details
* Added a `stability.mvgam()` method to compute stability metrics from models fit with Vector Autoregressive dynamics (#21 and #76)
* Added functionality to estimate hierarchical error correlations when using multivariate latent process models and when the data are nested among levels of a relevant grouping factor (#75); see `?mvgam::AR` for an example
* Added `ZMVN()` error models for estimating Zero-Mean Multivariate Normal errors; convenient for working with non time-series data where latent residuals are expected to be correlated (such as when fitting Joint Species Distribution Models); see `?mvgam::ZMVN` for examples
* Added a `fevd.mvgam()` method to compute forecast error variance decompositions from models fit with Vector Autoregressive dynamics (#21 and #76)
## Deprecations
* Arguments `use_stan`, `jags_path`, `data_train`, `data_test`, `adapt_delta`, `max_treedepth` and `drift` have been removed from primary functions to streamline documentation and reflect the package's mission to deprecate 'JAGS' as a suitable backend. Both `adapt_delta` and `max_treedepth` should now be supplied in a named `list()` to the new argument `control`
## Bug fixes
* Bug fix to ensure `marginaleffects::comparisons` functions appropriately recognise internal `rowid` variables
* Updates to ensure `ensemble` provides appropriate weighting of forecast draws (#98)
* Not necessarily a "bug fix", but this update removes several dependencies to lighten installation and improve efficiency of the workflow (#93)
* Fixed a minor bug in the way `trend_map` recognises levels of the `series` factor
* Bug fix to ensure `lfo_cv` recognises the actual times in `time`, just in case the user supplies data that doesn't start at `t = 1`. Also updated documentation to better reflect this
* Bug fix to ensure `update.mvgam` captures any `knots` or `trend_knots` arguments that were passed to the original model call
# mvgam 1.1.3
## New functionalities
* Allow intercepts to be included in process models when `trend_formula` is supplied. This breaks the assumption that the process has to be zero-centred, adding more modelling flexibility but also potentially inducing nonidentifiabilities with respect to any observation model intercepts. Thoughtful priors are a must for these models
* Added `standata.mvgam_prefit`, `stancode.mvgam` and `stancode.mvgam_prefit` methods for better alignment with 'brms' workflows
* Added 'gratia' to *Enhancements* to allow popular methods such as `draw()` to be used for 'mvgam' models if 'gratia' is already installed
* Added an `ensemble.mvgam_forecast()` method to generate evenly weighted combinations of probabilistic forecast distributions
* Added an `irf.mvgam()` method to compute Generalized and Orthogonalized Impulse Response Functions (IRFs) from models fit with Vector Autoregressive dynamics
## Deprecations
* The `drift` argument has been deprecated. It is now recommended for users to include parametric fixed effects of "time" in their respective GAM formulae to capture any expected drift effects
## Bug fixes
* Added a new check to ensure that exception messages are only suppressed by the `silent` argument if the user's version of 'cmdstanr' is adequate
* Updated dependency for 'brms' to version >= '2.21.0' so that `read_csv_as_stanfit` can be imported, which should future-proof the conversion of 'cmdstanr' models to `stanfit` objects (#70)
# mvgam 1.1.2
## New functionalities
* Added options for silencing some of the 'Stan' compiler and modeling messages using the `silent` argument in `mvgam()`
* Moved a number of packages from 'Depends' to 'Imports' for simpler package loading and fewer potential masking conflicts
* Improved efficiency of the model initialisation by tweaking parameters of the underlying 'mgcv' `gam` object's convergence criteria, resulting in much faster model setups
* Added an option to use `trend_model = 'None'` in State-Space models, increasing flexibility by ensuring the process error evolves as white noise (#51)
* Added an option to use the non-centred parameterisation for some autoregressive trend models,
which speeds up mixing most of the time
* Updated support for multithreading so that all observation families (apart from `nmix()`) can now be modeled with multiple threads
* Changed default priors on autoregressive coefficients (AR1, AR2, AR3) to enforce
stationarity, which is a much more sensible prior in the majority of contexts
## Bug fixes
* Fixed a small bug that prevented `conditional_effects.mvgam()` from handling effects with three-way interactions
# mvgam 1.1.1
## New functionalities
* Changed indexing of an internal c++ function after Prof Brian Ripley’s
email: Dear maintainer, Please see the problems shown on
https://cran.r-project.org/web/checks/check_results_mvgam.html. Please correct before 2024-05-22 to safely retain your package on CRAN. The CRAN Team
# mvgam 1.1.0
* First release of `mvgam` to CRAN
================================================
FILE: R/RcppExports.R
================================================
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
#' @noRd
ar3_recursC <- function(drift, ar1, ar2, ar3, linpreds, errors, last_trends, h) {
.Call(`_mvgam_ar3_recursC`, drift, ar1, ar2, ar3, linpreds, errors, last_trends, h)
}
#' @noRd
var1_recursC <- function(A, linpreds, errors, drift, last_trends, h) {
.Call(`_mvgam_var1_recursC`, A, linpreds, errors, drift, last_trends, h)
}
#' @noRd
varma_recursC <- function(A, A2, A3, theta, linpreds, errors, drift, last_trends, h) {
.Call(`_mvgam_varma_recursC`, A, A2, A3, theta, linpreds, errors, drift, last_trends, h)
}
================================================
FILE: R/add_MACor.R
================================================
#' Function to add moving average processes and/or
#' correlated process errors to an existing Stan model file
#' When adding MA for univariate trends, 'error' needs to take same form
#' as trend / LV (array[n] vector[n_lv]) so it can be
#' extracted in the same way
#' @noRd
add_MaCor = function(
model_file,
model_data,
data_train,
data_test,
add_ma = FALSE,
add_cor = FALSE,
trend_model = 'VAR1',
drift = FALSE
) {
if (inherits(trend_model, 'mvgam_trend')) {
trend_char <- ma_cor_additions(validate_trend_model(
trend_model
))$trend_model
} else {
trend_char <- trend_model
}
if (trend_char == 'ZMVN') {
# Update transformed data
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {} else {
if (any(grepl('transformed data {', model_file, fixed = TRUE))) {
model_file[grep('transformed data {', model_file, fixed = TRUE)] <-
paste0(
'transformed data {\n',
'vector[n_series] trend_zeros = rep_vector(0.0, n_series);'
)
} else {
model_file[grep('parameters {', model_file, fixed = TRUE)[1]] <-
paste0(
'transformed data {\n',
'vector[n_series] trend_zeros = rep_vector(0.0, n_series);\n',
'}\nparameters {'
)
}
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update parameters block
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {
model_file[grep('[n_lv] sigma;', model_file, fixed = TRUE)] <-
paste0(
model_file[grep('[n_lv] sigma;', model_file, fixed = TRUE)],
'\n\n',
'// correlated latent residuals\n',
'array[n] vector[n_lv] LV_raw;\n',
'cholesky_factor_corr[n_lv] L_Omega;'
)
starts <- grep("matrix[n, n_lv] LV;", model_file, fixed = TRUE) - 1
ends <- starts + 1
model_file <- model_file[-(starts:ends)]
} else {
model_file[grep(
'vector[n_series] sigma;',
model_file,
fixed = TRUE
)] <-
paste0(
'vector[n_series] sigma;\n\n',
'// correlated latent residuals\n',
'array[n] vector[n_series] trend_raw;\n',
'cholesky_factor_corr[n_series] L_Omega;'
)
starts <- grep("matrix[n, n_series] trend;", model_file, fixed = TRUE) - 1
ends <- starts + 1
model_file <- model_file[-(starts:ends)]
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update transformed parameters block
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {
model_file[grep('transformed parameters {', model_file, fixed = TRUE)] <-
paste0(
'transformed parameters {\n',
paste0(
'matrix[n, n_lv] LV;\n',
'// LKJ form of covariance matrix\n',
'matrix[n_lv, n_lv] L_Sigma;'
)
)
model_file[grep('// derived latent states', model_file, fixed = TRUE)] <-
paste0(
'// correlated residuals\n',
'\nL_Sigma = diag_pre_multiply(sigma, L_Omega);\n',
'for (i in 1:n) {\n',
'LV[i, 1:n_lv] = to_row_vector(LV_raw[i]);\n',
'}\n',
'// derived latent states'
)
} else {
model_file[grep('transformed parameters {', model_file, fixed = TRUE)] <-
paste0(
'transformed parameters {\n',
paste0(
'matrix[n, n_series] trend;\n',
'// LKJ form of covariance matrix\n',
'matrix[n_series, n_series] L_Sigma;'
)
)
last <- grep('model {', model_file, fixed = TRUE)
for (i in last:(last - 5)) {
last <- i
if (trimws(model_file[i]) != '}') {} else {
break
}
}
model_file[last] <-
paste0(
'// correlated residuals\n',
'\nL_Sigma = diag_pre_multiply(sigma, L_Omega);\n',
'for (i in 1:n) {\n',
'trend[i, 1:n_series] = to_row_vector(trend_raw[i]);\n',
'}\n}'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update model block
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {
starts <- grep(
"LV[1, j] ~ normal(trend_mus[ytimes_trend[1, j]], sigma[j]);",
model_file,
fixed = TRUE
) -
1
ends <- grep(
"LV[i, j] ~ normal(trend_mus[ytimes_trend[i, j]] + LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]], sigma[j]);",
model_file,
fixed = TRUE
) +
2
model_file <- model_file[-(starts:ends)]
model_file[starts] <- paste0(
'// residual error correlations\n',
'L_Omega ~ lkj_corr_cholesky(2);\n',
'for (i in 1:n){\n',
'LV_raw[i] ~ multi_normal_cholesky(trend_mus[ytimes_trend[i, 1:n_lv]], L_Sigma);\n',
'}\n',
model_file[starts]
)
} else {
starts <- grep("// trend estimates", model_file, fixed = TRUE)
ends <- grep(
"trend[2:n, s] ~ normal(trend[1:(n - 1), s], sigma[s]);",
model_file,
fixed = TRUE
) +
1
model_file <- model_file[-(starts:ends)]
model_file[starts] <- paste0(
'// residual error correlations\n',
'L_Omega ~ lkj_corr_cholesky(2);\n',
'for (i in 1:n){\n',
'trend_raw[i] ~ multi_normal_cholesky(trend_zeros, L_Sigma);\n',
'}\n',
model_file[starts]
)
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update generated quantities
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {
model_file[grep('// posterior predictions', model_file, fixed = TRUE)] <-
paste0(
'// computed error covariance matrix\n',
'cov_matrix[n_lv] Sigma = multiply_lower_tri_self_transpose(L_Sigma);\n',
'// posterior predictions'
)
} else {
model_file[grep('// posterior predictions', model_file, fixed = TRUE)] <-
paste0(
'// computed error covariance matrix\n',
'cov_matrix[n_series] Sigma = multiply_lower_tri_self_transpose(L_Sigma);\n',
'// posterior predictions'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_char %in% c('RW', 'AR1', 'AR2', 'AR3')) {
if (any(grepl('ytimes_trend', model_file))) {
remove_trendmus <- FALSE
} else {
remove_trendmus <- TRUE
}
# Update transformed data
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {
if (any(grepl('transformed data {', model_file, fixed = TRUE))) {
model_file[grep('transformed data {', model_file, fixed = TRUE)] <-
paste0(
'transformed data {\n',
'vector[n_lv] trend_zeros = rep_vector(0.0, n_lv);'
)
} else {
model_file[grep('parameters {', model_file, fixed = TRUE)[1]] <-
paste0(
'transformed data {\n',
'vector[n_lv] trend_zeros = rep_vector(0.0, n_lv);\n',
'}\nparameters {'
)
}
} else {
if (any(grepl('transformed data {', model_file, fixed = TRUE))) {
model_file[grep('transformed data {', model_file, fixed = TRUE)] <-
paste0(
'transformed data {\n',
'vector[n_series] trend_zeros = rep_vector(0.0, n_series);'
)
} else {
model_file[grep('parameters {', model_file, fixed = TRUE)[1]] <-
paste0(
'transformed data {\n',
'vector[n_series] trend_zeros = rep_vector(0.0, n_series);\n',
'}\nparameters {'
)
}
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update parameters block
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {
if (add_cor) {
model_file[grep('[n_lv] sigma;', model_file, fixed = TRUE)] <-
paste0(
model_file[grep('[n_lv] sigma;', model_file, fixed = TRUE)],
'\n',
'cholesky_factor_corr[n_lv] L_Omega;'
)
}
model_file[grep('matrix[n, n_lv] LV;', model_file, fixed = TRUE)] <-
paste0(
'matrix[n, n_lv] LV;\n',
if (add_ma) {
paste0(
'// ma coefficients\n',
if (add_cor) {
'matrix[n_lv, n_lv] theta;'
} else {
'vector[n_lv] theta;'
}
)
} else {
NULL
},
'\n// dynamic error parameters\n',
'vector[n_lv] error[n];'
)
model_file <- readLines(textConnection(model_file), n = -1)
end <- grep('matrix[n, n_lv] LV;', model_file, fixed = TRUE)
start <- end - 1
model_file <- model_file[-c(start:end)]
} else {
if (add_cor) {
model_file[grep(
'vector[n_series] sigma;',
model_file,
fixed = TRUE
)] <-
paste0(
'vector[n_series] sigma;\n',
'cholesky_factor_corr[n_series] L_Omega;'
)
}
model_file[grep(
'matrix[n, n_series] trend;',
model_file,
fixed = TRUE
)] <-
paste0(
'matrix[n, n_series] trend;\n',
if (add_ma) {
paste0(
'// ma coefficients\n',
if (add_cor) {
'matrix[n_series, n_series] theta;'
} else {
'vector[n_series] theta;'
}
)
} else {
NULL
},
'\n// dynamic error parameters\n',
'vector[n_series] error[n];'
)
model_file <- readLines(textConnection(model_file), n = -1)
end <- grep('matrix[n, n_series] trend;', model_file, fixed = TRUE)
start <- end - 1
model_file <- model_file[-c(start:end)]
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update transformed parameters
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {
model_file[grep(
'matrix[n, n_series] trend;',
model_file,
fixed = TRUE
)] <-
paste0(
'matrix[n, n_series] trend;\n',
if (add_cor) {
paste0(
'vector[n_lv] LV[n];\n',
if (add_ma) {
'vector[n_lv] epsilon[n];\n'
} else {
NULL
},
'// LKJ form of covariance matrix\n',
'matrix[n_lv, n_lv] L_Sigma;\n',
'// computed error covariance matrix\n',
'cov_matrix[n_lv] Sigma;'
)
} else {
paste0(
'matrix[n, n_lv] LV;\n',
if (add_ma) {
'matrix[n, n_lv] epsilon;'
} else {
NULL
}
)
}
)
if (add_cor) {
if (trend_char %in% c('AR1', 'RW')) {
if (any(grep('// derived latent states', model_file, fixed = TRUE))) {
to_modify <- grep(
'// derived latent states',
model_file,
fixed = TRUE
)
} else {
to_modify <- grep(
'// derived latent trends',
model_file,
fixed = TRUE
)
}
model_file[to_modify] <-
paste0(
'// derived latent states\n',
'LV[1] = ',
'trend_mus[ytimes_trend[1, 1:n_lv]] + error[1];\n',
if (add_ma) {
'epsilon[1] = error[1];\n'
},
'for (i in 2:n) {\n',
if (add_ma) {
paste0(
'// lagged error ma process\n',
'epsilon[i] = theta * error[i - 1];\n',
'// full ARMA process\n'
)
} else {
'// full AR process\n'
},
'LV[i] = ',
if (drift) {
'drift * (i - 1) + '
} else {
NULL
},
'trend_mus[ytimes_trend[i, 1:n_lv]] + ',
if (trend_char == 'AR1') {
'ar1 .* '
} else {
NULL
},
'(LV[i - 1] - trend_mus[ytimes_trend[i - 1, 1:n_lv]])',
if (add_ma) {
'+ epsilon[i] + error[i];\n'
} else {
'+ error[i];\n'
},
'}\n'
)
}
if (trend_char == 'AR2') {
if (any(grep('// derived latent states', model_file, fixed = TRUE))) {
to_modify <- grep(
'// derived latent states',
model_file,
fixed = TRUE
)
} else {
to_modify <- grep(
'// derived latent trends',
model_file,
fixed = TRUE
)
}
model_file[to_modify] <-
paste0(
'// derived latent states\n',
'LV[1] = ',
'trend_mus[ytimes_trend[1, 1:n_lv]] + error[1];\n',
if (add_ma) {
paste0(
'epsilon[1] = error[1];\n',
'epsilon[2] = theta * error[1];\n'
)
} else {
NULL
},
'LV[2] = ',
if (drift) {
'drift + '
} else {
NULL
},
'trend_mus[ytimes_trend[2, 1:n_lv]] + ',
'ar1 .* (LV[1] - trend_mus[ytimes_trend[1, 1:n_lv]]) + ',
if (add_ma) {
'epsilon[2] + error[2];\n'
} else {
'error[2];\n'
},
'for (i in 3:n) {\n',
if (add_ma) {
paste0(
'// lagged error ma process\n',
'epsilon[i] = theta * error[i - 1];\n',
'// full ARMA process\n'
)
} else {
'// full AR process\n'
},
'LV[i] = ',
if (drift) {
'drift * (i - 1) + '
} else {
NULL
},
'trend_mus[ytimes_trend[i, 1:n_lv]] + ',
'ar1 .* (LV[i - 1] - trend_mus[ytimes_trend[i - 1, 1:n_lv]]) + ',
'ar2 .* (LV[i - 2] - trend_mus[ytimes_trend[i - 2, 1:n_lv]]) + ',
if (add_ma) {
'epsilon[i] + error[i];\n'
} else {
'error[i];\n'
},
'}\n'
)
}
if (trend_char == 'AR3') {
if (any(grep('// derived latent states', model_file, fixed = TRUE))) {
to_modify <- grep(
'// derived latent states',
model_file,
fixed = TRUE
)
} else {
to_modify <- grep(
'// derived latent trends',
model_file,
fixed = TRUE
)
}
model_file[to_modify] <-
paste0(
'// derived latent states\n',
'LV[1] = ',
'trend_mus[ytimes_trend[1, 1:n_lv]] + error[1];\n',
if (add_ma) {
paste0(
'epsilon[1] = error[1];\n',
'epsilon[2] = theta * error[1];\n',
'epsilon[3] = theta * error[2];\n'
)
} else {
NULL
},
'LV[2] = ',
if (drift) {
'drift + '
} else {
NULL
},
'trend_mus[ytimes_trend[2, 1:n_lv]] + ',
'ar1 .* (LV[1] - trend_mus[ytimes_trend[1, 1:n_lv]]) + ',
if (add_ma) {
'epsilon[2] + error[2];\n'
} else {
'error[2];\n'
},
'LV[3] = ',
if (drift) {
'drift * 2 + '
} else {
NULL
},
'trend_mus[ytimes_trend[3, 1:n_lv]] + ',
'ar1 .* (LV[2] - trend_mus[ytimes_trend[2, 1:n_lv]]) + ',
'ar2 .* (LV[1] - trend_mus[ytimes_trend[1, 1:n_lv]]) + ',
if (add_ma) {
'epsilon[3] + error[3];\n'
} else {
'error[3];\n'
},
'for (i in 4:n) {\n',
if (add_ma) {
paste0(
'// lagged error ma process\n',
'epsilon[i] = theta * error[i - 1];\n',
'// full ARMA process\n'
)
} else {
'// full AR process\n'
},
'LV[i] = ',
if (drift) {
'drift * (i - 1) + '
} else {
NULL
},
'trend_mus[ytimes_trend[i, 1:n_lv]] + ',
'ar1 .* (LV[i - 1] - trend_mus[ytimes_trend[i - 1, 1:n_lv]]) + ',
'ar2 .* (LV[i - 2] - trend_mus[ytimes_trend[i - 2, 1:n_lv]]) + ',
'ar3 .* (LV[i - 3] - trend_mus[ytimes_trend[i - 3, 1:n_lv]]) + ',
if (add_ma) {
'epsilon[i] + error[i];\n'
} else {
'error[i];\n'
},
'}\n'
)
}
} else {
if (trend_char %in% c('AR1', 'RW')) {
if (any(grep('// derived latent states', model_file, fixed = TRUE))) {
to_modify <- grep(
'// derived latent states',
model_file,
fixed = TRUE
)
} else {
to_modify <- grep(
'// derived latent trends',
model_file,
fixed = TRUE
)
}
model_file[to_modify] <-
paste0(
'// derived latent states\n',
'for(j in 1:n_lv){\n',
'LV[1, j] = ',
'trend_mus[ytimes_trend[1, j]] + error[1, j];\n',
'epsilon[1, j] = error[1, j];\n',
'for(i in 2:n){\n',
'// lagged error ma process\n',
'epsilon[i, j] = theta[j] * error[i-1, j];\n',
'// full ARMA process\n',
'LV[i, j] = ',
if (drift) {
'drift[j] * (i - 1) + '
} else {
NULL
},
'trend_mus[ytimes_trend[i, j]] + ',
if (trend_char == 'AR1') {
'ar1[j] * '
} else {
NULL
},
'(LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]) + ',
'epsilon[i, j] + error[i, j];\n',
'}\n}'
)
}
if (trend_char == 'AR2') {
if (any(grep('// derived latent states', model_file, fixed = TRUE))) {
to_modify <- grep(
'// derived latent states',
model_file,
fixed = TRUE
)
} else {
to_modify <- grep(
'// derived latent trends',
model_file,
fixed = TRUE
)
}
model_file[to_modify] <-
paste0(
'// derived latent states\n',
'for(j in 1:n_lv){\n',
'LV[1, j] = ',
'trend_mus[ytimes_trend[1, j]] + error[1, j];\n',
'epsilon[1, j] = error[1, j];\n',
'epsilon[2, j] = theta[j] * error[1, j];\n',
'LV[2, j] = ',
if (drift) {
'drift[j] + '
} else {
NULL
},
'trend_mus[ytimes_trend[1, j]] + ',
'ar1[j] * (LV[1, j] - trend_mus[ytimes_trend[1, j]]) + ',
'epsilon[2, j] + error[2, j];\n',
'for(i in 3:n){\n',
'// lagged error ma process\n',
'epsilon[i, j] = theta[j] * error[i-1, j];\n',
'// full ARMA process\n',
'LV[i, j] = ',
if (drift) {
'drift[j] * (i - 1) + '
} else {
NULL
},
'trend_mus[ytimes_trend[i, j]] + ',
'ar1[j] * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]) + ',
'ar2[j] * (LV[i - 2, j] - trend_mus[ytimes_trend[i - 2, j]]) + ',
'epsilon[i, j] + error[i, j];\n',
'}\n}'
)
}
if (trend_char == 'AR3') {
if (any(grep('// derived latent states', model_file, fixed = TRUE))) {
to_modify <- grep(
'// derived latent states',
model_file,
fixed = TRUE
)
} else {
to_modify <- grep(
'// derived latent trends',
model_file,
fixed = TRUE
)
}
model_file[to_modify] <-
paste0(
'// derived latent states\n',
'for(j in 1:n_lv){\n',
'LV[1, j] = ',
'trend_mus[ytimes_trend[1, j]] + error[1, j];\n',
'epsilon[1, j] = error[1, j];\n',
'epsilon[2, j] = theta[j] * error[1, j];\n',
'epsilon[3, j] = theta[j] * error[2, j];\n',
'LV[2, j] = ',
if (drift) {
'drift[j] + '
} else {
NULL
},
'trend_mus[ytimes_trend[2, j]] + ',
'ar1[j] * (LV[1, j] - trend_mus[ytimes_trend[1, j]]) + ',
'epsilon[2, j] + error[2, j];\n',
'LV[3, j] = ',
if (drift) {
'drift[j] * 2 + '
} else {
NULL
},
'trend_mus[ytimes_trend[1, j]] + ',
'ar1[j] * (LV[2, j] - trend_mus[ytimes_trend[2, j]]) + ',
'ar2[j] * (LV[1, j] - trend_mus[ytimes_trend[1, j]]) + ',
'epsilon[3, j] + error[3, j];\n',
'for(i in 4:n){\n',
'// lagged error ma process\n',
'epsilon[i, j] = theta[j] * error[i-1, j];\n',
'// full ARMA process\n',
'LV[i, j] = ',
if (drift) {
'drift[j] * (i - 1) + '
} else {
NULL
},
'trend_mus[ytimes_trend[i, j]] + ',
'ar1[j] * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]) + ',
'ar2[j] * (LV[i - 2, j] - trend_mus[ytimes_trend[i - 2, j]]) + ',
'ar3[j] * (LV[i - 3, j] - trend_mus[ytimes_trend[i - 3, j]]) + ',
'epsilon[i, j] + error[i, j];\n',
'}\n}'
)
}
}
if (add_cor) {
model_file[grep('lv_coefs = Z;', model_file, fixed = TRUE)] <-
paste0(
'L_Sigma = diag_pre_multiply(sigma, L_Omega);\n',
'Sigma = multiply_lower_tri_self_transpose(L_Sigma);\n',
'lv_coefs = Z;'
)
}
} else {
model_file[grep('transformed parameters {', model_file, fixed = TRUE)] <-
paste0(
'transformed parameters {\n',
if (add_cor) {
paste0(
'vector[n_series] trend_raw[n];\n',
'matrix[n, n_series] trend;\n',
if (add_ma) {
'vector[n_series] epsilon[n];\n'
} else {
NULL
},
'// LKJ form of covariance matrix\n',
'matrix[n_series, n_series] L_Sigma;\n',
'// computed error covariance matrix\n',
'cov_matrix[n_series] Sigma;'
)
} else {
paste0(
'matrix[n, n_series] trend;\n',
if (add_ma) {
'matrix[n, n_series] epsilon;'
} else {
NULL
}
)
}
)
if (add_cor) {
if (trend_char %in% c('AR1', 'RW')) {
if (any(grepl('= mu_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= mu_raw[', model_file, fixed = TRUE))
} else if (any(grepl('= b_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= b_raw[', model_file, fixed = TRUE))
}
model_file[insert_line] <-
paste0(
model_file[insert_line],
'\n// derived latent states\n',
'trend_raw[1] = ',
'error[1];\n',
if (add_ma) {
'epsilon[1] = error[1];\n'
} else {
NULL
},
'for (i in 2:n) {\n',
if (add_ma) {
paste0(
'// lagged error ma process\n',
'epsilon[i] = theta * error[i - 1];\n',
'// full ARMA process\n'
)
} else {
paste0('// full AR process\n')
},
'trend_raw[i] = ',
if (drift) {
'drift * (i - 1) + '
} else {
NULL
},
if (trend_char == 'AR1') {
'ar1 .* '
} else {
NULL
},
'trend_raw[i - 1] + ',
if (add_ma) {
'epsilon[i] + error[i];\n'
} else {
'error[i];\n'
},
'}\n'
)
}
if (trend_char == 'AR2') {
if (any(grepl('= mu_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= mu_raw[', model_file, fixed = TRUE))
} else if (any(grepl('= b_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= b_raw[', model_file, fixed = TRUE))
}
model_file[insert_line] <-
paste0(
model_file[insert_line],
'\n// derived latent states\n',
'trend_raw[1] = ',
'error[1];\n',
if (add_ma) {
paste0(
'epsilon[1] = error[1];\n',
'epsilon[2] = theta * error[1];\n'
)
} else {
NULL
},
'trend_raw[2] = ',
if (drift) {
'drift + '
} else {
NULL
},
'ar1 .* trend_raw[1] + ',
if (add_ma) {
'epsilon[2] + error[2];\n'
} else {
'error[2];\n'
},
'for (i in 3:n) {\n',
if (add_ma) {
paste0(
'// lagged error ma process\n',
'epsilon[i] = theta * error[i - 1];\n',
'// full ARMA process\n'
)
} else {
'// full AR process\n'
},
'trend_raw[i] = ',
if (drift) {
'drift * (i - 1) + '
} else {
NULL
},
'ar1 .* trend_raw[i - 1] + ',
'ar2 .* trend_raw[i - 2] + ',
if (add_ma) {
'epsilon[i] + error[i];\n'
} else {
'error[i];\n'
},
'}\n'
)
}
if (trend_char == 'AR3') {
if (any(grepl('= mu_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= mu_raw[', model_file, fixed = TRUE))
} else if (any(grepl('= b_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= b_raw[', model_file, fixed = TRUE))
}
model_file[insert_line] <-
paste0(
model_file[insert_line],
'\n// derived latent states\n',
'trend_raw[1] = ',
'error[1];\n',
if (add_ma) {
paste0(
'epsilon[1] = error[1];\n',
'epsilon[2] = theta * error[1];\n',
'epsilon[3] = theta * error[2];\n'
)
} else {
NULL
},
'trend_raw[2] = ',
if (drift) {
'drift + '
} else {
NULL
},
'ar1 .* trend_raw[1] + ',
if (add_ma) {
'epsilon[2] + error[2];\n'
} else {
'error[2];\n'
},
'trend_raw[3] = ',
if (drift) {
'drift * 2 + '
} else {
NULL
},
'ar1 .* trend_raw[2] + ',
'ar2 .* trend_raw[1] + ',
if (add_ma) {
'epsilon[3] + error[3];\n'
} else {
'error[3];\n'
},
'for (i in 4:n) {\n',
if (add_ma) {
paste0(
'// lagged error ma process\n',
'epsilon[i] = theta * error[i - 1];\n',
'// full ARMA process\n'
)
} else {
'// full AR process\n'
},
'trend_raw[i] = ',
if (drift) {
'drift * (i - 1) + '
} else {
NULL
},
'ar1 .* trend_raw[i - 1] + ',
'ar2 .* trend_raw[i - 2] + ',
'ar3 .* trend_raw[i - 3] + ',
if (add_ma) {
'epsilon[i] + error[i];\n'
} else {
'error[i];\n'
},
'}\n'
)
}
} else {
if (trend_char %in% c('AR1', 'RW')) {
if (any(grepl('= mu_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= mu_raw[', model_file, fixed = TRUE))
} else if (any(grepl('= b_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= b_raw[', model_file, fixed = TRUE))
}
model_file[insert_line] <-
paste0(
model_file[insert_line],
'\nfor(j in 1:n_series){\n',
'trend[1, j] = ',
'error[1, j];\n',
'epsilon[1, j] = error[1, j];\n',
'for(i in 2:n){\n',
'// lagged error ma process\n',
'epsilon[i, j] = theta[j] * error[i-1, j];\n',
'// full ARMA process\n',
'trend[i, j] = ',
if (drift) {
'drift[j] * (i - 1) + '
} else {
NULL
},
if (trend_char == 'AR1') {
'ar1[j] * '
} else {
NULL
},
'trend[i - 1, j] + ',
'epsilon[i, j] + error[i, j];\n',
'}\n}'
)
}
if (trend_char == 'AR2') {
if (any(grepl('= mu_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= mu_raw[', model_file, fixed = TRUE))
} else if (any(grepl('= b_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= b_raw[', model_file, fixed = TRUE))
}
model_file[insert_line] <-
paste0(
model_file[insert_line],
'\nfor(j in 1:n_series){\n',
'trend[1, j] = ',
'error[1, j];\n',
'epsilon[1, j] = error[1, j];\n',
'epsilon[2, j] = theta[j] * error[1, j];\n',
'trend[2, j] = ',
if (drift) {
'drift[j] + '
} else {
NULL
},
'ar1[j] * trend[1, j] + ',
'epsilon[2, j] + error[2, j];\n',
'for(i in 3:n){\n',
'// lagged error ma process\n',
'epsilon[i, j] = theta[j] * error[i-1, j];\n',
'// full ARMA process\n',
'trend[i, j] = ',
if (drift) {
'drift[j] * (i - 1) + '
} else {
NULL
},
'ar1[j] * trend[i - 1, j] + ',
'ar2[j] * trend[i - 2, j] + ',
'epsilon[i, j] + error[i, j];\n',
'}\n}'
)
}
if (trend_char == 'AR3') {
if (any(grepl('= mu_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= mu_raw[', model_file, fixed = TRUE))
} else if (any(grepl('= b_raw[', model_file, fixed = TRUE))) {
insert_line <- max(grep('= b_raw[', model_file, fixed = TRUE))
}
model_file[insert_line] <-
paste0(
model_file[insert_line],
'\nfor(j in 1:n_series){\n',
'trend[1, j] = ',
'error[1, j];\n',
'epsilon[1, j] = error[1, j];\n',
'epsilon[2, j] = theta[j] * error[1, j];\n',
'epsilon[3, j] = theta[j] * error[2, j];\n',
'trend[2, j] = ',
if (drift) {
'drift[j] + '
} else {
NULL
},
'ar1[j] * trend[1, j] + ',
'epsilon[2, j] + error[2, j];\n',
'trend[3, j] = ',
if (drift) {
'drift[j] * 2 + '
} else {
NULL
},
'ar1[j] * trend[2, j] + ',
'ar2[j] * trend[1, j] + ',
'epsilon[2, j] + error[2, j];\n',
'for(i in 4:n){\n',
'// lagged error ma process\n',
'epsilon[i, j] = theta[j] * error[i-1, j];\n',
'// full ARMA process\n',
'trend[i, j] = ',
if (drift) {
'drift[j] * (i - 1) + '
} else {
NULL
},
'ar1[j] * trend[i - 1, j] + ',
'ar2[j] * trend[i - 2, j] + ',
'ar3[j] * trend[i - 3, j] + ',
'epsilon[i, j] + error[i, j];\n',
'}\n}'
)
}
}
model_file <- readLines(textConnection(model_file), n = -1)
if (add_cor) {
last <- grep('model {', model_file, fixed = TRUE)
for (i in last:(last - 5)) {
last <- i
if (trimws(model_file[i]) != '}') {} else {
break
}
}
model_file[last] <-
paste0(
'\nL_Sigma = diag_pre_multiply(sigma, L_Omega);\n',
'Sigma = multiply_lower_tri_self_transpose(L_Sigma);\n',
'for (i in 1:n) {\n',
'trend[i, 1:n_series] = to_row_vector(trend_raw[i]);\n',
'}\n}'
)
}
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update model block
if (any(grepl('[n_lv] sigma;', model_file, fixed = TRUE))) {
if (any(grepl('LV[1, j] ~ normal', model_file, fixed = TRUE))) {
start <- grep('LV[1, j] ~ normal', model_file, fixed = TRUE) - 1
end <- grep('LV[i, j] ~ normal', model_file, fixed = TRUE) + 2
} else {
start <- grep('LV[1, 1:n_lv] ~ normal(', model_file, fixed = TRUE) - 1
first <- grep(':n, j] ~ normal(', model_file, fixed = TRUE)
second <- grep('sigma[j]);', model_file, fixed = TRUE)
end <- intersect(first, second) + 1
}
model_file <- model_file[-c(start:end)]
model_file[start] <- paste0(
'// contemporaneous errors\n',
if (add_cor) {
paste0(
'L_Omega ~ lkj_corr_cholesky(2);\n',
'for(i in 1:n) {\n',
'error[i] ~ multi_normal_cholesky(trend_zeros, L_Sigma);\n',
'}'
)
} else {
paste0(
'for(i in 1:n) {\n',
'error[i] ~ normal(trend_zeros, sigma);\n',
'}'
)
},
if (add_ma) {
paste0(
'\n// ma coefficients\n',
if (add_cor) {
paste0(
'for(i in 1:n_lv){\n',
'for(j in 1:n_lv){\n',
'if (i != j)\n',
'theta[i, j] ~ normal(0, 0.2);\n',
'}\n}'
)
} else {
'theta ~ normal(0, 0.2);'
}
)
} else {
NULL
},
'\n',
model_file[start]
)
} else {
start <- grep(
'trend[1, 1:n_series] ~ normal(',
model_file,
fixed = TRUE
) -
1
first <- grep(':n, s] ~ normal(', model_file, fixed = TRUE)
second <- grep('sigma[s]);', model_file, fixed = TRUE)
end <- intersect(first, second) + 1
model_file <- model_file[-c(start:end)]
model_file[start] <- paste0(
'// contemporaneous errors\n',
if (add_cor) {
paste0(
'L_Omega ~ lkj_corr_cholesky(2);\n',
'for(i in 1:n) {\n',
'error[i] ~ multi_normal_cholesky(trend_zeros, L_Sigma);\n',
'}'
)
} else {
paste0(
'for(i in 1:n) {\n',
'error[i] ~ normal(trend_zeros, sigma);\n',
'}'
)
},
if (add_ma) {
paste0(
'\n// ma coefficients\n',
if (add_cor) {
paste0(
'for(i in 1:n_series){\n',
'for(j in 1:n_series){\n',
'if (i != j)\n',
'theta[i, j] ~ normal(0, 0.2);\n',
'}\n}'
)
} else {
'theta ~ normal(0, 0.2);'
}
)
} else {
NULL
},
'\n',
model_file[start]
)
}
if (remove_trendmus) {
model_file <- gsub(
'trend_mus[ytimes_trend[1, 1:n_lv]] +',
'',
model_file,
fixed = TRUE
)
model_file <- gsub(
'trend_mus[ytimes_trend[i, 1:n_lv]] + ',
'',
model_file,
fixed = TRUE
)
model_file <- gsub(
' - trend_mus[ytimes_trend[i - 1, 1:n_lv]]',
'',
model_file,
fixed = TRUE
)
model_file <- gsub(
' - trend_mus[ytimes_trend[1, 1:n_lv]]',
'',
model_file,
fixed = TRUE
)
model_file <- gsub(
' - trend_mus[ytimes_trend[i - 2, 1:n_lv]]',
'',
model_file,
fixed = TRUE
)
model_file <- gsub(
'trend_mus[ytimes_trend[2, 1:n_lv]] + ',
'',
model_file,
fixed = TRUE
)
model_file <- gsub(
'trend_mus[ytimes_trend[3, 1:n_lv]] + ',
'',
model_file,
fixed = TRUE
)
model_file <- gsub(
' - trend_mus[ytimes_trend[2, 1:n_lv]]',
'',
model_file,
fixed = TRUE
)
model_file <- gsub(
' - trend_mus[ytimes_trend[i - 3, 1:n_lv]]',
'',
model_file,
fixed = TRUE
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (grepl('VAR', trend_char) & add_ma) {
# Only ma can be added for VAR models currently
# Replace the reverse mapping function with the MA representation
start <- grep(
'/* Function to perform the reverse mapping*/',
model_file,
fixed = TRUE
)
end <- grep('return phiGamma;', model_file, fixed = TRUE) + 1
model_file <- model_file[-c(start:end)]
model_file[
grep(
'return mdivide_left_spd(sqrtm(B), P_real);',
model_file,
fixed = TRUE
) +
1
] <-
paste0(
'}\n',
'/* Function to compute Kronecker product */\n\n',
'/* see Heaps 2022 for details (https://doi.org/10.1080/10618600.2022.2079648)*/\n',
'matrix kronecker_prod(matrix A, matrix B) {\n',
'matrix[rows(A) * rows(B), cols(A) * cols(B)] C;\n',
'int m = rows(A);\n',
'int n = cols(A);\n',
'int p = rows(B);\n',
'int q = cols(B);\n',
'for (i in 1:m) {\n',
'for (j in 1:n) {\n',
'int row_start = (i - 1) * p + 1;\n',
'int row_end = (i - 1) * p + p;\n',
'int col_start = (j - 1) * q + 1;\n',
'int col_end = (j - 1) * q + q;\n',
'C[row_start:row_end, col_start:col_end] = A[i, j] * B;\n',
'}\n',
'}\n',
'return C;\n',
'}\n',
'/* Function to perform the reverse mapping\n\n',
'/* see Heaps 2022 for details (https://doi.org/10.1080/10618600.2022.2079648)*/\n',
'matrix[] rev_mapping(matrix[] P, matrix Sigma) {\n',
'int p = size(P);\n',
'int m = rows(Sigma);\n',
'matrix[m, m] phi_for[p, p]; matrix[m, m] phi_rev[p, p];\n',
'matrix[m, m] Sigma_for[p+1]; matrix[m, m] Sigma_rev[p+1];\n',
'matrix[m, m] S_for; matrix[m, m] S_rev;\n',
'matrix[m, m] S_for_list[p+1];\n',
'// Step 1:\n',
'Sigma_for[p+1] = Sigma;\n',
'S_for_list[p+1] = sqrtm(Sigma);\n',
'for(s in 1:p) {\n',
'// In this block of code S_rev is B^{-1} and S_for is a working matrix\n',
'S_for = - tcrossprod(P[p-s+1]);\n',
'for(i in 1:m) S_for[i, i] += 1.0;\n',
'S_rev = sqrtm(S_for);\n',
'S_for_list[p-s+1] = mdivide_right_spd(mdivide_left_spd(S_rev,\n',
'sqrtm(quad_form_sym(Sigma_for[p-s+2], S_rev))), S_rev);\n',
'Sigma_for[p-s+1] = tcrossprod(S_for_list[p-s+1]);\n',
'}\n',
'// Step 2:\n',
'Sigma_rev[1] = Sigma_for[1];\n',
'for(s in 0:(p-1)) {\n',
'S_for = S_for_list[s+1];\n',
'S_rev = sqrtm(Sigma_rev[s+1]);\n',
'phi_for[s+1, s+1] = mdivide_right_spd(S_for * P[s+1], S_rev);\n',
"phi_rev[s+1, s+1] = mdivide_right_spd(S_rev * P[s+1]', S_for);\n",
'if(s>=1) {\n',
'for(k in 1:s) {\n',
'phi_for[s+1, k] = phi_for[s, k] - phi_for[s+1, s+1] * phi_rev[s, s-k+1];\n',
'phi_rev[s+1, k] = phi_rev[s, k] - phi_rev[s+1, s+1] * phi_for[s, s-k+1];\n',
'}\n',
'}\n',
'Sigma_rev[s+2] = Sigma_rev[s+1] - quad_form_sym(Sigma_for[s+1],\n',
"phi_rev[s+1, s+1]');\n",
'}\n',
'return phi_for[p];\n',
'}\n',
'/* Function to compute the joint (stationary) distribution of\n',
'(y_0, ..., y_{1-p}, eps_0, ..., eps_{1-q})\n\n',
'/* see Heaps 2022 for details (https://doi.org/10.1080/10618600.2022.2079648)*/\n',
'matrix initial_joint_var(matrix Sigma, matrix[] phi, matrix[] theta) {\n',
'int p = size(phi);\n',
'int q = size(theta);\n',
'int m = rows(Sigma);\n',
'matrix[(p+q)*m, (p+q)*m] companion_mat = rep_matrix(0.0, (p+q)*m, (p+q)*m);\n',
'matrix[(p+q)*m, (p+q)*m] companion_var = rep_matrix(0.0, (p+q)*m, (p+q)*m);\n',
'matrix[(p+q)*m*(p+q)*m, (p+q)*m*(p+q)*m] tmp = diag_matrix(rep_vector(1.0,\n',
'(p+q)*m*(p+q)*m));\n',
'matrix[(p+q)*m, (p+q)*m] Omega;\n',
'// Construct phi_tilde:\n',
'for(i in 1:p) {\n',
'companion_mat[1:m, ((i-1)*m+1):(i*m)] = phi[i];\n',
'if(i>1) {\n',
'for(j in 1:m) {\n',
'companion_mat[(i-1)*m+j, (i-2)*m+j] = 1.0;\n',
'}\n',
'}\n',
'}\n',
'for(i in 1:q) {\n',
'companion_mat[1:m, ((p+i-1)*m+1):((p+i)*m)] = theta[i];\n',
'}\n',
'if(q>1) {\n',
'for(i in 2:q) {\n',
'for(j in 1:m) {\n',
'companion_mat[(p+i-1)*m+j, (p+i-2)*m+j] = 1.0;\n',
'}\n',
'}\n',
'}\n',
'// Construct Sigma_tilde:\n',
'companion_var[1:m, 1:m] = Sigma;\n',
'companion_var[(p*m+1):((p+1)*m), (p*m+1):((p+1)*m)] = Sigma;\n',
'companion_var[1:m, (p*m+1):((p+1)*m)] = Sigma;\n',
'companion_var[(p*m+1):((p+1)*m), 1:m] = Sigma;\n',
'// Compute Gamma0_tilde\n',
'tmp -= kronecker_prod(companion_mat, companion_mat);\n',
"Omega = to_matrix(tmp \\ to_vector(companion_var), (p+q)*m, (p+q)*m);\n",
'// Ensure Omega is symmetric:\n',
'for(i in 1:(rows(Omega)-1)) {\n',
'for(j in (i+1):rows(Omega)) {\n',
'Omega[j, i] = Omega[i, j];\n',
'}\n',
'}\n',
'return Omega;\n',
'}\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
# Update transformed data
if (
any(grepl(
'cholesky_factor_corr[n_lv] L_Omega;',
model_file,
fixed = TRUE
))
) {
model_file[grep(
'transformed data {',
model_file,
fixed = TRUE
)] <- paste0(
'transformed data {\n',
'vector[n_lv] trend_zeros = rep_vector(0.0, n_lv);\n',
'vector[n_lv*2] init_zeros = rep_vector(0.0, n_lv*2);\n'
)
} else {
model_file[grep(
'vector[n_series] trend_zeros = rep_vector(0.0, n_series);',
model_file,
fixed = TRUE
)] <- paste0(
'vector[n_series] trend_zeros = rep_vector(0.0, n_series);\n',
'vector[n_series*2] init_zeros = rep_vector(0.0, n_series*2);\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update parameters
if (
any(grepl(
'cholesky_factor_corr[n_lv] L_Omega;',
model_file,
fixed = TRUE
))
) {
model_file[grep(
'matrix[n_lv, n_lv] P_real;',
model_file,
fixed = TRUE
)] <- paste0(
'matrix[n_lv, n_lv] P_real;\n',
'// unconstrained MA partial autocorrelations\n',
'matrix[n_lv, n_lv] R_real;\n',
'// initial joint stationary VARMA process\n',
'vector[2 * n_lv] init;\n',
'// ma error parameters\n',
'vector[n_lv] error[n];'
)
} else {
model_file[grep(
'matrix[n_series, n_series] P_real;',
model_file,
fixed = TRUE
)] <- paste0(
'matrix[n_series, n_series] P_real;\n',
'// unconstrained MA partial autocorrelations\n',
'matrix[n_series, n_series] R_real;\n',
'// initial joint stationary VARMA process\n',
'vector[2 * n_series] init;\n',
'// ma error parameters\n',
'vector[n_series] error[n];'
)
}
# Update transformed parameters
if (
any(grepl(
'cholesky_factor_corr[n_lv] L_Omega;',
model_file,
fixed = TRUE
))
) {
model_file[grep(
'matrix[n_lv, n_lv] A;',
model_file,
fixed = TRUE
)] <- paste0(
'matrix[n_lv, n_lv] A;\n',
'// latent trend MA autoregressive terms\n',
'matrix[n_lv, n_lv] theta;\n',
'// ma process\n',
'array[n] vector[n_lv] epsilon;\n'
)
end <- grep('vector[n_lv] LV[n];', model_file, fixed = TRUE)
start <- end - 1
model_file <- model_file[-c(start:end)]
model_file[grep(
'cov_matrix[n_lv] Gamma;',
model_file,
fixed = TRUE
)] <- paste0(
'cov_matrix[n_lv * 2] Omega;\n',
"// latent states\n",
"vector[n_lv] LV[n];"
)
start <- grep('// derived latent states', model_file, fixed = TRUE)
end <- grep('Gamma = phiGamma[2, 1];', model_file, fixed = TRUE) + 1
model_file <- model_file[-c(start:end)]
model_file[start] <- paste0(
model_file[start],
'\n',
'// stationary VARMA reparameterisation\n',
'L_Sigma = diag_pre_multiply(sigma, L_Omega);\n',
'Sigma = multiply_lower_tri_self_transpose(L_Sigma);\n',
'{\n',
'// constrained partial autocorrelations\n',
'matrix[n_lv, n_lv] P[1];\n',
'matrix[n_lv, n_lv] R[1];\n',
'// stationary autoregressive coefficients\n',
'matrix[n_lv, n_lv] A_init[1];\n',
'matrix[n_lv, n_lv] theta_init[1];\n',
'P[1] = P_realtoP(P_real);\n',
'R[1] = P_realtoP(R_real);\n',
'// stationary autoregressive and ma coef matrices\n',
'A_init = rev_mapping(P, Sigma);\n',
'theta_init = rev_mapping(R, Sigma);\n',
'theta_init[1] = -theta_init[1];\n',
'// initial stationary covariance structure\n',
'Omega = initial_joint_var(Sigma, A_init, theta_init);\n',
'A = A_init[1];\n',
'theta = theta_init[1];\n',
'}\n',
'// computed VARMA trends\n',
'epsilon[1] = theta * init[(n_lv + 1) : (n_lv * 2)];\n',
'LV[1] = (A * init[1 : n_lv]) + trend_mus[ytimes_trend[1, 1 : n_lv]] + epsilon[1] + error[1];\n',
'for (i in 2 : n) {\n',
'// lagged error ma process\n',
'epsilon[i] = theta * error[i - 1];\n',
'// full VARMA process\n',
'LV[i] = trend_mus[ytimes_trend[i, 1 : n_lv]] + A * (LV[i - 1] - trend_mus[ytimes_trend[i - 1, 1 : n_lv]]) + epsilon[i] + error[i];\n',
'}\n',
'// derived latent states\n',
'lv_coefs = Z;\n',
'for (i in 1 : n) {\n',
'for (s in 1 : n_series) {\n',
'trend[i, s] = dot_product(lv_coefs[s, : ], LV[i]);\n',
'}\n}'
)
} else {
model_file[grep(
'matrix[n_series, n_series] A;',
model_file,
fixed = TRUE
)] <- paste0(
'matrix[n_series, n_series] A;\n',
'// latent trend MA autoregressive terms\n',
'matrix[n_series, n_series] theta;\n',
'// ma process\n',
'array[n] vector[n_series] epsilon;\n'
)
start <- grep('// raw latent trends', model_file, fixed = TRUE)
end <- start + 1
model_file <- model_file[-c(start:end)]
start <- grep(
'// trend estimates in matrix-form',
model_file,
fixed = TRUE
)
end <- grep('Gamma = phiGamma[2, 1];', model_file, fixed = TRUE) + 1
model_file <- model_file[-c(start:end)]
model_file[grep(
'cov_matrix[n_series] Gamma;',
model_file,
fixed = TRUE
)] <- paste0(
'cov_matrix[n_series * 2] Omega;\n',
'// raw latent trends\n',
'vector[n_series] trend_raw[n];\n',
'// trend estimates in matrix-form\n',
'matrix[n, n_series] trend;'
)
model_file[start] <- paste0(
model_file[start],
'\n',
'// stationary VARMA reparameterisation\n',
'L_Sigma = diag_pre_multiply(sigma, L_Omega);\n',
'Sigma = multiply_lower_tri_self_transpose(L_Sigma);\n',
'{\n',
'// constrained partial autocorrelations\n',
'matrix[n_series, n_series] P[1];\n',
'matrix[n_series, n_series] R[1];\n',
'// stationary autoregressive coefficients\n',
'matrix[n_series, n_series] A_init[1];\n',
'matrix[n_series, n_series] theta_init[1];\n',
'P[1] = P_realtoP(P_real);\n',
'R[1] = P_realtoP(R_real);\n',
'// stationary autoregressive and ma coef matrices\n',
'A_init = rev_mapping(P, Sigma);\n',
'theta_init = rev_mapping(R, Sigma);\n',
'theta_init[1] = -theta_init[1];\n',
'// initial stationary covariance structure\n',
'Omega = initial_joint_var(Sigma, A_init, theta_init);\n',
'A = A_init[1];\n',
'theta = theta_init[1];\n',
'}\n',
'// computed VARMA trends\n',
'epsilon[1] = theta * init[(n_series + 1) : (n_series * 2)];\n',
'trend_raw[1] = (A * init[1 : n_series]) + epsilon[1] + error[1];\n',
'for (i in 2 : n) {\n',
'// lagged error ma process\n',
'epsilon[i] = theta * error[i - 1];\n',
'// full VARMA process\n',
'trend_raw[i] = (A * trend_raw[i - 1]) + epsilon[i] + error[i];\n',
'}\n',
'// computed trends in matrix form\n',
'for (i in 1 : n) {\n',
'trend[i, 1 : n_series] = to_row_vector(trend_raw[i]);\n',
'}'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update model
if (
any(grepl(
'cholesky_factor_corr[n_lv] L_Omega;',
model_file,
fixed = TRUE
))
) {
start <- grep('// latent state mean parameters', model_file, fixed = TRUE)
end <- start + 1
model_file <- model_file[-c(start:end)]
model_file[grep('// latent state means', model_file, fixed = TRUE)] <-
paste0(
'// unconstrained ma inverse partial autocorrelations\n',
'diagonal(R_real) ~ std_normal();\n',
'for (i in 1 : n_lv) {\n',
'for (j in 1 : n_lv) {\n',
'if (i != j)\n',
'R_real[i, j] ~ std_normal();\n',
'}\n',
'}\n',
'// initial joint stationary distribution\n',
'init ~ multi_normal(init_zeros, Omega);\n',
'// correlated contemporaneous errors\n',
'for (i in 1 : n) {\n',
'error[i] ~ multi_normal_cholesky(trend_zeros, L_Sigma);\n',
'}\n',
'// latent state means'
)
model_file <- readLines(textConnection(model_file), n = -1)
end <- grep(
'(LV[i - 1] - trend_mus[ytimes_trend[i - 1, 1:n_lv]]);',
model_file,
fixed = TRUE
) +
1
start <- grep('// latent state means', model_file, fixed = TRUE)
model_file <- model_file[-c(start:end)]
start <- grep(
'LV[1] ~ multi_normal(trend_mus[ytimes_trend[1, 1:n_lv]], Gamma);',
model_file,
fixed = TRUE
)
end <- max(grep('L_Sigma);', model_file, fixed = TRUE)) + 1
model_file <- model_file[-c(start:end)]
} else {
start <- grep('// latent trend mean parameters', model_file, fixed = TRUE)
end <- start + 1
model_file <- model_file[-c(start:end)]
model_file[grep('// trend means', model_file, fixed = TRUE)] <-
paste0(
'// unconstrained ma inverse partial autocorrelations\n',
'diagonal(R_real) ~ std_normal();\n',
'for (i in 1 : n_series) {\n',
'for (j in 1 : n_series) {\n',
'if (i != j)\n',
'R_real[i, j] ~ std_normal();\n',
'}\n',
'}\n',
'// initial joint stationary distribution\n',
'init ~ multi_normal(init_zeros, Omega);\n',
'// correlated contemporaneous errors\n',
'for (i in 1 : n) {\n',
'error[i] ~ multi_normal_cholesky(trend_zeros, L_Sigma);\n',
'}\n',
'// trend means'
)
model_file <- readLines(textConnection(model_file), n = -1)
start <- grep('// trend means', model_file, fixed = TRUE)
end <- max(grep(
'trend_raw[i] ~ multi_normal_cholesky(mu[i - 1], L_Sigma);',
model_file,
fixed = TRUE
)) +
1
model_file <- model_file[-c(start:end)]
}
model_file <- readLines(textConnection(model_file), n = -1)
}
# Now do any rearrangements needed for hierarchical correlations
if (grepl('hiercor', validate_trend_model(trend_model))) {
# Add the function to calculate a convex combination of correlation matrices
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'/* Function to compute a partially pooled correlation matrix */\n',
'/* https://discourse.mc-stan.org/t/hierarchical-prior-for-partial-pooling-on-correlation-matrices*/\n',
'matrix combine_cholesky(matrix global_chol_cor, matrix local_chol_cor, real alpha){',
'int dim = rows(local_chol_cor);\n',
'matrix[dim, dim] global_cor = multiply_lower_tri_self_transpose(global_chol_cor);\n',
'matrix[dim, dim] local_cor = multiply_lower_tri_self_transpose(local_chol_cor);\n',
'matrix[dim, dim] combined_chol_cor;\n',
'combined_chol_cor = cholesky_decompose(alpha * global_cor +\n',
' (1 - alpha) * local_cor);\n',
'return(combined_chol_cor);\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'/* Function to compute a partially pooled correlation matrix */\n',
'/* https://discourse.mc-stan.org/t/hierarchical-prior-for-partial-pooling-on-correlation-matrices*/\n',
'matrix combine_cholesky(matrix global_chol_cor, matrix local_chol_cor, real alpha){',
'int dim = rows(local_chol_cor);\n',
'matrix[dim, dim] global_cor = multiply_lower_tri_self_transpose(global_chol_cor);\n',
'matrix[dim, dim] local_cor = multiply_lower_tri_self_transpose(local_chol_cor);\n',
'matrix[dim, dim] combined_chol_cor;\n',
'combined_chol_cor = cholesky_decompose(alpha * global_cor +\n',
' (1 - alpha) * local_cor);\n',
'return(combined_chol_cor);\n',
'}\n}\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
# Add group information to data block
model_file[grep('int n_series;', model_file, fixed = TRUE)] <-
paste0(
"int n_groups; // number of groups (correlations apply within grouping levels)\n",
"int n_subgroups; // number of subgroups (units whose errors will be correlated)\n",
"int n_series; // total number of unique series (n_groups * n_subgroups)\n",
"array[n_groups, n_subgroups] int group_inds; // indices of group membership"
)
model_file <- readLines(textConnection(model_file), n = -1)
#### Changes for VAR models ####
if (grepl('VAR', trend_char)) {
if (
any(grepl(
"cholesky_factor_corr[n_lv] L_Omega;",
model_file,
fixed = TRUE
))
) {
use_lv <- TRUE
} else {
use_lv <- FALSE
}
#### Parameters ####
# Need arrays of cholesky factors and partial autocorrelation matrices
if (use_lv) {
# Changes for State-Space models
model_file[grep(
"cholesky_factor_corr[n_lv] L_Omega;",
model_file,
fixed = TRUE
)] <-
paste0(
'cholesky_factor_corr[n_subgroups] L_Omega_global;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_deviation_group;\n',
'real alpha_cor;'
)
model_file[grep(
"matrix[n_lv, n_lv] P_real;",
model_file,
fixed = TRUE
)] <-
paste0(
'array[n_groups] matrix[n_subgroups, n_subgroups] P_real_group;'
)
} else {
# Changes for non State-Space models
model_file[grep(
"cholesky_factor_corr[n_series] L_Omega;",
model_file,
fixed = TRUE
)] <-
paste0(
'cholesky_factor_corr[n_subgroups] L_Omega_global;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_deviation_group;\n',
'real alpha_cor;'
)
model_file[grep(
"matrix[n_series, n_series] P_real;",
model_file,
fixed = TRUE
)] <-
paste0(
'array[n_groups] matrix[n_subgroups, n_subgroups] P_real_group;'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
#### Transformed parameters ####
# Need arrays of autocorrelation matrices, Gamma and Sigma matrices
if (use_lv) {
# Changes for State-Space models
model_file[grep("matrix[n_lv, n_lv] A;", model_file, fixed = TRUE)] <-
paste0(
'array[n_groups] matrix[n_subgroups, n_subgroups] A_group;\n',
'matrix[n_lv, n_lv] A;'
)
model_file[grep("cov_matrix[n_lv] Sigma;", model_file, fixed = TRUE)] <-
paste0(
'array[n_groups] cov_matrix[n_subgroups] Sigma_group;\n',
"matrix[n_lv, n_lv] Sigma;"
)
model_file[grep("cov_matrix[n_lv] Gamma;", model_file, fixed = TRUE)] <-
paste0(
'array[n_groups] cov_matrix[n_subgroups] Gamma_group;\n',
"matrix[n_lv, n_lv] Gamma;"
)
model_file <- model_file[
-grep(
'Sigma = multiply_lower_tri_self_transpose(L_Sigma);',
model_file,
fixed = TRUE
)
]
model_file[grep(
"L_Sigma = diag_pre_multiply(sigma, L_Omega);",
model_file,
fixed = TRUE
)] <-
paste0(
'// derived group-level VAR covariance matrices\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_Omega_group;\n',
'array[n_groups] matrix[n_subgroups, n_subgroups] L_Sigma_group;\n',
'for (g in 1 : n_groups){\n',
'L_Omega_group[g] = combine_cholesky(L_Omega_global, L_deviation_group[g], alpha_cor);\n',
'L_Sigma_group[g] = diag_pre_multiply(sigma[group_inds[g]], L_Omega_group[g]);\n',
'Sigma_group[g] = multiply_lower_tri_self_transpose(L_Sigma_group[g]);\n',
'}\n'
)
starts <- grep(
"// stationary VAR reparameterisation",
model_file,
fixed = TRUE
) +
1
ends <- grep(
"// stationary VAR reparameterisation",
model_file,
fixed = TRUE
) +
8
model_file <- model_file[-(starts:ends)]
model_file[grep(
"// stationary VAR reparameterisation",
model_file,
fixed = TRUE
)] <-
paste0(
'// stationary VAR reparameterisation\n',
'{\n',
"array[1] matrix[n_subgroups, n_subgroups] P;\n",
"array[2, 1] matrix[n_subgroups, n_subgroups] phiGamma;\n",
'for (g in 1 : n_groups){\n',
"P[1] = P_realtoP(P_real_group[g]);\n",
"phiGamma = rev_mapping(P, Sigma_group[g]);\n",
"A_group[g] = phiGamma[1, 1];\n",
"Gamma_group[g] = phiGamma[2, 1];\n",
"}\n\n",
"// computed (full) VAR matrices\n",
'Sigma = rep_matrix(0, n_lv, n_lv);\n',
'Gamma = rep_matrix(0, n_lv, n_lv);\n',
'A = rep_matrix(0, n_lv, n_lv);\n',
'for (g in 1 : n_groups){\n',
'Sigma[group_inds[g], group_inds[g]] = multiply_lower_tri_self_transpose(L_Sigma_group[g]);\n',
'Gamma[group_inds[g], group_inds[g]] = Gamma_group[g];\n',
'A[group_inds[g], group_inds[g]] = A_group[g];\n',
'}\n',
'L_Sigma = cholesky_decompose(Sigma);\n',
"}\n\n"
)
} else {
# Changes for non State-Space models
model_file[grep(
"matrix[n_series, n_series] A;",
model_file,
fixed = TRUE
)] <-
paste0(
'array[n_groups] matrix[n_subgroups, n_subgroups] A_group;\n',
'matrix[n_series, n_series] A;'
)
model_file[grep(
"cov_matrix[n_series] Sigma;",
model_file,
fixed = TRUE
)] <-
paste0(
'array[n_groups] cov_matrix[n_subgroups] Sigma_group;\n',
"matrix[n_series, n_series] Sigma;"
)
model_file[grep(
"cov_matrix[n_series] Gamma;",
model_file,
fixed = TRUE
)] <-
paste0(
'array[n_groups] cov_matrix[n_subgroups] Gamma_group;\n',
'matrix[n_series, n_series] Gamma;'
)
model_file <- model_file[
-grep(
'Sigma = multiply_lower_tri_self_transpose(L_Sigma);',
model_file,
fixed = TRUE
)
]
model_file[grep(
"L_Sigma = diag_pre_multiply(sigma, L_Omega);",
model_file,
fixed = TRUE
)] <-
paste0(
'// derived group-level VAR covariance matrices\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_Omega_group;\n',
'array[n_groups] matrix[n_subgroups, n_subgroups] L_Sigma_group;\n',
'for (g in 1 : n_groups){\n',
'L_Omega_group[g] = combine_cholesky(L_Omega_global, L_deviation_group[g], alpha_cor);\n',
'L_Sigma_group[g] = diag_pre_multiply(sigma[group_inds[g]], L_Omega_group[g]);\n',
'Sigma_group[g] = multiply_lower_tri_self_transpose(L_Sigma_group[g]);\n',
'}\n'
)
starts <- grep(
"// stationary VAR reparameterisation",
model_file,
fixed = TRUE
) +
1
ends <- grep(
"// stationary VAR reparameterisation",
model_file,
fixed = TRUE
) +
8
model_file <- model_file[-(starts:ends)]
model_file[grep(
"// stationary VAR reparameterisation",
model_file,
fixed = TRUE
)] <-
paste0(
'// stationary VAR reparameterisation\n',
'{\n',
"array[1] matrix[n_subgroups, n_subgroups] P;\n",
"array[2, 1] matrix[n_subgroups, n_subgroups] phiGamma;\n",
'for (g in 1 : n_groups){\n',
"P[1] = P_realtoP(P_real_group[g]);\n",
"phiGamma = rev_mapping(P, Sigma_group[g]);\n",
"A_group[g] = phiGamma[1, 1];\n",
"Gamma_group[g] = phiGamma[2, 1];\n",
"}\n\n",
"// computed (full) VAR matrices\n",
'Sigma = rep_matrix(0, n_series, n_series);\n',
'Gamma = rep_matrix(0, n_series, n_series);\n',
'A = rep_matrix(0, n_series, n_series);\n',
'for (g in 1 : n_groups){\n',
'Sigma[group_inds[g], group_inds[g]] = multiply_lower_tri_self_transpose(L_Sigma_group[g]);\n',
'A[group_inds[g], group_inds[g]] = A_group[g];\n',
'Gamma[group_inds[g], group_inds[g]] = Gamma_group[g];\n',
'}\n',
'L_Sigma = cholesky_decompose(Sigma);\n',
"}\n\n"
)
}
model_file <- readLines(textConnection(model_file), n = -1)
#### Model ####
model_file[grep(
"L_Omega ~ lkj_corr_cholesky(2);",
model_file,
fixed = TRUE
)] <-
paste0(
'alpha_cor ~ beta(3, 2);\n',
'L_Omega_global ~ lkj_corr_cholesky(1);\n',
'for (g in 1 : n_groups){\n',
'L_deviation_group[g] ~ lkj_corr_cholesky(6);\n',
'}'
)
starts <- grep(
"// unconstrained partial autocorrelations",
model_file,
fixed = TRUE
) +
1
ends <- grep(
"// unconstrained partial autocorrelations",
model_file,
fixed = TRUE
) +
6
model_file <- model_file[-(starts:ends)]
model_file[grep(
"// unconstrained partial autocorrelations",
model_file,
fixed = TRUE
)] <-
paste0(
'for (g in 1 : n_groups){\n',
'diagonal(P_real_group[g]) ~ normal(Pmu[1], 1 / sqrt(Pomega[1]));\n',
'for (i in 1:n_subgroups) {\n',
'for (j in 1:n_subgroups) {\n',
'if(i != j) P_real_group[g, i, j] ~ normal(Pmu[2], 1 / sqrt(Pomega[2]));\n',
'}\n}\n}'
)
model_file <- readLines(textConnection(model_file), n = -1)
} else {
if (grepl('ZMVN', trend_char)) {
#### Zero-mean multinormals ####
if (
any(grepl(
"matrix[n_series, n_lv] lv_coefs;",
model_file,
fixed = TRUE
))
) {
use_lv <- TRUE
} else {
use_lv <- FALSE
}
#### Transformed data ####
if (use_lv) {
if (any(grepl('transformed data {', model_file, fixed = TRUE))) {
model_file[grep('transformed data {', model_file, fixed = TRUE)] <-
paste0(
'transformed data {\n',
'vector[n_subgroups] trend_zeros = rep_vector(0.0, n_subgroups);'
)
} else {
model_file[grep('parameters {', model_file, fixed = TRUE)[1]] <-
paste0(
'transformed data {\n',
'vector[n_subgroups] trend_zeros = rep_vector(0.0, n_subgroups);\n',
'}\nparameters {'
)
}
} else {
model_file[grep(
"vector[n_series] trend_zeros = rep_vector(0.0, n_series);",
model_file,
fixed = TRUE
)] <-
paste0(
'vector[n_subgroups] trend_zeros = rep_vector(0.0, n_subgroups);'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
#### Parameters ####
if (use_lv) {
model_file <- model_file[
-grep(
'cholesky_factor_corr[n_lv] L_Omega;',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep("// correlated latent residuals", model_file, fixed = TRUE)
]
model_file <- model_file[
-grep("array[n] vector[n_lv] LV_raw;", model_file, fixed = TRUE)
]
model_file[grep("[n_lv] sigma;", model_file, fixed = TRUE)] <-
paste0(
model_file[grep("[n_lv] sigma;", model_file, fixed = TRUE)],
'\n',
'\n\n',
'// correlation params and correlated errors per group\n',
'cholesky_factor_corr[n_subgroups] L_Omega_global;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_deviation_group;\n',
'real alpha_cor;\n',
'array[n] matrix[n_groups, n_subgroups] sub_error;'
)
} else {
model_file <- model_file[
-grep(
'cholesky_factor_corr[n_series] L_Omega;',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep("// correlated latent residuals", model_file, fixed = TRUE)
]
model_file <- model_file[
-grep(
"array[n] vector[n_series] trend_raw;",
model_file,
fixed = TRUE
)
]
model_file[grep(
"vector[n_series] sigma;",
model_file,
fixed = TRUE
)] <-
paste0(
'vector[n_series] sigma;\n',
'\n\n',
'// correlation params and correlated errors per group\n',
'cholesky_factor_corr[n_subgroups] L_Omega_global;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_deviation_group;\n',
'real alpha_cor;\n',
'array[n] matrix[n_groups, n_subgroups] sub_error;'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
#### Transformed parameters ####
if (use_lv) {
model_file <- model_file[
-grep('matrix[n_lv, n_lv] L_Sigma;', model_file, fixed = TRUE)
]
model_file <- model_file[
-grep(
'L_Sigma = diag_pre_multiply(sigma, L_Omega);',
model_file,
fixed = TRUE
)
]
model_file[grep(
"// LKJ form of covariance matrix",
model_file,
fixed = TRUE
)] <-
paste0(
'// reconstructed correlated errors\n',
'array[n] vector[n_lv] error;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_Omega_group;\n',
'\n',
'// LKJ forms of covariance matrices\n',
'array[n_groups] matrix[n_subgroups, n_subgroups] L_Sigma_group;'
)
model_file[grep(
"// correlated residuals",
model_file,
fixed = TRUE
)] <-
paste0(
'// derived error correlation and covariance matrices\n',
'for (g in 1 : n_groups){\n',
'L_Omega_group[g] = combine_cholesky(L_Omega_global, L_deviation_group[g], alpha_cor);\n',
'L_Sigma_group[g] = diag_pre_multiply(sigma[group_inds[g]], L_Omega_group[g]);\n',
'}\n',
'// derived correlated errors\n',
'for (i in 1 : n){\n',
"error[i] = to_vector(sub_error[i]');\n",
'}\n'
)
model_file[grep(
"LV[i, 1:n_lv] = to_row_vector(LV_raw[i]);",
model_file,
fixed = TRUE
)] <-
"LV[i, 1:n_lv] = to_row_vector(error[i]);"
} else {
model_file <- model_file[
-grep(
'matrix[n_series, n_series] L_Sigma;',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep(
'L_Sigma = diag_pre_multiply(sigma, L_Omega);',
model_file,
fixed = TRUE
)
]
model_file[grep(
"// LKJ form of covariance matrix",
model_file,
fixed = TRUE
)] <-
paste0(
'// reconstructed correlated errors\n',
'array[n] vector[n_series] error;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_Omega_group;\n',
'\n',
'// LKJ forms of covariance matrices\n',
'array[n_groups] matrix[n_subgroups, n_subgroups] L_Sigma_group;'
)
model_file[grep(
"// correlated residuals",
model_file,
fixed = TRUE
)] <-
paste0(
'// derived error correlation and covariance matrices\n',
'for (g in 1 : n_groups){\n',
'L_Omega_group[g] = combine_cholesky(L_Omega_global, L_deviation_group[g], alpha_cor);\n',
'L_Sigma_group[g] = diag_pre_multiply(sigma[group_inds[g]], L_Omega_group[g]);\n',
'}\n',
'// derived correlated errors\n',
'for (i in 1 : n){\n',
"error[i] = to_vector(sub_error[i]');\n",
'}\n'
)
model_file[grep(
"trend[i, 1:n_series] = to_row_vector(trend_raw[i]);",
model_file,
fixed = TRUE
)] <-
"trend[i, 1:n_series] = to_row_vector(error[i]);"
}
model_file <- readLines(textConnection(model_file), n = -1)
#### Model ####
starts <- grep(
"// residual error correlations",
model_file,
fixed = TRUE
) +
1
ends <- grep(
"// residual error correlations",
model_file,
fixed = TRUE
) +
4
model_file <- model_file[-(starts:ends)]
model_file[grep(
"// residual error correlations",
model_file,
fixed = TRUE
)] <-
paste0(
'// hierarchical latent error correlations\n',
'alpha_cor ~ beta(3, 2);\n',
'L_Omega_global ~ lkj_corr_cholesky(1);\n',
'for (g in 1 : n_groups){\n',
'L_deviation_group[g] ~ lkj_corr_cholesky(6);\n',
'}\n',
'\n',
'// contemporaneous errors\n',
'for (i in 1 : n) {\n',
'for (g in 1 : n_groups){\n',
'to_vector(sub_error[i, g]) ~ multi_normal_cholesky(trend_zeros, L_Sigma_group[g]);\n',
'}\n',
'}'
)
model_file <- readLines(textConnection(model_file), n = -1)
#### Generated quantities ####
if (use_lv) {
model_file <- model_file[
-grep(
"cov_matrix[n_lv] Sigma = multiply_lower_tri_self_transpose(L_Sigma);",
model_file,
fixed = TRUE
)
]
model_file[grep(
"// computed error covariance matrix",
model_file,
fixed = TRUE
)] <-
paste0(
'// computed (full) error covariance matrix\n',
'matrix[n_lv, n_lv] Sigma;\n',
'Sigma = rep_matrix(0, n_lv, n_lv);\n',
'for (g in 1 : n_groups){\n',
'Sigma[group_inds[g], group_inds[g]] = multiply_lower_tri_self_transpose(L_Sigma_group[g]);\n',
'}'
)
} else {
model_file <- model_file[
-grep(
"cov_matrix[n_series] Sigma = multiply_lower_tri_self_transpose(L_Sigma);",
model_file,
fixed = TRUE
)
]
model_file[grep(
"// computed error covariance matrix",
model_file,
fixed = TRUE
)] <-
paste0(
'// computed (full) error covariance matrix\n',
'matrix[n_series, n_series] Sigma;\n',
'Sigma = rep_matrix(0, n_series, n_series);\n',
'for (g in 1 : n_groups){\n',
'Sigma[group_inds[g], group_inds[g]] = multiply_lower_tri_self_transpose(L_Sigma_group[g]);\n',
'}'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
} else {
#### Random walk and AR models ####
if (any(grepl("vector[n_lv] trend_zeros", model_file, fixed = TRUE))) {
use_lv <- TRUE
} else {
use_lv <- FALSE
}
#### Transformed data ####
if (use_lv) {
model_file[grep(
"vector[n_lv] trend_zeros = rep_vector(0.0, n_lv);",
model_file,
fixed = TRUE
)] <-
paste0(
'vector[n_subgroups] trend_zeros = rep_vector(0.0, n_subgroups);'
)
} else {
model_file[grep(
"vector[n_series] trend_zeros = rep_vector(0.0, n_series);",
model_file,
fixed = TRUE
)] <-
paste0(
'vector[n_subgroups] trend_zeros = rep_vector(0.0, n_subgroups);'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
#### Parameters ####
if (use_lv) {
model_file <- model_file[
-grep(
'cholesky_factor_corr[n_lv] L_Omega;',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep('// dynamic error parameters', model_file, fixed = TRUE)
]
model_file <- model_file[
-grep("vector[n_lv] error[n];", model_file, fixed = TRUE)
]
model_file[grep("[n_lv] sigma;", model_file, fixed = TRUE)] <-
paste0(
model_file[grep("[n_lv] sigma;", model_file, fixed = TRUE)],
'\n',
'\n\n',
'// correlation params and dynamic error parameters per group\n',
'cholesky_factor_corr[n_subgroups] L_Omega_global;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_deviation_group;\n',
'real alpha_cor;\n',
'array[n] matrix[n_groups, n_subgroups] sub_error;'
)
} else {
model_file <- model_file[
-grep(
'cholesky_factor_corr[n_series] L_Omega;',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep('// dynamic error parameters', model_file, fixed = TRUE)
]
model_file <- model_file[
-grep("vector[n_series] error[n];", model_file, fixed = TRUE)
]
model_file[grep(
"vector[n_series] sigma;",
model_file,
fixed = TRUE
)] <-
paste0(
'vector[n_series] sigma;\n',
'\n\n',
'// correlation params and dynamic error parameters per group\n',
'cholesky_factor_corr[n_subgroups] L_Omega_global;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_deviation_group;\n',
'real alpha_cor;\n',
'array[n] matrix[n_groups, n_subgroups] sub_error;'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
#### Transformed parameters ####
if (use_lv) {
model_file <- model_file[
-grep(
'// computed error covariance matrix',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep('cov_matrix[n_lv] Sigma;', model_file, fixed = TRUE)
]
model_file <- model_file[
-grep('matrix[n_lv, n_lv] L_Sigma;', model_file, fixed = TRUE)
]
model_file <- model_file[
-grep(
'L_Sigma = diag_pre_multiply(sigma, L_Omega);',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep(
'Sigma = multiply_lower_tri_self_transpose(L_Sigma);',
model_file,
fixed = TRUE
)
]
model_file[grep(
"// LKJ form of covariance matrix",
model_file,
fixed = TRUE
)] <-
paste0(
'// reconstructed correlated errors\n',
'array[n] vector[n_lv] error;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_Omega_group;\n',
'\n',
'// LKJ forms of covariance matrices\n',
'array[n_groups] matrix[n_subgroups, n_subgroups] L_Sigma_group;'
)
model_file[grep(
"// derived latent states",
model_file,
fixed = TRUE
)] <-
paste0(
'// derived error correlation and covariance matrices\n',
'for (g in 1 : n_groups){\n',
'L_Omega_group[g] = combine_cholesky(L_Omega_global, L_deviation_group[g], alpha_cor);\n',
'L_Sigma_group[g] = diag_pre_multiply(sigma[group_inds[g]], L_Omega_group[g]);\n',
'}\n',
'// derived correlated errors\n',
'for (i in 1 : n){\n',
"error[i] = to_vector(sub_error[i]');\n",
'}\n',
'// derived latent states'
)
} else {
model_file <- model_file[
-grep(
'// computed error covariance matrix',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep('cov_matrix[n_series] Sigma;', model_file, fixed = TRUE)
]
model_file <- model_file[
-grep(
'matrix[n_series, n_series] L_Sigma;',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep(
'L_Sigma = diag_pre_multiply(sigma, L_Omega);',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep(
'Sigma = multiply_lower_tri_self_transpose(L_Sigma);',
model_file,
fixed = TRUE
)
]
model_file[grep(
"// LKJ form of covariance matrix",
model_file,
fixed = TRUE
)] <-
paste0(
'// reconstructed correlated errors\n',
'array[n] vector[n_series] error;\n',
'array[n_groups] cholesky_factor_corr[n_subgroups] L_Omega_group;\n',
'\n',
'// LKJ forms of covariance matrices\n',
'array[n_groups] matrix[n_subgroups, n_subgroups] L_Sigma_group;'
)
model_file[grep(
"// derived latent states",
model_file,
fixed = TRUE
)] <-
paste0(
'// derived error correlation and covariance matrices\n',
'for (g in 1 : n_groups){\n',
'L_Omega_group[g] = combine_cholesky(L_Omega_global, L_deviation_group[g], alpha_cor);\n',
'L_Sigma_group[g] = diag_pre_multiply(sigma[group_inds[g]], L_Omega_group[g]);\n',
'}\n',
'// derived correlated errors\n',
'for (i in 1 : n){\n',
"error[i] = to_vector(sub_error[i]');\n",
'}\n',
'// derived latent states'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
#### Model ####
starts <- grep("// contemporaneous errors", model_file, fixed = TRUE) +
1
ends <- grep("// contemporaneous errors", model_file, fixed = TRUE) + 4
model_file <- model_file[-(starts:ends)]
model_file[grep(
"// contemporaneous errors",
model_file,
fixed = TRUE
)] <-
paste0(
'// hierarchical process error correlations\n',
'alpha_cor ~ beta(3, 2);\n',
'L_Omega_global ~ lkj_corr_cholesky(1);\n',
'for (g in 1 : n_groups){\n',
'L_deviation_group[g] ~ lkj_corr_cholesky(6);\n',
'}\n',
'\n',
'// contemporaneous errors\n',
'for (i in 1 : n) {\n',
'for (g in 1 : n_groups){\n',
'to_vector(sub_error[i, g]) ~ multi_normal_cholesky(trend_zeros, L_Sigma_group[g]);\n',
'}\n',
'}'
)
model_file <- readLines(textConnection(model_file), n = -1)
#### Generated quantities ####
if (use_lv) {
model_file[grep(
"// posterior predictions",
model_file,
fixed = TRUE
)] <-
paste0(
'// computed (full) error covariance matrix\n',
'matrix[n_lv, n_lv] Sigma;\n',
'Sigma = rep_matrix(0, n_lv, n_lv);\n',
'for (g in 1 : n_groups){\n',
'Sigma[group_inds[g], group_inds[g]] = multiply_lower_tri_self_transpose(L_Sigma_group[g]);\n',
'}\n',
'\n',
'// posterior predictions'
)
} else {
model_file[grep(
"// posterior predictions",
model_file,
fixed = TRUE
)] <-
paste0(
'// computed (full) error covariance matrix\n',
'matrix[n_series, n_series] Sigma;\n',
'Sigma = rep_matrix(0, n_series, n_series);\n',
'for (g in 1 : n_groups){\n',
'Sigma[group_inds[g], group_inds[g]] = multiply_lower_tri_self_transpose(L_Sigma_group[g]);\n',
'}\n',
'\n',
'// posterior predictions'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
}
#### Add grouping information to model_data ####
model_data$group_inds <- matrix(
1:nlevels(data_train$series),
nrow = nlevels(data_train[[trend_model$gr]]),
ncol = nlevels(data_train[[trend_model$subgr]]),
byrow = TRUE
)
model_data$n_groups <- nlevels(data_train[[trend_model$gr]])
model_data$n_subgroups <- nlevels(data_train[[trend_model$subgr]])
}
return(list(model_file = model_file, model_data = model_data))
}
================================================
FILE: R/add_base_dgam_lines.R
================================================
#' Dynamic GAM model file additions
#'
#' @noRd
#'
#' @param use_lv Logical (use latent variables or not?)
#'
#' @param stan Logical (convert existing model to a Stan model?)
#'
#' @param offset Logical (include an offset in the linear predictor?)
#'
#' @return A character string to add to the mgcv jagam model file
add_base_dgam_lines <- function(use_lv, stan = FALSE, offset = FALSE) {
if (stan) {
if (use_lv) {
add <- "
##insert data
transformed data {
// Number of non-zero lower triangular factor loadings
// Ensures identifiability of the model - no rotation of factors
int M;
M = n_lv * (n_series - n_lv) + n_lv * (n_lv - 1) / 2 + n_lv;
}
parameters {
// raw basis coefficients
row_vector[num_basis] b_raw;
// dynamic factors
matrix[n, n_lv] LV_raw;
// dynamic factor lower triangle loading coefficients
vector[M] L;
// smoothing parameters
vector[n_sp] lambda;
}
transformed parameters {
// GAM contribution to expectations (log scale)
vector[total_obs] eta;
// trends and dynamic factor loading matrix
matrix[n, n_series] trend;
matrix[n_series, n_lv] lv_coefs_raw;
// basis coefficients
row_vector[num_basis] b;
// constraints allow identifiability of loadings
for (i in 1:(n_lv - 1)) {
for (j in (i + 1):(n_lv)){
lv_coefs_raw[i, j] = 0;
}
}
{
int index;
index = 0;
for (j in 1:n_lv) {
for (i in j:n_series) {
index = index + 1;
lv_coefs_raw[i, j] = L[index];
}
}
}
// derived latent trends
for (i in 1:n){
for (s in 1:n_series){
trend[i, s] = dot_product(lv_coefs_raw[s,], LV_raw[i,]);
}
}
eta = to_vector(b * X);
}
model {
##insert smooths
// priors for smoothing parameters
lambda ~ normal(5, 30);
// priors for dynamic factor loading coefficients
L ~ student_t(5, 0, 1);
// dynamic factor estimates
for (j in 1:n_lv) {
LV_raw[1, j] ~ normal(0, 0.1);
}
for (j in 1:n_lv) {
LV_raw[2:n, j] ~ normal(LV_raw[1:(n - 1), j], 0.1);
}
// likelihood functions
for (i in 1:n) {
for (s in 1:n_series) {
if (y_observed[i, s])
y[i, s] ~ poisson_log(eta[ytimes[i, s]] + trend[i, s]);
}
}
}
generated quantities {
matrix[n, n_lv] LV;
matrix[n_series, n_lv] lv_coefs;
vector[n_sp] rho;
vector[n_lv] penalty;
matrix[n, n_series] ypred;
rho = log(lambda);
penalty = rep_vector(100.0, n_lv);
// Sign correct factor loadings and factors
for(j in 1:n_lv){
if(lv_coefs_raw[j, j] < 0){
lv_coefs[,j] = -1 * lv_coefs_raw[,j];
LV[,j] = -1 * LV_raw[,j];
} else {
lv_coefs[,j] = lv_coefs_raw[,j];
LV[,j] = LV_raw[,j];
}
}
// posterior predictions
for(i in 1:n){
for(s in 1:n_series){
ypred[i, s] = poisson_log_rng(eta[ytimes[i, s]] + trend[i, s]);
}
}
}
"
} else {
add <- "
##insert data
parameters {
// raw basis coefficients
row_vector[num_basis] b_raw;
// latent trend variance parameters
vector[n_series] sigma;
// latent trends
matrix[n, n_series] trend;
// smoothing parameters
vector[n_sp] lambda;
}
transformed parameters {
// GAM contribution to expectations (log scale)
vector[total_obs] eta;
// basis coefficients
row_vector[num_basis] b;
eta = to_vector(b * X);
}
model {
##insert smooths
// priors for smoothing parameters
lambda ~ normal(5, 30);
// priors for latent trend variance parameters
sigma ~ exponential(2);
// trend estimates
for (s in 1:n_series) {
trend[1, s] ~ normal(0, sigma[s]);
}
for (s in 1:n_series) {
trend[2:n, s] ~ normal(trend[1:(n - 1), s], sigma[s]);
}
// likelihood functions
for (i in 1:n) {
for (s in 1:n_series) {
if (y_observed[i, s])
y[i, s] ~ poisson_log(eta[ytimes[i, s]] + trend[i, s]);
}
}
}
generated quantities {
vector[n_sp] rho;
vector[n_series] tau;
matrix[n, n_series] ypred;
rho = log(lambda);
for (s in 1:n_series) {
tau[s] = pow(sigma[s], -2.0);
}
// posterior predictions
for(i in 1:n){
for(s in 1:n_series){
ypred[i, s] = poisson_log_rng(eta[ytimes[i, s]] + trend[i, s]);
}
}
}
"
}
} else {
if (use_lv) {
add <- c(
"
#### Begin model ####
model {
## GAM linear predictor
eta <- X %*% b
## mean expectations
for (i in 1:n) {
for (s in 1:n_series) {
mus[i, s] <- exp(eta[ytimes[i, s]] + trend[i, s])
}
}
## latent factors evolve as time series with penalised precisions;
## the penalty terms force any un-needed factors to evolve as flat lines
for (j in 1:n_lv) {
LV_raw[1, j] ~ dnorm(0, penalty[j])
}
for (j in 1:n_lv) {
LV_raw[2, j] ~ dnorm(drift[j] + ar1[j]*LV_raw[1, j], penalty[j])
}
for (j in 1:n_lv) {
LV_raw[3, j] ~ dnorm(drift[j]*2 + ar1[j]*LV_raw[2, j] + ar2[j]*LV_raw[1, j], penalty[j])
}
for (i in 4:n) {
for (j in 1:n_lv) {
LV_raw[i, j] ~ dnorm(drift[j]*(i - 1) + ar1[j]*LV_raw[i - 1, j] +
ar2[j]*LV_raw[i - 2, j] + ar3[j]*LV_raw[i - 3, j], penalty[j])
}
}
## AR components
for (s in 1:n_lv) {
drift[s] ~ dnorm(0, 10)
ar1[s] ~ dnorm(0, 10)
ar2[s] ~ dnorm(0, 10)
ar3[s] ~ dnorm(0, 10)
}
## shrinkage penalties for each factor's precision parameter act to squeeze
## the entire factor toward a flat white noise process if supported by
## the data. The prior for individual factor penalties allows each factor to possibly
## have a relatively large penalty, which shrinks the prior for that factor's variance
## substantially. Penalties increase exponentially with the number of factors following
## Welty, Leah J., et al. Bayesian distributed lag models: estimating effects of particulate
## matter air pollution on daily mortality Biometrics 65.1 (2009): 282-291.
pi ~ dunif(0, n_lv)
X2 ~ dnorm(0, 1)T(0, )
# eta1 controls the baseline penalty
eta1 ~ dunif(-1, 1)
# eta2 controls how quickly the penalties exponentially increase
eta2 ~ dunif(-1, 1)
for (t in 1:n_lv) {
X1[t] ~ dnorm(0, 1)T(0, )
l.dist[t] <- max(t, pi[])
l.weight[t] <- exp(eta2[] * l.dist[t])
l.var[t] <- exp(eta1[] * l.dist[t] / 2) * 1
theta.prime[t] <- l.weight[t] * X1[t] + (1 - l.weight[t]) * X2[]
penalty[t] <- max(0.0001, theta.prime[t] * l.var[t])
}
## latent factor loadings: standard normal with identifiability constraints
## upper triangle of loading matrix set to zero
for (j in 1:(n_lv - 1)) {
for (j2 in (j + 1):n_lv) {
lv_coefs_raw[j, j2] <- 0
}
}
## positive constraints on loading diagonals
for (j in 1:n_lv) {
lv_coefs_raw[j, j] ~ dnorm(0, 1)T(0, 1);
}
## lower diagonal free
for (j in 2:n_lv) {
for (j2 in 1:(j - 1)) {
lv_coefs_raw[j, j2] ~ dnorm(0, 1)T(-1, 1);
}
}
## other elements also free
for (j in (n_lv + 1):n_series) {
for (j2 in 1:n_lv) {
lv_coefs_raw[j, j2] ~ dnorm(0, 1)T(-1, 1);
}
}
## trend evolution depends on latent factors
for (i in 1:n) {
for (s in 1:n_series) {
trend[i, s] <- inprod(lv_coefs_raw[s,], LV_raw[i,])
}
}
# sign-correct factor loadings and coefficients
for (j in 1:n_lv){
if(lv_coefs[j,j] < 0){
lv_coefs[,j] <- -1 * lv_coefs_raw[,j]
LV[,j] <- -1 * LV_raw[,j]
} else {
lv_coefs[,j] <- lv_coefs_raw[,j]
LV[,j] <- LV_raw[,j]
}
}
## likelihood functions
for (i in 1:n) {
for (s in 1:n_series) {
y[i, s] ~ dnegbin(rate[i, s], phi[s])T(, upper_bound[s]);
rate[i, s] <- ifelse((phi[s] / (phi[s] + mus[i, s])) < min_eps, min_eps,
(phi[s] / (phi[s] + mus[i, s])))
}
}
## complexity penalising prior for the overdispersion parameter;
## where the likelihood reduces to a 'base' model (Poisson) unless
## the data support overdispersion
for (s in 1:n_series) {
phi[s] <- 1 / phi_inv[s]
phi_inv[s] ~ dexp(5)
}
## posterior predictions
for (i in 1:n) {
for (s in 1:n_series) {
ypred[i, s] ~ dnegbin(rate[i, s], phi[s])T(, upper_bound[s])
}
}
## GAM-specific priors"
)
} else {
add <- c(
"
#### Begin model ####
model {
## GAM linear predictor
eta <- X %*% b
## mean expectations
for (i in 1:n) {
for (s in 1:n_series) {
mus[i, s] <- exp(eta[ytimes[i, s]] + trend[i, s])
}
}
## trend estimates
for (s in 1:n_series) {
trend[1, s] ~ dnorm(0, tau[s])
}
for (s in 1:n_series) {
trend[2, s] ~ dnorm(drift[s] + ar1[s]*trend[1, s], tau[s])
}
for (s in 1:n_series) {
trend[3, s] ~ dnorm(drift[s]*2 + ar1[s]*trend[2, s] + ar2[s]*trend[1, s], tau[s])
}
for (i in 4:n) {
for (s in 1:n_series){
trend[i, s] ~ dnorm(drift[s]*(i - 1) + ar1[s]*trend[i - 1, s] + ar2[s]*trend[i - 2, s] + ar3[s]*trend[i - 3, s], tau[s])
}
}
## AR components
for (s in 1:n_series){
drift[s] ~ dnorm(0, 10)
ar1[s] ~ dnorm(0, 10)
ar2[s] ~ dnorm(0, 10)
ar3[s] ~ dnorm(0, 10)
tau[s] <- pow(sigma[s], -2)
sigma[s] ~ dexp(2)T(0.075, 5)
}
## likelihood functions
for (i in 1:n) {
for (s in 1:n_series) {
y[i, s] ~ dnegbin(rate[i, s], phi[s])T(, upper_bound[s]);
rate[i, s] <- ifelse((phi[s] / (phi[s] + mus[i, s])) < min_eps, min_eps,
(phi[s] / (phi[s] + mus[i, s])))
}
}
## complexity penalising prior for the overdispersion parameter;
## where the likelihood reduces to a 'base' model (Poisson) unless
## the data support overdispersion
for (s in 1:n_series) {
phi[s] <- 1 / phi_inv[s]
phi_inv[s] ~ dexp(5)
}
## posterior predictions
for (i in 1:n) {
for (s in 1:n_series) {
ypred[i, s] ~ dnegbin(rate[i, s], phi[s])T(, upper_bound[s])
}
}
## GAM-specific priors"
)
}
}
return(add)
}
================================================
FILE: R/add_binomial.R
================================================
#' @noRd
add_binomial = function(
formula,
model_file,
model_data,
data_train,
data_test,
family_char
) {
# Add trial information if necessary
if (family_char %in% c('binomial', 'beta_binomial')) {
# Identify which variable in data represents the number of trials
resp_terms <- as.character(terms(formula(formula))[[2]])
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
trial_name <- resp_terms[2]
# Pull the trials variable from the data and validate
train_trials <- data_train[[trial_name]]
if (any(is.na(train_trials))) {
stop(
paste0('variable ', trial_name, ' contains missing values'),
call. = FALSE
)
}
if (any(is.infinite(train_trials))) {
stop(
paste0('variable ', trial_name, ' contains infinite values'),
call. = FALSE
)
}
# Matrix of trials per series
all_trials <- data.frame(
series = as.numeric(data_train$series),
time = data_train$time,
trials = data_train[[trial_name]]
) %>%
dplyr::arrange(time, series)
# Same for data_test
if (!is.null(data_test)) {
if (!(exists(trial_name, where = data_test))) {
stop(
'Number of trials must also be supplied in "newdata" for Binomial models',
call. = FALSE
)
}
all_trials <- rbind(
all_trials,
data.frame(
series = as.numeric(data_test$series),
time = data_test$time,
trials = data_test[[trial_name]]
)
) %>%
dplyr::arrange(time, series)
if (any(is.na(all_trials$trial)) | any(is.infinite(all_trials$trial))) {
stop(
paste0(
'Missing or infinite values found in ',
trial_name,
' variable'
),
call. = FALSE
)
}
}
# Construct matrix of N-trials in the correct format so it can be
# flattened into one long vector
trials <- matrix(
NA,
nrow = length(unique(all_trials$time)),
ncol = length(unique(all_trials$series))
)
for (i in 1:length(unique(all_trials$series))) {
trials[, i] <- all_trials$trials[which(all_trials$series == i)]
}
# Add trial info to the model data
model_data$flat_trials <- as.vector(trials)
model_data$flat_trials_train <- as.vector(trials)[which(
as.vector(model_data$y_observed) == 1
)]
# Add trial vectors to model block
model_file[grep(
"int flat_ys[n_nonmissing]; // flattened nonmissing observations",
model_file,
fixed = TRUE
)] <-
paste0(
"array[n_nonmissing] int flat_ys; // flattened nonmissing observations\n",
"array[total_obs] int flat_trials; // flattened trial vector\n",
"array[n_nonmissing] int flat_trials_train; // flattened nonmissing trial vector\n"
)
model_file <- readLines(textConnection(model_file), n = -1)
} else {
trials <- NULL
}
# Update parameters block
if (family_char == 'beta_binomial') {
model_file[grep("vector[num_basis] b_raw;", model_file, fixed = TRUE)] <-
paste0("vector[num_basis] b_raw;\n", "vector[n_series] phi;")
model_file <- readLines(textConnection(model_file), n = -1)
}
# Update functions block
if (family_char == 'beta_binomial') {
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
"functions {\n",
"vector rep_each(vector x, int K) {\n",
"int N = rows(x);\n",
"vector[N * K] y;\n",
"int pos = 1;\n",
"for (n in 1 : N) {\n",
"for (k in 1 : K) {\n",
"y[pos] = x[n];\n",
"pos += 1;\n",
"}\n",
"}\n",
"return y;\n",
"}"
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
"vector rep_each(vector x, int K) {\n",
"int N = rows(x);\n",
"vector[N * K] y;\n",
"int pos = 1;\n",
"for (n in 1 : N) {\n",
"for (k in 1 : K) {\n",
"y[pos] = x[n];\n",
"pos += 1;\n",
"}\n",
"}\n",
"return y;\n",
"}\n}"
)
}
}
# Update model block
if (family_char == 'binomial') {
if (
any(grepl("flat_ys ~ poisson_log_glm(flat_xs,", model_file, fixed = TRUE))
) {
linenum <- grep(
"flat_ys ~ poisson_log_glm(flat_xs,",
model_file,
fixed = TRUE
)
model_file[linenum] <-
paste0("flat_ys ~ binomial(flat_trials_train, inv_logit(flat_xs * b));")
model_file <- model_file[-(linenum + 1)]
model_file <- readLines(textConnection(model_file), n = -1)
}
if (
any(grepl(
"flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends),",
model_file,
fixed = TRUE
))
) {
linenum <- grep(
"flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends),",
model_file,
fixed = TRUE
)
model_file[linenum] <-
paste0(
"flat_ys ~ binomial(flat_trials_train, inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0)));"
)
model_file <- model_file[-(linenum + 1)]
model_file <- readLines(textConnection(model_file), n = -1)
}
}
if (family_char == 'beta_binomial') {
model_file[grep("model {", model_file, fixed = TRUE)] <-
paste0(
"model {\n",
"// priors for Beta dispersion parameters\n",
"phi ~ gamma(0.01, 0.01);"
)
if (
any(grepl("flat_ys ~ poisson_log_glm(flat_xs,", model_file, fixed = TRUE))
) {
linenum <- grep(
"flat_ys ~ poisson_log_glm(flat_xs,",
model_file,
fixed = TRUE
)
model_file[linenum] <-
paste0(
"vector[n_nonmissing] flat_phis;\n",
"flat_phis = rep_each(phi, n)[obs_ind];\n",
"flat_ys ~ beta_binomial(flat_trials_train, inv_logit(flat_xs * b) .* flat_phis, (1 - inv_logit(flat_xs * b)) .* flat_phis);"
)
model_file <- model_file[-(linenum + 1)]
model_file <- readLines(textConnection(model_file), n = -1)
}
if (
any(grepl(
"flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends),",
model_file,
fixed = TRUE
))
) {
linenum <- grep(
"flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends),",
model_file,
fixed = TRUE
)
model_file[linenum] <-
paste0(
"vector[n_nonmissing] flat_phis;\n",
"flat_phis = rep_each(phi, n)[obs_ind];\n",
"flat_ys ~ beta_binomial(flat_trials_train, inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0)) .* flat_phis, (1 - inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0))) .* flat_phis);"
)
model_file <- model_file[-(linenum + 1)]
model_file <- readLines(textConnection(model_file), n = -1)
}
}
if (family_char == 'bernoulli') {
if (
any(grepl("flat_ys ~ poisson_log_glm(flat_xs,", model_file, fixed = TRUE))
) {
model_file[grep(
"flat_ys ~ poisson_log_glm(flat_xs,",
model_file,
fixed = TRUE
)] <-
"flat_ys ~ bernoulli_logit_glm(flat_xs,"
}
if (
any(grepl(
"flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends),",
model_file,
fixed = TRUE
))
) {
model_file[grep(
"flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends),",
model_file,
fixed = TRUE
)] <-
"flat_ys ~ bernoulli_logit_glm(append_col(flat_xs, flat_trends),"
}
}
# Update the generated quantities block
if (family_char == 'binomial') {
model_file[grep(
"ypred[1:n, s] = poisson_log_rng(mus[1:n, s]);",
model_file,
fixed = TRUE
)] <-
"ypred[1:n, s] = binomial_rng(flat_trials[ytimes[1:n, s]], inv_logit(mus[1:n, s]));"
}
if (family_char == 'beta_binomial') {
model_file[grep("vector[total_obs] eta;", model_file, fixed = TRUE)] <-
paste0("vector[total_obs] eta;\n", "matrix[n, n_series] phi_vec;")
model_file[grep("eta = X * b;", model_file, fixed = TRUE)] <-
paste0(
"eta = X * b;;\n",
"for (s in 1 : n_series) {\n",
"phi_vec[1 : n, s] = rep_vector(phi[s], n);\n",
"}"
)
model_file[grep(
"ypred[1:n, s] = poisson_log_rng(mus[1:n, s]);",
model_file,
fixed = TRUE
)] <-
"ypred[1:n, s] = beta_binomial_rng(flat_trials[ytimes[1:n, s]], inv_logit(mus[1:n, s]) .* phi_vec[1:n, s], (1 - inv_logit(mus[1:n, s])) .* phi_vec[1:n, s]);"
}
if (family_char == 'bernoulli') {
model_file[grep(
"ypred[1:n, s] = poisson_log_rng(mus[1:n, s]);",
model_file,
fixed = TRUE
)] <-
"ypred[1:n, s] = bernoulli_logit_rng(mus[1:n, s]);"
}
#### Return ####
return(list(
model_file = model_file,
model_data = model_data,
trials = trials
))
}
================================================
FILE: R/add_corcar.R
================================================
#' Updates for adding continuous time AR data
#' @noRd
add_corcar = function(model_data, data_train, data_test = NULL) {
# Calculate temporal separation among observed points
if (!is.null(data_test)) {
all_times <- rbind(
data.frame(
series = as.numeric(data_train$series),
time = data_train$time,
index..time..index = data_train$index..time..index
),
(data.frame(
series = as.numeric(data_test$series),
time = data_test$time,
index..time..index = data_test$index..time..index
))
) %>%
dplyr::group_by(series) %>%
dplyr::arrange(index..time..index) %>%
dplyr::mutate(
time_lag = dplyr::lag(time),
dis_time = time - time_lag,
dis_time = ifelse(is.na(dis_time), 1, dis_time),
dis_time = pmax(1e-3, dis_time)
) %>%
dplyr::arrange(index..time..index, series)
} else {
all_times <- data.frame(
series = as.numeric(data_train$series),
time = data_train$time,
index..time..index = data_train$index..time..index
) %>%
dplyr::group_by(series) %>%
dplyr::arrange(index..time..index) %>%
dplyr::mutate(
time_lag = dplyr::lag(time),
dis_time = time - time_lag,
dis_time = ifelse(is.na(dis_time), 1, dis_time),
dis_time = pmax(1e-3, dis_time)
) %>%
dplyr::ungroup() %>%
dplyr::arrange(index..time..index, series)
}
time_dis <- matrix(
NA,
nrow = length(unique(all_times$index..time..index)),
ncol = length(unique(all_times$series))
)
for (i in 1:length(unique(all_times$series))) {
time_dis[, i] <- all_times$dis_time[which(all_times$series == i)]
}
model_data$time_dis <- time_dis
return(model_data)
}
================================================
FILE: R/add_nmixture.R
================================================
#' Updates for adding N-mixture processes
#' @noRd
add_nmixture = function(
model_file,
model_data,
data_train,
data_test = NULL,
trend_map = NULL,
nmix_trendmap = TRUE,
orig_trend_model
) {
insight::check_if_installed(
"extraDistr",
reason = 'to simulate from N-Mixture distributions'
)
insight::check_if_installed(
"wrswoR",
reason = 'to simulate from N-Mixture distributions'
)
if (inherits(orig_trend_model, 'mvgam_trend')) {
orig_trend_model <- orig_trend_model$trend_model
}
# Update model data
model_data <- add_nmix_data(
model_data,
data_train,
data_test,
trend_map,
nmix_trendmap
)
#### Update the model file appropriately ####
# If orig_trend_model is 'None', this will be set up as a RW model so need
# to remove sigma and change the process model lines
if (orig_trend_model == 'None') {
# Replace Random Walk trends with no dynamic trend
start_replace <- grep(
'LV[1, j] ~ normal(trend_mus[ytimes_trend[1, j]], sigma[j]);',
model_file,
fixed = TRUE
) -
1
end_replace <- grep(
'LV[i, j] ~ normal(trend_mus[ytimes_trend[i, j]] + LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]], sigma[j]);',
model_file,
fixed = TRUE
) +
2
model_file <- model_file[-c(start_replace:end_replace)]
model_file[grep(
'trend_mus = X_trend * b_trend;',
model_file,
fixed = TRUE
)] <- paste0(
'trend_mus = X_trend * b_trend;',
'\n',
'for(j in 1:n_lv){\n',
'LV[1:n, j] = trend_mus[ytimes_trend[1:n, j]];\n',
'}\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
# Remove sigma parameters
start_replace <- grep('// latent state SD terms', model_file, fixed = TRUE)
end_replace <- start_replace + 1
model_file <- model_file[-c(start_replace:end_replace)]
# model_file <- model_file[-grep('vector[n_lv] penalty;',
# model_file, fixed = TRUE)]
# model_file <- model_file[-grep('penalty = 1.0 / (sigma .* sigma);',
# model_file, fixed = TRUE)]
model_file[grep(
"penalty = 1.0 / (sigma .* sigma);",
model_file,
fixed = TRUE
)] <-
'penalty = rep_vector(1e12, n_lv);'
model_file <- model_file[
-c(
grep(
'// priors for latent state SD parameters',
model_file,
fixed = TRUE
),
grep(
'// priors for latent state SD parameters',
model_file,
fixed = TRUE
) +
1
)
]
# LV has to be declared in transformed params, not params
model_file <- model_file[
-c(
grep('matrix[n, n_lv] LV;', model_file, fixed = TRUE) - 1,
grep('matrix[n, n_lv] LV;', model_file, fixed = TRUE)
)
]
model_file[grep("transformed parameters {", model_file, fixed = TRUE)] <-
paste0(
"transformed parameters {\n",
"// latent states\n",
"matrix[n, n_lv] LV;\n"
)
}
# Update functions block
model_file <- add_nmix_functions(model_file, trend_map, nmix_trendmap)
# Update the data block
model_file[grep(
'int n_nonmissing; // number of nonmissing observations',
model_file,
fixed = TRUE
)] <-
paste0(
"int n_nonmissing; // number of nonmissing observations\n",
"int cap[total_obs]; // upper limits of latent abundances\n",
'array[total_obs] int ytimes_array; // sorted ytimes\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
if (nmix_trendmap) {
model_file[grep(
'array[total_obs] int ytimes_array; // sorted ytimes',
model_file,
fixed = TRUE
)] <-
paste0(
'array[total_obs] int ytimes_array; // sorted ytimes\n',
'array[n, n_series] int ytimes_pred; // time-ordered matrix for prediction\n',
'int K_groups; // number of unique replicated observations\n',
'int K_reps; // maximum number of replicate observations\n',
'array[K_groups] int K_starts; // col of K_inds where each group starts\n',
'array[K_groups] int K_stops; // col of K_inds where each group ends\n',
'array[K_groups, K_reps] int K_inds; // indices of replicated observations'
)
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'int flat_ys[n_nonmissing]; // flattened nonmissing observations',
model_file,
fixed = TRUE
)] <-
'array[total_obs] int flat_ys; // flattened observations'
model_file <- model_file[
-grep(
'matrix[n_nonmissing, num_basis] flat_xs; // X values for nonmissing observations',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep(
'int obs_ind[n_nonmissing]; // indices of nonmissing observations',
model_file,
fixed = TRUE
)
]
}
# Update transformed data block
if (nmix_trendmap) {
model_file[grep("transformed data {", model_file, fixed = TRUE)] <-
paste0(
"transformed data {\n",
"matrix[total_obs, num_basis] X_ordered = X[ytimes_array, : ];\n",
"array[K_groups] int Y_max;\n",
"array[K_groups] int N_max;\n",
"for ( k in 1 : K_groups ) {\n",
"Y_max[k] = max(flat_ys[K_inds[k, K_starts[k] : K_stops[k]]]);\n",
"N_max[k] = max(cap[K_inds[k, K_starts[k] : K_stops[k]]]);\n",
"}"
)
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update the transformed parameters block
model_file[grep("transformed parameters {", model_file, fixed = TRUE)] <-
paste0(
"transformed parameters {\n",
"// detection probability\n",
"vector[total_obs] p;\n"
)
model_file[grep(
'// latent process linear predictors',
model_file,
fixed = TRUE
)] <- paste0(
'// detection probability\n',
'p = X_ordered * b;\n\n',
'// latent process linear predictors'
)
model_file <- readLines(textConnection(model_file), n = -1)
# Update the model block
model_file <- add_nmix_model(model_file, trend_map, nmix_trendmap)
# Update the generated quantities block
model_file <- add_nmix_genquant(model_file, trend_map, nmix_trendmap)
#### Return ####
return(list(model_file = model_file, model_data = model_data))
}
add_nmix_data = function(
model_data,
data_train,
data_test,
trend_map,
nmix_trendmap = TRUE
) {
model_data$ytimes_array <- as.vector(model_data$ytimes)
#### Perform necessary checks on 'cap' (positive integers, no missing values) ####
if (!(exists('cap', where = data_train))) {
stop(
'Max abundances must be supplied as a variable named "cap" for N-mixture models',
call. = FALSE
)
}
if (inherits(data_train, 'data.frame')) {
cap = data_train %>%
dplyr::arrange(series, time) %>%
dplyr::pull(cap)
} else {
cap = data.frame(
series = data_train$series,
cap = data_train$cap,
time = data_train$time
) %>%
dplyr::arrange(series, time) %>%
dplyr::pull(cap)
}
if (!is.null(data_test)) {
if (!(exists('cap', where = data_test))) {
stop(
'Max abundances must be supplied in test data as a variable named "cap" for N-mixture models',
call. = FALSE
)
}
if (inherits(data_test, 'data.frame')) {
captest = data_test %>%
dplyr::arrange(series, time) %>%
dplyr::pull(cap)
} else {
captest = data.frame(
series = data_test$series,
cap = data_test$cap,
time = data_test$time
) %>%
dplyr::arrange(series, time) %>%
dplyr::pull(cap)
}
cap <- c(cap, captest)
}
validate_pos_integers(cap)
if (any(is.na(cap)) | any(is.infinite(cap))) {
stop(
paste0('Missing or infinite values found for some "cap" terms'),
call. = FALSE
)
}
model_data$cap <- as.vector(cap)
if (any(model_data$cap[model_data$obs_ind] < model_data$flat_ys)) {
stop(
paste0('Some "cap" terms are < the observed counts. This is not allowed'),
call. = FALSE
)
}
# Additional data objects for trend_map situations
if (nmix_trendmap) {
obs_ind <- model_data$obs_ind
# Don't need to exclude non-missing obs anymore thanks to the grouping
# indices
model_data$flat_ys <- as.vector(model_data$y)
model_data$flat_ys[model_data$flat_ys == -1] <- 0
ytimes <- model_data$ytimes
Z <- model_data$Z
# For all observations, which factor do they belong to?
which_series <- matrix(NA, nrow = NROW(ytimes), ncol = NCOL(ytimes))
for (j in 1:NCOL(ytimes)) {
which_series[, j] <- j
}
which_series <- as.vector(which_series)
which_factor <- vector(length = length(ytimes))
for (i in 1:NCOL(Z)) {
Z_obs <- which(which_series %in% which(Z[, i] == 1))
which_factor[Z_obs] <- i
}
# Replicate group sizes for each factor * time sample
n_replicates <- colSums(Z)
shift_nas = function(dat) {
# Shift NAs to the right
dat_new <- t(apply(dat, 1, function(x) {
c(x[!is.na(x)], x[is.na(x)])
}))
# Delete any rows that are all NA
dat_new[rowSums(is.na(dat_new)) != ncol(dat_new), , drop = FALSE]
}
length_reps = function(dat) {
apply(dat, 1, function(x) {
length(x[!is.na(x)])
})
}
K_inds <- dplyr::bind_rows(lapply(seq_len(NCOL(Z)), function(i) {
factor_inds <- which(which_factor == i)
group_mat <- matrix(NA, nrow = model_data$n, ncol = n_replicates[i])
for (j in 1:model_data$n) {
group_mat[j, ] <- seq(
factor_inds[j],
max(factor_inds),
by = model_data$n
)
}
group_mat[!group_mat %in% obs_ind] <- NA
data.frame(shift_nas(group_mat))
}))
# A second version of K_inds is needed for later generation
# of properly-constrained latent N predictions; for this version,
# all observations must be included (no NAs)
K_inds_all <- dplyr::bind_rows(lapply(seq_len(NCOL(Z)), function(i) {
factor_inds <- which(which_factor == i)
group_mat <- matrix(NA, nrow = model_data$n, ncol = n_replicates[i])
for (j in 1:model_data$n) {
group_mat[j, ] <- seq(
factor_inds[j],
max(factor_inds),
by = model_data$n
)
}
data.frame(group_mat)
}))
# Add starting and ending indices for each group to model_data
model_data$K_starts <- rep(1, NROW(K_inds))
model_data$K_stops <- length_reps(K_inds)
# Change any remaining NAs to 1 so they are integers
K_inds[is.na(K_inds)] <- 1
# Add remaining group information to the model_data
model_data$K_reps <- NCOL(K_inds)
model_data$K_groups <- NROW(K_inds)
model_data$K_inds <- as.matrix(K_inds)
model_data$K_inds_all <- as.matrix(K_inds_all)
model_data$ytimes_pred <- matrix(
1:model_data$total_obs,
nrow = model_data$n,
byrow = FALSE
)
}
return(model_data)
}
add_nmix_genquant = function(model_file, trend_map, nmix_trendmap) {
rho_included <- any(grepl('rho = log(lambda);', model_file, fixed = TRUE))
rho_trend_included <- any(grepl(
'rho_trend = log(lambda_trend);',
model_file,
fixed = TRUE
))
if (
any(grepl("penalty = 1.0 / (sigma .* sigma);", model_file, fixed = TRUE))
) {
penalty_line <- "vector[n_lv] penalty = 1.0 / (sigma .* sigma);"
} else {
penalty_line <- "vector[n_lv] penalty = rep_vector(1e12, n_lv);"
}
# Delete most generated quantities so that they can be produced after model
# fitting; this dramatically speeds up model time for nmixture models
starts <- grep('generated quantities {', model_file, fixed = TRUE) + 1
ends <- max(grep('}', model_file, fixed = TRUE))
model_file <- model_file[-c(starts:ends)]
model_file[grep('generated quantities {', model_file, fixed = TRUE)] <-
paste0(
'generated quantities {\n',
penalty_line,
'\n',
'vector[total_obs] detprob = inv_logit(p);\n',
if (rho_included) {
'vector[n_sp] rho = log(lambda);\n'
} else {
NULL
},
if (rho_trend_included) {
'vector[n_sp_trend] rho_trend = log(lambda_trend);\n'
} else {
NULL
},
'}'
)
model_file <- readLines(textConnection(model_file), n = -1)
return(model_file)
}
add_nmix_model = function(model_file, trend_map, nmix_trendmap) {
if (nmix_trendmap) {
model_file[grep(
'vector[n_nonmissing] flat_trends;',
model_file,
fixed = TRUE
)] <-
'array[total_obs] real flat_trends;\narray[total_obs] real flat_ps;'
model_file[grep(
'flat_trends = (to_vector(trend))[obs_ind];',
model_file,
fixed = TRUE
)] <-
'flat_trends = (to_array_1d(trend));\nflat_ps = to_array_1d(p);'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends),',
model_file,
fixed = TRUE
)] <-
paste0(
'// loop over replicate sampling window (each site*time*species combination)\n',
'for (k in 1 : K_groups) {\n',
'// all log_lambdas are identical because they represent site*time\n',
'// covariates; so just use the first measurement\n',
'real log_lambda = flat_trends[K_inds[k, 1]];\n',
'// logit-scale detection probilities for the replicate observations\n',
'vector[size(K_inds[k, K_starts[k] : K_stops[k]])] logit_p = to_vector(flat_ps[K_inds[k, K_starts[k] : K_stops[k]]]);\n',
'// K values and observed counts for these replicates\n',
'int K_max = N_max[k];\n',
'int K_min = Y_max[k];\n',
'array[size(K_inds[k, K_starts[k] : K_stops[k]])] int N_obs = flat_ys[K_inds[k, K_starts[k] : K_stops[k]]];\n',
'int possible_N = K_max - K_min;\n',
'// marginalize over possible latent counts analytically\n',
'real ff = exp(log_lambda) * prod(1 - inv_logit(logit_p));\n',
'real prob_n = 1;\n',
'for (i in 1 : possible_N){\n',
'real N = K_max - i + 1;\n',
'real k_obs = 1;\n',
'for (j in 1 : size(N_obs)){\n',
'k_obs *= N / (N - N_obs[j]);\n',
'}\n',
'prob_n = 1 + prob_n * ff * k_obs / N;\n',
'}\n',
'// add log(pr_n) to prob(K_min)\n',
'target += poisson_log_lpmf(K_min | log_lambda) +\n',
'binomial_logit_lpmf(N_obs | K_min, logit_p) +\n',
'log(prob_n);\n',
'}'
)
model_file <- model_file[
-grep('0.0,append_row(b, 1.0));', model_file, fixed = TRUE)
]
model_file <- readLines(textConnection(model_file), n = -1)
}
return(model_file)
}
add_nmix_functions = function(model_file, trend_map, nmix_trendmap) {
model_file <- readLines(textConnection(model_file), n = -1)
return(model_file)
}
#' Function to add generated quantities for nmixture models, which
#' saves huge computational time
#' @noRd
add_nmix_posterior = function(
model_output,
obs_data,
test_data,
mgcv_model,
n_lv,
Z,
K_inds
) {
# Function to add samples to the 'sim' slot of a stanfit object
add_samples = function(
model_output,
names,
samples,
nsamples,
nchains,
parname
) {
samp_starts <- seq(1, NROW(samples), by = nsamples)
samp_ends <- seq(nsamples, NROW(samples), by = nsamples)
for (i in 1:nchains) {
samps_df <- data.frame(samples[samp_starts[i]:samp_ends[i], ])
colnames(samps_df) <- names
if (is.list(model_output@sim$samples[[i]])) {
old <- attributes(model_output@sim$samples[[i]])
oldnames <- attr(model_output@sim$samples[[i]], 'names')
model_output@sim$samples[[i]] <-
append(model_output@sim$samples[[i]], as.list(samps_df))
mostattributes(model_output@sim$samples[[i]]) <- old
attr(model_output@sim$samples[[i]], 'names') <-
c(oldnames, colnames(samps_df))
} else {
model_output@sim$samples[[i]] <-
dplyr::bind_cols(model_output@sim$samples[[i]], samps_df)
}
}
model_output@sim$fnames_oi <- c(model_output@sim$fnames_oi, names)
model_output@model_pars <- c(model_output@model_pars, parname)
model_output@sim$pars_oi <- c(model_output@sim$pars_oi, parname)
return(model_output)
}
# Number of chains
nchains <- model_output@sim$chains
# Trend samples (for getting dimnames needed for ypred, latent_ypred)
trend <- mcmc_chains(model_output, 'trend')
# Construct latent_ypred samples (arranged by time, then series)
detprob <- mcmc_chains(model_output, 'detprob')
ps <- qlogis(detprob)
Xp <- matrix(as.vector(ps))
attr(Xp, 'model.offset') <- 0
if (!is.null(test_data)) {
cap <- rbind(
data.frame(
time = obs_data$time,
series = obs_data$series,
cap = obs_data$cap
),
data.frame(
time = test_data$time,
series = test_data$series,
cap = test_data$cap
)
) %>%
dplyr::arrange(series, time) %>%
dplyr::pull(cap)
} else {
cap <- data.frame(
time = obs_data$time,
series = obs_data$series,
cap = obs_data$cap
) %>%
dplyr::arrange(series, time) %>%
dplyr::pull(cap)
}
cap <- as.vector(t(replicate(NROW(ps), cap)))
# Unconditional latent_N predictions
if (!is.null(test_data)) {
truth_df <- rbind(
data.frame(
time = obs_data$time,
series = obs_data$series,
y = obs_data$y
),
data.frame(
time = test_data$time,
series = test_data$series,
y = test_data$y
)
)
} else {
truth_df <- data.frame(
time = obs_data$time,
series = obs_data$series,
y = obs_data$y
)
}
get_min_cap = function(truth, K_inds) {
rowgroup = function(x) {
which(K_inds == x, arr.ind = TRUE)[1]
}
data.frame(index = 1:length(truth), truth = truth) %>%
dplyr::rowwise() %>%
dplyr::mutate(group = rowgroup(index)) %>%
dplyr::ungroup() %>%
dplyr::group_by(group) %>%
dplyr::mutate(min_cap = max(truth, na.rm = TRUE)) %>%
dplyr::pull(min_cap)
}
# K_inds was originally supplied in series, time order
# so the corresponding truth must be supplied that way
truth_df %>%
dplyr::arrange(series, time) %>%
dplyr::pull(y) -> orig_y
if (is.null(K_inds)) {
K_inds <- matrix(1:length(orig_y), ncol = 1)
}
min_cap <- suppressWarnings(get_min_cap(orig_y, K_inds))
min_cap[!is.finite(min_cap)] <- 0
# min_cap is now in the wrong order, so we need to change it
truth_df %>%
dplyr::arrange(series, time) %>%
dplyr::bind_cols(min_cap = min_cap) %>%
dplyr::arrange(time, series) %>%
dplyr::pull(min_cap) -> min_cap
# truth now also needs to be in the correct time, series
# order
truth_df %>%
dplyr::arrange(time, series) %>%
dplyr::pull(y) -> mod_y
truth <- as.vector(t(replicate(NROW(ps), mod_y)))
min_cap <- as.vector(t(replicate(NROW(ps), min_cap)))
latentypreds_vec <- mvgam_predict(
Xp = Xp,
family = 'nmix',
betas = 1,
latent_lambdas = exp(as.vector(trend)),
cap = cap,
min_cap = min_cap,
type = 'latent_N'
)
# Conditional latent_N predictions (when observations were not NA)
whichobs <- which(!is.na(truth))
Xp <- Xp[whichobs, , drop = FALSE]
attr(Xp, 'model.offset') <- 0
condpreds_vec <- mvgam_predict(
Xp = Xp,
family = 'nmix',
betas = 1,
latent_lambdas = exp(as.vector(trend)[whichobs]),
cap = cap[whichobs],
min_cap = min_cap[whichobs],
truth = truth[whichobs],
type = 'latent_N'
)
# Fill in the unconditionals using the conditionals when there were actually
# observations
latentypreds_vec[whichobs] <- condpreds_vec
latentypreds <- matrix(latentypreds_vec, nrow = NROW(ps))
# Update parameter names and samples to match expected order
expand.grid(
time = 1:model_output@sim$dims_oi$trend[1],
series = 1:model_output@sim$dims_oi$trend[2]
) %>%
dplyr::arrange(time, series) %>%
dplyr::mutate(current = dplyr::row_number()) %>%
dplyr::arrange(series, time) %>%
dplyr::mutate(needed = dplyr::row_number()) %>%
dplyr::mutate(name = paste0('trend[', time, ',', series, ']')) %>%
dplyr::arrange(current) -> ordering_needed
parnames <- ordering_needed %>%
dplyr::arrange(needed) %>%
dplyr::pull(name)
indices <- ordering_needed %>%
dplyr::arrange(needed) %>%
dplyr::pull(current)
# Add latent_ypreds to the posterior samples
model_output <- add_samples(
model_output = model_output,
names = gsub('trend', 'latent_ypred', parnames),
samples = latentypreds[, indices],
nsamples = NROW(latentypreds) / nchains,
nchains = nchains,
parname = 'latent_ypred'
)
model_output@sim$dims_oi$latent_ypred <-
model_output@sim$dims_oi$trend
# Now construct the detprob samples
# model_output <- add_samples(
# model_output = model_output,
# names = gsub('p', 'detprob', dimnames(ps)[[2]]),
# samples = detprob,
# nsamples = NROW(detprob) / nchains,
# nchains = nchains,
# parname = 'detprob'
# )
# model_output@sim$dims_oi$detprob <-
# model_output@sim$dims_oi$p
# Now construct ypred samples
ypreds_vec <- rbinom(
length(latentypreds_vec),
size = latentypreds_vec,
prob = as.vector(detprob)
)
ypreds <- matrix(ypreds_vec, nrow = NROW(ps))
model_output <- add_samples(
model_output = model_output,
names = gsub('trend', 'ypred', parnames),
samples = ypreds[, indices],
nsamples = NROW(ypreds) / nchains,
nchains = nchains,
parname = 'ypred'
)
model_output@sim$dims_oi$ypred <-
model_output@sim$dims_oi$trend
# Now construct mus (expectations) samples
mus_vec <- as.vector(detprob) * latentypreds_vec
mus <- matrix(mus_vec, nrow = NROW(ps))
model_output <- add_samples(
model_output = model_output,
names = gsub('trend', 'mus', parnames),
samples = mus[, indices],
nsamples = NROW(mus) / nchains,
nchains = nchains,
parname = 'mus'
)
model_output@sim$dims_oi$mus <-
model_output@sim$dims_oi$trend
# Now the lv_coefs samples
n_series <- length(unique(obs_data$series))
combinations <- expand.grid(1:n_series, 1:n_lv) %>%
dplyr::arrange(Var2)
lv_coef_names <- apply(
combinations,
1,
function(x) paste0('lv_coefs[', x[1], ',', x[2], ']')
)
lv_coef_samps <- t(as.matrix(replicate(NROW(ps), as.vector(t(Z)))))
model_output <- add_samples(
model_output = model_output,
names = lv_coef_names,
samples = lv_coef_samps,
nsamples = NROW(lv_coef_samps) / nchains,
nchains = nchains,
parname = 'lv_coefs'
)
model_output@sim$dims_oi$lv_coefs <- c(n_series, n_lv)
# Update number of total parameters
model_output@sim$n_flatnames <-
sum(unlist(lapply(model_output@sim$dims_oi, prod), use.names = FALSE))
return(model_output)
}
================================================
FILE: R/add_poisson_lines.R
================================================
#' Poisson JAGS modifications
#'
#'
#' @noRd
#' @param model_file A template `JAGS` model file to be modified
#' @param upper_bounds Optional upper bounds for the truncated observation likelihood
#' @return A modified `JAGS` model file
add_poisson_lines = function(model_file, upper_bounds) {
odis_begin <- grep('phi\\[s\\] <- ', model_file) - 4
odis_end <- odis_begin + 7
model_file <- model_file[-c(odis_begin:odis_end)]
rate_begin <- grep('rate\\[i, s\\] <- ', model_file)
rate_end <- rate_begin + 1
model_file <- model_file[-c(rate_begin:rate_end)]
if (missing(upper_bounds)) {
model_file[grep(
'y\\[i, s\\] ~',
model_file
)] <- ' y[i, s] ~ dpois(mus[i, s])'
model_file[grep(
'ypred\\[i, s\\] ~',
model_file
)] <- ' ypred[i, s] ~ dpois(mus[i, s])'
} else {
model_file[grep(
'y\\[i, s\\] ~',
model_file
)] <- ' y[i, s] ~ dpois(mus[i, s])T(, upper_bound[s])'
model_file[grep(
'ypred\\[i, s\\] ~',
model_file
)] <- ' ypred[i, s] ~ dpois(mus[i, s])T(, upper_bound[s])'
}
model_file
}
================================================
FILE: R/add_residuals.R
================================================
#'@title Calculate randomized quantile residuals for \pkg{mvgam} objects
#'@name add_residuals.mvgam
#'@param object \code{list} object of class \code{mvgam}. See [mvgam()]
#'@param ... unused
#'@details For each series, randomized quantile (i.e. Dunn-Smyth) residuals are calculated for inspecting model diagnostics
#'If the fitted model is appropriate then Dunn-Smyth residuals will be standard normal in distribution and no
#'autocorrelation will be evident. When a particular observation is missing, the residual is calculated by comparing independent
#'draws from the model's posterior distribution
#'@return A list object of class `mvgam` with residuals included in the `'resids'` slot
#'@export
add_residuals <- function(object, ...) {
UseMethod("add_residuals", object)
}
#'@rdname add_residuals.mvgam
#'@method add_residuals mvgam
#'@export
add_residuals.mvgam = function(object, ...) {
resids <- dsresids_vec(object)
object$resids <- resids
return(object)
}
================================================
FILE: R/add_stan_data.R
================================================
#' Add remaining data, model and parameter blocks to a Stan model
#'
#'
#' @noRd
#' @param jags_file Prepared JAGS mvgam model file
#' @param stan_file Incomplete Stan model file to be edited
#' @param ss_gam The GAM setup object
#' @param use_lv logical
#' @param n_lv \code{integer} number of latent dynamic factors (if \code{use_lv = TRUE})
#' @param jags_data Prepared mvgam data for JAGS modelling
#' @param family \code{character}.
#' @param upper_bounds Optional \code{vector} of \code{integer} values specifying upper limits for each series. If supplied,
#' this generates a modified likelihood where values above the bound are given a likelihood of zero. Note this modification
#' is computationally expensive in \code{JAGS} but can lead to better estimates when true bounds exist. Default is to remove
#' truncation entirely (i.e. there is no upper bound for each series)
#' @return A `list` containing the updated Stan model and model data
add_stan_data = function(
jags_file,
stan_file,
ss_gam,
use_lv = FALSE,
n_lv,
jags_data,
family = 'poisson',
upper_bounds
) {
#### Modify the Stan file ####
# Update lines associated with particular family
if (family == 'poisson') {
if (!is.null(upper_bounds)) {
stan_file[grep('~ poisson_log', stan_file)] <-
gsub(';', 'T[,U[s]];', stan_file[grep('~ poisson_log', stan_file)])
stan_file[grep('~ poisson_log', stan_file)] <-
gsub(
'poisson_log(',
'poisson(exp(',
stan_file[grep('~ poisson_log', stan_file)],
fixed = TRUE
)
stan_file[grep('~ poisson', stan_file)] <-
gsub(')', '))', stan_file[grep('~ poisson', stan_file)], fixed = TRUE)
}
}
if (family == 'negative binomial') {
stan_file[grep('// raw basis', stan_file) + 2] <-
'\n// negative binomial overdispersion\nvector[n_series] phi_inv;\n'
stan_file[grep('// priors for smoothing', stan_file) + 2] <-
paste0(
'\n// priors for overdispersion parameters\n',
'phi_inv ~ student_t(3, 0, 0.1);\n'
)
to_negbin <- gsub(
'poisson_log',
'neg_binomial_2',
stan_file[grep('y[i, s] ~ poisson', stan_file, fixed = T)]
)
stan_file[grep('y[i, s] ~ poisson', stan_file, fixed = T)] <-
gsub(');', ', inv(phi_inv[s]));', to_negbin)
add_exp_open <- gsub(
'\\(eta',
'(exp(eta',
stan_file[grep('y[i, s] ~ neg_binomial', stan_file, fixed = T)]
)
add_exp_cl <- gsub('],', ']),', add_exp_open)
stan_file[grep('y[i, s] ~ neg_binomial', stan_file, fixed = T)] <-
add_exp_cl
stan_file[grep('matrix[n, n_series] ypred;', stan_file, fixed = T)] <-
paste0(
'matrix[n, n_series] ypred;\n',
'matrix[n, n_series] phi_vec;\n',
'vector[n_series] phi;\n',
'phi = inv(phi_inv);\n',
'for (s in 1:n_series) {\n',
'phi_vec[1:n,s] = rep_vector(phi[s], n);\n}\n'
)
to_negbin <- gsub(
'poisson_log_rng',
'neg_binomial_2_rng',
stan_file[grep('ypred[i, s] = poisson_log_rng', stan_file, fixed = T)]
)
stan_file[grep('ypred[i, s] = poisson_log_rng', stan_file, fixed = T)] <-
gsub(');', ', phi_vec[i, s]);', to_negbin)
add_exp_open <- gsub(
'\\(eta',
'(exp(eta',
stan_file[grep('ypred[i, s] = neg_binomial', stan_file, fixed = T)]
)
if (any(grepl('trend[i, s]', stan_file, fixed = T))) {
add_exp_cl <- gsub('trend[i, s]', 'trend[i, s])', add_exp_open, fixed = T)
} else {
add_exp_cl <- gsub(
'eta[ytimes[i, s]]',
'eta[ytimes[i, s]])',
add_exp_open,
fixed = T
)
}
stan_file[grep('ypred[i, s] = neg_binomial', stan_file, fixed = T)] <-
add_exp_cl
if (!is.null(upper_bounds)) {
stan_file[grep('~ neg_binomial_2', stan_file)] <-
gsub(';', 'T[,U[s]];', stan_file[grep('~ neg_binomial_2', stan_file)])
}
stan_file <- readLines(textConnection(stan_file), n = -1)
}
# Get dimensions and numbers of smooth terms
snames <- names(jags_data)[grep('S.*', names(jags_data))]
if (length(snames) == 0) {
smooth_penalty_data <- NULL
} else {
smooth_dims <- matrix(NA, ncol = 2, nrow = length(snames))
for (i in 1:length(snames)) {
smooth_dims[i, ] <- dim(jags_data[[snames[i]]])
}
# Insert the data block for the model
smooth_penalty_data <- vector()
for (i in 1:length(snames)) {
smooth_penalty_data[i] <- paste0(
'matrix[',
smooth_dims[i, 1],
',',
smooth_dims[i, 2],
'] ',
snames[i],
'; // mgcv smooth penalty matrix ',
snames[i]
)
}
}
# Get parametric prior locations and precisions if necessary
if ('p_taus' %in% names(jags_data)) {
p_terms <- paste0(
'real p_taus[',
length(jags_data$p_taus),
']; // prior precisions for parametric coefficients\n',
'real p_coefs[',
length(jags_data$p_taus),
']; // prior locations for parametric coefficients\n'
)
} else {
p_terms <- NULL
}
# Add lines for upper bounds if supplied
if (!is.null(upper_bounds)) {
bounds <- paste0('int U[', length(upper_bounds), ']; // upper bounds\n')
} else {
bounds <- NULL
}
# Remove smooth parameter info if no smooth terms are included
if (any(grepl('## smoothing parameter priors...', jags_file))) {
zero_data <- paste0(
'vector[num_basis] zero; // prior locations for basis coefficients\n'
)
n_sp_data <- paste0(
'int n_sp; // number of smoothing parameters\n'
)
} else {
zero_data <- NULL
n_sp_data <- NULL
}
# Occasionally there are smooths with no zero vector
# (i.e. for bs = 'fs', they are often just normal(0, lambda))
if (is.null(jags_data$zero)) {
zero_data <- NULL
}
# latent variable lines
if (use_lv) {
lv_data <- paste0('int n_lv; // number of dynamic factors\n')
} else {
lv_data <- NULL
}
# shared smoothing parameter lines
if ('L' %in% names(jags_data)) {
lambda_links <- paste0(
'matrix[',
NROW(jags_data$L),
',',
NCOL(jags_data$L),
'] lambda_links; // smooth parameter linking matrix\n',
'int n_raw_sp; // number of raw smoothing parameters to estimate\n'
)
} else {
lambda_links <- NULL
}
# Offset information
if (any(grepl('eta <- X %*% b + offset', jags_file, fixed = TRUE))) {
offset_line <- paste0('vector[total_obs] offset; // offset vector\n')
} else {
offset_line <- NULL
}
if (any(grepl('eta <- X * b + offset', jags_file, fixed = TRUE))) {
offset_line <- paste0('vector[total_obs] offset; // offset vector\n')
} else {
offset_line <- NULL
}
if (
any(grepl(
'offset; offset vector of length (n x n_series)',
jags_file,
fixed = TRUE
))
) {
offset_line <- paste0('vector[total_obs] offset; // offset vector\n')
} else {
offset_line <- NULL
}
# Search for any non-contiguous indices that sometimes are used by mgcv
if (any(grep('in c\\(', jags_file))) {
add_idxs <- TRUE
seq_character = function(x) {
all_nums <- as.numeric(unlist(strsplit(x, ':')))
if (length(all_nums) > 1) {
out <- seq(all_nums[1], all_nums[2])
} else {
out <- all_nums
}
out
}
idx_locations <- grep('in c\\(', jags_file)
idx_vals <- list()
idx_data <- vector()
for (i in 1:length(idx_locations)) {
list_vals <- unlist(strsplit(
gsub('^.*c\\(*|\\s*).*$', '', jags_file[idx_locations[i]]),
','
))
idx_vals[[i]] <- array(
unlist(lapply(list_vals, seq_character)),
dim = length(unlist(lapply(list_vals, seq_character)))
)
idx_data[i] <- paste0(
'int idx',
i,
'[',
length(idx_vals[[i]]),
']; // discontiguous index values'
)
jags_file[idx_locations][i] <- sub(
"in.*\\)\\)",
paste0("in idx", i, ')'),
jags_file[idx_locations][i]
)
}
# Update the Stan data block
stan_file[grep('##insert data', stan_file)] <- paste0(
'// Stan model code generated by package mvgam\n',
'data {',
'\n',
bounds,
paste0(idx_data, collapse = '\n'),
'\n',
'int total_obs; // total number of observations\n',
'int n; // number of timepoints per series\n',
lv_data,
n_sp_data,
lambda_links,
'int n_series; // number of series\n',
'int num_basis; // total number of basis coefficients\n',
#p_terms,
zero_data,
offset_line,
'matrix[num_basis, total_obs] X; // transposed mgcv GAM design matrix\n',
'int ytimes[n, n_series]; // time-ordered matrix (which col in X belongs to each [time, series] observation?)\n',
paste0(smooth_penalty_data, collapse = '\n'),
'\n',
'int y_observed[n, n_series]; // indices of missing vs observed\n',
'int y[n, n_series]; // time-ordered observations, with -1 indicating missing\n',
'}\n'
)
} else {
add_idxs <- FALSE
stan_file[grep('##insert data', stan_file)] <- paste0(
'// Stan model code generated by package mvgam\n',
'data {',
'\n',
bounds,
'int total_obs; // total number of observations\n',
'int n; // number of timepoints per series\n',
lv_data,
n_sp_data,
lambda_links,
'int n_series; // number of series\n',
'int num_basis; // total number of basis coefficients\n',
zero_data,
offset_line,
#p_terms,
'matrix[num_basis, total_obs] X; // transposed mgcv GAM design matrix\n',
'int ytimes[n, n_series]; // time-ordered matrix (which col in X belongs to each [time, series] observation?)\n',
paste0(smooth_penalty_data, collapse = '\n'),
'\n',
'int y_observed[n, n_series]; // indices of missing vs observed\n',
'int y[n, n_series]; // time-ordered observations, with -1 indicating missing\n',
'}\n'
)
}
stan_file <- readLines(textConnection(stan_file), n = -1)
# Modify the model block to include each smooth term
if (any(grepl('## smoothing parameter priors...', jags_file))) {
smooths_start <- grep('## GAM-specific priors', jags_file) + 1
smooths_end <- grep('## smoothing parameter priors...', jags_file) - 1
jags_smooth_text <- jags_file[smooths_start:smooths_end]
jags_smooth_text <- gsub('##', '//', jags_smooth_text)
jags_smooth_text <- gsub('dexp', 'exponential', jags_smooth_text)
smooth_labs <- do.call(
rbind,
lapply(seq_along(ss_gam$smooth), function(x) {
data.frame(
label = ss_gam$smooth[[x]]$label,
term = paste(ss_gam$smooth[[x]]$term, collapse = ','),
class = class(ss_gam$smooth[[x]])[1]
)
})
)
if (length(ss_gam$sp) > 0 & !all(smooth_labs$class == 'random.effect')) {
any_ks <- TRUE
} else {
any_ks <- FALSE
}
# any_ks <- any(grep('K.* <- ', jags_smooth_text))
any_timevarying <- any(grep(
'// prior for s(time):',
jags_smooth_text,
fixed = TRUE
))
if (
any_ks ||
any_timevarying
) {
if (any(grep('K.* <- ', jags_smooth_text))) {
K_starts <- grep('K.* <- ', jags_smooth_text)
for (i in 1:length(K_starts)) {
jags_smooth_text[K_starts[i] + 1] <- gsub(
'\\bb\\b',
'b_raw',
gsub(
'dmnorm',
'multi_normal_prec',
paste0(
gsub(
'K.*',
trimws(gsub('K.* <- ', '', jags_smooth_text[K_starts[i]])),
jags_smooth_text[K_starts[i] + 1]
),
')'
)
)
)
}
jags_smooth_text <- jags_smooth_text[-K_starts]
}
} else {
# If no K terms or time-varying terms, then there are no smoothing parameters in the model
# (probably the only smooth terms included are random effect bases, which don't need
# smoothing parameters when we use the non-centred parameterisation)
stan_file <- stan_file[
-grep('// priors for smoothing parameters', stan_file, fixed = TRUE)
]
stan_file <- stan_file[-grep('lambda ~ ', stan_file, fixed = TRUE)]
stan_file <- stan_file[-grep('vector[n_sp] rho', stan_file, fixed = TRUE)]
stan_file <- stan_file[-grep('rho = log', stan_file, fixed = TRUE)]
stan_file <- stan_file[
-grep('// smoothing parameters', stan_file, fixed = TRUE)
]
stan_file <- stan_file[-grep('[n_sp] lambda', stan_file, fixed = TRUE)]
# stan_file <- stan_file[-grep('vector[num_basis] zero; //', stan_file,
# fixed = TRUE)]
stan_file <- stan_file[
-grep('int n_sp; //', stan_file, fixed = TRUE)
]
}
# If there are no K terms but there are time-varying, we don't need
# the zero vector
if (any_timevarying & !any_ks) {
stan_file <- stan_file[
-grep('vector[num_basis] zero; //', stan_file, fixed = TRUE)
]
}
# Create a new smooths_included check after working through the
# random effects
if (!any_timevarying & !any_ks) {
smooths_included <- FALSE
} else {
smooths_included <- TRUE
}
if (any(grep('b\\[i\\] = b_raw', jags_smooth_text))) {
jags_smooth_text <- jags_smooth_text[
-grep('b\\[i\\] = b_raw', jags_smooth_text)
]
}
jags_smooth_text <- gsub('dnorm', 'normal', jags_smooth_text)
jags_smooth_text <- gsub(' ', ' ', jags_smooth_text)
jags_smooth_text[-grep('//|\\}|\\{', jags_smooth_text)] <-
paste0(jags_smooth_text[-grep('//|\\}|\\{', jags_smooth_text)], ';')
jags_smooth_text <- gsub(') }', '); }', jags_smooth_text)
jags_smooth_text <- gsub('}', '}\n', jags_smooth_text)
jags_smooth_text[(grep('//', jags_smooth_text) - 1)[-1]] <-
paste0(jags_smooth_text[(grep('//', jags_smooth_text) - 1)[-1]], '\n')
stan_file[grep('##insert smooths', stan_file)] <- paste0(
jags_smooth_text,
collapse = '\n'
)
stan_file <- readLines(textConnection(stan_file), n = -1)
# Deal with any random effect priors
if (any(grep('b_raw\\[i\\] ~', stan_file))) {
b_raw_string <- paste0(
stan_file[grep('b_raw\\[i\\] ~', stan_file) - 1],
collapse = ','
)
n_b_raw <- max(as.numeric(unlist(regmatches(
b_raw_string,
gregexpr("[[:digit:]]+", b_raw_string)
))))
min_b_raw <- min(as.numeric(unlist(regmatches(
b_raw_string,
gregexpr("[[:digit:]]+", b_raw_string)
))))
n_sigma_raw <- max(as.numeric(unlist(regmatches(
unique(sub(
".*(sigma_raw?\\d+).*",
"\\1",
grep('sigma_raw', stan_file, value = T)
)),
gregexpr(
"[[:digit:]]+",
unique(sub(
".*(sigma_raw?\\d+).*",
"\\1",
grep('sigma_raw', stan_file, value = T)
))
)
))))
stan_file <- stan_file[-grep('mu_raw.* ~ ', stan_file)]
stan_file <- stan_file[-grep('<- mu_raw', stan_file)]
stan_file <- stan_file[-grep('sigma_raw.* ~ ', stan_file)]
stan_file[grep('model \\{', stan_file)] <-
paste0(
'model {\n// prior for random effect population variances\nsigma_raw ~ exponential(0.5);\n\n',
'// prior for random effect population means\nmu_raw ~ std_normal();\n'
)
stan_file[grep('parameters \\{', stan_file)[1] + 2] <-
paste0(
stan_file[grep('parameters \\{', stan_file)[1] + 2],
'\n',
'\n// random effect variances\n',
paste0(
'vector[',
n_sigma_raw,
'] sigma_raw',
';\n',
collapse = ''
),
'\n',
'\n// random effect means\n',
paste0('vector[', n_sigma_raw, '] mu_raw', ';\n', collapse = '')
)
b_raw_text <- vector()
min_beta <- vector()
b_raw_indices <- grep('b_raw\\[i\\] ~', stan_file)
for (i in 1:length(b_raw_indices)) {
b_raw_text[i] <- paste0(
'for (i in ',
as.numeric(sub(
"for \\(i in ",
"",
sub("\\:.*", "", stan_file[b_raw_indices[i] - 1])
)),
':',
as.numeric(sub(
" ",
"",
sub(
"\\{",
"",
sub("\\)", "", sub(".*\\:", "", stan_file[b_raw_indices[i] - 1]))
)
)),
') {\nb[i] = mu_raw[',
i,
'] + b_raw[i] * sigma_raw[',
i,
'];\n}\n'
)
min_beta[i] <- as.numeric(sub(
"for \\(i in ",
"",
sub("\\:.*", "", stan_file[b_raw_indices[i] - 1])
))
}
# If parametric coefficients are included, they'll come before random effects
min_re_betas <- min(min_beta)
if (min_re_betas > 1) {
b_raw_text <- c(
paste0(
'\nfor (i in 1:',
min_re_betas - 1,
') {\nb[i] = b_raw[i];\n}'
),
b_raw_text
)
} else {
b_raw_text <- b_raw_text
}
if (n_b_raw < dim(jags_data$X)[2]) {
b_raw_text <- c(
b_raw_text,
paste0(
'\nfor (i in ',
n_b_raw + 1,
':num_basis) {\nb[i] = b_raw[i];\n}\n'
)
)
}
stan_file[grep('// basis coefficients', stan_file) + 2] <- paste0(
b_raw_text,
collapse = '\n'
)
stan_file <- readLines(textConnection(stan_file), n = -1)
# If no random effects, betas are equal to beta_raws
} else {
stan_file[grep('// basis coefficients', stan_file) + 2] <-
paste0('\nfor (i in ', '1:num_basis) {\nb[i] = b_raw[i];\n}')
stan_file <- readLines(textConnection(stan_file), n = -1)
}
# Update parametric effect priors
if (any(grep('// parametric effect', stan_file))) {
# Get indices of parametric effects
smooth_labs <- do.call(
rbind,
lapply(seq_along(ss_gam$smooth), function(x) {
data.frame(
label = ss_gam$smooth[[x]]$label,
term = paste(ss_gam$smooth[[x]]$term, collapse = ','),
class = class(ss_gam$smooth[[x]])[1]
)
})
)
lpmat <- predict(ss_gam, type = 'lpmatrix', exclude = smooth_labs$label)
para_indices <- which(apply(lpmat, 2, function(x) !all(x == 0)) == TRUE)
# min_paras <- as.numeric(sub('.*(?=.$)', '',
# sub("\\:.*", "",
# stan_file[grep('// parametric effect', stan_file) + 1]),
# perl=T))
# max_paras <- as.numeric(substr(sub(".*\\:", "",
# stan_file[grep('// parametric effect', stan_file) + 1]),
# 1, 1))
# para_indices <- seq(min_paras, max_paras)
# Get names of parametric terms
# int_included <- attr(ss_gam$pterms, 'intercept') == 1L
# other_pterms <- attr(ss_gam$pterms, 'term.labels')
# all_paras <- other_pterms
# if(int_included){
# all_paras <- c('(Intercept)', all_paras)
# }
all_paras <- names(para_indices)
# Create prior lines for parametric terms
para_lines <- vector()
for (i in seq_along(all_paras)) {
para_lines[i] <- paste0(
'// prior for ',
all_paras[i],
'...\n',
'b_raw[',
para_indices[i],
'] ~ student_t(3, 0, 2);\n'
)
}
stan_file <- stan_file[-(grep('// parametric effect', stan_file) + 1)]
stan_file[grep('// parametric effect', stan_file)] <-
paste0(paste(para_lines, collapse = '\n'))
stan_file <- readLines(textConnection(stan_file), n = -1)
}
# Check for shared smoothing parameters and link them accordingly
if ('L' %in% names(jags_data)) {
stan_file[grep(
'lambda ~ normal',
stan_file,
fixed = TRUE
)] <- "lambda_raw ~ normal(30, 25);"
stan_file[grep(
"vector[n_sp] lambda;",
stan_file,
fixed = TRUE
)] <- "vector[n_raw_sp] lambda_raw;"
stan_file[grep(
'// GAM contribution to expectations',
stan_file,
fixed = TRUE
)] <-
"// GAM contribution to expectations (log scale)\n// linked smoothing parameters\nvector[n_sp] lambda;\n"
stan_file[grep('model {', stan_file, fixed = TRUE) - 2] <-
'lambda = to_vector(lambda_links * lambda_raw);\n}\n'
stan_file <- readLines(textConnection(stan_file), n = -1)
}
} else {
## No smooths included
smooths_included <- FALSE
stan_file <- stan_file[
-grep('// priors for smoothing parameters', stan_file, fixed = TRUE)
]
stan_file <- stan_file[-grep('lambda ~ normal', stan_file, fixed = TRUE)]
stan_file <- stan_file[-grep('vector[n_sp] rho', stan_file, fixed = TRUE)]
stan_file <- stan_file[-grep('rho = log', stan_file, fixed = TRUE)]
stan_file <- stan_file[
-grep('// smoothing parameters', stan_file, fixed = TRUE)
]
stan_file <- stan_file[-grep('[n_sp] lambda', stan_file, fixed = TRUE)]
stan_file[grep('// basis coefficients', stan_file) + 2] <-
paste0('\nfor (i in ', '1:num_basis) {\nb[i] = b_raw[i];\n}\n')
if (any(grep('## parametric effect priors', jags_file))) {
# Get indices of parametric effects
smooth_labs <- do.call(
rbind,
lapply(seq_along(ss_gam$smooth), function(x) {
data.frame(
label = ss_gam$smooth[[x]]$label,
term = paste(ss_gam$smooth[[x]]$term, collapse = ','),
class = class(ss_gam$smooth[[x]])[1]
)
})
)
lpmat <- predict(ss_gam, type = 'lpmatrix', exclude = smooth_labs$label)
para_indices <- which(apply(lpmat, 2, function(x) !all(x == 0)) == TRUE)
all_paras <- names(para_indices)
# min_paras <- as.numeric(sub('.*(?=.$)', '',
# sub("\\:.*", "",
# jags_file[grep('## parametric effect', jags_file) + 1]), perl=T))
# max_paras <- as.numeric(substr(sub(".*\\:", "",
# jags_file[grep('## parametric effect', jags_file) + 1]),
# 1, 1))
# para_indices <- seq(min_paras, max_paras)
#
# # Get names of parametric terms
# int_included <- attr(ss_gam$pterms, 'intercept') == 1L
# other_pterms <- attr(ss_gam$pterms, 'term.labels')
# all_paras <- other_pterms
# if(int_included){
# all_paras <- c('(Intercept)', all_paras)
# }
# Create prior lines for parametric terms
para_lines <- vector()
for (i in seq_along(all_paras)) {
para_lines[i] <- paste0(
'// prior for ',
all_paras[i],
'...\n',
'b_raw[',
para_indices[i],
'] ~ student_t(3, 0, 2);\n'
)
}
stan_file[grep('##insert smooths', stan_file)] <-
paste0(paste(para_lines, collapse = '\n'))
stan_file <- readLines(textConnection(stan_file), n = -1)
}
}
#### Minor text changes to improve efficiency of Stan code ####
#stan_file <- gsub('...', '', stan_file)
clean_up <- vector()
for (x in 1:length(stan_file)) {
clean_up[x] <- stan_file[x - 1] == "" & stan_file[x] == ""
}
clean_up[is.na(clean_up)] <- FALSE
stan_file <- stan_file[!clean_up]
# Use as much vectorization as possible for computing predictions
stan_file[grep('vector[total_obs] eta;', stan_file, fixed = TRUE)] <-
paste0(
'vector[total_obs] eta;\n\n',
'// expectations\n',
'matrix[n, n_series] mus;'
)
if (any(grepl('trend[i, s]', stan_file))) {
stan_file <- sub(
'eta[ytimes[i, s]] + trend[i, s]',
'mus[i, s]',
stan_file,
fixed = TRUE
)
stan_file[grep('model {', stan_file, fixed = TRUE) - 2] <-
paste0(
'\nfor(s in 1:n_series){\n',
'mus[1:n, s] = eta[ytimes[1:n, s]] + trend[1:n, s];\n',
'}\n',
'}'
)
} else {
stan_file <- sub('eta[ytimes[i, s]]', 'mus[i, s]', stan_file, fixed = TRUE)
stan_file[grep('model {', stan_file, fixed = TRUE) - 2] <-
paste0(
'\nfor(s in 1:n_series){\n',
'mus[1:n, s] = eta[ytimes[1:n, s]];\n',
'}\n',
'}'
)
}
stan_file <-
stan_file[-(grep('// posterior predictions', stan_file, fixed = TRUE) + 1)]
stan_file <-
stan_file[-(grep('// posterior predictions', stan_file, fixed = TRUE) + 4)]
stan_file[grep('ypred[i, s] =', stan_file, fixed = TRUE)] <-
gsub(
'i, s',
'1:n, s',
stan_file[grep('ypred[i, s] =', stan_file, fixed = TRUE)]
)
stan_file[grep('matrix[n, n_series] ypred;', stan_file, fixed = TRUE)] <-
'array[n, n_series] int ypred;'
# Remove un-needed loops for transformed beta parameters
b_i_indices <- grep('b[i] = ', stan_file, fixed = TRUE)
if (length(b_i_indices > 0)) {
for (x in b_i_indices) {
i_text <- paste0(
as.numeric(sub("for \\(i in ", "", sub("\\:.*", "", stan_file[x - 1]))),
':',
sub(
" ",
"",
sub("\\{", "", sub("\\)", "", sub(".*\\:", "", stan_file[x - 1])))
)
)
stan_file[x] <-
paste0(gsub(
'[i]',
paste0('[', i_text, ']'),
stan_file[x],
fixed = TRUE
))
}
stan_file <- stan_file[-c(b_i_indices - 1, b_i_indices + 1)]
}
# Remove un-needed loop for random effect priors
b_i_indices <- grep('// prior (non-centred) for', stan_file, fixed = TRUE)
if (length(b_i_indices > 0)) {
for (x in b_i_indices) {
x = x + 2
i_text <- paste0(
as.numeric(sub("for \\(i in ", "", sub("\\:.*", "", stan_file[x - 1]))),
':',
sub(
" ",
"",
sub("\\{", "", sub("\\)", "", sub(".*\\:", "", stan_file[x - 1])))
)
)
stan_file[x] <-
paste0(gsub(
'[i]',
paste0('[', i_text, ']'),
stan_file[x],
fixed = TRUE
))
}
stan_file <- stan_file[-c(b_i_indices + 1, b_i_indices + 3)]
}
# Replace any normal(0, 1) with std_normal() for faster computation
stan_file <- readLines(textConnection(stan_file), n = -1)
stan_file <- gsub('normal(0, 1)', 'std_normal()', stan_file, fixed = TRUE)
# Change b to b_raw for any idx normals
if (any(grep('for (i in idx', stan_file, fixed = TRUE))) {
lines_matching <- grep('for (i in idx', stan_file, fixed = TRUE)
for (i in lines_matching) {
stan_file[i] <- gsub('\\bb\\b', 'b_raw', stan_file[i])
}
}
# Final tidying of the Stan model for readability
unlink('base_gam_stan.txt')
stan_file <- readLines(textConnection(stan_file), n = -1)
clean_up <- vector()
for (x in 1:length(stan_file)) {
clean_up[x] <- stan_file[x - 1] == "" & stan_file[x] == ""
}
clean_up[is.na(clean_up)] <- FALSE
stan_file <- stan_file[!clean_up]
#### Modify the Stan data list ####
# Create matrix representing whether an observation was missing or not
y_observed <- matrix(NA, ncol = NCOL(jags_data$y), nrow = NROW(jags_data$y))
for (i in 1:dim(jags_data$y)[1]) {
for (s in 1:dim(jags_data$y)[2]) {
if (is.na(jags_data$y[i, s])) {
y_observed[i, s] = 0
} else {
y_observed[i, s] = 1
}
}
}
# Use -1 for any missing observations so Stan doesn't throw errors due to NAs
y <- jags_data$y
y[is.na(y)] <- -1
# The data list for Stan
stan_data <- jags_data
stan_data$y <- y
stan_data$y_observed <- y_observed
stan_data$X <- t(stan_data$X)
stan_data$total_obs <- NCOL(stan_data$X)
stan_data$num_basis <- NROW(stan_data$X)
if (
any(grepl('// priors for smoothing parameters', stan_file, fixed = TRUE))
) {
if ('L' %in% names(jags_data)) {
stan_data$lambda_links <- jags_data$L
stan_data$L <- NULL
stan_data$n_raw_sp <- NCOL(stan_data$lambda_links)
stan_data$n_sp <- NROW(stan_data$lambda_links)
} else {
stan_data$n_sp <- as.numeric(sub(
'\\) \\{',
'',
sub(
'for \\(i in 1\\:',
'',
jags_file[grep('lambda\\[i\\] ~ ', trimws(jags_file)) - 1]
)
))
}
}
# Add discontiguous index values if required
if (add_idxs) {
names(idx_vals) <- paste0('idx', seq_len(length(idx_vals)))
stan_data <- append(stan_data, idx_vals)
}
# Add parametric prior means and precisions if required
# if('p_taus' %in% names(jags_data)){
# stan_data$p_coefs <- array(jags_data$p_coefs, dim = length(jags_data$p_taus))
# stan_data$p_taus <- array(jags_data$p_taus, dim = length(jags_data$p_taus))
# }
# Add bounds if required
if (!is.null(upper_bounds)) {
stan_data$U <- upper_bounds
}
return(list(
stan_file = stan_file,
model_data = stan_data,
smooths_included = smooths_included
))
}
================================================
FILE: R/add_trend_lines.R
================================================
#' Latent trend model file modifications
#'
#'
#' @noRd
#' @param model_file A template `JAGS` or `Stan` model file to be modified
#' @param stan Logical (convert existing `JAGS` model to a `Stan` model?)
#' @param use_lv Logical (use latent variable trends or not)
#' @param trend_model The type of trend model to be added to the model file
#' @param drift Logical (add drift or not)
#' @return A modified `JAGS` or `Stan` model file
add_trend_lines = function(
model_file,
stan = FALSE,
use_lv,
trend_model,
drift
) {
if (use_lv & trend_model == 'None') {
trend_model <- 'RW'
}
# Add in necessary trend structure
if (stan) {
if (trend_model == 'None') {
model_file <- model_file[
-c(
(grep('// raw basis', model_file) + 3):(grep(
'// raw basis',
model_file
) +
7)
)
]
model_file <- model_file[
-c(
(grep('// priors for latent trend', model_file)):(grep(
'// priors for latent trend',
model_file
) +
2)
)
]
model_file <- model_file[
-c(
(grep('// trend estimates', model_file)):(grep(
'// trend estimates',
model_file
) +
3)
)
]
model_file <- model_file[
-c(
(grepws('trend[2:n', model_file, fixed = T) - 1):(grepws(
'trend[2:n',
model_file,
fixed = T
) +
1)
)
]
model_file[grepws('y[i, s] ~', model_file, fixed = T)] <-
'y[i, s] ~ poisson_log(eta[ytimes[i, s]]);'
model_file[grepws('ypred[i, s] =', model_file, fixed = T)] <-
"ypred[i, s] = poisson_log_rng(eta[ytimes[i, s]]);"
model_file <- model_file[
-c(
(grepws('tau[s] = pow(sigma[s], -2.0);', model_file, fixed = TRUE) -
1):(grepws(
'tau[s] = pow(sigma[s], -2.0);',
model_file,
fixed = TRUE
) +
1)
)
]
model_file <- model_file[
-grepws('vector[n_series] tau', model_file, fixed = T)
]
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'GP') {
hilbert_approx = T
if (hilbert_approx) {
if (use_lv) {
model_file <- model_file[
-c(
(grep('// raw basis', model_file) + 3):(grep(
'// raw basis',
model_file
) +
5)
)
]
model_file <- model_file[
-c(
(grep('// dynamic factor estimates', model_file)):(grep(
'// dynamic factor estimates',
model_file
) +
8)
)
]
model_file[grep('transformed data {', model_file, fixed = TRUE)] <-
paste0(
'transformed data {\n',
'vector[n] times;\n',
'vector[n] times_cent;\n',
'real mean_times;\n',
'real boundary;\n',
'int num_gp_basis;\n',
'num_gp_basis = min(20, n);\n',
'matrix[n, num_gp_basis] gp_phi;\n\n',
'for (t in 1:n){\n',
'times[t] = t;\n',
'}\n\n',
'mean_times = mean(times);\n',
'times_cent = times - mean_times;\n',
'boundary = (5.0/4) * (max(times_cent) - min(times_cent));\n',
'for (m in 1:num_gp_basis){\n',
'gp_phi[,m] = phi_SE(boundary, m, times_cent);\n',
'}\n'
)
model_file[grep('##insert data', model_file) - 1] <-
paste0(
'functions {\n',
'/* Spectral density GP eigenvalues*/\n',
'/* see Riutort-Mayol et al 2023 for details (https://doi.org/10.1007/s11222-022-10167-2)*/\n',
'real lambda_gp(real L, int m) {\n',
'real lam;\n',
'lam = ((m*pi())/(2*L))^2;\n',
'return lam;\n',
'}\n\n',
'/* Spectral density GP eigenfunctions*/\n',
'/* see Riutort-Mayol et al 2023 for details (https://doi.org/10.1007/s11222-022-10167-2)*/\n',
'vector phi_SE(real L, int m, vector x) {\n',
'vector[rows(x)] fi;\n',
'fi = 1/sqrt(L) * sin(m*pi()/(2*L) * (x+L));\n',
'return fi;\n',
'}\n\n',
'/* Spectral density squared exponential Gaussian Process*/\n',
'/* see Riutort-Mayol et al 2023 for details (https://doi.org/10.1007/s11222-022-10167-2)*/\n',
'real spd_SE(real alpha, real rho, real w) {\n',
'real S;\n',
'S = (alpha^2) * sqrt(2*pi()) * rho * exp(-0.5*(rho^2)*(w^2));\n',
'return S;\n',
'}\n}\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
model_file[
grep('// dynamic factor lower triangle', model_file) + 3
] <-
paste0(
'// gp parameters\n',
'vector[n_lv] rho_gp;\n\n',
'// gp coefficient weights\n',
'matrix[num_gp_basis, n_lv] b_gp;\n',
'// smoothing parameters\n'
)
model_file[
grep('vector[total_obs] eta;', model_file, fixed = TRUE) + 1
] <-
paste0(
'\n// gp spectral densities\n',
'matrix[n, n_lv] LV_raw;\n',
'matrix[num_gp_basis, n_lv] diag_SPD;\n',
'matrix[num_gp_basis, n_lv] SPD_beta;\n'
)
model_file[grep('eta = to_vector', model_file) + 1] <-
paste0(
'\n// gp LV estimates',
'\nfor (m in 1:num_gp_basis){\n',
'for (s in 1:n_lv){\n',
'diag_SPD[m, s] = sqrt(spd_SE(0.25, rho_gp[s], sqrt(lambda_gp(boundary, m))));\n',
'}\n}\n',
'SPD_beta = diag_SPD .* b_gp;\n',
'LV_raw = gp_phi * SPD_beta;\n}\n'
)
rho_line <- 'rho_gp ~ inv_gamma(1.499007, 5.670433);\n'
model_file[
grep('// priors for dynamic factor loading', model_file) - 1
] <-
paste0(
'\n// priors for gp parameters\n',
'for (s in 1:n_lv){\n',
'b_gp[1:num_gp_basis, s] ~ normal(0, 1);\n',
'}\n',
rho_line
)
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep('vector[n_lv] penalty;', model_file, fixed = TRUE)] <-
'vector[n_lv] alpha_gp;'
model_file[grep(
'penalty = rep_vector(100.0, n_lv);',
model_file,
fixed = TRUE
)] <-
'alpha_gp = rep_vector(0.25, n_lv);'
model_file <- model_file[
-c(
(grep('// derived latent trends', model_file)):(grep(
'// derived latent trends',
model_file
) +
5)
)
]
model_file[grep(
'LV_raw = gp_phi * SPD_beta;',
model_file,
fixed = TRUE
)] <-
paste0(
'LV_raw = gp_phi * SPD_beta;\n',
'// derived latent trends\n',
'for (i in 1:n){\n',
'for (s in 1:n_series){\n',
'trend[i, s] = dot_product(lv_coefs_raw[s,], LV_raw[i,1:n_lv]);\n',
'}\n}\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
} else {
model_file <- model_file[
-c(
(grep('// raw basis', model_file) + 3):(grep(
'// raw basis',
model_file
) +
5)
)
]
model_file <- model_file[
-c(
(grep('// priors for latent trend', model_file)):(grep(
'// priors for latent trend',
model_file
) +
2)
)
]
model_file <- model_file[
-c(
(grep('// trend estimates', model_file)):(grep(
'// trend estimates',
model_file
) +
3)
)
]
model_file <- model_file[
-c(
(grep('trend[2:n', model_file, fixed = T) - 1):(grep(
'trend[2:n',
model_file,
fixed = T
) +
1)
)
]
model_file <- model_file[
-c(
(grep('tau[s] = pow(sigma[s], -2.0);', model_file, fixed = TRUE) -
1):(grep(
'tau[s] = pow(sigma[s], -2.0);',
model_file,
fixed = TRUE
) +
1)
)
]
model_file <- model_file[
-grep('vector[n_series] tau', model_file, fixed = T)
]
model_file[grep('##insert data', model_file) + 1] <-
paste0(
'transformed data {\n',
'vector[n] times;\n',
'vector[n] times_cent;\n',
'real mean_times;\n',
'real boundary;\n',
'int num_gp_basis;\n',
'num_gp_basis = min(20, n);\n',
'matrix[n, num_gp_basis] gp_phi;\n\n',
'for (t in 1:n){\n',
'times[t] = t;\n',
'}\n\n',
'mean_times = mean(times);\n',
'times_cent = times - mean_times;\n',
'boundary = (5.0/4) * (max(times_cent) - min(times_cent));\n',
'for (m in 1:num_gp_basis){\n',
'gp_phi[,m] = phi_SE(boundary, m, times_cent);\n',
'}\n}\n\n',
'parameters {'
)
model_file[grep('##insert data', model_file) - 1] <-
paste0(
'functions {\n',
'/* Spectral density GP eigenvalues*/\n',
'/* see Riutort-Mayol et al 2023 for details (https://doi.org/10.1007/s11222-022-10167-2)*/\n',
'real lambda_gp(real L, int m) {\n',
'real lam;\n',
'lam = ((m*pi())/(2*L))^2;\n',
'return lam;\n',
'}\n\n',
'/* Spectral density GP eigenfunctions*/\n',
'/* see Riutort-Mayol et al 2023 for details (https://doi.org/10.1007/s11222-022-10167-2)*/\n',
'vector phi_SE(real L, int m, vector x) {\n',
'vector[rows(x)] fi;\n',
'fi = 1/sqrt(L) * sin(m*pi()/(2*L) * (x+L));\n',
'return fi;\n',
'}\n\n',
'/* Spectral density squared exponential Gaussian Process*/\n',
'/* see Riutort-Mayol et al 2023 for details (https://doi.org/10.1007/s11222-022-10167-2)*/\n',
'real spd_SE(real alpha, real rho, real w) {\n',
'real S;\n',
'S = (alpha^2) * sqrt(2*pi()) * rho * exp(-0.5*(rho^2)*(w^2));\n',
'return S;\n',
'}\n}\n'
)
model_file[grep('// latent trends', model_file) + 2] <-
paste0(
'// gp parameters\n',
'vector[n_series] alpha_gp;\n',
'vector[n_series] rho_gp;\n\n',
'// gp coefficient weights\n',
'matrix[num_gp_basis, n_series] b_gp;\n'
)
model_file <- model_file[
-c(
grep('// latent trends', model_file):(grep(
'// latent trends',
model_file
) +
1)
)
]
model_file[
grep('vector[total_obs] eta;', model_file, fixed = TRUE) + 1
] <-
paste0(
'\n// gp spectral densities\n',
'matrix[n, n_series] trend;\n',
'matrix[num_gp_basis, n_series] diag_SPD;\n',
'matrix[num_gp_basis, n_series] SPD_beta;\n'
)
model_file[grep('eta = to_vector', model_file) + 1] <-
paste0(
'\n// gp trend estimates',
'\nfor (m in 1:num_gp_basis){\n',
'for (s in 1:n_series){\n',
'diag_SPD[m, s] = sqrt(spd_SE(alpha_gp[s], rho_gp[s], sqrt(lambda_gp(boundary, m))));\n',
'}\n}\n',
'SPD_beta = diag_SPD .* b_gp;\n',
'trend = gp_phi * SPD_beta;\n}\n'
)
rho_line <- 'rho_gp ~ inv_gamma(1.499007, 5.670433);\n'
alpha_line <- 'alpha_gp ~ normal(0, 0.5);\n'
model_file[grep('// likelihood functions', model_file) - 1] <-
paste0(
'\n// priors for gp parameters\n',
'for (s in 1:n_series){\n',
'b_gp[1:num_gp_basis, s] ~ normal(0, 1);\n',
'}\n',
alpha_line,
rho_line
)
model_file <- readLines(textConnection(model_file), n = -1)
}
# If not Hilbert approx
} else {
model_file <- model_file[
-c(
(grep('// raw basis', model_file) + 3):(grep(
'// raw basis',
model_file
) +
5)
)
]
model_file <- model_file[
-c(
(grep('// priors for latent trend', model_file)):(grep(
'// priors for latent trend',
model_file
) +
2)
)
]
model_file <- model_file[
-c(
(grep('// trend estimates', model_file)):(grep(
'// trend estimates',
model_file
) +
3)
)
]
model_file <- model_file[
-c(
(grep('trend[2:n', model_file, fixed = T) - 1):(grep(
'trend[2:n',
model_file,
fixed = T
) +
1)
)
]
model_file <- model_file[
-c(
(grep('tau[s] = pow(sigma[s], -2.0);', model_file, fixed = TRUE) -
1):(grep(
'tau[s] = pow(sigma[s], -2.0);',
model_file,
fixed = TRUE
) +
1)
)
]
model_file <- model_file[
-grep('vector[n_series] tau', model_file, fixed = T)
]
model_file[grep('##insert data', model_file) + 1] <-
paste0(
'transformed data {\n',
'real times[n];\n',
'for (t in 1:n)\n',
'times[t] = t;\n',
'}\n\n',
'parameters {'
)
model_file[grep('// latent trends', model_file) + 1] <-
paste0(
'vector[n_series] alpha_gp;\n',
'vector[n_series] rho_gp;\n',
'vector[n] gp_std;\n'
)
model_file[grep('// basis coefficients', model_file) + 2] <-
paste0(
'\n\n// gp estimates\n',
'matrix[n, n_series] trend;\n',
'for (s in 1:n_series) {\n',
'// gp covariance matrices\n',
'matrix[n, n] cov;\n',
'matrix[n, n] L_cov;\n',
'cov = cov_exp_quad(times, alpha_gp[s], rho_gp[s]) + diag_matrix(rep_vector(1e-10, n));\n',
'L_cov = cholesky_decompose(cov);\n',
'// non-centred parameterisation\n',
'trend[1:n, s] = to_vector(L_cov * gp_std);\n',
'}\n'
)
model_file[
grep('// priors for smoothing parameters', model_file) + 2
] <-
paste0(
'\n// priors for gp parameters\n',
'to_vector(gp_std) ~ normal(0, 1);\n',
'alpha_gp ~ normal(0, 0.5);\n',
'rho_gp ~ inv_gamma(1.499007, 5.670433);\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
}
}
if (trend_model == 'RW') {
if (drift) {
if (use_lv) {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent factor drift terms\nvector[n_lv] drift;\n'
)
model_file[grep('LV_raw[1, j] ~ ', model_file, fixed = T)] <-
"LV_raw[1, j] ~ normal(0, 0.1);"
model_file[grep('// dynamic factor estimates', model_file) + 6] <-
paste0(
'LV_raw[2:n, j] ~ normal(drift[j]*(n - 1) + LV_raw[1:(n - 1), j], 0.1);'
)
} else {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent trend drift terms\nvector[n_series] drift;\n'
)
model_file[grep('trend[1, s] ~ ', model_file, fixed = T)] <-
"trend[1, s] ~ normal(0, sigma[s]);"
model_file[grep('// trend estimates', model_file) + 6] <-
paste0(
'trend[2:n, s] ~ normal(drift[s]*(n - 1) + trend[1:(n - 1), s], sigma[s]);'
)
}
model_file[grep('model \\{', model_file) + 2] <-
paste0('\n// priors for trend parameters\ndrift ~ normal(0, 0.1);\n')
model_file <- readLines(textConnection(model_file), n = -1)
}
}
if (trend_model == 'CAR1') {
if (use_lv) {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent factor AR1 terms\nvector[n_lv] ar1;'
)
model_file[grep('// dynamic factor estimates', model_file) + 6] <-
paste0('LV_raw[2:n, j] ~ normal(ar1[j] * LV_raw[1:(n - 1), j], 0.1);')
model_file[grep('model \\{', model_file) + 2] <-
paste0('\n// priors for AR parameters\nar1 ~ std_normal();\n')
} else {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent trend AR1 terms\nvector[n_series] ar1;'
)
model_file[grep('// trend estimates', model_file) + 6] <-
paste0(
'trend[2:n, s] ~ normal(ar1[s] * trend[1:(n - 1), s], sigma[s]);'
)
model_file[grep('model \\{', model_file) + 2] <-
paste0('\n// priors for AR parameters\nar1 ~ std_normal();\n')
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR1') {
if (drift) {
if (use_lv) {
model_file[grepws('// raw basis', model_file) + 1] <-
paste0(
c(
'row_vector[num_basis] b_raw;\n\n// latent factor AR1 terms\nvector[n_lv] ar1;\n\n'
),
'// latent factor drift terms\nvector[n_lv] drift;'
)
model_file[grepws('LV_raw[1, j] ~ ', model_file, fixed = T)] <-
"LV_raw[1, j] ~ normal(0, 0.1);"
model_file[grepws('// dynamic factor estimates', model_file) + 6] <-
paste0(
'LV_raw[2:n, j] ~ normal(drift[j]*(n - 1) + ar1[j] * LV_raw[1:(n - 1), j], 0.1);'
)
} else {
model_file[grepws('// raw basis', model_file) + 1] <-
paste0(
c(
'row_vector[num_basis] b_raw;\n\n// latent trend AR1 terms\nvector[n_series] ar1;\n\n'
),
'// latent trend drift terms\nvector[n_series] drift;'
)
model_file[grepws('trend[1, s] ~ ', model_file, fixed = T)] <-
"trend[1, s] ~ normal(0, sigma[s]);"
model_file[grep('// trend estimates', model_file) + 6] <-
paste0(
'trend[2:n, s] ~ normal(drift[s]*(n - 1) + ar1[s] * trend[1:(n - 1), s], sigma[s]);'
)
}
model_file[grep('model \\{', model_file) + 2] <-
paste0(
'\n// priors for AR parameters\nar1 ~ std_normal();\ndrift ~ std_normal();\n'
)
} else {
if (use_lv) {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent factor AR1 terms\nvector[n_lv] ar1;'
)
model_file[grep('// dynamic factor estimates', model_file) + 6] <-
paste0(
'LV_raw[2:n, j] ~ normal(ar1[j] * LV_raw[1:(n - 1), j], 0.1);'
)
model_file[grep('model \\{', model_file) + 2] <-
paste0('\n// priors for AR parameters\nar1 ~ std_normal();\n')
} else {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent trend AR1 terms\nvector[n_series] ar1;'
)
model_file[grep('// trend estimates', model_file) + 6] <-
paste0(
'trend[2:n, s] ~ normal(ar1[s] * trend[1:(n - 1), s], sigma[s]);'
)
model_file[grep('model \\{', model_file) + 2] <-
paste0('\n// priors for AR parameters\nar1 ~ std_normal();\n')
}
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR2') {
if (drift) {
if (use_lv) {
model_file[grepws('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent factor AR1 terms\nvector[n_lv] ar1;\n\n',
'// latent factor AR2 terms\nvector[n_lv] ar2;\n\n',
'// latent factor drift terms\nvector[n_lv] drift;'
)
model_file[grepws('LV_raw[1, j] ~ ', model_file, fixed = T)] <-
"LV_raw[1, j] ~ normal(0, 0.1);"
model_file <- model_file[
-(grep('// dynamic factor estimates', model_file) + 5:7)
]
model_file[grep('// dynamic factor estimates', model_file) + 5] <-
paste0(
'for (j in 1:n_lv) {\n',
'LV_raw[2, j] ~ normal(drift[j] + LV_raw[1, j] * ar1[j], 0.1);\n',
'}\n\n',
'for (i in 3:n) {\n',
'for (j in 1:n_lv) {\n',
'LV_raw[i, j] ~ normal(drift[j]*(i - 1) + ar1[j] * LV_raw[i - 1, j] + ar2[j] * LV_raw[i - 2, j], 0.1);\n',
'}\n}\n'
)
} else {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent trend AR1 terms\nvector[n_series] ar1;\n\n',
'// latent trend AR2 terms\nvector[n_series] ar2;\n\n',
'// latent trend drift terms\nvector[n_series] drift;'
)
model_file[grepws('trend[1, s] ~ ', model_file, fixed = T)] <-
"trend[1, s] ~ normal(0, sigma[s]);"
model_file <- model_file[
-(grep('// trend estimates', model_file) + 5:7)
]
model_file[grep('// trend estimates', model_file) + 5] <-
paste0(
'for (s in 1:n_series) {\n',
'trend[2, s] ~ normal(drift[s] + trend[1, s] * ar1[s], sigma[s]);\n',
'}\n\n',
'for (i in 3:n) {\n',
'for (s in 1:n_series) {\n',
'trend[i, s] ~ normal(drift[s]*(i - 1) + ar1[s] * trend[i - 1, s] + ar2[s] * trend[i - 2, s], sigma[s]);\n',
'}\n}\n'
)
}
model_file[grep('model \\{', model_file) + 2] <-
paste0(
'\n// priors for AR parameters\nar1 ~ std_normal();\nar2 ~ std_normal();\ndrift ~ std_normal();\n'
)
} else {
if (use_lv) {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent factor AR1 terms\nvector[n_lv] ar1;\n\n',
'// latent factor AR2 terms\nvector[n_lv] ar2;'
)
model_file[grep('// dynamic factor estimates', model_file) + 2] <-
paste0('LV_raw[1, j] ~ normal(0, 0.1);')
model_file <- model_file[
-(grep('// dynamic factor estimates', model_file) + 5:7)
]
model_file[grep('// dynamic factor estimates', model_file) + 5] <-
paste0(
'for (j in 1:n_lv) {\n',
'LV_raw[2, j] ~ normal(LV_raw[1, j] * ar1[j], 0.1);\n',
'}\n\n',
'for (i in 3:n) {\n',
'for (j in 1:n_lv) {\n',
'LV_raw[i, j] ~ normal(ar1[j] * LV_raw[i - 1, j] + ar2[j] * LV_raw[i - 2, j], 0.1);\n',
'}\n}\n'
)
} else {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent trend AR1 terms\nvector[n_series] ar1;\n\n',
'// latent trend AR2 terms\nvector[n_series] ar2;'
)
model_file[grep('// trend estimates', model_file) + 2] <-
paste0('trend[1, s] ~ normal(0, sigma[s]);')
model_file <- model_file[
-(grep('// trend estimates', model_file) + 5:7)
]
model_file[grep('// trend estimates', model_file) + 5] <-
paste0(
'for (s in 1:n_series) {\n',
'trend[2, s] ~ normal(trend[1, s] * ar1[s], sigma[s]);\n',
'}\n\n',
'for (i in 3:n) {\n',
'for (s in 1:n_series) {\n',
'trend[i, s] ~ normal(ar1[s] * trend[i - 1, s] + ar2[s] * trend[i - 2, s], sigma[s]);\n',
'}\n}\n'
)
}
model_file[grep('model \\{', model_file) + 2] <-
paste0(
'\n// priors for AR parameters\nar1 ~ std_normal();\nar2 ~ std_normal();\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR3') {
if (drift) {
if (use_lv) {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent factor AR1 terms\nvector[n_lv] ar1;\n\n',
'// latent factor AR2 terms\nvector[n_lv] ar2;\n\n',
'// latent factor AR3 terms\nvector[n_lv] ar3;\n\n',
'// latent factor drift terms\nvector[n_lv] drift;'
)
model_file[grep('LV_raw[1, s] ~ ', model_file, fixed = T)] <-
"LV_raw[1, s] ~ normal(0, 0.1);"
model_file <- model_file[
-(grep('// dynamic factor estimates', model_file) + 5:7)
]
model_file[grep('// dynamic factor estimates', model_file) + 5] <-
paste0(
'for (j in 1:n_lv) {\n',
'LV_raw[2, j] ~ normal(drift[j] + LV_raw[1, j] * ar1[j], 0.1);\n',
'}\n\n',
'for (j in 1:n_lv) {\n',
'LV_raw[3, j] ~ normal(drift[j]*2 + LV_raw[2, j] * ar1[j] + LV_raw[1, j] * ar2[j], 0.1);\n',
'}\n\n',
'for (i in 4:n) {\n',
'for (j in 1:n_lv) {\n',
'LV_raw[i, j] ~ normal(drift[j]*(i - 1) + ar1[j] * LV_raw[i - 1, j] + ar2[j] * LV_raw[i - 2, j] + ar3[j] * LV_raw[i - 3, j], 0.1);\n',
'}\n}\n'
)
} else {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent trend AR1 terms\nvector[n_series] ar1;\n\n',
'// latent trend AR2 terms\nvector[n_series] ar2;\n\n',
'// latent trend AR3 terms\nvector[n_series] ar3;\n\n',
'// latent trend drift terms\nvector[n_series] drift;'
)
model_file[grep('trend[1, s] ~ ', model_file, fixed = T)] <-
"trend[1, s] ~ normal(0, sigma[s]);"
model_file <- model_file[
-(grep('// trend estimates', model_file) + 5:7)
]
model_file[grep('// trend estimates', model_file) + 5] <-
paste0(
'for (s in 1:n_series) {\n',
'trend[2, s] ~ normal(drift[s] + trend[1, s] * ar1[s], sigma[s]);\n',
'}\n\n',
'for (s in 1:n_series) {\n',
'trend[3, s] ~ normal(drift[s]*2 + trend[2, s] * ar1[s] + trend[1, s] * ar2[s], sigma[s]);\n',
'}\n\n',
'for (i in 4:n) {\n',
'for (s in 1:n_series) {\n',
'trend[i, s] ~ normal(drift[s]*(i - 1) + ar1[s] * trend[i - 1, s] + ar2[s] * trend[i - 2, s] + ar3[s] * trend[i - 3, s], sigma[s]);\n',
'}\n}\n'
)
}
model_file[grep('model \\{', model_file) + 2] <-
paste0(
'\n// priors for AR parameters\nar1 ~ std_normal();\nar2 ~ std_normal();\nar3 ~ std_normal();\n',
'drift ~ std_normal();\n'
)
} else {
if (use_lv) {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent factor AR1 terms\nvector[n_lv] ar1;\n\n',
'// latent factor AR2 terms\nvector[n_lv] ar2;\n\n',
'// latent factor AR3 terms\nvector[n_lv] ar3;'
)
model_file[grep('// dynamic factor estimates', model_file) + 2] <-
paste0('LV_raw[1, j] ~ normal(0, 0.1);')
model_file <- model_file[
-(grep('// dynamic factor estimates', model_file) + 5:7)
]
model_file[grep('// dynamic factor estimates', model_file) + 5] <-
paste0(
'for (j in 1:n_lv) {\n',
'LV_raw[2, j] ~ normal(LV_raw[1, j] * ar1[j], 0.1);\n',
'}\n\n',
'for (j in 1:n_lv) {\n',
'LV_raw[3, j] ~ normal(LV_raw[2, j] * ar1[j] + LV_raw[1, j] * ar2[j], 0.1);\n',
'}\n\n',
'for (i in 4:n) {\n',
'for (j in 1:n_lv) {\n',
'LV_raw[i, j] ~ normal(ar1[j] * LV_raw[i - 1, j] + ar2[j] * LV_raw[i - 2, j] + ar3[j] * LV_raw[i - 3, j], 0.1);\n',
'}\n}\n'
)
} else {
model_file[grep('// raw basis', model_file) + 1] <-
paste0(
'row_vector[num_basis] b_raw;\n\n// latent trend AR1 terms\nvector[n_series] ar1;\n\n',
'// latent trend AR2 terms\nvector[n_series] ar2;\n\n',
'// latent trend AR3 terms\nvector[n_series] ar3;'
)
model_file[grep('// trend estimates', model_file) + 2] <-
paste0('trend[1, s] ~ normal(0, sigma[s]);')
model_file <- model_file[
-(grep('// trend estimates', model_file) + 5:7)
]
model_file[grep('// trend estimates', model_file) + 5] <-
paste0(
'for (s in 1:n_series) {\n',
'trend[2, s] ~ normal(trend[1, s] * ar1[s], sigma[s]);\n',
'}\n\n',
'for (s in 1:n_series) {\n',
'trend[3, s] ~ normal(trend[2, s] * ar1[s] + trend[1, s] * ar2[s], sigma[s]);\n',
'}\n\n',
'for (i in 4:n) {\n',
'for (s in 1:n_series) {\n',
'trend[i, s] ~ normal(ar1[s] * trend[i - 1, s] + ar2[s] * trend[i - 2, s] + ar3[s] * trend[i - 3, s], sigma[s]);\n',
'}\n}\n'
)
}
model_file[grep('model \\{', model_file) + 2] <-
paste0(
'\n// priors for AR parameters\nar1 ~ std_normal();\nar2 ~ std_normal();\nar3 ~ std_normal();\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
} else {
# Modify the JAGS model
if (trend_model == 'None') {
model_file[grep(
'mus\\[i, s\\] <- exp',
model_file
)] <- 'mus[i, s] <- exp(eta[ytimes[i, s]])'
model_file <- model_file[
-c(
grep('## trend estimates', model_file):(grep(
'## trend estimates',
model_file
) +
27)
)
]
}
if (use_lv) {
if (trend_model == 'RW') {
model_file <- model_file[
-c(
(grep('## latent factors evolve', model_file) + 6):(grep(
'## latent factors evolve',
model_file
) +
19)
)
]
if (drift) {
model_file[grep('## latent factors evolve', model_file) + 5] <-
'\nfor (i in 2:n) {\nfor (j in 1:n_lv){\nLV_raw[i, j] ~ dnorm(drift[j]*(n - 1) + LV_raw[i - 1, j], penalty[j])\n}\n}\n'
} else {
model_file[grep('## latent factors evolve', model_file) + 5] <-
'\nfor (i in 2:n) {\nfor (j in 1:n_lv){\nLV_raw[i, j] ~ dnorm(LV_raw[i - 1, j], penalty[j])\n}\n}\n'
model_file <- model_file[-grep('drift\\[s\\] ~', model_file)]
}
model_file <- readLines(textConnection(model_file), n = -1)
model_file <- model_file[
-c(
(grep('## AR components', model_file)):(grep(
'## AR components',
model_file
) +
5)
)
]
}
if (trend_model == 'AR1') {
model_file <- model_file[
-c(
(grep('## latent factors evolve', model_file) + 6):(grep(
'## latent factors evolve',
model_file
) +
12)
)
]
model_file[grep('## latent factors evolve', model_file) + 7] <-
'for (i in 2:n) {'
model_file <- model_file[
-c(
(grep('## latent factors evolve', model_file) + 9):(grep(
'## latent factors evolve',
model_file
) +
10)
)
]
if (drift) {} else {
model_file[grep('## latent factors evolve', model_file) + 9] <-
'LV_raw[i, j] ~ dnorm(ar1[j]*LV_raw[i - 1, j], penalty[j])\n}'
model_file <- model_file[-grep('drift\\[s\\] ~', model_file)]
}
model_file <- readLines(textConnection(model_file), n = -1)
model_file <- model_file[-grep('ar2\\[s\\] ~', model_file)]
model_file <- model_file[-grep('ar3\\[s\\] ~', model_file)]
}
if (trend_model == 'AR2') {
model_file <- model_file[
-c(
(grep('## latent factors evolve', model_file) + 10):(grep(
'## latent factors evolve',
model_file
) +
12)
)
]
model_file[grep('## latent factors evolve', model_file) + 11] <-
'for (i in 3:n) {'
if (drift) {
model_file[grep('## latent factors evolve', model_file) + 14] <-
'ar2[j]*LV_raw[i - 2, j], penalty[j])'
} else {
model_file[grep('## latent factors evolve', model_file) + 7] <-
'LV_raw[2, j] ~ dnorm(ar1[j]*LV_raw[1, j], penalty[j])'
model_file[grep('## latent factors evolve', model_file) + 13] <-
'LV_raw[i, j] ~ dnorm(ar1[j]*LV_raw[i - 1, j] +'
model_file[grep('## latent factors evolve', model_file) + 14] <-
'ar2[j]*LV_raw[i - 2, j], penalty[j])'
model_file <- model_file[-grep('drift\\[s\\] ~', model_file)]
}
model_file <- readLines(textConnection(model_file), n = -1)
model_file <- model_file[-grep('ar3\\[s\\] ~', model_file)]
}
if (trend_model == 'AR3') {
if (drift) {} else {
model_file[grep('## latent factors evolve', model_file) + 7] <-
'LV_raw[2, j] ~ dnorm(ar1[j]*LV_raw[1, j], penalty[j])'
model_file[grep('## latent factors evolve', model_file) + 11] <-
'LV_raw[3, j] ~ dnorm(ar1[j]*LV_raw[2, j] + ar2[j]*LV_raw[1, j], penalty[j])'
model_file[grep('## latent factors evolve', model_file) + 16] <-
'LV_raw[i, j] ~ dnorm(ar1[j]*LV_raw[i - 1, j] +'
model_file <- model_file[-grep('drift\\[s\\] ~', model_file)]
}
model_file <- readLines(textConnection(model_file), n = -1)
}
}
if (!use_lv) {
if (trend_model == 'RW') {
model_file <- model_file[
-c(
(grep('## trend estimates', model_file) + 4):(grep(
'## trend estimates',
model_file
) +
17)
)
]
if (drift) {
model_file[grep('## trend estimates', model_file) + 2] <-
"trend[1, s] ~ dnorm(drift[s], tau[s])"
model_file[grep('## trend estimates', model_file) + 4] <-
'\nfor (i in 2:n) {\nfor (s in 1:n_series){\ntrend[i, s] ~ dnorm(drift[s]*(i - 1) + trend[i - 1, s], tau[s])\n}\n}\n'
} else {
model_file[grep('## trend estimates', model_file) + 4] <-
'\nfor (i in 2:n) {\nfor (s in 1:n_series){\ntrend[i, s] ~ dnorm(trend[i - 1, s], tau[s])\n}\n}\n'
model_file <- model_file[-grep('drift\\[s\\] ~', model_file)]
}
model_file <- readLines(textConnection(model_file), n = -1)
model_file <- model_file[-grep('ar1\\[s\\] ~', model_file)]
model_file <- model_file[-grep('ar2\\[s\\] ~', model_file)]
model_file <- model_file[-grep('ar3\\[s\\] ~', model_file)]
}
if (trend_model == 'AR1') {
model_file <- model_file[
-c(
(grep('## trend estimates', model_file) + 4):(grep(
'## trend estimates',
model_file
) +
17)
)
]
if (drift) {
model_file[grep('## trend estimates', model_file) + 2] <-
"trend[1, s] ~ dnorm(drift[s], tau[s])"
model_file[grep('## trend estimates', model_file) + 4] <-
'\nfor (i in 2:n) {\nfor (s in 1:n_series){\ntrend[i, s] ~ dnorm(drift[s]*(i - 1) + ar1[s]*trend[i - 1, s], tau[s])\n}\n}\n'
} else {
model_file[grep('## trend estimates', model_file) + 4] <-
'\nfor (i in 2:n) {\nfor (s in 1:n_series){\ntrend[i, s] ~ dnorm(ar1[s]*trend[i - 1, s], tau[s])\n}\n}\n'
model_file <- model_file[-grep('drift\\[s\\] ~', model_file)]
}
model_file <- readLines(textConnection(model_file), n = -1)
model_file <- model_file[-grep('ar2\\[s\\] ~', model_file)]
model_file <- model_file[-grep('ar3\\[s\\] ~', model_file)]
}
if (trend_model == 'AR2') {
model_file <- model_file[
-c(
(grep('## trend estimates', model_file) + 9):(grep(
'## trend estimates',
model_file
) +
17)
)
]
if (drift) {
model_file[grep('## trend estimates', model_file) + 2] <-
"trend[1, s] ~ dnorm(drift[s], tau[s])"
model_file[grep('## trend estimates', model_file) + 9] <-
'\nfor (i in 3:n) {\nfor (s in 1:n_series){\ntrend[i, s] ~ dnorm(drift[s]*(i - 1) + ar1[s]*trend[i - 1, s] + ar2[s]*trend[i - 2, s], tau[s])\n}\n}\n'
} else {
model_file[grep('## trend estimates', model_file) + 6] <-
'trend[2, s] ~ dnorm(ar1[s]*trend[1, s], tau[s])'
model_file[grep('## trend estimates', model_file) + 9] <-
'\nfor (i in 3:n) {\nfor (s in 1:n_series){\ntrend[i, s] ~ dnorm(ar1[s]*trend[i - 1, s] + ar2[s]*trend[i - 2, s], tau[s])\n}\n}\n'
model_file <- model_file[-grep('drift\\[s\\] ~', model_file)]
}
model_file <- readLines(textConnection(model_file), n = -1)
model_file <- model_file[-grep('ar3\\[s\\] ~', model_file)]
}
if (trend_model == 'AR3') {
if (drift) {
model_file[grep('## trend estimates', model_file) + 2] <-
"trend[1, s] ~ dnorm(drift[s], tau[s])"
} else {
model_file[grep('## trend estimates', model_file) + 6] <-
'trend[2, s] ~ dnorm(ar1[s]*trend[1, s], tau[s])'
model_file[grep('## trend estimates', model_file) + 10] <-
'trend[3, s] ~ dnorm(ar1[s]*trend[2, s] + ar2[s]*trend[1, s], tau[s])'
model_file[grep('## trend estimates', model_file) + 15] <-
'trend[i, s] ~ dnorm(ar1[s]*trend[i - 1, s] + ar2[s]*trend[i - 2, s] + ar3[s]*trend[i - 3, s], tau[s])'
model_file <- model_file[-grep('drift\\[s\\] ~', model_file)]
}
model_file <- readLines(textConnection(model_file), n = -1)
}
}
}
return(model_file)
}
================================================
FILE: R/add_tweedie_lines.R
================================================
#' Tweedie JAGS modifications
#'
#'
#' @param model_file A template `JAGS` model file to be modified
#' @param upper_bounds Optional upper bounds for the truncated observation likelihood
#' @return A modified `JAGS` model file
#' @noRd
add_tweedie_lines = function(model_file, upper_bounds) {
rate_begin <- grep('rate\\[i, s\\] <- ', model_file)
rate_end <- rate_begin + 1
model_file <- model_file[-c(rate_begin:rate_end)]
odis_begin <- grep('phi\\[s\\] <- ', model_file) - 4
odis_end <- odis_begin + 7
model_file <- model_file[-c(odis_begin:odis_end)]
if (missing(upper_bounds)) {
model_file[grep(
'y\\[i, s\\] ~',
model_file
)] <- ' y[i, s] ~ dpois(linpred[i, s])\n linpred[i, s] ~'
model_file[grep(
'ypred\\[i, s\\] ~',
model_file
)] <- ' ypred[i, s] ~ dpois(linpred[i, s])'
} else {
model_file[grep(
'y\\[i, s\\] ~',
model_file
)] <- ' y[i, s] ~ dpois(linpred[i, s])T(, upper_bound[s])\n linpred[i, s] ~'
model_file[grep(
'ypred\\[i, s\\] ~',
model_file
)] <- ' ypred[i, s] ~ dpois(linpred[i, s])T(, upper_bound[s])'
}
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'linpred\\[i, s\\] ~',
model_file
)] <- ' linpred[i, s] ~ dgamma(shape[i, s, y_ind[i, s]], rate[i, s])\n twlambda[i, s] <-'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'twlambda\\[i, s\\] <-',
model_file
)] <- ' twlambda[i, s] <- pow(mus[i, s], 2 - p) / (phi[s] * (2 - p))\n N_pois[i, s] ~'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'N_pois\\[i, s\\] ~',
model_file
)] <- ' N_pois[i, s] ~ dpois(twlambda[i, s])T(1,)\n shape[i, s, 1] <-'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'shape\\[i, s, 1\\] <-',
model_file
)] <- ' shape[i, s, 1] <- N_pois[i, s] * ((2 - p) / (p - 1))\n shape[i, s, 2] <-'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'shape\\[i, s, 2\\] <-',
model_file
)] <- ' shape[i, s, 2] <- 1\n rate[i, s] <-'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'rate\\[i, s\\] <-',
model_file
)] <- ' rate[i, s] <- 1 / (phi[s] * (p - 1) * pow(mus[i, s], p - 1))\n pois_draw[i, s] ~'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'pois_draw\\[i, s\\] ~',
model_file
)] <- ' pois_draw[i, s] ~ dpois(mus[i, s])\n is_zero[i, s] <-'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'is_zero\\[i, s\\] <-',
model_file
)] <- ' is_zero[i, s] <- equals(pois_draw[i, s], 0)\n y_ind[i, s] <-'
model_file <- readLines(textConnection(model_file), n = -1)
model_file[grep(
'y_ind\\[i, s\\] <-',
model_file
)] <- ' y_ind[i, s] <- is_zero[i, s] + 1'
model_file <- readLines(textConnection(model_file), n = -1)
yind_begin <- grep('y_ind\\[i, s\\] <-', model_file)
prior_line <- yind_begin + 2
model_file[
prior_line
] <- '}\n\n## Tweedie power and overdispersion parameters\np <- 1.5\nfor (s in 1:n_series) {\n phi_raw[s] ~ dnorm(0, 2)T(-3.5, 3.5);\n phi[s] <- exp(phi_raw[s])\n}'
model_file <- readLines(textConnection(model_file), n = -1)
return(model_file)
}
================================================
FILE: R/all_neon_tick_data.R
================================================
#' NEON Amblyomma and Ixodes tick abundance survey data
#'
#' A dataset containing timeseries of Amblyomma americanum and Ixodes scapularis nymph abundances at NEON sites
#'
#' @format A tibble/dataframe containing covariate information alongside the main fields of:
#' \describe{
#' \item{Year}{Year of sampling}
#' \item{epiWeek}{Epidemiological week of sampling}
#' \item{plot_ID}{NEON plot ID for survey location}
#' \item{siteID}{NEON site ID for survey location}
#' \item{amblyomma_americanum}{Counts of A. americanum nymphs}
#' \item{ixodes_scapularis}{Counts of I. scapularis nymphs}
#' }
#' @source \url{https://www.neonscience.org/data}
"all_neon_tick_data"
================================================
FILE: R/as.data.frame.mvgam.R
================================================
#' @title Extract posterior draws from fitted \pkg{mvgam} objects
#'
#' @name mvgam_draws
#'
#' @description
#' Extract posterior draws in conventional formats as data.frames, matrices,
#' or arrays.
#'
#' @param x \code{list} object of class `mvgam`
#'
#' @param variable A character specifying which parameters to extract. Can
#' either be one of the following options:
#' \itemize{
#' \item `obs_params` (other parameters specific to the observation model,
#' such as overdispersions for negative binomial models or observation error
#' SD for gaussian / student-t models)
#' \item `betas` (beta coefficients from the GAM observation model linear
#' predictor; default)
#' \item `smooth_params` (smoothing parameters from the GAM observation model)
#' \item `linpreds` (estimated linear predictors on whatever link scale was
#' used in the model)
#' \item `trend_params` (parameters governing the trend dynamics, such as AR
#' parameters, trend SD parameters or Gaussian Process parameters)
#' \item `trend_betas` (beta coefficients from the GAM latent process model
#' linear predictor; only available if a `trend_formula` was supplied in the
#' original model)
#' \item `trend_smooth_params` (process model GAM smoothing parameters; only
#' available if a `trend_formula` was supplied in the original model)
#' \item `trend_linpreds` (process model linear predictors on the identity
#' scale; only available if a `trend_formula` was supplied in the original
#' model)
#' }
#' OR can be a character vector providing the variables to extract.
#'
#' @param regex Logical. If not using one of the prespecified options for
#' extractions, should `variable` be treated as a (vector of) regular
#' expressions? Any variable in `x` matching at least one of the regular
#' expressions will be selected. Defaults to `FALSE`.
#'
#' @param use_alias Logical. If more informative names for parameters are
#' available (i.e. for beta coefficients `b` or for smoothing parameters `rho`),
#' replace the uninformative names with the more informative alias. Defaults to
#' `TRUE`.
#'
#' @param inc_warmup Should warmup draws be included? Defaults to \code{FALSE}.
#'
#' @param row.names Ignored
#'
#' @param optional Ignored
#'
#' @param ... Ignored
#'
#' @return A `data.frame`, `matrix`, or `array` containing the posterior draws.
#'
#' @author Nicholas J Clark
#'
#' @examples
#' \dontrun{
#' sim <- sim_mvgam(family = Gamma())
#'
#' mod1 <- mvgam(
#' y ~ s(season, bs = 'cc'),
#' trend_model = AR(),
#' data = sim$data_train,
#' family = Gamma(),
#' chains = 2,
#' silent = 2
#' )
#'
#' beta_draws_df <- as.data.frame(mod1, variable = 'betas')
#' head(beta_draws_df)
#' str(beta_draws_df)
#'
#' beta_draws_mat <- as.matrix(mod1, variable = 'betas')
#' head(beta_draws_mat)
#' str(beta_draws_mat)
#'
#' shape_pars <- as.matrix(mod1, variable = 'shape', regex = TRUE)
#' head(shape_pars)
#' }
NULL
#'@rdname mvgam_draws
#'@export
as.data.frame.mvgam = function(
x,
row.names = NULL,
optional = TRUE,
variable = 'betas',
use_alias = TRUE,
regex = FALSE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
post <- as.data.frame(dummy, variable = extract_pars$to_extract)
# Rename if needed
if (use_alias) {
if (!is.null(extract_pars$newnames)) {
colnames(post) <- extract_pars$newnames
}
}
return(post)
}
#'@rdname mvgam_draws
#'@export
as.matrix.mvgam = function(
x,
variable = 'betas',
regex = FALSE,
use_alias = TRUE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
post <- as.matrix(dummy, variable = extract_pars$to_extract)
# Rename if needed
if (use_alias) {
if (!is.null(extract_pars$newnames)) {
colnames(post) <- extract_pars$newnames
}
}
return(post)
}
#'@rdname mvgam_draws
#'@export
as.array.mvgam = function(
x,
variable = 'betas',
regex = FALSE,
use_alias = TRUE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
post <- as.array(dummy, variable = extract_pars$to_extract)
# Rename if needed
if (use_alias) {
if (!is.null(extract_pars$newnames)) {
dimnames(post)$variable <- extract_pars$newnames
}
}
return(post)
}
#' @rdname mvgam_draws
#' @method as_draws mvgam
#' @export
as_draws.mvgam <- function(
x,
variable = NULL,
regex = FALSE,
inc_warmup = FALSE,
use_alias = TRUE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
# Extract
post <- as_draws_list(
dummy,
variable = extract_pars$to_extract,
regex = FALSE,
inc_warmup = inc_warmup,
...
)
# Rename if needed
if (use_alias) {
if (!is.null(extract_pars$newnames)) {
for (chain in seq_along(post)) {
names(post[[chain]]) <- extract_pars$newnames
}
}
}
return(post)
}
#' @export
#' @importFrom posterior as_draws
posterior::as_draws
#' @rdname mvgam_draws
#' @method as_draws_matrix mvgam
#' @export
as_draws_matrix.mvgam <- function(
x,
variable = NULL,
regex = FALSE,
inc_warmup = FALSE,
use_alias = TRUE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
# Extract
post <- as_draws_matrix(
dummy,
variable = extract_pars$to_extract,
regex = FALSE,
inc_warmup = inc_warmup,
...
)
# Rename if needed
if (use_alias) {
if (!is.null(extract_pars$newnames)) {
colnames(post) <- extract_pars$newnames
}
}
return(post)
}
#' @export
#' @importFrom posterior as_draws_matrix
posterior::as_draws_matrix
#' @rdname mvgam_draws
#' @method as_draws_df mvgam
#' @export
as_draws_df.mvgam <- function(
x,
variable = NULL,
regex = FALSE,
inc_warmup = FALSE,
use_alias = TRUE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
# Extract
post <- as_draws_df(
dummy,
variable = extract_pars$to_extract,
regex = FALSE,
inc_warmup = inc_warmup,
...
)
# Rename if needed
if (use_alias) {
if (!is.null(extract_pars$newnames)) {
colnames(post)[1:length(extract_pars$newnames)] <- extract_pars$newnames
}
}
return(post)
}
#' @export
#' @importFrom posterior as_draws_df
posterior::as_draws_df
#' @rdname mvgam_draws
#' @method as_draws_array mvgam
#' @export
as_draws_array.mvgam <- function(
x,
variable = NULL,
regex = FALSE,
inc_warmup = FALSE,
use_alias = TRUE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
# Extract
post <- as_draws_array(
dummy,
variable = extract_pars$to_extract,
regex = FALSE,
inc_warmup = inc_warmup,
...
)
# Rename if needed
if (use_alias) {
if (!is.null(extract_pars$newnames)) {
dimnames(post)$variable <- extract_pars$newnames
}
}
return(post)
}
#' @export
#' @importFrom posterior as_draws_array
posterior::as_draws_array
#' @rdname mvgam_draws
#' @method as_draws_list mvgam
#' @export
as_draws_list.mvgam <- function(
x,
variable = NULL,
regex = FALSE,
inc_warmup = FALSE,
use_alias = TRUE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
# Extract
post <- as_draws_list(
dummy,
variable = extract_pars$to_extract,
regex = FALSE,
inc_warmup = inc_warmup,
...
)
# Rename if needed
if (use_alias) {
if (!is.null(extract_pars$newnames)) {
for (chain in seq_along(post)) {
names(post[[chain]]) <- extract_pars$newnames
}
}
}
return(post)
}
#' @export
#' @importFrom posterior as_draws_list
posterior::as_draws_list
#' @rdname mvgam_draws
#' @method as_draws_rvars mvgam
#' @export
as_draws_rvars.mvgam <- function(
x,
variable = NULL,
regex = FALSE,
inc_warmup = FALSE,
...
) {
# Check variable and get more informative names if applicable
extract_pars <- validate_variables(x, variable = variable, regex = regex)
# Create a slim brmsfit object and use brms machinery to do extraction
dummy <- structure(list(fit = x$model_output), class = 'brmsfit')
# Extract (can't rename rvars due to the way it is structured)
post <- as_draws_rvars(
dummy,
variable = extract_pars$to_extract,
regex = FALSE,
inc_warmup = inc_warmup,
...
)
return(post)
}
#' @export
#' @importFrom posterior as_draws_rvars
posterior::as_draws_rvars
#'@noRd
validate_variables = function(x, variable, regex = FALSE) {
# Get a string of all possible variables to extract
all_vars <- variables(x)
all_orig_vars <- unlist(purrr::map(all_vars, 'orig_name'))
all_alias_vars <- unlist(purrr::map(all_vars, 'alias'))
all_orig_walias <- all_orig_vars[!is.na(all_alias_vars)]
all_alias_vars <- all_alias_vars[!is.na(all_alias_vars)]
# All possible var sets to extract
extract_choices = c(
"obs_params",
"betas",
"smooth_params",
"linpreds",
"trend_params",
"trend_betas",
"trend_smooth_params",
"trend_linpreds",
all_orig_vars,
all_alias_vars
)
if (variable[1] == 'obs_params') {
to_extract <- family_param_info(x$family)$param_names
newnames <- NULL
}
if (variable[1] == 'betas') {
to_extract <- 'b'
newnames <- names(coef(x$mgcv_model))
}
if (variable[1] == 'smooth_params') {
if (is.null(all_vars$observation_smoothpars)) {
stop(
'No observation-level smooth parameters in model; no smooth_params to extract',
call. = FALSE
)
}
to_extract <- 'rho'
newnames <- paste0(x$sp_names, '_rho')
}
if (variable[1] == 'linpreds') {
to_extract <- 'mus'
newnames <- NULL
}
if (variable[1] == 'trend_params') {
to_extract <- trend_par_names(
attr(x$model_data, 'trend_model'),
x$use_lv,
x$drift
)
to_extract <- to_extract[
!to_extract %in% c('tau', 'trend', 'LV', 'penalty', 'lv_coefs')
]
# Determine which other trend params to include
included <- vector(length = length(to_extract))
for (i in 1:length(to_extract)) {
# Check if it can be extracted
suppressWarnings(
estimates <- try(
mcmc_chains(x$model_output, params = to_extract[i]),
silent = TRUE
)
)
if (inherits(estimates, 'try-error')) {
included[i] <- FALSE
} else {
included[i] <- TRUE
}
}
to_extract <- to_extract[included]
newnames <- NULL
}
if (variable[1] == 'trend_betas') {
if (is.null(x$trend_call)) {
stop(
'No trend_formula supplied to model; no trend_betas to extract',
call. = FALSE
)
}
to_extract <- 'b_trend'
newnames <- paste0(names(coef(x$trend_mgcv_model)), '_trend')
}
if (variable[1] == "trend_smooth_params") {
if (is.null(all_vars$trend_smoothpars)) {
stop(
'No smoothing parameters included in trend-level model',
call. = FALSE
)
}
to_extract <- 'rho_trend'
newnames <- paste0(
unlist(purrr::map(x$trend_mgcv_model$smooth, 'label')),
'_rho_trend'
)
}
if (variable[1] == 'trend_linpreds') {
if (is.null(x$trend_call)) {
stop(
'No trend_formula supplied to model; no trend_linpreds to extract',
call. = FALSE
)
}
to_extract <- 'trend_mus'
newnames <- NULL
}
# If not one of the standard subsets, get aliases for the chosen variable(s)
if (
!variable[1] %in%
c(
"obs_params",
"betas",
"smooth_params",
"linpreds",
"trend_params",
"trend_betas",
"trend_smooth_params",
"trend_linpreds"
)
) {
if (regex) {
vars_to_extract <- vector(mode = 'list')
names_to_use <- vector(mode = 'list')
for (i in 1:length(variable)) {
if (!any(grepl(variable[i], extract_choices))) {
vars_to_extract[[i]] <- NA
names_to_use[[i]] <- NA
} else {
if (any(grepl(variable[i], all_alias_vars))) {
vars_to_extract[[i]] <- unname(unlist(purrr::map(
all_vars,
'orig_name'
))[
grepl(variable[i], unlist(purrr::map(all_vars, 'alias')))
])
names_to_use[[i]] <- unname(unlist(purrr::map(all_vars, 'alias'))[
grepl(variable[i], unlist(purrr::map(all_vars, 'alias')))
])
} else {
vars_to_extract[[i]] <- unname(unlist(purrr::map(
all_vars,
'orig_name'
))[
grepl(variable[i], unlist(purrr::map(all_vars, 'orig_name')))
])
names_to_use[[i]] <- unname(unlist(purrr::map(all_vars, 'alias'))[
grepl(variable[i], unlist(purrr::map(all_vars, 'orig_name')))
])
}
}
}
} else {
vars_to_extract <- vector(mode = 'list')
names_to_use <- vector(mode = 'list')
for (i in 1:length(variable)) {
if (!any(extract_choices == variable[i])) {
vars_to_extract[[i]] <- NA
names_to_use[[i]] <- NA
} else {
if (any(all_alias_vars == variable[i])) {
vars_to_extract[[i]] <- unname(all_orig_walias[
which(all_alias_vars == variable[i])
])
names_to_use[[i]] <- variable[i]
} else {
vars_to_extract[[i]] <- unname(unlist(purrr::map(
all_vars,
'orig_name'
))[
which(all_orig_vars == variable[i])
])
names_to_use[[i]] <- unname(unlist(purrr::map(all_vars, 'alias'))[
which(all_orig_vars == variable[i])
])
}
}
}
}
vars_to_extract <- unlist(vars_to_extract)
names_to_use <- unlist(names_to_use)
names_to_use[is.na(names_to_use)] <- vars_to_extract[is.na(names_to_use)]
if (all(is.na(vars_to_extract))) {
stop(
'could not find any variables matching the supplied patterns',
call. = FALSE
)
}
to_extract <- vars_to_extract[!is.na(vars_to_extract)]
newnames <- names_to_use[!is.na(names_to_use)]
}
return(list(to_extract = to_extract, newnames = newnames))
}
================================================
FILE: R/backends.R
================================================
#### Helper functions for preparing and manipulating Stan models ####
# All functions were modified from `brms` source code and so all credit must
# go to the `brms` development team
#' parse Stan model code with cmdstanr
#' @param model Stan model code
#' @return validated Stan model code
#' @noRd
.model_cmdstanr <- function(model_file, threads = 1, silent = 1, ...) {
if (silent < 2) {
message('Compiling Stan program using cmdstanr')
message()
}
if (cmdstanr::cmdstan_version() < "2.26.0") {
warning(
'Your version of Cmdstan is < 2.26.0; some mvgam models may not work properly!'
)
}
temp_file <- cmdstanr::write_stan_file(model_file)
if (cmdstanr::cmdstan_version() >= "2.29.0") {
if (threads > 1) {
out <- eval_silent(
cmdstanr::cmdstan_model(
temp_file,
stanc_options = list('O1'),
cpp_options = list(stan_threads = TRUE),
...
),
type = "message",
try = TRUE,
silent = silent > 0L
)
} else {
out <- eval_silent(
cmdstanr::cmdstan_model(temp_file, stanc_options = list('O1'), ...),
type = "message",
try = TRUE,
silent = silent > 0L
)
}
} else {
if (threads > 1) {
out <- eval_silent(
cmdstanr::cmdstan_model(
temp_file,
cpp_options = list(stan_threads = TRUE),
...
),
type = "message",
try = TRUE,
silent = silent
)
} else {
out <- eval_silent(
cmdstanr::cmdstan_model(temp_file, ...),
type = "message",
try = TRUE,
silent = silent
)
}
}
return(out)
}
#' fit Stan model with cmdstanr using HMC sampling or variational inference
#' @importFrom brms read_csv_as_stanfit
#' @param model a compiled Stan model
#' @param data named list to be passed to Stan as data
#' @return a fitted Stan model
#' @noRd
.sample_model_cmdstanr <- function(
model,
algorithm = 'sampling',
prior_simulation = FALSE,
data,
chains = 4,
parallel = TRUE,
silent = 1L,
max_treedepth,
adapt_delta,
threads = 1,
burnin,
samples,
param = param,
save_all_pars = FALSE,
...
) {
if (algorithm == 'pathfinder') {
if (cmdstanr::cmdstan_version() < "2.33") {
stop(
'Your version of Cmdstan is < 2.33; the "pathfinder" algorithm is not available',
call. = FALSE
)
}
if (utils::packageVersion('cmdstanr') < '0.6.1.9000') {
stop(
'Your version of cmdstanr is < 0.6.1.9000; the "pathfinder" algorithm is not available',
call. = FALSE
)
}
}
# Construct cmdstanr sampling arguments
args <- nlist(data = data)
dots <- list(...)
args[names(dots)] <- dots
if (prior_simulation) {
burnin <- 200
}
# do the actual sampling
if (silent < 2) {
message("Start sampling")
}
if (algorithm == 'sampling') {
c(args) <- nlist(
chains = chains,
refresh = 100,
max_treedepth,
adapt_delta,
diagnostics = NULL,
iter_sampling = samples,
iter_warmup = burnin,
show_messages = silent < 2
)
if (utils::packageVersion('cmdstanr') >= '0.7.0') {
c(args) <- nlist(show_exceptions = silent == 0)
}
if (parallel) {
c(args) <- nlist(
parallel_chains = min(c(chains, parallel::detectCores() - 1))
)
}
if (threads > 1) {
c(args) <- nlist(threads_per_chain = threads)
}
out <- do_call(model$sample, args)
} else if (algorithm %in% c("fullrank", "meanfield")) {
c(args) <- nlist(
algorithm = algorithm,
refresh = 500,
output_samples = samples
)
if (threads > 1) {
c(args) <- nlist(threads = threads)
}
out <- do_call(model$variational, args)
} else if (algorithm %in% c("laplace")) {
c(args) <- nlist(refresh = 500, draws = samples)
if (threads > 1) {
c(args) <- nlist(threads = threads)
}
out <- do_call(model$laplace, args)
} else if (algorithm %in% c("pathfinder")) {
c(args) <- nlist(refresh = 500, draws = samples)
if (threads > 1) {
c(args) <- nlist(num_threads = threads)
}
out <- do_call(model$pathfinder, args)
} else {
stop("Algorithm '", algorithm, "' is not supported.", call. = FALSE)
}
if (algorithm %in% c('meanfield', 'fullrank', 'laplace', 'pathfinder')) {
param <- param[!param %in% 'lp__']
}
# Convert model files to stan_fit class for consistency
repair_names <- function(x) {
x <- sub("\\.", "[", x)
x <- gsub("\\.", ",", x)
x[grep("\\[", x)] <- paste0(x[grep("\\[", x)], "]")
x
}
if (save_all_pars) {
out_gam_mod <- brms::read_csv_as_stanfit(
out$output_files(),
algorithm = algorithm
)
} else {
# Exclude certain pars and transformed_pars that are never needed
# for mvgam post-processing
metadata <- cmdstanr::read_cmdstan_csv(
files = out$output_files(),
variables = "",
sampler_diagnostics = ""
)
all_vars <- metadata$metadata$variables
out_gam_mod <- brms::read_csv_as_stanfit(
out$output_files(),
variables = all_vars,
exclude = c(
'trend_raw',
'b_raw',
'b_raw_trend',
'p',
'eta',
'phi_vec',
'nu_vec',
'sigma_obs_vec',
'shape_vec',
'phi_inv',
'lv_coefs_raw',
'L_Sigma',
'L_Omega',
'L_Sigma_group',
'Sigma_group',
'Gamma',
'Gamma_group',
'A_group',
'L_deviation_group',
'L_Omega_group',
'sub_error'
),
algorithm = algorithm
)
}
out_gam_mod <- repair_stanfit(out_gam_mod)
if (algorithm %in% c('meanfield', 'fullrank', 'pathfinder', 'laplace')) {
out_gam_mod@sim$iter <- samples
out_gam_mod@sim$thin <- 1
out_gam_mod@stan_args[[1]]$method <- 'sampling'
}
return(out_gam_mod)
}
#' fit Stan model with rstan
#' @param model a compiled Stan model
#' @param sdata named list to be passed to Stan as data
#' @return a fitted Stan model
#' @noRd
.sample_model_rstan <- function(
model,
algorithm = 'sampling',
prior_simulation = FALSE,
data,
chains = 4,
parallel = TRUE,
silent = 1L,
max_treedepth,
adapt_delta,
threads = 1,
burnin,
samples,
thin,
...
) {
if (rstan::stan_version() < "2.26.0") {
warning(
'Your version of Stan is < 2.26.0; some mvgam models may not work properly!'
)
}
if (algorithm == 'pathfinder') {
stop(
'The "pathfinder" algorithm is not yet available in rstan',
call. = FALSE
)
}
if (algorithm == 'laplace') {
stop('The "laplace" algorithm is not yet available in rstan', call. = FALSE)
}
# Set up parallel cores
mc_cores_def <- getOption('mc.cores')
options(mc.cores = parallel::detectCores())
on.exit(options(mc.cores = mc_cores_def))
# Fit the model in rstan using custom control parameters
if (threads > 1) {
if (utils::packageVersion("rstan") >= "2.26") {
threads_per_chain_def <- rstan::rstan_options("threads_per_chain")
on.exit(rstan::rstan_options(threads_per_chain = threads_per_chain_def))
rstan::rstan_options(threads_per_chain = threads)
} else {
stop(
"Threading is not supported by backend 'rstan' version ",
utils::packageVersion("rstan"),
".",
call. = FALSE
)
}
}
# Compile the model
if (silent < 2L) {
message('Compiling Stan program using rstan')
message()
}
stan_mod <- eval_silent(
rstan::stan_model(model_code = model, verbose = silent < 1L),
type = "message",
try = TRUE,
silent = silent >= 1L
)
# Construct rstan sampling arguments
args <- nlist(object = stan_mod, data = data)
dots <- list(...)
args[names(dots)] <- dots
if (samples <= burnin) {
samples <- burnin + samples
}
# do the actual sampling
if (silent < 2) {
message("Start sampling")
}
if (algorithm %in% c("sampling", "fixed_param")) {
stan_control <- list(
max_treedepth = max_treedepth,
adapt_delta = adapt_delta
)
if (prior_simulation) {
burnin = 200
samples = 700
}
if (parallel) {
c(args) <- nlist(cores = min(c(chains, parallel::detectCores() - 1)))
} else {
# Explicitly set cores = 1 if parallel = FALSE (#113)
c(args) <- nlist(cores = 1)
}
c(args) <- nlist(
warmup = burnin,
iter = samples,
chains = chains,
control = stan_control,
show_messages = silent < 1L,
verbose = FALSE,
thin = thin,
pars = NA,
refresh = 100,
save_warmup = FALSE
)
out <- do_call(rstan::sampling, args)
} else if (algorithm %in% c("fullrank", "meanfield")) {
c(args) <- nlist(algorithm, output_samples = samples, pars = NA)
out <- do_call(rstan::vb, args)
} else {
stop("Algorithm '", algorithm, "' is not supported.", call. = FALSE)
}
out <- repair_stanfit(out)
return(out)
}
#' @noRd
.autoformat <- function(
stan_file,
overwrite_file = TRUE,
backend = 'cmdstanr',
silent = TRUE
) {
# Can make LV models slightly more efficient by not filling in zeros in a loop
if (any(grepl('lv_coefs_raw[i, j] = 0;', stan_file, fixed = TRUE))) {
starts <- grepws('lv_coefs_raw[i, j] = 0;', stan_file) - 2
ends <- grepws('lv_coefs_raw[i, j] = 0;', stan_file) + 2
stan_file <- stan_file[-c(starts:ends)]
stan_file[grepws('matrix[n_series, n_lv] lv_coefs_raw;', stan_file)] <-
'matrix[n_series, n_lv] lv_coefs_raw = rep_matrix(0, n_series, n_lv);'
}
# No need to fill lv_coefs in each iteration if this is a
# trend_formula model
if (
any(grepl('lv_coefs = Z;', stan_file, fixed = TRUE)) &
!any(grepl('vector[n_lv] LV[n];', stan_file, fixed = TRUE))
) {
stan_file <- stan_file[-grep('lv_coefs = Z;', stan_file, fixed = TRUE)]
stan_file <- stan_file[
-grep('matrix[n_series, n_lv] lv_coefs;', stan_file, fixed = TRUE)
]
stan_file[grep(
'trend[i, s] = dot_product(lv_coefs[s,], LV[i,]);',
stan_file,
fixed = TRUE
)] <-
'trend[i, s] = dot_product(Z[s,], LV[i,]);'
stan_file[grep('// posterior predictions', stan_file, fixed = TRUE) - 1] <-
paste0(
stan_file[
grep('// posterior predictions', stan_file, fixed = TRUE) - 1
],
'\n',
'matrix[n_series, n_lv] lv_coefs = Z;'
)
stan_file <- readLines(textConnection(stan_file), n = -1)
}
if (backend == 'rstan' & rstan::stan_version() < '2.29.0') {
# normal_id_glm became available in 2.29.0; this needs to be replaced
# with the older non-glm version
if (any(grepl('normal_id_glm', stan_file, fixed = TRUE))) {
if (
any(grepl("flat_ys ~ normal_id_glm(flat_xs,", stan_file, fixed = TRUE))
) {
start <- grep(
"flat_ys ~ normal_id_glm(flat_xs,",
stan_file,
fixed = TRUE
)
end <- start + 2
stan_file <- stan_file[-c((start + 1):(start + 2))]
stan_file[start] <- 'flat_ys ~ normal(flat_xs * b, flat_sigma_obs);'
}
}
}
# Old ways of specifying arrays have been converted to errors in
# the latest version of Cmdstan (2.32.0); this coincides with
# a decision to stop automatically replacing these deprecations with
# the canonicalizer, so we have no choice but to replace the old
# syntax with this ugly bit of code
# rstan dependency in Description should mean that updates should
# always happen (mvgam depends on rstan >= 2.29.0)
update_code <- TRUE
# Tougher if using cmdstanr
if (backend == 'cmdstanr') {
if (cmdstanr::cmdstan_version() < "2.32.0") {
# If the autoformat options from cmdstanr are available,
# make use of them to update any deprecated array syntax
update_code <- FALSE
}
}
if (update_code) {
# Data modifications
stan_file[grep(
"int ytimes[n, n_series]; // time-ordered matrix (which col in X belongs to each [time, series] observation?)",
stan_file,
fixed = TRUE
)] <-
'array[n, n_series] int ytimes; // time-ordered matrix (which col in X belongs to each [time, series] observation?)'
stan_file[grep(
"int flat_ys[n_nonmissing]; // flattened nonmissing observations",
stan_file,
fixed = TRUE
)] <-
'array[n_nonmissing] int flat_ys; // flattened nonmissing observations'
stan_file[grep(
"int obs_ind[n_nonmissing]; // indices of nonmissing observations",
stan_file,
fixed = TRUE
)] <-
"array[n_nonmissing] int obs_ind; // indices of nonmissing observations"
if (
any(grepl(
'int ytimes_trend[n, n_lv]; // time-ordered matrix for latent states',
stan_file,
fixed = TRUE
))
) {
stan_file[grep(
"int ytimes_trend[n, n_lv]; // time-ordered matrix for latent states",
stan_file,
fixed = TRUE
)] <-
"array[n, n_lv] int ytimes_trend;"
}
if (
any(
grepl('int idx', stan_file) &
grepl('// discontiguous index values', stan_file, fixed = TRUE)
)
) {
lines_replace <- which(
grepl('int idx', stan_file) &
grepl('// discontiguous index values', stan_file, fixed = TRUE)
)
for (i in lines_replace) {
split_line <- strsplit(stan_file[i], ' ')[[1]]
idxnum <- gsub(
';',
'',
gsub("\\s*\\[[^\\]+\\]", "", as.character(split_line[2]))
)
idx_length <- gsub(
"\\]",
"",
gsub(
"\\[",
"",
regmatches(split_line[2], gregexpr("\\[.*?\\]", split_line[2]))[[1]]
)
)
stan_file[i] <-
paste0(
'array[',
idx_length,
'] int ',
idxnum,
'; // discontiguous index values'
)
}
}
if (
any(grepl(
'int cap[total_obs]; // upper limits of latent abundances',
stan_file,
fixed = TRUE
))
) {
stan_file[grep(
'int cap[total_obs]; // upper limits of latent abundances',
stan_file,
fixed = TRUE
)] <-
'array[total_obs] int cap; // upper limits of latent abundances'
stan_file[grep(
'int flat_caps[n_nonmissing];',
stan_file,
fixed = TRUE
)] <-
'array[n_nonmissing] int flat_caps;'
}
# Model modifications
if (any(grepl('real flat_phis[n_nonmissing];', stan_file, fixed = TRUE))) {
stan_file[grep(
"real flat_phis[n_nonmissing];",
stan_file,
fixed = TRUE
)] <-
"array[n_nonmissing] real flat_phis;"
}
# n-mixture modifications
if (
any(grepl(
'real p_ub = poisson_cdf(max_k, lambda);',
stan_file,
fixed = TRUE
))
) {
stan_file[grep(
'real p_ub = poisson_cdf(max_k, lambda);',
stan_file,
fixed = TRUE
)] <-
'real p_ub = poisson_cdf(max_k | lambda);'
}
# trend_formula modifications
if (
any(
grepl('int trend_rand_idx', stan_file) &
grepl('// trend random effect indices', stan_file, fixed = TRUE)
)
) {
lines_replace <- which(
grepl('int trend_rand_idx', stan_file) &
grepl('// trend random effect indices', stan_file, fixed = TRUE)
)
for (i in lines_replace) {
split_line <- strsplit(stan_file[i], ' ')[[1]]
trend_idxnum <- gsub(
';',
'',
gsub("\\s*\\[[^\\]+\\]", "", as.character(split_line[2]))
)
idx_length <- gsub(
"\\]",
"",
gsub(
"\\[",
"",
regmatches(split_line[2], gregexpr("\\[.*?\\]", split_line[2]))[[1]]
)
)
stan_file[i] <-
paste0(
'array[',
idx_length,
'] int ',
trend_idxnum,
'; // trend random effect indices'
)
}
}
if (
any(
grepl('int trend_idx', stan_file) &
grepl('// discontiguous index values', stan_file, fixed = TRUE)
)
) {
lines_replace <- which(
grepl('int trend_idx', stan_file) &
grepl('// discontiguous index values', stan_file, fixed = TRUE)
)
for (i in lines_replace) {
split_line <- strsplit(stan_file[i], ' ')[[1]]
trend_idxnum <- gsub(
';',
'',
gsub("\\s*\\[[^\\]+\\]", "", as.character(split_line[2]))
)
idx_length <- gsub(
"\\]",
"",
gsub(
"\\[",
"",
regmatches(split_line[2], gregexpr("\\[.*?\\]", split_line[2]))[[1]]
)
)
stan_file[i] <-
paste0(
'array[',
idx_length,
'] int ',
trend_idxnum,
'; // discontiguous index values'
)
}
}
if (any(grepl('vector[n_series] trend_raw[n];', stan_file, fixed = TRUE))) {
stan_file[grep(
"vector[n_series] trend_raw[n];",
stan_file,
fixed = TRUE
)] <-
"array[n] vector[n_series] trend_raw;"
}
if (any(grepl('vector[n_lv] error[n];', stan_file, fixed = TRUE))) {
stan_file[grep("vector[n_lv] error[n];", stan_file, fixed = TRUE)] <-
"array[n] vector[n_lv] error;"
}
if (any(grepl('vector[n_series] error[n];', stan_file, fixed = TRUE))) {
stan_file[grep("vector[n_series] error[n];", stan_file, fixed = TRUE)] <-
"array[n] vector[n_series] error;"
}
if (any(grepl('vector[n_lv] LV[n];', stan_file, fixed = TRUE))) {
stan_file[grep("vector[n_lv] LV[n];", stan_file, fixed = TRUE)] <-
"array[n] vector[n_lv] LV;"
}
if (any(grepl('vector[n_series] mu[n - 1];', stan_file, fixed = TRUE))) {
stan_file[grep("vector[n_series] mu[n - 1];", stan_file, fixed = TRUE)] <-
"array[n - 1] vector[n_series] mu;"
}
if (any(grepl('vector[n_lv] mu[n - 1];', stan_file, fixed = TRUE))) {
stan_file[grep("vector[n_lv] mu[n - 1];", stan_file, fixed = TRUE)] <-
"array[n - 1] vector[n_lv] mu;"
}
if (any(grepl('vector[n_series] mu[n];', stan_file, fixed = TRUE))) {
stan_file[grep("vector[n_series] mu[n];", stan_file, fixed = TRUE)] <-
"array[n] vector[n_series] mu;"
}
if (any(grepl('vector[n_lv] mu[n];', stan_file, fixed = TRUE))) {
stan_file[grep("vector[n_lv] mu[n];", stan_file, fixed = TRUE)] <-
"array[n] vector[n_lv] mu;"
}
# Generated quantity modifications
if (
any(grepl(
'real ypred[n, n_series];',
stan_file,
fixed = TRUE
))
) {
stan_file[grep(
"real ypred[n, n_series];",
stan_file,
fixed = TRUE
)] <-
"array[n, n_series] real ypred;"
}
if (
any(grepl('real ypred[n, n_series];', stan_file, fixed = TRUE))
) {
stan_file[grep(
"real ypred[n, n_series];",
stan_file,
fixed = TRUE
)] <-
"array[n, n_series] real ypred;"
}
# ARMA model modifications
if (any(grepl('vector[n_series] epsilon[n];', stan_file, fixed = TRUE))) {
stan_file[grep(
"vector[n_series] epsilon[n];",
stan_file,
fixed = TRUE
)] <-
"array[n] vector[n_series] epsilon;"
}
if (any(grepl('vector[n_lv] epsilon[n];', stan_file, fixed = TRUE))) {
stan_file[grep("vector[n_lv] epsilon[n];", stan_file, fixed = TRUE)] <-
"array[n] vector[n_lv] epsilon;"
}
# VARMA model modifications
if (
any(grepl('matrix[n_series, n_series] P[1];', stan_file, fixed = TRUE))
) {
stan_file[grep(
"matrix[n_series, n_series] P[1];",
stan_file,
fixed = TRUE
)] <-
"array[1] matrix[n_series, n_series] P;"
stan_file[grep(
"matrix[n_series, n_series] phiGamma[2, 1];",
stan_file,
fixed = TRUE
)] <-
"array[2, 1] matrix[n_series, n_series] phiGamma;"
}
if (
any(grepl(
'matrix initial_joint_var(matrix Sigma, matrix[] phi, matrix[] theta) {',
stan_file,
fixed = TRUE
))
) {
stan_file[grep(
"matrix initial_joint_var(matrix Sigma, matrix[] phi, matrix[] theta) {",
stan_file,
fixed = TRUE
)] <-
"matrix initial_joint_var(matrix Sigma, array[] matrix phi, array[] matrix theta) {"
}
if (any(grepl('matrix[n_lv, n_lv] P[1];', stan_file, fixed = TRUE))) {
stan_file[grep("matrix[n_lv, n_lv] P[1];", stan_file, fixed = TRUE)] <-
"array[1] matrix[n_lv, n_lv] P;"
stan_file[grep("matrix[n_lv, n_lv] R[1];", stan_file, fixed = TRUE)] <-
"array[1] matrix[n_lv, n_lv] R;"
stan_file[grep(
"matrix[n_lv, n_lv] A_init[1];",
stan_file,
fixed = TRUE
)] <-
"array[1] matrix[n_lv, n_lv] A_init;"
stan_file[grep(
"matrix[n_lv, n_lv] theta_init[1];",
stan_file,
fixed = TRUE
)] <-
"array[1] matrix[n_lv, n_lv] theta_init;"
}
if (
any(grepl('matrix[n_series, n_series] R[1];', stan_file, fixed = TRUE))
) {
stan_file[grep(
"matrix[n_series, n_series] R[1];",
stan_file,
fixed = TRUE
)] <-
"array[1] matrix[n_series, n_series] R;"
stan_file[grep(
"matrix[n_series, n_series] A_init[1];",
stan_file,
fixed = TRUE
)] <-
"array[1] matrix[n_series, n_series] A_init;"
stan_file[grep(
"matrix[n_series, n_series] theta_init[1];",
stan_file,
fixed = TRUE
)] <-
"array[1] matrix[n_series, n_series] theta_init;"
}
if (
any(grepl(
'matrix[] rev_mapping(matrix[] P, matrix Sigma) {',
stan_file,
fixed = TRUE
))
) {
stan_file[grep(
"matrix[] rev_mapping(matrix[] P, matrix Sigma) {",
stan_file,
fixed = TRUE
)] <-
"array[] matrix rev_mapping(array[] matrix P, matrix Sigma) {"
stan_file[grep(
"matrix[m, m] phi_for[p, p]; matrix[m, m] phi_rev[p, p];",
stan_file,
fixed = TRUE
)] <-
'array[p, p] matrix[m, m] phi_for; array[p, p] matrix[m, m] phi_rev;'
stan_file[grep(
"matrix[m, m] Sigma_for[p+1]; matrix[m, m] Sigma_rev[p+1];",
stan_file,
fixed = TRUE
)] <-
'array[p+1] matrix[m, m] Sigma_for; array[p+1] matrix[m, m] Sigma_rev;'
stan_file[grep(
"matrix[m, m] S_for_list[p+1];",
stan_file,
fixed = TRUE
)] <-
'array[p+1] matrix[m, m] S_for_list;'
}
# VAR model modifications
if (
any(grepl('matrix[n_lv, n_lv] phiGamma[2, 1];', stan_file, fixed = TRUE))
) {
stan_file[grep(
'matrix[n_lv, n_lv] phiGamma[2, 1];',
stan_file,
fixed = TRUE
)] <-
'array[2, 1] matrix[n_lv, n_lv] phiGamma;'
}
if (
any(grepl(
'matrix[,] rev_mapping(matrix[] P, matrix Sigma) {',
stan_file,
fixed = TRUE
))
) {
stan_file[grep(
"matrix[,] rev_mapping(matrix[] P, matrix Sigma) {",
stan_file,
fixed = TRUE
)] <-
"array[,] matrix rev_mapping(array[] matrix P, matrix Sigma) {"
stan_file[grep(
"matrix[m, m] phi_for[p, p]; matrix[m, m] phi_rev[p, p];",
stan_file,
fixed = TRUE
)] <-
'array[p, p] matrix[m, m] phi_for; array[p, p] matrix[m, m] phi_rev;'
stan_file[grep(
"matrix[m, m] Sigma_for[p+1]; matrix[m, m] Sigma_rev[p+1];",
stan_file,
fixed = TRUE
)] <-
'array[p+1] matrix[m, m] Sigma_for; array[p+1] matrix[m, m] Sigma_rev;'
stan_file[grep(
"matrix[m, m] S_for_list[p+1];",
stan_file,
fixed = TRUE
)] <-
'array[p+1] matrix[m, m] S_for_list;'
stan_file[grep(
"matrix[m, m] Gamma_trans[p+1];",
stan_file,
fixed = TRUE
)] <-
'array[p+1] matrix[m, m] Gamma_trans;'
stan_file[grep(
"matrix[m, m] phiGamma[2, p];",
stan_file,
fixed = TRUE
)] <-
'array[2, p] matrix[m, m] phiGamma;'
}
if (
any(grepl(
"real partial_log_lik(int[] seq, int start, int end,",
stan_file,
fixed = TRUE
))
) {
stan_file[grepl(
"real partial_log_lik(int[] seq, int start, int end,",
stan_file,
fixed = TRUE
)] <-
"real partial_log_lik(array[] int seq, int start, int end,"
}
if (
any(grepl(
"data vector Y, vector mu, real[] shape) {",
stan_file,
fixed = TRUE
))
) {
stan_file[grepl(
"data vector Y, vector mu, real[] shape) {",
stan_file,
fixed = TRUE
)] <-
"data vector Y, vector mu, array[] real shape) {"
}
if (
any(grepl(
"int seq[n_nonmissing]; // an integer sequence for reduce_sum slicing",
stan_file,
fixed = TRUE
))
) {
stan_file[grepl(
"int seq[n_nonmissing]; // an integer sequence for reduce_sum slicing",
stan_file,
fixed = TRUE
)] <-
"array[n_nonmissing] int seq; // an integer sequence for reduce_sum slicing"
}
}
if (backend == 'rstan') {
options(stanc.allow_optimizations = TRUE, stanc.auto_format = TRUE)
out <- eval_silent(
rstan::stanc(model_code = stan_file),
type = "message",
try = TRUE,
silent = silent
)
out <- out$model_code
} else {
stan_file <- cmdstanr::write_stan_file(stan_file)
cmdstan_mod <- eval_silent(
cmdstanr::cmdstan_model(stan_file, compile = FALSE),
type = "message",
try = TRUE,
silent = silent
)
out <- utils::capture.output(
cmdstan_mod$format(
max_line_length = 80,
canonicalize = TRUE,
overwrite_file = overwrite_file,
backup = FALSE
)
)
out <- paste0(out, collapse = "\n")
}
return(out)
}
#' @noRd
repair_stanfit <- function(x) {
if (!length(x@sim$fnames_oi)) {
# nothing to rename
return(x)
}
# the posterior package cannot deal with non-unique parameter names
# this case happens rarely but might happen when sample_prior = "yes"
x@sim$fnames_oi <- make.unique(as.character(x@sim$fnames_oi), "__")
for (i in seq_along(x@sim$samples)) {
# stanfit may have renamed dimension suffixes (#1218)
if (length(x@sim$samples[[i]]) == length(x@sim$fnames_oi)) {
names(x@sim$samples[[i]]) <- x@sim$fnames_oi
}
}
x
}
#' @noRd
repair_variable_names <- function(x) {
x <- sub("\\.", "[", x)
x <- gsub("\\.", ",", x)
x[grep("\\[", x)] <- paste0(x[grep("\\[", x)], "]")
x
}
#' @noRd
seq_rows = function(x) {
seq_len(NROW(x))
}
#' @noRd
is_equal <- function(x, y, check.attributes = FALSE, ...) {
isTRUE(all.equal(x, y, check.attributes = check.attributes, ...))
}
#' @noRd
ulapply <- function(X, FUN, ..., recursive = TRUE, use.names = TRUE) {
unlist(lapply(X, FUN, ...), recursive, use.names)
}
================================================
FILE: R/compute_edf.R
================================================
#' Compute approximate EDFs of smooths
#' @importFrom stats fitted
#'@noRd
compute_edf = function(
mgcv_model,
object,
rho_names,
sigma_raw_names,
conservative = FALSE
) {
if (length(mgcv_model$smooth) > 0) {
smooth_labs <- do.call(
rbind,
lapply(seq_along(mgcv_model$smooth), function(x) {
data.frame(
label = mgcv_model$smooth[[x]]$label,
term = paste(mgcv_model$smooth[[x]]$term, collapse = ','),
class = class(mgcv_model$smooth[[x]])[1]
)
})
)
# Find the best overall posterior draw
if (object$family == 'nmix') {
best_draw <- 1
} else {
liks <- logLik(object, include_forecast = FALSE)
best_draw <- which.max(rowMeans(liks, na.rm = TRUE))
}
# Extract smoothing parameters
sp_names <- names(mgcv_model$sp)
rho_sp <- vector()
random_sp <- vector()
if (!all(smooth_labs$class == 'random.effect')) {
rho_estimates <- mcmc_chains(object$model_output, rho_names)[best_draw, ]
rho_sp <- rho_estimates
names(rho_sp) <- paste0(sp_names[1:length(rho_estimates)], '_', rho_names)
}
if (any(smooth_labs$class == 'random.effect')) {
if (length(rho_sp) > 0) {
rho_sp <- rho_sp[-which(smooth_labs$class == 'random.effect')]
}
pop_sd_estimates <- mcmc_chains(object$model_output, sigma_raw_names)[
best_draw,
]
random_sp <- pop_sd_estimates
if (rho_names == 'rho_trend') {
names(random_sp) <- paste0(
'sd(',
sp_names[which(smooth_labs$class == 'random.effect')],
')_trend'
)
} else {
names(random_sp) <- paste0(
'sd(',
sp_names[which(smooth_labs$class == 'random.effect')],
')'
)
}
names(random_sp) <- gsub('s\\(', '', names(random_sp))
names(random_sp) <- gsub('\\))', ')', names(random_sp))
}
mgcv_model$sp <- exp(c(rho_sp, random_sp))
# Compute estimated degrees of freedom based on edf.type = 1 from
# https://github.com/cran/mgcv/blob/master/R/jagam.r
# using Simon Wood's example calculation
X <- predict(mgcv_model, type = 'lpmatrix')
if (rho_names == 'rho_trend') {
bs <- mcmc_chains(object$model_output, 'b_trend')[best_draw, ]
} else {
bs <- mcmc_chains(object$model_output, 'b')[best_draw, ]
}
eta <- X %*% bs
if (rho_names == 'rho_trend') {
# trend models use Gaussian family; expectations are simply the trend_mus
mu <- mcmc_chains(object$model_output, 'trend_mus')[
best_draw,
1:length(eta)
]
} else {
# observation models may vary in their response family; need to compute
# the expectations
mu <- fitted(object, summary = FALSE)[best_draw, 1:length(eta)]
}
# Calculate variance using family's mean-variance relationship
mu_variance <- predict(
object,
process_error = FALSE,
type = 'variance',
summary = FALSE
)[best_draw, ]
if (length(mu_variance) > 1) {
mu_variance <- mu_variance[1:length(eta)]
}
if (any(mu_variance == 0)) {
mu_variance[which(mu_variance == 0)] <-
mu[which(mu_variance == 0)]
}
if (!conservative) {
w <- as.numeric(mgcv_model$family$mu.eta(as.vector(eta))^2 / mu_variance)
XWX <- t(X) %*% (w * X)
} else {
XWX <- t(X) %*% X
}
lambda <- mgcv_model$sp
XWXS <- XWX
for (i in 1:length(lambda)) {
ind <- mgcv_model$off[i]:(mgcv_model$off[i] + ncol(mgcv_model$S[[i]]) - 1)
XWXS[ind, ind] <- XWXS[ind, ind] + mgcv_model$S[[i]] * lambda[i]
}
suppressWarnings(edf <- try(diag(solve(XWXS, XWX)), silent = TRUE))
if (inherits(edf, 'try-error')) {
edf <- mgcv_model$edf
names(edf) <- names(coef(mgcv_model))
}
mgcv_model$edf <- edf
mgcv_model$edf1 <- edf
mgcv_model$edf2 <- edf
}
# Add frequentist version of parameter covariance estimators
# for calculation of smooth term p-values;
# rV <- mroot(mgcv_model$Vp)
# V <- tcrossprod(rV)
# XWX <- crossprod(mgcv_model$R)
# Ve_hat <- V %*% XWX
# mgcv_model$Ve <- Ve_hat %*% V
mgcv_model$Ve <- mgcv_model$Vp
return(mgcv_model)
}
================================================
FILE: R/conditional_effects.R
================================================
#' Display conditional effects of predictors for \pkg{mvgam} models
#'
#' Display conditional effects of one or more numeric and/or categorical
#' predictors in models of class `mvgam` and `jsdgam`, including two-way
#' interaction effects.
#'
#' @importFrom ggplot2 scale_colour_discrete scale_fill_discrete theme_classic
#' @importFrom graphics plot
#' @importFrom grDevices devAskNewPage
#'
#' @inheritParams brms::conditional_effects.brmsfit
#' @inheritParams brms::plot.brms_conditional_effects
#'
#' @param x Object of class `mvgam`, `jsdgam` or `mvgam_conditional_effects`
#'
#' @param points `Logical`. Indicates if the original data points should be
#' added, but only if `type == 'response'`. Default is `TRUE`.
#'
#' @param rug `Logical`. Indicates if displays tick marks should be plotted on
#' the axes to mark the distribution of raw data, but only if
#' `type == 'response'`. Default is `TRUE`.
#'
#' @param ask `Logical`. Indicates if the user is prompted before a new page is
#' plotted. Only used if plot is `TRUE`. Default is `FALSE`.
#'
#' @param type `character` specifying the scale of predictions. When this has
#' the value \code{link} the linear predictor is calculated on the link
#' scale. If \code{expected} is used (the default), predictions reflect the
#' expectation of the response (the mean) but ignore uncertainty in the
#' observation process. When \code{response} is used, the predictions take
#' uncertainty in the observation process into account to return predictions
#' on the outcome scale. Two special cases are also allowed: type `latent_N`
#' will return the estimated latent abundances from an N-mixture distribution,
#' while type `detection` will return the estimated detection probability from
#' an N-mixture distribution.
#'
#' @param ... other arguments to pass to \code{\link[marginaleffects]{plot_predictions}}
#'
#' @return `conditional_effects` returns an object of class
#' \code{mvgam_conditional_effects} which is a named list with one slot per
#' effect containing a \code{\link[ggplot2]{ggplot}} object, which can be
#' further customized using the \pkg{ggplot2} package. The corresponding
#' `plot` method will draw these plots in the active graphic device.
#'
#' @details This function acts as a wrapper to the more flexible
#' \code{\link[marginaleffects]{plot_predictions}}. 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. Use
#' \code{\link[marginaleffects]{plot_predictions}} to change these and create
#' more bespoke conditional effects plots.
#'
#' @name conditional_effects.mvgam
#'
#' @author Nicholas J Clark
#'
#' @seealso \code{\link[marginaleffects]{plot_predictions}},
#' \code{\link[marginaleffects]{plot_slopes}}
#'
#' @examples
#' \dontrun{
#' # Simulate some data
#' simdat <- sim_mvgam(
#' family = poisson(),
#' seasonality = 'hierarchical'
#' )
#'
#' # Fit a model
#' mod <- mvgam(
#' y ~ s(season, by = series, k = 5) + year:series,
#' family = poisson(),
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Plot all main effects on the response scale
#' conditional_effects(mod)
#'
#' # Change the prediction interval to 70% using plot_predictions() argument
#' # 'conf_level'
#' conditional_effects(mod, conf_level = 0.7)
#'
#' # Plot all main effects on the link scale
#' conditional_effects(mod, type = 'link')
#'
#' # Works the same for smooth terms, including smooth interactions
#' set.seed(0)
#' dat <- mgcv::gamSim(1, n = 200, scale = 2)
#' mod <- mvgam(
#' y ~ te(x0, x1, k = 5) + s(x2, k = 6) + s(x3, k = 6),
#' data = dat,
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#' conditional_effects(mod)
#' conditional_effects(mod, conf_level = 0.5, type = 'link')
#'
#' # ggplot objects can be modified and combined with the help of many
#' # additional packages. Here is an example using the patchwork package
#'
#' # Simulate some nonlinear data
#' dat <- mgcv::gamSim(1, n = 200, scale = 2)
#' mod <- mvgam(
#' y ~ s(x1, bs = 'moi') + te(x0, x2),
#' data = dat,
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract the list of ggplot conditional_effect plots
#' m <- plot(conditional_effects(mod), plot = FALSE)
#'
#' # Add custom labels and arrange plots together using patchwork::wrap_plots()
#' library(patchwork)
#' library(ggplot2)
#' wrap_plots(
#' m[[1]] + labs(title = 's(x1, bs = "moi")'),
#' m[[2]] + labs(title = 'te(x0, x2)')
#' )
#' }
#'
#' @export
conditional_effects.mvgam = function(
x,
effects = NULL,
type = 'expected',
points = FALSE,
rug = FALSE,
...
) {
use_def_effects <- is.null(effects)
type <- match.arg(
type,
c('response', 'link', 'detection', 'latent_N', 'expected')
)
if (type == 'response') {
if (points) {
points <- 0.5
} else {
points <- 0
}
} else {
points <- 0
rug <- FALSE
}
# Can't plot points or rugs with binomial models due to the
# cbind syntax
if (rug) {
if (x$family %in% c('binomial', 'beta_binomial')) {
rug <- FALSE
message('Cannot show observation rug for binomial models')
}
}
if (points) {
if (x$family %in% c('binomial', 'beta_binomial')) {
points <- 0
message('Cannot show observation points for binomial models')
}
}
if (use_def_effects) {
# Get all term labels in the model
termlabs <- attr(terms(formula(x), keep.order = TRUE), 'term.labels')
#termlabs <- unlist(find_predictors(x), use.names = FALSE)
if (!is.null(x$trend_call)) {
termlabs <- c(
termlabs,
gsub(
'trend',
'series',
attr(
terms(formula(x, trend_effects = TRUE), keep.order = TRUE),
'term.labels'
)
)
)
}
# Find all possible (up to 2-way) plot conditions
cond_labs <- purrr::flatten(lapply(termlabs, function(i) {
split_termlabs(i)
}))
} else {
cond_labs <- strsplit(as.character(effects), split = ":")
}
if (any(lengths(cond_labs) > 3L)) {
stop(
"To display interactions of order higher than 3 ",
"please use plot_predictions()",
call. = FALSE
)
}
if (length(cond_labs) > 0) {
# Make the plot data with plot_predictions
out <- list()
for (i in seq_along(cond_labs)) {
if (length(cond_labs[[i]]) == 1) {
out[[i]] <- plot_predictions(
x,
condition = cond_labs[[i]],
draw = TRUE,
type = type,
points = points,
rug = rug,
...
) +
scale_fill_discrete(label = roundlabs) +
scale_colour_discrete(label = roundlabs) +
theme_classic()
}
if (length(cond_labs[[i]]) == 2) {
out[[i]] <- plot_predictions(
x,
condition = c(cond_labs[[i]][1], cond_labs[[i]][2]),
draw = TRUE,
type = type,
points = points,
rug = rug,
...
) +
scale_fill_discrete(label = roundlabs) +
scale_colour_discrete(label = roundlabs) +
theme_classic()
}
if (length(cond_labs[[i]]) == 3) {
out[[i]] <- plot_predictions(
x,
condition = c(
cond_labs[[i]][1],
cond_labs[[i]][2],
cond_labs[[i]][3]
),
draw = TRUE,
type = type,
points = points,
rug = rug,
...
) +
scale_fill_discrete(label = roundlabs) +
scale_colour_discrete(label = roundlabs) +
theme_classic()
}
}
} else {
out <- NULL
}
class(out) <- 'mvgam_conditional_effects'
return(out)
}
#' @export
#' @importFrom brms conditional_effects
brms::conditional_effects
#' @rdname conditional_effects.mvgam
#' @export
plot.mvgam_conditional_effects = function(x, plot = TRUE, ask = FALSE, ...) {
out <- x
for (i in seq_along(out)) {
if (plot) {
plot(out[[i]])
if (i == 1) {
devAskNewPage(ask = ask)
}
}
}
invisible(out)
}
#' A helper function so ggplot2 labels in the legend don't have
#' ridiculous numbers of digits for numeric bins
#' @noRd
decimalplaces <- function(x) {
x <- as.numeric(x)
if (abs(x - round(x)) > .Machine$double.eps^0.5) {
nchar(strsplit(sub('0+$', '', as.character(x)), ".", fixed = TRUE)[[1]][[
2
]])
} else {
return(0)
}
}
#' A helper function so ggplot2 labels in the legend don't have
#' ridiculous numbers of digits for numeric bins
#' @noRd
roundlabs = function(x) {
if (all(suppressWarnings(is.na(as.numeric(x))))) {
out <- x
} else if (all(sapply(x, decimalplaces) == 0)) {
out <- x
} else if (all(sapply(x, decimalplaces) <= 1)) {
out <- sprintf("%.1f", as.numeric(x))
} else {
out <- sprintf("%.4f", as.numeric(x))
}
out
}
#' @rdname conditional_effects.mvgam
#' @export
print.mvgam_conditional_effects <- function(x, ...) {
plot(x, ...)
}
#' @noRd
split_termlabs = function(lab) {
out <- list()
if (grepl(':', lab, fixed = TRUE)) {
out[[1]] <- strsplit(lab, ':')[[1]]
} else if (grepl('*', lab, fixed = TRUE)) {
out[[1]] <- strsplit(lab, '\\*')[[1]]
} else if (
grepl('s(', lab, fixed = TRUE) |
grepl('gp(', lab, fixed = TRUE) |
grepl('te(', lab, fixed = TRUE) |
grepl('t2(', lab, fixed = TRUE) |
grepl('ti(', lab, fixed = TRUE)
) {
term_struc <- eval(rlang::parse_expr(lab))
term_struc$by <- if (term_struc$by == 'NA') {
NULL
} else {
term_struc$by
}
if (length(term_struc$term) <= 2) {
out[[1]] <- c(all.vars(parse(text = term_struc$term)), term_struc$by)
}
if (length(term_struc$term) == 3) {
out[[1]] <- c(all.vars(parse(text = term_struc$term[1:2])), term_struc$by)
out[[2]] <- c(
all.vars(parse(text = term_struc$term[c(1, 3)])),
term_struc$by
)
out[[3]] <- c(
all.vars(parse(text = term_struc$term[c(2, 3)])),
term_struc$by
)
}
if (length(term_struc$term) == 4) {
out[[1]] <- c(all.vars(parse(text = term_struc$term[1:2])), term_struc$by)
out[[2]] <- c(
all.vars(parse(text = term_struc$term[c(1, 3)])),
term_struc$by
)
out[[3]] <- c(
all.vars(parse(text = term_struc$term[c(1, 4)])),
term_struc$by
)
out[[4]] <- c(
all.vars(parse(text = term_struc$term[c(2, 3)])),
term_struc$by
)
out[[5]] <- c(
all.vars(parse(text = term_struc$term[c(2, 4)])),
term_struc$by
)
}
} else if (grepl('dynamic(', lab, fixed = TRUE)) {
term_struc <- eval(rlang::parse_expr(lab))
out[[1]] <- c('time', all.vars(parse(text = term_struc$term[c(2, 4)])))
} else {
out[[1]] <- lab
}
return(out)
}
================================================
FILE: R/cpp_funs.R
================================================
#' @useDynLib mvgam, .registration = TRUE
#' @importFrom Rcpp evalCpp
NULL
================================================
FILE: R/data_grids.R
================================================
#' Get data objects into correct order in case it is not already
#'@noRd
sort_data = function(data, series_time = FALSE) {
if (inherits(data, 'list')) {
data_arranged <- data
if (series_time) {
temp_dat = data.frame(
time = data$index..time..index,
series = data$series
) %>%
dplyr::mutate(index = dplyr::row_number()) %>%
dplyr::arrange(series, time)
} else {
temp_dat = data.frame(
time = data$index..time..index,
series = data$series
) %>%
dplyr::mutate(index = dplyr::row_number()) %>%
dplyr::arrange(time, series)
}
data_arranged <- lapply(data, function(x) {
if (is.matrix(x)) {
matrix(x[temp_dat$index, ], ncol = NCOL(x))
} else {
x[temp_dat$index]
}
})
names(data_arranged) <- names(data)
} else {
if (series_time) {
data_arranged <- data %>%
dplyr::arrange(series, index..time..index)
} else {
data_arranged <- data %>%
dplyr::arrange(index..time..index, series)
}
}
return(data_arranged)
}
#' Create prediction grids, mostly for simple plotting functions
#'@noRd
data_grid = function(..., newdata) {
dots <- list(...)
vars <- names(dots)
# Validate that vars exist in supplied data
for (i in seq_along(vars)) {
if (!exists(vars[i], newdata)) {
stop(paste0('Variable ', vars[i], ' not found in newdata'), call. = FALSE)
}
}
# Create sample dummy dataframe to get the prediction grid, ensuring
# factors are preserved
newdat_grid <- data.frame(do.call(
cbind.data.frame,
lapply(vars, function(x) {
newdata[[x]]
})
))
colnames(newdat_grid) <- vars
# Use the supplied conditions for making the datagrid
newdat_grid <- marginaleffects::datagrid(..., newdata = newdat_grid)
# Now replicate the first observation for all other variables
if (inherits(newdata, 'list')) {
newdat_full <- lapply(seq_along(newdata), function(x) {
if (names(newdata)[x] %in% vars) {
newdat_grid[[names(newdata)[x]]]
} else {
if (is.matrix(newdata[[x]])) {
t(replicate(NROW(newdat_grid), newdata[[x]][1, ]))
} else {
if (is.factor(newdata[[x]])) {
factor(
rep(newdata[[x]][1], NROW(newdat_grid)),
levels = levels(newdata[[x]])
)
} else {
rep(newdata[[x]][1], NROW(newdat_grid))
}
}
}
})
names(newdat_full) <- names(newdata)
} else {
newdat_full <-
dplyr::bind_cols(
newdat_grid,
data.frame(
newdata %>%
dplyr::select(!vars) %>%
dplyr::slice_head(n = 1)
)
)
}
return(newdat_full)
}
================================================
FILE: R/dynamic.R
================================================
#' Defining dynamic coefficients in \pkg{mvgam} formulae
#'
#' Set up time-varying (dynamic) coefficients for use in \pkg{mvgam} models.
#' Currently, only low-rank Gaussian Process smooths are available for
#' estimating the dynamics of the time-varying coefficient.
#'
#' @importFrom stats terms formula reformulate
#'
#' @param variable The variable that the dynamic smooth will be a function of
#'
#' @param k Optional number of basis functions for computing approximate GPs.
#' If missing, `k` will be set as large as possible to accurately estimate
#' the nonlinear function.
#'
#' @param stationary Logical. If \code{TRUE} (the default) and `rho` is
#' supplied, the latent Gaussian Process smooth will not have a linear trend
#' component. If \code{FALSE}, a linear trend in the covariate is added to
#' the Gaussian Process smooth. Leave at \code{TRUE} if you do not believe
#' the coefficient is evolving with much trend, as the linear component of
#' the basis functions can be hard to penalize to zero. This sometimes causes
#' divergence issues in `Stan`. See \code{\link[mgcv]{gp.smooth}} for
#' details. Ignored if `rho` is missing (in which case a Hilbert space
#' approximate GP is used).
#'
#' @param rho Either a positive numeric stating the length scale to be used for
#' approximating the squared exponential Gaussian Process smooth (see
#' \code{\link[mgcv]{gp.smooth}} for details) or missing, in which case the
#' length scale will be estimated by setting up a Hilbert space approximate GP.
#'
#' @param scale Logical; If `TRUE` (the default) and `rho` is missing,
#' 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 scale is
#' `TRUE`.
#'
#' @details \code{mvgam} currently sets up dynamic coefficients as low-rank
#' squared exponential Gaussian Process smooths via the call
#' \code{s(time, by = variable, bs = "gp", m = c(2, rho, 2))}. These smooths,
#' if specified with reasonable values for the length scale parameter, will
#' give more realistic out of sample forecasts than standard splines such as
#' thin plate or cubic. But the user must set the value for `rho`, as there
#' is currently no support for estimating this value in \code{mgcv}. This may
#' not be too big of a problem, as estimating latent length scales is often
#' difficult anyway. The \code{rho} parameter should be thought of as a prior
#' on the smoothness of the latent dynamic coefficient function (where higher
#' values of \code{rho} lead to smoother functions with more temporal
#' covariance structure). Values of \code{k} are set automatically to ensure
#' enough basis functions are used to approximate the expected wiggliness of
#' the underlying dynamic function (\code{k} will increase as \code{rho}
#' decreases).
#'
#' @rdname dynamic
#'
#' @return a `list` object for internal usage in 'mvgam'
#'
#' @examples
#' \dontrun{
#' # Simulate a time-varying coefficient
#' # (as a Gaussian Process with length scale = 10)
#' set.seed(1111)
#' N <- 200
#'
#' # A function to simulate from a squared exponential Gaussian Process
#' sim_gp <- function(N, c, alpha, rho) {
#' Sigma <- alpha ^ 2 *
#' exp(-0.5 * ((outer(1:N, 1:N, "-") / rho) ^ 2)) +
#' diag(1e-9, N)
#' c + mgcv::rmvn(1, mu = rep(0, N), V = Sigma)
#' }
#'
#' beta <- sim_gp(alpha = 0.75, rho = 10, c = 0.5, N = N)
#' plot(
#' beta, type = 'l', lwd = 3, bty = 'l',
#' xlab = 'Time', ylab = 'Coefficient', col = 'darkred'
#' )
#'
#' # Simulate the predictor as a standard normal
#' predictor <- rnorm(N, sd = 1)
#'
#' # Simulate a Gaussian outcome variable
#' out <- rnorm(N, mean = 4 + beta * predictor, sd = 0.25)
#' time <- seq_along(predictor)
#' plot(
#' out, type = 'l', lwd = 3, bty = 'l',
#' xlab = 'Time', ylab = 'Outcome', col = 'darkred'
#' )
#'
#' # Gather into a data.frame and fit a dynamic coefficient model
#' data <- data.frame(out, predictor, time)
#'
#' # Split into training and testing
#' data_train <- data[1:190, ]
#' data_test <- data[191:200, ]
#'
#' # Fit a model using the dynamic function
#' mod <- mvgam(
#' out ~
#' # mis-specify the length scale slightly as this
#' # won't be known in practice
#' dynamic(predictor, rho = 8, stationary = TRUE),
#' family = gaussian(),
#' data = data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Inspect the summary
#' summary(mod)
#'
#' # Plot the time-varying coefficient estimates
#' plot(mod, type = 'smooths')
#'
#' # Extrapolate the coefficient forward in time
#' plot_mvgam_smooth(mod, smooth = 1, newdata = data)
#' abline(v = 190, lty = 'dashed', lwd = 2)
#'
#' # Overlay the true simulated time-varying coefficient
#' lines(beta, lwd = 2.5, col = 'white')
#' lines(beta, lwd = 2)
#' }
#'
#' @author Nicholas J Clark
#'
#' @export
dynamic = function(variable, k, rho = 5, stationary = TRUE, scale = TRUE) {
# Check that only one variable is supplied
vars <- as.list(substitute(list(variable)))[-1]
if (length(vars) > 1) {
stop("dynamic() can only handle one term at a time.")
}
term <- deparse(vars[[1]])
if (term[1] == ".") {
stop("dynamic(.) not supported.")
}
# Check rho
if (missing(rho)) {
rho <- NULL
} else {
if (rho <= 0) {
stop(
'Argument "rho" in dynamic() must be a positive value',
call. = FALSE
)
}
}
# Check k
if (missing(k)) {
k <- NULL
} else {
validate_pos_integer(k)
}
# Gather into a structured list and return
term <- attr(terms(reformulate(term)), "term.labels")
out <- list(
term = term,
rho = rho,
k = k,
stationary = stationary,
scale = scale
)
class(out) <- "dyncoef.spec"
return(out)
}
================================================
FILE: R/ensemble.R
================================================
#' Combine forecasts from \pkg{mvgam} models into evenly weighted ensembles
#'
#' Generate evenly weighted ensemble forecast distributions from
#' \code{mvgam_forecast} objects.
#'
#' @name ensemble.mvgam_forecast
#'
#' @param object \code{list} object of class \code{mvgam_forecast}.
#' See [forecast.mvgam()]
#'
#' @param ... More \code{mvgam_forecast} objects.
#'
#' @details It is widely recognised in the forecasting literature that
#' combining forecasts from different models often results in improved
#' forecast accuracy. The simplest way to create an ensemble is to use
#' evenly weighted combinations of forecasts from the different models.
#' This is straightforward to do in a Bayesian setting with \pkg{mvgam} as
#' the posterior MCMC draws contained in each \code{mvgam_forecast} object
#' will already implicitly capture correlations among the temporal posterior
#' predictions.
#'
#' @return An object of class \code{mvgam_forecast} containing the ensemble
#' predictions. This object can be readily used with the supplied S3
#' functions \code{plot} and \code{score}.
#'
#' @author Nicholas J Clark
#'
#' @seealso \code{\link{plot.mvgam_forecast}},
#' \code{\link{score.mvgam_forecast}}
#'
#' @examples
#' \dontrun{
#' # Simulate some series and fit a few competing dynamic models
#' set.seed(1)
#' simdat <- sim_mvgam(
#' n_series = 1,
#' prop_trend = 0.6,
#' mu = 1
#' )
#'
#' plot_mvgam_series(
#' data = simdat$data_train,
#' newdata = simdat$data_test
#' )
#'
#' m1 <- mvgam(
#' y ~ 1,
#' trend_formula = ~ time +
#' s(season, bs = 'cc', k = 9),
#' trend_model = AR(p = 1),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' newdata = simdat$data_test,
#' chains = 2,
#' silent = 2
#' )
#'
#' m2 <- mvgam(
#' y ~ time,
#' trend_model = RW(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' newdata = simdat$data_test,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Calculate forecast distributions for each model
#' fc1 <- forecast(m1)
#' fc2 <- forecast(m2)
#'
#' # Generate the ensemble forecast
#' ensemble_fc <- ensemble(fc1, fc2)
#'
#' # Plot forecasts
#' plot(fc1)
#' plot(fc2)
#' plot(ensemble_fc)
#'
#' # Score forecasts
#' score(fc1)
#' score(fc2)
#' score(ensemble_fc)
#' }
#'
#' @export
ensemble <- function(object, ...) {
UseMethod("ensemble", object)
}
#'@rdname ensemble.mvgam_forecast
#'
#'@method ensemble mvgam_forecast
#'
#'@param ndraws Positive integer specifying the number of draws to use from each
#'forecast distribution for creating the ensemble. If some of the ensemble members have
#'fewer draws than `ndraws`, their forecast distributions will be resampled with replacement
#'to achieve the correct number of draws
#'
#'@export
ensemble.mvgam_forecast <- function(object, ..., ndraws = 5000) {
models <- split_fc_dots(object, ..., model_names = NULL)
n_models <- length(models)
# Check that series names and key dimensions match for all forecasts
allsame <- function(x) length(unique(x)) == 1
if (!allsame(purrr::map(models, 'series_names'))) {
stop('Names of series must match for all forecast objects.', call. = FALSE)
}
if (!allsame(lapply(models, function(x) length(x$forecasts)))) {
stop(
'The number of forecast distributions must match for all forecast objects.',
call. = FALSE
)
}
if (!allsame(lapply(models, function(x) length(x$test_observations)))) {
stop('Validation data must match for all forecast objects.', call. = FALSE)
}
if (
!allsame(lapply(models, function(x) {
unlist(lapply(x$forecasts, function(y) dim(y)[2]), use.names = FALSE)
}))
) {
stop(
'Forecast horizons must match for all forecast objects.',
call. = FALSE
)
}
validate_pos_integer(ndraws)
# End of checks; now proceed with ensembling
n_series <- length(models[[1]]$series_names)
# Calculate total number of forecast draws to sample from for each model
n_mod_draws <- lapply(seq_len(n_models), function(x) {
NROW(models[[x]]$forecasts[[1]])
})
# Calculate model weights (only option at the moment is even weighting,
# but this may be relaxed in future)
mod_weights <- data.frame(
mod = paste0('mod', 1:n_models),
orig_weight = 1 / n_models,
ndraws = unlist(n_mod_draws, use.names = FALSE)
) %>%
# Adjust weights by the number of draws available per
# forecast, ensuring that models with fewer draws aren't
# under-represented in the final weighted ensemble
dplyr::mutate(weight = (orig_weight / ndraws) * 100) %>%
dplyr::mutate(mod = as.factor(mod)) %>%
dplyr::select(mod, weight)
# Create draw indices
mod_inds <- as.factor(unlist(
lapply(seq_len(n_models), function(x) {
rep(paste0('mod', x), NROW(models[[x]]$forecasts[[1]]))
}),
use.names = FALSE
))
all_draw_inds <- 1:sum(unlist(n_mod_draws, use.names = FALSE))
mod_inds_draws <- split(all_draw_inds, mod_inds)
# Add model-specific weights to the draw indices
draw_weights <- data.frame(draw = all_draw_inds, mod = mod_inds) %>%
dplyr::left_join(mod_weights, by = 'mod')
# Perform multinomial sampling using draw-specific weights
fc_draws <- sample(
all_draw_inds,
size = ndraws,
replace = max(all_draw_inds) < ndraws,
prob = draw_weights$weight
)
# Create weighted ensemble hindcasts and forecasts
ens_hcs <- lapply(seq_len(n_series), function(series) {
all_hcs <- do.call(rbind, lapply(models, function(x) x$hindcasts[[series]]))
all_hcs[fc_draws, ]
})
ens_fcs <- lapply(seq_len(n_series), function(series) {
all_fcs <- do.call(rbind, lapply(models, function(x) x$forecasts[[series]]))
all_fcs[fc_draws, ]
})
# Initiate the ensemble forecast object
ens_fc <- models[[1]]
# Add in hindcasts and forecasts
ens_fc$hindcasts <- ens_hcs
ens_fc$forecasts <- ens_fcs
names(ens_fc$hindcasts) <- names(models[[1]]$hindcasts)
names(ens_fc$forecasts) <- names(models[[1]]$forecasts)
# Return
return(ens_fc)
}
#'@noRd
split_fc_dots = function(x, ..., model_names = NULL, other = TRUE) {
dots <- list(x, ...)
names <- substitute(list(x, ...), env = parent.frame())[-1]
names <- ulapply(names, deparse)
if (!is.null(model_names)) {
names <- model_names
}
if (length(names)) {
if (!length(names(dots))) {
names(dots) <- names
} else {
has_no_name <- !nzchar(names(dots))
names(dots)[has_no_name] <- names[has_no_name]
}
}
is_mvgam_fc <- unlist(lapply(dots, function(y) inherits(y, 'mvgam_forecast')))
models <- dots[is_mvgam_fc]
out <- dots[!is_mvgam_fc]
if (length(out)) {
stop(
"Only mvgam_forecast objects can be passed to '...' for this method.",
call. = FALSE
)
}
models
}
================================================
FILE: R/evaluate_mvgams.R
================================================
#' Evaluate forecasts from fitted \pkg{mvgam} objects
#'
#' @importFrom graphics barplot boxplot axis
#' @importFrom stats quantile ecdf median predict
#' @importFrom grDevices devAskNewPage
#' @importFrom utils lsf.str
#'
#' @param object \code{list} object returned from \code{mvgam}
#'
#' @param n_samples \code{integer} specifying the number of samples to generate
#' from the model's posterior distribution
#'
#' @param eval_timepoint \code{integer} indexing the timepoint that represents
#' our last 'observed' set of outcome data
#'
#' @param fc_horizon \code{integer} specifying the length of the forecast
#' horizon for evaluating forecasts
#'
#' @param n_cores Deprecated. Parallel processing is no longer supported
#'
#' @param score \code{character} specifying the type of ranked probability score
#' to use for evaluation. Options are: `variogram`, `drps` or `crps`
#'
#' @param log \code{logical}. Should the forecasts and truths be logged prior
#' to scoring? This is often appropriate for comparing performance of models
#' when series vary in their observation ranges
#'
#' @param weights optional \code{vector} of weights (where
#' \code{length(weights) == n_series}) for weighting pairwise correlations
#' when evaluating the variogram score for multivariate forecasts. Useful for
#' down-weighting series that have larger magnitude observations or that are
#' of less interest when forecasting. Ignored if \code{score != 'variogram'}
#'
#' @details `eval_mvgam` may be useful when both repeated fitting of a model
#' using \code{\link{update.mvgam}} for exact leave-future-out cross-validation
#' and approximate leave-future-out cross-validation using \code{\link{lfo_cv}}
#' are impractical. The function generates a set of samples representing fixed
#' parameters estimated from the full \code{mvgam} model and latent trend states
#' at a given point in time. The trends are rolled forward a total of
#' \code{fc_horizon} timesteps according to their estimated state space dynamics
#' to generate an 'out-of-sample' forecast that is evaluated against the true
#' observations in the horizon window. This function therefore simulates a
#' situation where the model's parameters had already been estimated but we have
#' only observed data up to the evaluation timepoint and would like to generate
#' forecasts from the latent trends that have been observed up to that timepoint.
#' Evaluation involves calculating an appropriate Rank Probability Score and a
#' binary indicator for whether or not the true value lies within the forecast's
#' 90% prediction interval
#'
#' `roll_eval_mvgam` sets up a sequence of evaluation timepoints along a rolling
#' window and iteratively calls \code{eval_mvgam} to evaluate 'out-of-sample'
#' forecasts. Evaluation involves calculating the Rank Probability Scores and a
#' binary indicator for whether or not the true value lies within the forecast's
#' 90% prediction interval
#'
#' `compare_mvgams` automates the evaluation to compare two fitted models using
#' rolling window forecast evaluation and provides a series of summary plots to
#' facilitate model selection. It is essentially a wrapper for
#' \code{roll_eval_mvgam}
#'
#' @return For `eval_mvgam`, a \code{list} object containing information on
#' specific evaluations for each series (if using `drps` or `crps` as the score)
#' or a vector of scores when using `variogram`.
#'
#' For `roll_eval_mvgam`, a \code{list} object containing information on specific
#' evaluations for each series as well as a total evaluation summary (taken by
#' summing the forecast score for each series at each evaluation and averaging
#' the coverages at each evaluation)
#'
#' For `compare_mvgams`, a series of plots comparing forecast Rank Probability
#' Scores for each competing model. A lower score is preferred. Note however
#' that it is possible to select a model that ultimately would perform poorly
#' in true out-of-sample forecasting. For example if a wiggly smooth function
#' of 'year' is included in the model then this function will be learned prior
#' to evaluating rolling window forecasts, and the model could generate very
#' tight predictions as a result. But when forecasting ahead to timepoints that
#' the model has not seen (i.e. next year), the smooth function will end up
#' extrapolating, sometimes in very strange and unexpected ways. It is therefore
#' recommended to only use smooth functions for covariates that are adequately
#' measured in the data (i.e. 'seasonality', for example) to reduce possible
#' extrapolation of smooths and let the latent trends in the \code{mvgam} model
#' capture any temporal dependencies in the data. These trends are time series
#' models and so will provide much more stable forecasts
#'
#' @seealso \code{\link{forecast}}, \code{\link{score}}, \code{\link{lfo_cv}}
#'
#' @examples
#' \dontrun{
#' # Simulate from a Poisson-AR2 model with a seasonal smooth
#' set.seed(1)
#' dat <- sim_mvgam(
#' T = 75,
#' n_series = 1,
#' prop_trend = 0.75,
#' trend_model = AR(p = 2),
#' family = poisson()
#' )
#'
#' # Fit an appropriate model
#' mod_ar2 <- mvgam(
#' formula = y ~ s(season, bs = 'cc'),
#' trend_model = AR(p = 2),
#' family = poisson(),
#' data = dat$data_train,
#' newdata = dat$data_test,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Fit a less appropriate model
#' mod_rw <- mvgam(
#' formula = y ~ 1,
#' trend_model = RW(),
#' family = poisson(),
#' data = dat$data_train,
#' newdata = dat$data_test,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Compare Discrete Ranked Probability Scores for the testing period
#' fc_ar2 <- forecast(mod_ar2)
#' fc_rw <- forecast(mod_rw)
#' score_ar2 <- score(
#' object = fc_ar2,
#' score = 'drps'
#' )
#' score_rw <- score(
#' object = fc_rw,
#' score = 'drps'
#' )
#' sum(score_ar2$series_1$score)
#' sum(score_rw$series_1$score)
#'
#' # Use rolling evaluation for approximate comparisons of 3-step ahead
#' # forecasts across the training period
#' compare_mvgams(
#' model1 = mod_ar2,
#' model2 = mod_rw,
#' fc_horizon = 3,
#' n_samples = 1000,
#' n_evaluations = 5
#' )
#'
#' # A more appropriate comparison would be to use approximate
#' # leave-future-out CV to compare forecasts (see ?mvgam::lfo_cv())
#' }
#' @name evaluate_mvgams
NULL
#' @rdname evaluate_mvgams
#' @export
eval_mvgam = function(
object,
n_samples = 5000,
eval_timepoint = 3,
fc_horizon = 3,
n_cores = 1,
score = 'drps',
log = FALSE,
weights
) {
# Check arguments
if (!(inherits(object, 'mvgam'))) {
stop('argument "object" must be of class "mvgam"')
}
if (attr(object$model_data, 'trend_model') == 'None') {
stop(
'cannot compute rolling forecasts for mvgams that have no trend model',
call. = FALSE
)
}
validate_pos_integer(fc_horizon)
validate_pos_integer(eval_timepoint)
validate_pos_integer(n_cores)
if (n_cores > 1L) {
message('argument "n_cores" is deprecated')
}
validate_pos_integer(n_samples)
if (eval_timepoint < 3) {
stop('argument "eval_timepoint" must be >= 3', call. = FALSE)
}
#### 1. Prepare the data at the right timepoint ####
data_train <- object$obs_data
n_series <- NCOL(object$ytimes)
# Check evaluation timepoint
if (inherits(object$obs_data, 'list')) {
all_times <- (data.frame(time = object$obs_data$time) %>%
dplyr::select(time) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::mutate(time = dplyr::row_number())) %>%
dplyr::pull(time)
} else {
all_times <- (object$obs_data %>%
dplyr::select(time) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::mutate(time = dplyr::row_number())) %>%
dplyr::pull(time)
}
if (!eval_timepoint %in% all_times) {
stop('Evaluation timepoint does not exist in original training data')
}
# Filter training data to correct point (just following evaluation timepoint)
data.frame(time = object$obs_data$time, series = object$obs_data$series) %>%
dplyr::mutate(row_number = dplyr::row_number()) %>%
dplyr::left_join(
data.frame(time = object$obs_data$time, series = object$obs_data$series),
by = c('time', 'series')
) %>%
dplyr::arrange(time, series) %>%
dplyr::filter(
time > (eval_timepoint) &
time <= (eval_timepoint + fc_horizon)
) %>%
dplyr::pull(row_number) -> assim_rows
if (inherits(object$obs_data, 'list')) {
data_assim <- lapply(object$obs_data, function(x) {
if (is.matrix(x)) {
matrix(x[assim_rows, ], ncol = NCOL(x))
} else {
x[assim_rows]
}
})
} else {
object$obs_data[assim_rows, ] -> data_assim
}
#### 2. Generate the forecast distribution ####
draw_fcs <- forecast_draws(
object = object,
type = 'response',
series = 'all',
data_test = data_assim,
n_samples = n_samples,
ending_time = eval_timepoint,
n_cores = n_cores
)
if (missing(weights)) {
weights <- rep(1, NCOL(object$ytimes))
}
# Final forecast distribution
series_fcs <- lapply(seq_len(n_series), function(series) {
indexed_forecasts <- do.call(
rbind,
lapply(seq_along(draw_fcs), function(x) {
draw_fcs[[x]][[series]]
})
)
indexed_forecasts
})
names(series_fcs) <- levels(data_assim$series)
# If variogram score is chosen
if (score == 'variogram') {
# Get truths (out of sample) into correct format
truths <- do.call(
rbind,
lapply(seq_len(n_series), function(series) {
s_name <- levels(data_assim$series)[series]
data.frame(
series = data_assim$series,
y = data_assim$y,
time = data_assim$time
) %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
})
)
series_score <- variogram_mcmc_object(
truths = truths,
fcs = series_fcs,
log = log,
weights = weights
)
}
# If not using variogram score
if (score != 'variogram') {
# Evaluate against the truth
series_truths <- lapply(seq_len(n_series), function(series) {
if (class(object$obs_data)[1] == 'list') {
data_assim[['y']][which(as.numeric(data_assim$series) == series)]
} else {
data_assim[which(as.numeric(data_assim$series) == series), 'y']
}
})
# Calculate score and interval coverage per series
if (
object$family %in%
c('poisson', 'negative binomial', 'binomial', 'beta_binomial')
) {
series_score <- lapply(seq_len(n_series), function(series) {
DRPS <- data.frame(drps_mcmc_object(
as.vector(as.matrix(series_truths[[series]])),
series_fcs[[series]],
log = log
))
colnames(DRPS) <- c('score', 'in_interval')
DRPS$eval_horizon <- seq(1, fc_horizon)
DRPS
})
names(series_score) <- levels(data_assim$series)
} else {
series_score <- lapply(seq_len(n_series), function(series) {
CRPS <- data.frame(crps_mcmc_object(
as.vector(as.matrix(series_truths[[series]])),
series_fcs[[series]],
log = log
))
colnames(CRPS) <- c('score', 'in_interval')
if (log) {
CRPS$score <- log(CRPS$score + 0.0001)
}
CRPS$eval_horizon <- seq(1, fc_horizon)
CRPS
})
names(series_score) <- levels(data_assim$series)
}
}
return(series_score)
}
#' @param object \code{list} object returned from \code{mvgam}
#'
#' @param n_samples \code{integer} specifying the number of samples to generate
#' from the model's posterior distribution
#'
#' @param evaluation_seq Optional \code{integer sequence} specifying the exact
#' set of timepoints for evaluating the model's forecasts. This sequence
#' cannot have values \code{<3} or
#' \code{> max(training timepoints) - fc_horizon}
#'
#' @param n_evaluations \code{integer} specifying the total number of
#' evaluations to perform (ignored if \code{evaluation_seq} is supplied)
#'
#' @param fc_horizon \code{integer} specifying the length of the forecast
#' horizon for evaluating forecasts
#'
#' @param n_cores Deprecated. Parallel processing is no longer supported
#'
#' @rdname evaluate_mvgams
#'
#' @export
roll_eval_mvgam = function(
object,
n_evaluations = 5,
evaluation_seq,
n_samples = 5000,
fc_horizon = 3,
n_cores = 1,
score = 'drps',
log = FALSE,
weights
) {
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
if (attr(object$model_data, 'trend_model') == 'None') {
stop(
'cannot compute rolling forecasts for mvgams that have no trend model',
call. = FALSE
)
}
validate_pos_integer(n_cores)
if (n_cores > 1L) {
message('argument "n_cores" is deprecated')
}
validate_pos_integer(n_evaluations)
validate_pos_integer(n_samples)
validate_pos_integer(fc_horizon)
# Generate time variable from training data
if (inherits(object$obs_data, 'list')) {
all_timepoints <- (data.frame(time = object$obs_data$index..time..index) %>%
dplyr::select(time) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::mutate(time = dplyr::row_number())) %>%
dplyr::pull(time)
} else {
all_timepoints <- (object$obs_data %>%
dplyr::select(index..time..index) %>%
dplyr::distinct() %>%
dplyr::arrange(index..time..index) %>%
dplyr::mutate(time = dplyr::row_number())) %>%
dplyr::pull(time)
}
# Generate evaluation sequence if not supplied
if (missing(evaluation_seq)) {
evaluation_seq <- floor(seq(
from = 3,
to = (max(all_timepoints) - fc_horizon),
length.out = n_evaluations
))
}
# Check evaluation sequence
if (min(evaluation_seq) < 3) {
stop('Evaluation sequence cannot start before timepoint 3')
}
if (max(evaluation_seq) > (max(all_timepoints) - fc_horizon)) {
stop(
'Maximum of evaluation sequence is too large for fc_horizon evaluations'
)
}
# Loop across evaluation sequence and calculate evaluation metrics
if (missing(weights)) {
weights <- rep(1, NCOL(object$ytimes))
}
evals <- lapply(evaluation_seq, function(timepoint) {
eval_mvgam(
object = object,
n_samples = n_samples,
n_cores = 1,
eval_timepoint = timepoint,
fc_horizon = fc_horizon,
score = score,
log = log,
weights = weights
)
})
# Take sum of score at each evaluation point for multivariate models
sum_or_na = function(x) {
if (all(is.na(x))) {
NA
} else {
sum(x, na.rm = T)
}
}
if (score == 'variogram') {
eval_horizons <- do.call(
rbind,
lapply(seq_along(evals), function(x) {
data.frame(seq_along(evals[[x]]))
})
)
scores <- do.call(
rbind,
lapply(seq_along(evals), function(x) {
data.frame(evals[[x]])
})
)
evals_df <- data.frame(
score = scores,
eval_horizon = eval_horizons,
in_interval = NA
)
colnames(evals_df) <- c('score', 'eval_horizon', 'in_interval')
# Calculate summary statistics for each series
out <- list(
sum_score = sum_or_na(evals_df$score),
score_summary = summary(evals_df$score),
score_horizon_summary = evals_df %>%
dplyr::group_by(eval_horizon) %>%
dplyr::summarise(median_score = median(score, na.rm = T)),
interval_coverage = NA,
series_evals = NA,
all_scores = evals_df
)
} else {
evals_df <- do.call(rbind, do.call(rbind, evals)) %>%
dplyr::group_by(eval_horizon) %>%
dplyr::summarise(
score = sum_or_na(score),
in_interval = mean(in_interval, na.rm = T)
)
# Calculate summary statistics for each series
tidy_evals <- lapply(
seq_len(length(levels(object$obs_data$series))),
function(series) {
all_evals <- do.call(
rbind,
purrr::map(evals, levels(object$obs_data$series)[series])
)
list(
sum_drps = sum_or_na(all_evals$score),
score_summary = summary(all_evals$score),
score_horizon_summary = all_evals %>%
dplyr::group_by(eval_horizon) %>%
dplyr::summarise(median_score = mean(score, na.rm = T)),
interval_coverage = mean(all_evals$in_interval, na.rm = T),
all_scores = all_evals
)
}
)
names(tidy_evals) <- levels(object$obs_data$series)
out <- list(
sum_score = sum_or_na(evals_df$score),
score_summary = summary(evals_df$score),
score_horizon_summary = evals_df %>%
dplyr::group_by(eval_horizon) %>%
dplyr::summarise(median_score = median(score, na.rm = T)),
interval_coverage = mean(evals_df$in_interval, na.rm = T),
series_evals = tidy_evals
)
}
# Return score summary statistics
return(out)
}
#' @param model1 \code{list} object returned from \code{mvgam} representing
#' the first model to be evaluated
#'
#' @param model2 \code{list} object returned from \code{mvgam} representing
#' the second model to be evaluated
#'
#' @param n_samples \code{integer} specifying the number of samples to generate
#' from the model's posterior distribution
#'
#' @param fc_horizon \code{integer} specifying the length of the forecast
#' horizon for evaluating forecasts
#'
#' @param n_evaluations \code{integer} specifying the total number of
#' evaluations to perform
#'
#' @param n_cores Deprecated. Parallel processing is no longer supported
#'
#' @rdname evaluate_mvgams
#'
#' @export
compare_mvgams = function(
model1,
model2,
n_samples = 1000,
fc_horizon = 3,
n_evaluations = 10,
n_cores = 1,
score = 'drps',
log = FALSE,
weights
) {
# Check arguments
if (!(inherits(model1, "mvgam"))) {
stop('argument "model1" must be of class "mvgam"')
}
if (!(inherits(model2, "mvgam"))) {
stop('argument "model2" must be of class "mvgam"')
}
if (attr(model2$model_data, 'trend_model') == 'None') {
stop(
'cannot compare rolling forecasts for mvgams that have no trend model',
call. = FALSE
)
}
if (attr(model1$model_data, 'trend_model') == 'None') {
stop(
'cannot compare rolling forecasts for mvgams that have no trend model',
call. = FALSE
)
}
validate_pos_integer(n_evaluations)
validate_pos_integer(fc_horizon)
validate_pos_integer(n_cores)
if (n_cores > 1L) {
message('argument "n_cores" is deprecated')
}
validate_pos_integer(n_samples)
# Evaluate the two models
if (missing(weights)) {
weights <- rep(1, NCOL(model1$ytimes))
}
mod1_eval <- roll_eval_mvgam(
model1,
n_samples = n_samples,
fc_horizon = fc_horizon,
n_cores = n_cores,
n_evaluations = n_evaluations,
score = score,
log = log,
weights = weights
)
mod2_eval <- roll_eval_mvgam(
model2,
n_samples = n_samples,
fc_horizon = fc_horizon,
n_cores = n_cores,
n_evaluations = n_evaluations,
score = score,
log = log,
weights = weights
)
# Generate a simple summary of forecast scores for each model
model_summary <- rbind(mod1_eval$score_summary, mod2_eval$score_summary)
rownames(model_summary) <- c('Model 1', 'Model 2')
cat('RPS summaries per model (lower is better)\n')
print(model_summary)
# Print 90% interval coverages for each model
if (score != 'variogram') {
cat('\n90% interval coverages per model (closer to 0.9 is better)\n')
cat('Model 1', mod1_eval$interval_coverage, '\n')
cat('Model 2', mod2_eval$interval_coverage)
}
# Set up plotting loop and return summary plots of DRPS
ask <- TRUE
for (i in 1:3) {
if (i == 1) {
barplot(
c('model 1' = mod1_eval$sum_score, 'model 2' = mod2_eval$sum_score),
col = c("#B97C7C", "#7C0000"),
border = NA,
ylab = 'Sum RPS (lower is better)',
lwd = 2
)
} else if (i == 2) {
boxplot(
list(
'model 1' = mod1_eval$score_summary,
'model 2' = mod2_eval$score_summary
),
border = c("#B97C7C", "#7C0000"),
ylab = 'Sum RPS per evaluation',
axes = FALSE
)
axis(side = 2, lwd = 2)
axis(side = 1, at = c(1, 2), labels = c('model 1', 'model 2'), lwd = 0)
} else {
plot_dat <- rbind(
mod1_eval$score_horizon_summary$median_score,
mod2_eval$score_horizon_summary$median_score
)
colnames(plot_dat) <- seq(1:NCOL(plot_dat))
ylim = c(
min(0, min(plot_dat, na.rm = TRUE)),
max(plot_dat, na.rm = T) * 1.4
)
barplot(
plot_dat,
ylim = ylim,
beside = T,
xlab = 'Forecast horizon',
ylab = 'Median RPS',
col = c("#B97C7C", "#7C0000"),
lwd = 2,
border = NA,
legend.text = c('Model 1', 'Model 2'),
args.legend = list(x = "top", ncol = 2, border = NA, bty = 'n')
)
}
if (ask) {
oask <- devAskNewPage(TRUE)
on.exit(devAskNewPage(oask))
ask <- FALSE
}
}
invisible()
}
#' @noRd
crps_edf <- function(y, dat, w = NULL) {
if (is.null(w)) {
c_1n <- 1 / length(dat)
x <- sort(dat)
a <- seq.int(0.5 * c_1n, 1 - 0.5 * c_1n, length.out = length(dat))
f <- function(s) 2 * c_1n * sum(((s < x) - a) * (x - s))
} else {
if (!identical(length(dat), length(w)) || any(w < 0, na.rm = TRUE)) {
return(rep(NaN, length(y)))
}
ord <- order(dat)
x <- dat[ord]
w <- w[ord]
p <- cumsum(w)
P <- p[length(p)]
a <- (p - 0.5 * w) / P
f <- function(s) 2 / P * sum(w * ((s < x) - a) * (x - s))
}
sapply(y, f)
}
# Compute CRPS
# code borrowed from scoringRules: https://github.com/FK83/scoringRules/blob/master/R/scores_sample_univ.R
#' @noRd
crps_score <- function(
truth,
fc,
method = "edf",
w = NULL,
interval_width = 0.9,
log = FALSE
) {
if (log) {
truth <- log(truth + 0.001)
fc <- log(fc + 0.001)
}
if (identical(length(truth), 1L) && is.vector(fc)) {
score <- crps_edf(truth, fc, w)
} else {
score <- sapply(
seq_along(truth),
function(i) crps_edf(truth[i], fc[i, ], w[i, ])
)
}
# Is value within empirical interval?
interval <- quantile(
fc,
probs = c(
(1 - interval_width) / 2,
(interval_width + (1 - interval_width) / 2)
),
na.rm = TRUE
)
in_interval <- ifelse(truth <= interval[2] & truth >= interval[1], 1, 0)
return(c(score, in_interval))
}
# Compute DRPS
#' @noRd
drps_score <- function(truth, fc, interval_width = 0.9, log = FALSE) {
if (log) {
truth <- log(truth + 0.001)
fc <- log(fc + 0.001)
nsum <- max(c(truth, fc), na.rm = TRUE) + 5
} else {
nsum <- max(
c(truth, quantile(fc, probs = 0.99, na.rm = TRUE)),
na.rm = TRUE
) +
1000
}
Fy = ecdf(fc)
ysum <- 0:nsum
indicator <- ifelse(ysum - truth >= 0, 1, 0)
score <- sum((indicator - Fy(ysum))^2)
# Is value within empirical interval?
interval <- quantile(
fc,
probs = c(
(1 - interval_width) / 2,
(interval_width + (1 - interval_width) / 2)
),
na.rm = TRUE
)
in_interval <- ifelse(truth <= interval[2] & truth >= interval[1], 1, 0)
return(c(score, in_interval))
}
# Compute the scaled interval score
#' @noRd
sis_score <- function(truth, fc, interval_width = 0.9, log = FALSE) {
if (log) {
truth <- log(truth + 0.001)
fc <- log(fc + 0.001)
}
lower_prob <- (1 - interval_width) / 2
upper_prob <- 1 - lower_prob
creds <- quantile(fc, probs = c(lower_prob, upper_prob), na.rm = TRUE)
cred_lower <- creds[1]
cred_upper <- creds[2]
alpha <- 2 / (2 * lower_prob)
cred_interval <- (cred_upper - cred_lower) / 2
err_up <- truth - cred_upper
err_low <- cred_lower - truth
# SIS
score <- 2 *
cred_interval +
alpha * err_up * (err_up > 0) +
alpha * err_low * (err_low > 0)
# Is value within empirical interval?
interval <- quantile(
fc,
probs = c(
(1 - interval_width) / 2,
(interval_width + (1 - interval_width) / 2)
),
na.rm = TRUE
)
in_interval <- ifelse(truth <= interval[2] & truth >= interval[1], 1, 0)
return(c(score, in_interval))
}
# Compute the Brier score
#' @noRd
brier_score <- function(truth, fc, interval_width = 0.9) {
score <- (truth - fc)^2
score <- sum(score) / length(score)
# Cannot evaluate coverage for binary truths
in_interval <- NA
return(c(score, in_interval))
}
#' Compute the multivariate energy score
#' @noRd
energy_score <- function(truth, fc, log = FALSE) {
insight::check_if_installed(
"scoringRules",
reason = 'to calculate energy scores'
)
# es_sample can't handle any NAs
has_nas <- apply(fc, 2, function(x) any(is.na(x)))
fc <- fc[, !has_nas]
if (log) {
truth <- log(truth + 0.001)
fc <- log(fc + 0.001)
}
es <- scoringRules::es_sample(y = truth, dat = fc)
return(es)
}
#' Compute the variogram score, using the median pairwise difference
#' from the forecast distribution (scoringRules::vs_sample uses the
#' mean, which is not appropriate for skewed distributions)
#' @noRd
variogram_score = function(truth, fc, log = FALSE, weights) {
if (log) {
truth <- log(truth + 0.001)
fc <- log(fc + 0.001)
}
# Use weight of 1 for each pairwise combination if no weights
# are supplied; else take the product of each pair of weights
if (missing(weights)) {
weights <- matrix(1, nrow = length(truth), ncol = length(truth))
} else {
weights <- outer(weights, weights, FUN = function(X, Y) {
(X + Y) / 2
})
}
out <- matrix(NA, length(truth), length(truth))
for (i in 1:length(truth)) {
for (j in 1:length(truth)) {
if (i == j) {
out[i, j] <- 0
} else {
v_fc <- quantile(abs(fc[i, ] - fc[j, ])^0.5, 0.5, na.rm = TRUE)
v_dat <- abs(truth[i] - truth[j])^0.5
out[i, j] <- 2 * weights[i, j] * ((v_dat - v_fc)^2)
}
}
}
# Divide by two as we have (inefficiently) computed each pairwise
# comparison twice
score <- sum(out) / 2
}
#' Compute the energy score on all observations in fc_horizon
#' @noRd
energy_mcmc_object <- function(truths, fcs, log = FALSE, weights) {
fc_horizon <- length(fcs[[1]][1, ])
fcs_per_horizon <- lapply(seq_len(fc_horizon), function(horizon) {
do.call(
rbind,
lapply(seq_along(fcs), function(fc) {
fcs[[fc]][, horizon]
})
)
})
unlist(lapply(seq_len(fc_horizon), function(horizon) {
energy_score(
truth = truths[, horizon],
fc = fcs_per_horizon[[horizon]],
log = log
)
}))
}
#' Compute the Brier score on all observations in fc_horizon
#' @noRd
brier_mcmc_object <- function(truth, fc, log = FALSE, weights) {
indices_keep <- which(!is.na(truth))
if (length(indices_keep) == 0) {
scores = data.frame(
'brier' = rep(NA, length(truth)),
'interval' = rep(NA, length(truth))
)
} else {
scores <- matrix(NA, nrow = length(truth), ncol = 2)
for (i in indices_keep) {
scores[i, ] <- brier_score(truth = as.vector(truth)[i], fc = fc[, i])
}
}
scores
}
#' Wrapper to calculate variogram score on all observations in fc_horizon
#' @noRd
variogram_mcmc_object <- function(truths, fcs, log = FALSE, weights) {
fc_horizon <- length(fcs[[1]][1, ])
fcs_per_horizon <- lapply(seq_len(fc_horizon), function(horizon) {
do.call(
rbind,
lapply(seq_along(fcs), function(fc) {
fcs[[fc]][, horizon]
})
)
})
unlist(lapply(seq_len(fc_horizon), function(horizon) {
variogram_score(
truth = truths[, horizon],
fc = fcs_per_horizon[[horizon]],
log = log,
weights = weights
)
}))
}
# Wrapper to calculate DRPS scores on all observations in fc_horizon
#' @noRd
drps_mcmc_object <- function(truth, fc, interval_width = 0.9, log = FALSE) {
indices_keep <- which(!is.na(truth))
if (length(indices_keep) == 0) {
scores = data.frame(
'drps' = rep(NA, length(truth)),
'interval' = rep(NA, length(truth))
)
} else {
scores <- matrix(NA, nrow = length(truth), ncol = 2)
for (i in indices_keep) {
scores[i, ] <- drps_score(
truth = as.vector(truth)[i],
fc = fc[, i],
interval_width,
log = log
)
}
}
scores
}
# Wrapper to calculate %
#' # add 'series' information, which is an identifier of site, replicate
#' # and species
#' dplyr::mutate(
#' series = paste0(
#' 'site_', site,
#' '_', species,
#' '_rep_', replicate
#' ),
#' time = as.numeric(time),
#' # add a 'cap' variable that defines the maximum latent N to
#' # marginalize over when estimating latent abundance; in other words
#' # how large do we realistically think the true abundance could be?
#' cap = 80
#' ) %>%
#' dplyr::select(-replicate) -> testdat
#'
#' # Now add another species that has a different temporal trend and a
#' # smaller detection probability (0.45 for this species)
#' testdat <- testdat %>%
#' dplyr::bind_rows(
#' data.frame(
#' site = 1,
#' replicate = rep(1:5, 6),
#' time = sort(rep(1:6, 5)),
#' species = 'sp_2',
#' truth = c(
#' rep(4, 5),
#' rep(7, 5),
#' rep(15, 5),
#' rep(16, 5),
#' rep(19, 5),
#' rep(18, 5)
#' ),
#' obs = c(
#' rbinom(5, 4, 0.45),
#' rbinom(5, 7, 0.45),
#' rbinom(5, 15, 0.45),
#' rbinom(5, 16, 0.45),
#' rbinom(5, 19, 0.45),
#' rbinom(5, 18, 0.45)
#' )
#' ) %>%
#' dplyr::mutate(
#' series = paste0(
#' 'site_', site,
#' '_', species,
#' '_rep_', replicate
#' ),
#' time = as.numeric(time),
#' cap = 50
#' ) %>%
#' dplyr::select(-replicate)
#' )
#'
#' # series identifiers
#' testdat$species <- factor(
#' testdat$species,
#' levels = unique(testdat$species)
#' )
#' testdat$series <- factor(
#' testdat$series,
#' levels = unique(testdat$series)
#' )
#'
#' # The trend_map to state how replicates are structured
#' testdat %>%
#' # each unique combination of site*species is a separate process
#' dplyr::mutate(
#' trend = as.numeric(factor(paste0(site, species)))
#' ) %>%
#' dplyr::select(trend, series) %>%
#' dplyr::distinct() -> trend_map
#' trend_map
#'
#' # Fit a model
#' mod <- mvgam(
#' # the observation formula sets up linear predictors for
#' # detection probability on the logit scale
#' formula = obs ~ species - 1,
#'
#' # the trend_formula sets up the linear predictors for
#' # the latent abundance processes on the log scale
#' trend_formula = ~ s(time, by = trend, k = 4) + species,
#'
#' # the trend_map takes care of the mapping
#' trend_map = trend_map,
#'
#' # nmix() family and data
#' family = nmix(),
#' data = testdat,
#'
#' # priors can be set in the usual way
#' priors = c(
#' prior(std_normal(), class = b),
#' prior(normal(1, 1.5), class = Intercept_trend)
#' ),
#' chains = 2
#' )
#'
#' # The usual diagnostics
#' summary(mod)
#'
#' # Plotting conditional effects
#' library(ggplot2)
#'
#' plot_predictions(
#' mod,
#' condition = 'species',
#' type = 'detection'
#' ) +
#' ylab('Pr(detection)') +
#' ylim(c(0, 1)) +
#' theme_classic() +
#' theme(legend.position = 'none')
#'
#' # =============================================================================
#' # Binomial Models
#' # =============================================================================
#'
#' # Simulate two time series of Binomial trials
#' trials <- sample(c(20:25), 50, replace = TRUE)
#' x <- rnorm(50)
#' detprob1 <- plogis(-0.5 + 0.9 * x)
#' detprob2 <- plogis(-0.1 - 0.7 * x)
#' dat <- rbind(
#' data.frame(
#' y = rbinom(n = 50, size = trials, prob = detprob1),
#' time = 1:50,
#' series = 'series1',
#' x = x,
#' ntrials = trials
#' ),
#' data.frame(
#' y = rbinom(n = 50, size = trials, prob = detprob2),
#' time = 1:50,
#' series = 'series2',
#' x = x,
#' ntrials = trials
#' )
#' )
#' dat <- dplyr::mutate(dat, series = as.factor(series))
#' dat <- dplyr::arrange(dat, time, series)
#'
#' # Fit a model using the binomial() family; must specify observations
#' # and number of trials in the cbind() wrapper
#' mod <- mvgam(
#' cbind(y, ntrials) ~ series + s(x, by = series),
#' family = binomial(),
#' data = dat
#' )
#' summary(mod)
#' }
#'
#' @export
nmix = function(link = 'log') {
linktemp <- make.link('log')
structure(
list(
family = "nmix",
link = 'log',
linkfun = linktemp$linkfun,
linkinv = linktemp$linkinv,
mu.eta = linktemp$mu.eta,
valideta = linktemp$valideta
),
class = c("extended.family", "family")
)
}
#### Non-exported functions for performing family-specific tasks ####
#' Family options in character format
#' @noRd
family_char_choices = function() {
c(
'negative binomial',
"poisson",
"binomial",
'beta_binomial',
"bernoulli",
"nmix",
"tweedie",
"beta",
"gaussian",
"lognormal",
"student",
"Gamma"
)
}
# Convert location / precision parameters to shape parameters for the beta distribution
# Original author: Andrew Heiss (https://www.andrewheiss.com/blog/2021/11/08/beta-regression-guide/)
#' @noRd
beta_shapes = function(mu, phi) {
return(list(shape1 = mu * phi, shape2 = (1 - mu) * phi))
}
# Calculate all possible Poisson log-densities for N-mixture simulation
#' @noRd
pois_dens = function(min_cap, max_cap, lambdas) {
# Identify which indices share the exact same lambda AND
# k value so that we only need to run dpois once for each group
data.frame(lambdas, min_cap, max_cap) %>%
dplyr::group_by(lambdas) %>%
dplyr::summarise(
min_cap = min(min_cap, na.rm = TRUE),
max_cap = max(max_cap, na.rm = TRUE)
) -> group_inds
l <- mapply(`:`, group_inds$min_cap, group_inds$max_cap)
data.frame(
k = unlist(l),
lambda = group_inds$lambdas[rep(1:nrow(group_inds), lengths(l))]
) %>%
dplyr::mutate(pois_dens = dpois(k, lambda, log = TRUE)) -> all_ks
return(all_ks)
}
#' Generic prediction function
#' @importFrom stats predict
#' @param Xp A `mgcv` linear predictor matrix
#' @param family \code{character}. The `family` slot of the model's family argument
#' @param betas Vector of regression coefficients of length `NCOL(Xp)`
#' @param latent_lambdas Optional vector of latent abundance estimates, only used for N-Mixture models
#' @param cap Optional vector of latent abundance maximum capacities, only used for N-Mixture models
#' @param type Either `link`, `expected`, `response`, `variance`,
#' `latent_N` (only applies to N-mixture distributions) or
#' `detection` (only applies to N-mixture distributions)
#' @param family_pars Additional arguments for each specific observation process (i.e.
#' overdispersion parameter if `family == "nb"`)
#' @param density logical. Rather than calculating a prediction, evaluate the log-likelihood.
#' Use this option when particle filtering
#' @param truth Observation to use for evaluating the likelihood (if `density == TRUE`)
#' @details A generic prediction function that will make it easier to add new
#' response distributions in future. Use `type = variance` for computing family-level
#' variance as a function of the mean
#' @noRd
mvgam_predict = function(
Xp,
family,
betas,
latent_lambdas,
cap,
min_cap,
type = 'link',
family_pars,
density = FALSE,
truth = NULL
) {
if (type == 'latent_N' & family != 'nmix') {
stop('"latent_N" type only available for N-mixture models', call. = FALSE)
}
if (type == 'detection' & family != 'nmix') {
stop('"detection" type only available for N-mixture models', call. = FALSE)
}
# Poisson-Binomial N-Mixture (requires family parameter
# 'cap' as well as 'latent_lambdas' argument)
if (family == 'nmix') {
insight::check_if_installed(
"extraDistr",
reason = 'to simulate from N-Mixture distributions'
)
insight::check_if_installed(
"wrswoR",
reason = 'to simulate from N-Mixture distributions'
)
# Calculate detection probability and convert to probability scale
p <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
p <- plogis(p)
# Latent mean of State vector
lambdas <- as.vector(latent_lambdas)
# User-specified cap on latent abundance
cap <- as.vector(cap)
if (type == 'detection') {
out <- p
} else if (type == 'link') {
# 'link' predictions are expectations of the latent abundance
out <- lambdas
if (density) {
out <- unlist(
lapply(seq_along(truth), function(i) {
if (is.na(truth[i])) {
output <- NA
} else {
ks <- truth[i]:cap[i]
lik_binom <- dbinom(truth[i], size = ks, prob = p[i], log = TRUE)
lik_poisson <- dpois(x = ks, lambda = lambdas[i], log = TRUE)
loglik <- lik_binom + lik_poisson
output <- log_sum_exp(loglik)
}
output
}),
use.names = FALSE
)
}
} else if (type == 'latent_N') {
if (missing(min_cap)) {
min_cap <- 0
}
min_cap <- as.vector(min_cap)
if (missing(truth)) {
out <- extraDistr::rtpois(
n = length(lambdas),
lambda = lambdas,
a = min_cap,
b = cap
)
} else {
# If true observed N is supplied, we can calculate the
# most likely latent N given the covariates and the estimated
# detection probability
out <- unlist(
lapply(seq_along(truth), function(i) {
if (is.na(truth[i])) {
output <- NA
} else {
ks <- min_cap[[i]]:cap[[i]]
lik <- exp(
dbinom(truth[[i]], size = ks, prob = p[[i]], log = TRUE) +
dpois(x = ks, lambda = lambdas[i], log = TRUE)
)
probs <- lik / sum(lik)
probs[!is.finite(probs)] <- 0
output <- ks[wrswoR::sample_int_ccrank(
length(ks),
size = 1L,
prob = probs
)]
}
output
}),
use.names = FALSE
)
}
} else if (type == 'response') {
xpred <- extraDistr::rtpois(
n = length(lambdas),
lambda = lambdas,
b = cap
)
out <- rbinom(length(lambdas), size = xpred, prob = p)
} else if (type == 'variance') {
xpred <- extraDistr::rtpois(
n = length(lambdas),
lambda = lambdas,
b = cap
)
# Variance of a Binomial distribution using the
# weights convention from stats::glm()
mu <- p / xpred
out <- mu * (1 - mu)
} else {
# Expectations
xpred <- extraDistr::rtpois(
n = length(lambdas),
lambda = lambdas,
b = cap
)
out <- xpred * p
}
}
# Gaussian observations (requires family parameter 'sigma_obs')
if (family == 'gaussian') {
if (type %in% c('link', 'expected')) {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dnorm(
truth,
mean = out,
sd = as.vector(family_pars$sigma_obs),
log = TRUE
)
}
} else if (type == 'variance') {
out <- rep.int(1, NROW(Xp))
} else {
out <- rnorm(
n = NROW(Xp),
mean = ((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset'),
sd = as.vector(family_pars$sigma_obs)
)
}
}
# LogNormal observations (requires family parameter 'sigma_obs')
if (family == 'lognormal') {
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dlnorm(
truth,
meanlog = out,
sdlog = as.vector(family_pars$sigma_obs),
log = TRUE
)
}
} else if (type == 'response') {
out <- rlnorm(
n = NROW(Xp),
meanlog = ((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset'),
sdlog = as.vector(family_pars$sigma_obs)
)
} else if (type == 'variance') {
mu <- ((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
sd <- as.vector(family_pars$sigma_obs)
out <- as.vector((exp((sd)^2) - 1) * exp((2 * mu + sd^2)))
} else {
mu <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
out <- exp(mu + (as.vector(family_pars$sigma_obs)^2 / 2))
}
}
# Student-T observations (requires family parameters 'nu', 'sigma_obs')
if (family == 'student') {
if (type %in% c('link', 'expected')) {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dstudent_t(
truth,
df = as.vector(family_pars$nu),
mu = out,
sigma = as.vector(family_pars$sigma_obs),
log = TRUE
)
}
} else if (type == 'variance') {
out <- as.vector(family_pars$sigma_obs)^2 *
as.vector(family_pars$nu) /
pmax(1.01, (as.vector(family_pars$nu) - 2))
} else {
out <- rstudent_t(
n = NROW(Xp),
df = family_pars$nu,
mu = ((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset'),
sigma = as.vector(family_pars$sigma_obs)
)
}
}
# Poisson observations
if (family == 'poisson') {
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dpois(truth, lambda = exp(out), log = TRUE)
}
} else if (type == 'response') {
out <- rpois(
n = NROW(Xp),
lambda = exp(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
)
)
} else if (type == 'variance') {
out <- exp(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
))
} else {
out <- exp(as.vector(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
))
}
}
# Bernoulli observations
if (family == 'bernoulli') {
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dbinom(truth, prob = plogis(out), size = 1, log = TRUE)
}
} else if (type == 'response') {
out <- rbinom(
n = NROW(Xp),
prob = plogis(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
),
size = 1
)
} else if (type == 'variance') {
mu <- plogis(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
))
out <- mu * (1 - mu)
} else {
out <- plogis(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
))
}
}
# Binomial observations (requires argument 'trials')
if (family == 'binomial') {
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dbinom(
truth,
prob = plogis(out),
size = as.vector(family_pars$trials),
log = TRUE
)
}
} else if (type == 'response') {
out <- rbinom(
n = NROW(Xp),
prob = plogis(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
),
size = as.vector(family_pars$trials)
)
} else if (type == 'variance') {
mu <- plogis(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)) /
as.vector(family_pars$trials)
out <- mu * (1 - mu)
} else {
out <- plogis(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
) *
as.vector(family_pars$trials)
}
}
# Beta_Binomial observations (requires arguments 'trials' and 'phi')
if (family == 'beta_binomial') {
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dbeta_binomial(
truth,
mu = plogis(out),
phi = as.vector(family_pars$phi),
size = as.vector(family_pars$trials),
log = TRUE
)
}
} else if (type == 'response') {
out <- rbeta_binomial(
n = NROW(Xp),
mu = plogis(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
),
phi = as.vector(family_pars$phi),
size = as.vector(family_pars$trials)
)
} else if (type == 'variance') {
mu <- plogis(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
))
# https://en.wikipedia.org/wiki/Beta-binomial_distribution
alpha <- mu * as.vector(family_pars$phi)
beta <- (1 - mu) * as.vector(family_pars$phi)
p <- 1 / (alpha + beta + 1)
n <- as.vector(family_pars$trials)
out <- ((n * p) * (1 - p)) * ((alpha + beta + n) / (alpha + beta + 1))
} else {
out <- as.vector(
plogis(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
) *
as.vector(family_pars$trials)
)
}
}
# Negative Binomial observations (requires argument 'phi')
if (family == 'negative binomial') {
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dnbinom(
truth,
mu = exp(out),
size = as.vector(family_pars$phi),
log = TRUE
)
}
} else if (type == 'response') {
out <- rnbinom(
n = NROW(Xp),
mu = exp(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
),
size = as.vector(family_pars$phi)
)
} else if (type == 'variance') {
mu <- exp(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
))
out <- mu + mu^2 / as.vector(family_pars$phi)
} else {
out <- as.vector(exp(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
))
}
}
# Beta observations (requires argument 'phi')
if (family == 'beta') {
shape_pars <- beta_shapes(
mu = plogis(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)),
phi = as.vector(family_pars$phi)
)
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dbeta(
truth,
shape1 = shape_pars$shape1,
shape2 = shape_pars$shape2,
log = TRUE
)
}
} else if (type == 'response') {
out <- rbeta(
n = NROW(Xp),
shape1 = shape_pars$shape1,
shape2 = shape_pars$shape2
)
} else if (type == 'variance') {
mu <- plogis(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
))
out <- mu * (1 - mu) / (1 + as.vector(family_pars$phi))
} else {
out <- plogis(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
))
}
}
# Gamma observations (requires argument 'shape')
if (family == 'Gamma') {
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- dgamma(
truth,
rate = as.vector(family_pars$shape) / exp(out),
shape = as.vector(family_pars$shape),
log = TRUE
)
}
} else if (type == 'response') {
out <- rgamma(
n = NROW(Xp),
rate = as.vector(family_pars$shape) /
exp(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)),
shape = as.vector(family_pars$shape)
)
} else if (type == 'variance') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)^2
} else {
out <- as.vector(family_pars$shape) /
(as.vector(family_pars$shape) /
exp(as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)))
}
}
# Tweedie observations (requires argument 'phi')
if (family == 'tweedie') {
if (type == 'link') {
out <- as.vector(
(matrix(Xp, ncol = NCOL(Xp)) %*%
betas) +
attr(Xp, 'model.offset')
)
if (density) {
out <- mgcv::ldTweedie(
y = truth,
mu = exp(out),
# Power parameter is fixed
p = 1.5,
phi = as.vector(family_pars$phi),
all.derivs = F
)[, 1]
}
} else if (type == 'response') {
out <- rpois(
n = NROW(Xp),
lambda = mgcv::rTweedie(
mu = exp(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
),
# Power parameter is fixed
p = 1.5,
phi = as.vector(family_pars$phi)
)
)
} else if (type == 'variance') {
out <- (exp(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
)^1.5) *
as.vector(family_pars$phi)
} else {
out <- as.vector(exp(
((matrix(Xp, ncol = NCOL(Xp)) %*%
betas)) +
attr(Xp, 'model.offset')
))
}
}
return(out)
}
#' Set which family to use when calculating default intercept priors
#' in brms
#' @noRd
family_to_brmsfam = function(family) {
if (family$family == 'beta') {
brms::Beta()
} else if (family$family == 'Beta regression') {
brms::Beta()
} else if (family$family == 'student') {
brms::student()
} else if (family$family %in% c('tweedie', 'negative binomial')) {
brms::negbinomial()
} else if (family$family == 'Gamma') {
Gamma(link = 'log')
} else {
family
}
}
#' Set which family to use when setting up the gam object
#' Stick to Gaussian where possible to ensure the initial setup
#' doesn't fail
#' @noRd
family_to_mgcvfam = function(family) {
if (family$family == 'beta') {
mgcv::betar()
} else if (family$family == 'student') {
gaussian()
} else if (family$family %in% c('gamma', 'Gamma', 'lognormal')) {
gaussian()
} else if (family$family == 'tweedie') {
mgcv::Tweedie(p = 1.5, link = 'log')
} else if (family$family == 'nmix') {
poisson()
} else if (family$family %in% c('bernoulli', 'beta_binomial')) {
binomial()
} else {
family
}
}
#' Set which family to use when setting up the jagam object
#' @noRd
family_to_jagamfam = function(family) {
if (family %in% c('gaussian', 'student')) {
gaussian()
} else {
poisson()
}
}
#' Define links used for the mean
#' @noRd
family_links = function(family) {
if (family %in% c('gaussian', 'lognormal', 'student')) {
out <- 'identity'
}
if (
family %in% c('Gamma', 'poisson', 'negative binomial', 'tweedie', 'nmix')
) {
out <- 'log'
}
if (family %in% c('beta', 'binomial', 'bernoulli', 'beta_binomial')) {
out <- 'logit'
}
out
}
#' @noRd
family_invlinks = function(family) {
if (family %in% c('gaussian', 'lognormal', 'student')) {
out <- function(x) {
x
}
}
if (family %in% c('Gamma', 'poisson', 'negative binomial', 'tweedie')) {
out <- function(x) {
exp(x)
}
}
if (family %in% c('beta', 'binomial', 'bernoulli', 'beta_binomial')) {
out <- function(x) {
plogis(x)
}
}
out
}
#' Parameters to monitor / extract depending on the observation family
#' @param family Character string of family name
#' @return Named list with parameter names and descriptive labels
#' @noRd
family_param_info = function(family) {
# Define family parameter specifications
family_specs <- list(
gaussian = list(
param_names = "sigma_obs",
labels = "observation_error"
),
lognormal = list(
param_names = "sigma_obs",
labels = "log_observation_error"
),
student = list(
param_names = c("sigma_obs", "nu"),
labels = c("observation_error", "observation_df")
),
Gamma = list(
param_names = "shape",
labels = "observation_shape"
),
beta = list(
param_names = "phi",
labels = "observation_precision"
),
beta_binomial = list(
param_names = "phi",
labels = "observation_dispersion"
),
"negative binomial" = list(
param_names = "phi",
labels = "observation_dispersion"
),
tweedie = list(
param_names = "phi",
labels = "observation_dispersion"
),
nmix = list(
param_names = "detprob",
labels = "detection_probability"
),
poisson = list(
param_names = character(0),
labels = character(0)
),
binomial = list(
param_names = character(0),
labels = character(0)
),
bernoulli = list(
param_names = character(0),
labels = character(0)
)
)
# Return specification for the given family
spec <- family_specs[[family]]
if (is.null(spec)) {
# Default for unknown families
spec <- list(
param_names = character(0),
labels = character(0)
)
}
return(spec)
}
#' Parameters to monitor / extract depending on the observation family
#' (deprecated Use family_param_info() instead)
#' @noRd
family_par_names = function(family) {
# Maintain backward compatibility by extracting param_names from new function
family_param_info(family)$param_names
}
#' Define which parameters to monitor / extract
#' @noRd
extract_family_pars = function(object, newdata = NULL) {
# Get names of parameters to extract
pars_to_extract <- family_param_info(object$family)$param_names
# Extract into a named list
if (length(pars_to_extract) > 0) {
out <- vector(mode = 'list')
for (i in 1:length(pars_to_extract)) {
out[[i]] <- mcmc_chains(object$model_output, params = pars_to_extract[i])
if (NCOL(out[[i]]) == 1) {
out[[i]] <- as.vector(out[[i]])
}
}
} else {
out <- list()
}
names(out) <- pars_to_extract
# Return list of extracted posterior parameter samples
out
}
#' Family-specific prior information
#' @noRd
family_prior_info = function(family, use_stan, data) {
if (family == 'gaussian') {
prior_df <- data.frame(
param_name = c('vector[n_series] sigma_obs;'),
param_length = length(unique(data$series)),
param_info = c('observation error sd'),
prior = c('sigma_obs ~ student_t(3, 0, 2);'),
example_change = c(
paste0(
'sigma_obs ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
}
if (family == 'lognormal') {
prior_df <- data.frame(
param_name = c('vector[n_series] sigma_obs;'),
param_length = length(unique(data$series)),
param_info = c('log(observation error sd)'),
prior = c('sigma_obs ~ student_t(3, 0, 1);'),
example_change = c(
paste0(
'sigma_obs ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
}
if (family == 'student') {
prior_df <- data.frame(
param_name = c(
'vector[n_series] sigma_obs;',
'vector[n_series] nu;'
),
param_length = rep(length(unique(data$series)), 2),
param_info = c('observation error sd', 'observation degrees of freedom'),
prior = c('sigma_obs ~ student_t(3, 0, 2);', 'nu ~ gamma(2, 0.1);'),
example_change = c(
paste0(
'sigma_obs ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'nu ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
}
if (family == 'beta') {
prior_df <- data.frame(
param_name = c('vector[n_series] phi;'),
param_length = length(unique(data$series)),
param_info = c('Beta precision parameter'),
prior = c('phi ~ gamma(0.01, 0.01);'),
example_change = c(
paste0(
'phi ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
}
if (family == 'beta_binomial') {
prior_df <- data.frame(
param_name = c('vector[n_series] phi;'),
param_length = length(unique(data$series)),
param_info = c('Beta Binomial precision parameter'),
prior = c('phi ~ gamma(0.01, 0.01);'),
example_change = c(
paste0(
'phi ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
}
if (family == 'Gamma') {
prior_df <- data.frame(
param_name = c('vector[n_series] shape;'),
param_length = length(unique(data$series)),
param_info = c('Gamma shape parameter'),
prior = c('shape ~ gamma(0.01, 0.01);'),
example_change = c(
paste0(
'shape ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
}
if (family == 'negative binomial') {
if (use_stan) {
prior_df <- data.frame(
param_name = c('vector[n_series] phi_inv;'),
param_length = length(unique(data$series)),
param_info = c('inverse of NB dispsersion'),
prior = c('phi_inv ~ student_t(3, 0, 0.1);'),
example_change = c(
paste0(
'phi_inv ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
} else {
prior_df <- data.frame(
param_name = c('vector[n_series] phi_inv;'),
param_length = length(unique(data$series)),
param_info = c('inverse of NB dispsersion'),
prior = c('phi_inv[s] ~ dexp(5)'),
example_change = c(
paste0(
'phi_inv[s] ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')T(0, )'
)
)
)
}
}
if (family == 'tweedie') {
prior_df <- data.frame(
param_name = c('vector[n_series] phi_raw;'),
param_length = length(unique(data$series)),
param_info = c('log of Tweedie dispsersion (for each series s)'),
prior = c('phi_raw[s] ~ dnorm(0, 2)T(-3.5, 3.5)'),
example_change = c(
paste0(
'phi_raw[s] ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.5, max = 5, n = 1), 2),
')'
)
)
)
}
if (family %in% c('nmix', 'poisson', 'binomial', 'bernoulli')) {
prior_df <- NULL
}
return(prior_df)
}
#' Family-specific Dunn-Smyth residual functions
#' @noRd
ds_resids_nmix = function(truth, fitted, draw, p, N) {
na_obs <- is.na(truth)
a_obs <- pbinom(
ifelse(
as.vector(truth[!na_obs]) - 1.e-6 > 0,
as.vector(truth[!na_obs]) - 1.e-6,
0
),
size = N[!na_obs],
prob = p[!na_obs]
)
b_obs <- pbinom(
as.vector(truth[!na_obs]),
size = N[!na_obs],
prob = p[!na_obs]
)
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_binomial = function(truth, fitted, draw, N) {
na_obs <- is.na(truth)
a_obs <- pbinom(
ifelse(
as.vector(truth[!na_obs]) - 1.e-6 > 0,
as.vector(truth[!na_obs]) - 1.e-6,
0
),
size = N[!na_obs],
prob = fitted[!na_obs]
)
b_obs <- pbinom(
as.vector(truth[!na_obs]),
size = N[!na_obs],
prob = fitted[!na_obs]
)
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_beta_binomial = function(truth, fitted, draw, N, phi) {
na_obs <- is.na(truth)
a_obs <- pbeta_binomial(
ifelse(
as.vector(truth[!na_obs]) - 1.e-6 > 0,
as.vector(truth[!na_obs]) - 1.e-6,
0
),
size = N[!na_obs],
mu = fitted[!na_obs],
phi = phi[!na_obs]
)
b_obs <- pbeta_binomial(
ifelse(as.vector(truth[!na_obs]), as.vector(truth[!na_obs]), 0),
size = N[!na_obs],
mu = fitted[!na_obs],
phi = phi[!na_obs]
)
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_nb = function(truth, fitted, draw, size) {
na_obs <- is.na(truth)
p <- size[!na_obs] / (fitted[!na_obs] + size[!na_obs])
a_obs <- ifelse(
as.vector(truth[!na_obs]) > 0,
pbeta(p, size[!na_obs], pmax(as.vector(truth[!na_obs]), 1)),
0
)
b_obs <- pbeta(p, size[!na_obs], as.vector(truth[!na_obs]) + 1)
u_obs <- runif(n = length(truth[!na_obs]), min = a_obs, max = b_obs)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_beta = function(truth, fitted, draw, precision) {
shape_pars <- beta_shapes(mu = fitted, phi = precision)
na_obs <- is.na(truth)
a_obs <- pbeta(
as.vector(truth[!na_obs]) - 1.e-6,
shape1 = shape_pars$shape1[!na_obs],
shape2 = shape_pars$shape2[!na_obs]
)
b_obs <- pbeta(
as.vector(truth[!na_obs]),
shape1 = shape_pars$shape1[!na_obs],
shape2 = shape_pars$shape2[!na_obs]
)
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_pois = function(truth, fitted, draw) {
na_obs <- is.na(truth)
a_obs <- ppois(as.vector(truth[!na_obs]) - 1.e-6, lambda = fitted[!na_obs])
b_obs <- ppois(as.vector(truth[!na_obs]), lambda = fitted[!na_obs])
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_tw = function(truth, fitted, draw) {
na_obs <- is.na(truth)
a_obs <- ppois(as.vector(truth[!na_obs]) - 1.e-6, lambda = fitted[!na_obs])
b_obs <- ppois(as.vector(truth[!na_obs]), lambda = fitted[!na_obs])
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_gaus = function(truth, fitted, sigma, draw) {
na_obs <- is.na(truth)
a_obs <- pnorm(
as.vector(truth[!na_obs]) - 1.e-6,
mean = fitted[!na_obs],
sd = sigma
)
b_obs <- pnorm(as.vector(truth[!na_obs]), mean = fitted[!na_obs], sd = sigma)
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_lnorm = function(truth, fitted, sigma, draw) {
na_obs <- is.na(truth)
a_obs <- plnorm(
as.vector(truth[!na_obs]) - 1.e-6,
meanlog = log(fitted[!na_obs]),
sdlog = sigma[!na_obs]
)
b_obs <- plnorm(
as.vector(truth[!na_obs]),
meanlog = log(fitted[!na_obs]),
sdlog = sigma[!na_obs]
)
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_gamma = function(truth, fitted, shape, draw) {
na_obs <- is.na(truth)
a_obs <- pgamma(
as.vector(truth[!na_obs]) - 1.e-6,
shape = shape[!na_obs],
rate = shape[!na_obs] / fitted[!na_obs]
)
b_obs <- pgamma(
as.vector(truth[!na_obs]),
shape = shape[!na_obs],
rate = shape[!na_obs] / fitted[!na_obs]
)
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#' @noRd
ds_resids_student = function(truth, fitted, sigma, nu, draw) {
na_obs <- is.na(truth)
a_obs <- pstudent_t(
as.vector(truth[!na_obs]) - 1,
df = nu[!na_obs],
mu = fitted[!na_obs],
sigma = sigma[!na_obs]
)
b_obs <- pstudent_t(
as.vector(truth[!na_obs]),
df = nu[!na_obs],
mu = fitted[!na_obs],
sigma = sigma[!na_obs]
)
u_obs <- runif(
n = length(truth[!na_obs]),
min = pmin(a_obs, b_obs),
max = pmax(a_obs, b_obs)
)
if (any(is.na(truth))) {
u <- vector(length = length(truth))
u[na_obs] <- NaN
u[!na_obs] <- u_obs
} else {
u <- u_obs
}
dsres_out <- qnorm(u)
dsres_out[is.infinite(dsres_out)] <- NaN
dsres_out
}
#'Residual calculations for a forecast
#' @noRd
get_forecast_resids = function(
object,
series,
truth,
preds,
family,
sample_seq
) {
if (family == 'poisson') {
series_residuals <- do.call(
rbind,
lapply(sample_seq, function(x) {
suppressWarnings(ds_resids_pois(
truth = truth,
fitted = preds[x, ],
draw = preds[x, ]
))
})
)
}
if (family == 'negative binomial') {
size <- mcmc_chains(object$model_output, 'phi')
series_residuals <- do.call(
rbind,
lapply(sample_seq, function(x) {
suppressWarnings(ds_resids_nb(
truth = truth,
fitted = preds[x, ],
draw = preds[x, ],
size = size[x]
))
})
)
}
if (family == 'gaussian') {
sigma <- mcmc_chains(object$model_output, 'sigma_obs')
series_residuals <- do.call(
rbind,
lapply(sample_seq, function(x) {
suppressWarnings(ds_resids_gaus(
truth = truth,
fitted = preds[x, ],
draw = preds[x, ],
sigma = sigma[x]
))
})
)
}
if (family == 'lognormal') {
sigma <- mcmc_chains(object$model_output, 'sigma_obs')
series_residuals <- do.call(
rbind,
lapply(sample_seq, function(x) {
suppressWarnings(ds_resids_lnorm(
truth = truth,
fitted = preds[x, ],
draw = preds[x, ],
sigma = sigma[x]
))
})
)
}
if (family == 'student') {
sigma <- mcmc_chains(object$model_output, 'sigma_obs')
nu <- mcmc_chains(object$model_output, 'nu')
series_residuals <- do.call(
rbind,
lapply(sample_seq, function(x) {
suppressWarnings(ds_resids_student(
truth = truth,
fitted = preds[x, ],
draw = preds[x, ],
sigma = sigma[x],
nu = nu[x]
))
})
)
}
if (family == 'beta') {
precision <- mcmc_chains(object$model_output, 'phi')
series_residuals <- do.call(
rbind,
lapply(sample_seq, function(x) {
suppressWarnings(ds_resids_beta(
truth = truth,
fitted = preds[x, ],
draw = preds[x, ],
precision = precision[x]
))
})
)
}
if (family == 'Gamma') {
shapes <- mcmc_chains(object$model_output, 'shape')
series_residuals <- do.call(
rbind,
lapply(sample_seq, function(x) {
suppressWarnings(ds_resids_gamma(
truth = truth,
fitted = preds[x, ],
draw = preds[x, ],
shape = shapes[x]
))
})
)
}
if (family == 'tweedie') {
series_residuals <- do.call(
rbind,
lapply(sample_seq, function(x) {
suppressWarnings(ds_resids_tw(
truth = truth,
fitted = preds[x, ],
draw = preds[x, ]
))
})
)
}
return(series_residuals)
}
#' #'Residual calculations for a fitted mvgam object
#' @noRd
dsresids_vec = function(object) {
family <- object$family
obs_series <- object$obs_data$series
series_levels <- levels(obs_series)
fit_engine <- object$fit_engine
# Need to know which series each observation belongs to so we can
# pull out appropriate family-level parameters (overdispersions, shapes, etc...)
all_dat <- data.frame(
series = object$obs_data$series,
time = object$obs_data$index..time..index,
y = object$obs_data$y
) %>%
dplyr::arrange(time, series)
truth <- all_dat$y
last_train <- NROW(all_dat)
series_obs <- as.numeric(all_dat$series)
# Extract expectations and necessary generated quantities
# and subset to only include training data
preds <- posterior_epred(object)[, 1:last_train, drop = FALSE]
if (family == 'nmix') {
p <- mcmc_chains(object$model_output, 'detprob')[,
1:last_train,
drop = FALSE
]
N <- mcmc_chains(object$model_output, 'latent_ypred')[,
1:last_train,
drop = FALSE
]
}
if (family %in% c('binomial', 'beta_binomial')) {
p <- plogis(mcmc_chains(object$model_output, 'mus')[,
1:last_train,
drop = FALSE
])
N <- as.vector(attr(object$mgcv_model, 'trials'))[1:length(truth)]
}
# Family-specific parameters
family_pars <- extract_family_pars(object = object)
n_series <- NCOL(object$ytimes)
# Family parameters spread into a vector
family_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
as.vector(family_pars[[j]][, series_obs])
} else {
as.vector(matrix(
rep(family_pars[[j]], NCOL(preds)),
nrow = NROW(preds),
byrow = FALSE
))
}
})
names(family_extracts) <- names(family_pars)
# Create a truth matrix for vectorised residual computation
truth_mat <- matrix(rep(truth, NROW(preds)), nrow = NROW(preds), byrow = TRUE)
# Calculate DS residual distributions
if (family == 'gaussian') {
resids <- matrix(
ds_resids_gaus(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1,
sigma = family_extracts$sigma_obs
),
nrow = NROW(preds)
)
}
if (family == 'binomial') {
N_mat <- matrix(rep(N, NROW(preds)), nrow = NROW(preds), byrow = TRUE)
resids <- matrix(
ds_resids_binomial(
truth = as.vector(truth_mat),
fitted = as.vector(p),
draw = 1,
N = as.vector(N_mat)
),
nrow = NROW(preds)
)
}
if (family == 'beta_binomial') {
N_mat <- matrix(rep(N, NROW(preds)), nrow = NROW(preds), byrow = TRUE)
resids <- matrix(
ds_resids_beta_binomial(
truth = as.vector(truth_mat),
fitted = as.vector(p),
draw = 1,
N = as.vector(N_mat),
phi = family_extracts$phi
),
nrow = NROW(preds)
)
}
if (family == 'bernoulli') {
resids <- matrix(
ds_resids_binomial(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1,
N = rep(1, length(truth_mat))
),
nrow = NROW(preds)
)
}
if (family == 'nmix') {
resids <- matrix(
ds_resids_nmix(
truth = as.vector(truth_mat),
fitted = 1,
draw = 1,
N = as.vector(N),
p = as.vector(p)
),
nrow = NROW(preds)
)
}
if (family == 'student') {
resids <- matrix(
ds_resids_student(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1,
sigma = family_extracts$sigma_obs,
nu = family_extracts$nu
),
nrow = NROW(preds)
)
}
if (family == 'lognormal') {
resids <- matrix(
ds_resids_lnorm(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1,
sigma = family_extracts$sigma_obs
),
nrow = NROW(preds)
)
}
if (family == 'poisson') {
resids <- matrix(
ds_resids_pois(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1
),
nrow = NROW(preds)
)
}
if (family == 'beta') {
resids <- matrix(
ds_resids_beta(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1,
precision = family_extracts$phi
),
nrow = NROW(preds)
)
}
if (family == 'Gamma') {
resids <- matrix(
ds_resids_gamma(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1,
shape = family_extracts$shape
),
nrow = NROW(preds)
)
}
if (family == 'negative binomial') {
resids <- matrix(
ds_resids_nb(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1,
size = family_extracts$phi
),
nrow = NROW(preds)
)
}
if (family == 'tweedie') {
resids <- matrix(
ds_resids_tw(
truth = as.vector(truth_mat),
fitted = as.vector(preds),
draw = 1
),
nrow = NROW(preds)
)
}
# Convert to a list of series-level matrices and return
series_resids <- lapply(seq_len(n_series), function(series) {
inds_keep <- which(series_obs == series)
resids[, inds_keep]
})
names(series_resids) <- levels(all_dat$series)
return(series_resids)
}
================================================
FILE: R/fevd.mvgam.R
================================================
#' Calculate latent VAR forecast error variance decompositions
#'
#' Compute forecast error variance decompositions from
#' \code{mvgam} models with Vector Autoregressive dynamics
#'
#' @name fevd.mvgam
#'
#' @param object \code{list} object of class \code{mvgam} resulting from a call to [mvgam()]
#' that used a Vector Autoregressive latent process model (either as `VAR(cor = FALSE)` or
#' `VAR(cor = TRUE)`; see [VAR()] for details)
#'
#' @param h Positive \code{integer} specifying the forecast horizon over which to calculate
#' the IRF
#'
#' @param ... ignored
#'
#' @return See \code{\link{mvgam_fevd-class}} for a full description of the quantities that are
#' computed and returned by this function, along with key references.
#'
#' @author Nicholas J Clark
#'
#' @seealso [VAR()], [irf()], [stability()], \code{\link{mvgam_fevd-class}}
#'
#' @references Lütkepohl, H. (2007).
#' New Introduction to Multiple Time Series Analysis. 2nd ed. Springer-Verlag Berlin Heidelberg.
#'
#' @examples
#' \dontrun{
#' # Simulate some time series that follow a latent VAR(1) process
#' simdat <- sim_mvgam(
#' family = gaussian(),
#' n_series = 4,
#' trend_model = VAR(cor = TRUE),
#' prop_trend = 1
#' )
#' plot_mvgam_series(data = simdat$data_train, series = "all")
#'
#' # Fit a model that uses a latent VAR(1)
#' mod <- mvgam(
#' formula = y ~ -1,
#' trend_formula = ~ 1,
#' trend_model = VAR(cor = TRUE),
#' family = gaussian(),
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Plot the autoregressive coefficient distributions;
#' # use 'dir = "v"' to arrange the order of facets
#' # correctly
#' mcmc_plot(
#' mod,
#' variable = 'A',
#' regex = TRUE,
#' type = 'hist',
#' facet_args = list(dir = 'v')
#' )
#'
#' # Calulate forecast error variance decompositions for each series
#' fevds <- fevd(mod, h = 12)
#'
#' # Plot median contributions to forecast error variance
#' plot(fevds)
#'
#' # View a summary of the error variance decompositions
#' summary(fevds)
#' }
#' @export
fevd <- function(object, ...) {
UseMethod("fevd", object)
}
#' @rdname fevd.mvgam
#' @method fevd mvgam
#' @export
fevd.mvgam <- function(object, h = 10, ...) {
validate_pos_integer(h)
trend_model <- attr(object$model_data, "trend_model")
if (!trend_model %in% c("VAR", "VARcor", "VAR1", "VAR1cor")) {
stop(
"Only VAR(1) models currently supported for calculating FEVDs",
call. = FALSE
)
}
beta_vars <- mcmc_chains(object$model_output, "A")
sigmas <- mcmc_chains(object$model_output, "Sigma")
n_series <- object$n_lv
if (is.null(n_series)) {
n_series <- nlevels(object$obs_data$series)
}
all_fevds <- lapply(seq_len(NROW(beta_vars)), function(draw) {
# Get necessary VAR parameters into a simple list format
x <- list(
K = n_series,
A = matrix(
beta_vars[draw, ],
nrow = n_series,
ncol = n_series,
byrow = TRUE
),
Sigma = matrix(
sigmas[draw, ],
nrow = n_series,
ncol = n_series,
byrow = TRUE
),
p = 1
)
# Calculate the FEVD for this draw
gen_fevd(x, h = h)
})
class(all_fevds) <- "mvgam_fevd"
return(all_fevds)
}
#### Functions to compute forecast error variance decompositions
# Much of this code is modified from R code generously provided in the vars
# package https://github.com/cran/vars ####
#' Forecast error variance decomposition
#' @noRd
gen_fevd <- function(x, h = 6, ...) {
K <- x$K
ynames <- paste0("process_", 1:K)
msey <- var_fecov(x, h = h)
Psi <- var_psi(x, h = h)
mse <- matrix(NA, nrow = h, ncol = K)
Omega <- array(0, dim = c(h, K, K))
for (i in 1:h) {
mse[i, ] <- diag(msey[,, i])
temp <- matrix(0, K, K)
for (l in 1:K) {
for (m in 1:K) {
for (j in 1:i) {
temp[l, m] <- temp[l, m] + Psi[l, m, j]^2
}
}
}
temp <- temp / mse[i, ]
for (j in 1:K) {
Omega[i, , j] <- temp[j, ]
}
}
result <- list()
for (i in 1:K) {
result[[i]] <- matrix(Omega[,, i], nrow = h, ncol = K)
colnames(result[[i]]) <- ynames
}
names(result) <- ynames
return(result)
}
#' Forecast error covariance matrix
#' @noRd
var_fecov <- function(x, h) {
sigma_yh <- array(NA, dim = c(x$K, x$K, h))
Phi <- var_phi(x, h = h)
sigma_yh[,, 1] <- Phi[,, 1] %*% t(Phi[,, 1])
if (h > 1) {
for (i in 2:h) {
temp <- matrix(0, nrow = x$K, ncol = x$K)
for (j in 2:i) {
temp <- temp + Phi[,, j] %*% t(Phi[,, j])
}
sigma_yh[,, i] <- temp + sigma_yh[,, 1]
}
}
return(sigma_yh)
}
================================================
FILE: R/forecast.mvgam.R
================================================
#' @importFrom generics forecast
#' @export
generics::forecast
#' @title Extract or compute hindcasts and forecasts for a fitted
#' \code{mvgam} object
#'
#' @name forecast.mvgam
#'
#' @method forecast mvgam
#'
#' @importFrom stats predict
#'
#' @importFrom rlang missing_arg
#'
#' @inheritParams predict.mvgam
#'
#' @param newdata Optional \code{dataframe} or \code{list} of test data
#' containing the same variables that were included in the original `data`
#' used to fit the model. If included, the covariate information in
#' \code{newdata} will be used to generate forecasts from the fitted model
#' equations. If this same \code{newdata} was originally included in the call
#' to \code{mvgam}, then forecasts have already been produced by the
#' generative model and these will simply be extracted and plotted. However
#' if no \code{newdata} was supplied to the original model call, an
#' assumption is made that the \code{newdata} supplied here comes
#' sequentially after the data supplied in the original model (i.e. we
#' assume there is no time gap between the last observation of series 1 in
#' the original data and the first observation for series 1 in
#' \code{newdata})
#'
#' @param data_test Deprecated. Still works in place of \code{newdata} but
#' users are recommended to use \code{newdata} instead for more seamless
#' integration into `R` workflows
#'
#' @param n_cores Deprecated. Parallel processing is no longer supported
#'
#' @param ... Ignored
#'
#' @details Posterior predictions are drawn from the fitted \code{mvgam} and
#' used to simulate a forecast distribution
#'
#' @return An object of class \code{mvgam_forecast} containing hindcast and
#' forecast distributions. See \code{\link{mvgam_forecast-class}} for
#' details.
#'
#' @seealso [hindcast.mvgam()], [plot.mvgam_forecast()],
#' [summary.mvgam_forecast()], [score.mvgam_forecast()]
#' [ensemble.mvgam_forecast()]
#'
#' @examples
#' \dontrun{
#' # Simulate data with 3 series and AR trend model
#' simdat <- sim_mvgam(n_series = 3, trend_model = AR())
#'
#' # Fit mvgam model
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Hindcasts on response scale
#' hc <- hindcast(mod)
#' str(hc)
#'
#' # Use summary() to extract hindcasts / forecasts for custom plotting
#' head(summary(hc), 12)
#'
#' # Or just use the plot() function for quick plots
#' plot(hc, series = 1)
#' plot(hc, series = 2)
#' plot(hc, series = 3)
#'
#' # Forecasts on response scale
#' fc <- forecast(
#' mod,
#' newdata = simdat$data_test
#' )
#' str(fc)
#' head(summary(fc), 12)
#' plot(fc, series = 1)
#' plot(fc, series = 2)
#' plot(fc, series = 3)
#'
#' # Forecasts as expectations
#' fc <- forecast(
#' mod,
#' newdata = simdat$data_test,
#' type = 'expected'
#' )
#' head(summary(fc), 12)
#' plot(fc, series = 1)
#' plot(fc, series = 2)
#' plot(fc, series = 3)
#'
#' # Dynamic trend extrapolations
#' fc <- forecast(
#' mod,
#' newdata = simdat$data_test,
#' type = 'trend'
#' )
#' head(summary(fc), 12)
#' plot(fc, series = 1)
#' plot(fc, series = 2)
#' plot(fc, series = 3)
#' }
#'
#' @export
forecast.mvgam = function(
object,
newdata,
data_test,
n_cores = 1,
type = 'response',
...
) {
# Check arguments
validate_pos_integer(n_cores)
if (n_cores > 1L) {
message('argument "n_cores" is deprecated')
}
if (!missing("newdata")) {
data_test <- newdata
}
if (missing("newdata") & missing(data_test) & is.null(object$test_data)) {
stop('newdata must be supplied to compute forecasts', call. = FALSE)
}
type <- match.arg(
arg = type,
choices = c(
"link",
"response",
"trend",
"expected",
"detection",
"latent_N"
)
)
if (inherits(object, 'jsdgam')) {
orig_trend_model <- attr(object$model_data, 'prepped_trend_model')
} else {
orig_trend_model <- object$trend_model
}
data_train <- validate_series_time(
object$obs_data,
trend_model = orig_trend_model
)
n_series <- NCOL(object$ytimes)
# Check whether a forecast has already been computed
forecasts_exist <- FALSE
if (!is.null(object$test_data) && !missing(data_test)) {
object$test_data <- validate_series_time(
object$test_data,
trend_model = orig_trend_model
)
data_test <- validate_series_time(data_test, trend_model = orig_trend_model)
if (
max(data_test$index..time..index) <=
max(object$test_data$index..time..index)
) {
forecasts_exist <- TRUE
} else {
data.frame(time = data_test$time) %>%
dplyr::mutate(rowid = dplyr::row_number()) %>%
dplyr::filter(time > max(object$test_data$index..time..index)) %>%
dplyr::pull(rowid) -> idx
if (inherits(data_test, 'list')) {
data_arranged <- data_test
data_arranged <- lapply(data_test, function(x) {
if (is.matrix(x)) {
matrix(x[idx, ], ncol = NCOL(x))
} else {
x[idx]
}
})
names(data_arranged) <- names(data_test)
data_test <- data_arranged
} else {
data_test <- data_test[idx, ]
}
}
}
if (!is.null(object$test_data) && missing(data_test)) {
forecasts_exist <- TRUE
}
if (is.null(object$test_data)) {
data_test <- validate_series_time(
data_test,
name = 'newdata',
trend_model = orig_trend_model
)
data.frame(series = object$obs_data$series, time = object$obs_data$time) %>%
dplyr::group_by(series) %>%
dplyr::summarise(maxt = max(time)) -> series_max_ts
data.frame(series = data_test$series, time = data_test$time) %>%
dplyr::mutate(orig_rows = dplyr::row_number()) %>%
dplyr::left_join(series_max_ts, by = 'series') %>%
dplyr::filter(time > maxt) %>%
dplyr::pull(orig_rows) -> idx
if (inherits(data_test, 'list')) {
data_arranged <- data_test
data_arranged <- lapply(data_test, function(x) {
if (is.matrix(x)) {
matrix(x[idx, ], ncol = NCOL(x))
} else {
x[idx]
}
})
names(data_arranged) <- names(data_test)
data_test <- data_arranged
} else {
data_test <- data_test[idx, ]
}
object$test_data <- data_test
}
# Only compute forecasts if they don't already exist!
if (!forecasts_exist) {
resp_terms <- as.character(terms(formula(object))[[2]])
if (length(resp_terms) == 1) {
out_name <- as.character(terms(formula(object))[[2]])
} else {
if (any(grepl('cbind', resp_terms))) {
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
out_name <- resp_terms[1]
}
}
if (out_name != 'y') {
data_test$y <- data_test[[out_name]]
}
if (!missing(data_test)) {
if (!'y' %in% names(data_test)) {
data_test$y <- rep(NA, NROW(data_test))
}
data_test <- validate_series_time(
data_test,
name = 'newdata',
trend_model = orig_trend_model
)
}
# Generate draw-specific forecasts
fc_preds <- forecast_draws(
object = object,
type = type,
series = 'all',
data_test = data_test,
n_cores = n_cores,
...
)
# Extract forecasts into the correct format
series_fcs <- lapply(seq_len(n_series), function(series) {
indexed_forecasts <- do.call(
rbind,
lapply(seq_along(fc_preds), function(x) {
fc_preds[[x]][[series]]
})
)
indexed_forecasts
})
names(series_fcs) <- levels(data_test$series)
# Extract hindcasts
data_train <- validate_series_time(
object$obs_data,
trend_model = orig_trend_model
)
ends <- seq(
0,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
length.out = NCOL(object$ytimes) + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, (NCOL(object$ytimes) + 1))])
ends <- ends[-1]
series_hcs <- lapply(seq_len(n_series), function(series) {
to_extract <- switch(
type,
'link' = 'mus',
'expected' = 'mus',
'response' = 'ypred',
'trend' = 'trend',
'latent_N' = 'mus',
'detection' = 'mus'
)
if (
object$family == 'nmix' &
type == 'link'
) {
to_extract <- 'trend'
}
if (object$fit_engine == 'stan') {
preds <- mcmc_chains(object$model_output, to_extract)[,
seq(
series,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
by = NCOL(object$ytimes)
),
drop = FALSE
]
} else {
preds <- mcmc_chains(object$model_output, to_extract)[,
starts[series]:ends[series],
drop = FALSE
]
}
if (
object$family == 'nmix' &
type == 'link'
) {
preds <- exp(preds)
}
if (type %in% c('expected', 'latent_N', 'detection')) {
# Compute expectations as one long vector
Xpmat <- matrix(as.vector(preds))
attr(Xpmat, 'model.offset') <- 0
family_pars <- extract_family_pars(object = object)
par_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
as.vector(matrix(
rep(as.vector(family_pars[[j]][, series]), NCOL(preds)),
nrow = NROW(preds),
byrow = FALSE
))
} else {
as.vector(matrix(
rep(family_pars[[j]], NCOL(preds)),
nrow = NROW(preds),
byrow = FALSE
))
}
})
names(par_extracts) <- names(family_pars)
# Add trial information if this is a Binomial model
if (object$family %in% c('binomial', 'beta_binomial')) {
trials <- as.vector(matrix(
rep(
as.vector(attr(object$mgcv_model, 'trials')[, series]),
NROW(preds)
),
nrow = NROW(preds),
byrow = TRUE
))
par_extracts$trials <- trials
}
if (object$family == 'nmix') {
preds <- mcmc_chains(object$model_output, 'detprob')[,
object$ytimes[, series],
drop = FALSE
]
Xpmat <- matrix(qlogis(as.vector(preds)))
attr(Xpmat, 'model.offset') <- 0
latent_lambdas <- as.vector(mcmc_chains(
object$model_output,
'trend'
)[,
seq(
series,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
by = NCOL(object$ytimes)
),
drop = FALSE
])
latent_lambdas <- exp(latent_lambdas)
n_draws <- dim(mcmc_chains(object$model_output, 'ypred'))[1]
cap <- as.vector(t(replicate(
n_draws,
object$obs_data$cap[which(
as.numeric(object$obs_data$series) == series
)]
)))
} else {
latent_lambdas <- NULL
cap <- NULL
}
if (type == 'latent_N') {
preds <- mcmc_chains(object$model_output, 'latent_ypred')[,
seq(
series,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
by = NCOL(object$ytimes)
),
drop = FALSE
]
} else {
preds <- matrix(
as.vector(mvgam_predict(
family = object$family,
Xp = Xpmat,
latent_lambdas = latent_lambdas,
cap = cap,
type = type,
betas = 1,
family_pars = par_extracts
)),
nrow = NROW(preds)
)
}
}
preds
})
names(series_hcs) <- levels(data_test$series)
# Extract observations
series_obs <- lapply(seq_len(n_series), function(series) {
s_name <- levels(object$obs_data$series)[series]
data.frame(
series = object$obs_data$series,
time = object$obs_data$index..time..index,
y = object$obs_data$y
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
})
names(series_obs) <- levels(data_test$series)
series_test <- lapply(seq_len(n_series), function(series) {
s_name <- levels(object$obs_data$series)[series]
data.frame(
series = data_test$series,
time = data_test$index..time..index,
y = data_test$y
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
})
names(series_test) <- levels(data_test$series)
} else {
# If forecasts already exist, simply extract them
data_test <- validate_series_time(
object$test_data,
trend_model = orig_trend_model
)
last_train <- max(object$obs_data$index..time..index) -
(min(object$obs_data$index..time..index) - 1)
data_train <- validate_series_time(
object$obs_data,
trend_model = orig_trend_model
)
ends <- seq(
0,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
length.out = NCOL(object$ytimes) + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, (NCOL(object$ytimes) + 1))])
ends <- ends[-1]
series_fcs <- lapply(seq_len(n_series), function(series) {
to_extract <- switch(
type,
'link' = 'mus',
'expected' = 'mus',
'response' = 'ypred',
'trend' = 'trend',
'latent_N' = 'mus',
'detection' = 'mus'
)
if (
object$family == 'nmix' &
type == 'link'
) {
to_extract <- 'trend'
}
if (object$fit_engine == 'stan') {
preds <- mcmc_chains(object$model_output, to_extract)[,
seq(
series,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
by = NCOL(object$ytimes)
),
drop = FALSE
]
} else {
preds <- mcmc_chains(object$model_output, to_extract)[,
starts[series]:ends[series],
drop = FALSE
]
}
if (
object$family == 'nmix' &
type == 'link'
) {
preds <- exp(preds)
}
if (type %in% c('expected', 'latent_N', 'detection')) {
# Compute expectations as one long vector
Xpmat <- matrix(as.vector(preds))
attr(Xpmat, 'model.offset') <- 0
family_pars <- extract_family_pars(object = object)
par_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
family_pars[[j]][, series]
} else {
family_pars[[j]]
}
})
names(par_extracts) <- names(family_pars)
# Add trial information if this is a Binomial model
if (object$family %in% c('binomial', 'beta_binomial')) {
trials <- as.vector(matrix(
rep(
as.vector(attr(object$mgcv_model, 'trials')[, series]),
NROW(mus)
),
nrow = NROW(mus),
byrow = TRUE
))
par_extracts$trials <- trials
}
if (object$family == 'nmix') {
preds <- mcmc_chains(object$model_output, 'detprob')[,
object$ytimes[, series],
drop = FALSE
]
Xpmat <- matrix(qlogis(as.vector(preds)))
attr(Xpmat, 'model.offset') <- 0
n_draws <- dim(mcmc_chains(object$model_output, 'ypred'))[1]
n_cols <- dim(mcmc_chains(object$model_output, 'ypred'))[2]
latent_lambdas <- as.vector(mcmc_chains(
object$model_output,
'trend'
)[, seq(series, n_cols, by = NCOL(object$ytimes)), drop = FALSE])
latent_lambdas <- exp(latent_lambdas)
cap <- as.vector(t(replicate(
n_draws,
c(
object$obs_data$cap[which(
as.numeric(object$obs_data$series) == series
)],
object$test_data$cap[which(
as.numeric(object$test_data$series) == series
)]
)
)))
} else {
latent_lambdas <- NULL
cap <- NULL
}
if (type == 'latent_N') {
preds <- mcmc_chains(object$model_output, 'latent_ypred')[,
seq(
series,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
by = NCOL(object$ytimes)
),
drop = FALSE
]
} else {
preds <- matrix(
as.vector(mvgam_predict(
family = object$family,
Xp = Xpmat,
latent_lambdas = latent_lambdas,
cap = cap,
type = type,
betas = 1,
family_pars = par_extracts
)),
nrow = NROW(preds)
)
}
}
preds[, (last_train + 1):NCOL(preds)]
})
names(series_fcs) <- levels(data_train$series)
# Extract hindcasts for storing in the returned object
series_hcs <- lapply(seq_len(n_series), function(series) {
to_extract <- switch(
type,
'link' = 'mus',
'expected' = 'mus',
'response' = 'ypred',
'trend' = 'trend',
'latent_N' = 'mus',
'detection' = 'mus'
)
if (
object$family == 'nmix' &
type == 'link'
) {
to_extract <- 'trend'
}
if (object$fit_engine == 'stan') {
preds <- mcmc_chains(object$model_output, to_extract)[,
seq(
series,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
by = NCOL(object$ytimes)
),
drop = FALSE
][, 1:last_train]
} else {
preds <- mcmc_chains(object$model_output, to_extract)[,
starts[series]:ends[series],
drop = FALSE
][, 1:last_train]
}
if (
object$family == 'nmix' &
type == 'link'
) {
preds <- exp(preds)
}
if (type %in% c('expected', 'latent_N', 'detection')) {
# Compute expectations as one long vector
Xpmat <- matrix(as.vector(preds))
attr(Xpmat, 'model.offset') <- 0
family_pars <- extract_family_pars(object = object)
par_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
family_pars[[j]][, series]
} else {
family_pars[[j]]
}
})
names(par_extracts) <- names(family_pars)
# Add trial information if this is a Binomial model
if (object$family %in% c('binomial', 'beta_binomial')) {
trials <- as.vector(matrix(
rep(
as.vector(attr(object$mgcv_model, 'trials')[
1:last_train,
series
]),
NROW(mus)
),
nrow = NROW(mus),
byrow = TRUE
))
par_extracts$trials <- trials
}
if (object$family == 'nmix') {
preds <- mcmc_chains(object$model_output, 'detprob')[,
object$ytimes[1:last_train, series],
drop = FALSE
]
Xpmat <- matrix(qlogis(as.vector(preds)))
attr(Xpmat, 'model.offset') <- 0
n_draws <- dim(mcmc_chains(object$model_output, 'ypred'))[1]
n_cols <- dim(mcmc_chains(object$model_output, 'ypred'))[2]
latent_lambdas <- as.vector(mcmc_chains(
object$model_output,
'trend'
)[, seq(series, n_cols, by = NCOL(object$ytimes)), drop = FALSE][,
1:last_train
])
latent_lambdas <- exp(latent_lambdas)
cap <- as.vector(t(replicate(
n_draws,
object$obs_data$cap[which(
as.numeric(object$test_data$series) == series
)]
)))
} else {
latent_lambdas <- NULL
cap <- NULL
}
if (type == 'latent_N') {
preds <- mcmc_chains(object$model_output, 'latent_ypred')[,
seq(
series,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
by = NCOL(object$ytimes)
),
drop = FALSE
][, 1:last_train]
} else {
preds <- matrix(
as.vector(mvgam_predict(
family = object$family,
Xp = Xpmat,
latent_lambdas = latent_lambdas,
cap = cap,
type = type,
betas = 1,
family_pars = par_extracts
)),
nrow = NROW(preds)
)
}
}
preds
})
names(series_hcs) <- levels(data_train$series)
series_obs <- lapply(seq_len(n_series), function(series) {
s_name <- levels(object$obs_data$series)[series]
data.frame(
series = object$obs_data$series,
time = object$obs_data$index..time..index,
y = object$obs_data$y
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
})
names(series_obs) <- levels(data_train$series)
series_test <- lapply(seq_len(n_series), function(series) {
s_name <- levels(object$obs_data$series)[series]
data.frame(
series = object$test_data$series,
time = object$test_data$index..time..index,
y = object$test_data$y
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
})
names(series_test) <- levels(data_train$series)
}
series_train_times <- lapply(seq_len(n_series), function(series) {
s_name <- levels(object$obs_data$series)[series]
data.frame(
series = object$obs_data$series,
time = object$obs_data$time,
y = object$obs_data$y
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(time)
})
names(series_train_times) <- levels(data_train$series)
series_test_times <- lapply(seq_len(n_series), function(series) {
s_name <- levels(object$obs_data$series)[series]
data.frame(
series = data_test$series,
time = data_test$time
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(time)
})
names(series_test_times) <- levels(data_train$series)
series_fcs <- structure(
list(
call = object$call,
trend_call = object$trend_call,
family = object$family,
family_pars = if (type == 'link') {
extract_family_pars(object = object)
} else {
NULL
},
trend_model = object$trend_model,
drift = object$drift,
use_lv = object$use_lv,
fit_engine = object$fit_engine,
type = type,
series_names = factor(
levels(data_train$series),
levels = levels(data_train$series)
),
train_observations = series_obs,
train_times = series_train_times,
test_observations = series_test,
test_times = series_test_times,
hindcasts = series_hcs,
forecasts = series_fcs
),
class = 'mvgam_forecast'
)
return(series_fcs)
}
#'Compute forecasts using a posterior distribution
#'@noRd
forecast_draws = function(
object,
type = 'response',
series = 'all',
data_test,
n_cores = 1,
n_samples,
ending_time,
b_uncertainty = TRUE,
trend_uncertainty = TRUE,
obs_uncertainty = TRUE
) {
# Check arguments
validate_pos_integer(n_cores)
if (inherits(object, 'jsdgam')) {
orig_trend_model <- attr(object$model_data, 'prepped_trend_model')
} else {
orig_trend_model <- object$trend_model
}
data_test <- validate_series_time(
data_test,
name = 'newdata',
trend_model = orig_trend_model
)
data_test <- sort_data(data_test)
n_series <- NCOL(object$ytimes)
use_lv <- object$use_lv
if (series != 'all') {
s_name <- levels(data_test$series)[series]
}
# Generate the observation model linear predictor matrix,
# ensuring the test data is sorted correctly (by time and then series)
if (inherits(data_test, 'list')) {
Xp <- obs_Xp_matrix(
newdata = sort_data(data_test),
mgcv_model = object$mgcv_model
)
if (series != 'all') {
obs_keep <- data.frame(
y = data_test$y,
series = data_test$series,
time = data_test$index..time..index,
rowid = 1:length(data_test$y)
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(rowid)
series_test <- data.frame(
y = data_test$y,
series = data_test$series,
time = data_test$index..time..index,
rowid = 1:length(data_test$y)
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time)
Xp <- Xp[obs_keep, ]
} else {
series_test <- NULL
}
} else {
if (series != 'all') {
series_test <- data_test %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(index..time..index)
Xp <- obs_Xp_matrix(newdata = series_test, mgcv_model = object$mgcv_model)
} else {
Xp <- obs_Xp_matrix(
newdata = sort_data(data_test),
mgcv_model = object$mgcv_model
)
series_test <- NULL
}
}
# Generate linear predictor matrix from trend mgcv model, ensuring
# the test data is sorted correctly (by time and then series)
if (!is.null(object$trend_call)) {
Xp_trend <- trend_Xp_matrix(
newdata = sort_data(data_test),
trend_map = object$trend_map,
series = series,
mgcv_model = object$trend_mgcv_model,
forecast = TRUE
)
# For trend_formula models with autoregressive processes,
# the process model operates as: AR * (process[t - 1] - mu[t-1]])
# We therefore need the values of mu at the end of the training set
# to correctly propagate the process model forward
if (use_lv & attr(object$model_data, 'trend_model') != 'GP') {
# Get the observed trend predictor matrix
newdata <- trend_map_data_prep(
object$obs_data,
object$trend_map,
forecast = TRUE
)
Xp_trend_last <- predict(
object$trend_mgcv_model,
newdata = newdata,
type = 'lpmatrix'
)
# Ensure the last three values are used, in case the obs_data
# was not supplied in order
data.frame(
time = newdata$index..time..index,
series = newdata$series,
row_id = 1:length(newdata$index..time..index)
) %>%
dplyr::arrange(time, series) %>%
dplyr::pull(row_id) -> sorted_inds
n_processes <- length(unique(object$trend_map$trend))
linpred_order <- tail(sorted_inds, 3 * n_processes)
# Deal with any offsets
if (!all(attr(Xp_trend_last, 'model.offset') == 0)) {
offset_vec <- attr(Xp_trend_last, 'model.offset')
offset_last <- offset_vec[linpred_order]
offset_last[is.na(offset_last)] <- 0
full_offset <- c(offset_last, attr(Xp_trend, 'model.offset'))
} else {
full_offset <- 0
}
# Bind the last 3 linpred rows with the forecast linpred rows
Xp_trend <- rbind(Xp_trend_last[linpred_order, , drop = FALSE], Xp_trend)
attr(Xp_trend, 'model.offset') <- full_offset
}
} else {
Xp_trend <- NULL
}
# No need to compute in parallel if there was no trend model
nmix_notrend <- FALSE
if (
!inherits(orig_trend_model, 'mvgam_trend') &
object$family == 'nmix'
) {
nmix_notrend <- TRUE
}
if (
attr(object$model_data, 'trend_model') == 'None' |
nmix_notrend
) {
if (type == 'trend' & !nmix_notrend & !use_lv) {
stop('No trend_model was used in this model', call. = FALSE)
}
all_preds <- predict(
object,
type = type,
newdata = data_test,
summary = FALSE
)
fc_preds <- lapply(seq_len(NROW(all_preds)), function(draw) {
lapply(seq_len(n_series), function(series) {
all_preds[
draw,
which(data_test$series == levels(data_test$series)[series])
]
})
})
} else {
# Else compute forecasts including dynamic trend components
# Set forecast horizon
if (series != 'all') {
fc_horizon <- NROW(series_test)
} else {
fc_horizon <- length(unique(data_test$index..time..index))
}
# Beta coefficients for GAM observation component
betas <- mcmc_chains(object$model_output, 'b')
# Generate sample sequence for n_samples
if (missing(n_samples)) {
sample_seq <- 1:dim(betas)[1]
} else {
if (n_samples < dim(betas)[1]) {
sample_seq <- sample(
seq_len(dim(betas)[1]),
size = n_samples,
replace = FALSE
)
} else {
sample_seq <- sample(
seq_len(dim(betas)[1]),
size = n_samples,
replace = TRUE
)
}
}
# Beta coefficients for GAM trend component
if (!is.null(object$trend_call)) {
betas_trend <- mcmc_chains(object$model_output, 'b_trend')
} else {
betas_trend <- NULL
}
# Family of model
family <- object$family
# Family-specific parameters
family_pars <- extract_family_pars(object = object, newdata = data_test)
# Add trial information if this is a Binomial model
if (object$family %in% c('binomial', 'beta_binomial')) {
resp_terms <- as.character(terms(formula(object$call))[[2]])
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
trial_name <- resp_terms[2]
if (!exists(trial_name, data_test)) {
stop(
paste0('Variable ', trial_name, ' not found in newdata'),
call. = FALSE
)
}
trial_df <- data.frame(
series = data_test$series,
time = data_test$index..time..index,
trial = data_test[[trial_name]]
)
trials <- matrix(NA, nrow = fc_horizon, ncol = n_series)
for (i in 1:n_series) {
trials[, i] <- trial_df %>%
dplyr::filter(series == levels(data_test$series)[i]) %>%
dplyr::arrange(time) %>%
dplyr::pull(trial)
}
} else {
trials <- NULL
}
# Trend model
trend_model <- attr(object$model_data, 'trend_model')
# Calculate time_dis if this is a CAR1 model
if (trend_model == 'CAR1') {
data_test$index..time..index <- data_test$index..time..index +
max(object$obs_data$index..time..index)
time_dis <- add_corcar(
model_data = list(),
data_train = object$obs_data,
data_test = data_test
)[[1]]
time_dis <- time_dis[-c(1:max(object$obs_data$index..time..index)), ]
} else {
time_dis <- NULL
}
# Trend-specific parameters
if (missing(ending_time)) {
trend_pars <- extract_trend_pars(
object = object,
keep_all_estimates = FALSE
)
} else {
trend_pars <- extract_trend_pars(
object = object,
keep_all_estimates = FALSE,
ending_time = ending_time
)
}
# Any model in which an autoregressive process was included should be
# considered as VAR1 for forecasting purposes as this will make use of the
# faster c++ functions
if (trend_model == 'CAR1') {
if (!'last_lvs' %in% names(trend_pars)) {
trend_pars$last_lvs <- trend_pars$last_trends
}
} else {
if (
'Sigma' %in%
names(trend_pars) |
'sigma' %in% names(trend_pars) |
'tau' %in% names(trend_pars)
) {
trend_model <- 'VAR1'
if (!'last_lvs' %in% names(trend_pars)) {
trend_pars$last_lvs <- trend_pars$last_trends
}
}
}
# Loop over draws and compute forecasts (in serial at the moment)
fc_preds <- lapply(seq_len(dim(betas)[1]), function(i) {
# Sample index
samp_index <- i
# Sample beta coefs
if (b_uncertainty) {
betas <- betas[samp_index, ]
} else {
betas <- betas[1, ]
}
if (!is.null(betas_trend)) {
if (b_uncertainty) {
betas_trend <- betas_trend[samp_index, ]
} else {
betas_trend <- betas_trend[1, ]
}
}
# Return predictions
# Sample general trend-specific parameters
if (trend_uncertainty) {
general_trend_pars <- extract_general_trend_pars(
trend_pars = trend_pars,
samp_index = samp_index
)
} else {
general_trend_pars <- extract_general_trend_pars(
trend_pars = trend_pars,
samp_index = 1
)
}
if (
use_lv || trend_model %in% c('VAR1', 'PWlinear', 'PWlogistic', 'CAR1')
) {
if (trend_model == 'PWlogistic') {
if (!(exists('cap', where = data_test))) {
stop(
'Capacities must also be supplied in "newdata" for logistic growth predictions',
call. = FALSE
)
}
family_links <- eval(parse(text = family))
if (family_links()$family == 'Gamma') {
family_links <- Gamma(link = 'log')
}
cap <- data.frame(
series = data_test$series,
time = data_test$index..time..index,
cap = suppressWarnings(linkfun(
data_test$cap,
link = family_links()$link
))
)
if (any(is.na(cap$cap)) | any(is.infinite(cap$cap))) {
stop(
paste0(
'Missing or infinite values found for some "cap" terms\n',
'after transforming to the ',
family$link,
' link scale'
),
call. = FALSE
)
}
} else {
cap <- NULL
}
# Propagate all trends / lvs forward jointly using sampled trend parameters
trends <- forecast_trend(
trend_model = trend_model,
use_lv = use_lv,
trend_pars = general_trend_pars,
h = fc_horizon,
betas_trend = betas_trend,
Xp_trend = Xp_trend,
time = unique(
data_test$index..time..index -
min(object$obs_data$index..time..index) +
1
),
cap = cap,
time_dis = time_dis
)
}
# Loop across series and produce the next trend estimate
trend_states <- lapply(seq_len(n_series), function(series) {
# Sample series- and trend-specific parameters
trend_extracts <- extract_series_trend_pars(
series = series,
samp_index = samp_index,
trend_pars = trend_pars,
use_lv = use_lv
)
if (
use_lv || trend_model %in% c('VAR1', 'PWlinear', 'PWlogistic', 'CAR1')
) {
if (use_lv) {
# Multiply lv states with loadings to generate the series' forecast trend state
out <- as.numeric(trends %*% trend_extracts$lv_coefs)
} else if (
trend_model %in% c('VAR1', 'PWlinear', 'PWlogistic', 'CAR1')
) {
out <- trends[, series]
}
} else {
# Propagate the series-specific trends forward
out <- forecast_trend(
trend_model = trend_model,
use_lv = FALSE,
trend_pars = trend_extracts,
h = fc_horizon,
betas_trend = betas_trend,
Xp_trend = Xp_trend,
time = sort(unique(data_test$index..time..index)),
time_dis = NULL
)
}
out
})
if (type == 'trend') {
out <- trend_states
} else {
trend_states <- do.call(cbind, trend_states)
out <- lapply(seq_len(n_series), function(series) {
if (family == 'nmix') {
Xpmat <- Xp[which(as.numeric(data_test$series) == series), ]
latent_lambdas <- exp(trend_states[, series])
pred_betas <- betas
cap <- data_test$cap[which(as.numeric(data_test$series) == series)]
} else {
Xpmat <- cbind(
Xp[which(as.numeric(data_test$series) == series), ],
trend_states[, series]
)
latent_lambdas <- NULL
pred_betas <- c(betas, 1)
cap <- NULL
}
if (!is.null(attr(Xp, 'model.offset'))) {
attr(Xpmat, 'model.offset') <-
attr(Xp, 'model.offset')[which(
as.numeric(data_test$series) == series
)]
attr(Xpmat, 'model.offset')[is.na(attr(Xpmat, 'model.offset'))] <- 0
}
# Family-specific parameters
family_extracts <- lapply(seq_along(family_pars), function(x) {
if (is.matrix(family_pars[[x]])) {
if (obs_uncertainty) {
family_pars[[x]][samp_index, series]
} else {
family_pars[[x]][1, series]
}
} else {
if (obs_uncertainty) {
family_pars[[x]][samp_index]
} else {
family_pars[[x]][1]
}
}
})
names(family_extracts) <- names(family_pars)
# Add trial information if this is a Binomial model
if (family %in% c('binomial', 'beta_binomial')) {
family_extracts$trials <- trials[, series]
}
mvgam_predict(
family = family,
Xp = Xpmat,
latent_lambdas = latent_lambdas,
cap = cap,
type = type,
betas = pred_betas,
family_pars = family_extracts
)
})
}
out
})
}
return(fc_preds)
}
================================================
FILE: R/formula.mvgam.R
================================================
#'Extract formulae from \pkg{mvgam} objects
#'
#'@rdname formula.mvgam
#'@param x `mvgam`, `jsdgam` or `mvgam_prefit` object
#'@param trend_effects \code{logical}, return the formula from the
#'observation model (if \code{FALSE}) or from the underlying process
#'model (if\code{TRUE})
#'@param ... Ignored
#'@author Nicholas J Clark
#'@return A \code{formula} object
#'@export
formula.mvgam = function(x, trend_effects = FALSE, ...) {
# Check trend_effects
if (trend_effects) {
if (is.null(x$trend_call)) {
stop('no trend_formula exists so there is no trend-level model.frame')
}
}
if (!trend_effects) {
out <- x$call
} else {
out <- x$trend_call
out <- update(out, as.formula(paste('trend_y', '~.')))
}
return(out)
}
#'@rdname formula.mvgam
#'@export
formula.mvgam_prefit = function(x, trend_effects = FALSE, ...) {
# Check trend_effects
if (trend_effects) {
if (is.null(x$trend_call)) {
stop('no trend_formula exists so there is no trend-level model.frame')
}
}
if (!trend_effects) {
out <- x$call
} else {
out <- x$trend_call
out <- update(out, as.formula(paste('trend_y', '~.')))
}
return(out)
}
================================================
FILE: R/get_linear_predictors.R
================================================
#' Function to prepare observation model linear predictor matrix
#' @importFrom brms brmsterms
#' @noRd
obs_Xp_matrix = function(newdata, mgcv_model) {
suppressWarnings(
Xp <- try(
predict(mgcv_model, newdata = newdata, type = 'lpmatrix'),
silent = TRUE
)
)
if (inherits(Xp, 'try-error')) {
testdat <- data.frame(time = newdata$time)
terms_include <- insight::find_predictors(mgcv_model)$conditional
if (any(terms_include %in% names(newdata) == FALSE)) {
stop(
'not all required variables have been supplied in newdata!',
call. = FALSE
)
}
if (length(terms_include) > 0L) {
newnames <- vector()
newnames[1] <- 'time'
for (i in 1:length(terms_include)) {
testdat <- cbind(testdat, data.frame(newdata[[terms_include[i]]]))
newnames[i + 1] <- terms_include[i]
}
colnames(testdat) <- newnames
}
suppressWarnings(
Xp <- predict(mgcv_model, newdata = testdat, type = 'lpmatrix')
)
}
# Check for any gp() terms and update the design matrix
# accordingly
if (!is.null(attr(mgcv_model, 'gp_att_table'))) {
# Compute the gp() eigenfunctions for newdata using the supplied brms_mock object
# Requires a dataframe of all relevant variables for the gp effects
mock_terms <- brms::brmsterms(attr(mgcv_model, 'brms_mock')$formula)
terms_needed <- unique(all.vars(mock_terms$formula)[-1])
newdata_mock <- data.frame(newdata[[terms_needed[1]]])
if (length(terms_needed) > 1L) {
for (i in 2:length(terms_needed)) {
newdata_mock <- cbind(
newdata_mock,
data.frame(newdata[[terms_needed[i]]])
)
}
}
colnames(newdata_mock) <- terms_needed
newdata_mock$.fake_gp_y <- rnorm(NROW(newdata_mock))
brms_mock_data <- brms::standata(
attr(mgcv_model, 'brms_mock'),
newdata = newdata_mock,
internal = TRUE
)
# Extract GP attributes
gp_att_table <- attr(mgcv_model, 'gp_att_table')
bys <- unlist(purrr::map(gp_att_table, 'by'), use.names = FALSE)
lvls <- unlist(purrr::map(gp_att_table, 'level'), use.names = FALSE)
# Extract eigenfunctions for each gp effect
eigenfuncs <- eigenfunc_list(
stan_data = brms_mock_data,
mock_df = newdata_mock,
by = bys,
level = lvls
)
# Find indices to replace in the design matrix and replace with
# the computed eigenfunctions
starts <- purrr::map(gp_att_table, 'first_coef')
ends <- purrr::map(gp_att_table, 'last_coef')
for (i in seq_along(starts)) {
Xp[, c(starts[[i]]:ends[[i]])] <- eigenfuncs[[i]]
}
}
return(Xp)
}
#' Function to prepare trend linear predictor matrix in the presence of a
#' trend_map
#' @noRd
trend_map_data_prep = function(newdata, trend_map, forecast = FALSE) {
trend_test <- newdata
trend_indicators <- vector(length = length(trend_test$series))
for (i in 1:length(trend_test$series)) {
trend_indicators[i] <- trend_map$trend[which(
as.character(trend_map$series) == as.character(trend_test$series[i])
)]
}
trend_indicators <- factor(
paste0('trend', trend_indicators),
levels = paste0('trend', unique(trend_map$trend))
)
trend_test$series <- trend_indicators
trend_test$y <- NULL
# Only keep one time observation per trend, in case this is a reduced dimensionality
# State-Space model (with a trend_map) and we are forecasting ahead
if (forecast) {
data.frame(
series = trend_test$series,
time = trend_test$index..time..index,
row_num = 1:length(trend_test$index..time..index)
) %>%
dplyr::group_by(series, time) %>%
dplyr::slice_head(n = 1) %>%
dplyr::pull(row_num) -> inds_keep
inds_keep <- sort(inds_keep)
if (inherits(trend_test, 'list')) {
trend_test <- lapply(trend_test, function(x) {
if (is.matrix(x)) {
matrix(x[inds_keep, ], ncol = NCOL(x))
} else {
x[inds_keep]
}
})
} else {
trend_test <- trend_test[inds_keep, ]
}
}
return(trend_test)
}
#' Function to prepare trend linear predictor matrix, ensuring ordering and
#' indexing is correct with respect to the model structure
#' @noRd
trend_Xp_matrix = function(
newdata,
trend_map,
series = 'all',
mgcv_model,
forecast = FALSE
) {
trend_test <- trend_map_data_prep(newdata, trend_map, forecast = forecast)
suppressWarnings(
Xp_trend <- try(
predict(mgcv_model, newdata = trend_test, type = 'lpmatrix'),
silent = TRUE
)
)
if (inherits(Xp_trend, 'try-error')) {
testdat <- data.frame(series = trend_test$series)
terms_include <- insight::find_predictors(mgcv_model)$conditional
if (any(terms_include %in% names(trend_test) == FALSE)) {
stop(
'not all required variables have been supplied in newdata!',
call. = FALSE
)
}
if (length(terms_include) > 0) {
newnames <- vector()
newnames[1] <- 'series'
for (i in 1:length(terms_include)) {
testdat <- cbind(testdat, data.frame(trend_test[[terms_include[i]]]))
newnames[i + 1] <- terms_include[i]
}
colnames(testdat) <- newnames
}
suppressWarnings(
Xp_trend <- predict(mgcv_model, newdata = testdat, type = 'lpmatrix')
)
}
# Check for any gp() terms and update the design matrix
# accordingly
if (!is.null(attr(mgcv_model, 'gp_att_table'))) {
# Compute the gp() eigenfunctions for newdata using the supplied brms_mock object
# Requires a dataframe of all relevant variables for the gp effects
mock_terms <- brms::brmsterms(attr(mgcv_model, 'brms_mock')$formula)
terms_needed <- unique(all.vars(mock_terms$formula)[-1])
newdata_mock <- data.frame(trend_test[[terms_needed[1]]])
if (length(terms_needed) > 1L) {
for (i in 2:length(terms_needed)) {
newdata_mock <- cbind(
newdata_mock,
data.frame(trend_test[[terms_needed[i]]])
)
}
}
colnames(newdata_mock) <- terms_needed
newdata_mock$.fake_gp_y <- rnorm(NROW(newdata_mock))
brms_mock_data <- brms::standata(
attr(mgcv_model, 'brms_mock'),
newdata = newdata_mock,
internal = TRUE
)
# Extract GP attributes
gp_att_table <- attr(mgcv_model, 'gp_att_table')
bys <- unlist(purrr::map(gp_att_table, 'by'), use.names = FALSE)
lvls <- unlist(purrr::map(gp_att_table, 'level'), use.names = FALSE)
# Extract eigenfunctions for each gp effect
eigenfuncs <- eigenfunc_list(
stan_data = brms_mock_data,
mock_df = newdata_mock,
by = bys,
level = lvls
)
# Find indices to replace in the design matrix and replace with
# the computed eigenfunctions
starts <- purrr::map(gp_att_table, 'first_coef')
ends <- purrr::map(gp_att_table, 'last_coef')
for (i in seq_along(starts)) {
Xp_trend[, c(starts[[i]]:ends[[i]])] <- eigenfuncs[[i]]
}
}
return(Xp_trend)
}
================================================
FILE: R/get_monitor_pars.R
================================================
#' Return parameters to monitor during modelling
#'
#'
#' @param family \code{character}
#' @param smooths_included Logical. Are smooth terms included in the model formula?
#' @param use_lv Logical (use latent variable trends or not)
#' @param trend_model The type of trend model used
#' @param drift Logical (was a drift term estimated or not)
#' @return A string of parameters to monitor
#' @noRd
get_monitor_pars = function(
family,
smooths_included = TRUE,
use_lv,
trend_model,
drift
) {
family <- match.arg(
arg = family,
choices = c(
"negative binomial",
"poisson",
"tweedie",
"beta",
"gaussian",
"lognormal",
"student",
"Gamma",
"nmix",
"binomial",
"bernoulli",
"beta_binomial"
)
)
if (smooths_included) {
param <- c('rho', 'b', 'ypred', 'mus', 'lp__', 'lambda')
} else {
param <- c('b', 'ypred', 'mus', 'lp__')
}
# Family-specific parameters to monitor
param <- c(param, family_param_info(family)$param_names)
# Trend-specific parameters
param <- c(
param,
trend_par_names(trend_model = trend_model, use_lv = use_lv, drift = drift)
)
return(param)
}
================================================
FILE: R/get_mvgam_priors.R
================================================
#' Extract information on default prior distributions for an \pkg{mvgam} model
#'
#' This function lists the parameters that can have their prior distributions
#' changed for a given model, as well listing their default distributions
#'
#' @inheritParams mvgam
#'
#' @inheritParams jsdgam
#'
#' @param ... Not currently used
#'
#' @param factor_formula Can be supplied instead `trend_formula` to match
#' syntax from [jsdgam]
#'
#' @details Users can supply a model formula, prior to fitting the model, so
#' that default priors can be inspected and altered. To make alterations,
#' change the contents of the `prior` column and supplying this
#' \code{data.frame} to the \code{\link{mvgam}} or \code{\link{jsdgam}}
#' functions using the argument `priors`. If using `Stan` as the backend,
#' users can also modify the parameter bounds by modifying the
#' `new_lowerbound` and/or `new_upperbound` columns. This will be necessary
#' if using restrictive distributions on some parameters, such as a Beta
#' distribution for the trend sd parameters for example (Beta only has
#' support on \code{(0,1)}), so the upperbound cannot be above `1`. Another
#' option is to make use of the prior modification functions in \pkg{brms}
#' (i.e. \code{\link[brms]{prior}}) to change prior distributions and bounds
#' (just use the name of the parameter that you'd like to change as the
#' `class` argument; see examples below)
#'
#' @note Only the `prior`, `new_lowerbound` and/or `new_upperbound` columns of
#' the output should be altered when defining the user-defined priors for
#' the model. Use only if you are familiar with the underlying probabilistic
#' programming language. There are no sanity checks done to ensure that the
#' code is legal (i.e. to check that lower bounds are smaller than upper
#' bounds, for example)
#'
#' @author Nicholas J Clark
#'
#' @seealso \code{\link{mvgam}}, \code{\link{mvgam_formulae}},
#' \code{\link[brms]{prior}}
#'
#' @return either a \code{data.frame} containing the prior definitions (if any
#' suitable priors can be altered by the user) or \code{NULL}, indicating
#' that no priors in the model can be modified
#'
#' @examples
#' \dontrun{
#' # ========================================================================
#' # Example 1: Simulate data and inspect default priors
#' # ========================================================================
#'
#' dat <- sim_mvgam(trend_rel = 0.5)
#'
#' # Get a model file that uses default mvgam priors for inspection (not
#' # always necessary, but this can be useful for testing whether your
#' # updated priors are written correctly)
#' mod_default <- mvgam(
#' y ~ s(series, bs = "re") + s(season, bs = "cc") - 1,
#' family = nb(),
#' data = dat$data_train,
#' trend_model = AR(p = 2),
#' run_model = FALSE
#' )
#'
#' # Inspect the model file with default mvgam priors
#' stancode(mod_default)
#'
#' # Look at which priors can be updated in mvgam
#' test_priors <- get_mvgam_priors(
#' y ~ s(series, bs = "re") + s(season, bs = "cc") - 1,
#' family = nb(),
#' data = dat$data_train,
#' trend_model = AR(p = 2)
#' )
#' test_priors
#'
#' # ========================================================================
#' # Example 2: Modify priors manually
#' # ========================================================================
#'
#' # Make a few changes; first, change the population mean for the
#' # series-level random intercepts
#' test_priors$prior[2] <- "mu_raw ~ normal(0.2, 0.5);"
#'
#' # Now use stronger regularisation for the series-level AR2 coefficients
#' test_priors$prior[5] <- "ar2 ~ normal(0, 0.25);"
#'
#' # Check that the changes are made to the model file without any warnings
#' # by setting 'run_model = FALSE'
#' mod <- mvgam(
#' y ~ s(series, bs = "re") + s(season, bs = "cc") - 1,
#' family = nb(),
#' data = dat$data_train,
#' trend_model = AR(p = 2),
#' priors = test_priors,
#' run_model = FALSE
#' )
#' stancode(mod)
#'
#' # No warnings, the model is ready for fitting now in the usual way with
#' # the addition of the 'priors' argument
#'
#' # ========================================================================
#' # Example 3: Use brms syntax for prior modification
#' # ========================================================================
#'
#' # The same can be done using 'brms' functions; here we will also change
#' # the ar1 prior and put some bounds on the ar coefficients to enforce
#' # stationarity; we set the prior using the 'class' argument in all brms
#' # prior functions
#' brmsprior <- c(
#' prior(normal(0.2, 0.5), class = mu_raw),
#' prior(normal(0, 0.25), class = ar1, lb = -1, ub = 1),
#' prior(normal(0, 0.25), class = ar2, lb = -1, ub = 1)
#' )
#' brmsprior
#'
#' mod <- mvgam(
#' y ~ s(series, bs = "re") + s(season, bs = "cc") - 1,
#' family = nb(),
#' data = dat$data_train,
#' trend_model = AR(p = 2),
#' priors = brmsprior,
#' run_model = FALSE
#' )
#' stancode(mod)
#'
#' # ========================================================================
#' # Example 4: Error handling example
#' # ========================================================================
#'
#' # Look at what is returned when an incorrect spelling is used
#' test_priors$prior[5] <- "ar2_bananas ~ normal(0, 0.25);"
#' mod <- mvgam(
#' y ~ s(series, bs = "re") + s(season, bs = "cc") - 1,
#' family = nb(),
#' data = dat$data_train,
#' trend_model = AR(p = 2),
#' priors = test_priors,
#' run_model = FALSE
#' )
#' stancode(mod)
#'
#' # ========================================================================
#' # Example 5: Parametric (fixed effect) priors
#' # ========================================================================
#'
#' simdat <- sim_mvgam()
#'
#' # Add a fake covariate
#' simdat$data_train$cov <- rnorm(NROW(simdat$data_train))
#'
#' priors <- get_mvgam_priors(
#' y ~ cov + s(season),
#' data = simdat$data_train,
#' family = poisson(),
#' trend_model = AR()
#' )
#'
#' # Change priors for the intercept and fake covariate effects
#' priors$prior[1] <- "(Intercept) ~ normal(0, 1);"
#' priors$prior[2] <- "cov ~ normal(0, 0.1);"
#'
#' mod2 <- mvgam(
#' y ~ cov + s(season),
#' data = simdat$data_train,
#' trend_model = AR(),
#' family = poisson(),
#' priors = priors,
#' run_model = FALSE
#' )
#' stancode(mod2)
#'
#' # ========================================================================
#' # Example 6: Alternative brms syntax for fixed effects
#' # ========================================================================
#'
#' # Likewise using 'brms' utilities (note that you can use Intercept rather
#' # than `(Intercept)`) to change priors on the intercept
#' brmsprior <- c(
#' prior(normal(0.2, 0.5), class = cov),
#' prior(normal(0, 0.25), class = Intercept)
#' )
#' brmsprior
#'
#' mod2 <- mvgam(
#' y ~ cov + s(season),
#' data = simdat$data_train,
#' trend_model = AR(),
#' family = poisson(),
#' priors = brmsprior,
#' run_model = FALSE
#' )
#' stancode(mod2)
#'
#' # ========================================================================
#' # Example 7: Bulk prior assignment
#' # ========================================================================
#'
#' # The "class = 'b'" shortcut can be used to put the same prior on all
#' # 'fixed' effect coefficients (apart from any intercepts)
#' set.seed(0)
#' dat <- mgcv::gamSim(1, n = 200, scale = 2)
#' dat$time <- 1:NROW(dat)
#' mod <- mvgam(
#' y ~ x0 + x1 + s(x2) + s(x3),
#' priors = prior(normal(0, 0.75), class = "b"),
#' data = dat,
#' family = gaussian(),
#' run_model = FALSE
#' )
#' stancode(mod)
#' }
#'
#' @export
get_mvgam_priors = function(
formula,
trend_formula,
factor_formula,
knots,
trend_knots,
trend_model = 'None',
family = poisson(),
data,
unit = time,
species = series,
use_lv = FALSE,
n_lv,
trend_map,
...
) {
# Validate the data
dots <- list(...)
if (missing("data")) {
if ('data_train' %in% names(dots)) {
message('argument "data_train" is deprecated; supply as "data" instead')
data <- dots$data_train
dots$data_train <- NULL
} else {
stop('Argument "data" is missing with no default', call. = FALSE)
}
}
if (!missing("data")) {
data_train <- data
}
orig_data <- data_train
# Set trend_formula
if (!missing(factor_formula)) {
if (missing(n_lv)) {
n_lv <- 2
}
validate_pos_integer(n_lv)
unit <- deparse0(substitute(unit))
subgr <- deparse0(substitute(species))
prepped_trend <- prep_jsdgam_trend(unit = unit, subgr = subgr, data = data)
trend_model <- 'None'
data_train <- validate_series_time(data = data, trend_model = prepped_trend)
trend_map <- prep_jsdgam_trendmap(data_train, n_lv)
if (!missing(trend_formula)) {
warning(
'Both "trend_formula" and "factor_formula" supplied\nUsing "factor_formula" as default'
)
}
trend_formula <- factor_formula
}
# Validate the trend arguments
if ('drift' %in% names(dots)) {
message(
'The "drift" argument is deprecated; use fixed effects of "time" instead'
)
dots$drift <- NULL
}
drift <- FALSE
orig_trend_model <- trend_model
trend_model <- validate_trend_model(
orig_trend_model,
drift = drift,
noncentred = FALSE,
warn = FALSE
)
# Ensure series and time variables are present
data_train <- validate_series_time(
data_train,
name = 'data',
trend_model = orig_trend_model
)
# Validate the formula to convert any dynamic() terms
formula <- interpret_mvgam(formula, N = max(data_train$time), family = family)
# Check for gp terms in the validated formula
list2env(
check_gp_terms(formula, data_train, family = family),
envir = environment()
)
# Check for missing rhs in formula
list2env(check_obs_intercept(formula, orig_formula), envir = environment())
# Validate observation formula
formula <- interpret_mvgam(formula, N = max(data_train$time))
data_train <- validate_obs_formula(formula, data = data_train, refit = FALSE)
# Validate the family argument
use_stan <- TRUE
family <- validate_family(family, use_stan = use_stan)
family_char <- match.arg(arg = family$family, choices = family_char_choices())
# Nmixture additions?
list2env(
check_nmix(
family,
family_char,
trend_formula,
trend_model,
trend_map,
data_train,
priors = TRUE
),
envir = environment()
)
# Validate remaining trend arguments
trend_val <- validate_trend_restrictions(
trend_model = trend_model,
formula = formula,
trend_formula = trend_formula,
trend_map = trend_map,
drift = drift,
drop_obs_intercept = drop_obs_intercept,
use_lv = use_lv,
n_lv = n_lv,
data_train = data_train,
use_stan = use_stan,
priors = TRUE
)
list2env(trend_val, envir = environment())
if (is.null(trend_map)) {
trend_map <- rlang::missing_arg()
}
if (is.null(n_lv)) {
n_lv <- rlang::missing_arg()
}
# If trend_formula supplied, first run get_mvgam_priors for the observation model
# and then modify the resulting output
if (!missing(trend_formula)) {
if (trend_model == 'None') {
trend_model <- 'RW'
}
validate_trend_formula(trend_formula)
prior_df <- get_mvgam_priors(
formula = orig_formula,
data = data_train,
family = family,
use_lv = FALSE,
trend_model = if (trend_model == 'None') {
RW()
} else {
orig_trend_model
},
trend_map = trend_map,
knots = knots
)
# Replace any terms labelled 'trend' with 'series' for creating the necessary
# structures
trend_formula <- formula(paste(
gsub('trend', 'series', as.character(trend_formula), fixed = TRUE),
collapse = " "
))
# Drop any intercept from the formula if this is not an N-mixture model or if a
# trend_map was not originally supplied
if (family_char == 'nmix') {
drop_trend_int <- FALSE
} else {
drop_trend_int <- TRUE
}
if (!missing(trend_map)) {
drop_trend_int <- FALSE
}
if (drop_trend_int) {
if (attr(terms(trend_formula), 'intercept') == 1) {
trend_formula <- update(trend_formula, trend_y ~ . - 1)
} else {
trend_formula <- update(trend_formula, trend_y ~ .)
}
} else {
trend_formula <- update(trend_formula, trend_y ~ .)
}
trend_train <- data_train
trend_train$time <- trend_train$index..time..index
trend_train$trend_y <- rnorm(length(trend_train$time))
# Add indicators of trend names as factor levels using the trend_map
trend_indicators <- vector(length = length(trend_train$time))
for (i in 1:length(trend_train$time)) {
trend_indicators[i] <- trend_map$trend[which(
trend_map$series == trend_train$series[i]
)]
}
trend_indicators <- as.factor(paste0('trend', trend_indicators))
trend_train$series <- trend_indicators
trend_train$y <- NULL
# Only keep one time observation per trend
data.frame(
series = trend_train$series,
time = trend_train$time,
row_num = 1:length(trend_train$time)
) %>%
dplyr::group_by(series, time) %>%
dplyr::slice_head(n = 1) %>%
dplyr::pull(row_num) -> inds_keep
if (inherits(trend_train, 'list')) {
trend_train <- lapply(trend_train, function(x) {
if (is.matrix(x)) {
matrix(x[inds_keep, ], ncol = NCOL(x))
} else {
x[inds_keep]
}
})
} else {
trend_train <- trend_train[inds_keep, ]
}
# Now get the priors related to the trend model
trend_prior_df <- get_mvgam_priors(
trend_formula,
data = trend_train,
family = gaussian(),
trend_model = 'None',
knots = trend_knots
)
# Modify some of the term names and return
if (any(grepl('fixed effect', trend_prior_df$param_info))) {
para_lines <- grep('fixed effect', trend_prior_df$param_info)
for (i in para_lines) {
trend_prior_df$param_name[i] <- paste0(
trend_prior_df$param_name[i],
'_trend'
)
trend_prior_df$prior[i] <- paste0(
trimws(strsplit(trend_prior_df$prior[i], "[~]")[[1]][1]),
'_trend ~ student_t(3, 0, 2);'
)
trend_prior_df$example_change[i] <- paste0(
trimws(strsplit(trend_prior_df$example_change[i], "[~]")[[1]][1]),
'_trend ~ normal(0, 1);'
)
}
}
if (any(grepl('(Intercept)', trend_prior_df$param_info))) {
para_lines <- grep('(Intercept)', trend_prior_df$param_info)
for (i in para_lines) {
trend_prior_df$param_name[i] <- paste0(
trend_prior_df$param_name[i],
'_trend'
)
trend_prior_df$prior[i] <- paste0(
trimws(strsplit(trend_prior_df$prior[i], "[~]")[[1]][1]),
'_trend ~ student_t(3, 0, 2);'
)
trend_prior_df$example_change[i] <- paste0(
trimws(strsplit(trend_prior_df$example_change[i], "[~]")[[1]][1]),
'_trend ~ normal(0, 1);'
)
trend_prior_df$param_info[i] <- '(Intercept) for the trend'
}
}
trend_prior_df[] <- lapply(
trend_prior_df,
function(x) gsub("lambda", "lambda_trend", x)
)
trend_prior_df[] <- lapply(
trend_prior_df,
function(x) gsub("n_sp", "n_sp_trend", x)
)
trend_prior_df[] <- lapply(
trend_prior_df,
function(x) gsub("mu_raw", "mu_raw_trend", x)
)
trend_prior_df[] <- lapply(
trend_prior_df,
function(x) gsub("sigma_raw", "sigma_raw_trend", x)
)
trend_prior_df[] <- lapply(
trend_prior_df,
function(x) gsub("n_series", "n_lv", x)
)
trend_prior_df[] <- lapply(
trend_prior_df,
function(x) gsub("series", "trend", x)
)
trend_prior_df[] <- lapply(
trend_prior_df,
function(x) gsub("alpha_gp", "alpha_gp_trend", x)
)
trend_prior_df[] <- lapply(
trend_prior_df,
function(x) gsub("rho_gp", "rho_gp_trend", x)
)
trend_prior_df <- trend_prior_df[
!trend_prior_df$param_info == 'observation error sd',
]
out <- rbind(prior_df, trend_prior_df)
out[] <- lapply(out, function(x) gsub("trend sd", "process error sd", x))
out[] <- lapply(out, function(x) gsub("trend AR1", "process model AR1", x))
out[] <- lapply(out, function(x) gsub("trend AR2", "process model AR2", x))
out[] <- lapply(out, function(x) gsub("trend AR3", "process model AR3", x))
out[] <- lapply(
out,
function(x) gsub("trend drift", "process model drift", x)
)
out[] <- lapply(
out,
function(x) {
gsub(
"vector[n_series] sigma;",
"vector[n_lv] sigma;",
x,
fixed = TRUE
)
}
)
# Remove intercept prior if an intercept was suppressed from the
# observation model
if (drop_obs_intercept) {
if (any(grepl('Intercept', out$param_name))) {
which_obs_int <- grep('Intercept', out$param_name) &
!grep('(Intercept)_trend', out$param_name)
if (length(which_obs_int) > 0L) out <- out[-which_obs_int, ]
}
}
# Remove sigma prior if this is an N-mixture with no dynamics
if (add_nmix & trend_model == 'None') {
out <- out[
-grep('vector[n_lv] sigma;', out$param_name, fixed = TRUE),
]
}
} else {
# JAGS cannot support latent GP, VAR or piecewise trends
if (
!use_stan & trend_model %in% c('GP', 'VAR1', 'PWlinear', 'PWlogistic')
) {
stop(
'Gaussian Process, VAR and piecewise trends not supported for JAGS',
call. = FALSE
)
}
if (use_stan & family_char == 'tweedie') {
warning('Tweedie family not supported for Stan; reverting to JAGS')
use_stan <- FALSE
}
# Number of latent variables cannot be greater than number of series
if (use_lv) {
if (missing(n_lv)) {
n_lv <- min(2, floor(length(unique(data_train$series)) / 2))
}
if (n_lv > length(unique(data_train$series))) {
stop(
'number of latent variables cannot be greater than number of series',
call. = FALSE
)
}
}
# # No point in latent variables if trend model is None
# if(trend_model == 'None' & use_lv){
# use_lv <- FALSE
# warning('No point in latent variables if trend model is None; changing use_lv to FALSE')
# }
# Fill in missing observations in data_train so the size of the dataset is correct when
# building the initial JAGS model
resp_terms <- as.character(terms(formula(formula))[[2]])
if (length(resp_terms) == 1) {
out_name <- as.character(terms(formula(formula))[[2]])
} else {
if (any(grepl('cbind', resp_terms))) {
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
out_name <- resp_terms[1]
}
}
data_train[[out_name]] <- replace_nas(data_train[[out_name]])
# Some general family-level restrictions can now be checked
validate_family_restrictions(
response = data_train[[out_name]],
family = family
)
# Use a small fit from mgcv to extract relevant information on smooths included
# in the model
ss_gam <- try(
mvgam_setup(
formula = formula,
family = family_to_mgcvfam(family),
dat = data_train,
knots = knots
),
silent = TRUE
)
if (inherits(ss_gam, 'try-error')) {
if (grepl('missing values', ss_gam[1])) {
stop(
paste(
'Missing values found in data predictors:\n',
attr(ss_gam, 'condition')
),
call. = FALSE
)
} else {
stop(paste(ss_gam[1]), call. = FALSE)
}
}
# Parametric effect priors
if (use_stan) {
smooth_labs <- do.call(
rbind,
lapply(seq_along(ss_gam$smooth), function(x) {
data.frame(
label = ss_gam$smooth[[x]]$label,
term = paste(ss_gam$smooth[[x]]$term, collapse = ','),
class = class(ss_gam$smooth[[x]])[1]
)
})
)
lpmat <- suppressWarnings(predict(
ss_gam,
type = 'lpmatrix',
exclude = smooth_labs$label
))
para_indices <- which(apply(lpmat, 2, function(x) !all(x == 0)) == TRUE)
int_included <- attr(ss_gam$pterms, 'intercept') == 1L
if (int_included) {
other_pterms <- names(para_indices)[-1]
} else {
other_pterms <- names(para_indices)
}
all_paras <- other_pterms
para_priors <- c()
para_info <- c()
if (length(other_pterms) > 0) {
para_priors <- c(
para_priors,
paste(other_pterms, '~ student_t(3, 0, 2);')
)
para_info <- c(para_info, paste(other_pterms, 'fixed effect'))
}
if (int_included) {
all_paras <- c('(Intercept)', all_paras)
# Compute default intercept prior using brms
def_int <- make_default_int(response = data_train$y, family = family)
para_priors <- c(
paste0(def_int$class, ' ~ ', def_int$prior, ';'),
para_priors
)
para_info <- c('(Intercept)', para_info)
}
if (length(all_paras) == 0) {
para_df <- NULL
} else {
para_df <- data.frame(
param_name = all_paras,
param_length = 1,
param_info = para_info,
prior = para_priors,
example_change = c(
paste0(all_paras, ' ~ normal(0, 1);')
)
)
}
} else {
para_df <- NULL
}
# Extract information on the number of smoothing parameters and
# random effects
smooth_labs <- do.call(
rbind,
lapply(seq_along(ss_gam$smooth), function(x) {
data.frame(
label = ss_gam$smooth[[x]]$label,
class = class(ss_gam$smooth[[x]])[1],
nsp = ss_gam$smooth[[x]]$last.sp -
ss_gam$smooth[[x]]$first.sp +
1
)
})
)
# Check for gp() terms
if (!is.null(gp_terms)) {
gp_additions <- make_gp_additions(
gp_details = gp_details,
orig_formula = orig_formula,
data = data_train,
newdata = NULL,
model_data = list(X = t(predict(ss_gam, type = 'lpmatrix'))),
mgcv_model = ss_gam,
gp_terms = gp_terms,
family = family
)
gp_names <- unlist(
purrr::map(gp_additions$gp_att_table, 'name'),
use.names = FALSE
)
gp_isos <- unlist(
purrr::map(gp_additions$gp_att_table, 'iso'),
use.names = FALSE
)
abbv_names <- vector(mode = 'list', length = length(gp_names))
full_names <- vector(mode = 'list', length = length(gp_names))
for (i in seq_len(length(gp_names))) {
if (gp_isos[i]) {
abbv_names[[i]] <- gp_names[i]
full_names[[i]] <- paste0(gp_names[i], '[1]')
} else {
abbv_names[[i]] <- paste0(gp_names[i], '[1][', 1:2, ']')
full_names[[i]] <- paste0(gp_names[i], '[1][', 1:2, ']')
}
}
full_names <- unlist(full_names, use.names = FALSE)
abbv_names <- unlist(abbv_names, use.names = FALSE)
alpha_priors <- unlist(
purrr::map(gp_additions$gp_att_table, 'def_alpha'),
use.names = FALSE
)
rho_priors <- unlist(
purrr::map(gp_additions$gp_att_table, 'def_rho'),
use.names = FALSE
)
rho_2_priors <- unlist(
purrr::map(gp_additions$gp_att_table, 'def_rho_2'),
use.names = FALSE
)
full_priors <- vector(mode = 'list', length = length(gp_names))
for (i in seq_len(length(gp_names))) {
if (gp_isos[i]) {
full_priors[[i]] <- rho_priors[i]
} else {
full_priors[[i]] <- c(rho_priors[i], rho_2_priors[i])
}
}
full_priors <- unlist(full_priors, use.names = FALSE)
smooth_labs <- smooth_labs %>%
dplyr::filter(
!label %in%
gsub('gp(', 's(', gp_names, fixed = TRUE)
)
alpha_df <- data.frame(
param_name = paste0('real alpha_', gp_names, ';'),
param_length = 1,
param_info = paste(gp_names, 'marginal deviation'),
prior = paste0('alpha_', gp_names, ' ~ ', alpha_priors, ';'),
example_change = paste0(
'alpha_',
gp_names,
' ~ ',
'normal(0, ',
round(runif(length(gp_names), 0.5, 1), 2),
');'
)
)
rho_df <- data.frame(
param_name = paste0('real rho_', abbv_names, ';'),
param_length = 1,
param_info = paste(abbv_names, 'length scale'),
prior = paste0('rho_', full_names, ' ~ ', full_priors, ';'),
example_change = paste0(
'rho_',
full_names,
' ~ ',
'normal(0, ',
round(runif(length(full_names), 0.5, 1), 2),
');'
)
)
gp_df <- rbind(alpha_df, rho_df)
} else {
gp_df <- NULL
}
# Smoothing parameter priors for non-random effect smooths
if (any(smooth_labs$class != 'random.effect')) {
n_smooth_params <- smooth_labs %>%
dplyr::filter(class != 'random.effect') %>%
dplyr::pull(nsp)
nonre_smooths <- smooth_labs %>%
dplyr::filter(class != 'random.effect') %>%
dplyr::pull(label)
if (use_stan) {
sp_df <- data.frame(
param_name = 'vector[n_sp] lambda;',
param_length = sum(smooth_labs$nsp),
param_info = c(paste(
nonre_smooths,
'smooth parameters',
collapse = ', '
)),
prior = 'lambda ~ normal(5, 30);',
# Add an example for changing the prior; note that it is difficult to
# understand how to change individual smoothing parameter priors because each
# one acts on a different subset of the smooth function parameter space
example_change = c(
paste0(
'lambda ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
} else {
# Not recommended to alter smoothing parameter priors for JAGS as the Gibbs sampler
# needs to have informative priors to have any hope of convergence
sp_df <- NULL
}
} else {
sp_df <- NULL
}
# Population mean and sd priors for random effect smooths
if (any(smooth_labs$class == 'random.effect')) {
re_smooths <- smooth_labs %>%
dplyr::filter(class == 'random.effect') %>%
dplyr::pull(label)
n_re_terms <- length(re_smooths)
if (use_stan) {
re_df <- data.frame(
param_name = c(
paste0('vector[', n_re_terms, '] mu_raw;'),
paste0('vector[', n_re_terms, '] sigma_raw;')
),
param_length = rep(n_re_terms, 2),
param_info = c(
paste(re_smooths, 'pop mean', collapse = ', '),
paste(re_smooths, 'pop sd', collapse = ', ')
),
prior = c('mu_raw ~ std_normal();', 'sigma_raw ~ exponential(0.5);')
)
# Add example change that users could implement to put different priors
# on each re's mean and sd
if (n_re_terms > 1) {
re_df <- cbind(
re_df,
data.frame(
example_change = c(
paste(
paste0(
'mu_raw[',
1:n_re_terms,
'] ~ normal(',
round(runif(min = -1, max = 1, n = n_re_terms), 2),
', ',
round(runif(min = 0.1, max = 1, n = n_re_terms), 2),
');'
),
collapse = '\n'
),
paste(
paste0(
'sigma_raw[',
1:n_re_terms,
'] ~ exponential(',
round(runif(min = 0.01, max = 1, n = n_re_terms), 2),
');'
),
collapse = '\n'
)
)
)
)
} else {
re_df <- cbind(
re_df,
data.frame(
example_change = c(
paste0(
'mu_raw ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'sigma_raw ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
)
}
} else {
# If using JAGS as the backend
re_df <- data.frame(
param_name = c(
paste0('mu_raw', 1:n_re_terms),
paste0('sigma_raw', 1:n_re_terms, '')
),
param_length = 1,
param_info = c(
paste(re_smooths, 'pop mean'),
paste(re_smooths, 'pop sd')
),
prior = c(
paste0('mu_raw', 1:n_re_terms, ' ~ dnorm(0, 1)'),
paste0('sigma_raw', 1:n_re_terms, ' ~ dexp(0.5)')
)
)
# Add example change that users could implement to put different priors
# on each re's mean and sd
if (n_re_terms > 1) {
re_df <- cbind(
re_df,
data.frame(
example_change = c(
paste(paste0(
'mu_raw',
1:n_re_terms,
' ~ dnorm(',
round(runif(min = -1, max = 1, n = n_re_terms), 2),
', ',
round(runif(min = 0.1, max = 10, n = n_re_terms), 2),
')'
)),
paste(paste0(
'sigma_raw',
1:n_re_terms,
' ~ dexp(',
round(runif(min = 0.01, max = 1, n = n_re_terms), 2),
')'
))
)
)
)
} else {
re_df <- cbind(
re_df,
data.frame(
example_change = c(
paste0(
'mu_raw ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')'
),
paste0(
'sigma_raw ~ dexp(',
round(runif(min = 0.01, max = 1, n = 1), 2),
')'
)
)
)
)
}
}
} else {
re_df <- NULL
}
# Extract information on priors for trend components
trend_df <- NULL
if (trend_model %in% c('PWlinear', 'PWlogistic')) {
# Need to fix this as a next priority
# trend_df <- NULL
trend_df <- data.frame(
param_name = c(
'vector[n_series] k_trend;',
'vector[n_series] m_trend;'
),
param_length = length(unique(data_train$series)),
param_info = c('base trend growth rates', 'trend offset parameters'),
prior = c('k_trend ~ std_normal();', 'm_trend ~ student_t(3, 0, 2.5);'),
example_change = c(
paste0(
'k ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'm ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
}
if (trend_model == 'GP') {
if (use_lv) {
trend_df <- data.frame(
param_name = c('vector[n_lv] rho_gp;'),
param_length = n_lv,
param_info = c('trend length scale'),
prior = c('rho_gp ~ inv_gamma(1.499007, 5.670433);'),
example_change = paste0(
'rho_gp ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
} else {
trend_df <- data.frame(
param_name = c(
'vector[n_series] alpha_gp;',
'vector[n_series] rho_gp;'
),
param_length = length(unique(data_train$series)),
param_info = c('trend amplitude', 'trend length scale'),
prior = c(
'alpha_gp ~ normal(0, 0.5);',
'rho_gp ~ inv_gamma(1.499007, 5.670433);'
),
example_change = c(
paste0(
'alpha_gp ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'rho_gp ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
}
trend_df <- rbind(
trend_df,
data.frame(
param_name = c('int num_gp_basis;'),
param_length = 1,
param_info = c('basis dimension for approximate GP'),
prior = c('num_gp_basis = min(20, n);'),
example_change = 'num_gp_basis = 12;'
)
)
}
if (trend_model %in% c('ZMVN', 'ZMVNhiercor')) {
trend_df <- data.frame(
param_name = c(paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)),
param_length = ifelse(use_lv, n_lv, length(unique(data_train$series))),
param_info = c('residual sd'),
prior = c('sigma ~ exponential(2);'),
example_change = c(
paste0(
'sigma ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
}
if (trend_model %in% c('RW', 'RWcor', 'RWhiercor')) {
if (use_stan) {
trend_df <- data.frame(
param_name = c(paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c('trend sd'),
prior = c('sigma ~ exponential(2);'),
example_change = c(
paste0(
'sigma ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
} else {
trend_df <- data.frame(
param_name = c('vector[n_series] sigma'),
param_length = length(unique(data_train$series)),
param_info = 'trend sd (for each series s)',
prior = c('sigma[s] ~ dexp(1)T(0.075, 5)'),
example_change = c(
paste0(
'sigma[s] ~ dexp(',
round(runif(min = 0.01, max = 1, n = 1), 2),
')'
)
)
)
}
}
if (trend_model == 'VAR1') {
trend_df <- data.frame(
param_name = c('vector[n_series] sigma;'),
param_length = c(length(unique(data_train$series))),
param_info = c('trend sd'),
prior = c('sigma ~ inv_gamma(2.3693353, 0.7311319);'),
example_change = c(
paste0(
'sigma ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
trend_df <- rbind(
trend_df,
data.frame(
param_name = c(
"real es[1];",
"real es[2];",
"real fs[1];",
"real fs[2];",
"real gs[1];",
"real gs[2];",
"real hs[1];",
"real hs[2];"
),
param_length = 1,
param_info = c(
'diagonal autocorrelation population mean',
'off-diagonal autocorrelation population mean',
'diagonal autocorrelation population variance',
'off-diagonal autocorrelation population variance',
'shape1 for diagonal autocorrelation precision',
'shape1 for off-diagonal autocorrelation precision',
'shape2 for diagonal autocorrelation precision',
'shape2 for off-diagonal autocorrelation precision'
),
prior = c(
"es[1] = 0;",
"es[2] = 0;",
"fs[1] = sqrt(0.455);",
"fs[2] = sqrt(0.455);",
"gs[1] = 1.365;",
"gs[2] = 1.365;",
"hs[1] = 0.071175;",
"hs[2] = 0.071175;"
),
example_change = c(
"es[1] = 0.5;",
"es[2] = 0.1;",
"fs[1] = 0.6;",
"fs[2] = 0.3;",
"gs[1] = 1.1;",
"gs[2] = 1.07;",
"hs[1] = 0.08;",
"hs[2] = 0.1;"
)
)
)
}
if (trend_model %in% c('VAR1cor', 'VARhiercor', 'VARMA1,1cor')) {
trend_df <- data.frame(
param_name = c('vector[n_series] sigma;'),
param_length = c(length(unique(data_train$series))),
param_info = c('trend sd'),
prior = c('sigma ~ inv_gamma(2.3693353, 0.7311319);'),
example_change = c(
paste0(
'sigma ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
trend_df <- rbind(
trend_df,
data.frame(
param_name = c(
"real es[1];",
"real es[2];",
"real fs[1];",
"real fs[2];",
"real gs[1];",
"real gs[2];",
"real hs[1];",
"real hs[2];",
"real L_Omega;"
),
param_length = 1,
param_info = c(
'diagonal autocorrelation population mean',
'off-diagonal autocorrelation population mean',
'diagonal autocorrelation population variance',
'off-diagonal autocorrelation population variance',
'shape1 for diagonal autocorrelation precision',
'shape1 for off-diagonal autocorrelation precision',
'shape2 for diagonal autocorrelation precision',
'shape2 for off-diagonal autocorrelation precision',
'LKJ prior on trend error correlations'
),
prior = c(
"es[1] = 0;",
"es[2] = 0;",
"fs[1] = sqrt(0.455);",
"fs[2] = sqrt(0.455);",
"gs[1] = 1.365;",
"gs[2] = 1.365;",
"hs[1] = 0.071175;",
"hs[2] = 0.071175;",
"L_Omega ~ lkj_corr_cholesky(2);"
),
example_change = c(
"es[1] = 0.5;",
"es[2] = 0.1;",
"fs[1] = 0.6;",
"fs[2] = 0.3;",
"gs[1] = 1.1;",
"gs[2] = 1.07;",
"hs[1] = 0.08;",
"hs[2] = 0.1;",
"L_Omega ~ lkj_corr_cholesky(4);"
)
)
)
}
if (trend_model == 'CAR1') {
trend_df <- data.frame(
param_name = c(
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar1;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)
),
param_length = ifelse(use_lv, n_lv, length(unique(data_train$series))),
param_info = c('trend AR1 coefficient', 'trend sd'),
prior = c('ar1 ~ std_normal();', 'sigma ~ exponential(2);'),
example_change = c(
paste0(
'ar1 ~ normal(',
round(runif(min = 0.1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'sigma ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
}
if (trend_model %in% c('AR1', 'AR1cor', 'AR1hiercor')) {
if (use_stan) {
trend_df <- data.frame(
param_name = c(
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar1;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)
),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c('trend AR1 coefficient', 'trend sd'),
prior = c('ar1 ~ std_normal();', 'sigma ~ exponential(2);'),
example_change = c(
paste0(
'ar1 ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'sigma ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
} else {
trend_df <- data.frame(
param_name = c(
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar1;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)
),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c(
'trend AR1 coefficient (for each series s)',
'trend sd (for each series s)'
),
prior = c('ar1[s] ~ dnorm(0, 10)', 'sigma[s] ~ dexp(2)T(0.075, 5)'),
example_change = c(
paste0(
'ar1[s] ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')'
),
paste0(
'sigma[s] ~ dexp(',
round(runif(min = 0.01, max = 1, n = 1), 2),
')'
)
)
)
}
}
if (trend_model %in% c('AR2', 'AR2cor', 'AR2hiercor')) {
if (use_stan) {
trend_df <- data.frame(
param_name = c(
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar1;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar2;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)
),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c(
'trend AR1 coefficient',
'trend AR2 coefficient',
'trend sd'
),
prior = c(
'ar1 ~ std_normal();',
'ar2 ~ std_normal();',
'sigma ~ exponential(2);'
),
example_change = c(
paste0(
'ar1 ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'ar2 ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'sigma ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
} else {
trend_df <- data.frame(
param_name = c(
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar1;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar2;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)
),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c(
'trend AR1 coefficient (for each series s)',
'trend AR2 coefficient (for each series s)',
'trend sd (for each series s)'
),
prior = c(
'ar1[s] ~ dnorm(0, 10)',
'ar2[s] ~ dnorm(0, 10)',
'sigma[s] ~ dexp(2)T(0.075, 5)'
),
example_change = c(
paste0(
'ar1[s] ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')'
),
paste0(
'ar2[s] ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')'
),
paste0(
'sigma[s] ~ dexp(',
round(runif(min = 0.01, max = 1, n = 1), 2),
')'
)
)
)
}
}
if (trend_model %in% c('AR3', 'AR3cor', 'AR3hiercor')) {
if (use_stan) {
trend_df <- data.frame(
param_name = c(
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar1;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar2;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar3;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)
),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c(
'trend AR1 coefficient',
'trend AR2 coefficient',
'trend AR3 coefficient',
'trend sd'
),
prior = c(
'ar1 ~ std_normal();',
'ar2 ~ std_normal();',
'ar3 ~ std_normal();',
'sigma ~ exponential(2);'
),
example_change = c(
paste0(
'ar1 ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'ar2 ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'ar3 ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
),
paste0(
'sigma ~ exponential(',
round(runif(min = 0.01, max = 1, n = 1), 2),
');'
)
)
)
} else {
trend_df <- data.frame(
param_name = c(
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar1;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar2;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] ar3;'
),
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
)
),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c(
'trend AR1 coefficient (for each series s)',
'trend AR2 coefficient (for each series s)',
'trend AR3 coefficient (for each series s)',
'trend sd (for each series s)'
),
prior = c(
'ar1[s] ~ dnorm(0, 10)',
'ar2[s] ~ dnorm(0, 10)',
'ar3[s] ~ dnorm(0, 10)',
'sigma[s] ~ dexp(2)T(0.075, 5)'
),
example_change = c(
paste0(
'ar1[s] ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')'
),
paste0(
'ar2[s] ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')'
),
paste0(
'ar3[s] ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')'
),
paste0(
'sigma[s] ~ dexp(',
round(runif(min = 0.01, max = 1, n = 1), 2),
')'
)
)
)
}
}
# Remove options for trend variance priors if using a dynamic factor model
if (use_lv) {
if (missing(trend_map)) {
trend_df %>%
dplyr::filter(
!grepl(
paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] sigma;'
),
param_name,
fixed = TRUE
)
) -> trend_df
}
if (use_stan) {
if (missing(trend_map)) {
trend_df <- rbind(
trend_df,
data.frame(
param_name = c('vector[M] L;'),
param_length = n_lv * length(unique(data_train$series)),
param_info = c('factor loadings'),
prior = c('L ~ student_t(5, 0, 1);'),
example_change = 'L ~ std_normal();'
)
)
}
}
}
# Extract drift parameter information
if (drift) {
if (use_stan) {
drift_df <- data.frame(
param_name = paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] drift;'
),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c('trend drift'),
prior = c('drift ~ std_normal();'),
example_change = c(
paste0(
'drift ~ normal(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
');'
)
)
)
} else {
drift_df <- data.frame(
param_name = paste0(
'vector[',
ifelse(use_lv, 'n_lv', 'n_series'),
'] drift;'
),
param_length = ifelse(
use_lv,
n_lv,
length(unique(data_train$series))
),
param_info = c('trend drift (for each series s)'),
prior = c('drift ~ dnorm(0, 10)'),
example_change = c(
paste0(
'drift ~ dnorm(',
round(runif(min = -1, max = 1, n = 1), 2),
', ',
round(runif(min = 0.1, max = 1, n = 1), 2),
')'
)
)
)
}
} else {
drift_df <- NULL
}
# Extract information for family-specific parameters
family_df <- family_prior_info(
family = family_char,
use_stan = use_stan,
data = data_train
)
# Return the dataframe of prior information
prior_df <- rbind(
para_df,
gp_df,
sp_df,
re_df,
trend_df,
drift_df,
family_df
)
prior_df$new_lowerbound <- NA
prior_df$new_upperbound <- NA
# Final update to use more brms-like default priors on
# scale parameters
def_scale_prior <- update_default_scales(
response = replace_nas(data_train[[out_name]]),
family = family
)
# Update in priors df
if (any(grepl('sigma|sigma_raw|sigma_obs', prior_df$prior))) {
lines_with_scales <- grep('sigma|sigma_raw|sigma_obs', prior_df$prior)
for (i in lines_with_scales) {
prior_df$prior[i] <- paste0(
trimws(strsplit(prior_df$prior[i], "[~]")[[1]][1]),
' ~ ',
def_scale_prior,
';'
)
}
}
out <- prior_df
}
return(out)
}
#' @export
#' @importFrom brms prior
brms::prior
#' @export
#' @importFrom brms prior_
brms::prior_
#' @export
#' @importFrom brms set_prior
brms::set_prior
#' @export
#' @importFrom brms prior_string
brms::prior_string
#' Use informative scale and intercept priors following brms example
#' @importFrom stats mad qcauchy setNames
#' @importFrom brms logm1 prior_string get_prior
#' @noRd
make_default_scales = function(response, family) {
def_scale_prior <- update_default_scales(response, family)
c(
prior_string(def_scale_prior, class = 'sigma'),
prior_string(def_scale_prior, class = 'sigma_raw'),
prior_string(def_scale_prior, class = 'sigma_obs')
)
}
#' @noRd
make_default_int = function(response, family) {
if (all(is.na(response))) {
out <- prior_string("student_t(3, 0, 3.5)", class = '(Intercept)')
} else if (family$family == 'nmix') {
# Intercept prior in N-Mixtures applies to avg detection probability
out <- prior_string("normal(0, 1.5)", class = '(Intercept)')
} else {
resp_dat <- data.frame(y = response[!is.na(response)])
int_prior <- get_prior(
y ~ 1,
data = resp_dat,
family = family_to_brmsfam(family)
)
out <- prior_string(
int_prior$prior[which(int_prior$class == 'Intercept')],
class = '(Intercept)'
)
}
return(out)
}
#' @noRd
linkfun = 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 = plogis(x),
probit = qnorm(x),
cauchit = qcauchy(x),
probit_approx = qnorm(x),
squareplus = (x^2 - 1) / x,
stop("Link '", link, "' is not supported.", call. = FALSE)
)
}
#' @noRd
update_default_scales = function(
response,
family,
df = 3,
center = TRUE
) {
if (all(is.na(response))) {
out <- paste0(
"student_t(",
paste0(as.character(c(df, '0', '3')), collapse = ", "),
")"
)
} else {
y <- response[!is.na(response)]
link <- family$link
if (link %in% c("log", "inverse", "1/mu^2")) {
# avoid Inf in link(y)
y <- ifelse(y == 0, y + 0.1, y)
}
y_link <- suppressWarnings(linkfun(y, link = link))
scale_y <- round(mad(y_link, na.rm = TRUE), 1)
if (scale_y <= 5) {
out <- 'inv_gamma(1.418, 0.452)'
}
if (
scale_y > 5 &
scale_y <= 20
) {
out <- 'inv_gamma(0.9187, 0.3516)'
}
if (scale_y > 20) {
out <- paste0(
"student_t(",
paste0(as.character(c(df, 0, scale_y)), collapse = ", "),
")"
)
}
}
return(out)
}
================================================
FILE: R/globals.R
================================================
#' Prevent R CMD Check notes about missing global variables due to
#' dplyr mutates etc...
#' @noRd
utils::globalVariables(c(
"y",
"year",
"smooth_vals",
"smooth_num",
"series",
"season",
"rowid",
"row_number",
"nsp",
"last_assim",
"index",
"in_interval",
"assimilated",
"eval_horizon",
"label",
"mod_call",
"particles",
"obs",
"mgcv_model",
"param_name",
"outcome",
"mgcv_plottable",
"term",
"data_test",
"object",
"row_num",
"trends_test",
"trend",
"trend_series",
"trend_y",
".",
"gam",
"group",
"mod",
"row_id",
"byvar",
"direction",
"index..time..index",
"trend_test",
"Var2",
"add_cor",
"add_ma",
"add_nmix",
"binomial",
"current",
"drop_obs_intercept",
"gp_details",
"gp_terms",
"k",
"mus",
"name",
"needed",
"nmix_trendmap",
"orig_formula",
"trial",
"use_var1",
"use_var1cor",
"xcols_drop",
"time_lag",
"dis_time",
"maxt",
"orig_rows",
"matches",
"time.",
"file_name",
".data",
"horizon",
"target",
"Series",
"evd",
"mean_evd",
"total_evd",
"smooth_label",
"by_variable",
"gr",
"tot_subgrs",
"subgr",
"lambda",
"level",
"sim_hilbert_gp",
"trend_model",
"jags_path",
"x",
"elpds",
"pareto_ks",
"value",
"threshold",
"colour",
"resids",
"c_dark",
"eval_timepoints",
"yqlow",
"ymidlow",
"ymidhigh",
"yqhigh",
"preds",
"yhigh",
"ylow",
"weight",
"orig_weight",
"imp_resp",
"lower1",
"lower2",
"lower3",
"lower4",
"med",
"resp_var",
"upper1",
"upper2",
"upper3",
"upper4",
"draw",
"fevd_Qlower",
"fevd_Qupper",
"fevd_median",
"shock",
"irf_median",
"irf_Qlower",
"irf_Qupper",
"fevdQ50",
"parameter",
"pred_median",
"pred_Qupper",
"pred_Qlower",
"lower_deriv",
"med_deriv",
"upper_deriv",
"sum_contribution",
"total",
"Contribution",
"Var1",
"lv",
"correlation",
"Factor",
"contribution",
"unit",
"lw",
"data"
))
================================================
FILE: R/gp.R
================================================
#' Re-label gp terms inside an mgcv gam object for nicer plotting
#' @noRd
relabel_gps = function(mgcv_model) {
if (length(mgcv_model$smooth) > 0L) {
# Get classes of all smooths
smooth_classes <- purrr::map(mgcv_model$smooth, class)
# Check for gp() terms
for (x in seq_along(smooth_classes)) {
if (any(smooth_classes[[x]] %in% 'hilbert.smooth')) {
mgcv_model$smooth[[x]]$label <-
gsub('s\\(|ti\\(', 'gp(', mgcv_model$smooth[[x]]$label)
}
}
}
return(mgcv_model)
}
#' @noRd
seq_cols <- function(x) {
seq_len(NCOL(x))
}
#' Make gp() attributes table and necessary stan lines
#' @importFrom brms brm standata
#' @noRd
make_gp_additions = function(
gp_details,
orig_formula,
data,
newdata,
model_data,
mgcv_model,
gp_terms,
family = gaussian(),
rho_names
) {
by <- gp_details$by
gp_details$row_id <- 1:NROW(gp_details)
gp_covariates <- gp_details$gp_covariates
gp_details_orig <- gp_details
if (any(!is.na(by))) {
for (i in 1:length(by)) {
if (!is.na(by[i])) {
if (is.factor(data[[by[i]]])) {
nlevels <- length(levels(droplevels(data[[by[i]]])))
new_details <- do.call(
rbind,
lapply(1:nlevels, function(x) {
gp_details_orig[i, ]
})
)
new_details$level <- levels(droplevels(data[[by[i]]]))
rows_drop <- which(
gp_details$gp_covariates == gp_covariates[i] &
gp_details$by == by[i]
)
gp_details <- gp_details[-rows_drop, ]
gp_details <- rbind(gp_details, new_details)
}
}
}
}
# Preserve ordering of terms
gp_details %>%
dplyr::arrange(row_id, level) %>%
dplyr::select(-row_id) -> gp_details
# Initiate a brms GP model using the 'mock' backend so it doesn't actually fit;
terms_needed <- unique(c(
unlist(strsplit(gp_details$gp_covariates, ", |\\n")),
unlist(strsplit(gp_details$by, ", |\\n"))
))
terms_needed <- terms_needed[!is.na(terms_needed)]
terms_needed <- terms_needed[!terms_needed %in% c('series', 'time')]
brms_fake_df <- data.frame(
.fake_gp_y = rnorm(length(data[[1]])),
series = data$series,
time = data$index..time..index
)
for (i in seq_along(terms_needed)) {
brms_fake_df <- cbind(brms_fake_df, data[[terms_needed[i]]])
}
colnames(brms_fake_df) <- c('.fake_gp_y', 'series', 'time', terms_needed)
brms_fake_df <- brms_fake_df %>%
dplyr::arrange(time, series)
# Build the gp formula to pass to the mock brms
gp_formula <- reformulate(
attr(terms(attr(gp_details, 'gp_formula')), 'term.labels'),
'.fake_gp_y'
)
brms_mock <- brms::brm(
gp_formula,
data = brms_fake_df,
mock_fit = 1,
backend = "mock",
rename = FALSE
)
brms_mock <- trim_mockbrms(brms_mock)
# Eigenfunction design matrices (to be inserted into Xp matrices)
brms_mock_data <- brms::standata(brms_mock)
eigenfuncs <- eigenfunc_list(
stan_data = brms_mock_data,
mock_df = brms_fake_df,
by = gp_details$by,
level = gp_details$level
)
# Eigenvalues (l_gp in mvgam stancode)
eigenvals <- eigenval_list(brms_mock_data)
# If newdata supplied, compute the eigenfunctions for these out of
# sample data points
if (!is.null(newdata)) {
brms_fake_df_new <- data.frame(
.fake_gp_y = rnorm(length(newdata[[1]])),
series = newdata$series,
time = newdata$index..time..index
)
for (i in seq_along(terms_needed)) {
brms_fake_df_new <- cbind(brms_fake_df_new, newdata[[terms_needed[i]]])
}
colnames(brms_fake_df_new) <- c(
'.fake_gp_y',
'series',
'time',
terms_needed
)
brms_fake_df_new <- brms_fake_df_new %>%
dplyr::arrange(time, series)
# Compute eigenfunctions for these new data and bind to the
# training data eigenfunctions
brms_mock_data_new <- brms::standata(
brms_mock,
newdata = brms_fake_df_new,
internal = TRUE
)
eigenfuncs_new <- eigenfunc_list(
stan_data = brms_mock_data_new,
mock_df = brms_fake_df_new,
by = gp_details$by,
level = gp_details$level
)
for (i in seq_along(eigenfuncs)) {
eigenfuncs[[i]] <- rbind(eigenfuncs[[i]], eigenfuncs_new[[i]])
}
}
# Numbers of basis functions (k_gp in mvgam stancode)
k_gps <- lapply(eigenvals, function(x) NROW(x))
# Put all relevant data into a list
gp_data <- lapply(seq_along(eigenvals), function(x) {
byname <- ifelse(is.na(gp_details$by[x]), '', paste0(':', gp_details$by[x]))
covariate_name <- paste0('gp(', gp_details$gp_covariates[x], ')', byname)
if (!is.na(gp_details$level[x])) {
covariate_name <- paste0(covariate_name, gp_details$level[x])
}
orig_name <- if (gp_details$dim[x] > 1L) {
paste0('ti(', gp_details$gp_covariates[x], ')', byname)
} else {
paste0('s(', gp_details$gp_covariates[x], ')', byname)
}
if (!is.na(gp_details$level[x])) {
orig_name <- paste0(orig_name, gp_details$level[x])
}
att_table <- list(
effect = 'gp',
name = covariate_name,
orig_name = orig_name,
dim = gp_details$dim[x],
iso = gp_details$iso[x],
kernel = gp_details$kernel[x],
covariate = gp_details$gp_covariates[x],
by = gp_details$b[x],
level = gp_details$level[x],
k = k_gps[[x]],
def_rho = gp_details$def_rho[x],
def_rho_2 = gp_details$def_rho_2[x],
def_rho_3 = gp_details$def_rho_3[x],
def_rho_4 = gp_details$def_rho_4[x],
def_alpha = gp_details$def_alpha[x],
eigenvalues = eigenvals[[x]]
)
# Items to add to Stan data
# Number of basis functions
covariate_name <- clean_gpnames(covariate_name)
data_lines <- paste0(
'int k_',
covariate_name,
'; // basis functions for approximate gp\n'
)
append_dat <- list(k = k_gps[[x]])
names(append_dat) <- paste0('k_', covariate_name, '')
# Approximate GP eigenvalues
data_lines <- paste0(
data_lines,
paste0(
'array[',
'k_',
covariate_name,
'] vector[',
gp_details$dim[x],
'] l_',
covariate_name,
'; // approximate gp eigenvalues\n'
),
collapse = '\n'
)
append_dat2 <- list(slambda = eigenvals[[x]])
names(append_dat2) <- paste0('l_', covariate_name, '')
append_dat <- append(append_dat, append_dat2)
# Return necessary objects in a list
list(
att_table = att_table,
data_lines = data_lines,
data_append = append_dat,
eigenfunctions = eigenfuncs[[x]]
)
})
# Consolidate Stan data objects and add to model_data
gp_stan_data <- do.call(c, purrr::map(gp_data, 'data_append'))
model_data <- append(model_data, gp_stan_data)
# Consolidate attribute tables
gp_att_table <- purrr::map(gp_data, 'att_table')
# Create updated design matrix by replacing the s() basis functions with
# the gp() eigenfunctions
coefs_replace <- list()
for (x in gp_terms) {
label <- attr(terms(formula(mgcv_model), keep.order = TRUE), 'term.labels')[
x
]
s_attributes <- eval(rlang::parse_expr(label))
if (s_attributes$by != 'NA') {
if (grepl('ti(', label, fixed = TRUE)) {
coef_name <- paste0(
'ti(',
paste(s_attributes$term, collapse = ','),
'):',
s_attributes$by
)
} else {
coef_name <- paste0('s(', s_attributes$term, '):', s_attributes$by)
}
} else {
if (grepl('ti(', label, fixed = TRUE)) {
coef_name <- paste0(
'ti(',
paste(s_attributes$term, collapse = ','),
')'
)
} else {
coef_name <- paste0('s(', s_attributes$term, ')')
}
}
which_replace <- grep(coef_name, names(coef(mgcv_model)), fixed = TRUE)
names(mgcv_model$coefficients)[which_replace] <-
if (grepl('ti(', label, fixed = TRUE)) {
gsub(
'ti(',
'gp(',
names(mgcv_model$coefficients)[which_replace],
fixed = TRUE
)
} else {
gsub(
's(',
'gp(',
names(mgcv_model$coefficients)[which_replace],
fixed = TRUE
)
}
coefs_replace[[x]] <- which_replace
}
# Replace basis functions with gp() eigenfunctions
newX <- model_data$X
# Add eigenfunctions to the GAM design matrix
eigenfuncs <- do.call(cbind, purrr::map(gp_data, 'eigenfunctions'))
newX[unlist(coefs_replace), ] <- t(eigenfuncs)
model_data$X <- newX
# Consolidate Stan data lines
gp_stan_lines <- paste0(purrr::map(gp_data, 'data_lines'), collapse = '')
# Add coefficient indices to attribute table and to Stan data
for (covariate in seq_along(gp_att_table)) {
clean_name <- gsub(' ', '', gp_att_table[[covariate]]$name)
clean_coefs <- sub("^(.*)[.].*", "\\1", names(coef(mgcv_model)))
coef_indices <- which(
clean_coefs %in%
clean_name &
!grepl(
paste0(gp_att_table[[covariate]]$name, ':'),
names(coef(mgcv_model)),
fixed = TRUE
) ==
TRUE
)
gp_att_table[[covariate]]$first_coef <- min(coef_indices)
gp_att_table[[covariate]]$last_coef <- max(coef_indices)
gp_names <- clean_gpnames(gp_att_table[[covariate]]$name)
gp_stan_lines <- paste0(
gp_stan_lines,
paste0(
'array[',
gp_att_table[[covariate]]$k,
'] int b_idx_',
gp_names,
'; // gp basis coefficient indices\n'
)
)
gp_idx_data <- list(coef_indices)
names(gp_idx_data) <- paste0('b_idx_', gp_names)
model_data <- append(model_data, gp_idx_data)
}
# Add the GP attribute table and mock brmsfit object to the mgcv_model
attr(mgcv_model, 'gp_att_table') <- gp_att_table
attr(mgcv_model, 'brms_mock') <- brms_mock
# Assign GP labels to smooths
gp_assign <- data.frame(
label = unlist(purrr::map(gp_att_table, 'name')),
first.para = unlist(purrr::map(gp_att_table, 'first_coef')),
last.para = unlist(purrr::map(gp_att_table, 'last_coef')),
by = unlist(purrr::map(gp_att_table, 'by'))
)
for (i in seq_along(mgcv_model$smooth)) {
if (
mgcv_model$smooth[[i]]$label %in%
gsub('gp(', 's(', gsub(' ', '', gp_assign$label[i]), fixed = TRUE) ||
mgcv_model$smooth[[i]]$label %in%
gsub('gp(', 'ti(', gsub(' ', '', gp_assign$label[i]), fixed = TRUE) &
mgcv_model$smooth[[i]]$first.para %in% gp_assign$first.para
) {
mgcv_model$smooth[[i]]$gp_term <- TRUE
class(mgcv_model$smooth[[i]]) <- c(
class(mgcv_model$smooth[[i]])[1],
'hilbert.smooth',
'mgcv.smooth'
)
} else {
mgcv_model$smooth[[i]]$gp_term <- FALSE
}
}
# Update smoothing parameter names and return
if (!missing(rho_names)) {
gp_names <- unlist(purrr::map(gp_att_table, 'name'))
gp_names_new <- vector()
for (i in seq_along(gp_names)) {
if (any(grepl(',', gp_names[i]))) {
gp_names_new[i] <- gsub(
' ',
'',
gsub('gp(', 'ti(', gp_names[i], fixed = TRUE)
)
} else {
gp_names_new[i] <- gsub('gp(', 's(', gp_names[i], fixed = TRUE)
}
}
rhos_change <- list()
for (i in seq_along(gp_names_new)) {
rhos_change[[i]] <- grep(gp_names_new[i], rho_names, fixed = TRUE)
}
rho_names[c(unique(unlist(rhos_change)))] <- gsub(
's\\(|ti\\(',
'gp(',
rho_names[c(unique(unlist(rhos_change)))]
)
} else {
rho_names <- NULL
}
# Return
return(list(
model_data = model_data,
mgcv_model = mgcv_model,
gp_stan_lines = gp_stan_lines,
gp_att_table = gp_att_table,
rho_names
))
}
#' Reduce the size of the brmsfit object
#' @noRd
trim_mockbrms = function(brms_mock) {
brms_mock$opencl <- NULL
brms_mock$data.name <- NULL
brms_mock$algorithm <- NULL
brms_mock$backend <- NULL
brms_mock$stan_args <- NULL
brms_mock$model <- NULL
brms_mock$stan_funs <- NULL
brms_mock$threads <- NULL
brms_mock$prior <- NULL
brms_mock$family <- NULL
brms_mock$save_pars <- NULL
brms_mock
}
#' Extract eigenfunctions for gp() terms and pad with zeros if necessary
#' @noRd
eigenfunc_list = function(stan_data, mock_df, by = NA, level = NA) {
eigenfuncs <- stan_data[which(
grepl('Xgp_', names(stan_data), fixed = TRUE) &
!grepl('_old', names(stan_data), fixed = TRUE) &
!grepl('_prior', names(stan_data), fixed = TRUE)
)]
# We need to pad the eigenfunctions with zeros
# for the observations where the by is a different level;
padded_eigenfuncs <- lapply(seq_along(eigenfuncs), function(x) {
if (!is.na(by[x])) {
if (!is.na(level[x])) {
sorted_by <- mock_df[[by[x]]]
full_eigens <- matrix(
0,
nrow = length(sorted_by),
ncol = NCOL(eigenfuncs[[x]])
)
full_eigens[
(seq_along(sorted_by))[
sorted_by == level[x]
],
] <- eigenfuncs[[x]]
} else {
# Numeric by variables should be multiplied by the
# spectral eigenfunctions
full_eigens <- eigenfuncs[[x]] * mock_df[[by[x]]]
}
} else {
full_eigens <- eigenfuncs[[x]]
}
full_eigens
})
padded_eigenfuncs
}
#' Extract eigenvalues for gp() terms
#' @noRd
eigenval_list = function(stan_data) {
stan_data[which(
grepl('slambda_', names(stan_data), fixed = TRUE) &
!grepl('_old', names(stan_data), fixed = TRUE)
)]
}
#' Which terms are gp() terms?
#' @noRd
which_are_gp = function(formula) {
termlabs <- attr(terms(formula, keep.order = TRUE), 'term.labels')
return(grep('gp(', termlabs, fixed = TRUE))
}
#' Convert gp() terms to s() terms for initial model construction
#' @importFrom stats drop.terms
#' @noRd
gp_to_s <- function(formula, data, family) {
# Extract details of gp() terms
gp_details <- get_gp_attributes(formula, data, family)
termlabs <- attr(terms(formula, keep.order = TRUE), 'term.labels')
# Check for offsets as well
off_names <- grep(
'offset',
rownames(attr(terms.formula(formula), 'factors')),
value = TRUE
)
if (length(off_names) > 0L) {
termlabs <- c(termlabs, off_names)
}
# Replace the gp() terms with s() for constructing the initial model
which_gp <- which_are_gp(formula)
response <- rlang::f_lhs(formula)
s_terms <- vector()
for (i in 1:NROW(gp_details)) {
if (!is.na(gp_details$by[i])) {
if (is.factor(data[[gp_details$by[i]]])) {
# For terms with factor by variables, constraints are in place
# we either need one additional
# value for k (for unidimensionsal terms) or must use mc = 0 for all
# marginals in a ti call (for multidimensional terms)
s_terms[i] <- paste0(
if (gp_details$dim[i] < 2L) {
's('
} else {
'ti('
},
gp_details$gp_covariates[i],
', by = ',
gp_details$by[i],
', k = ',
if (gp_details$dim[i] > 1L) {
paste0(
gp_details$k[i],
', mc = c(',
paste(rep(0, gp_details$dim[i]), collapse = ', '),
')'
)
} else {
gp_details$k[i] + 1
},
')'
)
} else {
# No constraints are used when numeric by variables are in smooths,
# so number of coefficients will match those from the brms gp
s_terms[i] <- paste0(
if (gp_details$dim[i] < 2L) {
's('
} else {
'ti('
},
gp_details$gp_covariates[i],
', by = ',
gp_details$by[i],
', k = ',
gp_details$k[i],
')'
)
}
} else {
# For terms with no by-variable, we either need one additional
# value for k (for unidimensionsal terms) or must use mc = 0 for all
# marginals in a ti call (for multidimensional terms)
s_terms[i] <- paste0(
if (gp_details$dim[i] < 2L) {
's('
} else {
'ti('
},
gp_details$gp_covariates[i],
', k = ',
if (gp_details$dim[i] > 1L) {
paste0(
gp_details$k[i],
', mc = c(',
paste(rep(0, gp_details$dim[i]), collapse = ', '),
')'
)
} else {
gp_details$k[i] + 1
},
')'
)
}
termlabs[which_gp[i]] <- s_terms[i]
}
newformula <- reformulate(termlabs, rlang::f_lhs(formula))
attr(newformula, '.Environment') <- attr(formula, '.Environment')
return(newformula)
}
#' Store attributes of the gp terms
#' @importFrom rlang parse_expr
#' @noRd
get_gp_attributes = function(formula, data, family = gaussian()) {
gp_terms <- rownames(attr(terms(formula), 'factors'))[
grep('gp(', rownames(attr(terms(formula), 'factors')), fixed = TRUE)
]
# Term details and default priors
gp_attributes <- lapply(seq_along(gp_terms), function(x) {
eval(rlang::parse_expr(gp_terms[x]))
})
gp_isos <- unlist(purrr::map(gp_attributes, 'iso'), use.names = FALSE)
gp_kernels <- unlist(purrr::map(gp_attributes, 'cov'), use.names = FALSE)
gp_cmcs <- unlist(purrr::map(gp_attributes, 'cmc'), use.names = FALSE)
if (any(gp_cmcs == FALSE)) {
rlang::warn(
paste0(
"gp effects in mvgam cannot yet handle contrast coding\n",
"resetting all instances of 'cmc = FALSE' to 'cmc = TRUE'"
),
.frequency = "once",
.frequency_id = 'gp_cmcs'
)
}
gp_grs <- unlist(purrr::map(gp_attributes, 'gr'), use.names = FALSE)
if (any(gp_grs == TRUE)) {
rlang::warn(
paste0(
"gp effects in mvgam cannot yet handle autogrouping\n",
"resetting all instances of 'gr = TRUE' to 'gr = FALSE'"
),
.frequency = "once",
.frequency_id = 'gp_grs'
)
}
newgp_terms <- unlist(
lapply(seq_along(gp_terms), function(x) {
lbl <- paste0(
'gp(',
paste(gp_attributes[[x]]$term, collapse = ', '),
if (gp_attributes[[x]]$by != 'NA') {
paste0(', by = ', gp_attributes[[x]]$by)
} else {
NULL
},
', k = ',
gp_attributes[[x]]$k,
', cov = "',
gp_attributes[[x]]$cov,
'", iso = ',
gp_attributes[[x]]$iso,
', scale = ',
gp_attributes[[x]]$scale,
', c = ',
gp_attributes[[x]]$c[1],
', gr = FALSE, cmc = TRUE)'
)
}),
use.names = FALSE
)
gp_formula <- reformulate(newgp_terms, rlang::f_lhs(formula))
gp_def_priors <- do.call(
rbind,
lapply(seq_along(gp_terms), function(x) {
def_gp_prior <- suppressWarnings(brms::get_prior(
reformulate(newgp_terms[x], rlang::f_lhs(formula)),
family = family_to_brmsfam(family),
data = data
))
def_gp_prior <- def_gp_prior[def_gp_prior$prior != '', ]
def_rho <- def_gp_prior$prior[which(def_gp_prior$class == 'lscale')]
def_alpha <- def_gp_prior$prior[min(which(def_gp_prior$class == 'sdgp'))]
if (def_alpha == '') {
def_alpha <- 'student_t(3, 0, 2.5);'
}
if (length(def_rho) > 1L) {
def_rho_1 <- def_rho[1]
def_rho_2 <- def_rho[2]
out <- data.frame(
def_rho = def_rho_1,
def_rho_2 = def_rho_2,
def_rho_3 = NA,
def_rho_4 = NA,
def_alpha = def_alpha
)
if (length(def_rho) > 2L) {
out$def_rho_3 <- def_rho[3]
}
if (length(def_rho) > 3L) out$def_rho_4 <- def_rho[4]
} else {
out <- data.frame(
def_rho = def_rho,
def_rho_2 = NA,
def_rho_3 = NA,
def_rho_4 = NA,
def_alpha = def_alpha
)
}
out
})
)
# Extract information necessary to construct the GP terms
gp_terms <- purrr::map(gp_attributes, 'term')
gp_dims <- unlist(lapply(gp_terms, length), use.names = FALSE)
gp_covariates <- unlist(
lapply(gp_terms, function(x) {
paste(x, collapse = ', ')
}),
use.names = FALSE
)
k <- unlist(purrr::map(gp_attributes, 'k'))
if (any(is.na(k))) {
stop('argument "k" must be supplied for any gp() terms', call. = FALSE)
}
# No longer will need boundary or scale information as
# brms will handle this internally
by <- unlist(purrr::map(gp_attributes, 'by'), use.names = FALSE)
if (any(by == 'NA')) {
by[by == 'NA'] <- NA
}
ret_dat <- data.frame(
gp_covariates,
dim = gp_dims,
kernel = gp_kernels,
iso = gp_isos,
k = k,
by,
level = NA,
def_alpha = gp_def_priors$def_alpha,
def_rho = gp_def_priors$def_rho,
def_rho_2 = gp_def_priors$def_rho_2,
def_rho_3 = gp_def_priors$def_rho_3,
def_rho_4 = gp_def_priors$def_rho_4
)
attr(ret_dat, 'gp_formula') <- gp_formula
# Return as a data.frame
return(ret_dat)
}
#' Clean GP names so no illegal characters are used in Stan code
#' @noRd
clean_gpnames = function(gp_names) {
gp_names_clean <- gsub(' ', '_', gp_names, fixed = TRUE)
gp_names_clean <- gsub('(', '_', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub(')', '_', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub(',', 'by', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub(':', 'by', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub('.', '_', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub(']', '_', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub('[', '_', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub(';', '_', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub(':', '_', gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub("'", "", gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub("\"", "", gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub("%", "percent", gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub("[.]+", "_", gp_names_clean, fixed = TRUE)
gp_names_clean <- gsub("'", "", gp_names_clean, fixed = TRUE)
#gp_names_clean <- gsub("’", "", gp_names_clean, fixed = TRUE)
gp_names_clean
}
#' Update a Stan file with GP information
#' @noRd
add_gp_model_file = function(model_file, model_data, mgcv_model, gp_additions) {
rho_priors <- unlist(
purrr::map(gp_additions$gp_att_table, 'def_rho'),
use.names = FALSE
)
rho_2_priors <- unlist(
purrr::map(gp_additions$gp_att_table, 'def_rho_2'),
use.names = FALSE
)
rho_3_priors <- unlist(
purrr::map(gp_additions$gp_att_table, 'def_rho_3'),
use.names = FALSE
)
rho_4_priors <- unlist(
purrr::map(gp_additions$gp_att_table, 'def_rho_4'),
use.names = FALSE
)
alpha_priors <- unlist(
purrr::map(gp_additions$gp_att_table, 'def_alpha'),
use.names = FALSE
)
# Add data lines
model_file[grep(
'int ytimes[n, n_series];',
model_file,
fixed = TRUE
)] <-
paste0(
model_file[grep(
'int ytimes[n, n_series];',
model_file,
fixed = TRUE
)],
'\n',
gp_additions$gp_stan_lines
)
model_file <- readLines(textConnection(model_file), n = -1)
# Replace the multi_normal_prec lines with the relevant spd function
gp_kernels <- unlist(
purrr::map(attr(mgcv_model, 'gp_att_table'), 'kernel'),
use.names = FALSE
)
gp_names <- unlist(
purrr::map(attr(mgcv_model, 'gp_att_table'), 'name'),
use.names = FALSE
)
gp_isos <- unlist(
purrr::map(attr(mgcv_model, 'gp_att_table'), 'iso'),
use.names = FALSE
)
gp_dims <- unlist(
purrr::map(attr(mgcv_model, 'gp_att_table'), 'dim'),
use.names = FALSE
)
orig_names <- unlist(
purrr::map(attr(mgcv_model, 'gp_att_table'), 'orig_name'),
use.names = FALSE
)
gp_names_clean <- clean_gpnames(gp_names)
s_to_remove <- list()
for (i in seq_along(gp_names)) {
i_rho_priors <- c(
rho_priors[i],
rho_2_priors[i],
rho_3_priors[i],
rho_4_priors[i]
)
i_rho_priors <- i_rho_priors[!is.na(i_rho_priors)]
s_name <- gsub(' ', '', orig_names[i])
to_replace <- grep(
paste0('// prior for ', s_name, '...'),
model_file,
fixed = TRUE
) +
1
pattern <- "S\\s*(.*?)\\s*\\["
result <- regmatches(
model_file[to_replace],
regexec(pattern, model_file[to_replace])
)[[1]]
s_to_remove[[i]] <- unique(unlist(regmatches(
result,
gregexpr("[[:digit:]]+", result)
)))
model_file[grep(
paste0('// prior for ', s_name, '...'),
model_file,
fixed = TRUE
)] <-
gsub(
's\\(|ti\\(',
'gp(',
model_file[grep(
paste0('// prior for ', s_name, '...'),
model_file,
fixed = TRUE
)]
)
rho_prior_lines <- paste(
paste0(
'rho_',
gp_names_clean[i],
if (!gp_isos[i]) {
'[1]'
} else {
NULL
},
'[',
if (gp_isos[i]) {
1
} else {
seq(1:gp_dims[i])
},
']',
' ~ ',
if (gp_isos[i]) {
rho_priors[i]
} else {
i_rho_priors
},
';\n'
),
collapse = '\n'
)
model_file[to_replace] <-
paste0(
'z_',
gp_names_clean[i],
' ~ std_normal();\n',
'alpha_',
gp_names_clean[i],
' ~ ',
alpha_priors[i],
';\n',
rho_prior_lines,
'b_raw[b_idx_',
gp_names_clean[i],
'] ~ std_normal();\n'
)
}
b_line <- max(which(
grepl('b[', model_file, fixed = TRUE) &
grepl('] =', model_file, fixed = TRUE)
))
b_edits <- paste0(
'b[b_idx_',
gp_names_clean,
add_gp_spd_calls(gp_kernels),
gp_names_clean,
', alpha_',
gp_names_clean,
', rho_',
gp_names_clean,
'[1])) .* z_',
gp_names_clean,
';',
collapse = '\n'
)
model_file[b_line] <- paste0(model_file[b_line], '\n', b_edits)
model_file <- readLines(textConnection(model_file), n = -1)
# Remove un-needed penalty matrices from the model file and the
# model data
for (i in seq_along(unique(unlist(s_to_remove)))) {
model_data[[paste0('S', unique(unlist(s_to_remove))[i])]] <- NULL
model_file <- model_file[
-grep(
paste0(
'\\bmgcv smooth penalty matrix S',
unique(unlist(s_to_remove))[i],
'\\b'
),
model_file
)
]
}
# Add alpha, rho and z lines in parameters and model blocks
alpha_names <- paste(
paste0('real alpha_', gp_names_clean, ';'),
collapse = '\n'
)
rho_names <- paste(
paste0(
'array[1] vector[',
ifelse(gp_isos, 1, gp_dims),
'] rho_',
gp_names_clean,
';'
),
collapse = '\n'
)
z_names <- paste(
paste0('vector[k_', gp_names_clean, '] z_', gp_names_clean, ';'),
collapse = '\n'
)
model_file[grep("vector[num_basis] b_raw;", model_file, fixed = TRUE)] <-
paste0(
"vector[num_basis] b_raw;\n\n",
'// gp term sd parameters\n',
alpha_names,
'\n\n// gp term length scale parameters\n',
rho_names,
'\n\n// gp term latent variables\n',
z_names,
'\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
# Add spd_ functions from brms code
kerns_add <- rev(gp_kernels)
for (i in seq_along(kerns_add)) {
model_file <- add_gp_spd_funs(model_file, kerns_add[i])
}
return(list(model_file = model_file, model_data = model_data))
}
#' Add GP SPD functions to a stan model file
#' @noRd
add_gp_spd_calls = function(kernels) {
kern_calls <- vector(length = length(kernels))
for (i in seq_along(kern_calls)) {
if (kernels[i] == 'exp_quad') {
kern_calls[i] <- '] = sqrt(spd_gp_exp_quad(l_'
}
if (kernels[i] == 'exponential') {
kern_calls[i] <- '] = sqrt(spd_gp_exponential(l_'
}
if (kernels[i] == 'matern32') {
kern_calls[i] <- '] = sqrt(spd_gp_matern32(l_'
}
if (kernels[i] == 'matern52') {
kern_calls[i] <- '] = sqrt(spd_gp_matern52(l_'
}
}
return(kern_calls)
}
#' @noRd
add_gp_spd_funs = function(model_file, kernel) {
if (kernel == 'exp_quad') {
if (
!any(grepl(
'/* Spectral density of a squared exponential Gaussian process',
model_file,
fixed = TRUE
))
) {
fun_lines <- paste0(
'/* Spectral density of a squared exponential Gaussian process\n',
'* Args:\n',
'* x: array of numeric values of dimension NB x D\n',
'* sdgp: marginal SD parameter\n',
'* lscale: vector of length-scale parameters\n',
'* Returns:\n',
"* numeric vector of length NB of the SPD evaluated at 'x'\n",
'*/\n',
'vector spd_gp_exp_quad(data array[] vector x, real sdgp, vector lscale) {\n',
'int NB = dims(x)[1];\n',
'int D = dims(x)[2];\n',
'int Dls = rows(lscale);\n',
'real constant = square(sdgp) * sqrt(2 * pi())^D;\n',
'vector[NB] out;\n',
'if (Dls == 1) {\n',
'// one dimensional or isotropic GP\n',
'real neg_half_lscale2 = -0.5 * square(lscale[1]);\n',
'constant = constant * lscale[1]^D;\n',
'for (m in 1:NB) {\n',
'out[m] = constant * exp(neg_half_lscale2 * dot_self(x[m]));\n',
'}\n',
'} else {\n',
'// multi-dimensional non-isotropic GP\n',
'vector[Dls] neg_half_lscale2 = -0.5 * square(lscale);\n',
'constant = constant * prod(lscale);\n',
'for (m in 1:NB) {\n',
'out[m] = constant * exp(dot_product(neg_half_lscale2, square(x[m])));\n',
'}\n',
'}\n',
'return out;\n',
'}'
)
} else {
fun_lines <- NULL
}
}
if (kernel %in% c('exponential', 'matern12')) {
if (
!any(grepl(
'/* Spectral density of an exponential Gaussian process',
model_file,
fixed = TRUE
))
) {
fun_lines <- paste0(
'/* Spectral density of an exponential Gaussian process\n',
'* also known as the Matern 1/2 kernel\n',
'* Args:\n',
'* x: array of numeric values of dimension NB x D\n',
'* sdgp: marginal SD parameter\n',
'* lscale: vector of length-scale parameters\n',
'* Returns:\n',
"* numeric vector of length NB of the SPD evaluated at 'x'\n",
'*/\n',
'vector spd_gp_exponential(data array[] vector x, real sdgp, vector lscale) {\n',
'int NB = dims(x)[1];\n',
'int D = dims(x)[2];\n',
'int Dls = rows(lscale);\n',
'real constant = square(sdgp) *\n',
'(2^D * pi()^(D / 2.0) * tgamma((D + 1.0) / 2)) / sqrt(pi());\n',
'real expo = -(D + 1.0) / 2;\n',
'vector[NB] out;\n',
'if (Dls == 1) {\n',
'// one dimensional or isotropic GP\n',
'real lscale2 = square(lscale[1]);\n',
'constant = constant * lscale[1]^D;\n',
'for (m in 1:NB) {\n',
'out[m] = constant * (1 + lscale2 * dot_self(x[m]))^expo;\n',
'}\n',
'} else {\n',
'// multi-dimensional non-isotropic GP\n',
'vector[Dls] lscale2 = square(lscale);\n',
'constant = constant * prod(lscale);\n',
'for (m in 1:NB) {\n',
'out[m] = constant * (1 + dot_product(lscale2, square(x[m])))^expo;\n',
'}\n',
'}\n',
'return out;\n',
'}'
)
} else {
fun_lines <- NULL
}
}
if (kernel == 'matern32') {
if (
!any(grepl(
'/* Spectral density of a Matern 3/2 Gaussian process',
model_file,
fixed = TRUE
))
) {
fun_lines <- paste0(
'/* Spectral density of a Matern 3/2 Gaussian process\n',
'* Args:\n',
'* x: array of numeric values of dimension NB x D\n',
'* sdgp: marginal SD parameter\n',
'* lscale: vector of length-scale parameters\n',
'* Returns:\n',
"* numeric vector of length NB of the SPD evaluated at 'x'\n",
'*/\n',
'vector spd_gp_matern32(data array[] vector x, real sdgp, vector lscale) {\n',
'int NB = dims(x)[1];\n',
'int D = dims(x)[2];\n',
'int Dls = rows(lscale);\n',
'real constant = square(sdgp) *\n',
'(2^D * pi()^(D / 2.0) * tgamma((D + 3.0) / 2) * 3^(3.0 / 2)) /\n',
'(0.5 * sqrt(pi()));\n',
'real expo = -(D + 3.0) / 2;\n',
'vector[NB] out;\n',
'if (Dls == 1) {\n',
'// one dimensional or isotropic GP\n',
'real lscale2 = square(lscale[1]);\n',
'constant = constant * lscale[1]^D;\n',
'for (m in 1:NB) {\n',
'out[m] = constant * (3 + lscale2 * dot_self(x[m]))^expo;\n',
'}\n',
'} else {\n',
'// multi-dimensional non-isotropic GP\n',
'vector[Dls] lscale2 = square(lscale);\n',
'constant = constant * prod(lscale);\n',
'for (m in 1:NB) {\n',
'out[m] = constant * (3 + dot_product(lscale2, square(x[m])))^expo;\n',
'}\n',
'}\n',
'return out;\n',
'}'
)
} else {
fun_lines <- NULL
}
}
if (kernel == 'matern52') {
if (
!any(grepl(
'/* Spectral density of a Matern 5/2 Gaussian process',
model_file,
fixed = TRUE
))
) {
fun_lines <- paste0(
'/* Spectral density of a Matern 5/2 Gaussian process\n',
'* Args:\n',
'* x: array of numeric values of dimension NB x D\n',
'* sdgp: marginal SD parameter\n',
'* lscale: vector of length-scale parameters\n',
'* Returns:\n',
"* numeric vector of length NB of the SPD evaluated at 'x'\n",
'*/\n',
'vector spd_gp_matern52(data array[] vector x, real sdgp, vector lscale) {\n',
'int NB = dims(x)[1];\n',
'int D = dims(x)[2];\n',
'int Dls = rows(lscale);\n',
'real constant = square(sdgp) *\n',
'(2^D * pi()^(D / 2.0) * tgamma((D + 5.0) / 2) * 5^(5.0 / 2)) /\n',
'(0.75 * sqrt(pi()));\n',
'real expo = -(D + 5.0) / 2;\n',
'vector[NB] out;\n',
'if (Dls == 1) {\n',
'// one dimensional or isotropic GP\n',
'real lscale2 = square(lscale[1]);\n',
'constant = constant * lscale[1]^D;\n',
'for (m in 1:NB) {\n',
'out[m] = constant * (5 + lscale2 * dot_self(x[m]))^expo;\n',
'}\n',
'} else {\n',
'// multi-dimensional non-isotropic GP\n',
'vector[Dls] lscale2 = square(lscale);\n',
'constant = constant * prod(lscale);\n',
'for (m in 1:NB) {\n',
'out[m] = constant * (5 + dot_product(lscale2, square(x[m])))^expo;\n',
'}\n',
'}\n',
'return out;\n',
'}'
)
} else {
fun_lines <- NULL
}
}
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0('functions {\n', fun_lines)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
fun_lines,
'\n}\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
#' Evaluate Laplacian eigenfunction for a given GP basis function
#' @noRd
phi = function(boundary, m, centred_covariate) {
1 /
sqrt(boundary) *
sin((m * pi) / (2 * boundary) * (centred_covariate + boundary))
}
#' Evaluate eigenvalues for a given GP basis function
#' @noRd
lambda = function(boundary, m) {
((m * pi) / (2 * boundary))^2
}
#' Spectral density squared exponential Gaussian Process kernel
#' @noRd
spd = function(alpha_gp, rho_gp, eigenvalues) {
(alpha_gp^2) *
sqrt(2 * pi) *
rho_gp *
exp(-0.5 * (rho_gp^2) * (eigenvalues^2))
}
#' @noRd
sim_hilbert_gp = function(
alpha_gp,
rho_gp,
b_gp,
last_trends,
fc_times,
train_times,
mean_train_times
) {
num_gp_basis <- length(b_gp)
# Get vector of eigenvalues of covariance matrix
eigenvalues <- vector()
for (m in 1:num_gp_basis) {
eigenvalues[m] <- lambda(
boundary = (5.0 / 4) *
(max(train_times) - min(train_times)),
m = m
)
}
# Get vector of eigenfunctions
eigenfunctions <- matrix(NA, nrow = length(fc_times), ncol = num_gp_basis)
for (m in 1:num_gp_basis) {
eigenfunctions[, m] <- phi(
boundary = (5.0 / 4) *
(max(train_times) - min(train_times)),
m = m,
centred_covariate = fc_times - mean_train_times
)
}
# Compute diagonal of covariance matrix
diag_SPD <- sqrt(spd(alpha_gp = alpha_gp, rho_gp = rho_gp, sqrt(eigenvalues)))
# Compute GP trend forecast
as.vector((diag_SPD * b_gp) %*% t(eigenfunctions))
}
#### Old gp() prepping functions; these are now redundant because
# brms is used to evaluate gp() effects and produce the relevant
# eigenfunctions / eigenvalues, but keeping the functions here for
# now in case they are needed for later work ####
#' #' Compute the mth eigen function of an approximate GP
#' #' Credit to Paul Burkner from brms: https://github.com/paul-buerkner/brms/R/formula-gp.R#L289
#' #' @noRd
#' 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)
#' }
#' #' Compute squared differences
#' #' Credit to Paul Burkner from brms: https://github.com/paul-buerkner/brms/R/formula-gp.R#L241
#' #' @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
#' #' @noRd
#' 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
#' }
#' #' Extended range of input data for which predictions should be made
#' #' Credit to Paul Burkner from brms: https://github.com/paul-buerkner/brms/R/formula-gp.R#L301
#' #' @noRd
#' 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
#' }
#' #' Mean-center and scale the particular covariate of interest
#' #' so that the maximum Euclidean distance between any two points is 1
#' #' @noRd
#' scale_cov <- function(data, covariate, by, level,
#' mean, max_dist){
#' Xgp <- data[[covariate]]
#' if(!is.na(by) &
#' !is.na(level)){
#' Xgp <- data[[covariate]][data[[by]] == level]
#' }
#'
#' # Compute max Euclidean distance if not supplied
#' if(is.na(max_dist)){
#' Xgp_max_dist <- sqrt(max(diff_quad(Xgp)))
#' } else {
#' Xgp_max_dist <- max_dist
#' }
#'
#' # Scale
#' Xgp <- Xgp / Xgp_max_dist
#'
#' # Compute mean if not supplied (after scaling)
#' if(is.na(mean)){
#' Xgp_mean <- mean(Xgp, na.rm = TRUE)
#' } else {
#' Xgp_mean <- mean
#' }
#'
#' # Center
#' Xgp <- Xgp - Xgp_mean
#'
#' return(list(Xgp = Xgp,
#' Xgp_mean = Xgp_mean,
#' Xgp_max_dist = Xgp_max_dist))
#' }
#'
#' #' Prep GP eigenfunctions
#' #' @noRd
#' prep_eigenfunctions = function(data,
#' covariate,
#' by = NA,
#' level = NA,
#' k,
#' boundary,
#' mean = NA,
#' max_dist = NA,
#' scale = TRUE,
#' L,
#' initial_setup = FALSE){
#'
#' # Extract and scale covariate (scale set to FALSE if this is a prediction
#' # step so that we can scale by the original training covariate values supplied
#' # in mean and max_dist)
#' covariate_cent <- scale_cov(data = data,
#' covariate = covariate,
#' by = by,
#' level = level,
#' mean = mean,
#' max_dist = max_dist)$Xgp
#'
#' # Construct matrix of eigenfunctions
#' eigenfunctions <- matrix(NA, nrow = length(covariate_cent),
#' ncol = k)
#' if(missing(L)){
#' L <- choose_L(covariate_cent, boundary)
#' }
#'
#' for(m in 1:k){
#' eigenfunctions[, m] <- eigen_fun_cov_exp_quad(x = matrix(covariate_cent),
#' m = m,
#' L = L)
#' }
#'
#' # Multiply eigenfunctions by the 'by' variable if one is supplied
#' if(!is.na(by)){
#' if(!is.na(level)){
#' # no multiplying needed as this is a factor by variable,
#' # but we need to pad the eigenfunctions with zeros
#' # for the observations where the by is a different level;
#' # the design matrix is always sorted by time and then by series
#' # in mvgam
#' if(initial_setup){
#' sorted_by <- data.frame(time = data$time,
#' series = data$series,
#' byvar = data[[by]]) %>%
#' dplyr::arrange(time, series) %>%
#' dplyr::pull(byvar)
#' } else {
#' sorted_by <- data[[by]]
#' }
#'
#' full_eigens <- matrix(0, nrow = length(data[[by]]),
#' ncol = NCOL(eigenfunctions))
#' full_eigens[(1:length(data[[by]]))[
#' sorted_by == level],] <- eigenfunctions
#' eigenfunctions <- full_eigens
#' } else {
#' eigenfunctions <- eigenfunctions * data[[by]]
#' }
#' }
#' eigenfunctions
#' }
#'
#' #' Prep Hilbert Basis GP covariates
#' #' @noRd
#' prep_gp_covariate = function(data,
#' response,
#' covariate,
#' by = NA,
#' level = NA,
#' scale = TRUE,
#' boundary = 5.0/4,
#' k = 20,
#' family = gaussian()){
#'
#' # Get default gp param priors from a call to brms::get_prior()
#' def_gp_prior <- suppressWarnings(brms::get_prior(formula(paste0(response,
#' ' ~ gp(', covariate,
#' ifelse(is.na(by), ', ',
#' paste0(', by = ', by, ', ')),
#' 'k = ', k,
#' ', scale = ',
#' scale,
#' ', c = ',
#' boundary,
#' ')')), data = data,
#' family = family))
#' def_gp_prior <- def_gp_prior[def_gp_prior$prior != '',]
#' def_rho <- def_gp_prior$prior[min(which(def_gp_prior$class == 'lscale'))]
#' if(def_rho == ''){
#' def_rho <- 'inv_gamma(1.5, 5);'
#' }
#' def_alpha <- def_gp_prior$prior[min(which(def_gp_prior$class == 'sdgp'))]
#' if(def_alpha == ''){
#' def_alpha<- 'student_t(3, 0, 2.5);'
#' }
#'
#' # Prepare the covariate
#' if(scale){
#' max_dist <- NA
#' } else {
#' max_dist <- 1
#' }
#'
#' covariate_cent <- scale_cov(data = data,
#' covariate = covariate,
#' by = by,
#' mean = NA,
#' max_dist = max_dist,
#' level = level)
#'
#' covariate_mean <- covariate_cent$Xgp_mean
#' covariate_max_dist <- covariate_cent$Xgp_max_dist
#' covariate_cent <- covariate_cent$Xgp
#'
#' # Construct vector of eigenvalues for GP covariance matrix; the
#' # same eigenvalues are always used in prediction, so we only need to
#' # create them when prepping the data. They will need to be included in
#' # the Stan data list
#' L <- choose_L(covariate_cent, boundary)
#' eigenvalues <- vector()
#' for(m in 1:k){
#' eigenvalues[m] <- sqrt(lambda(boundary = L,
#' m = m))
#' }
#'
#' # Construct matrix of eigenfunctions; this will change depending on the values
#' # of the covariate, so it needs to be computed and included as data but also needs
#' # to be computed to make predictions
#' eigenfunctions <- prep_eigenfunctions(data = data,
#' covariate = covariate,
#' by = by,
#' level = level,
#' L = L,
#' k = k,
#' boundary = boundary,
#' mean = covariate_mean,
#' max_dist = covariate_max_dist,
#' scale = scale,
#' initial_setup = TRUE)
#'
#' # Make attributes table using a cleaned version of the covariate
#' # name to ensure there are no illegal characters in the Stan code
#' byname <- ifelse(is.na(by), '', paste0(':', by))
#' covariate_name <- paste0('gp(', covariate, ')', byname)
#' if(!is.na(level)){
#' covariate_name <- paste0(covariate_name, level)
#' }
#' att_table <- list(effect = 'gp',
#' name = covariate_name,
#' covariate = covariate,
#' by = by,
#' level = level,
#' k = k,
#' boundary = boundary,
#' L = L,
#' scale = scale,
#' def_rho = def_rho,
#' def_alpha = def_alpha,
#' mean = covariate_mean,
#' max_dist = covariate_max_dist,
#' eigenvalues = eigenvalues)
#'
#' # Items to add to Stan data
#' # Number of basis functions
#' covariate_name <- clean_gpnames(covariate_name)
#' data_lines <- paste0('int k_', covariate_name,
#' '; // basis functions for approximate gp\n')
#' append_dat <- list(k = k)
#' names(append_dat) <- paste0('k_', covariate_name, '')
#'
#' # Approximate GP eigenvalues
#' data_lines <- paste0(data_lines, paste0(
#' 'vector[',
#' 'k_', covariate_name,
#' '] l_', covariate_name, '; // approximate gp eigenvalues\n'),
#' collapse = '\n')
#' append_dat2 <- list(slambda = eigenvalues)
#' names(append_dat2) <- paste0('l_', covariate_name, '')
#' append_dat <- append(append_dat, append_dat2)
#'
#' # Return necessary objects in a list
#' list(att_table = att_table,
#' data_lines = data_lines,
#' data_append = append_dat,
#' eigenfunctions = eigenfunctions)
#' }
================================================
FILE: R/gratia_methods.R
================================================
#### Functions to ensure gratia methods work with mvgam, using the Enhance functionality
# in the Description ####
# Add eval_smooth and draw methods to gratia namespace
# on load
.onLoad <- function(libname, pkgname) {
if (requireNamespace("gratia", quietly = TRUE)) {
registerS3method(
"eval_smooth",
"moi.smooth",
eval_smoothDotmoiDotsmooth,
envir = asNamespace("gratia")
)
registerS3method(
"eval_smooth",
"mod.smooth",
eval_smoothDotmodDotsmooth,
envir = asNamespace("gratia")
)
registerS3method(
"eval_smooth",
"hilbert.smooth",
eval_smoothDothilbertDotsmooth,
envir = asNamespace("gratia")
)
registerS3method(
"draw",
"mvgam",
drawDotmvgam,
envir = asNamespace("gratia")
)
}
}
#' Enhance post-processing of \pkg{mvgam} models using \pkg{gratia} functionality
#'
#' These evaluation and plotting functions exist to allow some popular `gratia`
#' methods to work with `mvgam` or `jsdgam` models
#'
#' @name gratia_mvgam_enhancements
#'
#' @param object a fitted mvgam, the result of a call to [mvgam()]
#'
#' @param model a fitted `mgcv` model of clas `gam` or `bam`
#'
#' @param data a data frame of covariate values at which to evaluate the
#' model's smooth functions
#'
#' @param smooth a smooth object of class `"gp.smooth"` (returned from a model using either the
#' `dynamic()` function or the `gp()` function) or of class `"moi.smooth"` or `"mod.smooth"`
#' (returned from a model using the 'moi' or 'mod' basis)
#'
#' @param trend_effects logical specifying whether smooth terms from the `trend_formula` should
#' be drawn. If `FALSE`, only terms from the observation formula are drawn. If `TRUE`, only
#' terms from the `trend_formula` are drawn
#'
#' @param select character, logical, or numeric; which smooths to plot. If
#' `NULL`, the default, then all model smooths are drawn.
#' Character `select` matches the labels for smooths
#' as shown for example in the output from `summary(object)`. Logical
#' `select` operates as per numeric `select` in the order that smooths are
#' stored
#'
#' @param parametric logical; plot parametric terms also? Note that `select` is
#' used for selecting which smooths to plot. The `terms` argument is used to
#' select which parametric effects are plotted. The default, as with
#' [mgcv::plot.gam()], is to not draw parametric effects
#'
#' @param terms character; which model parametric terms should be drawn? The
#' Default of `NULL` will plot all parametric terms that can be drawn.
#' @param residuals currently ignored for `mvgam` models
#'
#' @param scales character; should all univariate smooths be plotted with the
#' same y-axis scale? If `scales = "free"`, the default, each univariate
#' smooth has its own y-axis scale. If `scales = "fixed"`, a common y axis
#' scale is used for all univariate smooths.
#'
#' Currently does not affect the y-axis scale of plots of the parametric
#' terms
#'
#' @param constant numeric; a constant to add to the estimated values of the
#' smooth. `constant`, if supplied, will be added to the estimated value
#' before the confidence band is computed
#'
#' @param fun function; a function that will be applied to the estimated values
#' and confidence interval before plotting. Can be a function or the name of a
#' function. Function `fun` will be applied after adding any `constant`, if
#' provided
#'
#' @param ci_level numeric between 0 and 1; the coverage of credible interval.
#' @param n numeric; the number of points over the range of the covariate at
#' which to evaluate the smooth
#'
#' @param n_3d,n_4d numeric; the number of points over the range of last
#' covariate in a 3D or 4D smooth. The default is `NULL` which achieves the
#' standard behaviour of using `n` points over the range of all covariate,
#' resulting in `n^d` evaluation points, where `d` is the dimension of the
#' smooth. For `d > 2` this can result in very many evaluation points and slow
#' performance. For smooths of `d > 4`, the value of `n_4d` will be used for
#' all dimensions `> 4`, unless this is `NULL`, in which case the default
#' behaviour (using `n` for all dimensions) will be observed
#'
#' @param unconditional ignored for `mvgam` models as all appropriate
#' uncertainties are already included in the posterior estimates
#'
#' @param overall_uncertainty ignored for `mvgam` models as all appropriate
#' uncertainties are already included in the posterior estimates
#'
#' @param dist numeric; if greater than 0, this is used to determine when
#' a location is too far from data to be plotted when plotting 2-D smooths.
#' The data are scaled into the unit square before deciding what to exclude,
#' and `dist` is a distance within the unit square. See
#' [mgcv::exclude.too.far()] for further details
#'
#' @param rug logical; draw a rug plot at the bottom of each plot for 1-D
#' smooths or plot locations of data for higher dimensions.
#' @param contour logical; should contours be draw on the plot using
#' [ggplot2::geom_contour()]
#'
#' @param grouped_by logical; should factor by smooths be drawn as one panel
#' per level of the factor (`FALSE`, the default), or should the individual
#' smooths be combined into a single panel containing all levels (`TRUE`)?
#'
#' @param ci_alpha numeric; alpha transparency for confidence or simultaneous
#' interval
#'
#' @param ci_col colour specification for the confidence/credible intervals
#' band. Affects the fill of the interval
#'
#' @param smooth_col colour specification for the smooth line
#'
#' @param resid_col colour specification for residual points. Ignored
#'
#' @param contour_col colour specification for contour lines
#'
#' @param n_contour numeric; the number of contour bins. Will result in
#' `n_contour - 1` contour lines being drawn. See [ggplot2::geom_contour()]
#'
#' @param partial_match logical; should smooths be selected by partial matches
#' with `select`? If `TRUE`, `select` can only be a single string to match
#' against
#'
#' @param discrete_colour a suitable colour scale to be used when plotting
#' discrete variables
#'
#' @param discrete_fill a suitable fill scale to be used when plotting
#' discrete variables.
#' @param continuous_colour a suitable colour scale to be used when plotting
#' continuous variables
#'
#' @param continuous_fill a suitable fill scale to be used when plotting
#' continuous variables
#'
#' @param position Position adjustment, either as a string, or the result of a
#' call to a position adjustment function
#'
#' @param angle numeric; the angle at which the x axis tick labels are to be
#' drawn passed to the `angle` argument of [ggplot2::guide_axis()]
#'
#' @param ncol,nrow numeric; the numbers of rows and columns over which to
#' spread the plots
#'
#' @param guides character; one of `"keep"` (the default), `"collect"`, or
#' `"auto"`. Passed to [patchwork::plot_layout()]
#'
#' @param widths,heights The relative widths and heights of each column and
#' row in the grid. Will get repeated to match the dimensions of the grid. If
#' there is more than 1 plot and `widths = NULL`, the value of `widths` will
#' be set internally to `widths = 1` to accommodate plots of smooths that
#' use a fixed aspect ratio.=
#'
#' @param crs the coordinate reference system (CRS) to use for the plot. All
#' data will be projected into this CRS. See [ggplot2::coord_sf()] for
#' details
#'
#' @param default_crs the coordinate reference system (CRS) to use for the
#' non-sf layers in the plot. If left at the default `NULL`, the CRS used is
#' 4326 (WGS84), which is appropriate for spline-on-the-sphere smooths, which
#' are parameterized in terms of latitude and longitude as coordinates. See
#' [ggplot2::coord_sf()] for more details
#'
#' @param lims_method character; affects how the axis limits are determined. See
#' [ggplot2::coord_sf()]. Be careful; in testing of some examples, changing
#' this to `"orthogonal"` for example with the chlorophyll-a example from
#' Simon Wood's GAM book quickly used up all the RAM in my test system and the
#' OS killed R. This could be incorrect usage on my part; right now the grid
#' of points at which SOS smooths are evaluated (if not supplied by the user)
#' can produce invalid coordinates for the corners of tiles as the grid is
#' generated for tile centres without respect to the spacing of those tiles
#'
#' @param wrap logical; wrap plots as a patchwork? If \code{FALSE}, a list of
#' ggplot objects is returned, 1 per term plotted
#'
#' @param envir an environment to look up the data within
#'
#' @param ... additional arguments passed to other methods
#'
#' @details These methods allow `mvgam` models to be *Enhanced* if users have the `gratia`
#' package installed, making available the popular `draw()` function to plot partial effects
#' of `mvgam` smooth functions using [ggplot2::ggplot()] utilities
#'
#' @author Nicholas J Clark
#'
#' @examples
#' \dontrun{
#' # Fit a simple GAM and draw partial effects of smooths using 'gratia'
#' set.seed(0)
#' dat <- mgcv::gamSim(
#' eg = 1,
#' n = 200,
#' scale = 2
#' )
#'
#' mod <- mvgam(
#' formula = y ~ s(x1, bs = 'moi') +
#' te(x0, x2),
#' data = dat,
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#'
#' if (require("gratia")) {
#' gratia::draw(mod)
#' }
#' }
NULL
#' @rdname gratia_mvgam_enhancements
#' @aliases draw.mvgam
#' @export
#'
`drawDotmvgam` <- function(
object,
trend_effects = FALSE,
data = NULL,
select = NULL,
parametric = FALSE,
terms = NULL,
residuals = FALSE,
scales = c("free", "fixed"),
ci_level = 0.95,
n = 100,
n_3d = 16,
n_4d = 4,
unconditional = FALSE,
overall_uncertainty = TRUE,
constant = NULL,
fun = NULL,
dist = 0.1,
rug = TRUE,
contour = TRUE,
grouped_by = FALSE,
ci_alpha = 0.2,
ci_col = "black",
smooth_col = "black",
resid_col = "steelblue3",
contour_col = "black",
n_contour = NULL,
partial_match = FALSE,
discrete_colour = NULL,
discrete_fill = NULL,
continuous_colour = NULL,
continuous_fill = NULL,
position = "identity",
angle = NULL,
ncol = NULL,
nrow = NULL,
guides = "keep",
widths = NULL,
heights = NULL,
crs = NULL,
default_crs = NULL,
lims_method = "cross",
wrap = TRUE,
envir = environment(formula(object)),
...
) {
if (trend_effects) {
if (is.null(object$trend_call)) {
stop('no trend_formula exists so there are no trend-level terms to plot')
}
object$trend_mgcv_model <- relabel_gps(object$trend_mgcv_model)
object$trend_mgcv_model$call$data <- NULL
object$trend_mgcv_model$cmX <- object$trend_mgcv_model$coefficients
sm_plots <- gratia::draw(
object = object$trend_mgcv_model,
data = data,
select = select,
parametric = parametric,
terms = terms,
residuals = FALSE,
scales = scales,
ci_level = ci_level,
n = n,
n_3d = n_3d,
n_4d = n_4d,
unconditional = FALSE,
overall_uncertainty = FALSE,
constant = constant,
fun = fun,
dist = dist,
rug = rug,
contour = contour,
grouped_by = grouped_by,
ci_alpha = ci_alpha,
ci_col = ci_col,
smooth_col = smooth_col,
resid_col = "steelblue3",
contour_col = contour_col,
n_contour = n_contour,
partial_match = partial_match,
discrete_colour = discrete_colour,
discrete_fill = discrete_fill,
continuous_colour = continuous_colour,
continuous_fill = continuous_fill,
position = position,
angle = angle,
ncol = ncol,
nrow = nrow,
guides = guides,
widths = widths,
heights = heights,
crs = crs,
default_crs = default_crs,
lims_method = lims_method,
wrap = wrap,
envir = envir,
...
)
} else {
object$mgcv_model <- relabel_gps(object$mgcv_model)
object$mgcv_model$call$data <- NULL
object$mgcv_model$cmX <- object$mgcv_model$coefficients
sm_plots <- gratia::draw(
object = object$mgcv_model,
data = data,
select = select,
parametric = parametric,
terms = terms,
residuals = FALSE,
scales = scales,
ci_level = ci_level,
n = n,
n_3d = n_3d,
n_4d = n_4d,
unconditional = FALSE,
overall_uncertainty = FALSE,
constant = constant,
fun = fun,
dist = dist,
rug = rug,
contour = contour,
grouped_by = grouped_by,
ci_alpha = ci_alpha,
ci_col = ci_col,
smooth_col = smooth_col,
resid_col = "steelblue3",
contour_col = contour_col,
n_contour = n_contour,
partial_match = partial_match,
discrete_colour = discrete_colour,
discrete_fill = discrete_fill,
continuous_colour = continuous_colour,
continuous_fill = continuous_fill,
position = position,
angle = angle,
ncol = ncol,
nrow = nrow,
guides = guides,
widths = widths,
heights = heights,
crs = crs,
default_crs = default_crs,
lims_method = lims_method,
wrap = wrap,
envir = envir,
...
)
}
sm_plots
}
#' @rdname gratia_mvgam_enhancements
#' @aliases eval_smooth.hilbert.smooth
#' @export
eval_smoothDothilbertDotsmooth = function(
smooth,
model,
n = 100,
n_3d = NULL,
n_4d = NULL,
data = NULL,
unconditional = FALSE,
overall_uncertainty = TRUE,
dist = NULL,
...
) {
insight::check_if_installed("gratia")
model$cmX <- model$coefficients
# deal with data if supplied
data <- process_user_data_for_eval(
data = data,
model = model,
n = n,
n_3d = n_3d,
n_4d = n_4d,
id = which_smooth(
model,
gratia::smooth_label(smooth)
)
)
# by variables
by_var <- gratia::by_variable(smooth)
if (by_var == "NA") {
by_var <- NA_character_
}
# Compute the gp() eigenfunctions for newdata using the supplied brms_mock object
# Requires a dataframe of all relevant variables for the gp effects
mock_terms <- brms::brmsterms(attr(model, 'brms_mock')$formula)
terms_needed <- unique(all.vars(mock_terms$formula)[-1])
# Only use actual values of those covariates needed for this smooth
terms_smooth <- intersect(terms_needed, colnames(data))
newdata_mock <- data.frame(data[[terms_smooth[1]]])
if (length(terms_smooth) > 1L) {
for (i in 2:length(terms_smooth)) {
newdata_mock <- cbind(newdata_mock, data.frame(data[[terms_smooth[i]]]))
}
}
colnames(newdata_mock) <- terms_smooth
newdata_mock$.fake_gp_y <- rnorm(NROW(newdata_mock))
# Fill in other covariates as fixed values from the original data
other_terms <- setdiff(terms_needed, colnames(data))
if (length(other_terms) > 0) {
newdata_mock <- cbind(
newdata_mock,
do.call(
cbind,
lapply(seq_along(other_terms), function(x) {
df <- data.frame(
var = rep(model$model[[other_terms[x]]][1], NROW(newdata_mock))
)
colnames(df) <- other_terms[x]
df
})
)
)
}
brms_mock_data <- brms::standata(
attr(model, 'brms_mock'),
newdata = newdata_mock,
internal = TRUE
)
# Extract GP attributes
gp_att_table <- attr(model, 'gp_att_table')
bys <- unlist(purrr::map(gp_att_table, 'by'), use.names = FALSE)
lvls <- unlist(purrr::map(gp_att_table, 'level'), use.names = FALSE)
# Extract eigenfunctions for each gp effect
eigenfuncs <- eigenfunc_list(
stan_data = brms_mock_data,
mock_df = newdata_mock,
by = bys,
level = lvls
)
# Which GP term are we plotting?
gp_covariate <- smooth$term
level <- ifelse(is.null(smooth$by.level), NA, smooth$by.level)
gp_names <- gsub(' ', '', unlist(purrr::map(gp_att_table, 'name')))
if (!is.na(level)) {
gp_select <- which(
gp_names == smooth$label &
unlist(purrr::map(gp_att_table, 'level')) == level
)
} else {
gp_select <- which(
gp_names == smooth$label &
which(bys %in% by_var)
)
}
# Compute eigenfunctions for this GP term
X <- eigenfuncs[[gp_select]]
# Extract mean coefficients
start <- purrr::map(gp_att_table, 'first_coef')[[gp_select]]
end <- purrr::map(gp_att_table, 'last_coef')[[gp_select]]
betas <- model$coefficients[start:end]
fit <- as.vector(X %*% betas)
## want full vcov for component-wise CI
V <- model$Vp
## variables for component-wise CIs for smooths
column_means <- model[["cmX"]]
lcms <- length(column_means)
nc <- ncol(V)
meanL1 <- smooth[["meanL1"]]
eta_idx <- lss_eta_index(model)
para.seq <- start:end
if (isTRUE(overall_uncertainty) && attr(smooth, "nCons") > 0L) {
if (lcms < nc) {
column_means <- c(column_means, rep(0, nc - lcms))
}
Xcm <- matrix(column_means, nrow = nrow(X), ncol = nc, byrow = TRUE)
if (!is.null(meanL1)) {
Xcm <- Xcm / meanL1
}
Xcm[, para.seq] <- X
# only apply the uncertainty from linear predictors of which this smooth
# is a part of
idx <- vapply(
eta_idx,
function(i, beta) any(beta %in% i),
FUN.VALUE = logical(1L),
beta = para.seq
)
idx <- unlist(eta_idx[idx])
rs <- rowSums(
(Xcm[, idx, drop = FALSE] %*%
V[idx, idx, drop = FALSE]) *
Xcm[, idx, drop = FALSE]
)
} else {
rs <- rowSums((X %*% V[para.seq, para.seq, drop = FALSE]) * X)
}
## standard error of the estimate
se.fit <- sqrt(pmax(0, rs))
# convert to the gratia tidy format
label <- smooth$label
## identify which vars are needed for this smooth...
keep_vars <- c(smooth$term, smooth$by)
keep_vars <- keep_vars[!keep_vars %in% 'NA']
## ... then keep only those vars
data <- dplyr::select(data, dplyr::all_of(keep_vars))
## tibble object
tbl <- tibble::tibble(
.smooth = rep(label, nrow(X)),
.estimate = fit,
.se = se.fit
)
## bind on the data
tbl <- dplyr::bind_cols(tbl, data)
## nest all columns with varying data
eval_sm <- tidyr::nest(
tbl,
data = tidyr::all_of(c(".estimate", ".se", names(data)))
)
## add on info regarding by variable
eval_sm <- add_by_var_column(eval_sm, by_var = by_var)
## add on spline type info
eval_sm <- add_smooth_type_column(eval_sm, sm_type = "GP")
# set some values to NA if too far from the data
if (gratia::smooth_dim(smooth) == 2L && (!is.null(dist) && dist > 0)) {
eval_sm <- gratia::too_far_to_na(
smooth,
input = eval_sm,
reference = model[["model"]],
cols = c(".estimate", ".se"),
dist = dist
)
}
return(eval_sm)
}
#' @rdname gratia_mvgam_enhancements
#' @aliases eval_smooth.mod.smooth
#' @export
eval_smoothDotmodDotsmooth = function(
smooth,
model,
n = 100,
n_3d = NULL,
n_4d = NULL,
data = NULL,
unconditional = FALSE,
overall_uncertainty = TRUE,
dist = NULL,
...
) {
insight::check_if_installed("gratia")
model$cmX <- model$coefficients
## deal with data if supplied
data <- process_user_data_for_eval(
data = data,
model = model,
n = n,
n_3d = n_3d,
n_4d = n_4d,
id = which_smooth(
model,
gratia::smooth_label(smooth)
)
)
by_var <- gratia::by_variable(smooth) # even if not a by as we want NA later
if (by_var == "NA") {
by_var <- NA_character_
}
## values of spline at data
eval_sm <- gratia::spline_values(
smooth,
data = data,
unconditional = unconditional,
model = model,
overall_uncertainty = overall_uncertainty
)
## add on info regarding by variable
eval_sm <- add_by_var_column(eval_sm, by_var = by_var)
## add on spline type info
eval_sm <- add_smooth_type_column(eval_sm, sm_type = "Mono dec P spline")
# set some values to NA if too far from the data
if (gratia::smooth_dim(smooth) == 2L && (!is.null(dist) && dist > 0)) {
eval_sm <- gratia::too_far_to_na(
smooth,
input = eval_sm,
reference = model[["model"]],
cols = c(".estimate", ".se"),
dist = dist
)
}
## return
eval_sm
}
#' @rdname gratia_mvgam_enhancements
#' @aliases eval_smooth.moi.smooth
#' @export
eval_smoothDotmoiDotsmooth = function(
smooth,
model,
n = 100,
n_3d = NULL,
n_4d = NULL,
data = NULL,
unconditional = FALSE,
overall_uncertainty = TRUE,
dist = NULL,
...
) {
insight::check_if_installed("gratia")
model$cmX <- model$coefficients
## deal with data if supplied
data <- process_user_data_for_eval(
data = data,
model = model,
n = n,
n_3d = n_3d,
n_4d = n_4d,
id = which_smooth(
model,
gratia::smooth_label(smooth)
)
)
by_var <- gratia::by_variable(smooth) # even if not a by as we want NA later
if (by_var == "NA") {
by_var <- NA_character_
}
## values of spline at data
eval_sm <- gratia::spline_values(
smooth,
data = data,
unconditional = unconditional,
model = model,
overall_uncertainty = overall_uncertainty
)
## add on info regarding by variable
eval_sm <- add_by_var_column(eval_sm, by_var = by_var)
## add on spline type info
eval_sm <- add_smooth_type_column(eval_sm, sm_type = "Mono inc P spline")
# set some values to NA if too far from the data
if (gratia::smooth_dim(smooth) == 2L && (!is.null(dist) && dist > 0)) {
eval_sm <- gratia::too_far_to_na(
smooth,
input = eval_sm,
reference = model[["model"]],
cols = c(".estimate", ".se"),
dist = dist
)
}
## return
eval_sm
}
#' Utility functions; full credit goes to Gavin Simpson, the developer and
#' maintainer of the gratia package
#' @noRd
`is.gamm` <- function(object) {
inherits(object, "gamm")
}
#' @noRd
`is.gamm4` <- function(object) {
is.list(object) & (!is.null(object[["gam"]]))
}
#' @noRd
`is.gam` <- function(object) {
inherits(object, "gam")
}
#' @noRd
`is.bam` <- function(object) {
inherits(object, "bam")
}
#' @noRd
`which_smooth` <- function(object, term) {
if (is.gamm(object) || is.gamm4(object)) {
object <- object[["gam"]]
}
smooths <- gratia::smooths(object)
which(term == smooths)
}
#' @noRd
`process_user_data_for_eval` <- function(
data,
model,
n,
n_3d,
n_4d,
id,
var_order = NULL
) {
if (is.null(data)) {
data <- gratia::smooth_data(
model = model,
n = n,
n_3d = n_3d,
n_4d = n_4d,
id = id,
var_order = var_order
)
} else {
smooth <- gratia::get_smooths_by_id(model, id)[[1L]]
vars <- smooth_variable(smooth)
by_var <- gratia::by_variable(smooth)
if (!identical(by_var, "NA")) {
vars <- append(vars, by_var)
}
## if this is a by variable, filter the by variable for the required
## level now
if (gratia::is_factor_by_smooth(smooth)) {
data <- data %>%
dplyr::filter(.data[[by_var]] == gratia::by_level(smooth))
}
}
data
}
#' @noRd
`add_by_var_column` <- function(object, by_var, n = NULL) {
if (is.null(n)) {
n <- NROW(object)
}
insight::check_if_installed("tibble")
tibble::add_column(object, .by = rep(by_var, times = n), .after = 1L)
}
#' @noRd
`add_smooth_type_column` <- function(object, sm_type, n = NULL) {
if (is.null(n)) {
n <- NROW(object)
}
insight::check_if_installed("tibble")
tibble::add_column(object, .type = rep(sm_type, times = n), .after = 1L)
}
#' @noRd
lss_eta_index <- function(object) {
function(object) {
lpi <- attr(formula(object), "lpi")
if (is.null(lpi)) {
lpi <- list(seq_along(coef(object)))
}
attr(lpi, "overlap") <- NULL
lpi
}
}
#' @noRd
smooth_variable <- function(smooth) {
gratia::check_is_mgcv_smooth(smooth)
smooth[["term"]]
}
================================================
FILE: R/hindcast.mvgam.R
================================================
#'@title Extract hindcasts for a fitted \code{mvgam} object
#'@name hindcast.mvgam
#'@importFrom stats predict
#'@inheritParams predict.mvgam
#'@param ... Ignored
#'@details Posterior hindcasts (i.e. retrodictions) are drawn from the fitted \code{mvgam} and
#'organized into a convenient format for plotting
#'@return An object of class \code{mvgam_forecast} containing hindcast distributions.
#'See \code{\link{mvgam_forecast-class}} for details.
#'
#'@seealso [plot.mvgam_forecast()], [summary.mvgam_forecast()],
#'[forecast.mvgam()], [fitted.mvgam()], [predict.mvgam()]
#'@export
hindcast <- function(object, ...) {
UseMethod("hindcast", object)
}
#'@rdname hindcast.mvgam
#'@method hindcast mvgam
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam(n_series = 3, trend_model = AR())
#' mod <- mvgam(y ~ s(season, bs = 'cc'),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2)
#'
#' # Hindcasts on response scale
#' hc <- hindcast(mod)
#' str(hc)
#' head(summary(hc), 12)
#' plot(hc, series = 1)
#' plot(hc, series = 2)
#' plot(hc, series = 3)
#'
#' # Hindcasts as expectations
#' hc <- hindcast(mod, type = 'expected')
#' head(summary(hc), 12)
#' plot(hc, series = 1)
#' plot(hc, series = 2)
#' plot(hc, series = 3)
#'
#' # Estimated latent trends
#' hc <- hindcast(mod, type = 'trend')
#' head(summary(hc), 12)
#' plot(hc, series = 1)
#' plot(hc, series = 2)
#' plot(hc, series = 3)
#' }
#'@export
hindcast.mvgam = function(object, type = 'response', ...) {
# Check arguments
series <- 'all'
type <- match.arg(
arg = type,
choices = c(
"link",
"response",
"trend",
"expected",
"latent_N",
"detection"
)
)
data_train <- object$obs_data
data_train <- validate_series_time(
data_train,
trend_model = attr(object$model_data, 'trend_model')
)
last_train <- max(data_train$index..time..index) -
(min(data_train$index..time..index) - 1)
n_series <- NCOL(object$ytimes)
n_predcols <- dim(mcmc_chains(object$model_output, 'ypred'))
ends <- seq(0, n_predcols[2], length.out = NCOL(object$ytimes) + 1)
starts <- ends + 1
starts <- c(1, starts[-c(1, (NCOL(object$ytimes) + 1))])
ends <- ends[-1]
# Extract hindcasts for storing in the returned object
series_hcs <- lapply(seq_len(n_series), function(series) {
to_extract <- switch(
type,
'link' = 'mus',
'expected' = 'mus',
'response' = 'ypred',
'trend' = 'trend',
'latent_N' = 'mus',
'detection' = 'mus'
)
if (object$family == 'nmix' & type == 'link') {
to_extract <- 'trend'
}
if (object$fit_engine == 'stan') {
preds <- mcmc_chains(object$model_output, to_extract)[,
seq(series, n_predcols[2], by = n_series),
drop = FALSE
][, 1:last_train]
} else {
preds <- mcmc_chains(object$model_output, to_extract)[,
starts[series]:ends[series],
drop = FALSE
][, 1:last_train]
}
if (object$family == 'nmix' & type == 'link') {
preds <- exp(preds)
}
if (type %in% c('expected', 'latent_N', 'detection')) {
# Extract family-specific parameters for this series
family_pars <- extract_family_pars(object = object)
par_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
as.vector(matrix(
rep(as.vector(family_pars[[j]][, series]), NCOL(preds)),
nrow = NROW(preds),
byrow = FALSE
))
} else {
as.vector(matrix(
rep(family_pars[[j]], NCOL(preds)),
nrow = NROW(preds),
byrow = FALSE
))
}
})
names(par_extracts) <- names(family_pars)
# Add trial information if this is a Binomial model
if (object$family %in% c('binomial', 'beta_binomial')) {
trials <- as.vector(matrix(
rep(
as.vector(attr(object$mgcv_model, 'trials')[, series]),
NROW(preds)
),
nrow = NROW(preds),
byrow = TRUE
))
par_extracts$trials <- trials
}
# Compute expectations as one long vector
Xpmat <- matrix(as.vector(preds))
attr(Xpmat, 'model.offset') <- 0
if (object$family == 'nmix') {
preds <- mcmc_chains(object$model_output, 'detprob')[,
object$ytimes[1:last_train, series],
drop = FALSE
]
Xpmat <- matrix(qlogis(as.vector(preds)))
attr(Xpmat, 'model.offset') <- 0
latent_lambdas <- as.vector(mcmc_chains(object$model_output, 'trend')[,
seq(series, n_predcols[2], by = n_series),
drop = FALSE
][, 1:last_train])
latent_lambdas <- exp(latent_lambdas)
cap <- as.vector(t(replicate(
n_predcols[1],
object$obs_data$cap[which(
as.numeric(object$obs_data$series) == series
)]
)))
} else {
latent_lambdas <- NULL
cap <- NULL
}
if (type == 'latent_N') {
preds <- mcmc_chains(object$model_output, 'latent_ypred')[,
seq(series, n_predcols[2], by = n_series),
drop = FALSE
][, 1:last_train]
} else {
preds <- matrix(
as.vector(mvgam_predict(
family = object$family,
Xp = Xpmat,
latent_lambdas = latent_lambdas,
cap = cap,
type = type,
betas = 1,
family_pars = par_extracts
)),
nrow = NROW(preds)
)
}
}
preds
})
names(series_hcs) <- levels(data_train$series)
series_obs <- lapply(seq_len(n_series), function(series) {
s_name <- levels(data_train$series)[series]
data.frame(
series = data_train$series,
time = data_train$index..time..index,
y = data_train$y
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
})
names(series_obs) <- levels(data_train$series)
series_train_times <- lapply(seq_len(n_series), function(series) {
s_name <- levels(data_train$series)[series]
data.frame(
series = data_train$series,
time = data_train$time,
y = data_train$y
) %>%
dplyr::filter(series == s_name) %>%
dplyr::arrange(time) %>%
dplyr::pull(time)
})
names(series_train_times) <- levels(data_train$series)
series_fcs <- structure(
list(
call = object$call,
trend_call = object$trend_call,
family = object$family,
trend_model = object$trend_model,
drift = object$drift,
use_lv = object$use_lv,
fit_engine = object$fit_engine,
type = type,
series_names = levels(data_train$series),
train_observations = series_obs,
train_times = series_train_times,
test_observations = NULL,
test_times = NULL,
hindcasts = series_hcs,
forecasts = NULL
),
class = 'mvgam_forecast'
)
return(series_fcs)
}
================================================
FILE: R/how_to_cite.R
================================================
#' Generate a methods description for \pkg{mvgam} models
#'
#' Create a brief but fully referenced methods description, along with a useful
#' list of references, for fitted \code{mvgam} and \code{jsdgam} models.
#'
#' @name how_to_cite.mvgam
#'
#' @param object \code{list} object of class \code{mvgam} resulting from a call
#' to [mvgam()] or [jsdgam()]
#'
#' @param ... ignored
#'
#' @details This function uses the model's structure to come up with a very
#' basic but hopefully useful methods description that can help users to
#' appropriately acknowledge the hard work of developers and champion open
#' science. Please do not consider the text returned by this function to be a
#' completely adequate methods section; it is only meant to get you started.
#'
#' @return An object of class \code{how_to_cite} containing a text description
#' of the methods as well as lists of both primary and additional references.
#'
#' @author Nicholas J Clark
#'
#' @seealso \code{\link[utils]{citation}}, \code{\link{mvgam}},
#' \code{\link{jsdgam}}
#'
#' @examples
#' \dontrun{
#' #--------------------------------------------------
#' # Simulate 4 time series with hierarchical seasonality
#' # and a VAR(1) dynamic process
#' #--------------------------------------------------
#' set.seed(0)
#'
#' simdat <- sim_mvgam(
#' seasonality = 'hierarchical',
#' trend_model = VAR(cor = TRUE),
#' family = gaussian()
#' )
#'
#' # Fit an appropriate model
#' mod1 <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' data = simdat$data_train,
#' family = gaussian(),
#' trend_model = VAR(cor = TRUE),
#' chains = 2,
#' silent = 2
#' )
#'
#' how_to_cite(mod1)
#'
#' #--------------------------------------------------
#' # For a GP example, simulate data using the mgcv package
#' #--------------------------------------------------
#' dat <- mgcv::gamSim(1, n = 30, scale = 2)
#'
#' # Fit a model that uses an approximate GP from brms
#' mod2 <- mvgam(
#' y ~ gp(x2, k = 12),
#' data = dat,
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#'
#' how_to_cite(mod2)
#' }
#'
#'@export
how_to_cite <- function(object, ...) {
UseMethod("how_to_cite", object)
}
#'@export
#'@export
print.how_to_cite = function(x, ...) {
cat("Methods text skeleton\n")
cat(insight::format_message(x$methods_text))
cat('\n')
cat("\nPrimary references\n")
for (i in seq_along(x$citations)) {
cat(insight::format_message(x$citations[[i]]))
cat('\n')
}
cat("\nOther useful references\n")
for (i in seq_along(x$other_citations)) {
cat(insight::format_message(x$other_citations[[i]]))
cat('\n')
}
invisible(x)
}
#'@rdname how_to_cite.mvgam
#'@method how_to_cite mvgam
#'@export
how_to_cite.mvgam <- function(object, ...) {
current_year <- format(Sys.Date(), "%Y")
citations <- vector(mode = 'list')
# mvgam-specific methods
mvgam_text <- paste0(
"We used the R package mvgam (version ",
utils::packageVersion("mvgam"),
"; Clark & Wells, 2023) to construct, fit and interrogate the model.",
" mvgam fits Bayesian State-Space models that can include flexible",
" predictor effects in both the process and observation components",
" by incorporating functionalities from the brms (Burkner 2017),",
" mgcv (Wood 2017) and splines2 (Wang & Yan, 2023) packages."
)
citations[[
1
]] <- "Clark, NJ and Wells K (2023). Dynamic Generalized Additive Models (DGAMs) for forecasting discrete ecological time series. Methods in Ecology and Evolution, 14, 771-784. doi.org/10.1111/2041-210X.13974"
citations[[
2
]] <- "Burkner, PC (2017). brms: An R Package for Bayesian Multilevel Models Using Stan. Journal of Statistical Software, 80(1), 1-28. doi:10.18637/jss.v080.i01"
citations[[
3
]] <- "Wood, SN (2017). Generalized Additive Models: An Introduction with R (2nd edition). Chapman and Hall/CRC."
citations[[
4
]] <- "Wang W and Yan J (2021). Shape-Restricted Regression Splines with R Package splines2. Journal of Data Science, 19(3), 498-517. doi:10.6339/21-JDS1020 https://doi.org/10.6339/21-JDS1020."
# Any specials; first check whether this model used a VAR / VARMA process
specials_text <- NULL
trend_model <- attr(object$model_data, 'trend_model')
if (
trend_model %in%
c(
'VAR',
'VARcor',
'VARhiercor',
'VAR1',
'VAR1cor',
'VAR1hiercor',
'VARMA',
'VARMAcor',
'VARMA1,1cor'
)
) {
specials_text <- c(
specials_text,
" To encourage stability and prevent forecast variance from increasing indefinitely, we enforced stationarity of the Vector Autoregressive process following methods described by Heaps (2023) and Clark et al. (2025)."
)
citations <- append(
citations,
list(
"Heaps, SE (2023). Enforcing stationarity through the prior in vector autoregressions. Journal of Computational and Graphical Statistics 32, 74-83."
)
)
citations <- append(
citations,
list(
"Clark NJ, Ernest SKM, Senyondo H, Simonis J, White EP, Yenni GM, Karunarathna KANK (2025). Beyond single-species models: leveraging multispecies forecasts to navigate the dynamics of ecological predictability. PeerJ 13:e18929."
)
)
}
# Check for approximate GPs
if (
!is.null(attr(object$mgcv_model, 'gp_att_table')) |
!is.null(attr(object$trend_mgcv_model, 'gp_att_table')) |
trend_model == 'GP'
) {
specials_text <- c(
specials_text,
" Gaussian Process functional effects were estimated using a low-rank Hilbert space approximation following methods described by Riutort-Mayol et al. (2023)."
)
citations <- append(
citations,
list(
"Riutort-Mayol G, Burkner PC, Andersen MR, Solin A and Vehtari A (2023). Practical Hilbert space approximate Bayesian Gaussian processes for probabilistic programming. Statistics and Computing 33, 1. https://doi.org/10.1007/s11222-022-10167-2"
)
)
}
# Check for piecewise trends
if (
trend_model %in%
c('PWlogistic', 'PWlinear')
) {
specials_text <- c(
specials_text,
" Piecewise dynamic trends were parameterized and estimated following methods described by Taylor and Letham (2018)."
)
citations <- append(
citations,
list(
"Taylor S and Letham B (2018). Forecasting at scale. The American Statistician 72(1) 37-45. https://doi.org/10.1080/00031305.2017.1380080"
)
)
}
# Was this a jsdgam?
if (inherits(object, 'jsdgam')) {
specials_text <- c(
specials_text,
" To ensure identifiability of factors, factor loadings were constrained following Lopes & West (2004)."
)
citations <- append(
citations,
list(
"Lopes HF and West M (2014). Bayesian model assessment in factor analysis. Statistica Sinica 14(1) 41-67. https://www.jstor.org/stable/24307179"
)
)
}
# Stan-specific methods
citations <- append(
citations,
list(
"Carpenter B, Gelman A, Hoffman MD, Lee D, Goodrich B, Betancourt M, Brubaker M, Guo J, Li P and Riddell A (2017). Stan: A probabilistic programming language. Journal of Statistical Software 76."
)
)
stan_text <-
paste0(
" The mvgam-constructed model and observed data",
" were passed to the probabilistic programming environment Stan"
)
if (object$backend == 'cmdstanr') {
stan_text <- paste0(
stan_text,
" (version ",
cmdstanr::cmdstan_version(),
"; Carpenter et al. 2017, Stan Development Team ",
current_year,
"), specifically through the cmdstanr interface (Gabry & Cesnovar, 2021)."
)
citations <- append(
citations,
list(paste0(
"Gabry J, Cesnovar R, Johnson A, and Bronder S (",
current_year,
"). cmdstanr: R Interface to 'CmdStan'. https://mc-stan.org/cmdstanr/, https://discourse.mc-stan.org."
))
)
} else {
stan_text <- paste0(
stan_text,
" (version ",
rstan::stan_version(),
"; Carpenter et al. 2017)",
", specifically through the rstan interface (Stan Development Team ",
current_year,
")"
)
citations <- append(
citations,
list(paste0(
"Stan Development Team (",
current_year,
"). RStan: the R interface to Stan. R package version ",
utils::packageVersion("rstan"),
". https://mc-stan.org/."
))
)
}
if (object$algorithm == 'sampling') {
stan_text <- paste0(
stan_text,
" We ran ",
object$model_output@sim$chains,
" Hamiltonian Monte Carlo chains for ",
object$model_output@sim$warmup,
" warmup iterations and ",
object$model_output@sim$iter - object$model_output@sim$warmup,
" sampling iterations for joint posterior estimation.",
" Rank normalized split Rhat (Vehtari et al. 2021) and effective",
" sample sizes were used to monitor convergence."
)
citations <- append(
citations,
list(
"Vehtari A, Gelman A, Simpson D, Carpenter B, and Burkner P (2021). Rank-normalization, folding, and localization: An improved Rhat for assessing convergence of MCMC (with discussion). Bayesian Analysis 16(2) 667-718. https://doi.org/10.1214/20-BA1221."
)
)
}
if (object$algorithm %in% c('meanfield', 'fullrank')) {
stan_text <- paste0(
stan_text,
" We used Stan's Automatic Differentiation Variational Inference algorithm",
" (Kucukelbir et al. 2017) for posterior approximation, specifically using ",
object$algorithm,
" algorithm to draw ",
object$model_output@sim$iter,
" samples from the approximate joint posterior."
)
citations <- append(
citations,
list(
"Kucukelbir A, Tran D, Ranganath R, Gelman A, and Blei DM (2017). Automatic Differentiation Variational Inference. Journal of Machine Learning Research 18 1-45."
)
)
}
if (object$algorithm == c('laplace')) {
stan_text <- paste0(
stan_text,
" We used Stan's Laplace approximation algorithm",
" to draw ",
object$model_output@sim$iter,
" samples from the approximate joint posterior."
)
}
if (object$algorithm == c('pathfinder')) {
stan_text <- paste0(
stan_text,
" We used Stan's Pathfinder variational approximation algorithm (Zhang et al. 2022)",
" to draw ",
object$model_output@sim$iter,
" samples from the approximate joint posterior."
)
citations <- append(
citations,
list(
"Zhang L, Carpenter B, Gelman A, and Vehtari A (2022). Pathfinder: parallel Quasi-Newton variational inference. Journal of Machine Learning Research 23(306), 1-49. http://jmlr.org/papers/v23/21-0889.html."
)
)
}
# Append texts
all_text <- paste0(mvgam_text, specials_text, stan_text)
# List of additional, possibly very useful references
other_citations <- vector(mode = 'list')
other_citations[[
1
]] <- "Arel-Bundock V, Greifer N, and Heiss A (2024). How to interpret statistical models using marginaleffects for R and Python. Journal of Statistical Software, 111(9), 1-32. https://doi.org/10.18637/jss.v111.i09"
other_citations[[
2
]] <- "Gabry J, Simpson D, Vehtari A, Betancourt M, and Gelman A (2019). Visualization in Bayesian workflow. Journal of the Royal Statatistical Society A, 182, 389-402. doi:10.1111/rssa.12378."
other_citations[[
3
]] <- "Vehtari A, Gelman A, and Gabry J (2017). Practical Bayesian model evaluation using leave-one-out cross-validation and WAIC. Statistics and Computing, 27, 1413-1432. doi:10.1007/s11222-016-9696-4."
other_citations[[
4
]] <- "Burkner PC, Gabry J, and Vehtari A. (2020). Approximate leave-future-out cross-validation for Bayesian time series models. Journal of Statistical Computation and Simulation, 90(14), 2499-2523. https://doi.org/10.1080/00949655.2020.1783262"
out <- structure(
list(
methods_text = all_text,
citations = citations,
other_citations = other_citations
),
class = 'how_to_cite'
)
return(out)
}
================================================
FILE: R/index-mvgam.R
================================================
#' Index \code{mvgam} objects
#'
#' @aliases variables
#'
#' Index variables and their `mgcv` coefficient names
#'
#' @param x A \code{mvgam} object or another \R object for which
#' the methods are defined.
#'
#' @param ... Arguments passed to individual methods (if applicable).
#'
#' @name index-mvgam
NULL
#' @rdname index-mvgam
#'
#' @importFrom posterior variables
#'
#' @param x \code{list} object returned from \code{mvgam}. See [mvgam()]
#'
#' @method variables mvgam
#'
#' @return a `list` object of the variables that can be extracted, along
#' with their aliases
#'
#' @author Nicholas J Clark
#'
#' @examples
#' \dontrun{
#' # Simulate data and fit a model
#' simdat <- sim_mvgam(
#' n_series = 1,
#' trend_model = AR()
#' )
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract model variables
#' variables(mod)
#' }
#'
#' @export
#' @export variables
variables.mvgam = function(x, ...) {
parnames <- dimnames(x$model_output)$parameters
# Observation distribution parameters
if (
any(grepl(
paste(c('sigma_obs', 'phi', 'nu', 'shape'), collapse = '|'),
parnames
))
) {
observation_pars <- data.frame(
orig_name = parnames[grepl(
paste(c('sigma_obs', 'phi', 'nu', 'shape'), collapse = '|'),
parnames
)],
alias = NA
)
} else {
observation_pars <- NULL
}
# Linear predictor parameters
observation_linpreds <- data.frame(
orig_name = parnames[
grepl('mus[', parnames, fixed = TRUE) &
!grepl('trend_mus[', parnames, fixed = TRUE)
],
alias = NA
)
if (!is.null(x$trend_call) & !inherits(x, 'jsdgam')) {
trend_linpreds <- data.frame(
orig_name = parnames[grepl('trend_mus[', parnames, fixed = TRUE)],
alias = NA
)
} else {
trend_linpreds <- NULL
}
# Posterior predictions
posterior_preds <- data.frame(
orig_name = parnames[grepl('ypred[', parnames, fixed = TRUE)],
alias = NA
)
# Beta coefficient parameters
b_names <- colnames(mcmc_chains(x$model_output, 'b'))
mgcv_names <- names(coef(x$mgcv_model))
observation_betas <- data.frame(orig_name = b_names, alias = mgcv_names)
if (!is.null(x$trend_call) & !inherits(x, 'jsdgam')) {
b_names <- colnames(mcmc_chains(x$model_output, 'b_trend'))
mgcv_names <- gsub(
'series',
'trend',
paste0(names(coef(x$trend_mgcv_model)), '_trend')
)
trend_betas <- data.frame(orig_name = b_names, alias = mgcv_names)
} else {
trend_betas <- NULL
}
# Population parameters from hierarchical (random) effects
if (any(unlist(purrr::map(x$mgcv_model$smooth, inherits, 'random.effect')))) {
re_labs <- unlist(lapply(
purrr::map(x$mgcv_model$smooth, 'term'),
paste,
collapse = ','
))[
unlist(purrr::map(x$mgcv_model$smooth, inherits, 'random.effect'))
]
observation_re_params <- data.frame(
orig_name = c(
rownames(mcmc_summary(x$model_output, 'mu_raw', ISB = TRUE)),
rownames(mcmc_summary(x$model_output, 'sigma_raw', ISB = TRUE))
),
alias = c(paste0('mean(', re_labs, ')'), paste0('sd(', re_labs, ')'))
)
} else {
observation_re_params <- NULL
}
trend_re_params <- NULL
if (!is.null(x$trend_call) & !inherits(x, 'jsdgam')) {
if (
any(unlist(purrr::map(
x$trend_mgcv_model$smooth,
inherits,
'random.effect'
)))
) {
re_labs <- unlist(lapply(
purrr::map(x$trend_mgcv_model$smooth, 'term'),
paste,
collapse = ','
))[
unlist(purrr::map(x$trend_mgcv_model$smooth, inherits, 'random.effect'))
]
re_labs <- gsub('series', 'trend', re_labs)
trend_re_params <- data.frame(
orig_name = c(
rownames(mcmc_summary(x$model_output, 'mu_raw_trend', ISB = TRUE)),
rownames(mcmc_summary(x$model_output, 'sigma_raw_trend', ISB = TRUE))
),
alias = c(
paste0('mean(', re_labs, ')_trend'),
paste0('sd(', re_labs, ')_trend')
)
)
} else {
trend_re_params <- NULL
}
}
# Smoothing parameters
if (any(grepl('rho[', parnames, fixed = TRUE))) {
observation_smoothpars <- data.frame(
orig_name = parnames[grepl('rho[', parnames, fixed = TRUE)],
alias = paste0(x$sp_names, '_rho')
)
} else {
observation_smoothpars <- NULL
}
if (
any(grepl('rho_trend[', parnames, fixed = TRUE)) & !inherits(x, 'jsdgam')
) {
trend_smoothpars <- data.frame(
orig_name = parnames[grepl('rho_trend[', parnames, fixed = TRUE)],
alias = paste0(x$trend_sp_names, '_rho_trend')
)
} else {
trend_smoothpars <- NULL
}
# Trend state parameters
if (
any(
grepl('trend[', parnames, fixed = TRUE) &
!grepl('_trend[', parnames, fixed = TRUE)
) &
!inherits(x, 'jsdgam')
) {
trend_states <- grepl('trend[', parnames, fixed = TRUE) &
!grepl('_trend[', parnames, fixed = TRUE)
trends <- data.frame(orig_name = parnames[trend_states], alias = NA)
} else {
trends <- NULL
}
# Trend dynamics parameters
if (
any(
grepl(
paste(
c(
'sigma',
'alpha_gp',
'rho_gp',
'ar1',
'ar2',
'ar3',
'A',
'Sigma',
'error',
'alpha_cor',
'theta',
'k_trend',
'delta_trend',
'm_trend'
),
collapse = '|'
),
parnames
) &
!grepl('sigma_obs', parnames, fixed = TRUE) &
!grepl('sigma_raw', parnames, fixed = TRUE)
)
) {
trend_pars <- grepl(
paste(
c(
'sigma',
'alpha_gp',
'rho_gp',
'ar1',
'ar2',
'ar3',
'A',
'Sigma',
'error',
'alpha_cor',
'theta',
'k_trend',
'delta_trend',
'm_trend'
),
collapse = '|'
),
parnames
) &
!grepl('sigma_obs', parnames, fixed = TRUE) &
!grepl('sigma_raw', parnames, fixed = TRUE)
trend_pars <- data.frame(orig_name = parnames[trend_pars], alias = NA)
} else {
trend_pars <- NULL
}
return(list(
observation_pars = observation_pars,
observation_linpreds = observation_linpreds,
observation_betas = observation_betas,
observation_smoothpars = observation_smoothpars,
observation_re_params = observation_re_params,
posterior_preds = posterior_preds,
trend_pars = trend_pars,
trend_linpreds = trend_linpreds,
trend_betas = trend_betas,
trend_smoothpars = trend_smoothpars,
trend_re_params = trend_re_params,
trends = trends
))
}
================================================
FILE: R/interpret_mvgam.R
================================================
#' Interpret the formula specified to mvgam and replace any dynamic terms
#' with the correct Gaussian Process smooth specification
#' @importFrom stats formula terms as.formula terms.formula
#' @noRd
interpret_mvgam = function(formula, N, family) {
# Check for proper binomial specification
if (!missing(family)) {
if (is.character(family)) {
if (family == 'beta') {
family <- betar()
}
family <- try(eval(parse(text = family)), silent = TRUE)
if (inherits(family, 'try-error')) {
stop("family not recognized", call. = FALSE)
}
}
if (is.function(family)) {
family <- family()
}
if (family$family %in% c('binomial', 'beta_binomial')) {
# Check that response terms use the cbind() syntax
resp_terms <- as.character(terms(formula(formula))[[2]])
if (length(resp_terms) == 1) {
stop(
'Binomial family requires cbind() syntax in the formula left-hand side',
call. = FALSE
)
} else {
if (any(grepl('cbind', resp_terms))) {} else {
stop(
'Binomial family requires cbind() syntax in the formula left-hand side',
call. = FALSE
)
}
}
}
}
facs <- colnames(attr(terms.formula(formula), 'factors'))
# Check if formula has an intercept
keep_intercept <- attr(terms(formula), 'intercept') == 1
# Re-arrange so that random effects always come last
if (any(grepl('bs = \"re\"', facs, fixed = TRUE))) {
newfacs <- facs[!grepl('bs = \"re\"', facs, fixed = TRUE)]
refacs <- facs[grepl('bs = \"re\"', facs, fixed = TRUE)]
int <- attr(terms.formula(formula), 'intercept')
# Preserve offset if included
if (!is.null(attr(terms(formula(formula)), 'offset'))) {
newformula <- as.formula(paste(
dimnames(attr(terms(formula), 'factors'))[[1]][1],
'~',
grep(
'offset',
rownames(attr(terms.formula(formula), 'factors')),
value = TRUE
),
'+',
paste(
paste(newfacs, collapse = '+'),
'+',
paste(refacs, collapse = '+'),
collapse = '+'
),
ifelse(int == 0, ' - 1', '')
))
} else {
newformula <- as.formula(paste(
dimnames(attr(terms(formula), 'factors'))[[1]][1],
'~',
paste(
paste(newfacs, collapse = '+'),
'+',
paste(refacs, collapse = '+'),
collapse = '+'
),
ifelse(int == 0, ' - 1', '')
))
}
} else {
newformula <- formula
}
attr(newformula, '.Environment') <- attr(formula, '.Environment')
# Check if any terms use the gp wrapper
response <- terms.formula(newformula)[[2]]
tf <- terms.formula(newformula, specials = c("gp"))
which_gp <- attr(tf, "specials")$gp
if (length(which_gp) != 0L) {
gp_details <- vector(length = length(which_gp), mode = 'list')
for (i in seq_along(which_gp)) {
gp_details[[i]] <- eval(parse(
text = rownames(attr(tf, "factors"))[which_gp[i]]
))
}
}
# Check if any terms use the dynamic wrapper
response <- terms.formula(newformula)[[2]]
tf <- attr(terms.formula(newformula, keep.order = TRUE), 'term.labels')
which_dynamics <- grep('dynamic(', tf, fixed = TRUE)
# Update the formula to the correct Gaussian Process implementation
if (length(which_dynamics) != 0L) {
dyn_details <- vector(length = length(which_dynamics), mode = 'list')
if (length(which_dynamics > 1)) {
for (i in seq_along(which_dynamics)) {
dyn_details[[i]] <- eval(parse(text = tf[which_dynamics[i]]))
}
}
# k is set based on the number of timepoints available; want to ensure
# it is large enough to capture the expected wiggliness of the latent GP
# (a smaller rho will require more basis functions for accurate approximation)
dyn_to_gpspline = function(term, N) {
if (term$rho > N - 1) {
stop(
'Argument "rho" in dynamic() cannot be larger than (max(time) - 1)',
call. = FALSE
)
}
k <- term$k
if (is.null(k)) {
if (N > 8) {
k <- min(
50,
min(N, max(8, ceiling(N / (term$rho - (term$rho / 10)))))
)
} else {
k <- N
}
}
paste0(
"s(time,by=",
term$term,
",bs='gp',m=c(",
ifelse(term$stationary, '-', ''),
"2,",
term$rho,
",2),",
"k=",
k,
")"
)
}
dyn_to_gphilbert = function(term, N) {
k <- term$k
if (is.null(k)) {
if (N > 8) {
k <- min(40, min(N - 1, max(8, N - 1)))
} else {
k <- N - 1
}
}
paste0(
"gp(time,by=",
term$term,
",c=5/4,",
"k=",
k,
",scale=",
term$scale,
")"
)
}
# Replace dynamic terms with the correct specification
termlabs <- attr(terms(newformula, keep.order = TRUE), 'term.labels')
for (i in seq_along(which_dynamics)) {
if (is.null(dyn_details[[i]]$rho)) {
termlabs[which_dynamics[i]] <- dyn_to_gphilbert(dyn_details[[i]], N = N)
} else {
termlabs[which_dynamics[i]] <- dyn_to_gpspline(dyn_details[[i]], N = N)
}
}
# Return the updated formula for passing to mgcv
updated_formula <- reformulate(termlabs, rlang::f_lhs(newformula))
attr(updated_formula, '.Environment') <- attr(newformula, '.Environment')
} else {
updated_formula <- newformula
}
if (!keep_intercept) {
updated_formula <- update(updated_formula, . ~ . - 1)
attr(updated_formula, '.Environment') <- attr(newformula, '.Environment')
}
return(updated_formula)
}
================================================
FILE: R/irf.mvgam.R
================================================
#' Calculate latent VAR impulse response functions
#'
#' Compute Generalized or Orthogonalized Impulse Response Functions (IRFs) from
#' \code{mvgam} models with Vector Autoregressive dynamics
#'
#' @name irf.mvgam
#' @param object \code{list} object of class \code{mvgam} resulting from a call to [mvgam()]
#' that used a Vector Autoregressive latent process model (either as `VAR(cor = FALSE)` or
#' `VAR(cor = TRUE)`; see [VAR()] for details)
#' @param h Positive \code{integer} specifying the forecast horizon over which to calculate
#' the IRF
#' @param cumulative \code{Logical} flag indicating whether the IRF should be cumulative
#' @param orthogonal \code{Logical} flag indicating whether orthogonalized IRFs should be
#' calculated. Note that the order of the variables matters when calculating these
#' @param ... ignored
#' @details
#' See \code{\link{mvgam_irf-class}} for a full description of the quantities that are
#' computed and returned by this function, along with key references.
#' @return An object of \code{\link{mvgam_irf-class}} containing the posterior IRFs. This
#' object can be used with the supplied S3 functions [plot.mvgam_irf()]
#' and [summary.mvgam_irf()]
#' @author Nicholas J Clark
#' @seealso \code{\link{mvgam_irf-class}}, [VAR()], [plot.mvgam_irf()], [stability()], [fevd()]
#' @examples
#' \dontrun{
#' # Fit a model to the portal time series that uses a latent VAR(1)
#' mod <- mvgam(
#' formula = captures ~ -1,
#' trend_formula = ~ trend,
#' trend_model = VAR(cor = TRUE),
#' family = poisson(),
#' data = portal_data,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Plot the autoregressive coefficient distributions;
#' # use 'dir = "v"' to arrange the order of facets
#' # correctly
#' mcmc_plot(
#' mod,
#' variable = 'A',
#' regex = TRUE,
#' type = 'hist',
#' facet_args = list(dir = 'v')
#' )
#'
#' # Calulate Generalized IRFs for each series
#' irfs <- irf(
#' mod,
#' h = 12,
#' cumulative = FALSE
#' )
#'
#' # Plot them
#' plot(irfs, series = 1)
#' plot(irfs, series = 2)
#' plot(irfs, series = 3)
#' plot(irfs, series = 4)
#'
#' # Calculate posterior median, upper and lower 95th quantiles
#' # of the impulse responses
#' summary(irfs)
#' }
#' @export
irf <- function(object, ...) {
UseMethod("irf", object)
}
#' @rdname irf.mvgam
#' @method irf mvgam
#' @export
irf.mvgam <- function(
object,
h = 10,
cumulative = FALSE,
orthogonal = FALSE,
...
) {
validate_pos_integer(h)
trend_model <- attr(object$model_data, "trend_model")
if (!trend_model %in% c("VAR", "VARcor", "VAR1", "VAR1cor")) {
stop(
"Only VAR(1) models currently supported for calculating IRFs",
call. = FALSE
)
}
beta_vars <- mcmc_chains(object$model_output, "A")
sigmas <- mcmc_chains(object$model_output, "Sigma")
n_series <- object$n_lv
if (is.null(n_series)) {
n_series <- nlevels(object$obs_data$series)
}
all_irfs <- lapply(seq_len(NROW(beta_vars)), function(draw) {
# Get necessary VAR parameters into a simple list format
x <- list(
K = n_series,
A = matrix(
beta_vars[draw, ],
nrow = n_series,
ncol = n_series,
byrow = TRUE
),
Sigma = matrix(
sigmas[draw, ],
nrow = n_series,
ncol = n_series,
byrow = TRUE
),
p = 1
)
# Calculate the IRF
gen_irf(x, h = h, cumulative = cumulative, orthogonal = orthogonal)
})
class(all_irfs) <- "mvgam_irf"
attr(all_irfs, "irf_type") <- ifelse(
orthogonal,
"Orthogonalized",
"Generalized"
)
return(all_irfs)
}
#### Functions to compute Generalized Impulse Response functions
# Much of this code is modified from R code generously provided by Clinton Watkins:
# https://www.clintonwatkins.com/posts/2021-generalised-impulse-response-function-R/ ####
#' Calculate impulse response functions
#' @noRd
gen_irf <- function(x, h = 6, cumulative = TRUE, orthogonal = FALSE) {
impulse <- paste0("process_", 1:x$K)
# Create arrays to hold calculations
IRF_o <- array(
data = 0,
dim = c(h, x$K, x$K),
dimnames = list(NULL, impulse, impulse)
)
IRF_g <- array(
data = 0,
dim = c(h, x$K, x$K),
dimnames = list(NULL, impulse, impulse)
)
IRF_g1 <- array(data = 0, dim = c(h, x$K, x$K))
# Estimation of orthogonalised or generalised IRFs
if (orthogonal) {
var_ma <- var_psi(x, h)
} else {
var_ma <- var_phi(x, h)
}
sigma_u <- x$Sigma
P <- t(chol(sigma_u))
sig_jj <- diag(sigma_u)
for (jj in 1:x$K) {
indx_ <- matrix(0, x$K, 1)
indx_[jj, 1] <- 1
for (kk in 1:h) {
IRF_o[kk, , jj] <- var_ma[,, kk] %*% P %*% indx_ # Peseran-Shin eqn 7 (OIRF)
IRF_g1[kk, , jj] <- var_ma[,, kk] %*% sigma_u %*% indx_
IRF_g[kk, , jj] <- sig_jj[jj]^(-0.5) * IRF_g1[kk, , jj] # Peseran-Shin eqn 10 (GIRF)
}
}
if (orthogonal == TRUE) {
irf <- IRF_o
} else if (orthogonal == FALSE) {
irf <- IRF_g
} else {
stop("\nError! Orthogonalised or generalised IRF?\n")
}
idx <- length(impulse)
irs <- list()
for (ii in 1:idx) {
irs[[ii]] <- matrix(irf[1:(h), impulse, impulse[ii]], nrow = h)
colnames(irs[[ii]]) <- impulse
if (cumulative) {
if (length(impulse) > 1) {
irs[[ii]] <- apply(irs[[ii]], 2, cumsum)
}
if (length(impulse) == 1) {
tmp <- matrix(cumsum(irs[[ii]]))
colnames(tmp) <- impulse
irs[[ii]] <- tmp
}
}
}
names(irs) <- impulse
return(irs)
}
#' Convert a VAR A matrix to its moving average representation
#' @noRd
var_phi <- function(x, h = 10) {
h <- abs(as.integer(h))
K <- x$K
p <- x$p
A <- as.array(x$A)
if (h >= p) {
As <- array(0, dim = c(K, K, h + 1))
for (i in (p + 1):(h + 1)) {
As[,, i] <- matrix(0, nrow = K, ncol = K)
}
} else {
As <- array(0, dim = c(K, K, p))
}
As[,, 1] <- A
Phi <- array(0, dim = c(K, K, h + 1))
Phi[,, 1] <- diag(K)
Phi[,, 2] <- Phi[,, 1] %*% As[,, 1]
if (h > 1) {
for (i in 3:(h + 1)) {
tmp1 <- Phi[,, 1] %*% As[,, i - 1]
tmp2 <- matrix(0, nrow = K, ncol = K)
idx <- (i - 2):1
for (j in 1:(i - 2)) {
tmp2 <- tmp2 + Phi[,, j + 1] %*% As[,, idx[j]]
}
Phi[,, i] <- tmp1 + tmp2
}
}
return(Phi)
}
#' Convert a VAR A matrix to its orthogonalised moving average representation
#' @noRd
var_psi <- function(x, h = 10) {
h <- abs(as.integer(h))
Phi <- var_phi(x, h = h)
Psi <- array(0, dim = dim(Phi))
sigma_u <- x$Sigma
P <- t(chol(sigma_u))
dim3 <- dim(Phi)[3]
for (i in 1:dim3) {
Psi[,, i] <- Phi[,, i] %*% P
}
return(Psi)
}
================================================
FILE: R/jsdgam.R
================================================
#'Fit Joint Species Distribution Models in \pkg{mvgam}
#'
#'This function sets up a Joint Species Distribution Model whereby the residual
#'associations among species can be modelled in a reduced-rank format using a
#'set of latent factors. The factor specification is extremely flexible,
#'allowing users to include spatial, temporal or any other type of predictor
#'effects to more efficiently capture unmodelled residual associations, while
#'the observation model can also be highly flexible (including all smooth, GP
#'and other effects that \pkg{mvgam} can handle)
#'
#'@inheritParams mvgam
#'@inheritParams ZMVN
#'
#'@param formula A \code{formula} object specifying the GAM observation model
#' formula. These are exactly like the formula for a GLM except that smooth
#' terms, `s()`, `te()`, `ti()`, `t2()`, as well as time-varying `dynamic()`
#' terms, nonparametric `gp()` terms and offsets using `offset()`, can be
#' added to the right hand side to specify that the linear predictor depends
#' on smooth functions of predictors (or linear functionals of these).
#' Details of the formula syntax used by \pkg{mvgam} can be found in
#' \code{\link{mvgam_formulae}}
#'
#'@param factor_formula A \code{formula} object specifying the linear predictor
#' effects for the latent factors. Use `by = trend` within calls to functional
#' terms (i.e. `s()`, `te()`, `ti()`, `t2()`, `dynamic()`, or `gp()`) to
#' ensure that each factor captures a different axis of variation. See the
#' example below as an illustration
#'
#'@param factor_knots An optional \code{list} containing user specified knot
#' values to be used for basis construction of any smooth terms in
#' `factor_formula`. For most bases the user simply supplies the knots to be
#' used, which must match up with the `k` value supplied (note that the
#' number of knots is not always just `k`). Different terms can use different
#' numbers of knots, unless they share a covariate
#'
#'@param data A \code{dataframe} or \code{list} containing the model response
#' variable and covariates required by the GAM \code{formula} and
#' \code{factor_formula} objects
#'
#'@param family \code{family} specifying the observation family for the
#' outcomes. Currently supported families are:
#'\itemize{
#' \item`gaussian()` for real-valued data
#' \item`betar()` for proportional data on `(0,1)`
#' \item`lognormal()` for non-negative real-valued data
#' \item`student_t()` for real-valued data
#' \item`Gamma()` for non-negative real-valued data
#' \item`bernoulli()` for binary data
#' \item`poisson()` for count data
#' \item`nb()` for overdispersed count data
#' \item`binomial()` for count data with imperfect detection when the number
#' of trials is known; note that the `cbind()` function must be used to
#' bind the discrete observations and the discrete number of trials
#' \item`beta_binomial()` as for `binomial()` but allows for overdispersion}
#'Default is `poisson()`. See \code{\link{mvgam_families}} for more details
#'
#' @param species The unquoted name of the `factor` variable that indexes the
#' different response units in `data` (usually `'species'` in a JSDM).
#' Defaults to `series` to be consistent with other `mvgam` models
#'
#'@param n_lv \code{integer} the number of latent factors to use for modelling
#' residual associations. Cannot be `> n_species`. Defaults arbitrarily to `2`
#'
#'@param threads \code{integer} Experimental option to use multithreading for
#' within-chain parallelisation in \code{Stan}. We recommend its use only if
#' you are experienced with \code{Stan}'s `reduce_sum` function and have a
#' slow running model that cannot be sped up by any other means. Currently
#' works for all families when using \pkg{cmdstanr} as the backend
#'
#'@param priors An optional \code{data.frame} with prior definitions (in Stan
#' syntax) or, preferentially, a vector containing objects of class
#' `brmsprior` (see. \code{\link[brms]{prior}} for details). See
#' [get_mvgam_priors] and for more information on changing default prior
#' distributions
#'
#'@param ... Other arguments to pass to [mvgam]
#'
#'@author Nicholas J Clark
#'
#'@details Joint Species Distribution Models allow for responses of multiple
#'species to be learned hierarchically, whereby responses to environmental
#'variables in `formula` can be partially pooled and any latent, unmodelled
#'residual associations can also be learned. In \pkg{mvgam}, both of these
#'effects can be modelled with the full power of latent factor Hierarchical
#'GAMs, providing unmatched flexibility to model full communities of species.
#'When calling [jsdgam], an initial State-Space model using `trend = 'None'` is
#'set up and then modified to include the latent factors and their linear
#'predictors. Consequently, you can inspect priors for these models using
#'[get_mvgam_priors] by supplying the relevant `formula`, `factor_formula`,
#'`data` and `family` arguments and keeping the default `trend = 'None'`.
#'
#' In a JSDGAM, the expectation of response \eqn{Y_{ij}} is modelled with
#'
#' \deqn{g(\mu_{ij}) = X_i\beta + u_i\theta_j,}
#'
#' where \eqn{g(.)} is a known link function,
#' \eqn{X} is a design matrix of linear predictors (with associated \eqn{\beta}
#' coefficients), \eqn{u} are \eqn{n_{lv}}-variate latent factors
#' (\eqn{n_{lv}}<<\eqn{n_{species}}) and \eqn{\theta_j} are species-specific
#' loadings on the latent factors, respectively. The design matrix \eqn{X} and
#' \eqn{\beta} coefficients are constructed and modelled using `formula` and
#' can contain any of `mvgam`'s predictor effects, including random intercepts
#' and slopes, multidimensional penalized smooths, GP effects etc... The factor
#' loadings \eqn{\theta_j} are constrained for identifiability but can be used
#' to reconstruct an estimate of the species' residual variance-covariance
#' matrix using \eqn{\Theta \Theta'} (see the example below and
#' [residual_cor()] for details). The latent factors are further modelled using:
#'\deqn{
#'u_i \sim \text{Normal}(Q_i\beta_{factor}, 1)
#'}
#'where the second design matrix \eqn{Q} and associated \eqn{\beta_{factor}}
#'coefficients are constructed and modelled using `factor_formula`. Again, the
#'effects that make up this linear predictor can contain any of `mvgam`'s
#'allowed predictor effects, providing enormous flexibility for modelling
#'species' communities.
#'
#'@seealso [mvgam()], [residual_cor()]
#'
#'@references Nicholas J Clark & Konstans Wells (2023). Dynamic generalised
#'additive models (DGAMs) for forecasting discrete ecological time series.
#'Methods in Ecology and Evolution. 14:3, 771-784.
#' \cr
#' \cr
#'David I Warton, F Guillaume Blanchet, Robert B O'Hara, Otso Ovaskainen, Sara
#'Taskinen, Steven C Walker & Francis KC Hui (2015). So many variables: joint
#'modeling in community ecology. Trends in Ecology & Evolution 30:12, 766-779.
#'
#'@return A \code{list} object of class \code{mvgam} containing model output,
#'the text representation of the model file, the mgcv model output (for easily
#'generating simulations at unsampled covariate values), Dunn-Smyth residuals
#'for each species and key information needed for other functions in the
#'package. See \code{\link{mvgam-class}} for details. Use
#'`methods(class = "mvgam")` for an overview on available methods
#'
#'@examples
#'\dontrun{
#' # ========================================================================
#' # Example 1: Basic JSDGAM with Portal Data
#' # ========================================================================
#'
#' # Fit a JSDGAM to the portal_data captures
#' mod <- jsdgam(
#' formula = captures ~
#' # Fixed effects of NDVI and mintemp, row effect as a GP of time
#' ndvi_ma12:series + mintemp:series + gp(time, k = 15),
#' factor_formula = ~ -1,
#' data = portal_data,
#' unit = time,
#' species = series,
#' family = poisson(),
#' n_lv = 2,
#' silent = 2,
#' chains = 2
#' )
#'
#' # Plot covariate effects
#' library(ggplot2); theme_set(theme_bw())
#' plot_predictions(
#' mod,
#' condition = c('ndvi_ma12', 'series', 'series')
#' )
#'
#' plot_predictions(
#' mod,
#' condition = c('mintemp', 'series', 'series')
#' )
#'
#' # A residual correlation plot
#' plot(residual_cor(mod))
#'
#' # An ordination biplot can also be constructed
#' # from the factor scores and their loadings
#' if(requireNamespace('ggrepel', quietly = TRUE)){
#' ordinate(mod, alpha = 0.7)
#' }
#'
#' # ========================================================================
#' # Example 2: Advanced JSDGAM with Spatial Predictors
#' # ========================================================================
#'
#' # Simulate latent count data for 500 spatial locations and 10 species
#' set.seed(0)
#' N_points <- 500
#' N_species <- 10
#'
#' # Species-level intercepts (on the log scale)
#' alphas <- runif(N_species, 2, 2.25)
#'
#' # Simulate a covariate and species-level responses to it
#' temperature <- rnorm(N_points)
#' betas <- runif(N_species, -0.5, 0.5)
#'
#' # Simulate points uniformly over a space
#' lon <- runif(N_points, min = 150, max = 155)
#' lat <- runif(N_points, min = -20, max = -19)
#'
#' # Set up spatial basis functions as a tensor product of lat and lon
#' sm <- mgcv::smoothCon(
#' mgcv::te(lon, lat, k = 5),
#' data = data.frame(lon, lat),
#' knots = NULL
#' )[[1]]
#'
#' # The design matrix for this smooth is in the 'X' slot
#' des_mat <- sm$X
#' dim(des_mat)
#'
#' # Function to generate a random covariance matrix where all variables
#' # have unit variance (i.e. diagonals are all 1)
#' random_Sigma = function(N){
#' L_Omega <- matrix(0, N, N);
#' L_Omega[1, 1] <- 1;
#' for (i in 2 : N) {
#' bound <- 1;
#' for (j in 1 : (i - 1)) {
#' L_Omega[i, j] <- runif(1, -sqrt(bound), sqrt(bound));
#' bound <- bound - L_Omega[i, j] ^ 2;
#' }
#' L_Omega[i, i] <- sqrt(bound);
#' }
#' Sigma <- L_Omega %*% t(L_Omega);
#' return(Sigma)
#' }
#'
#' # Simulate a variance-covariance matrix for the correlations among
#' # basis coefficients
#' Sigma <- random_Sigma(N = NCOL(des_mat))
#'
#' # Now simulate the species-level basis coefficients hierarchically, where
#' # spatial basis function correlations are a convex sum of a base correlation
#' # matrix and a species-level correlation matrix
#' basis_coefs <- matrix(NA, nrow = N_species, ncol = NCOL(Sigma))
#' base_field <- mgcv::rmvn(1, mu = rep(0, NCOL(Sigma)), V = Sigma)
#' for(t in 1:N_species){
#' corOmega <- (cov2cor(Sigma) * 0.7) +
#' (0.3 * cov2cor(random_Sigma(N = NCOL(des_mat))))
#' basis_coefs[t, ] <- mgcv::rmvn(1, mu = rep(0, NCOL(Sigma)), V = corOmega)
#' }
#'
#' # Simulate the latent spatial processes
#' st_process <- do.call(rbind, lapply(seq_len(N_species), function(t){
#' data.frame(
#' lat = lat,
#' lon = lon,
#' species = paste0('species_', t),
#' temperature = temperature,
#' process = alphas[t] +
#' betas[t] * temperature +
#' des_mat %*% basis_coefs[t,]
#' )
#' }))
#'
#' # Now take noisy observations at some of the points (60)
#' obs_points <- sample(1:N_points, size = 60, replace = FALSE)
#' obs_points <- data.frame(
#' lat = lat[obs_points],
#' lon = lon[obs_points],
#' site = 1:60
#' )
#'
#' # Keep only the process data at these points
#' st_process %>%
#' dplyr::inner_join(obs_points, by = c('lat', 'lon')) %>%
#' # now take noisy Poisson observations of the process
#' dplyr::mutate(count = rpois(NROW(.), lambda = exp(process))) %>%
#' dplyr::mutate(species = factor(
#' species,
#' levels = paste0('species_', 1:N_species)
#' )) %>%
#' dplyr::group_by(lat, lon) -> dat
#'
#' # View the count distributions for each species
#' ggplot(dat, aes(x = count)) +
#' geom_histogram() +
#' facet_wrap(~ species, scales = 'free')
#'
#' ggplot(dat, aes(x = lon, y = lat, col = log(count + 1))) +
#' geom_point(size = 2.25) +
#' facet_wrap(~ species, scales = 'free') +
#' scale_color_viridis_c()
#'
#' # ------------------------------------------------------------------------
#' # Model Fitting with Custom Priors
#' # ------------------------------------------------------------------------
#'
#' # Inspect default priors for a joint species model with three spatial factors
#' priors <- get_mvgam_priors(
#' formula = count ~
#' # Environmental model includes random slopes for
#' # a linear effect of temperature
#' s(species, bs = 're', by = temperature),
#'
#' # Each factor estimates a different nonlinear spatial process, using
#' # 'by = trend' as in other mvgam State-Space models
#' factor_formula = ~ gp(lon, lat, k = 6, by = trend) - 1,
#' n_lv = 3,
#'
#' # The data and grouping variables
#' data = dat,
#' unit = site,
#' species = species,
#'
#' # Poisson observations
#' family = poisson()
#' )
#' head(priors)
#'
#' # Fit a JSDM that estimates hierarchical temperature responses
#' # and that uses three latent spatial factors
#' mod <- jsdgam(
#' formula = count ~
#' # Environmental model includes random slopes for a
#' # linear effect of temperature
#' s(species, bs = 're', by = temperature),
#'
#' # Each factor estimates a different nonlinear spatial process, using
#' # 'by = trend' as in other mvgam State-Space models
#' factor_formula = ~ gp(lon, lat, k = 6, by = trend) - 1,
#' n_lv = 3,
#'
#' # Change default priors for fixed random effect variances and
#' # factor GP marginal deviations to standard normal
#' priors = c(
#' prior(std_normal(), class = sigma_raw),
#' prior(std_normal(), class = `alpha_gp_trend(lon, lat):trendtrend1`),
#' prior(std_normal(), class = `alpha_gp_trend(lon, lat):trendtrend2`),
#' prior(std_normal(), class = `alpha_gp_trend(lon, lat):trendtrend3`)
#' ),
#'
#' # The data and the grouping variables
#' data = dat,
#' unit = site,
#' species = species,
#'
#' # Poisson observations
#' family = poisson(),
#' chains = 2,
#' silent = 2
#' )
#'
#' # ------------------------------------------------------------------------
#' # Model Visualization and Diagnostics
#' # ------------------------------------------------------------------------
#'
#' # Plot the implicit species-level intercept estimates
#' plot_predictions(mod, condition = 'species', type = 'link')
#'
#' # Plot species' hierarchical responses to temperature
#' plot_predictions(
#' mod,
#' condition = c('temperature', 'species', 'species'),
#' type = 'link'
#' )
#'
#' # Plot posterior median estimates of the latent spatial factors
#' plot(mod, type = 'smooths', trend_effects = TRUE)
#'
#' # Or using gratia, if you have it installed
#' if(requireNamespace('gratia', quietly = TRUE)){
#' gratia::draw(mod, trend_effects = TRUE, dist = 0)
#' }
#'
#' # Plot species' randomized quantile residual distributions
#' # as a function of latitude
#' pp_check(
#' mod,
#' type = 'resid_ribbon_grouped',
#' group = 'species',
#' x = 'lat',
#' ndraws = 200
#' )
#'
#' # ------------------------------------------------------------------------
#' # Residual Correlation Analysis
#' # ------------------------------------------------------------------------
#'
#' # Calculate residual spatial correlations
#' post_cors <- residual_cor(mod)
#' names(post_cors)
#'
#' # Look at lower and upper credible interval estimates for
#' # some of the estimated correlations
#' post_cors$cor[1:5, 1:5]
#' post_cors$cor_upper[1:5, 1:5]
#' post_cors$cor_lower[1:5, 1:5]
#'
#' # Plot of the posterior median correlations for those estimated
#' # to be non-zero
#' plot(post_cors, cluster = TRUE)
#'
#' # An ordination biplot can also be constructed
#' # from the factor scores and their loadings
#' if(requireNamespace('ggrepel', quietly = TRUE)){
#' ordinate(mod)
#' }
#'
#' # ------------------------------------------------------------------------
#' # Model Validation and Prediction
#' # ------------------------------------------------------------------------
#'
#' # Posterior predictive checks and ELPD-LOO can ascertain model fit
#' pp_check(
#' mod,
#' type = "pit_ecdf_grouped",
#' group = "species",
#' ndraws = 200
#' )
#' loo(mod)
#'
#' # Forecast log(counts) for entire region (site value doesn't matter as long
#' # as each spatial location has a different and unique site identifier);
#' # note this calculation takes a few minutes because of the need to calculate
#' # draws from the stochastic latent factors
#' newdata <- st_process %>%
#' dplyr::mutate(species = factor(
#' species,
#' levels = paste0('species_', 1:N_species)
#' )) %>%
#' dplyr::group_by(lat, lon) %>%
#' dplyr::mutate(site = dplyr::cur_group_id()) %>%
#' dplyr::ungroup()
#' preds <- predict(mod, newdata = newdata)
#'
#' # Plot the median log(count) predictions on a grid
#' newdata$log_count <- preds[,1]
#' ggplot(newdata, aes(x = lon, y = lat, col = log_count)) +
#' geom_point(size = 1.5) +
#' facet_wrap(~ species, scales = 'free') +
#' scale_color_viridis_c() +
#' theme_classic()
#'
#' # Not needed for general use; cleans up connections for automated testing
#' closeAllConnections()
#' }
#'@export
jsdgam = function(
formula,
factor_formula = ~ -1,
knots,
factor_knots,
data,
newdata,
family = poisson(),
unit = time,
species = series,
share_obs_params = FALSE,
priors,
n_lv = 2,
backend = getOption("brms.backend", "cmdstanr"),
algorithm = getOption("brms.algorithm", "sampling"),
control = list(max_treedepth = 10, adapt_delta = 0.8),
chains = 4,
burnin = 500,
samples = 500,
thin = 1,
parallel = TRUE,
threads = 1,
silent = 1,
run_model = TRUE,
return_model_data = FALSE,
residuals = TRUE,
...
) {
#### Validate arguments and initialise the model skeleton ####
validate_pos_integer(n_lv)
# Prep the trend so that the data can be structured in the usual
# mvgam fashion (with 'time' and 'series' variables)
unit <- deparse0(substitute(unit))
subgr <- deparse0(substitute(species))
prepped_trend <- prep_jsdgam_trend(unit = unit, subgr = subgr, data = data)
data_train <- validate_series_time(data = data, trend_model = prepped_trend)
# Set up a simple trend_map to get the model dimensions correct;
# this requires that we only have n_lv trends and that each series
# only maps to one distinct trend, resulting in a loading matrix of
# the correct size (n_series x n_lv)
trend_map <- prep_jsdgam_trendmap(data_train, n_lv)
# Set up the model structure but leave autoformat off so that the
# model file can be easily modified
mod <- suppressWarnings(mvgam(
formula = formula,
trend_formula = factor_formula,
knots = knots,
trend_knots = factor_knots,
family = family,
share_obs_params = share_obs_params,
priors = priors,
trend_model = 'None',
trend_map = trend_map,
data = data_train,
noncentred = TRUE,
run_model = FALSE,
autoformat = FALSE,
backend = backend,
...
))
model_file <- mod$model_file
#### Modify model data and model file ####
# Remove Z from supplied data
model_file <- model_file[
-grep(
"matrix[n_series, n_lv] Z; // matrix mapping series to latent states",
model_file,
fixed = TRUE
)
]
# Add M to data block
model_file[grep(
'int n_lv; // number of dynamic factors',
model_file,
fixed = TRUE
)] <- paste0(
'int n_lv; // number of dynamic factors\n',
'int M; // number of nonzero lower-triangular factor loadings'
)
model_file <- readLines(textConnection(model_file), n = -1)
# Update parameters
model_file <- model_file[
-grep("// latent state SD terms", model_file, fixed = TRUE)
]
model_file <- model_file[
-grep("vector[n_lv] sigma;", model_file, fixed = TRUE)
]
model_file[grep(
"matrix[n, n_lv] LV_raw;",
model_file,
fixed = TRUE
)] <- paste0(
"matrix[n, n_lv] LV_raw;\n\n",
"// factor lower triangle loadings\n",
"vector[M] L_lower;\n",
"// factor diagonal loadings\n",
"vector[n_lv] L_diag;"
)
model_file <- readLines(textConnection(model_file), n = -1)
# Update transformed parameters
model_file <- model_file[-grep("// latent states", model_file, fixed = TRUE)]
model_file <- model_file[-grep("lv_coefs = Z;", model_file, fixed = TRUE)]
model_file <- model_file[
-grep("matrix[n, n_lv] LV;", model_file, fixed = TRUE)
]
model_file <- model_file[
-grep("trend_mus = X_trend * b_trend;", model_file, fixed = TRUE)
]
model_file[grep(
"matrix[n_series, n_lv] lv_coefs;",
model_file,
fixed = TRUE
)] <- paste0(
"matrix[n_series, n_lv] lv_coefs = rep_matrix(0, n_series, n_lv);\n",
'matrix[n, n_lv] LV;\n'
)
starts <- grep(
"LV = LV_raw .* rep_matrix(sigma', rows(LV_raw));",
model_file,
fixed = TRUE
)
ends <- starts + 5
model_file <- model_file[-(starts:ends)]
# Simplified latent variable creation if no terms in factor_formula
if (
is.null(rownames(attr(terms.formula(factor_formula), 'factors'))) &
is.null(colnames(attr(terms.formula(factor_formula), 'factors')))
) {
model_file[grep(
"// latent process linear predictors",
model_file,
fixed = TRUE
)] <- paste0(
"// latent process linear predictors\n",
"trend_mus = X_trend * b_trend;\n\n",
"// constraints allow identifiability of loadings\n",
"{\n",
"int idx;\n",
"idx = 0;\n",
"for(j in 1 : n_lv) lv_coefs[j, j] = L_diag[j];\n",
"for(j in 1 : n_lv) {\n",
"for(k in (j + 1) : n_series) {\n",
"idx = idx + 1;\n",
"lv_coefs[k, j] = L_lower[idx];\n",
"}\n",
"}\n",
"}\n\n",
"// raw latent factors\n",
"LV = LV_raw;\n"
)
} else {
model_file[grep(
"// latent process linear predictors",
model_file,
fixed = TRUE
)] <- paste0(
"// latent process linear predictors\n",
"trend_mus = X_trend * b_trend;\n\n",
"// constraints allow identifiability of loadings\n",
"{\n",
"int idx;\n",
"idx = 0;\n",
"for(j in 1 : n_lv) lv_coefs[j, j] = L_diag[j];\n",
"for(j in 1 : n_lv) {\n",
"for(k in (j + 1) : n_series) {\n",
"idx = idx + 1;\n",
"lv_coefs[k, j] = L_lower[idx];\n",
"}\n",
"}\n",
"}\n\n",
"// raw latent factors (with linear predictors)\n",
"for (j in 1 : n_lv) {\n",
"for (i in 1 : n) {\n",
"LV[i, j] = trend_mus[ytimes_trend[i, j]] + LV_raw[i, j];\n",
"}\n}\n"
)
}
model_file <- model_file[
-grep("// derived latent states", model_file, fixed = TRUE)
]
model_file <- readLines(textConnection(model_file), n = -1)
# Update model block
sigma_prior <- grep(
"// priors for latent state SD parameters",
model_file,
fixed = TRUE
) +
1
model_file <- model_file[-sigma_prior]
# Use standard normal for loadings in most models, apart from
# those using identify link
if (family_links(mod$family) != 'identity') {
model_file[grep(
"// priors for latent state SD parameters",
model_file,
fixed = TRUE
)] <- paste0(
"// priors for factors and loading coefficients\n",
"L_lower ~ std_normal();\n",
"L_diag ~ std_normal();"
)
model_file <- readLines(textConnection(model_file), n = -1)
} else {
model_file[grep(
"// priors for latent state SD parameters",
model_file,
fixed = TRUE
)] <- paste0(
"// priors for factors and loading coefficients\n",
"L_lower ~ student_t(3, 0, 1);\n",
"L_diag ~ student_t(3, 0, 1);"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
# Update generated quantities
model_file[grep(
'matrix[n, n_series] mus;',
model_file,
fixed = TRUE
)] <- paste0(
'matrix[n, n_series] mus;\n',
'vector[n_lv] sigma;'
)
model_file[grep(
"penalty = 1.0 / (sigma .* sigma);",
model_file,
fixed = TRUE
)] <- paste0(
"penalty = rep_vector(1.0, n_lv);\n",
"sigma = rep_vector(1.0, n_lv);"
)
model_file <- readLines(textConnection(model_file), n = -1)
model_file <- sanitise_modelfile(model_file)
# Remove Z from model_data as it is no longer needed
model_data <- mod$model_data
model_data$Z <- NULL
# Add M to model_data
n_series <- NCOL(model_data$ytimes)
model_data$M <- n_lv * (n_series - n_lv) + n_lv * (n_lv - 1) / 2
#### Autoformat the Stan code ####
if (requireNamespace('cmdstanr', quietly = TRUE) & backend == 'cmdstanr') {
if (
requireNamespace('cmdstanr') &
cmdstanr::cmdstan_version() >= "2.29.0"
) {
model_file <- .autoformat(
model_file,
overwrite_file = FALSE,
backend = 'cmdstanr',
silent = silent >= 1L
)
}
model_file <- readLines(textConnection(model_file), n = -1)
} else {
model_file <- .autoformat(
model_file,
overwrite_file = FALSE,
backend = 'rstan',
silent = silent >= 1L
)
model_file <- readLines(textConnection(model_file), n = -1)
}
# Remove lp__ from monitor params if VB is to be used
param <- unique(c(mod$monitor_pars, 'Sigma', 'LV'))
if (algorithm %in% c('meanfield', 'fullrank', 'pathfinder', 'laplace')) {
param <- param[!param %in% 'lp__']
}
#### Determine what to return ####
if (!run_model) {
mod$model_file <- model_file
mod$monitor_pars <- param
attr(model_data, 'trend_model') <- 'None'
attr(model_data, 'prepped_trend_model') <- prepped_trend
attr(model_data, 'noncentred') <- NULL
attr(model_data, 'threads') <- threads
mod$model_data <- model_data
out <- mod
} else {
# Check if cmdstan is accessible; if not, use rstan
if (backend == 'cmdstanr') {
if (!requireNamespace('cmdstanr', quietly = TRUE)) {
if (silent < 2) {
message('cmdstanr library not found; defaulting to rstan')
}
use_cmdstan <- FALSE
} else {
use_cmdstan <- TRUE
if (is.null(cmdstanr::cmdstan_version(error_on_NA = FALSE))) {
warning(
'cmdstanr library found but Cmdstan not found. Defaulting to rstan'
)
use_cmdstan <- FALSE
}
}
}
#### Run the model ####
if (use_cmdstan) {
# Prepare threading and generate the model
cmd_mod <- .model_cmdstanr(model_file, threads = threads, silent = silent)
# Condition the model using Cmdstan
out_gam_mod <- .sample_model_cmdstanr(
model = cmd_mod,
algorithm = algorithm,
prior_simulation = FALSE,
data = model_data,
chains = chains,
parallel = parallel,
silent = silent,
max_treedepth = control$max_treedepth,
adapt_delta = control$adapt_delta,
threads = threads,
burnin = burnin,
samples = samples,
param = param,
save_all_pars = FALSE,
...
)
} else {
# Condition the model using rstan
requireNamespace('rstan', quietly = TRUE)
out_gam_mod <- .sample_model_rstan(
model = model_file,
algorithm = algorithm,
prior_simulation = FALSE,
data = model_data,
chains = chains,
parallel = parallel,
silent = silent,
max_treedepth = control$max_treedepth,
adapt_delta = control$adapt_delta,
threads = threads,
burnin = burnin,
samples = samples,
thin = thin,
...
)
}
# After modeling (add a new class to make predictions and other post-processing
# simpler)
out1 <- mod
out1$model_output <- out_gam_mod
class(out1) <- c('mvgam')
if (residuals) {
mod_residuals <- dsresids_vec(out1)
} else {
mod_residuals <- NULL
}
rm(out1)
# Add the posterior median coefficients to the mgcv objects
ss_gam <- mod$mgcv_model
V <- cov(mcmc_chains(out_gam_mod, 'b'))
ss_gam$Vp <- ss_gam$Vc <- V
p <- mcmc_summary(
out_gam_mod,
'b',
variational = algorithm %in%
c('meanfield', 'fullrank', 'pathfinder', 'laplace')
)[, c(4)]
names(p) <- names(ss_gam$coefficients)
ss_gam$coefficients <- p
trend_mgcv_model <- mod$trend_mgcv_model
V <- cov(mcmc_chains(out_gam_mod, 'b_trend'))
trend_mgcv_model$Vp <- trend_mgcv_model$Vc <- V
p <- mcmc_summary(
out_gam_mod,
'b_trend',
variational = algorithm %in%
c('meanfield', 'fullrank', 'pathfinder', 'laplace')
)[, c(4)]
names(p) <- names(trend_mgcv_model$coefficients)
trend_mgcv_model$coefficients <- p
#### Return the output as class mvgam ####
trim_data <- list()
attr(trim_data, 'threads') <- threads
attr(trim_data, 'noncentred') <- NULL
attr(trim_data, 'trend_model') <- 'None'
attr(trim_data, 'prepped_trend_model') <- prepped_trend
# Extract sampler arguments
dots <- list(...)
if ('adapt_delta' %in% names(dots)) {
message(
'argument "adapt_delta" should be supplied as an element in "control"'
)
adapt_delta <- dots$adapt_delta
dots$adapt_delta <- NULL
} else {
adapt_delta <- control$adapt_delta
if (is.null(adapt_delta)) adapt_delta <- 0.8
}
if ('max_treedepth' %in% names(dots)) {
message(
'argument "max_treedepth" should be supplied as an element in "control"'
)
max_treedepth <- dots$max_treedepth
dots$max_treedepth <- NULL
} else {
max_treedepth <- control$max_treedepth
if (is.null(max_treedepth)) max_treedepth <- 10
}
out <- structure(
list(
call = mod$call,
trend_call = factor_formula,
family = mod$family,
share_obs_params = mod$share_obs_params,
trend_model = 'None',
trend_map = trend_map,
drift = FALSE,
priors = mod$priors,
model_output = out_gam_mod,
model_file = model_file,
model_data = if (return_model_data) {
model_data
} else {
trim_data
},
inits = NULL,
monitor_pars = param,
sp_names = mod$sp_names,
trend_sp_names = mod$trend_sp_names,
mgcv_model = ss_gam,
trend_mgcv_model = trend_mgcv_model,
ytimes = mod$ytimes,
resids = mod_residuals,
use_lv = TRUE,
n_lv = n_lv,
upper_bounds = mod$upper_bounds,
obs_data = mod$obs_data,
test_data = mod$test_data,
fit_engine = 'stan',
backend = backend,
algorithm = algorithm,
max_treedepth = max_treedepth,
adapt_delta = adapt_delta
),
class = c('mvgam', 'jsdgam')
)
}
return(out)
}
#' Prep trend for jsdgam
#' @noRd
prep_jsdgam_trend = function(data, unit, subgr) {
unit <- as_one_character(unit)
subgr <- as_one_character(subgr)
validate_var_exists(
data = data,
variable = unit,
type = 'num/int',
name = 'data',
trend_char = 'ZMVN'
)
validate_var_exists(
data = data,
variable = subgr,
type = 'factor',
name = 'data',
trend_char = 'ZMVN'
)
out <- structure(
list(
trend_model = 'ZMVN',
ma = FALSE,
cor = TRUE,
unit = unit,
gr = "NA",
subgr = subgr,
label = NULL
),
class = 'mvgam_trend'
)
}
#' @noRd
prep_jsdgam_trendmap = function(data, n_lv) {
if (n_lv > nlevels(data$series)) {
stop(
'Number of factors must be <= number of levels in species',
call. = FALSE
)
}
data.frame(
trend = rep(1:n_lv, nlevels(data$series))[1:nlevels(data$series)],
series = factor(levels(data$series), levels = levels(data$series))
)
}
================================================
FILE: R/lfo_cv.mvgam.R
================================================
#'@title Approximate leave-future-out cross-validation of fitted \pkg{mvgam} objects
#'@name lfo_cv.mvgam
#'@importFrom stats update logLik
#'@param object \code{list} object of class \code{mvgam}. See [mvgam()]
#'@param data A \code{dataframe} or \code{list} containing the model response variable and covariates
#'required by the GAM \code{formula}. Should include columns:
#''series' (character or factor index of the series IDs)
#''time' (numeric index of the time point for each observation).
#'Any other variables to be included in the linear predictor of \code{formula} must also be present
#'@param min_t Integer specifying the minimum training time required before making predictions
#'from the data. Default is either the `30`th timepoint in the observational data,
#'or whatever training time allows for at least
#'`10` lfo-cv calculations, if possible.
#'This value is essentially arbitrary so it is highly recommended to change it
#'to something that is more suitable to the
#'data and models being evaluated.
#'@param fc_horizon Integer specifying the number of time steps ahead for evaluating forecasts
#'@param pareto_k_threshold Proportion specifying the threshold over which the Pareto shape parameter
#'is considered unstable, triggering a model refit. Default is `0.7`
#'@param silent Verbosity level between `0` and `2`. If `1` (the default), most of the informational
#'messages of compiler and sampler are suppressed. If `2`, even more messages are suppressed. The
#'actual sampling progress is still printed. Set `refresh = 0` to turn this off as well. If using
#'`backend = "rstan"` you can also set open_progress = FALSE to prevent opening additional
#'progress bars.
#'@param ... Ignored
#'@details Approximate leave-future-out cross-validation uses an expanding training window scheme
#' to evaluate a model on its forecasting ability. The steps used in this function mirror those laid out
#' in the [lfo vignette from the `loo` package](https://mc-stan.org/loo/articles/loo2-lfo.html),
#' written by Paul Bürkner, Jonah Gabry, Aki Vehtari. First, we refit the model using the first `min_t`
#' observations to perform a single exact `fc_horizon`-ahead forecast step. This forecast is evaluated against
#' the `min_t + fc_horizon` out of sample observations using the Expected Log Predictive Density (ELPD).
#' Next, we approximate each successive round of
#' expanding window forecasts by moving forward one step at a time `for i in 1:N_evaluations` and re-weighting
#' draws from the model's posterior predictive distribution using Pareto Smoothed
#' Importance Sampling (PSIS). In each iteration `i`, PSIS weights are obtained for the next observation
#' that would have been included in the model if we had re-fit (i.e. the last observation that would have
#' been in the training data, or `min_t + i`). If these importance ratios are stable, we consider the
#' approximation adequate and use the re-weighted posterior's forecast for evaluating the next holdout
#' set of testing observations (`(min_t + i + 1):(min_t + i + fc_horizon)`). At some point the
#' importance ratio variability will become too large and importance sampling will fail. This is
#' indicated by the estimated shape parameter `k` of the generalized Pareto distribution
#' crossing a certain threshold `pareto_k_threshold`. Only then do we refit the model using
#' all of the observations up to the time of the failure. We then restart the process and iterate forward
#' until the next refit is triggered (Bürkner et al. 2020).
#'@return A `list` of class `mvgam_lfo` containing the approximate ELPD scores,
#'the Pareto-k shape values and 'the specified `pareto_k_threshold`
#'@seealso \code{\link{forecast}}, \code{\link{score}}, \code{\link{compare_mvgams}}
#'@references Paul-Christian Bürkner, Jonah Gabry & Aki Vehtari (2020). Approximate leave-future-out cross-validation for Bayesian time series models
#'Journal of Statistical Computation and Simulation. 90:14, 2499-2523.
#'@examples
#'\dontrun{
#'# Simulate from a Poisson-AR2 model with a seasonal smooth
#'set.seed(100)
#'dat <- sim_mvgam(T = 75,
#' n_series = 1,
#' prop_trend = 0.75,
#' trend_model = 'AR2',
#' family = poisson())
#'
#'# Plot the time series
#'plot_mvgam_series(data = dat$data_train,
#' newdata = dat$data_test,
#' series = 1)
#'
#'# Fit an appropriate model
#'mod_ar2 <- mvgam(y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(p = 2),
#' family = poisson(),
#' data = dat$data_train,
#' newdata = dat$data_test,
#' chains = 2,
#' silent = 2)
#'
#'# Fit a less appropriate model
#'mod_rw <- mvgam(y ~ s(season, bs = 'cc', k = 6),
#' trend_model = RW(),
#' family = poisson(),
#' data = dat$data_train,
#' newdata = dat$data_test,
#' chains = 2,
#' silent = 2)
#'
#'# Compare Discrete Ranked Probability Scores for the testing period
#'fc_ar2 <- forecast(mod_ar2)
#'fc_rw <- forecast(mod_rw)
#'score_ar2 <- score(fc_ar2, score = 'drps')
#'score_rw <- score(fc_rw, score = 'drps')
#'sum(score_ar2$series_1$score)
#'sum(score_rw$series_1$score)
#'
#'# Now use approximate leave-future-out CV to compare
#'# rolling forecasts; start at time point 40 to reduce
#'# computational time and to ensure enough data is available
#'# for estimating model parameters
#'lfo_ar2 <- lfo_cv(mod_ar2,
#' min_t = 40,
#' fc_horizon = 3,
#' silent = 2)
#'lfo_rw <- lfo_cv(mod_rw,
#' min_t = 40,
#' fc_horizon = 3,
#' silent = 2)
#'
#'# Plot Pareto-K values and ELPD estimates
#'plot(lfo_ar2)
#'plot(lfo_rw)
#'
#'# Proportion of timepoints in which AR2 model gives better forecasts
#'length(which((lfo_ar2$elpds - lfo_rw$elpds) > 0)) /
#' length(lfo_ar2$elpds)
#'
#'# A higher total ELPD is preferred
#'lfo_ar2$sum_ELPD
#'lfo_rw$sum_ELPD
#'}
#'@author Nicholas J Clark
#'@export
lfo_cv <- function(object, ...) {
UseMethod("lfo_cv", object)
}
#'@rdname lfo_cv.mvgam
#'@method lfo_cv mvgam
#'@export
lfo_cv.mvgam = function(
object,
data,
min_t,
fc_horizon = 1,
pareto_k_threshold = 0.7,
silent = 1,
...
) {
validate_proportional(pareto_k_threshold)
validate_pos_integer(fc_horizon)
if (missing(data)) {
all_data <- object$obs_data
} else {
all_data <- validate_series_time(
data,
name = 'data',
trend_model = object$trend_model
)
}
N <- max(all_data$index..time..index)
all_unique_times <- sort(unique(all_data$index..time..index))
# Default minimum training time is the 30th timepoint, or
# whatever training time allows for at least 10 lfo_cv calculations
if (missing(min_t)) {
if (length(all_unique_times) > 30) {
min_t <- pmin(max(1, N - 10 - fc_horizon), all_unique_times[30])
} else if (length(all_unique_times) < 30 & length(all_unique_times) > 20) {
min_t <- pmin(max(1, N - 10 - fc_horizon), all_unique_times[20])
} else if (length(all_unique_times) < 20 & length(all_unique_times) > 10) {
min_t <- pmin(max(1, N - 10 - fc_horizon), all_unique_times[10])
} else {
min_t <- 1
}
}
if (min_t < 0) {
min_t <- 1
}
validate_pos_integer(min_t)
if (min_t >= N) {
stop('Argument "min_t" is >= the maximum training time', call. = FALSE)
}
# Store the Expected Log Predictive Density (EPLD) at each time point
approx_elpds <- rep(NA, N)
# Initialize the process for i = min_t, generating a
# conditional forecast for all of the future data
data_splits <- cv_split(all_data, last_train = min_t, fc_horizon = fc_horizon)
# Fit model to training and forecast all remaining testing observations
noncentred <- if (is.null(attr(object$model_data, 'noncentred'))) {
FALSE
} else {
TRUE
}
if (silent < 1L) {
cat('Approximating elpd for training point', min_t, '...\n')
}
fit_past <- update(
object,
data = data_splits$data_train,
newdata = data_splits$data_test,
lfo = TRUE,
noncentred = noncentred,
silent = silent
)
# Calculate log likelihoods of forecast observations for the next
# fc_horizon ahead observations
fc_indices <- which(
c(data_splits$data_train$time, data_splits$data_test$time) %in%
(min_t + 1):(min_t + fc_horizon)
)
loglik_past <- logLik(fit_past)
# Store the EPLD estimate
approx_elpds[min_t + 1] <- log_mean_exp(sum_rows(loglik_past[, fc_indices]))
# Iterate over i > min_t
i_refit <- min_t
refits <- min_t
ks <- 0
for (i in (min_t + 1):(N - fc_horizon)) {
if (silent < 1L) {
cat('Approximating elpd for training point', i, '...\n')
}
# Get log likelihoods of what would be the
# last training observations for calculating Pareto k values
last_obs_indices <- which(
c(data_splits$data_train$time, data_splits$data_test$time) %in%
(i_refit + 1):i
)
logratio <- sum_rows(loglik_past[, last_obs_indices])
# Use PSIS to estimate whether the Pareto shape parameter of the
# importance weights is below the specified threshold; a lower value
# indicates the importance ratios have finite variance and can be
# used for approximating prediction error
psis_obj <- suppressWarnings(loo::psis(logratio))
k <- loo::pareto_k_values(psis_obj)
ks <- c(ks, k)
# If k is too high, refit the model based on the first i observations;
# in other words, the last refit did not provide stable enough predictions
# of what would be the last set of training observations; we instead need
# to include these in the training data, resulting in a slightly larger
# model
if (k > pareto_k_threshold) {
i_refit <- i
refits <- c(refits, i)
# Subset the data to now include the last set of training observations
data_splits <- cv_split(all_data, last_train = i, fc_horizon = fc_horizon)
# Re-fit the model
fit_past <- update(
fit_past,
data = data_splits$data_train,
newdata = data_splits$data_test,
lfo = TRUE,
noncentred = noncentred,
silent = silent
)
# Calculate ELPD as before
fc_indices <- which(
c(data_splits$data_train$time, data_splits$data_test$time) %in%
(i + 1):(i + fc_horizon)
)
loglik_past <- logLik(fit_past)
approx_elpds[i + 1] <- log_mean_exp(sum_rows(loglik_past[, fc_indices]))
} else {
# If k below threshold, calculate log likelihoods for the
# forecast observations using the normalised importance weights
# to weight the posterior draws
fc_indices <- which(
c(data_splits$data_train$time, data_splits$data_test$time) %in%
(i + 1):(i + fc_horizon)
)
lw <- loo::weights.importance_sampling(psis_obj, normalize = TRUE)[, 1]
approx_elpds[i + 1] <- log_sum_exp(
lw + sum_rows(loglik_past[, fc_indices])
)
}
}
return(structure(
list(
elpds = approx_elpds[(min_t + 1):(N - fc_horizon)],
sum_ELPD = sum(approx_elpds, na.rm = TRUE),
pareto_ks = ks[-1],
eval_timepoints = (min_t + 1):(N - fc_horizon),
pareto_k_threshold = pareto_k_threshold
),
class = 'mvgam_lfo'
))
}
#' Plot Pareto-k and ELPD values from a `mvgam_lfo` object
#'
#' This function takes an object of class `mvgam_lfo` and creates several
#' informative diagnostic plots
#' @importFrom graphics layout axis lines abline polygon points
#' @param x An object of class `mvgam_lfo`
#' @param ... Ignored
#' @return A `ggplot` object presenting Pareto-k and ELPD values over the
#' evaluation timepoints. For the Pareto-k plot, a dashed red line indicates the
#' specified threshold chosen for triggering model refits. For the ELPD plot,
#' a dashed red line indicates the bottom 10% quantile of ELPD values. Points below
#' this threshold may represent outliers that were more difficult to forecast
#' @export
plot.mvgam_lfo = function(x, ...) {
object <- x
# Plot Pareto-k values over time
object$pareto_ks[which(is.infinite(object$pareto_ks))] <-
max(object$pareto_ks[which(!is.infinite(object$pareto_ks))])
dplyr::tibble(
eval_timepoints = object$eval_timepoints,
elpds = object$elpds,
pareto_ks = object$pareto_ks
) -> obj_tribble
# Hack so we don't have to import tidyr just to use pivot_longer once
dplyr::bind_rows(
obj_tribble %>%
dplyr::select(eval_timepoints, elpds) %>%
dplyr::mutate(name = 'elpds', value = elpds) %>%
dplyr::select(-elpds),
obj_tribble %>%
dplyr::select(eval_timepoints, pareto_ks) %>%
dplyr::mutate(name = 'pareto_ks', value = pareto_ks) %>%
dplyr::select(-pareto_ks)
) %>%
dplyr::left_join(
dplyr::tribble(
~name ,
~threshold ,
"elpds" ,
quantile(object$elpds, probs = 0.15, na.rm = TRUE) ,
"pareto_ks" ,
object$pareto_k_threshold
),
by = "name"
) %>%
dplyr::rowwise() %>%
dplyr::mutate(
colour = dplyr::case_when(
name == 'elpds' & value < threshold ~ "outlier",
name == 'pareto_ks' & value > threshold ~ "outlier",
TRUE ~ "inlier"
)
) %>%
dplyr::ungroup() %>%
ggplot2::ggplot(ggplot2::aes(eval_timepoints, value)) +
ggplot2::facet_wrap(
~ factor(
name,
levels = c("pareto_ks", "elpds"),
labels = c("Pareto K", "ELPD")
),
ncol = 1,
scales = "free_y"
) +
ggplot2::geom_hline(
ggplot2::aes(yintercept = threshold),
colour = "#A25050",
linetype = "dashed",
linewidth = 1
) +
ggplot2::geom_line(linewidth = 0.5, col = "grey30") +
ggplot2::geom_point(shape = 16, colour = 'white', size = 2) +
ggplot2::geom_point(
ggplot2::aes(colour = colour),
shape = 16,
show.legend = F,
size = 1.5
) +
ggplot2::scale_colour_manual(values = c("grey30", "#8F2727")) +
ggplot2::labs(x = "Evaluation time", y = NULL) +
ggplot2::theme_bw()
}
#' Function to generate training and testing splits
#' @noRd
cv_split = function(data, last_train, fc_horizon = 1) {
if (inherits(data, 'list')) {
# Find indices of training and testing splits
temp_dat = data.frame(
time = data$index..time..index,
series = data$series
) %>%
dplyr::mutate(index = dplyr::row_number()) %>%
dplyr::arrange(time, series)
indices_train <- temp_dat %>%
dplyr::filter(time <= last_train) %>%
dplyr::pull(index)
indices_test <- temp_dat %>%
dplyr::filter(time > last_train) %>%
dplyr::pull(index)
# Split
data_train <- lapply(data, function(x) {
if (is.matrix(x)) {
matrix(x[indices_train, ], ncol = NCOL(x))
} else {
x[indices_train]
}
})
data_test <- lapply(data, function(x) {
if (is.matrix(x)) {
matrix(x[indices_test, ], ncol = NCOL(x))
} else {
x[indices_test]
}
})
} else {
data_train <- data %>%
dplyr::filter(index..time..index <= last_train) %>%
dplyr::arrange(index..time..index, series)
data_test <- data %>%
dplyr::filter(index..time..index > last_train) %>%
dplyr::arrange(index..time..index, series)
}
return(list(data_train = data_train, data_test = data_test))
}
#' More stable version of log(sum(exp(x)))
#' @noRd
log_sum_exp <- function(x) {
max_x <- max(x)
max_x + log(sum(exp(x - max_x)))
}
#' More stable version of log(mean(exp(x)))
#' @noRd
log_mean_exp <- function(x) {
log_sum_exp(x) - log(length(x))
}
#' Summing without NAs
#' @noRd
sum_rows = function(x) {
if (NCOL(x) > 1) {
out <- rowSums(x, na.rm = TRUE)
} else {
out <- x[!is.na(x)]
}
return(out)
}
================================================
FILE: R/logLik.mvgam.R
================================================
#' @title Compute pointwise Log-Likelihoods from fitted \pkg{mvgam} objects
#'
#' @importFrom parallel setDefaultCluster stopCluster
#'
#' @param object \code{list} object of class \code{mvgam} or \code{jsdgam}
#'
#' @param linpreds Optional `matrix` of linear predictor draws to use for
#' calculating pointwise log-likelihoods.
#'
#' @param newdata Optional `data.frame` or `list` object specifying which series
#' each column in `linpreds` belongs to. If `linpreds` is supplied, then
#' `newdata` must also be supplied.
#'
#' @param family_pars Optional `list` containing posterior draws of
#' family-specific parameters (i.e. shape, scale or overdispersion parameters).
#' Required if `linpreds` and `newdata` are supplied.
#'
#' @param include_forecast Logical. If `newdata` were fed to the model to
#' compute forecasts, should the log-likelihood draws for these observations
#' also be returned. Defaults to `TRUE`.
#'
#' @param ... Ignored
#'
#' @return A `matrix` of dimension `n_samples x n_observations` containing the
#' pointwise log-likelihood draws for all observations in `newdata`. If no
#' `newdata` is supplied, log-likelihood draws are returned for all observations
#' that were originally fed to the model (training observations and, if supplied
#' to the original model via the `newdata` argument in \code{\link{mvgam}},
#' testing observations).
#'
#' @author Nicholas J Clark
#'
#' @examples
#' \dontrun{
#' # Simulate some data and fit a model
#' simdat <- sim_mvgam(
#' n_series = 1,
#' trend_model = AR()
#' )
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract log-likelihood values
#' lls <- logLik(mod)
#' str(lls)
#' }
#'
#' @export
logLik.mvgam = function(
object,
linpreds,
newdata,
family_pars,
include_forecast = TRUE,
...
) {
if (!missing(linpreds) & missing(newdata)) {
stop('argument "newdata" must be supplied when "linpreds" is supplied')
}
if (!missing(linpreds) & missing(family_pars)) {
stop('argument "family_pars" must be supplied when "linpreds" is supplied')
}
if (!missing(newdata) & missing(linpreds)) {
stop('argument "linpreds" must be supplied when "newdata" is supplied')
}
if (!missing(family_pars) & missing(linpreds)) {
stop('argument "linpreds" must be supplied when "family_pars" is supplied')
}
# Extract the linear predictor draws
if (missing(linpreds)) {
mus <- mcmc_chains(object$model_output, 'mus')
} else {
mus <- linpreds
}
# Need to know which series each observation belongs to so we can
# pull out appropriate family-level parameters (overdispersions, shapes, etc...)
if (!missing(newdata)) {
all_dat <- data.frame(series = newdata$series, y = newdata$y)
if (object$family == 'nmix') {
all_dat$cap <- newdata$cap
}
} else {
if (is.null(object$test_data)) {
all_dat <- data.frame(
series = object$obs_data$series,
time = object$obs_data$time,
y = object$obs_data$y
) %>%
dplyr::arrange(time, series)
if (object$family == 'nmix') {
all_dat$cap <- data.frame(
series = object$obs_data$series,
time = object$obs_data$time,
cap = object$obs_data$cap
) %>%
dplyr::select(series, time, cap) %>%
dplyr::arrange(time, series) %>%
dplyr::pull(cap)
}
} else {
all_dat <- data.frame(
series = c(object$obs_data$series, object$test_data$series),
time = c(object$obs_data$time, object$test_data$time),
y = c(object$obs_data$y, object$test_data$y)
) %>%
dplyr::arrange(time, series)
if (object$family == 'nmix') {
all_dat$cap <- data.frame(
series = c(object$obs_data$series, object$test_data$series),
time = c(object$obs_data$time, object$test_data$time),
cap = c(object$obs_data$cap, object$test_data$cap)
) %>%
dplyr::select(series, time, cap) %>%
dplyr::arrange(time, series) %>%
dplyr::pull(cap)
}
}
}
obs <- all_dat$y
series_obs <- as.numeric(all_dat$series)
# Supply forecast NAs if include_forecast is FALSE
if (!is.null(object$test_data) & !include_forecast & missing(newdata)) {
n_fc_obs <- length(object$test_data$y)
n_obs <- length(obs)
obs[((n_obs - n_fc_obs) + 1):n_obs] <- NA
}
# Family-specific parameters
family <- object$family
if (missing(family_pars)) {
family_pars <- extract_family_pars(object = object)
n_series <- NCOL(object$ytimes)
} else {
n_series <- length(object$series_names)
}
# Family parameters spread into a vector
family_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
as.vector(family_pars[[j]][, series_obs])
} else {
as.vector(matrix(
rep(family_pars[[j]], NCOL(mus)),
nrow = NROW(mus),
byrow = FALSE
))
}
})
names(family_extracts) <- names(family_pars)
# Add trial information if this is a Binomial model
if (object$family %in% c('binomial', 'beta_binomial')) {
trials <- as.vector(matrix(
rep(as.vector(attr(object$mgcv_model, 'trials')), NROW(mus)),
nrow = NROW(mus),
byrow = TRUE
))
family_extracts$trials <- trials
}
# Create a truth matrix that can also be spread to a vector
truth_mat <- matrix(rep(obs, NROW(mus)), nrow = NROW(mus), byrow = TRUE)
# Log-likelihood as a vector
Xp <- as.matrix(as.vector(mus))
attr(Xp, 'model.offset') <- 0
if (family == 'nmix') {
Xp <- as.matrix(qlogis(as.vector(mcmc_chains(
object$model_output,
'detprob'
))))
attr(Xp, 'model.offset') <- 0
latent_lambdas <- exp(as.vector(mcmc_chains(object$model_output, 'trend')))
cap_mat <- matrix(
rep(all_dat$cap, NROW(mus)),
nrow = NROW(mus),
byrow = TRUE
)
cap <- as.vector(cap_mat)
} else {
latent_lambdas <- NULL
cap <- NULL
}
log_lik_vec <- mvgam_predict(
family = family,
family_pars = family_extracts,
truth = as.vector(truth_mat),
latent_lambdas = latent_lambdas,
cap = cap,
type = 'link',
Xp = Xp,
betas = 1,
density = TRUE
)
# Convert back to matrix and return
log_lik_mat <- matrix(log_lik_vec, nrow = NROW(mus))
return(log_lik_mat)
}
================================================
FILE: R/loo.mvgam.R
================================================
#' LOO information criteria for \pkg{mvgam} models
#'
#' Extract the LOOIC (leave-one-out information criterion) using [loo::loo()].
#'
#' @importFrom loo loo is.loo
#'
#' @param x Object of class `mvgam` or `jsdgam`
#'
#' @param incl_dynamics Deprecated and currently ignored
#'
#' @param ... Additional arguments for [loo::loo()]
#'
#' @rdname loo.mvgam
#'
#' @return For `loo.mvgam`, an object of class `psis_loo` (see [loo::loo()]
#' for details). For `loo_compare.mvgam`, an object of class `compare.loo`
#' (see [loo::loo_compare()] for details).
#'
#' @details
#' When comparing two (or more) fitted `mvgam` models, we can estimate the
#' difference in their in-sample predictive accuracies using the Expected Log
#' Predictive Density (ELPD). This metric can be approximated using Pareto
#' Smoothed Importance Sampling (PSIS), which re-weights posterior draws to
#' approximate predictions for a datapoint had it not been included in the
#' original model fit (i.e. leave-one-out cross-validation).
#'
#' See [loo::loo()] and [loo::loo_compare()] for further details on how this
#' importance sampling works.
#'
#' Note: In-sample predictive metrics such as PSIS-LOO can sometimes be overly
#' optimistic for models that include process error components (e.g. those with
#' `trend_model`, `trend_formula`, or `factor_formula`). Consider using
#' out-of-sample evaluations for further scrutiny (see
#' \code{\link{forecast.mvgam}}, \code{\link{score.mvgam_forecast}},
#' \code{\link{lfo_cv}}).
#'
#' @author Nicholas J Clark
#'
#' @examples
#' \dontrun{
#' #--------------------------------------------------
#' # Simulate 4 time series with hierarchical seasonality
#' # and independent AR1 dynamic processes
#' #--------------------------------------------------
#' set.seed(111)
#'
#' simdat <- sim_mvgam(
#' seasonality = 'hierarchical',
#' trend_model = AR(),
#' family = gaussian()
#' )
#'
#' # Fit a model with shared seasonality
#' mod1 <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' data = rbind(simdat$data_train, simdat$data_test),
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#'
#' conditional_effects(mod1)
#'
#' mc.cores.def <- getOption('mc.cores')
#' options(mc.cores = 1)
#' loo(mod1)
#'
#' # Fit a model with hierarchical seasonality
#' mod2 <- update(
#' mod1,
#' formula = y ~ s(season, bs = 'cc', k = 6) +
#' s(season, series, bs = 'fs', xt = list(bs = 'cc'), k = 4),
#' chains = 2,
#' silent = 2
#' )
#'
#' conditional_effects(mod2)
#' loo(mod2)
#'
#' # Add AR1 dynamic errors to mod2
#' mod3 <- update(
#' mod2,
#' trend_model = AR(),
#' chains = 2,
#' silent = 2
#' )
#'
#' conditional_effects(mod3)
#' plot(mod3, type = 'trend')
#' loo(mod3)
#'
#' #--------------------------------------------------
#' # Compare models using LOO
#' #--------------------------------------------------
#' loo_compare(mod1, mod2, mod3)
#' options(mc.cores = mc.cores.def)
#'
#' #--------------------------------------------------
#' # Compare forecast abilities using LFO-CV
#' #--------------------------------------------------
#'
#' lfo_mod2 <- lfo_cv(mod2, min_t = 92)
#' lfo_mod3 <- lfo_cv(mod3, min_t = 92)
#'
#' # Plot forecast ELPD differences
#' plot(
#' y = lfo_mod2$elpds - lfo_mod3$elpds,
#' x = lfo_mod2$eval_timepoints,
#' pch = 16,
#' ylab = 'ELPD_mod2 - ELPD_mod3',
#' xlab = 'Evaluation timepoint'
#' )
#'
#' abline(h = 0, lty = 'dashed')
#' }
#'
#' @export
loo.mvgam <- function(x, incl_dynamics = FALSE, ...) {
# Families with observation error components can give strange log-likelihood estimates
# if process error components were also included in the model (this is because the
# observation error estimates may be very small); use incl_dynamics = TRUE for these
# families to ensure all errors are propagated appropriately when calculating the
# log-likelihood
incl_dynamics <- FALSE
if (
x$family %in%
c(
"gaussian",
"lognormal",
"student"
)
) {
incl_dynamics <- TRUE
}
if (x$family == 'nmix' | incl_dynamics) {
logliks <- logLik(x, include_forecast = FALSE)
} else {
x$series_names <- levels(x$obs_data$series)
logliks <- logLik(
x,
linpreds = predict(
x,
newdata = x$obs_data,
type = 'link',
summary = FALSE,
process_error = FALSE
),
newdata = x$obs_data,
family_pars = extract_family_pars(x),
include_forecast = FALSE
)
}
logliks <- clean_ll(x, logliks)
releffs <- loo::relative_eff(
exp(logliks),
chain_id = sort(rep(
1:x$model_output@sim$chains,
(NROW(logliks) /
x$model_output@sim$chains)
))
)
loo::loo(logliks, r_eff = releffs, ...)
}
#' @importFrom loo loo_compare
#'
#' @param x Object of class `mvgam`
#'
#' @param ... More \code{mvgam} objects
#'
#' @param model_names If `NULL` (the default) will use model names derived
#' from deparsing the call. Otherwise will use the passed values as model names
#'
#' @param incl_dynamics Deprecated and currently ignored
#'
#' @rdname loo.mvgam
#'
#' @export
loo_compare.mvgam <- function(
x,
...,
model_names = NULL,
incl_dynamics = FALSE
) {
models <- split_mod_dots(x, ..., model_names = model_names)
loos <- named_list(names(models))
for (i in seq_along(models)) {
loos[[i]] <- loo(models[[i]], incl_dynamics = incl_dynamics)
}
loo_compare(loos)
}
#' @export
#' @importFrom loo loo
loo::loo
#' @export
#' @importFrom loo loo_compare
loo::loo_compare
#'@noRd
split_mod_dots = function(x, ..., model_names = NULL, other = TRUE) {
dots <- list(x, ...)
names <- substitute(list(x, ...), env = parent.frame())[-1]
names <- ulapply(names, deparse)
if (!is.null(model_names)) {
names <- model_names
}
if (length(names)) {
if (!length(names(dots))) {
names(dots) <- names
} else {
has_no_name <- !nzchar(names(dots))
names(dots)[has_no_name] <- names[has_no_name]
}
}
is_mvgam <- unlist(lapply(dots, function(y) inherits(y, 'mvgam')))
models <- dots[is_mvgam]
out <- dots[!is_mvgam]
if (length(out)) {
stop(
"Only model objects can be passed to '...' for this method.",
call. = FALSE
)
}
models
}
#'@noRd
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)
}
#'@noRd
clean_ll = function(x, logliks) {
# First remove any columns that are all NA (these had missing observations)
logliks <- logliks[, !apply(logliks, 2, function(x) all(!is.finite(x)))]
# Next resample any remaining non-finite values (occasionally happens with
# some observation families)
samp_noinf = function(x) {
x_finite <- x[is.finite(x)]
x[!is.finite(x)] <- sample(
x_finite,
length(x[!is.finite(x)]),
replace = TRUE
)
x
}
logliks <- apply(logliks, 2, samp_noinf)
# return
logliks
}
================================================
FILE: R/lv_correlations.R
================================================
#' Calculate trend correlations based on latent factor loadings for
#' \pkg{mvgam} models
#'
#' This function uses factor loadings from a fitted dynamic factor
#' \code{mvgam} model to calculate temporal correlations among series' trends.
#'
#' @importFrom stats cov2cor cov
#'
#' @param object \code{list} object of class \code{mvgam} that used latent
#' factors, either with `use_lv = TRUE` or by supplying a `trend_map`. See
#' [mvgam()] for details and for an example.
#'
#' @return A \code{list} object containing the mean posterior correlations and
#' the full array of posterior correlations.
#'
#' @details Although this function will still work, it is now recommended to use
#' [residual_cor()] to obtain residual correlation information in a more
#' user-friendly format that allows for a deeper investigation of relationships
#' among the time series.
#'
#' @seealso [residual_cor()], [plot.mvgam_residcor()]
#'
#' @examples
#' \dontrun{
#' #--------------------------------------------------
#' # Fit a model that uses two AR(1) dynamic factors to model
#' # the temporal dynamics of the four rodent species in the portal_data
#' #--------------------------------------------------
#' mod <- mvgam(
#' captures ~ series,
#' trend_model = AR(),
#' use_lv = TRUE,
#' n_lv = 2,
#' data = portal_data,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Plot the two dynamic factors
#' plot(mod, type = 'factors')
#'
#' # Calculate correlations among the series
#' lvcors <- lv_correlations(mod)
#' names(lvcors)
#' lapply(lvcors, class)
#'
#' # Recommended: use residual_cor() instead
#' lvcors <- residual_cor(mod)
#' names(lvcors)
#' lvcors$cor
#'
#' # Plot credible correlations as a matrix
#' plot(lvcors, cluster = TRUE)
#'
#' # Not needed for general use; cleans up connections for automated testing
#' closeAllConnections()
#' }
#'
#' @export
lv_correlations = function(object) {
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
# Series start and end indices
ends <- seq(
0,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
length.out = NCOL(object$ytimes) + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, (NCOL(object$ytimes) + 1))])
ends <- ends[-1]
# Total number of MCMC samples
n_preds <- dim(mcmc_chains(object$model_output, 'trend')[,
starts[1]:ends[1]
])[1]
data_train <- object$obs_data
# Total number of observations per series
if (inherits(data_train, 'list')) {
n_obs <- length(data_train$y) / NCOL(object$ytimes)
} else {
n_obs <- NROW(data_train) / NCOL(object$ytimes)
}
# Extract series trends
series_trends <- lapply(seq_len(length(ends)), function(y) {
if (object$fit_engine == 'stan') {
# For stan objects, trend is stored as a vector in column-major order
mcmc_chains(object$model_output, 'trend')[, seq(
y,
dim(mcmc_chains(object$model_output, 'trend'))[2],
by = NCOL(object$ytimes)
)]
} else {
mcmc_chains(object$model_output, 'trend')[, starts[y]:ends[y]][, 1:n_obs]
}
})
# Get list of trend correlation estimates
all_trend_cors <- lapply(seq_len(n_preds), function(x) {
cov2cor(cov(do.call(
cbind,
lapply(series_trends, function(y) {
y[x, ]
})
)))
})
# Calculate posterior mean correlations
mean_correlations <- Reduce(`+`, all_trend_cors) / length(all_trend_cors)
rownames(mean_correlations) <- colnames(mean_correlations) <- levels(
data_train$series
)
list(
mean_correlations = mean_correlations,
posterior_correlations = all_trend_cors
)
}
================================================
FILE: R/marginaleffects.mvgam.R
================================================
#' Helper functions for \pkg{marginaleffects} calculations in \pkg{mvgam} models
#'
#' @importFrom stats coef model.frame
#' @importFrom insight find_predictors get_data
#' @importFrom marginaleffects get_coef set_coef get_vcov get_predict
#' @importFrom utils getFromNamespace
#'
#' @inheritParams marginaleffects::get_coef
#' @inheritParams marginaleffects::set_coef
#' @inheritParams marginaleffects::get_vcov
#' @inheritParams marginaleffects::get_predict
#' @inheritParams insight::get_data
#' @inheritParams insight::find_predictors
#'
#' @param mfx Ignored
#' @param newparams Ignored
#' @param ndraws Ignored
#' @param se.fit Ignored
#'
#' @param trend_effects `logical`, extract from the process model component
#' (only applicable if a `trend_formula` was specified in the model)
#'
#' @param process_error `logical`. If `TRUE`, uncertainty in the latent
#' process (or trend) model is incorporated in predictions
#'
#' @return Objects suitable for internal 'marginaleffects' functions to proceed.
#' See [marginaleffects::get_coef()], [marginaleffects::set_coef()],
#' [marginaleffects::get_vcov()], [marginaleffects::get_predict()],
#' [insight::get_data()] and [insight::find_predictors()] for details
#'
#' @name mvgam_marginaleffects
#'
#' @author Nicholas J Clark
NULL
#' @export
#' @importFrom marginaleffects predictions
marginaleffects::predictions
#' @export
#' @importFrom marginaleffects avg_predictions
marginaleffects::avg_predictions
#' @export
#' @importFrom marginaleffects plot_predictions
marginaleffects::plot_predictions
#' @export
#' @importFrom marginaleffects slopes
marginaleffects::slopes
#' @export
#' @importFrom marginaleffects plot_slopes
marginaleffects::plot_slopes
#' @export
#' @importFrom marginaleffects comparisons
marginaleffects::comparisons
#' @export
#' @importFrom marginaleffects plot_comparisons
marginaleffects::plot_comparisons
#' @export
#' @importFrom marginaleffects datagrid
marginaleffects::datagrid
#' @export
#' @importFrom marginaleffects hypotheses
marginaleffects::hypotheses
#' @export
#' @importFrom marginaleffects get_predict
marginaleffects::get_predict
#' @export
#' @importFrom insight get_data
insight::get_data
#' Functions needed for working with \pkg{marginaleffects}
#' @rdname mvgam_marginaleffects
#' @export
get_coef.mvgam <- function(model, trend_effects = FALSE, ...) {
# Check trend_effects
if (trend_effects) {
if (is.null(model$trend_call)) {
stop('no trend_formula exists so there no trend-level coefficients')
}
}
if (!trend_effects) {
b <- coef(model$mgcv_model)
} else {
b <- coef(model$trend_mgcv_model)
}
return(b)
}
#' @rdname mvgam_marginaleffects
#' @export
set_coef.mvgam <- function(model, coefs, trend_effects = FALSE, ...) {
# Check trend_effects
if (trend_effects) {
if (is.null(model$trend_call)) {
stop('no trend_formula exists so there no trend-level coefficients')
}
}
out <- model
if (!trend_effects) {
out$mgcv_model$coefficients <- coefs
} else {
out$trend_mgcv_model$coefficients <- coefs
}
return(out)
}
#' @rdname mvgam_marginaleffects
#' @export
get_vcov.mvgam <- function(model, vcov = NULL, ...) {
if (!is.null(vcov) && !is.logical(vcov)) {
insight::format_warning(
"The `vcov` argument is not supported for models of this class."
)
}
return(NULL)
}
#' @rdname mvgam_marginaleffects
#' @export
get_predict.mvgam <- function(
model,
newdata,
type = 'response',
mfx,
newparams,
ndraws,
se.fit,
process_error = FALSE,
...
) {
preds <- predict(
object = model,
newdata = newdata,
type = type,
process_error = process_error,
summary = FALSE,
...
)
if ("rowid" %in% colnames(newdata)) {
out <- data.frame(
rowid = newdata[["rowid"]],
estimate = apply(preds, 2, median)
)
} else {
out <- data.frame(
rowid = seq_len(NCOL(preds)),
estimate = apply(preds, 2, median)
)
}
attr(out, "posterior_draws") <- t(preds)
return(out)
}
#' Functions needed for getting data / objects with \pkg{insight}
#' @rdname mvgam_marginaleffects
#' @export
get_data.mvgam = function(x, source = "environment", verbose = TRUE, ...) {
resp_terms <- as.character(rlang::f_lhs(x$call))
if (length(resp_terms) == 1L) {
resp <- resp_terms
} else {
if (any(grepl('cbind', resp_terms))) {
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
resp <- resp_terms[1]
}
}
mf <- tryCatch(
{
# Drop response observations if a trend call was used because often
# there won't be an easy way to match them up (for example if multiple
# series depend on a shared latent trend)
if (!is.null(x$trend_call)) {
# Original series, time and outcomes
orig_dat <- data.frame(
series = x$obs_data$series,
time = x$obs_data$index..time..index,
y = x$obs_data$y
)
# Add indicators of trend names as factor levels using the trend_map
trend_indicators <- vector(length = length(orig_dat$time))
for (i in 1:length(orig_dat$time)) {
trend_indicators[i] <- x$trend_map$trend[which(
x$trend_map$series == orig_dat$series[i]
)]
}
trend_indicators <- factor(
paste0('trend', trend_indicators),
levels = paste0('trend', unique(x$trend_map$trend))
)
# Trend-level data, before any slicing that took place
orig_dat %>%
dplyr::bind_cols(data.frame(
trend_series = trend_indicators,
row_num = 1:length(x$obs_data$index..time..index)
)) -> trend_level_data
# # We only kept one time observation per trend
trend_level_data %>%
dplyr::group_by(trend_series, time) %>%
dplyr::slice_head(n = 1) %>%
dplyr::pull(row_num) -> idx
# Extract model.frame for trend_level effects and add the
# trend indicators
mf_data <- model.frame(x, trend_effects = TRUE)
mf_data$trend_series <- trend_level_data$trend_series[idx]
mf_data$time <- trend_level_data$time[idx]
if ('series' %in% names(mf_data)) {
mf_data %>%
dplyr::select(-series) -> mf_data
}
# Now join with the original data so the original observations can
# be included
trend_level_data %>%
dplyr::left_join(mf_data, by = c('trend_series', 'time')) %>%
dplyr::select(-trend_series, -row_num, -trend_y) -> mf_data
# Extract any predictors from the observation level model and
# bind to the trend level model.frame
mf_obs <- model.frame(x, trend_effects = FALSE)
mf_data <- cbind(mf_obs, mf_data) %>%
subset(., select = which(!duplicated(names(.))))
# Now get the observed response, in case there are any
# NAs there that need to be updated
mf_data[, resp] <- x$obs_data$y
} else {
mf_data <- model.frame(x, trend_effects = FALSE)
mf_data[, resp] <- x$obs_data[[resp]]
}
mf_data
},
error = function(x) {
NULL
}
)
prep_data <- utils::getFromNamespace(".prepare_get_data", "insight")
out <- prep_data(x, mf, effects = "all", verbose = verbose)
# Remove colnames with cbind in them as these can be artifacts in
# binomial model data preparations
if (any(grepl('cbind', colnames(out)))) {
out %>%
dplyr::select(-matches('cbind')) -> out
}
return(out)
}
#' @rdname mvgam_marginaleffects
#' @export
get_data.mvgam_prefit = function(
x,
source = "environment",
verbose = TRUE,
...
) {
resp_terms <- as.character(rlang::f_lhs(x$call))
if (length(resp_terms) == 1L) {
resp <- resp_terms
} else {
if (any(grepl('cbind', resp_terms))) {
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
resp <- resp_terms[1]
}
}
mf <- tryCatch(
{
# Drop response observations if a trend call was used because often
# there won't be an easy way to match them up (for example if multiple
# series depend on a shared latent trend)
if (!is.null(x$trend_call)) {
# Original series, time and outcomes
orig_dat <- data.frame(
series = x$obs_data$series,
time = x$obs_data$index..time..index,
y = x$obs_data$y
)
# Add indicators of trend names as factor levels using the trend_map
trend_indicators <- vector(length = length(orig_dat$time))
for (i in 1:length(orig_dat$time)) {
trend_indicators[i] <- x$trend_map$trend[which(
x$trend_map$series == orig_dat$series[i]
)]
}
trend_indicators <- as.factor(paste0('trend', trend_indicators))
# Trend-level data, before any slicing that took place
trend_level_data <- data.frame(
trend_series = trend_indicators,
series = orig_dat$series,
time = orig_dat$time,
y = orig_dat$y,
row_num = 1:length(x$obs_data$index..time..index)
)
# # We only kept one time observation per trend
trend_level_data %>%
dplyr::group_by(trend_series, time) %>%
dplyr::slice_head(n = 1) %>%
dplyr::pull(row_num) -> idx
# Extract model.frame for trend_level effects and add the
# trend indicators
mf_data <- model.frame(x, trend_effects = TRUE)
mf_data$trend_series <- trend_level_data$trend_series[idx]
mf_data$time <- trend_level_data$time[idx]
if ('series' %in% names(mf_data)) {
mf_data %>%
dplyr::select(-series) -> mf_data
}
# Now join with the original data so the original observations can
# be included
trend_level_data %>%
dplyr::left_join(mf_data, by = c('trend_series', 'time')) %>%
dplyr::select(-trend_series, -row_num, -trend_y) -> mf_data
# Extract any predictors from the observation level model and
# bind to the trend level model.frame
mf_obs <- model.frame(x, trend_effects = FALSE)
mf_data <- cbind(mf_obs, mf_data) %>%
subset(., select = which(!duplicated(names(.))))
# Now get the observed response, in case there are any
# NAs there that need to be updated
mf_data[, resp] <- x$obs_data$y
} else {
mf_data <- model.frame(x, trend_effects = FALSE)
mf_data[, resp] <- x$obs_data[[resp]]
}
mf_data
},
error = function(x) {
NULL
}
)
prep_data <- utils::getFromNamespace(".prepare_get_data", "insight")
out <- prep_data(x, mf, effects = "all", verbose = verbose)
# Remove colnames with cbind in them as these can be artifacts in
# binomial model data preparations
if (any(grepl('cbind', colnames(out)))) {
out %>%
dplyr::select(-matches('cbind')) -> out
}
return(out)
}
#' @rdname mvgam_marginaleffects
#' @export
find_predictors.mvgam = function(
x,
effects = c('fixed', 'random', 'all'),
component = c(
'all',
'conditional',
'zi',
'zero_inflated',
'dispersion',
'instruments',
'correlation',
'smooth_terms'
),
flatten = FALSE,
verbose = TRUE,
...
) {
obs_preds <- insight::find_predictors(
x$mgcv_model,
effects = effects,
component = component,
flatten = flatten
)
if (!is.null(x$trend_call)) {
preds <- list()
trend_preds <- insight::find_predictors(
x$trend_mgcv_model,
effects = effects,
component = component,
flatten = flatten
)
if (flatten) {
preds <- unique(c(obs_preds, trend_preds))
} else {
preds$conditional <- unique(c(
obs_preds$conditional,
trend_preds$conditional
))
}
} else {
preds <- obs_preds
}
if (x$family == 'nmix') {
if (flatten) {
preds <- c(preds, 'cap')
} else {
preds$conditional <- c(preds$conditional, 'cap')
}
}
# Check for offsets and add appropriately
if (!is.null(attr(terms(x$call), "offset"))) {
off_names <- grep(
'offset',
rownames(attr(terms.formula(x$call), 'factors')),
value = TRUE
)
off_names <- sub(
"offset\\((.*)\\)$",
"\\1",
grep('offset', off_names, value = TRUE)
)
if (flatten) {
for (i in 1:length(off_names)) {
preds <- c(preds, off_names[i])
}
} else {
for (i in 1:length(off_names)) {
preds$conditional <- c(preds$conditional, off_names[i])
}
}
}
# Any other required variables, needed for grouped models
if (!inherits(attr(x$model_data, 'trend_model'), 'mvgam_trend')) {
trend_model <- list(
trend_model = attr(x$model_data, 'trend_model'),
unit = 'time',
gr = 'NA',
subgr = 'series'
)
} else {
trend_model <- attr(x$model_data, 'trend_model')
}
other_vars <- c(trend_model$unit, trend_model$gr, trend_model$subgr)
if (!is.null(attr(x$model_data, 'prepped_trend_model'))) {
prepped_model <- attr(x$model_data, 'prepped_trend_model')
other_vars <- c(
other_vars,
c(prepped_model$unit, prepped_model$gr, prepped_model$subgr)
)
}
if (flatten) {
other_vars <- setdiff(unique(other_vars), c('NA', preds))
preds <- c(preds, other_vars)
} else {
other_vars <- setdiff(unique(other_vars), c('NA', preds$conditional))
preds$conditional <- c(preds$conditional, other_vars)
}
return(preds)
}
#' @rdname mvgam_marginaleffects
#' @export
find_predictors.mvgam_prefit = function(
x,
effects = c('fixed', 'random', 'all'),
component = c(
'all',
'conditional',
'zi',
'zero_inflated',
'dispersion',
'instruments',
'correlation',
'smooth_terms'
),
flatten = FALSE,
verbose = TRUE,
...
) {
obs_preds <- insight::find_predictors(
x$mgcv_model,
effects = effects,
component = component,
flatten = flatten
)
if (!is.null(x$trend_call)) {
preds <- list()
trend_preds <- insight::find_predictors(
x$trend_mgcv_model,
effects = effects,
component = component,
flatten = flatten
)
if (flatten) {
preds <- unique(c(obs_preds, trend_preds))
} else {
preds$conditional <- unique(c(
obs_preds$conditional,
trend_preds$conditional
))
}
} else {
preds <- obs_preds
}
if (x$family == 'nmix') {
if (flatten) {
preds <- c(preds, 'cap')
} else {
preds$conditional <- c(preds$conditional, 'cap')
}
}
# Any other required variables, needed for grouped models
if (!inherits(attr(x$model_data, 'trend_model'), 'mvgam_trend')) {
trend_model <- list(
trend_model = attr(x$model_data, 'trend_model'),
unit = 'time',
gr = 'NA',
subgr = 'series'
)
} else {
trend_model <- attr(x$model_data, 'trend_model')
}
other_vars <- c(trend_model$unit, trend_model$gr, trend_model$subgr)
if (!is.null(attr(x$model_data, 'prepped_trend_model'))) {
prepped_model <- attr(x$model_data, 'prepped_trend_model')
other_vars <- c(
other_vars,
c(prepped_model$unit, prepped_model$gr, prepped_model$subgr)
)
}
if (flatten) {
other_vars <- setdiff(unique(other_vars), c('NA', preds))
preds <- c(preds, other_vars)
} else {
other_vars <- setdiff(unique(other_vars), c('NA', preds$conditional))
preds$conditional <- c(preds$conditional, other_vars)
}
return(preds)
}
================================================
FILE: R/mcmc_plot.mvgam.R
================================================
#' MCMC plots of \pkg{mvgam} parameters, as implemented in \pkg{bayesplot}
#'
#' Convenient way to call MCMC plotting functions
#' implemented in the \pkg{bayesplot} package for \pkg{mvgam} models
#' @importFrom bayesplot color_scheme_set color_scheme_get
#' @inheritParams brms::mcmc_plot
#' @inheritParams as.data.frame.mvgam
#' @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{areas_ridges}, \code{combo}, \code{acf},
#' \code{acf_bar}, \code{trace}, \code{trace_highlight},
#' \code{scatter}, \code{hex}, \code{pairs}, \code{violin},
#' \code{rhat}, \code{rhat_hist}, \code{neff}, \code{neff_hist}
#' and \code{nuts_energy}.
#' For an overview on the various plot types see
#' \code{\link[bayesplot:MCMC-overview]{MCMC-overview}}.
#' @return A \code{\link[ggplot2:ggplot]{ggplot}} object
#' that can be further customized using the \pkg{ggplot2} package.
#' @seealso \code{\link{mvgam_draws}} for an overview of some of the shortcut strings
#' that can be used for argument `variable`
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam(n_series = 1, trend_model = AR())
#' mod <- mvgam(y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2)
#' mcmc_plot(mod)
#' mcmc_plot(mod, type = 'neff_hist')
#' mcmc_plot(mod, variable = 'betas', type = 'areas')
#' mcmc_plot(mod, variable = 'trend_params', type = 'combo')
#' }
#' @export
mcmc_plot.mvgam = function(
object,
type = 'intervals',
variable = NULL,
regex = FALSE,
use_alias = TRUE,
...
) {
# Set red colour scheme
col_scheme <- attr(color_scheme_get(), 'scheme_name')
color_scheme_set('red')
# Check type validity
valid_types <- as.character(bayesplot::available_mcmc(""))
valid_types <- sub("^mcmc_", "", valid_types)
if (!type %in% valid_types) {
stop(
"Invalid plot type. Valid plot types are: \n",
paste0("'", valid_types, "'", collapse = ", "),
call. = FALSE
)
}
# Set default params to plot
# By default, don't plot the Betas as there can be hundreds
# of them in spline models
if (is.null(variable)) {
all_pars <- variables(object)
variable <- c(
all_pars$observation_pars[, 1],
all_pars$observation_smoothpars[, 1],
all_pars$observation_re_params[, 1],
all_pars$trend_pars[, 1],
all_pars$trend_smoothpars[, 1],
all_pars$trend_re_params[, 1]
)
regex <- FALSE
}
# Formal arguments
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 <- brms::nuts_params(object$model_output)
} else {
# x refers to a data.frame of draws
draws <- as.array(
object,
variable = variable,
regex = regex,
use_alias = use_alias
)
sel_variables <- dimnames(draws)$variable
if (type %in% c("scatter", "hex") && length(sel_variables) != 2L) {
stop(
"Exactly 2 parameters must be selected for this type.",
"\nParameters selected: ",
paste0("'", sel_variables, "'", collapse = ", "),
call. = FALSE
)
}
if (type == 'pairs' && length(sel_variables) == 1L) {
stop(
"2 or more parameters must be selected for this type.",
"\nParameters selected: ",
paste0("'", sel_variables, "'", collapse = ", "),
call. = FALSE
)
}
mcmc_args$x <- draws
}
}
if ("np" %in% mcmc_arg_names) {
mcmc_args$np <- brms::nuts_params(object$model_output)
}
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)
}
# Generate plot and reset colour scheme
out_plot <- do.call(mcmc_fun, args = mcmc_args)
color_scheme_set(col_scheme)
# Return the plot
return(out_plot)
}
#' @export
#' @importFrom brms mcmc_plot
brms::mcmc_plot
================================================
FILE: R/model.frame.mvgam.R
================================================
#' Extract model.frame from a fitted \pkg{mvgam} object
#'
#' @inheritParams stats::model.frame
#'
#' @param trend_effects \code{logical}, return the model.frame from the
#' observation model (if \code{FALSE}) or from the underlying process
#' model (if \code{TRUE})
#'
#' @param ... Ignored
#'
#' @method model.frame mvgam
#'
#' @author Nicholas J Clark
#'
#' @return A \code{matrix} containing the fitted model frame
#'
#' @export
model.frame.mvgam = function(formula, trend_effects = FALSE, ...) {
# Check trend_effects
if (trend_effects) {
if (is.null(formula$trend_call)) {
out <- NULL
} else {
out <- stats::model.frame(formula$trend_mgcv_model)
}
} else {
out <- stats::model.frame(formula$mgcv_model)
# Identify response variable
resp_terms <- as.character(rlang::f_lhs(formula$call))
if (length(resp_terms) == 1L) {
resp <- resp_terms
} else {
if (any(grepl('cbind', resp_terms))) {
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
resp <- resp_terms[1]
}
}
# Now add the observed response, in case there are any
# NAs there that need to be updated
out[, resp] <- formula$obs_data$y
# Ensure 'cap' is included if this is an N-mixture model
if (formula$family == 'nmix') {
out$cap <- formula$obs_data$cap
}
# Check for offsets and add appropriately
if (!is.null(attr(terms(formula$call), "offset"))) {
off_names <- grep(
'offset',
rownames(attr(terms.formula(formula$call), 'factors')),
value = TRUE
)
off_names <- sub(
"offset\\((.*)\\)$",
"\\1",
grep('offset', off_names, value = TRUE)
)
for (i in 1:length(off_names)) {
out[[off_names[i]]] <- formula$obs_data[[off_names[i]]]
}
}
# Any other required variables, needed for grouped models
if (
!inherits(attr(formula$model_data, 'trend_model'), 'mvgam_trend') &
!inherits(formula$trend_model, 'mvgam_trend')
) {
trend_model <- list(
trend_model = attr(formula$model_data, 'trend_model'),
unit = 'time',
gr = 'NA',
subgr = 'series'
)
}
if (inherits(attr(formula$model_data, 'trend_model'), 'mvgam_trend')) {
trend_model <- attr(formula$model_data, 'trend_model')
}
if (inherits(formula$trend_model, 'mvgam_trend')) {
trend_model <- formula$trend_model
}
other_vars <- c(trend_model$unit, trend_model$gr, trend_model$subgr)
if (!is.null(attr(formula$model_data, 'prepped_trend_model'))) {
prepped_model <- attr(formula$model_data, 'prepped_trend_model')
other_vars <- c(
other_vars,
c(prepped_model$unit, prepped_model$gr, prepped_model$subgr)
)
}
other_vars <- setdiff(unique(other_vars), c('NA', colnames(out)))
if (length(other_vars)) {
orig_names <- colnames(out)
for (i in 1:length(other_vars)) {
out <- cbind(out, formula$obs_data[[other_vars[i]]])
}
colnames(out) <- c(orig_names, other_vars)
}
}
return(out)
}
#' @inheritParams model.frame.mvgam
#' @rdname model.frame.mvgam
#' @method model.frame mvgam_prefit
#' @export
model.frame.mvgam_prefit = function(formula, trend_effects = FALSE, ...) {
# Check trend_effects
if (trend_effects) {
if (is.null(formula$trend_call)) {
out <- NULL
} else {
out <- stats::model.frame(formula$trend_mgcv_model)
}
} else {
out <- stats::model.frame(formula$mgcv_model)
# Identify response variable
resp_terms <- as.character(rlang::f_lhs(formula$call))
if (length(resp_terms) == 1L) {
resp <- resp_terms
} else {
if (any(grepl('cbind', resp_terms))) {
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
resp <- resp_terms[1]
}
}
# Now add the observed response, in case there are any
# NAs there that need to be updated
out[, resp] <- formula$obs_data$y
# Ensure 'cap' is included if this is an N-mixture model
if (formula$family == 'nmix') {
out$cap <- formula$obs_data$cap
}
# Check for offsets and add appropriately
if (!is.null(attr(terms(formula$call), "offset"))) {
off_names <- grep(
'offset',
rownames(attr(terms.formula(formula$call), 'factors')),
value = TRUE
)
off_names <- sub(
"offset\\((.*)\\)$",
"\\1",
grep('offset', off_names, value = TRUE)
)
for (i in 1:length(off_names)) {
out[[off_names[i]]] <- formula$obs_data[[off_names[i]]]
}
}
# Any other required variables, needed for grouped models
if (!inherits(attr(formula$model_data, 'trend_model'), 'mvgam_trend')) {
trend_model <- list(
trend_model = attr(formula$model_data, 'trend_model'),
unit = 'time',
gr = 'NA',
subgr = 'series'
)
} else {
trend_model <- attr(formula$model_data, 'trend_model')
}
other_vars <- c(trend_model$unit, trend_model$gr, trend_model$subgr)
if (!is.null(attr(formula$model_data, 'prepped_trend_model'))) {
prepped_model <- attr(formula$model_data, 'prepped_trend_model')
other_vars <- c(
other_vars,
c(prepped_model$unit, prepped_model$gr, prepped_model$subgr)
)
}
other_vars <- setdiff(unique(other_vars), c('NA', colnames(out)))
if (length(other_vars)) {
orig_names <- colnames(out)
for (i in 1:length(other_vars)) {
out <- cbind(out, formula$obs_data[[other_vars[i]]])
}
colnames(out) <- c(orig_names, other_vars)
}
}
return(out)
}
================================================
FILE: R/monotonic.R
================================================
#' Monotonic splines in \pkg{mvgam} models
#'
#' Uses constructors from package \pkg{splines2} to build monotonically increasing
#' or decreasing splines. Details also in Wang & Yan (2021).
#'
#' @inheritParams mgcv::smooth.construct.bs.smooth.spec
#'
#' @param object A smooth specification object, usually generated by a term
#' `s(x, bs = "moi", ...)` or `s(x, bs = "mod", ...)`
#'
#' @details The constructor is not normally called directly,
#' but is rather used internally by [mvgam]. If they are not supplied then the
#' knots of the spline are placed evenly throughout the covariate values to
#' which the term refers: For example, if fitting 101 data with an 11
#' knot spline of x then there would be a knot at every 10th (ordered) x value.
#' The spline is an implementation of the closed-form I-spline basis based
#' on the recursion formula given by Ramsay (1988), in which the basis coefficients
#' must be constrained to either be non-negative (for monotonically increasing
#' functions) or non-positive (monotonically decreasing)
#' \cr
#' \cr
#' Take note that when using either monotonic basis, the number of basis functions
#' `k` must be supplied as an even integer due to the manner in
#' which monotonic basis functions are constructed
#'
#' @return An object of class `"moi.smooth"` or `"mod.smooth"`. In addition to
#' the usual elements of a smooth class documented under \code{\link[mgcv]{smooth.construct}},
#' this object will contain a slot called `boundary` that defines the endpoints beyond
#' which the spline will begin extrapolating (extrapolation is flat due to the first
#' order penalty placed on the smooth function)
#'
#' @note This constructor will result in a valid smooth if using a call to
#' \code{\link[mgcv]{gam}} or \code{\link[mgcv]{bam}}, however the resulting
#' functions will not be guaranteed to be monotonic because constraints on
#' basis coefficients will not be enforced
#'
#' @references
#' Wang, Wenjie, and Jun Yan. "Shape-Restricted Regression Splines with R Package splines2."
#' Journal of Data Science 19.3 (2021).
#' \cr
#' \cr
#' Ramsay, J. O. (1988). Monotone regression splines in action. Statistical Science, 3(4), 425--441.
#'
#' @importFrom mgcv smooth.construct
#'
#' @author Nicholas J Clark
#'
#' @name monotonic
#'
#' @examples
#' \dontrun{
#' # Simulate data from a monotonically increasing function
#' set.seed(123123)
#'
#' x <- runif(80) * 4 - 1
#' x <- sort(x)
#' f <- exp(4 * x) / (1 + exp(4 * x))
#' y <- f + rnorm(80) * 0.1
#' plot(x, y)
#'
#' # A standard TRPS smooth doesn't capture monotonicity
#' library(mgcv)
#'
#' mod_data <- data.frame(y = y, x = x)
#' mod <- gam(
#' y ~ s(x, k = 16),
#' data = mod_data,
#' family = gaussian()
#' )
#'
#' library(marginaleffects)
#' plot_predictions(
#' mod,
#' by = 'x',
#' newdata = data.frame(
#' x = seq(min(x) - 0.5, max(x) + 0.5, length.out = 100)
#' ),
#' points = 0.5
#' )
#'
#' # Using the 'moi' basis in mvgam rectifies this
#' mod_data$time <- 1:NROW(mod_data)
#' mod2 <- mvgam(
#' y ~ s(x, bs = 'moi', k = 18),
#' data = mod_data,
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#'
#' plot_predictions(
#' mod2,
#' by = 'x',
#' newdata = data.frame(
#' x = seq(min(x) - 0.5, max(x) + 0.5, length.out = 100)
#' ),
#' points = 0.5
#' )
#'
#' plot(mod2, type = 'smooth', realisations = TRUE)
#'
#' # 'by' terms that produce a different smooth for each level of the 'by'
#' # factor are also allowed
#'
#' x <- runif(80) * 4 - 1
#' x <- sort(x)
#'
#' # Two different monotonic smooths, one for each factor level
#' f <- exp(4 * x) / (1 + exp(4 * x))
#' f2 <- exp(3.5 * x) / (1 + exp(3 * x))
#' fac <- c(rep('a', 80), rep('b', 80))
#' y <- c(
#' f + rnorm(80) * 0.1,
#' f2 + rnorm(80) * 0.2
#' )
#'
#' plot(x, y[1:80])
#' plot(x, y[81:160])
#'
#' # Gather all data into a data.frame, including the factor 'by' variable
#' mod_data <- data.frame(y, x, fac = as.factor(fac))
#' mod_data$time <- 1:NROW(mod_data)
#'
#' # Fit a model with different smooths per factor level
#' mod <- mvgam(
#' y ~ s(x, bs = 'moi', by = fac, k = 8),
#' data = mod_data,
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#'
#' # Visualise the different monotonic functions
#' plot_predictions(
#' mod,
#' condition = c('x', 'fac', 'fac'),
#' points = 0.5
#' )
#'
#' plot(mod, type = 'smooth', realisations = TRUE)
#'
#' # First derivatives (on the link scale) should never be
#' # negative for either factor level
#' (derivs <- slopes(
#' mod,
#' variables = 'x',
#' by = c('x', 'fac'),
#' type = 'link'
#' ))
#'
#' all(derivs$estimate > 0)
#' }
#' @export
smooth.construct.moi.smooth.spec <- function(object, data, knots) {
insight::check_if_installed("splines2")
# Check arguments
object$p.order <- 1
if (object$bs.dim < 0) {
object$bs.dim <- 10
}
`k(bs = 'moi')` <- object$bs.dim
if (`k(bs = 'moi')` <= 1) {
stop("Basis dimension is too small", call. = FALSE)
}
validate_pos_integer(`k(bs = 'moi')`)
validate_even(`k(bs = 'moi')`)
# Number of knots must be k / 2
nk <- object$bs.dim / 2L
if (!is.null(object$id)) {
stop("Monotonic splines don't work with ids", call. = FALSE)
}
# Check basis dimension
if (length(object$term) != 1) {
stop("Monotonic basis only handles 1D smooths", call. = FALSE)
}
# Find the data and specified knots
x <- data[[object$term]]
k <- knots[[object$term]]
if (length(unique(x)) < nk) {
warning("basis dimension is larger than number of unique covariates")
}
# Checks on knots
if (is.null(k)) {
xl <- min(x)
xu <- max(x)
} else {
xl <- min(k)
xu <- max(k)
if (xl > min(x) || xu < max(x)) {
stop("knot range does not include data", call. = FALSE)
}
if (length(k) != nk) {
stop(paste("there should be ", nk - 1, " supplied knots"), call. = FALSE)
}
}
if (!is.null(k)) {
if (sum(colSums(object$X) == 0) > 0) {
warning("there is *no* information about some basis coefficients")
}
}
if (is.null(k)) {
# Generate knots if missing
k <- seq(xl, xu, length.out = nk + 2)[2:nk + 1]
}
# Set anchor points beyond which extrapolation will occur
xr <- xu - xl
boundary <- c(xl - xr * 0.01, xu + xr * 0.01)
# Generate basis functions
i_spline_basis <- splines2::iSpline(
x,
knots = k,
degree = nk,
Boundary.knots = boundary,
intercept = TRUE
)
nbasis <- dim(i_spline_basis)[2]
# Fill in object
object$boundary <- boundary
object$bs.dim <- nbasis
object$knots <- k
class(object) <- c("moi.smooth")
object$X <- i_spline_basis
if (!is.null(object$xt$S)) {
stop(
'Cannot accept supplied penalty matrices for monotonic splines',
call. = FALSE
)
}
object$S <- list(diag(object$bs.dim))
object$rank <- object$bs.dim
object$null.space.dim <- 0
object$C <- matrix(0, 0, ncol(object$X))
object$random <- TRUE
return(object)
}
#' @export
#' @author Nicholas J Clark
#' @rdname monotonic
smooth.construct.mod.smooth.spec <- function(object, data, knots) {
insight::check_if_installed("splines2")
# Check arguments
object$p.order <- 1
if (object$bs.dim < 0) {
object$bs.dim <- 10
}
`k(bs = 'moi')` <- object$bs.dim
if (`k(bs = 'moi')` <= 1) {
stop("Basis dimension is too small", call. = FALSE)
}
validate_pos_integer(`k(bs = 'moi')`)
validate_even(`k(bs = 'moi')`)
# Number of knots must be k / 2
nk <- object$bs.dim / 2L
if (!is.null(object$id)) {
stop("Monotonic splines don't work with ids", call. = FALSE)
}
# Check basis dimension
if (length(object$term) != 1) {
stop("Monotonic basis only handles 1D smooths", call. = FALSE)
}
# Find the data and specified knots
x <- data[[object$term]]
k <- knots[[object$term]]
if (length(unique(x)) < nk) {
warning("basis dimension is larger than number of unique covariates")
}
# Checks on knots
if (is.null(k)) {
xl <- min(x)
xu <- max(x)
} else {
xl <- min(k)
xu <- max(k)
if (xl > min(x) || xu < max(x)) {
stop("knot range does not include data", call. = FALSE)
}
if (length(k) != nk) {
stop(paste("there should be ", nk - 1, " supplied knots"), call. = FALSE)
}
}
if (!is.null(k)) {
if (sum(colSums(object$X) == 0) > 0) {
warning("there is *no* information about some basis coefficients")
}
}
if (is.null(k)) {
# Generate knots if missing
k <- seq(xl, xu, length.out = nk + 2)[2:nk + 1]
}
# Set anchor points beyond which extrapolation will occur
xr <- xu - xl
boundary <- c(xl - xr * 0.01, xu + xr * 0.01)
# Generate basis functions
i_spline_basis <- splines2::iSpline(
x,
knots = k,
degree = nk,
Boundary.knots = boundary,
intercept = TRUE
)
nbasis <- dim(i_spline_basis)[2]
# Fill in object
object$boundary <- boundary
object$bs.dim <- nbasis
object$knots <- k
class(object) <- c("mod.smooth")
object$X <- i_spline_basis
if (!is.null(object$xt$S)) {
stop(
'Cannot accept supplied penalty matrices for monotonic splines',
call. = FALSE
)
}
object$S <- list(diag(object$bs.dim))
object$rank <- object$bs.dim
object$null.space.dim <- 0
object$C <- matrix(0, 0, ncol(object$X))
object$random <- TRUE
return(object)
}
# Prediction function for the `moi' smooth class
#' @rdname monotonic
#' @importFrom mgcv Predict.matrix
#' @export
Predict.matrix.moi.smooth <- function(object, data) {
insight::check_if_installed("splines2")
# Ensure extrapolation is flat (1st degree penalty behaviour)
x <- data[[object$term]]
boundary <- object$boundary
x[x > max(boundary)] <- max(boundary)
x[x < min(boundary)] <- min(boundary)
Xp <- suppressWarnings(splines2::iSpline(
x,
knots = object$knots,
degree = object$bs.dim / 2,
Boundary.knots = boundary,
intercept = TRUE
))
return(as.matrix(Xp))
}
# Prediction function for the `mod' smooth class
#' @rdname monotonic
#' @importFrom mgcv Predict.matrix
#' @export
Predict.matrix.mod.smooth <- function(object, data) {
insight::check_if_installed("splines2")
# Ensure extrapolation is flat (1st degree penalty behaviour)
x <- data[[object$term]]
boundary <- object$boundary
x[x > max(boundary)] <- max(boundary)
x[x < min(boundary)] <- min(boundary)
Xp <- suppressWarnings(splines2::iSpline(
x,
knots = object$knots,
degree = object$bs.dim / 2,
Boundary.knots = boundary,
intercept = TRUE
))
return(as.matrix(Xp))
}
add_mono_model_file = function(model_file, model_data, mgcv_model) {
# Which smooths are monotonic?
smooth_labs <- do.call(
rbind,
lapply(seq_along(mgcv_model$smooth), function(x) {
data.frame(
label = mgcv_model$smooth[[x]]$label,
class = class(mgcv_model$smooth[[x]])[1]
)
})
)
# Clean labels for inclusion in Stan code
mono_names <- smooth_labs$label[which(
smooth_labs$class %in% c('moi.smooth', 'mod.smooth')
)]
mono_names_clean <- clean_gpnames(mono_names)
# What directions are the constraints?
mono_directions <- smooth_labs %>%
dplyr::filter(class %in% c('moi.smooth', 'mod.smooth')) %>%
dplyr::mutate(
direction = dplyr::case_when(
class == 'moi.smooth' ~ 1,
class == 'mod.smooth' ~ -1,
TRUE ~ -1
)
) %>%
dplyr::pull(direction)
# Update model file to include constrained coefficients
b_line <- max(grep('b[', model_file, fixed = TRUE))
b_edits <- paste0(
'b[b_idx_',
mono_names_clean,
'] = abs(b_raw[b_idx_',
mono_names_clean,
']) * ',
mono_directions,
';',
collapse = '\n'
)
model_file[b_line] <- paste0(model_file[b_line], '\n', b_edits)
model_file <- readLines(textConnection(model_file), n = -1)
# Add the necessary indices to the model_data and data block
mono_stan_lines <- ''
for (covariate in seq_along(mono_names)) {
coef_indices <- which(
grepl(mono_names[covariate], names(coef(mgcv_model)), fixed = TRUE) &
!grepl(
paste0(mono_names[covariate], ':'),
names(coef(mgcv_model)),
fixed = TRUE
) ==
TRUE
)
mono_stan_lines <- paste0(
mono_stan_lines,
paste0(
'array[',
length(coef_indices),
'] int b_idx_',
mono_names_clean[covariate],
'; // monotonic basis coefficient indices\n'
)
)
mono_idx_data <- list(coef_indices)
names(mono_idx_data) <- paste0('b_idx_', mono_names_clean[covariate])
model_data <- append(model_data, mono_idx_data)
}
model_file[grep(
'int ytimes[n, n_series];',
model_file,
fixed = TRUE
)] <-
paste0(
model_file[grep(
'int ytimes[n, n_series];',
model_file,
fixed = TRUE
)],
'\n',
mono_stan_lines
)
model_file <- readLines(textConnection(model_file), n = -1)
return(list(model_file = model_file, model_data = model_data))
}
================================================
FILE: R/mvgam-class.R
================================================
#' Fitted `mvgam` object description
#'
#' A fitted \code{mvgam} object returned by function \code{\link{mvgam}}.
#' Run `methods(class = "mvgam")` to see an overview of available methods.
#'
#' @details A `mvgam` object contains the following elements:
#'
#' - `call` the original observation model formula
#'
#' - `trend_call` If a `trend_formula was supplied`, the original trend model
#' formula is returned. Otherwise `NULL`
#'
#' - `family` \code{character} description of the observation distribution
#'
#' - `trend_model` \code{character} description of the latent trend model
#'
#' - `trend_map` \code{data.frame} describing the mapping of trend states to
#' observations, if supplied in the original model. Otherwise `NULL`
#'
#' - `drift` Logical specifying whether a drift term was used in the trend
#' model
#'
#' - `priors` If the model priors were updated from their defaults, the prior
#' `dataframe` will be returned. Otherwise `NULL`
#'
#' - `model_output` The `MCMC` object returned by the fitting engine. If the
#' model was fitted using `Stan`, this will be an object of class `stanfit`
#' (see \code{\link[rstan]{stanfit-class}} for details). If `JAGS` was used
#' as the backend, this will be an object of class `runjags` (see
#' \code{\link[runjags]{runjags-class}} for details)
#'
#' - `model_file` The `character` string model file used to describe the model
#' in either `Stan` or `JAGS` syntax
#'
#' - `model_data` If `return_model_data` was set to `TRUE` when fitting the
#' model, the `list` object containing all data objects needed to condition
#' the model is returned. Each item in the `list` is described in detail at
#' the top of the `model_file`. Otherwise `NULL`
#'
#' - `inits` If `return_model_data` was set to `TRUE` when fitting the model,
#' the initial value functions used to initialise the MCMC chains will be
#' returned. Otherwise `NULL`
#'
#' - `monitor_pars` The parameters that were monitored during MCMC sampling
#' are returned as a `character vector`
#'
#' - `sp_names` A `character vector` specifying the names for each smoothing
#' parameter
#'
#' - `mgcv_model` An object of class `gam` containing the `mgcv` version of
#' the observation model. This object is used for generating the linear
#' predictor matrix when making predictions for new data. The coefficients
#' in this model object will contain the posterior median coefficients from
#' the GAM linear predictor, but these are only used if generating plots of
#' smooth functions that `mvgam` currently cannot handle (such as plots for
#' three-dimensional smooths). This model therefore should not be used for
#' inference. See \code{\link[mgcv]{gamObject}} for details
#'
#' - `trend_mgcv_model` If a `trend_formula was supplied`, an object of class
#' `gam` containing the `mgcv` version of the trend model. Otherwise `NULL`
#'
#' - `ytimes` The `matrix` object used in model fitting for indexing which
#' series and timepoints were observed in each row of the supplied data.
#' Used internally by some downstream plotting and prediction functions
#'
#' - `resids` A named `list` object containing posterior draws of Dunn-Smyth
#' randomized quantile residuals
#'
#' - `use_lv` Logical flag indicating whether latent dynamic factors were used
#' in the model
#'
#' - `n_lv` If `use_lv == TRUE`, the number of latent dynamic factors used in
#' the model
#'
#' - `upper_bounds` If bounds were supplied in the original model fit, they
#' will be returned. Otherwise `NULL`
#'
#' - `obs_data` The original data object (either a `list` or `dataframe`)
#' supplied in model fitting.
#'
#' - `test_data` If test data were supplied (as argument `newdata` in the
#' original model), it will be returned. Othwerise `NULL`
#'
#' - `fit_engine` `Character` describing the fit engine, either as `stan` or
#' `jags`
#'
#' - `backend` `Character` describing the backend used for modelling, either
#' as `rstan`, `cmdstanr` or `rjags`
#'
#' - `algorithm` `Character` describing the algorithm used for finding the
#' posterior, either as `sampling`, `laplace`, `pathfinder`, `meanfield` or
#' `fullrank`
#'
#' - `max_treedepth` If the model was fitted using `Stan`, the value supplied
#' for the maximum treedepth tuning parameter is returned (see
#' \code{\link[rstan]{stan}} for details). Otherwise `NULL`
#'
#' - `adapt_delta` If the model was fitted using `Stan`, the value supplied
#' for the adapt_delta tuning parameter is returned (see
#' \code{\link[rstan]{stan}} for details). Otherwise `NULL`
#'
#' @seealso [mvgam]
#'
#' @author Nicholas J Clark
#'
#' @name mvgam-class
NULL
================================================
FILE: R/mvgam-package.R
================================================
#' @keywords internal
"_PACKAGE"
## usethis namespace: start
## usethis namespace: end
NULL
================================================
FILE: R/mvgam.R
================================================
#' Fit a Bayesian Dynamic GAM to Univariate or Multivariate Time Series
#'
#' @description
#' This function estimates the posterior distribution for Generalised Additive
#' Models (GAMs) that can include smooth spline functions, specified in the GAM
#' formula, as well as latent temporal processes, specified by `trend_model`.
#'
#' Further modelling options include State-Space representations to allow covariates
#' and dynamic processes to occur on the latent 'State' level while also capturing
#' observation-level effects. Prior specifications are flexible and explicitly
#' encourage users to apply prior distributions that actually reflect their beliefs.
#'
#' In addition, model fits can easily be assessed and compared with posterior
#' predictive checks, forecast comparisons and leave-one-out / leave-future-out
#' cross-validation.
#'
#' @importFrom parallel clusterExport stopCluster setDefaultCluster
#' @importFrom stats formula terms rnorm update.formula predict
#' @importFrom rlang missing_arg
#'
#' @param formula A `formula` object specifying the GAM observation model formula.
#' These are exactly like the formula for a GLM except that smooth terms, `s()`,
#' `te()`, `ti()`, `t2()`, as well as time-varying `dynamic()` terms,
#' nonparametric `gp()` terms and offsets using `offset()`, can be added to the
#' right hand side to specify that the linear predictor depends on smooth
#' functions of predictors (or linear functionals of these).
#'
#' In `nmix()` family models, the `formula` is used to set up a linear predictor
#' for the detection probability. Details of the formula syntax used by
#' \pkg{mvgam} can be found in \code{\link{mvgam_formulae}}
#'
#' @param trend_formula An optional `formula` object specifying the GAM process
#' model formula. If supplied, a linear predictor will be modelled for the
#' latent trends to capture process model evolution separately from the
#' observation model.
#'
#' **Important notes:**
#' - Should not have a response variable specified on the left-hand side
#' (e.g., `~ season + s(year)`)
#' - Use `trend` instead of `series` for effects that vary across time series
#' - Only available for `RW()`, `AR()` and `VAR()` trend models
#' - In `nmix()` family models, sets up linear predictor for latent abundance
#' - Consider dropping one intercept using `- 1` convention to avoid
#' estimation challenges
#'
#' @param knots An optional `list` containing user specified knot values for
#' basis construction. For most bases the user simply supplies the knots to be
#' used, which must match up with the `k` value supplied. Different terms can
#' use different numbers of knots, unless they share a covariate.
#'
#' @param trend_knots As for `knots` above, this is an optional `list` of knot
#' values for smooth functions within the `trend_formula`.
#'
#' @param data A `dataframe` or `list` containing the model response variable
#' and covariates required by the GAM `formula` and optional `trend_formula`.
#'
#' **Required columns for most models:**
#' - `series`: A `factor` index of the series IDs (number of levels should equal
#' number of unique series labels)
#' - `time`: `numeric` or `integer` index of time points. For most dynamic trend
#' types, time should be measured in discrete, regularly spaced intervals
#' (i.e., `c(1, 2, 3, ...)`). Irregular spacing is allowed for `trend_model = CAR(1)`,
#' but zero intervals are adjusted to `1e-12` to prevent sampling errors.
#'
#' **Special cases:**
#' - Models with hierarchical temporal correlation (e.g., `AR(gr = region, subgr = species)`)
#' should NOT include a `series` identifier
#' - Models without temporal dynamics (`trend_model = 'None'` or `trend_model = ZMVN()`)
#' don't require a `time` variable
#'
#' @param newdata Optional `dataframe` or `list` of test data containing the same
#' variables as in `data`. If included, observations in variable `y` will be
#' set to `NA` when fitting the model so that posterior simulations can be obtained.
#'
#' @param run_model `logical`. If `FALSE`, the model is not fitted but instead
#' the function returns the model file and the data/initial values needed to
#' fit the model outside of `mvgam`.
#'
#' @param prior_simulation `logical`. If `TRUE`, no observations are fed to the
#' model, and instead simulations from prior distributions are returned.
#'
#' @param return_model_data `logical`. If `TRUE`, the list of data needed to fit
#' the model is returned, along with initial values for smooth and AR parameters,
#' once the model is fitted. Helpful for users who wish to modify the model file
#' to add other stochastic elements. Default is `FALSE` unless `run_model == FALSE`.
#'
#' @param family `family` specifying the exponential observation family for the series.
#'
#' **Supported families:**
#' - `gaussian()`: Real-valued data
#' - `betar()`: Proportional data on `(0,1)`
#' - `lognormal()`: Non-negative real-valued data
#' - `student_t()`: Real-valued data
#' - `Gamma()`: Non-negative real-valued data
#' - `bernoulli()`: Binary data
#' - `poisson()`: Count data (default)
#' - `nb()`: Overdispersed count data
#' - `binomial()`: Count data with imperfect detection when number of trials is known
#' (use `cbind()` to bind observations and trials)
#' - `beta_binomial()`: As `binomial()` but allows for overdispersion
#' - `nmix()`: Count data with imperfect detection when number of trials is unknown
#' (State-Space N-Mixture model with Poisson latent states and Binomial observations)
#'
#' See \code{\link{mvgam_families}} for more details.
#'
#' @param share_obs_params `logical`. If `TRUE` and the `family` has additional
#' family-specific observation parameters (e.g., variance components, dispersion
#' parameters), these will be shared across all outcome variables. Useful when
#' multiple outcomes share properties. Default is `FALSE`.
#'
#' @param use_lv `logical`. If `TRUE`, use dynamic factors to estimate series'
#' latent trends in a reduced dimension format. Only available for `RW()`,
#' `AR()` and `GP()` trend models. Default is `FALSE`.
#' See \code{\link{lv_correlations}} for examples.
#'
#' @param n_lv `integer` specifying the number of latent dynamic factors to use
#' if `use_lv == TRUE`. Cannot exceed `n_series`. Default is
#' `min(2, floor(n_series / 2))`.
#'
#' @param trend_model `character` or `function` specifying the time series dynamics
#' for the latent trend.
#'
#' **Available options:**
#' - `None`: No latent trend component (GAM component only, like \code{\link[mgcv]{gam}})
#' - `ZMVN` or `ZMVN()`: Zero-Mean Multivariate Normal (Stan only)
#' - `'RW'` or `RW()`: Random Walk
#' - `'AR1'`, `'AR2'`, `'AR3'` or `AR(p = 1, 2, 3)`: Autoregressive models
#' - `'CAR1'` or `CAR(p = 1)`: Continuous-time AR (Ornstein–Uhlenbeck process)
#' - `'VAR1'` or `VAR()`: Vector Autoregressive (Stan only)
#' - `'PWlogistic'`, `'PWlinear'` or `PW()`: Piecewise trends (Stan only)
#' - `'GP'` or `GP()`: Gaussian Process with squared exponential kernel (Stan only)
#'
#' **Additional features:**
#' - Moving average and/or correlated process error terms available for most types
#' (e.g., `RW(cor = TRUE)` for multivariate Random Walk)
#' - Hierarchical correlations possible for structured data
#' - See [mvgam_trends] for details and [ZMVN()] for examples
#'
#' @param trend_map Optional `data.frame` specifying which series should depend on
#' which latent trends. Enables multiple series to depend on the same latent
#' trend process with different observation processes.
#'
#' **Required structure:**
#' - Column `series`: Single unique entry for each series (matching factor levels in data)
#' - Column `trend`: Integer values indicating which trend each series depends on
#'
#' **Notes:**
#' - Sets up latent factor model by enabling `use_lv = TRUE`
#' - Process model intercept is NOT automatically suppressed
#' - Not yet supported for continuous time models (`CAR()`)
#'
#' @param noncentred `logical`. Use non-centred parameterisation for autoregressive
#' trend models? Can improve efficiency by avoiding degeneracies in latent dynamic
#' random effects estimation. Benefits vary by model - highly informative data
#' may perform worse with this option. Available for `RW()`, `AR()`, `CAR()`,
#' or `trend = 'None'` with `trend_formula`. Not available for moving average
#' or correlated error models.
#'
#' @param chains `integer` specifying the number of parallel chains for the model.
#' Ignored for variational inference algorithms.
#'
#' @param burnin `integer` specifying the number of warmup iterations to tune
#' sampling algorithms. Ignored for variational inference algorithms.
#'
#' @param samples `integer` specifying the number of post-warmup iterations for
#' sampling the posterior distribution.
#'
#' @param thin Thinning interval for monitors. Ignored for variational inference
#' algorithms.
#'
#' @param parallel `logical` specifying whether to use multiple cores for parallel
#' MCMC simulation. If `TRUE`, uses `min(c(chains, parallel::detectCores() - 1))` cores.
#'
#' @param threads `integer`. Experimental option for within-chain parallelisation
#' in Stan using `reduce_sum`. Recommended only for experienced Stan users with
#' slow models. Currently works for all families except `nmix()` and when using
#' Cmdstan backend.
#'
#' @param priors An optional `data.frame` with prior definitions or, preferably,
#' a vector of `brmsprior` objects (see \code{\link[brms]{prior}()}).
#' See [get_mvgam_priors()] and Details for more information.
#'
#' @param refit `logical`. Indicates whether this is a refit called using
#' [update.mvgam()]. Users should leave as `FALSE`.
#'
#' @param lfo `logical`. Indicates whether this is part of [lfo_cv.mvgam] call.
#' Returns lighter model version for speed. Users should leave as `FALSE`.
#'
#' @param residuals `logical`. Whether to compute series-level randomized quantile
#' residuals. Default is `TRUE`. Set to `FALSE` to save time and reduce object
#' size (can add later using [add_residuals]).
#'
#' @param backend Character string naming the package for Stan model fitting.
#' Options are `"cmdstanr"` (default) or `"rstan"`. Can be set globally via
#' `"brms.backend"` option. See https://mc-stan.org/rstan/ and
#' https://mc-stan.org/cmdstanr/ for details.
#'
#' @param algorithm Character string naming the estimation approach:
#' - `"sampling"`: MCMC (default)
#' - `"meanfield"`: Variational inference with factorized normal distributions
#' - `"fullrank"`: Variational inference with multivariate normal distribution
#' - `"laplace"`: Laplace approximation (cmdstanr only)
#' - `"pathfinder"`: Pathfinder algorithm (cmdstanr only)
#'
#' Can be set globally via `"brms.algorithm"` option. Limited testing suggests
#' `"meanfield"` performs best among non-MCMC approximations for dynamic GAMs.
#'
#' @param autoformat `logical`. Use `stanc` parser to automatically format Stan
#' code and check for deprecations. For development purposes - leave as `TRUE`.
#'
#' @param save_all_pars `logical`. Save draws from all variables defined in Stan's
#' `parameters` block. Default is `FALSE`.
#'
#' @param control Named `list` for controlling sampler behaviour. Valid elements
#' include `max_treedepth`, `adapt_delta` and `init`.
#'
#' @param silent Verbosity level between `0` and `2`. If `1` (default), most
#' informational messages are suppressed. If `2`, even more messages are
#' suppressed. Sampling progress is still printed - set `refresh = 0` to
#' disable. For `backend = "rstan"`, also set `open_progress = FALSE` to
#' prevent additional progress bars.
#'
#' @param ... Further arguments passed to Stan:
#' - For `backend = "rstan"`: passed to \code{\link[rstan]{sampling}()} or
#' \code{\link[rstan]{vb}()}
#' - For `backend = "cmdstanr"`: passed to `cmdstanr::sample`,
#' `cmdstanr::variational`, `cmdstanr::laplace` or `cmdstanr::pathfinder` methods
#'
#' @details
#' Dynamic GAMs are useful when we wish to predict future values from time series
#' that show temporal dependence but we do not want to rely on extrapolating from
#' a smooth term (which can sometimes lead to unpredictable and unrealistic behaviours).
#' In addition, smooths can often try to wiggle excessively to capture any
#' autocorrelation that is present in a time series, which exacerbates the problem
#' of forecasting ahead.
#'
#' As GAMs are very naturally viewed through a Bayesian lens, and we often must
#' model time series that show complex distributional features and missing data,
#' parameters for \pkg{mvgam} models are estimated in a Bayesian framework using
#' Markov Chain Monte Carlo by default.
#'
#' **Getting Started Resources:**
#' - General overview: `vignette("mvgam_overview")` and `vignette("data_in_mvgam")`
#' - Full list of vignettes: `vignette(package = "mvgam")`
#' - Real-world examples: \code{\link{mvgam_use_cases}}
#' - Quick reference: [mvgam cheatsheet](https://github.com/nicholasjclark/mvgam/raw/master/misc/mvgam_cheatsheet.pdf)
#'
#' @section Model Specification Details:
#'
#' **Formula Syntax:** Details of the formula syntax used by \pkg{mvgam} can be
#' found in \code{\link{mvgam_formulae}}. Note that it is possible to supply an
#' empty formula where there are no predictors or intercepts in the observation
#' model (i.e. `y ~ 0` or `y ~ -1`). In this case, an intercept-only observation
#' model will be set up but the intercept coefficient will be fixed at zero. This
#' can be handy if you wish to fit pure State-Space models where the variation in
#' the dynamic trend controls the average expectation, and/or where intercepts are
#' non-identifiable (as in piecewise trends).
#'
#' **Families and Link Functions:** Details of families supported by \pkg{mvgam}
#' can be found in \code{\link{mvgam_families}}.
#'
#' **Trend Models:** Details of latent error process models supported by \pkg{mvgam}
#' can be found in \code{\link{mvgam_trends}}.
#'
#' @section Prior Specifications:
#' Default priors for intercepts and any variance parameters are chosen to be
#' vaguely informative, but these should always be checked by the user. Prior
#' distributions for most important model parameters can be altered (see
#' [get_mvgam_priors()] for details). Note that latent trends are estimated on
#' the link scale so choose priors accordingly.
#'
#' However more control over the model specification can be accomplished by setting
#' \code{run_model = FALSE} and then editing the model code (found in the
#' `model_file` slot in the returned object) before running the model using either
#' \pkg{rstan} or \pkg{cmdstanr}. This is encouraged for complex modelling tasks.
#'
#' **Important:** No priors are formally checked to ensure they are in the right
#' syntax so it is up to the user to ensure these are correct.
#'
#' @section Model Components:
#'
#' **Random Effects:** For any smooth terms using the random effect basis
#' (\code{\link[mgcv]{smooth.construct.re.smooth.spec}}), a non-centred
#' parameterisation is automatically employed to avoid degeneracies that are common
#' in hierarchical models. Note however that centred versions may perform better
#' for series that are particularly informative, so as with any foray into Bayesian
#' modelling, it is worth building an understanding of the model's assumptions and
#' limitations by following a principled workflow. Also note that models are
#' parameterised using `drop.unused.levels = FALSE` in \code{\link[mgcv]{jagam}}
#' to ensure predictions can be made for all levels of the supplied factor variable.
#'
#' **Observation Level Parameters:** When more than one series is included in
#' \code{data} and an observation family that contains more than one parameter is
#' used, additional observation family parameters (i.e. `phi` for `nb()` or `sigma`
#' for `gaussian()`) are by default estimated independently for each series. But if
#' you wish for the series to share the same observation parameters, set
#' `share_obs_params = TRUE`.
#'
#' @section Model Diagnostics:
#'
#' **Residuals:** For each series, randomized quantile (i.e. Dunn-Smyth) residuals
#' are calculated for inspecting model diagnostics. If the fitted model is
#' appropriate then Dunn-Smyth residuals will be standard normal in distribution
#' and no autocorrelation will be evident. When a particular observation is missing,
#' the residual is calculated by comparing independent draws from the model's
#' posterior distribution.
#'
#' @section Computational Backend:
#'
#' **Using Stan:** \pkg{mvgam} is primarily designed to use Hamiltonian Monte Carlo
#' for parameter estimation via the software `Stan` (using either the `cmdstanr`
#' or `rstan` interface). There are great advantages when using `Stan` over Gibbs /
#' Metropolis Hastings samplers, which includes the option to estimate nonlinear
#' effects via [Hilbert space approximate Gaussian Processes](https://arxiv.org/abs/2004.11408),
#' the availability of a variety of inference algorithms (i.e. variational inference,
#' laplacian inference etc...) and [capabilities to enforce stationarity for complex Vector Autoregressions](https://www.tandfonline.com/doi/full/10.1080/10618600.2022.2079648).
#'
#' Because of the many advantages of `Stan` over `JAGS`, **further development of
#' the package will only be applied to `Stan`**. This includes the planned addition
#' of more response distributions, plans to handle zero-inflation, and plans to
#' incorporate a greater variety of trend models. Users are strongly encouraged to
#' opt for `Stan` over `JAGS` in any proceeding workflows.
#'
#' @section Recommended Workflow:
#'
#' **How to Start:** The [`mvgam` cheatsheet](https://github.com/nicholasjclark/mvgam/raw/master/misc/mvgam_cheatsheet.pdf)
#' is a good starting place if you are just learning to use the package. It gives
#' an overview of the package's key functions and objects, as well as providing a
#' reasonable workflow that new users can follow.
#'
#' **Recommended Steps:**
#'
#' 1. **Data Preparation:** Check that your data are in a suitable tidy format for
#' \pkg{mvgam} modeling (see the [data formatting vignette](https://nicholasjclark.github.io/mvgam/articles/data_in_mvgam.html)
#' for guidance)
#'
#' 2. **Data Exploration:** Inspect features of the data using \code{\link{plot_mvgam_series}}.
#' Now is also a good time to familiarise yourself with the package's example
#' workflows that are detailed in the vignettes:
#' - [Getting started vignette](https://nicholasjclark.github.io/mvgam/articles/mvgam_overview.html)
#' - [Shared latent states vignette](https://nicholasjclark.github.io/mvgam/articles/shared_states.html)
#' - [Time-varying effects vignette](https://nicholasjclark.github.io/mvgam/articles/time_varying_effects.html)
#' - [State-Space models vignette](https://nicholasjclark.github.io/mvgam/articles/trend_formulas.html)
#' - ["Fitting N-mixture models in `mvgam`"](https://nicholasjclark.github.io/mvgam/articles/nmixtures.html)
#' - ["Joint Species Distribution Models in `mvgam`"](https://nicholasjclark.github.io/mvgam/reference/jsdgam.html)
#' - ["Incorporating time-varying seasonality in forecast models"](https://ecogambler.netlify.app/blog/time-varying-seasonality/)
#' - ["Temporal autocorrelation in GAMs and the `mvgam` package"](https://ecogambler.netlify.app/blog/autocorrelated-gams/)
#'
#' 3. **Model Structure:** Carefully think about how to structure linear predictor
#' effects (i.e. smooth terms using \code{\link[mgcv]{s}()}, \code{\link[mgcv]{te}()}
#' or \code{\link[mgcv]{ti}()}, GPs using \code{\link[brms]{gp}()}, dynamic
#' time-varying effects using [dynamic()], and parametric terms), latent temporal
#' trend components (see \code{\link{mvgam_trends}}) and the appropriate
#' observation family (see \code{\link{mvgam_families}}). Use [get_mvgam_priors()]
#' to see default prior distributions for stochastic parameters.
#'
#' 4. **Prior Specification:** Change default priors using appropriate prior knowledge
#' (see \code{\link[brms]{prior}()}). When using State-Space models with a
#' `trend_formula`, pay particular attention to priors for any variance parameters
#' such as process errors and observation errors. Default priors on these parameters
#' are chosen to be vaguely informative and to avoid zero (using Inverse Gamma
#' priors), but more informative priors will often help with model efficiency
#' and convergence.
#'
#' 5. **Model Fitting:** Fit the model using either Hamiltonian Monte Carlo or an
#' approximation algorithm (i.e. change the `backend` argument) and use
#' [summary.mvgam()], [conditional_effects.mvgam()], [mcmc_plot.mvgam()],
#' [pp_check.mvgam()], [pairs.mvgam()] and [plot.mvgam()] to inspect /
#' interrogate the model.
#'
#' 6. **Model Comparison:** Update the model as needed and use [loo_compare.mvgam()]
#' for in-sample model comparisons, or alternatively use [forecast.mvgam()],
#' [lfo_cv.mvgam()] and [score.mvgam_forecast()] to compare models based on
#' out-of-sample forecasts (see the [forecast evaluation vignette](https://nicholasjclark.github.io/mvgam/articles/forecast_evaluation.html)
#' for guidance).
#'
#' 7. **Inference and Prediction:** When satisfied with the model structure, use
#' [predict.mvgam()], \code{\link[marginaleffects]{plot_predictions}()} and/or
#' \code{\link[marginaleffects]{plot_slopes}()} for more targeted simulation-based
#' inferences (see ["How to interpret and report nonlinear effects from Generalized Additive Models"](https://ecogambler.netlify.app/blog/interpreting-gams/)
#' for some guidance on interpreting GAMs). For time series models, use
#' [hindcast.mvgam()], [fitted.mvgam()], [augment.mvgam()] and [forecast.mvgam()]
#' to inspect posterior hindcast / forecast distributions.
#'
#' 8. **Documentation:** Use [how_to_cite()] to obtain a scaffold methods section
#' (with full references) to begin describing this model in scientific publications.
#'
#' @author Nicholas J Clark
#'
#' @references
#' Nicholas J Clark & Konstans Wells (2023). Dynamic generalised additive models
#' (DGAMs) for forecasting discrete ecological time series. Methods in Ecology and
#' Evolution. 14:3, 771-784.
#'
#' Nicholas J Clark, SK Morgan Ernest, Henry Senyondo, Juniper Simonis, Ethan P White,
#' Glenda M Yenni, KANK Karunarathna (2025). Beyond single-species models: leveraging
#' multispecies forecasts to navigate the dynamics of ecological predictability.
#' PeerJ. 13:e18929 https://doi.org/10.7717/peerj.18929
#'
#' @seealso \code{\link[mgcv]{jagam}()}, \code{\link[mgcv]{gam}()},
#' \code{\link[mgcv]{gam.models}}, [get_mvgam_priors()], [jsdgam()],
#' [hindcast.mvgam()], [forecast.mvgam()], [predict.mvgam()]
#'
#' @return A `list` object of class `mvgam` containing model output, the text
#' representation of the model file, the mgcv model output (for easily generating
#' simulations at unsampled covariate values), Dunn-Smyth residuals for each
#' series and key information needed for other functions in the package. See
#' \code{\link{mvgam-class}} for details. Use `methods(class = "mvgam")` for an
#' overview on available methods.
#'
#' @examples
#' \dontrun{
#' # =============================================================================
#' # Basic Multi-Series Time Series Modeling
#' # =============================================================================
#'
#' # Simulate three time series that have shared seasonal dynamics,
#' # independent AR(1) trends, and Poisson observations
#' set.seed(0)
#' dat <- sim_mvgam(
#' T = 80,
#' n_series = 3,
#' mu = 2,
#' trend_model = AR(p = 1),
#' prop_missing = 0.1,
#' prop_trend = 0.6
#' )
#'
#' # Plot key summary statistics for a single series
#' plot_mvgam_series(data = dat$data_train, series = 1)
#'
#' # Plot all series together
#' plot_mvgam_series(data = dat$data_train, series = "all")
#'
#' # Formulate a model using Stan where series share a cyclic smooth for
#' # seasonality and each series has an independent AR1 temporal process.
#' # Note that 'noncentred = TRUE' will likely give performance gains.
#' # Set run_model = FALSE to inspect the returned objects
#' mod1 <- mvgam(
#' formula = y ~ s(season, bs = "cc", k = 6),
#' data = dat$data_train,
#' trend_model = AR(),
#' family = poisson(),
#' noncentred = TRUE,
#' run_model = FALSE
#' )
#'
#' # View the model code in Stan language
#' stancode(mod1)
#'
#' # View the data objects needed to fit the model in Stan
#' sdata1 <- standata(mod1)
#' str(sdata1)
#'
#' # Now fit the model
#' mod1 <- mvgam(
#' formula = y ~ s(season, bs = "cc", k = 6),
#' data = dat$data_train,
#' trend_model = AR(),
#' family = poisson(),
#' noncentred = TRUE,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract the model summary
#' summary(mod1)
#'
#' # Plot the historical trend and hindcast distributions for one series
#' hc_trend <- hindcast(mod1, type = "trend")
#' plot(hc_trend)
#'
#' hc_predicted <- hindcast(mod1, type = "response")
#' plot(hc_predicted)
#'
#' # Residual diagnostics
#' plot(mod1, type = "residuals", series = 1)
#' resids <- residuals(mod1)
#' str(resids)
#'
#' # Fitted values and residuals can be added directly to the training data
#' augment(mod1)
#'
#' # Compute the forecast using covariate information in data_test
#' fc <- forecast(mod1, newdata = dat$data_test)
#' str(fc)
#' fc_summary <- summary(fc)
#' head(fc_summary, 12)
#' plot(fc)
#'
#' # Plot the estimated seasonal smooth function
#' plot(mod1, type = "smooths")
#'
#' # Plot estimated first derivatives of the smooth
#' plot(mod1, type = "smooths", derivatives = TRUE)
#'
#' # Plot partial residuals of the smooth
#' plot(mod1, type = "smooths", residuals = TRUE)
#'
#' # Plot posterior realisations for the smooth
#' plot(mod1, type = "smooths", realisations = TRUE)
#'
#' # Plot conditional response predictions using marginaleffects
#' conditional_effects(mod1)
#' plot_predictions(mod1, condition = "season", points = 0.5)
#'
#' # Generate posterior predictive checks using bayesplot
#' pp_check(mod1)
#'
#' # Extract observation model beta coefficient draws as a data.frame
#' beta_draws_df <- as.data.frame(mod1, variable = "betas")
#' head(beta_draws_df)
#' str(beta_draws_df)
#'
#' # Investigate model fit
#' mc.cores.def <- getOption("mc.cores")
#' options(mc.cores = 1)
#' loo(mod1)
#' options(mc.cores = mc.cores.def)
#'
#'
#' # =============================================================================
#' # Vector Autoregressive (VAR) Models
#' # =============================================================================
#'
#' # Fit a model to the portal time series that uses a latent
#' # Vector Autoregression of order 1
#' mod <- mvgam(
#' formula = captures ~ -1,
#' trend_formula = ~ trend,
#' trend_model = VAR(cor = TRUE),
#' family = poisson(),
#' data = portal_data,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Plot the autoregressive coefficient distributions;
#' # use 'dir = "v"' to arrange the order of facets correctly
#' mcmc_plot(
#' mod,
#' variable = 'A',
#' regex = TRUE,
#' type = 'hist',
#' facet_args = list(dir = 'v')
#' )
#'
#' # Plot the process error variance-covariance matrix in the same way
#' mcmc_plot(
#' mod,
#' variable = 'Sigma',
#' regex = TRUE,
#' type = 'hist',
#' facet_args = list(dir = 'v')
#' )
#'
#' # Calculate Generalized Impulse Response Functions for each series
#' irfs <- irf(
#' mod,
#' h = 12,
#' cumulative = FALSE
#' )
#'
#' # Plot some of them
#' plot(irfs, series = 1)
#' plot(irfs, series = 2)
#'
#' # Calculate forecast error variance decompositions for each series
#' fevds <- fevd(mod, h = 12)
#'
#' # Plot median contributions to forecast error variance
#' plot(fevds)
#'
#'
#' # =============================================================================
#' # Dynamic Factor Models
#' # =============================================================================
#'
#' # Now fit a model that uses two RW dynamic factors to model
#' # the temporal dynamics of the four rodent species
#' mod <- mvgam(
#' captures ~ series,
#' trend_model = RW(),
#' use_lv = TRUE,
#' n_lv = 2,
#' data = portal_data,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Plot the factors
#' plot(mod, type = 'factors')
#'
#' # Plot the hindcast distributions
#' hcs <- hindcast(mod)
#' plot(hcs, series = 1)
#' plot(hcs, series = 2)
#' plot(hcs, series = 3)
#' plot(hcs, series = 4)
#'
#' # Use residual_cor() to calculate temporal correlations among the series
#' # based on the factor loadings
#' lvcors <- residual_cor(mod)
#' names(lvcors)
#' lvcors$cor
#'
#' # For those correlations whose credible intervals did not include
#' # zero, plot them as a correlation matrix (all other correlations
#' # are shown as zero on this plot)
#' plot(lvcors, cluster = TRUE)
#'
#'
#' # =============================================================================
#' # Shared Latent Trends with Custom Trend Mapping
#' # =============================================================================
#'
#' # Example of supplying a trend_map so that some series can share
#' # latent trend processes
#' sim <- sim_mvgam(n_series = 3)
#' mod_data <- sim$data_train
#'
#' # Here, we specify only two latent trends; series 1 and 2 share a trend,
#' # while series 3 has its own unique latent trend
#' trend_map <- data.frame(
#' series = unique(mod_data$series),
#' trend = c(1, 1, 2)
#' )
#'
#' # Fit the model using AR1 trends
#' mod <- mvgam(
#' formula = y ~ s(season, bs = "cc", k = 6),
#' trend_map = trend_map,
#' trend_model = AR(),
#' data = mod_data,
#' return_model_data = TRUE,
#' chains = 2,
#' silent = 2
#' )
#'
#' # The mapping matrix is now supplied as data to the model in the 'Z' element
#' mod$model_data$Z
#'
#' # The first two series share an identical latent trend; the third is different
#' plot(residual_cor(mod))
#' plot(mod, type = "trend", series = 1)
#' plot(mod, type = "trend", series = 2)
#' plot(mod, type = "trend", series = 3)
#'
#'
#' # =============================================================================
#' # Time-Varying (Dynamic) Coefficients
#' # =============================================================================
#'
#' # Example of how to use dynamic coefficients
#' # Simulate a time-varying coefficient for the effect of temperature
#' set.seed(123)
#' N <- 200
#' beta_temp <- vector(length = N)
#' beta_temp[1] <- 0.4
#' for (i in 2:N) {
#' beta_temp[i] <- rnorm(1, mean = beta_temp[i - 1] - 0.0025, sd = 0.05)
#' }
#' plot(beta_temp)
#'
#' # Simulate a covariate called 'temp'
#' temp <- rnorm(N, sd = 1)
#'
#' # Simulate some noisy Gaussian observations
#' out <- rnorm(N,
#' mean = 4 + beta_temp * temp,
#' sd = 0.5
#' )
#'
#' # Gather necessary data into a data.frame; split into training / testing
#' data <- data.frame(out, temp, time = seq_along(temp))
#' data_train <- data[1:180, ]
#' data_test <- data[181:200, ]
#'
#' # Fit the model using the dynamic() function
#' mod <- mvgam(
#' formula = out ~ dynamic(
#' temp,
#' scale = FALSE,
#' k = 40
#' ),
#' family = gaussian(),
#' data = data_train,
#' newdata = data_test,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Inspect the model summary, forecast and time-varying coefficient distribution
#' summary(mod)
#' plot(mod, type = "smooths")
#' fc <- forecast(mod, newdata = data_test)
#' plot(fc)
#'
#' # Propagating the smooth term shows how the coefficient is expected to evolve
#' plot_mvgam_smooth(mod, smooth = 1, newdata = data)
#' abline(v = 180, lty = "dashed", lwd = 2)
#' points(beta_temp, pch = 16)
#'
#'
#' # =============================================================================
#' # Working with Offset Terms
#' # =============================================================================
#'
#' # Example showing how to incorporate an offset; simulate some count data
#' # with different means per series
#' set.seed(100)
#' dat <- sim_mvgam(
#' prop_trend = 0,
#' mu = c(0, 2, 2),
#' seasonality = "hierarchical"
#' )
#'
#' # Add offset terms to the training and testing data
#' dat$data_train$offset <- 0.5 * as.numeric(dat$data_train$series)
#' dat$data_test$offset <- 0.5 * as.numeric(dat$data_test$series)
#'
#' # Fit a model that includes the offset in the linear predictor as well as
#' # hierarchical seasonal smooths
#' mod <- mvgam(
#' formula = y ~ offset(offset) +
#' s(series, bs = "re") +
#' s(season, bs = "cc") +
#' s(season, by = series, m = 1, k = 5),
#' data = dat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Inspect the model file to see the modification to the linear predictor (eta)
#' stancode(mod)
#'
#' # Forecasts for the first two series will differ in magnitude
#' fc <- forecast(mod, newdata = dat$data_test)
#' plot(fc, series = 1, ylim = c(0, 75))
#' plot(fc, series = 2, ylim = c(0, 75))
#'
#' # Changing the offset for the testing data should lead to changes in
#' # the forecast
#' dat$data_test$offset <- dat$data_test$offset - 2
#' fc <- forecast(mod, newdata = dat$data_test)
#' plot(fc)
#'
#' # Relative Risks can be computed by fixing the offset to the same value
#' # for each series
#' dat$data_test$offset <- rep(1, NROW(dat$data_test))
#' preds_rr <- predict(mod,
#' type = "link",
#' newdata = dat$data_test,
#' summary = FALSE
#' )
#' series1_inds <- which(dat$data_test$series == "series_1")
#' series2_inds <- which(dat$data_test$series == "series_2")
#'
#' # Relative Risks are now more comparable among series
#' layout(matrix(1:2, ncol = 2))
#' plot(preds_rr[1, series1_inds],
#' type = "l", col = "grey75",
#' ylim = range(preds_rr),
#' ylab = "Series1 Relative Risk", xlab = "Time"
#' )
#' for (i in 2:50) {
#' lines(preds_rr[i, series1_inds], col = "grey75")
#' }
#'
#' plot(preds_rr[1, series2_inds],
#' type = "l", col = "darkred",
#' ylim = range(preds_rr),
#' ylab = "Series2 Relative Risk", xlab = "Time"
#' )
#' for (i in 2:50) {
#' lines(preds_rr[i, series2_inds], col = "darkred")
#' }
#' layout(1)
#'
#'
#' # =============================================================================
#' # Binomial Family Models
#' # =============================================================================
#'
#' # Example showcasing how cbind() is needed for Binomial observations
#' # Simulate two time series of Binomial trials
#' trials <- sample(c(20:25), 50, replace = TRUE)
#' x <- rnorm(50)
#' detprob1 <- plogis(-0.5 + 0.9 * x)
#' detprob2 <- plogis(-0.1 - 0.7 * x)
#' dat <- rbind(
#' data.frame(
#' y = rbinom(n = 50, size = trials, prob = detprob1),
#' time = 1:50,
#' series = "series1",
#' x = x,
#' ntrials = trials
#' ),
#' data.frame(
#' y = rbinom(n = 50, size = trials, prob = detprob2),
#' time = 1:50,
#' series = "series2",
#' x = x,
#' ntrials = trials
#' )
#' )
#' dat <- dplyr::mutate(dat, series = as.factor(series))
#' dat <- dplyr::arrange(dat, time, series)
#' plot_mvgam_series(data = dat, series = "all")
#'
#' # Fit a model using the binomial() family; must specify observations
#' # and number of trials in the cbind() wrapper
#' mod <- mvgam(
#' formula = cbind(y, ntrials) ~ series + s(x, by = series),
#' family = binomial(),
#' data = dat,
#' chains = 2,
#' silent = 2
#' )
#' summary(mod)
#' pp_check(mod,
#' type = "bars_grouped",
#' group = "series", ndraws = 50
#' )
#' pp_check(mod,
#' type = "ecdf_overlay_grouped",
#' group = "series", ndraws = 50
#' )
#' conditional_effects(mod, type = "link")
#'
#' # To view predictions on the probability scale,
#' # use ntrials = 1 in datagrid()
#' plot_predictions(
#' mod,
#' by = c('x', 'series'),
#' newdata = datagrid(
#' x = runif(100, -2, 2),
#' series = unique,
#' ntrials = 1
#' ),
#' type = 'expected'
#' )
#'
#' # Not needed for general use; cleans up connections for automated testing
#' closeAllConnections()
#' }
#' @export
mvgam <- function(
formula,
trend_formula,
knots,
trend_knots,
trend_model = "None",
noncentred = FALSE,
family = poisson(),
share_obs_params = FALSE,
data,
newdata,
use_lv = FALSE,
n_lv,
trend_map,
priors,
run_model = TRUE,
prior_simulation = FALSE,
residuals = TRUE,
return_model_data = FALSE,
backend = getOption("brms.backend", "cmdstanr"),
algorithm = getOption("brms.algorithm", "sampling"),
control = list(max_treedepth = 10, adapt_delta = 0.8),
chains = 4,
burnin = 500,
samples = 500,
thin = 1,
parallel = TRUE,
threads = 1,
save_all_pars = FALSE,
silent = 1,
autoformat = TRUE,
refit = FALSE,
lfo = FALSE,
...
) {
# Check data arguments
dots <- list(...)
if (missing("data")) {
if ("data_train" %in% names(dots)) {
message('argument "data_train" is deprecated; supply as "data" instead')
data <- dots$data_train
dots$data_train <- NULL
} else {
stop('Argument "data" is missing with no default', call. = FALSE)
}
}
if (missing("newdata")) {
if ("data_test" %in% names(dots)) {
message('argument "data_test" is deprecated; supply as "newdata" instead')
data_test <- dots$data_train
dots$data_test <- NULL
} else {
data_test <- rlang::missing_arg()
}
}
if (!missing("data")) {
data_train <- data
}
if (!missing("newdata")) {
data_test <- newdata
}
orig_data <- data_train
# Check sampler arguments
use_stan <- TRUE
if ("adapt_delta" %in% names(dots)) {
message(
'argument "adapt_delta" should be supplied as an element in "control"'
)
adapt_delta <- dots$adapt_delta
dots$adapt_delta <- NULL
} else {
adapt_delta <- control$adapt_delta
if (is.null(adapt_delta)) adapt_delta <- 0.8
}
if ("max_treedepth" %in% names(dots)) {
message(
'argument "max_treedepth" should be supplied as an element in "control"'
)
max_treedepth <- dots$max_treedepth
dots$max_treedepth <- NULL
} else {
max_treedepth <- control$max_treedepth
if (is.null(max_treedepth)) max_treedepth <- 10
}
# Validate trend_model
if ("drift" %in% names(dots) & silent < 2L) {
message(
'The "drift" argument is deprecated; use fixed effects of "time" instead'
)
dots$drift <- NULL
}
drift <- FALSE
orig_trend_model <- trend_model
trend_model <- validate_trend_model(
orig_trend_model,
drift = drift,
noncentred = noncentred
)
# Cannot yet map observations to trends that evolve as CAR1
if (trend_model == "CAR1" & !missing(trend_map)) {
stop("cannot yet use trend mapping for CAR1 dynamics", call. = FALSE)
}
# Ensure series and time variables are present
data_train <- validate_series_time(
data_train,
name = "data",
trend_model = orig_trend_model
)
# Validate the formula to convert any dynamic() terms
formula <- interpret_mvgam(
formula,
N = max(data_train$index..time..index),
family = family
)
# Check sampler arguments
validate_pos_integer(chains)
validate_pos_integer(threads)
validate_pos_integer(burnin)
validate_pos_integer(samples)
validate_pos_integer(thin)
validate_silent(silent)
# Upper bounds no longer supported as they are fairly useless
upper_bounds <- rlang::missing_arg()
# Check for gp terms in the validated formula
list2env(
check_gp_terms(formula, data_train, family = family),
envir = environment()
)
# Check for missing rhs in formula
list2env(check_obs_intercept(formula, orig_formula), envir = environment())
# Check for brmspriors
if (!missing(priors)) {
if (inherits(priors, "brmsprior") & !lfo & use_stan) {
priors <- adapt_brms_priors(
priors = priors,
formula = orig_formula,
trend_formula = trend_formula,
data = data_train,
family = family,
use_lv = use_lv,
n_lv = n_lv,
trend_model = orig_trend_model,
trend_map = trend_map,
drift = drift,
warnings = TRUE,
knots = knots
)
}
}
# Ensure series and time variables are present
data_train <- validate_series_time(
data_train,
name = "data",
trend_model = orig_trend_model
)
if (!missing(data_test)) {
data_test <- validate_series_time(
data_test,
name = "newdata",
trend_model = orig_trend_model
)
if (trend_model == "CAR1") {
data_test$index..time..index <- data_test$index..time..index +
max(data_train$index..time..index)
}
}
# Lighten the final object if this is an lfo run
if (lfo) {
return_model_data <- FALSE
}
# Validate observation formula
formula <- interpret_mvgam(formula, N = max(data_train$index..time..index))
data_train <- validate_obs_formula(formula, data = data_train, refit = refit)
if (!missing(data_test)) {
data_test <- validate_obs_formula(formula, data = data_test, refit = refit)
}
if (is.null(attr(terms(formula(formula)), "offset"))) {
offset <- FALSE
} else {
offset <- TRUE
}
# Ensure fitting software can be located
if (!use_stan & run_model) {
find_jags()
}
if (use_stan & run_model) {
find_stan()
}
# Validate the family and threads arguments
family <- validate_family(family, use_stan = use_stan)
family_char <- match.arg(arg = family$family, choices = family_char_choices())
threads <- validate_threads(family_char, threads)
# Nmixture additions?
list2env(
check_nmix(
family,
family_char,
trend_formula,
trend_model,
trend_map,
data_train
),
envir = environment()
)
# Validate remaining trend arguments
trend_val <- validate_trend_restrictions(
trend_model = trend_model,
formula = formula,
trend_formula = trend_formula,
trend_map = trend_map,
drift = drift,
drop_obs_intercept = drop_obs_intercept,
use_lv = use_lv,
n_lv = n_lv,
data_train = data_train,
use_stan = use_stan
)
list2env(trend_val, envir = environment())
if (is.null(trend_map)) {
trend_map <- rlang::missing_arg()
}
if (is.null(n_lv)) {
n_lv <- rlang::missing_arg()
}
# Some general family-level restrictions can now be checked
orig_y <- data_train$y
if (any(!is.na(orig_y))) {
validate_family_restrictions(response = orig_y, family = family)
}
# Fill in missing observations in data_train so the size of the dataset is correct when
# building the initial JAGS model
resp_terms <- as.character(terms(formula(formula))[[2]])
if (length(resp_terms) == 1) {
out_name <- as.character(terms(formula(formula))[[2]])
} else {
if (any(grepl("cbind", resp_terms))) {
resp_terms <- resp_terms[-grepl("cbind", resp_terms)]
out_name <- resp_terms[1]
}
}
data_train[[out_name]] <- replace_nas(data_train[[out_name]])
# Compute default priors
if (use_stan) {
def_priors <- adapt_brms_priors(
c(
make_default_scales(orig_y, family),
make_default_int(
orig_y,
family = if (add_nmix) {
nmix()
} else {
family
}
)
),
formula = orig_formula,
trend_formula = trend_formula,
data = orig_data,
family = family,
use_lv = use_lv,
n_lv = n_lv,
trend_model = orig_trend_model,
trend_map = trend_map,
drift = drift,
knots = knots
)
}
# Initiate the GAM model using mgcv so that the linear predictor matrix can be easily calculated
# when simulating from the Bayesian model later on;
ss_gam <- try(
mvgam_setup(
formula = formula,
knots = knots,
family = family_to_mgcvfam(family),
dat = data_train
),
silent = TRUE
)
if (inherits(ss_gam, "try-error")) {
if (grepl("missing values", ss_gam[1])) {
stop(
paste(
"Missing values found in data predictors:\n",
attr(ss_gam, "condition")
),
call. = FALSE
)
} else {
stop(paste(ss_gam[1]), call. = FALSE)
}
}
# Check the test data for NAs as well using predict.gam
testdat_pred <- try(
predict(ss_gam, newdata = data_test, na.action = na.fail),
silent = TRUE
)
if (inherits(testdat_pred, "try-error")) {
if (grepl("missing values", testdat_pred[1])) {
stop(
paste(
"Missing values found in newdata predictors:\n",
attr(testdat_pred, "condition")
),
call. = FALSE
)
}
}
# Make JAGS file and appropriate data structures
list2env(
jagam_setup(
ss_gam = ss_gam,
formula = formula,
data_train = data_train,
family = family,
family_char = family_char,
knots = knots
),
envir = environment()
)
# Update initial values of lambdas using the full estimates from the
# fitted gam model to speed convergence; remove initial betas so that the
# chains can start in very different regions of the parameter space
ss_jagam$jags.ini$b <- NULL
if (length(ss_gam$sp) == length(ss_jagam$jags.ini$lambda)) {
ss_jagam$jags.ini$lambda <- ss_gam$sp
ss_jagam$jags.ini$lambda[log(ss_jagam$jags.ini$lambda) > 10] <- exp(10)
}
if (length(ss_gam$smooth) == 0) {
ss_jagam$jags.ini$lambda <- NULL
}
# Fill y with NAs if this is a simulation from the priors;
# otherwise replace with the original supplied values
data_train <- check_priorsim(prior_simulation, data_train, orig_y, formula)
# Read in the base (unmodified) jags model file
base_model <- suppressWarnings(readLines(file_name))
# Remove lines from the linear predictor section
lines_remove <- c(1:grep("## response", base_model))
base_model <- base_model[-lines_remove]
if (any(grepl("scale <- 1/tau", base_model, fixed = TRUE))) {
base_model <- base_model[-grep("scale <- 1/tau", base_model, fixed = TRUE)]
}
if (any(grepl("tau ~ dgamma(.05,.005)", base_model, fixed = TRUE))) {
base_model <- base_model[
-grep("tau ~ dgamma(.05,.005)", base_model, fixed = TRUE)
]
}
# Any parametric effects in the gam (particularly the intercept) need sensible priors to ensure they
# do not directly compete with the latent trends
if (any(grepl("Parametric effect priors", base_model))) {
in_parenth <- regmatches(
base_model[grep("Parametric effect priors", base_model) + 1],
gregexpr(
"(?<=\\().+?(?=\\))",
base_model[grep("Parametric effect priors", base_model) + 1],
perl = T
)
)[[1]][1]
n_terms <- as.numeric(sub(".*:", "", in_parenth))
ss_jagam$jags.data$p_coefs <- coef(ss_gam)[1:n_terms]
# Use the initialised GAM's estimates for parametric effects, but widen them
# substantially to allow for better exploration
beta_sims <- rmvn(100, coef(ss_gam), ss_gam$Vp)
ss_jagam$jags.data$p_taus <- apply(
as.matrix(beta_sims[, 1:n_terms]),
2,
function(x) 1 / (sd(x)^2)
)
base_model[grep("Parametric effect priors", base_model) + 1] <- paste0(
" for (i in 1:",
n_terms,
") { b[i] ~ dnorm(p_coefs[i], p_taus[i]) }"
)
base_model[grep("Parametric effect priors", base_model)] <- c(
" ## parametric effect priors (regularised for identifiability)"
)
}
# For any random effect smooths, use non-centred parameterisation to avoid degeneracies
# For monotonic smooths, need to determine which direction to place
# coefficient constraints
smooth_labs <- do.call(
rbind,
lapply(seq_along(ss_gam$smooth), function(x) {
data.frame(
label = ss_gam$smooth[[x]]$label,
class = class(ss_gam$smooth[[x]])[1],
id = ifelse(is.null(ss_gam$smooth[[x]]$id), NA, ss_gam$smooth[[x]]$id)
)
})
)
# Check for 'id' arguments, which are not yet supported
if (any(!is.na(smooth_labs$id))) {
stop(
'smooth terms with the "id" argument not yet supported by mvgam',
call. = FALSE
)
}
if (any(smooth_labs$class == "random.effect")) {
re_smooths <- smooth_labs %>%
dplyr::filter(class == "random.effect") %>%
dplyr::pull(label)
for (i in 1:length(re_smooths)) {
# If there are multiple smooths with this label, find out where the random effect
# smooth sits
smooth_labs %>%
dplyr::filter(label == re_smooths[i]) %>%
dplyr::mutate(smooth_number = dplyr::row_number()) %>%
dplyr::filter(class == "random.effect") %>%
dplyr::pull(smooth_number) -> smooth_number
in_parenth <- regmatches(
base_model[
grep(re_smooths[i], base_model, fixed = T)[smooth_number] + 1
],
gregexpr(
"(?<=\\().+?(?=\\))",
base_model[
grep(re_smooths[i], base_model, fixed = T)[smooth_number] + 1
],
perl = T
)
)[[1]][1]
n_terms <- as.numeric(sub(".*:", "", in_parenth))
n_start <- as.numeric(strsplit(sub(".*\\(", "", in_parenth), ":")[[1]][1])
base_model[
grep(re_smooths[i], base_model, fixed = T)[smooth_number] + 1
] <- paste0(
" for (i in ",
n_start,
":",
n_terms,
") {\n b_raw[i] ~ dnorm(0, 1)\n",
"b[i] <- ",
paste0("mu_raw", i),
" + b_raw[i] * ",
paste0("sigma_raw", i),
"\n }\n ",
paste0("sigma_raw", i),
" ~ dexp(0.5)\n",
paste0("mu_raw", i),
" ~ dnorm(0, 1)"
)
base_model[grep(re_smooths[i], base_model, fixed = T)[
smooth_number
]] <- paste0(" ## prior (non-centred) for ", re_smooths[i], "...")
}
}
base_model[grep("smoothing parameter priors", base_model)] <- c(
" ## smoothing parameter priors..."
)
# Remove the fakery lines if they were added
if (!smooths_included) {
base_model <- base_model[
-c(
grep("## prior for s(fakery)", trimws(base_model), fixed = TRUE):(grep(
"## prior for s(fakery)",
trimws(base_model),
fixed = TRUE
) +
7)
)
]
}
# Add replacement lines for priors, trends and the linear predictor
fil <- tempfile(fileext = ".xt")
modification <- add_base_dgam_lines(use_lv)
cat(
c(readLines(textConnection(modification)), base_model),
file = fil,
sep = "\n"
)
model_file <- trimws(readLines(fil, n = -1))
# Modify observation distribution lines
if (family_char == "tweedie") {
model_file <- add_tweedie_lines(model_file, upper_bounds = upper_bounds)
} else if (family_char == "poisson") {
model_file <- add_poisson_lines(model_file, upper_bounds = upper_bounds)
} else {
if (missing(upper_bounds)) {
model_file[grep(
"y\\[i, s\\] ~",
model_file
)] <- " y[i, s] ~ dnegbin(rate[i, s], phi[s])"
model_file[grep(
"ypred\\[i, s\\] ~",
model_file
)] <- " ypred[i, s] ~ dnegbin(rate[i, s], phi[s])"
}
}
# Modify lines needed for the specified trend model
model_file <- add_trend_lines(
model_file,
stan = FALSE,
use_lv = use_lv,
trend_model = if (
trend_model %in%
c("RW", "VAR1", "PWlinear", "PWlogistic", "ZMVN")
) {
"RW"
} else {
trend_model
},
drift = drift
)
# Use informative priors based on the fitted mgcv model to speed convergence
# and eliminate searching over strange parameter spaces
if (length(ss_gam$sp) == length(ss_jagam$jags.ini$lambda)) {
model_file[grep(
"lambda\\[i\\] ~",
model_file
)] <- " lambda[i] ~ dexp(1/sp[i])"
} else {
model_file[grep(
"lambda\\[i\\] ~",
model_file
)] <- " lambda[i] ~ dexp(0.05)"
}
# Final tidying of the JAGS model for readability
clean_up <- vector()
for (x in 1:length(model_file)) {
clean_up[x] <- model_file[x - 1] == "" & model_file[x] == ""
}
clean_up[is.na(clean_up)] <- FALSE
model_file <- model_file[!clean_up]
# Add in the offset if needed
if (offset) {
model_file[grep("eta <- X %*% b", model_file, fixed = TRUE)] <-
"eta <- X %*% b + offset"
model_file[grep("eta <- X * b", model_file, fixed = TRUE)] <-
"eta <- X * b + offset"
if (!missing(data_test) & !prior_simulation) {
ss_jagam$jags.data$offset <- c(
ss_jagam$jags.data$offset,
data_test[[get_offset(ss_gam)]]
)
}
}
model_file_jags <- textConnection(model_file)
# Covariate dataframe including training and testing observations
if (!missing(data_test) & !prior_simulation) {
suppressWarnings(
lp_test <- try(
predict(ss_gam, newdata = data_test, type = "lpmatrix"),
silent = TRUE
)
)
if (inherits(lp_test, "try-error")) {
testdat <- data.frame(time = data_test$index..time..index)
terms_include <- names(ss_gam$coefficients)[which(
!names(ss_gam$coefficients) %in% "(Intercept)"
)]
if (length(terms_include) > 0) {
newnames <- vector()
newnames[1] <- "time"
for (i in 1:length(terms_include)) {
testdat <- cbind(testdat, data.frame(data_test[[terms_include[i]]]))
newnames[i + 1] <- terms_include[i]
}
colnames(testdat) <- newnames
}
suppressWarnings(
lp_test <- predict(ss_gam, newdata = testdat, type = "lpmatrix")
)
}
# Remove fakery columns from design matrix if no smooth terms were included
if (!smooths_included) {
ss_jagam$jags.data$X <- as.matrix(
ss_jagam$jags.data$X[, -c(xcols_drop)],
ncol = NCOL(lp_test)
)
}
X <- data.frame(rbind(ss_jagam$jags.data$X, lp_test))
# Add a time variable
if (inherits(data_train, "list")) {
temp_dat_train <- data.frame(
index..time..index = data_train$index..time..index,
series = data_train$series
)
temp_dat_test <- data.frame(
index..time..index = data_test$index..time..index,
series = data_test$series
)
X$index..time..index <- rbind(temp_dat_train, temp_dat_test) %>%
dplyr::left_join(
rbind(temp_dat_train, temp_dat_test) %>%
dplyr::select(index..time..index) %>%
dplyr::distinct() %>%
dplyr::arrange(index..time..index) %>%
dplyr::mutate(index..time..index = dplyr::row_number()),
by = c("index..time..index")
) %>%
dplyr::pull(index..time..index)
# Add a series identifier variable
X$series <- as.numeric(rbind(temp_dat_train, temp_dat_test)$series)
# Add an outcome variable
X$outcome <- c(orig_y, rep(NA, NROW(temp_dat_test)))
} else {
if (NCOL(data_train) != NCOL(data_test)) {
stop(
'"data" and "newdata" have different numbers of columns',
call. = FALSE
)
}
X$index..time..index <- dplyr::bind_rows(data_train, data_test) %>%
dplyr::left_join(
dplyr::bind_rows(data_train, data_test) %>%
dplyr::select(index..time..index) %>%
dplyr::distinct() %>%
dplyr::arrange(index..time..index) %>%
dplyr::mutate(index..time..index = dplyr::row_number()),
by = c("index..time..index")
) %>%
dplyr::pull(index..time..index)
# Add a series identifier variable
X$series <- as.numeric(dplyr::bind_rows(data_train, data_test)$series)
# Add an outcome variable
X$outcome <- c(data_train$y, rep(NA, NROW(data_test)))
}
} else {
X <- data.frame(ss_jagam$jags.data$X)
# Remove fakery columns from design matrix if no smooth terms were included
if (!smooths_included) {
X[, xcols_drop] <- NULL
}
if (inherits(data_train, "list")) {
temp_dat <- data.frame(index..time..index = data_train$index..time..index)
X$index..time..index <- temp_dat %>%
dplyr::left_join(
temp_dat %>%
dplyr::select(index..time..index) %>%
dplyr::distinct() %>%
dplyr::arrange(index..time..index) %>%
dplyr::mutate(index..time..index = dplyr::row_number()),
by = c("index..time..index")
) %>%
dplyr::pull(index..time..index)
} else {
X$index..time..index <- data_train %>%
dplyr::left_join(
data_train %>%
dplyr::select(index..time..index) %>%
dplyr::distinct() %>%
dplyr::arrange(index..time..index) %>%
dplyr::mutate(index..time..index = dplyr::row_number()),
by = c("index..time..index")
) %>%
dplyr::pull(index..time..index)
}
X$outcome <- c(data_train$y)
X$series <- as.numeric(data_train$series)
}
# Arrange by time then by series
X %>% dplyr::arrange(index..time..index, series) -> X
# Matrix of indices in X that correspond to timepoints for each series
ytimes <- matrix(
NA,
nrow = length(unique(X$index..time..index)),
ncol = length(unique(X$series))
)
for (i in 1:length(unique(X$series))) {
ytimes[, i] <- which(X$series == i)
}
ss_jagam$jags.data$ytimes <- ytimes
# Matrix of outcomes in X that correspond to each series at each timepoint
ys_mat <- matrix(NA, nrow = NROW(ytimes), ncol = NCOL(ytimes))
for (i in 1:length(unique(X$series))) {
ys_mat[, i] <- X$outcome[which(X$series == i)]
}
ss_jagam$jags.data$y <- ys_mat
# Other necessary variables
ss_jagam$jags.data$n <- NROW(ytimes)
ss_jagam$jags.data$n_series <- NCOL(ytimes)
ss_jagam$jags.data$X <- as.matrix(
X %>%
dplyr::select(-index..time..index, -series, -outcome)
)
if (NCOL(ss_jagam$jags.data$X) == 1) {
if (offset) {
model_file[grep(
"eta <-",
model_file,
fixed = TRUE
)] <- "eta <- X * b + offset"
} else {
model_file[grep("eta <-", model_file, fixed = TRUE)] <- "eta <- X * b"
}
}
if (!missing(upper_bounds)) {
ss_jagam$jags.data$upper_bound <- upper_bounds
}
if (length(ss_gam$sp) == length(ss_jagam$jags.ini$lambda)) {
ss_jagam$jags.data$sp <- ss_gam$sp
}
# Machine epsilon for minimum allowable non-zero rate
if (family_char == "negative binomial") {
ss_jagam$jags.data$min_eps <- .Machine$double.eps
}
# Number of latent variables to use
if (use_lv) {
if (missing(n_lv)) {
ss_jagam$jags.data$n_lv <- min(2, floor(ss_jagam$jags.data$n_series / 2))
} else {
ss_jagam$jags.data$n_lv <- n_lv
ss_jagam$jags.ini$X1 <- rep(1, n_lv)
ss_jagam$jags.ini$X2 <- 1
}
if (ss_jagam$jags.data$n_lv > ss_jagam$jags.data$n_series) {
stop("Number of latent variables cannot be greater than number of series")
}
}
if (missing(upper_bounds)) {
upper_bounds <- NULL
}
if (use_lv) {
n_lv <- ss_jagam$jags.data$n_lv
} else {
if (missing(trend_map)) {
n_lv <- NULL
}
}
if (missing(data_test)) {
data_test <- NULL
}
# Remove Smooth penalty matrix if no smooths were used in the formula
if (!smooths_included) {
if (any(grepl("S.*", names(ss_jagam$jags.data)))) {
ss_jagam$jags.data[[grep("S.*", names(ss_jagam$jags.data))]] <- NULL
ss_jagam$jags.data$sp <- NULL
}
ss_jagam$jags.data$zero <- NULL
}
# Add information about the call and necessary data structures to the model file
# Get dimensions and numbers of smooth terms
snames <- names(ss_jagam$jags.data)[grep("S.*", names(ss_jagam$jags.data))]
if (length(snames) == 0) {
smooth_penalty_data <- NULL
} else {
smooth_dims <- matrix(NA, ncol = 2, nrow = length(snames))
for (i in 1:length(snames)) {
smooth_dims[i, ] <- dim(ss_jagam$jags.data[[snames[i]]])
}
smooth_penalty_data <- vector()
for (i in 1:length(snames)) {
smooth_penalty_data[i] <- paste0(
"matrix ",
snames[i],
"; mgcv smooth penalty matrix ",
snames[i]
)
}
}
if ("sp" %in% names(ss_jagam$jags.data)) {
if (length(ss_jagam$jags.data$sp) == 1) {
sp_data <- c(
paste0(
"real sp; inverse exponential location prior for smoothing parameter ",
paste0(names(ss_jagam$jags.data$sp))
),
"___________values ranging 5 - 50 are a good start"
)
} else {
sp_data <- c(
paste0(
"vector sp; inverse exponential location priors for smoothing parameters: ",
paste0(names(ss_jagam$jags.data$sp), collapse = "; ")
),
"___________values ranging 5 - 50 are a good start"
)
}
} else {
sp_data <- NULL
}
if ("p_coefs" %in% names(ss_jagam$jags.data)) {
parametric_ldata <- paste0(
"vector p_coefs; vector (length = ",
length(ss_jagam$jags.data$p_coefs),
") of prior Gaussian means for parametric effects"
)
} else {
parametric_ldata <- NULL
}
if ("p_taus" %in% names(ss_jagam$jags.data)) {
parametric_tdata <- paste0(
"vector p_taus; vector (length = ",
length(ss_jagam$jags.data$p_coefs),
") of prior Gaussian precisions for parametric effects"
)
} else {
parametric_tdata <- NULL
}
# A second check for any smooth parameters
if (any(grep("lambda", model_file, fixed = TRUE))) {
smooths_included <- TRUE
} else {
smooths_included <- smooths_included
}
if (any(grep("K.* <- ", model_file))) {
smooths_included <- TRUE
} else {
smooths_included <- smooths_included
}
# Add in additional data structure information for the model file heading
if (family_char == "negative binomial") {
min_eps <- paste0(
"min_eps; .Machine$double.eps (smallest floating-point number x such that 1 + x != 1)\n"
)
} else {
min_eps <- NULL
}
if (smooths_included) {
zeros <- paste0(
"vector zero; prior basis coefficient locations vector of length ncol(X)\n"
)
} else {
zeros <- NULL
}
if (offset) {
offset_line <- paste0("offset; offset vector of length (n x n_series)\n")
} else {
offset_line <- NULL
}
model_file <- c(
"JAGS model code generated by package mvgam",
"\n",
"GAM formula:",
gsub('\"', "", paste(formula[2], formula[3], sep = " ~ ")),
"\n",
"Trend model:",
trend_model,
"\n",
"Required data:",
"integer n; number of timepoints per series\n",
"integer n_series; number of series\n",
"matrix y; time-ordered observations of dimension n x n_series (missing values allowed)\n",
"matrix ytimes; time-ordered n x n_series matrix (which row in X belongs to each [time, series] observation?)\n",
"matrix X; mgcv GAM design matrix of dimension (n x n_series) x basis dimension\n",
paste0(smooth_penalty_data),
offset_line,
zeros,
paste0(parametric_ldata),
paste0(parametric_tdata),
sp_data,
min_eps,
"\n",
model_file
)
# Get names of smoothing parameters
if (smooths_included) {
ss_gam$off <- ss_jagam$pregam$off
ss_gam$S <- ss_jagam$pregam$S
name_starts <- unlist(purrr::map(ss_jagam$pregam$smooth, "first.sp"))
name_ends <- unlist(purrr::map(ss_jagam$pregam$smooth, "last.sp"))
rho_names <- unlist(lapply(seq(1:length(ss_gam$smooth)), function(i) {
number_seq <- seq(1:(1 + name_ends[i] - name_starts[i]))
number_seq[1] <- ""
paste0(rep(ss_gam$smooth[[i]]$label, length(number_seq)), number_seq)
}))
} else {
rho_names <- NA
}
#### Set up model file and modelling data ####
if (use_stan) {
algorithm <- match.arg(
algorithm,
c("sampling", "meanfield", "fullrank", "pathfinder", "laplace")
)
backend <- match.arg(backend, c("rstan", "cmdstanr"))
cmdstan_avail <- insight::check_if_installed(
"cmdstanr",
stop = FALSE,
quietly = TRUE
)
if (isTRUE(cmdstan_avail)) {
if (is.null(cmdstanr::cmdstan_version(error_on_NA = FALSE))) {
backend <- "rstan"
}
}
fit_engine <- "stan"
use_cmdstan <- ifelse(backend == "cmdstanr", TRUE, FALSE)
# Import the base Stan model file
modification <- add_base_dgam_lines(stan = TRUE, use_lv = use_lv)
unlink("base_gam_stan.txt")
stanfile_name <- tempfile(pattern = "base_gam_stan", fileext = ".txt")
cat(modification, file = stanfile_name, sep = "\n", append = T)
base_stan_model <- trimws(suppressWarnings(readLines(stanfile_name)))
unlink(stanfile_name)
# Add necessary trend structure
base_stan_model <- add_trend_lines(
model_file = base_stan_model,
stan = TRUE,
trend_model = if (
trend_model %in% c("RW", "VAR1", "PWlinear", "PWlogistic", "ZMVN")
) {
"RW"
} else {
trend_model
},
use_lv = use_lv,
drift = drift
)
# Add remaining data, model and parameters blocks to the Stan model file;
# gather Stan data structure
stan_objects <- add_stan_data(
jags_file = trimws(model_file),
stan_file = base_stan_model,
ss_gam = ss_gam,
use_lv = use_lv,
n_lv = n_lv,
jags_data = ss_jagam$jags.data,
family = ifelse(
family_char %in% c("binomial", "bernoulli", "beta_binomial"),
"poisson",
family_char
),
upper_bounds = upper_bounds
)
if (use_lv || !missing(trend_map)) {
stan_objects$model_data$n_lv <- n_lv
}
# Set monitor parameters
param <- get_monitor_pars(
family = family_char,
use_lv = use_lv,
trend_model = trend_model,
smooths_included = stan_objects$smooths_included,
drift = drift
)
if (any(smooth_labs$class == "random.effect")) {
param <- c(param, "mu_raw", "sigma_raw")
}
# Don't place inits when using Stan; may add options later for users
# to supply them though
inits <- NULL
# Include any GP term updates
if (!is.null(gp_terms)) {
gp_additions <- make_gp_additions(
gp_details = gp_details,
orig_formula = orig_formula,
data = data_train,
newdata = data_test,
model_data = stan_objects$model_data,
mgcv_model = ss_gam,
gp_terms = gp_terms,
family = family,
rho_names = rho_names
)
stan_objects$model_data <- gp_additions$model_data
ss_gam <- gp_additions$mgcv_model
rho_names <- gp_additions$rho_names
}
# Vectorise likelihoods
vectorised <- vectorise_stan_lik(
model_file = stan_objects$stan_file,
model_data = stan_objects$model_data,
family = family_char,
threads = threads,
trend_model = trend_model,
use_lv = use_lv,
offset = offset,
drift = drift
)
# If a VAR model is used, enforce stationarity using methods described by
# Heaps 2022 (Enforcing stationarity through the prior in vector autoregressions)
if (use_var1) {
vectorised$model_file <- stationarise_VAR(vectorised$model_file)
}
if (use_var1cor) {
param <- c(param, "L_Omega")
vectorised$model_file <- stationarise_VARcor(vectorised$model_file)
}
# Add modifications for trend mapping and trend predictors, if
# supplied
trend_sp_names <- NA
if (!missing(trend_map)) {
trend_map_setup <- trend_map_mods(
model_file = vectorised$model_file,
model_data = vectorised$model_data,
trend_map = trend_map,
data_train = data_train,
ytimes = ytimes,
n_lv = n_lv,
trend_model = trend_model
)
vectorised$model_file <- trend_map_setup$model_file
vectorised$model_data <- trend_map_setup$model_data
if (
trend_model %in% c("None", "RW", "AR1", "AR2", "AR3", "CAR1", "ZMVN")
) {
param <- unique(c(param, "trend", "sigma"))
}
# If trend formula specified, add the predictors for the trend models
if (!missing(trend_formula)) {
if (missing(trend_knots)) {
trend_knots <- missing_arg()
}
trend_pred_setup <- add_trend_predictors(
trend_formula = trend_formula,
trend_knots = trend_knots,
trend_map = trend_map,
trend_model = trend_model,
data_train = data_train,
data_test = if (missing(data_test)) {
NULL
} else {
data_test
},
model_file = vectorised$model_file,
model_data = vectorised$model_data,
drop_trend_int = FALSE,
drift = drift
)
vectorised$model_file <- trend_pred_setup$model_file
vectorised$model_data <- trend_pred_setup$model_data
trend_mgcv_model <- trend_pred_setup$trend_mgcv_model
param <- unique(c(param, "trend", "b_trend", "trend_mus"))
if (trend_pred_setup$trend_smooths_included) {
param <- c(param, "rho_trend", "lambda_trend")
}
if (trend_pred_setup$trend_random_included) {
param <- c(param, "mu_raw_trend", "sigma_raw_trend")
}
trend_sp_names <- trend_pred_setup$trend_sp_names
} else {}
if (trend_model == "VAR1") {
param <- c(param, "lv_coefs", "LV")
use_lv <- TRUE
}
}
# Update default priors
vectorised$model_file <- suppressWarnings(update_priors(
vectorised$model_file,
def_priors,
use_stan = TRUE
))
# Drop observation intercept if specified
if (drop_obs_intercept) {
if (
any(grepl(
"// observation model basis coefficients",
vectorised$model_file,
fixed = TRUE
))
) {
vectorised$model_file[
grep(
"// observation model basis coefficients",
vectorised$model_file,
fixed = TRUE
) +
1
] <-
paste0(
vectorised$model_file[
grep(
"// observation model basis coefficients",
vectorised$model_file,
fixed = TRUE
) +
1
],
"\n",
"// (Intercept) fixed at zero\n",
"b[1] = 0;"
)
} else {
vectorised$model_file[grep(
"b[1:num_basis] = b_raw[1:num_basis]",
vectorised$model_file,
fixed = TRUE
)] <-
paste0(
"b[1:num_basis] = b_raw[1:num_basis];\n",
"// (Intercept) fixed at zero\n",
"b[1] = 0;"
)
}
vectorised$model_file <- readLines(
textConnection(vectorised$model_file),
n = -1
)
attr(ss_gam, "drop_obs_intercept") <- TRUE
} else {
attr(ss_gam, "drop_obs_intercept") <- FALSE
}
# Remaining model file updates for any GP terms
if (!is.null(gp_terms)) {
final_gp_updates <- add_gp_model_file(
model_file = vectorised$model_file,
model_data = vectorised$model_data,
mgcv_model = ss_gam,
gp_additions = gp_additions
)
vectorised$model_file <- final_gp_updates$model_file
vectorised$model_data <- final_gp_updates$model_data
}
# Update monitor pars for any GP terms
if (
any(grepl(
"real alpha_gp",
vectorised$model_file,
fixed = TRUE
)) &
!lfo
) {
alpha_params <- trimws(gsub(
";",
"",
gsub(
"real ",
"",
grep(
"real alpha_gp",
vectorised$model_file,
fixed = TRUE,
value = TRUE
),
fixed = TRUE
)
))
rho_params <- trimws(gsub(
";",
"",
gsub(
"real ",
"",
grep(
"real rho_gp",
vectorised$model_file,
fixed = TRUE,
value = TRUE
),
fixed = TRUE
)
))
param <- c(param, alpha_params, rho_params)
}
# Update for any monotonic term updates
if (any(smooth_labs$class %in% c("moi.smooth", "mod.smooth"))) {
final_mono_updates <- add_mono_model_file(
model_file = vectorised$model_file,
model_data = vectorised$model_data,
mgcv_model = ss_gam
)
vectorised$model_file <- final_mono_updates$model_file
vectorised$model_data <- final_mono_updates$model_data
}
# Update for any piecewise trends
if (trend_model %in% c("PWlinear", "PWlogistic")) {
pw_additions <- add_piecewise(
vectorised$model_file,
vectorised$model_data,
data_train,
data_test,
orig_trend_model,
family
)
vectorised$model_file <- pw_additions$model_file
vectorised$model_data <- pw_additions$model_data
orig_trend_model$changepoints <- pw_additions$model_data$t_change
orig_trend_model$change_freq <- pw_additions$model_data$change_freq
orig_trend_model$cap <- pw_additions$model_data$cap
}
# Update for CAR1 trends
if (trend_model == "CAR1") {
vectorised$model_data <- add_corcar(
vectorised$model_data,
data_train,
data_test
)
}
# Updates for Binomial and Bernoulli families
if (family_char %in% c("binomial", "bernoulli", "beta_binomial")) {
bin_additions <- add_binomial(
formula,
vectorised$model_file,
vectorised$model_data,
data_train,
data_test,
family_char
)
vectorised$model_file <- bin_additions$model_file
vectorised$model_data <- bin_additions$model_data
attr(ss_gam, "trials") <- bin_additions$trials
}
# Add in any user-specified priors
if (!missing(priors)) {
vectorised$model_file <- update_priors(
vectorised$model_file,
priors,
use_stan = TRUE
)
} else {
priors <- NULL
}
# Check if non-centering can be used
nc_check <- check_noncent(
model_file = vectorised$model_file,
noncentred = noncentred,
use_lv = use_lv,
trend_map = trend_map,
add_ma = add_ma,
add_cor = add_cor,
trend_model = trend_model,
drift = drift,
silent = silent,
nmix = add_nmix
)
vectorised$model_file <- nc_check$model_file
noncentred <- nc_check$noncentred
# Add any correlated error or moving average processes; this comes after
# priors as currently there is no option to change priors on these parameters
if (add_ma | add_cor) {
MaCor_additions <- add_MaCor(
model_file = vectorised$model_file,
model_data = vectorised$model_data,
data_train = data_train,
data_test = data_test,
add_ma = add_ma,
add_cor = add_cor,
trend_model = orig_trend_model
)
vectorised$model_file <- MaCor_additions$model_file
vectorised$model_data <- MaCor_additions$model_data
}
# Add updates for an N-mixture model
if (add_nmix) {
nmix_additions <- add_nmixture(
vectorised$model_file,
vectorised$model_data,
orig_trend_model = orig_trend_model,
data_train = data_train,
data_test = data_test,
trend_map = trend_map,
nmix_trendmap = nmix_trendmap
)
vectorised$model_file <- nmix_additions$model_file
vectorised$model_data <- nmix_additions$model_data
family <- nmix()
family_char <- "nmix"
# Nmixtures don't use generated quantities because it is faster
# to produce these in R after sampling has finished
param <- c(param, "p")
param <- param[
!param %in%
c(
"ypred",
"mus",
"theta",
"detprob",
"latent_ypred",
"lv_coefs",
"error"
)
]
}
# Updates for sharing of observation params
if (share_obs_params) {
vectorised$model_file <- shared_obs_params(
vectorised$model_file,
family_char
)
}
# Tidy the representation
vectorised$model_file <- sanitise_modelfile(vectorised$model_file)
if (requireNamespace("cmdstanr", quietly = TRUE) & backend == "cmdstanr") {
# Replace new syntax if this is an older version of Stan
if (cmdstanr::cmdstan_version() < "2.26") {
warning(
"Your version of CmdStan is out of date. Some features of mvgam may not work"
)
vectorised$model_file <-
gsub(
"array[n, n_series] int ypred;",
"int ypred[n, n_series];",
vectorised$model_file,
fixed = TRUE
)
vectorised$model_file <-
gsub(
"array[n, n_series] real ypred;",
"real ypred[n, n_series];",
vectorised$model_file,
fixed = TRUE
)
}
# Auto-format the model file
if (autoformat) {
if (
requireNamespace("cmdstanr") &
cmdstanr::cmdstan_version() >= "2.29.0"
) {
vectorised$model_file <- .autoformat(
vectorised$model_file,
overwrite_file = FALSE,
backend = "cmdstanr",
silent = silent >= 1L
)
}
vectorised$model_file <- readLines(
textConnection(vectorised$model_file),
n = -1
)
}
} else {
if (autoformat) {
vectorised$model_file <- .autoformat(
vectorised$model_file,
overwrite_file = FALSE,
backend = "rstan",
silent = silent >= 1L
)
vectorised$model_file <- readLines(
textConnection(vectorised$model_file),
n = -1
)
}
# Replace new syntax if this is an older version of Stan
if (rstan::stan_version() < "2.26") {
warning(
"Your version of rstan is out of date. Some features of mvgam may not work"
)
vectorised$model_file <-
gsub(
"array[n, n_series] int ypred;",
"int ypred[n, n_series];",
vectorised$model_file,
fixed = TRUE
)
}
}
attr(vectorised$model_data, "trend_model") <- trend_model
# Remove data likelihood if this is a prior sampling run
if (prior_simulation) {
vectorised$model_file <- remove_likelihood(vectorised$model_file)
}
} else {
# Set up data and model file for JAGS
attr(ss_jagam$jags.data, "trend_model") <- trend_model
trend_sp_names <- NA
if (!smooths_included) {
inits <- NULL
} else {
inits <- ss_jagam$jags.ini
}
initlist <- replicate(chains, inits, simplify = FALSE)
inits <- initlist
if (!missing(priors)) {
model_file <- update_priors(model_file, priors, use_stan = FALSE)
} else {
priors <- NULL
}
# Set monitor parameters and initial values
param <- get_monitor_pars(
family_char,
smooths_included = smooths_included,
use_lv,
trend_model,
drift
)
# Add random effect parameters for monitoring
if (any(smooth_labs$class == "random.effect")) {
param <- c(param, paste0("mu_raw", 1:length(re_smooths)))
param <- c(param, paste0("sigma_raw", 1:length(re_smooths)))
}
}
# Remove lp__ from monitor params if VB is to be used
if (algorithm %in% c("meanfield", "fullrank", "pathfinder", "laplace")) {
param <- param[!param %in% "lp__"]
}
# Lighten up the mgcv model(s) to reduce size of the returned object
ss_gam <- trim_mgcv(ss_gam)
if (!missing(trend_formula)) {
trend_mgcv_model <- trim_mgcv(trend_mgcv_model)
}
#### Return only the model file and all data / inits needed to run the model
# outside of mvgam ####
if (!run_model) {
unlink("base_gam.txt")
output <- structure(
list(
call = orig_formula,
trend_call = if (!missing(trend_formula)) {
trend_formula
} else {
NULL
},
family = family_char,
share_obs_params = share_obs_params,
trend_model = orig_trend_model,
trend_map = if (!missing(trend_map)) {
trend_map
} else {
NULL
},
drift = FALSE,
priors = priors,
model_file = if (use_stan) {
vectorised$model_file
} else {
trimws(model_file)
},
model_data = if (use_stan) {
vectorised$model_data
} else {
ss_jagam$jags.data
},
inits = inits,
monitor_pars = param,
mgcv_model = ss_gam,
trend_mgcv_model = if (!missing(trend_formula)) {
trend_mgcv_model
} else {
NULL
},
sp_names = rho_names,
trend_sp_names = trend_sp_names,
ytimes = ytimes,
use_lv = use_lv,
n_lv = n_lv,
upper_bounds = upper_bounds,
obs_data = data_train,
test_data = data_test,
fit_engine = if (use_stan) {
"stan"
} else {
"jags"
},
backend = if (use_stan) {
backend
} else {
"rjags"
},
algorithm = if (use_stan) {
algorithm
} else {
"sampling"
},
max_treedepth = NULL,
adapt_delta = NULL
),
class = "mvgam_prefit"
)
#### Else if running the model, complete the setup for fitting ####
} else {
# If this is a lfo_cv run, trim down parameters to monitor so post-processing
# is faster
if (lfo) {
to_remove <- c(
"trend",
"b_trend",
"b",
"b_raw",
"rho",
"sigma",
"alpha_gp",
"rho_gp",
"ar1",
"ar2",
"ar3",
"LV",
"lv_coefs",
"penalty",
"Sigma",
"theta",
"error"
)
param <- param[!param %in% to_remove]
}
if (use_stan) {
model_data <- vectorised$model_data
# Check if cmdstan is accessible; if not, use rstan
if (backend == "cmdstanr") {
if (!requireNamespace("cmdstanr", quietly = TRUE)) {
if (silent < 2) {
message("cmdstanr library not found; defaulting to rstan")
}
use_cmdstan <- FALSE
} else {
use_cmdstan <- TRUE
if (is.null(cmdstanr::cmdstan_version(error_on_NA = FALSE))) {
warning(
"cmdstanr library found but Cmdstan not found. Defaulting to rstan"
)
use_cmdstan <- FALSE
}
}
}
if (use_cmdstan) {
# Prepare threading and generate the model
cmd_mod <- .model_cmdstanr(
vectorised$model_file,
threads = threads,
silent = silent
)
# Condition the model using Cmdstan
out_gam_mod <- .sample_model_cmdstanr(
model = cmd_mod,
algorithm = algorithm,
prior_simulation = prior_simulation,
data = model_data,
chains = chains,
parallel = parallel,
silent = silent,
max_treedepth = max_treedepth,
adapt_delta = adapt_delta,
threads = threads,
burnin = burnin,
samples = samples,
param = param,
save_all_pars = save_all_pars,
dots
)
} else {
# Condition the model using rstan
requireNamespace("rstan", quietly = TRUE)
out_gam_mod <- .sample_model_rstan(
model = vectorised$model_file,
algorithm = algorithm,
prior_simulation = prior_simulation,
data = model_data,
chains = chains,
parallel = parallel,
silent = silent,
max_treedepth = max_treedepth,
adapt_delta = adapt_delta,
threads = threads,
burnin = burnin,
samples = samples,
thin = thin,
dots
)
}
}
if (!use_stan) {
requireNamespace("runjags", quietly = TRUE)
fit_engine <- "jags"
model_data <- ss_jagam$jags.data
runjags::runjags.options(silent.jags = TRUE, silent.runjags = TRUE)
# Initiate adaptation of the model for the full burnin period. This is necessary as JAGS
# will take a while to optimise the samplers, so long adaptation with little 'burnin'
# is more crucial than little adaptation but long 'burnin' https://mmeredith.net/blog/2016/Adapt_or_burn.htm
unlink("base_gam.txt")
cat(model_file, file = "base_gam.txt", sep = "\n", append = T)
message("Compiling the JAGS program...")
message()
if (prior_simulation) {
n_adapt <- 500
n_burn <- 0
samples <- 1000
thin <- 1
} else {
n_burn <- burnin
# Rely on long adaptation to tune samplers appropriately
n_adapt <- max(1000, n_burn - 1000)
}
if (parallel) {
cl <- parallel::makePSOCKcluster(min(c(
chains,
parallel::detectCores() - 1
)))
setDefaultCluster(cl)
gam_mod <- runjags::run.jags(
model = "base_gam.txt",
data = ss_jagam$jags.data,
modules = "glm",
inits = initlist,
n.chains = chains,
adapt = n_adapt,
burnin = n_burn,
sample = samples,
jags = jags_path,
thin = thin,
method = "rjparallel",
monitor = param,
silent.jags = TRUE,
cl = cl
)
stopCluster(cl)
} else {
gam_mod <- runjags::run.jags(
model = "base_gam.txt",
data = ss_jagam$jags.data,
modules = "glm",
inits = initlist,
n.chains = chains,
adapt = n_adapt,
burnin = n_burn,
sample = samples,
jags = jags_path,
thin = thin,
method = "rjags",
monitor = param,
silent.jags = TRUE
)
}
out_gam_mod <- coda::as.mcmc.list(gam_mod)
}
unlink(file_name)
unlink(fil)
# Add generated quantities for N-mixture models
if (family_char == "nmix") {
out_gam_mod <- add_nmix_posterior(
model_output = out_gam_mod,
obs_data = data_train,
test_data = data_test,
mgcv_model = trend_mgcv_model,
Z = model_data$Z,
n_lv = n_lv,
K_inds = model_data$K_inds_all
)
}
# Get Dunn-Smyth Residual distributions for each series if this
# is not a prior simulation or an lfo fit
if (prior_simulation || lfo || !residuals) {
series_resids <- NULL
} else {
object <- list(
model_output = out_gam_mod,
call = orig_formula,
mgcv_model = ss_gam,
model_data = if (use_stan) {
vectorised$model_data
} else {
ss_jagam$jags.data
},
fit_engine = fit_engine,
family = family_char,
share_obs_params = share_obs_params,
obs_data = data_train,
test_data = data_test,
ytimes = ytimes
)
class(object) <- "mvgam"
# Use the much faster vectorized residual
# calculation function now
series_resids <- dsresids_vec(object)
}
if (prior_simulation) {
data_train$y <- orig_y
}
# Add Bayesian coefficients to the mgcv model to help with plotting of
# smooths that aren't yet supported by mvgam plotting functions; this is
# also necessary for computing EDFs and approximate p-values of smooths
if (!lfo) {
V <- cov(mcmc_chains(out_gam_mod, "b"))
ss_gam$Vp <- ss_gam$Vc <- V
# Add the posterior median coefficients
p <- mcmc_summary(
out_gam_mod,
"b",
variational = algorithm %in%
c("meanfield", "fullrank", "pathfinder", "laplace")
)[, c(4)]
names(p) <- names(ss_gam$coefficients)
ss_gam$coefficients <- p
# Repeat for any trend-specific mgcv model
if (!missing(trend_formula)) {
V <- cov(mcmc_chains(out_gam_mod, "b_trend"))
trend_mgcv_model$Vp <- trend_mgcv_model$Vc <- V
p <- mcmc_summary(
out_gam_mod,
"b_trend",
variational = algorithm %in%
c("meanfield", "fullrank", "pathfinder", "laplace")
)[, c(4)]
names(p) <- names(trend_mgcv_model$coefficients)
trend_mgcv_model$coefficients <- p
}
}
#### Return the output as class mvgam ####
trim_data <- list()
attr(model_data, "trend_model") <- trend_model
attr(trim_data, "trend_model") <- trend_model
attr(model_data, "noncentred") <- if (noncentred) TRUE else NULL
attr(trim_data, "noncentred") <- if (noncentred) TRUE else NULL
attr(model_data, "threads") <- threads
attr(trim_data, "threads") <- threads
output <- structure(
list(
call = orig_formula,
trend_call = if (!missing(trend_formula)) {
trend_formula
} else {
NULL
},
family = family_char,
share_obs_params = share_obs_params,
trend_model = orig_trend_model,
trend_map = if (!missing(trend_map)) {
trend_map
} else {
NULL
},
drift = FALSE,
priors = priors,
model_output = out_gam_mod,
model_file = if (use_stan) {
vectorised$model_file
} else {
trimws(model_file)
},
model_data = if (return_model_data) {
model_data
} else {
trim_data
},
inits = if (return_model_data) {
inits
} else {
NULL
},
monitor_pars = param,
sp_names = rho_names,
trend_sp_names = trend_sp_names,
mgcv_model = ss_gam,
trend_mgcv_model = if (!missing(trend_formula)) {
trend_mgcv_model
} else {
NULL
},
ytimes = ytimes,
resids = series_resids,
use_lv = use_lv,
n_lv = n_lv,
upper_bounds = upper_bounds,
obs_data = data_train,
test_data = data_test,
fit_engine = fit_engine,
backend = if (use_stan) {
backend
} else {
"rjags"
},
algorithm = if (use_stan) {
algorithm
} else {
"sampling"
},
max_treedepth = if (use_stan & algorithm == "sampling") {
max_treedepth
} else {
NULL
},
adapt_delta = if (use_stan & algorithm == "sampling") {
adapt_delta
} else {
NULL
}
),
class = "mvgam"
)
}
return(output)
}
================================================
FILE: R/mvgam_diagnostics.R
================================================
#' Extract diagnostic quantities of \pkg{mvgam} models
#'
#' Extract quantities that can be used to diagnose sampling behavior
#' of the algorithms applied by \pkg{Stan} at the back-end of \pkg{mvgam}.
#'
#' @name mvgam_diagnostics
#' @aliases nuts_params rhat neff_ratio
#'
#' @param object,x A \code{mvgam} or \code{jsdgam} 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.
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam(n_series = 1, trend_model = 'AR1')
#' mod <- mvgam(y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2)
#' np <- nuts_params(mod)
#' head(np)
#'
#' # extract the number of divergence transitions
#' sum(subset(np, Parameter == "divergent__")$Value)
#'
#' head(neff_ratio(mod))
#' }
#' @details For more details see
#' \code{\link[bayesplot:bayesplot-extractors]{bayesplot-extractors}}.
#'
NULL
#' @rdname mvgam_diagnostics
#' @importFrom bayesplot nuts_params
#' @export nuts_params
#' @export
nuts_params.mvgam <- function(object, pars = NULL, ...) {
bayesplot::nuts_params(object$model_output, pars = pars, ...)
}
#' @rdname mvgam_diagnostics
#' @importFrom bayesplot log_posterior
#' @export
log_posterior.mvgam <- function(object, ...) {
bayesplot::log_posterior(object$model_output, ...)
}
#' @rdname mvgam_diagnostics
#' @importFrom posterior rhat
#' @export rhat
#' @export
rhat.mvgam <- function(x, pars = NULL, ...) {
# bayesplot uses outdated rhat code from rstan
# bayesplot::rhat(object$fit, pars = pars, ...)
if (is.null(pars)) {
vars_extract <- variables(x)
draws <- as_draws_array(
x,
variable = unlist(purrr::map(vars_extract, 'orig_name')),
use_alias = FALSE
)
} else {
draws <- as_draws_array(x, variable = pars)
}
tmp <- posterior::summarise_draws(draws, rhat = posterior::rhat)
rhat <- tmp$rhat
names(rhat) <- tmp$variable
rhat
}
#' @rdname mvgam_diagnostics
#' @importFrom bayesplot neff_ratio
#' @importFrom brms ndraws
#' @export neff_ratio
#' @export
neff_ratio.mvgam <- function(object, pars = NULL, ...) {
insight::check_if_installed(
"matrixStats",
reason = 'to calculate effective sample sizes'
)
if (is.null(pars)) {
vars_extract <- unlist(purrr::map(variables(object), 'orig_name'))
vars_extract <- vars_extract[-grep('ypred', vars_extract)]
draws <- as_draws_array(object, variable = vars_extract, use_alias = FALSE)
} else {
draws <- as_draws_array(object, variable = pars)
}
tmp <- posterior::summarise_draws(
draws,
ess_bulk = posterior::ess_bulk,
ess_tail = posterior::ess_tail
)
# min of ess_bulk and ess_tail mimics definition of posterior::rhat.default
ess <- matrixStats::rowMins(cbind(tmp$ess_bulk, tmp$ess_tail))
names(ess) <- tmp$variable
ess / brms::ndraws(draws)
}
================================================
FILE: R/mvgam_fevd-class.R
================================================
#' `mvgam_fevd` object description
#'
#' A \code{mvgam_fevd} object returned by function [fevd()]. Run
#' `methods(class = "mvgam_fevd")` to see an overview of available methods.
#'
#' @details A forecast error variance decomposition is useful for quantifying
#' the amount of information each series that in a Vector Autoregression
#' contributes to the forecast distributions of the other series in the
#' autoregression. This object contains the forecast error variance
#' decomposition using the orthogonalised impulse response coefficient
#' matrices \eqn{\Psi_h}, which can be used to quantify the contribution of
#' series \eqn{j} to the h-step forecast error variance of series \eqn{k}:
#' \deqn{
#' \sigma_k^2(h) = \sum_{j=1}^K(\psi_{kj, 0}^2 + \ldots + \psi_{kj,
#' h-1}^2) \quad
#' }
#' If the orthogonalised impulse reponses \eqn{(\psi_{kj, 0}^2 + \ldots +
#' \psi_{kj, h-1}^2)} are divided by the variance of the forecast error
#' \eqn{\sigma_k^2(h)}, this yields an interpretable percentage representing
#' how much of the forecast error variance for \eqn{k} can be explained by an
#' exogenous shock to \eqn{j}. This percentage is what is calculated and
#' returned in objects of class `mvgam_fevd`, where the posterior
#' distribution of variance decompositions for each variable in the original
#' model is contained in a separate slot within the returned `list` object
#'
#' @seealso [mvgam()], [VAR()]
#'
#' @references Lütkepohl, H (2006). New Introduction to Multiple Time Series
#' Analysis. Springer, New York.
#'
#' @author Nicholas J Clark
#'
#' @name mvgam_fevd-class
NULL
#' @title Posterior summary of forecast error variance decompositions
#'
#' @description This function takes an \code{mvgam_fevd} object and calculates
#' a posterior summary of the error variance decompositions of each series,
#' at all horizons
#'
#' @param object an object of class `mvgam_fevd` obtained using the
#' \code{fevd()} function. This object will contain draws from the posterior
#' distribution of the forecast error variance decompositions.
#'
#' @param probs The upper and lower percentiles to be computed by the
#' `quantile` function, in addition to the median
#'
#' @param ... ignored
#'
#' @return A long-format `tibble` / `data.frame` reporting the posterior median,
#' upper and lower percentiles of the error variance decompositions of each
#' series at all horizons.
#'
#' @method summary mvgam_fevd
#'
#' @seealso \code{\link{fevd}}, \code{\link{plot.mvgam_fevd}}
#'
#' @author Nicholas J Clark
#'
#' @export
summary.mvgam_fevd = function(object, probs = c(0.025, 0.975), ...) {
if (length(probs) != 2L) {
stop("argument 'probs' must be a vector of length 2", call. = FALSE)
}
validate_proportional(min(probs))
validate_proportional(max(probs))
# Calculate posterior quantiles of error variance contributions
ynames <- names(object[[1]])
out <- do.call(
rbind,
lapply(seq_len(length(object)), function(draw) {
fevd_df(object[[draw]], ynames = ynames) %>%
dplyr::mutate(draw = draw)
})
) %>%
dplyr::group_by(horizon, target, draw) %>%
dplyr::mutate(total_evd = sum(evd)) %>%
dplyr::ungroup() %>%
dplyr::mutate(evd = evd / total_evd) %>%
dplyr::group_by(horizon, target, Series) %>%
dplyr::mutate(
fevdQ50 = median(evd),
fevd_Qlower = quantile(evd, min(probs), na.rm = TRUE),
fevd_Qupper = quantile(evd, max(probs), na.rm = TRUE)
) %>%
dplyr::ungroup() %>%
dplyr::mutate(
shock = gsub('process', 'Process', paste0(Series, ' -> ', target))
) %>%
dplyr::select(shock, horizon, fevdQ50, fevd_Qlower, fevd_Qupper) %>%
dplyr::distinct()
colnames(out) <- c(
'shock',
'horizon',
'fevdQ50',
paste0('fevdQ', 100 * min(probs)),
paste0('fevdQ', 100 * max(probs))
)
return(out)
}
#'Plot forecast error variance decompositions from an `mvgam_fevd` object
#'
#'This function takes an \code{mvgam_fevd} object and produces
#'a plot of the posterior median contributions to forecast variance for each series
#'in the fitted Vector Autoregression
#'
#'@importFrom ggplot2 ggplot aes geom_bar facet_wrap labs
#'
#'@param x \code{list} object of class \code{mvgam_fevd}. See [fevd()]
#'
#'@param ... ignored
#'
#'@return A \code{\link[ggplot2]{ggplot}} object,
#' which can be further customized using the \pkg{ggplot2} package
#'
#'@author Nicholas J Clark
#'
#'@export
plot.mvgam_fevd = function(x, ...) {
# Calculate posterior median error variance contributions
ynames <- names(x[[1]])
do.call(
rbind,
lapply(seq_len(length(x)), function(draw) {
fevd_df(x[[draw]], ynames = ynames)
})
) %>%
dplyr::group_by(horizon, target, Series) %>%
dplyr::summarise(mean_evd = median(evd)) %>%
dplyr::ungroup() %>%
dplyr::group_by(horizon, target) %>%
dplyr::mutate(
total_evd = sum(mean_evd),
mean_evd = mean_evd / total_evd
) %>%
dplyr::ungroup() %>%
dplyr::mutate(
Series = gsub('process', 'Process', Series),
target = gsub('process', 'Process', target)
) -> mean_evds
# Plot as a ggplot object
ggplot2::ggplot(
mean_evds,
ggplot2::aes(fill = Series, y = mean_evd, x = horizon)
) +
ggplot2::geom_bar(position = "stack", stat = "identity") +
ggplot2::facet_wrap(~target) +
ggplot2::theme_bw() +
ggplot2::labs(
x = 'Forecast horizon',
y = 'Median contribution to forecast variance'
)
}
#'@noRd
fevd_df = function(x, ynames) {
do.call(
rbind,
lapply(seq_len(length(x)), function(process) {
data.frame(
horizon = 1:NROW(x[[process]]),
evd = as.vector(x[[process]]),
Series = paste0(
'process_',
sort(rep(
1:length(ynames),
NROW(x[[process]])
))
),
target = ynames[process]
)
})
)
}
================================================
FILE: R/mvgam_forecast-class.R
================================================
#' `mvgam_forecast` object description
#'
#' A \code{mvgam_forecast} object returned by function \code{\link{hindcast}}
#' or \code{\link{forecast}}. Run `methods(class = "mvgam_forecast")` to see
#' an overview of available methods.
#'
#' @details A `mvgam_forecast` object contains the following elements:
#'
#' \itemize{
#' \item `call` the original observation model formula
#'
#' \item `trend_call` If a `trend_formula was supplied`, the original trend
#' model formula is returned. Otherwise `NULL`
#'
#' \item `family` \code{character} description of the observation distribution
#'
#' \item `family_pars` \code{list} containing draws of family-specific
#' parameters (i.e. shape, scale or overdispersion parameters). Only
#' returned if `type = link`. Otherwise `NULL`
#'
#' \item `trend_model` \code{character} description of the latent trend model
#'
#' \item `drift` Logical specifying whether a drift term was used in the
#' trend model
#'
#' \item `use_lv` Logical flag indicating whether latent dynamic factors were
#' used in the model
#'
#' \item `fit_engine` `Character` describing the fit engine, either as `stan`
#' or `jags`
#'
#' \item `type` The type of predictions included (either `link`, `response`
#' or `trend`)
#'
#' \item `series_names` Names of the time series, taken from
#' `levels(data$series)` in the original model fit
#'
#' \item `train_observations` A `list` of training observation vectors of
#' length `n_series`
#'
#' \item `train_times` A `list` of the unique training times of length
#' `n_series`
#'
#' \item `test_observations` If the \code{\link{forecast}} function was used,
#' a `list` of test observation vectors of length `n_series`. Otherwise
#' `NULL`
#'
#' \item `test_times` If the \code{\link{forecast}} function was used, a
#' `list` of the unique testing (validation) times of length `n_series`.
#' Otherwise `NULL`
#'
#' \item `hindcasts` A `list` of posterior hindcast distributions of length
#' `n_series`.
#'
#' \item `forecasts` If the \code{\link{forecast}} function was used, a
#' `list` of posterior forecast distributions of length `n_series`.
#' Otherwise `NULL`
#' }
#'
#' @seealso [mvgam], [hindcast.mvgam], [forecast.mvgam]
#'
#' @author Nicholas J Clark
#'
#' @name mvgam_forecast-class
NULL
#' @title Posterior summary of hindcast and forecast objects
#'
#' @description This function takes an \code{mvgam_forecast} object and
#' calculates a posterior summary of the hindcast and forecast distributions
#' of each series, along with any true values that were included in `data`
#' and `newdata` if `type = 'response'` was used in the call to
#' \code{hindcast()} or \code{function()}
#'
#' @param object an object of class `mvgam_forecast` obtained using either the
#' \code{hindcast()} or \code{function()} function. This object will contain
#' draws from the posterior distribution of hindcasts and forecasts.
#'
#' @param probs The upper and lower percentiles to be computed by the
#' `quantile` function, in addition to the median
#'
#' @param ... ignored
#'
#' @return A long-format `tibble` / `data.frame` reporting the posterior median,
#' upper and lower percentiles of the predictions for each series at each of
#' the timepoints that were originally supplied in `data` and, optionally,
#' in `newdata`.
#'
#' @method summary mvgam_forecast
#'
#' @seealso \code{\link{forecast.mvgam}}, \code{\link{plot.mvgam_forecast}}
#'
#' @author Nicholas J Clark
#'
#' @export
summary.mvgam_forecast = function(object, probs = c(0.025, 0.975), ...) {
if (length(probs) != 2L) {
stop("argument 'probs' must be a vector of length 2", call. = FALSE)
}
validate_proportional(min(probs))
validate_proportional(max(probs))
n_series <- length(object$series_names)
type <- object$type
# Extract predictions and truths (if type = 'response')
fc_preds <- do.call(
rbind,
lapply(1:n_series, function(x) {
s_name <- object$series_names[x]
preds <- cbind(
object$hindcasts[[which(names(object$hindcasts) == s_name)]],
object$forecasts[[which(names(object$forecasts) == s_name)]]
)
# Calculate quantiles of the forecast distribution
cred <- sapply(
1:NCOL(preds),
function(n) quantile(preds[, n], probs = probs, na.rm = TRUE)
)
meds <- apply(preds, 2, median)
# Put into a long "tidy" dataframe
if (type == 'response') {
df <- data.frame(
series = s_name,
time = c(
object$train_times[[which(names(object$hindcasts) == s_name)]],
object$test_times[[which(names(object$hindcasts) == s_name)]]
),
pred_median = meds,
pred_Qlower = cred[1, ],
pred_Qupper = cred[2, ],
truth = c(
object$train_observations[[s_name]],
object$test_observations[[s_name]]
),
type = 'response'
)
colnames(df) <- c(
'series',
'time',
'predQ50',
paste0('predQ', 100 * min(probs)),
paste0('predQ', 100 * max(probs)),
'truth',
'type'
)
rownames(df) <- NULL
} else {
df <- data.frame(
series = s_name,
time = c(
object$train_times[[which(names(object$hindcasts) == s_name)]],
object$test_times[[which(names(object$hindcasts) == s_name)]]
),
predQ50 = meds,
predQlower = cred[1, ],
predQupper = cred[2, ],
type = type
)
colnames(df) <- c(
'series',
'time',
'predQ50',
paste0('predQ', 100 * min(probs)),
paste0('predQ', 100 * max(probs)),
'type'
)
rownames(df) <- NULL
}
df
})
) %>%
dplyr::mutate(
series = factor(series, levels = object$series_names)
)
class(fc_preds) <- c("tbl_df", "tbl", "data.frame")
return(fc_preds)
}
================================================
FILE: R/mvgam_formulae.R
================================================
#' Details of formula specifications in \pkg{mvgam} models
#' @details \code{\link{mvgam}} will accept an observation model formula and an optional
#' process model formula (via the argument `trend_formula`). Neither of these formulae can
#' be specified as lists, contrary to the accepted behaviour in some `mgcv` or `brms` models.
#' \cr
#' \cr
#' Note that it is possible to supply an empty formula where
#' there are no predictors or intercepts in the observation model (i.e. `y ~ 0` or `y ~ -1`).
#' In this case, an intercept-only observation model will be set up but the intercept coefficient
#' will be fixed at zero. This can be handy if you wish to fit pure State-Space models where
#' the variation in the dynamic trend controls the average expectation, and/or where intercepts
#' are non-identifiable.
#' \cr
#' \cr
#' The formulae supplied to \code{\link{mvgam}} and \code{\link{jsdgam}}
#' are exactly like those supplied to
#' \code{\link{glm}} except that smooth terms,
#' \code{\link[mgcv]{s}},
#' \code{\link[mgcv]{te}},
#' \code{\link[mgcv]{ti}} and
#' \code{\link[mgcv]{t2}},
#' time-varying effects using \code{\link{dynamic}},
#' monotonically increasing (using `s(x, bs = 'moi')`)
#' or decreasing splines (using `s(x, bs = 'mod')`;
#' see \code{\link{smooth.construct.moi.smooth.spec}} for
#' details), as well as
#' Gaussian Process functions using \code{\link[brms]{gp}} and offsets using
#' \code{\link[stats]{offset}}
#' can be added to the right hand side (and \code{.} is not supported in \code{mvgam} formulae).
#' \cr
#' \cr
#' Further details on specifying different kinds of smooth functions, and how to control their behaviours
#' by modifying their potential complexities and / or how the penalties behave, can be found in the
#' extensive documentation for the `mgcv` package.
#' @seealso \code{\link{mvgam}},
#' \code{\link[mgcv]{formula.gam}},
#' \code{\link[mgcv]{gam.models}},
#' \code{\link[mgcv]{jagam}},
#' \code{\link[mgcv]{gam}},
#' \code{\link[mgcv]{s}},
#' \code{\link[brms]{gp}},
#' \code{\link[stats]{formula}}
#' @author Nicholas J Clark
#' @name mvgam_formulae
NULL
#' @export
#' @importFrom brms gp
brms::gp
#' @export
#' @importFrom mgcv s
mgcv::s
#' @export
#' @importFrom mgcv te
mgcv::te
#' @export
#' @importFrom mgcv ti
mgcv::ti
#' @export
#' @importFrom mgcv t2
mgcv::t2
================================================
FILE: R/mvgam_irf-class.R
================================================
#' `mvgam_irf` object description
#'
#' A \code{mvgam_irf} object returned by function \code{\link{irf}}.
#' Run `methods(class = "mvgam_irf")` to see an overview of available methods.
#'
#' @details Generalized or Orthogonalized Impulse Response Functions can be
#' computed using the posterior estimates of Vector Autoregressive parameters.
#' This function generates a positive "shock" for a target process at time
#' `t = 0` and then calculates how each of the remaining processes in the
#' latent VAR are expected to respond over the forecast horizon `h`. The
#' function computes IRFs for all processes in the object and returns them in
#' an array that can be plotted using the S3 `plot` function. To inspect
#' community-level metrics of stability using latent VAR processes, you can
#' use the related [stability()] function.
#'
#' A `mvgam_irf` object contains a `list` of posterior impulse response
#' functions, each stored as its own `list`
#'
#' @seealso [mvgam], [VAR]
#'
#' @references PH Pesaran & Shin Yongcheol (1998).
#' Generalized impulse response analysis in linear multivariate models.
#' Economics Letters 58: 17–29.
#'
#' @author Nicholas J Clark
#'
#' @name mvgam_irf-class
NULL
#' @title Posterior summary of impulse responses
#'
#' @description This function takes an \code{mvgam_irf} object and
#' calculates a posterior summary of the impulse responses of each
#' series to shocks from each of the other series, at all horizons
#'
#' @param object an object of class `mvgam_irf` obtained using the
#' \code{irf()} function. This object will contain draws from the posterior
#' distribution of the impulse responses.
#'
#' @param probs The upper and lower percentiles to be computed by the
#' `quantile` function, in addition to the median
#'
#' @param ... ignored
#'
#' @return A long-format `tibble` / `data.frame` reporting the posterior median,
#' upper and lower percentiles of the impulse responses of each series to
#' shocks from each of the other series at all horizons.
#'
#' @method summary mvgam_irf
#'
#' @seealso \code{\link{irf}}, \code{\link{plot.mvgam_irf}}
#'
#' @author Nicholas J Clark
#'
#' @export
summary.mvgam_irf = function(object, probs = c(0.025, 0.975), ...) {
if (length(probs) != 2L) {
stop("argument 'probs' must be a vector of length 2", call. = FALSE)
}
validate_proportional(min(probs))
validate_proportional(max(probs))
n_processes <- dim(object[[1]][[1]])[2]
h <- dim(object[[1]][[1]])[1]
n_draws <- length(object)
out <- do.call(
rbind,
lapply(1:n_processes, function(series) {
# Extract IRFs for the specific series
impulse_responses <- lapply(seq_along(object), function(j) {
object[[j]][series]
})
responses <- do.call(
rbind,
lapply(seq_along(impulse_responses), function(j) {
data.frame(
horizon = 1:h,
imp_resp = as.vector(impulse_responses[[j]][[1]]),
resp_var = paste0(
'Process_',
sort(rep(
1:n_processes,
NROW(impulse_responses[[j]][[1]])
))
)
)
})
) %>%
dplyr::mutate(shock = paste0('Process_', series, ' -> ', resp_var)) %>%
# Calculate posterior empirical quantiles of impulse responses
dplyr::group_by(shock, horizon) %>%
dplyr::summarise(
irfQ50 = median(imp_resp),
irfQlower = quantile(imp_resp, min(probs), na.rm = TRUE),
irfQupper = quantile(imp_resp, max(probs), na.rm = TRUE),
.groups = 'keep'
) %>%
dplyr::ungroup()
colnames(responses) <- c(
'shock',
'horizon',
'irfQ50',
paste0('irfQ', 100 * min(probs)),
paste0('irfQ', 100 * max(probs))
)
responses
})
)
return(out)
}
#' Plot impulse responses from an `mvgam_irf` object
#'
#' This function takes an \code{mvgam_irf} object and produces plots of
#' Impulse Response Functions
#'
#' @param x \code{list} object of class \code{mvgam_irf}. See [irf()]
#'
#' @param series \code{integer} specifying which process series should be
#' given the shock
#'
#' @param ... ignored
#'
#' @return A `ggplot` object showing the expected response of each latent time
#' series to a shock of the focal `series`
#'
#' @author Nicholas J Clark
#'
#' @export
plot.mvgam_irf = function(x, series = 1, ...) {
all_irfs <- x
validate_pos_integer(series)
n_processes <- dim(all_irfs[[1]][[1]])[2]
if (series > n_processes) {
stop(paste0("argument 'series' must be <= ", n_processes), call. = FALSE)
}
h <- dim(all_irfs[[1]][[1]])[1]
# Extract IRFs for the specific series
impulse_responses <- lapply(seq_along(all_irfs), function(j) {
all_irfs[[j]][series]
})
# Extract impulse responses to a shock in the focal series
# in tidy format for ggploting
responses <- do.call(
rbind,
lapply(seq_along(impulse_responses), function(j) {
data.frame(
horizon = 1:h,
imp_resp = as.vector(impulse_responses[[j]][[1]]),
resp_var = sort(rep(
paste0('Process_~', 1:n_processes),
NROW(impulse_responses[[j]][[1]])
))
)
})
) %>%
dplyr::mutate(
resp_var = paste0('Process_~', series, ' %->% ', resp_var)
) %>%
# Calculate posterior empirical quantiles of impulse responses
dplyr::group_by(resp_var, horizon) %>%
dplyr::summarise(
med = median(imp_resp),
lower1 = quantile(imp_resp, 0.1, na.rm = TRUE),
lower2 = quantile(imp_resp, 0.2, na.rm = TRUE),
lower3 = quantile(imp_resp, 0.3, na.rm = TRUE),
lower4 = quantile(imp_resp, 0.4, na.rm = TRUE),
upper1 = quantile(imp_resp, 0.9, na.rm = TRUE),
upper2 = quantile(imp_resp, 0.8, na.rm = TRUE),
upper3 = quantile(imp_resp, 0.7, na.rm = TRUE),
upper4 = quantile(imp_resp, 0.6, na.rm = TRUE),
.groups = 'keep'
) %>%
dplyr::ungroup()
# Plot the IRFs
ggplot2::ggplot(data = responses, ggplot2::aes(x = horizon, y = med)) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower1, ymax = upper1),
fill = "#DCBCBC"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower2, ymax = upper2),
fill = "#C79999"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower3, ymax = upper3),
fill = "#B97C7C"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower4, ymax = upper4),
fill = "#A25050"
) +
ggplot2::geom_line(col = "#8F2727", linewidth = 1) +
ggplot2::geom_hline(yintercept = 0, linetype = "dashed", colour = "black") +
ggplot2::facet_wrap(
~resp_var,
scales = 'free_y',
labeller = ggplot2::label_parsed
) +
ggplot2::labs(
x = "Horizon",
y = paste0(attr(x, 'irf_type'), " impulse response")
) +
ggplot2::theme_bw()
}
================================================
FILE: R/mvgam_residcor-class.R
================================================
#' `mvgam_residcor` object description
#'
#' A \code{mvgam_residcor} object returned by function [residual_cor()].
#' Run `methods(class = "mvgam_residcor")` to see an overview of available methods.
#' @return Objects of this class are structured as a `list` with the following components:
#'
#' \item{cor, cor_lower, cor_upper}{A set of \eqn{p \times p} correlation matrices,
#' containing either the posterior median or mean estimate, plus lower and upper limits
#' of the corresponding credible intervals supplied to `probs`}
#' \item{sig_cor}{A \eqn{p \times p} correlation matrix containing only those correlations whose credible
#' interval does not contain zero. All other correlations are set to zero}
#' \item{prec, prec_lower, prec_upper}{A set of \eqn{p \times p} precision matrices,
#' containing either the posterior median or mean estimate, plus lower and upper limits
#' of the corresponding credible intervals supplied to `probs`}
#' \item{sig_prec}{A \eqn{p \times p} precision matrix containing only those precisions whose credible
#' interval does not contain zero. All other precisions are set to zero}
#' \item{cov}{A \eqn{p \times p} posterior median or mean covariance matrix}
#' \item{trace}{The median/mean point estimator of the trace (sum of the diagonal elements)
#' of the residual covariance matrix `cov`}
#'
#' @details
#' Hui (2016) provides an excellent description of the quantities that this function calculates, so this passage
#' is heavily paraphrased from his associated \pkg{boral} package.
#'
#' In latent factor models, the residual covariance matrix is calculated
#' based on the matrix of latent factor loading matrix \eqn{\Theta}, where the residual covariance
#' matrix \eqn{\Sigma = \Theta\Theta'}. A strong residual covariance/correlation matrix
#' between two species can be interpreted as evidence of species interactions (e.g.,
#' facilitation or competition),
#' missing covariates, as well as any additional species correlation not accounted for by shared
#' environmental captured in `formula`.
#'
#' The residual precision matrix (also known as partial correlation matrix, Ovaskainen et al., 2016)
#' is defined as the inverse of the residual correlation matrix. The precision matrix is often used to
#' identify direct or causal relationships between two species e.g., two species can have a zero
#' precision but still be correlated, which can be interpreted as saying that two species are not
#' directly associated, but they are still correlated *through* other species. In other words, they
#' are conditionally independent given the other species. It is important that the precision matrix
#' does not exhibit the exact same properties of the correlation e.g., the diagonal elements are
#' not equal to 1. Nevertheless, relatively larger values of precision may imply stronger
#' direct relationships between two species.
#'
#' In addition to the residual correlation and precision matrices, the median or mean point estimator
#' of trace of the residual covariance matrix is returned,
#' \eqn{\sum\limits_{j=1}^p [\Theta\Theta']_{jj}}. Often used in other areas of multivariate
#' statistics, the trace may be interpreted as the amount of covariation explained by the latent factors.
#' One situation where the trace may be useful is when comparing a pure latent factor model
#' (where no terms are suppled to `formula`) versus a model with latent
#' factors and some additional predictors in `formula` -- the proportional difference in trace
#' between these two models may be interpreted as the proportion of covariation between species explained
#' by the predictors in `formula`. Of course, the trace itself is random due to the MCMC sampling, and so it
#' is not always guaranteed to produce sensible answers.
#' @author Nicholas J Clark
#' @references
#' Francis KC Hui (2016). BORAL - Bayesian ordination and regression analysis of
#' multivariate abundance data in R. Methods in Ecology and Evolution. 7, 744-750.
#' \cr
#' \cr
#' Otso Ovaskainen et al. (2016). Using latent variable models to identify large networks of
#' species-to-species associations at different spatial scales. Methods in Ecology and Evolution,
#' 7, 549-555.
#' @seealso [jsdgam()], [residual_cor()]
#' @author Nicholas J Clark
#' @name mvgam_residcor-class
NULL
#' Plot residual correlations based on latent factors
#'
#' Plot residual correlation estimates from Joint Species Distribution
#' (\code{jsdgam}) or dynamic factor (\code{mvgam}) models
#' @param x \code{list} object of class \code{mvgam_residcor} resulting from a
#' call to `residual_cor(..., summary = TRUE)`
#' @param cluster Logical. Should the variables be re-arranged within the plot
#' to group the correlation matrix into clusters of positive and negative correlations?
#' Defaults to `FALSE`
#' @param ... ignored
#' @method plot mvgam_residcor
#' @details This function plots the significant residual correlations from a
#' \code{mvgam_residcor} object, whereby the posterior mean (if `robust = FALSE`)
#' or posterior median (if `robust = TRUE`) correlations are shown
#' only those correlations whose credible interval does not contain zero. All other
#' correlations are set to zero in the returned plot
#' @return A `ggplot` object
#' @seealso [jsdgam()], [lv_correlations()], [residual_cor()]
#'
#' @author Nicholas J Clark
#'
#' @export
plot.mvgam_residcor = function(x, cluster = FALSE, ...) {
# Extract significant correlations
corrmat <- x$sig_cor
# Re-order into clusters, if specified
if (cluster) {
idx <- cluster_cormat(corrmat)
} else {
idx <- 1:NROW(corrmat)
}
# Plot the correlation matrix
ggplot2::ggplot(
data = gather_matrix(corrmat[idx, idx]),
mapping = ggplot2::aes(
x = Var1,
y = Var2,
fill = correlation
)
) +
ggplot2::geom_tile(colour = 'grey50') +
ggplot2::scale_fill_gradient2(
breaks = seq(-1, 1, by = 0.5),
limits = c(-1, 1)
) +
ggplot2::labs(x = '', y = '') +
ggplot2::scale_x_discrete(guide = ggplot2::guide_axis(angle = 45)) +
ggplot2::theme_minimal()
}
#' Melt a symmetric matrix into a long data.frame
#' @noRd
gather_matrix <- function(mat) {
mat[upper.tri(mat)] <- NA
if (is.null(dimnames(mat))) {
grid <- expand.grid(seq.int(NROW(mat)), seq.int(NCOL(mat)))
} else {
grid <- expand.grid(dimnames(mat))
}
out <- as.data.frame(cbind(grid, value = as.vector(mat)))
colnames(out) <- c('Var1', 'Var2', 'correlation')
return(out)
}
#' Order a symmetric correlation matrix using approximate Robinson
#' ordering, for better visualisation of "clusters"
#' Credit for these functions goes to the maintainers of the gclus R package
#' @importFrom stats hclust as.dist
#' @noRd
cluster_cormat <- function(cormat, ...) {
dis <- -cormat
dis_d <- as.dist(dis)
n <- NROW(dis)
if (n <= 2) {
idx <- 1:n
} else {
clusters <- stats::hclust(dis_d, ...)
clusters <- reorder_clusters(clusters, dis)
idx <- clusters$order
}
return(idx)
}
#' @noRd
reorder_clusters <- function(x, dis, ...) {
if (!is.matrix(dis)) {
dis <- as.matrix(dis)
}
merges <- x$merge
n <- NROW(merges)
endpoints <- matrix(0, n, 2)
dir <- matrix(1L, n, 2)
for (i in 1L:n) {
j <- merges[i, 1]
k <- merges[i, 2]
if ((j < 0) && (k < 0)) {
endpoints[i, 1] <- -j
endpoints[i, 2] <- -k
} else if (j < 0) {
j <- -j
endpoints[i, 1] <- j
e1 <- endpoints[k, 1]
e2 <- endpoints[k, 2]
if (dis[j, e1] < dis[j, e2]) {
endpoints[i, 2] <- e2
} else {
endpoints[i, 2] <- e1
dir[i, 2] <- -1
}
} else if (k < 0) {
k <- -k
endpoints[i, 2] <- k
e1 <- endpoints[j, 1]
e2 <- endpoints[j, 2]
if (dis[k, e1] < dis[k, e2]) {
endpoints[i, 1] <- e2
dir[i, 1] <- -1
} else {
endpoints[i, 1] <- e1
}
} else {
ek1 <- endpoints[k, 1]
ek2 <- endpoints[k, 2]
ej1 <- endpoints[j, 1]
ej2 <- endpoints[j, 2]
d11 <- dis[ej1, ek1]
d12 <- dis[ej1, ek2]
d21 <- dis[ej2, ek1]
d22 <- dis[ej2, ek2]
dmin <- min(d11, d12, d21, d22)
if (dmin == d21) {
endpoints[i, 1] <- ej1
endpoints[i, 2] <- ek2
} else if (dmin == d11) {
endpoints[i, 1] <- ej2
endpoints[i, 2] <- ek2
dir[i, 1] <- -1
} else if (dmin == d12) {
endpoints[i, 1] <- ej2
endpoints[i, 2] <- ek1
dir[i, 1] <- -1
dir[i, 2] <- -1
} else {
endpoints[i, 1] <- ej1
endpoints[i, 2] <- ek1
dir[i, 2] <- -1
}
}
}
for (i in n:2L) {
if (dir[i, 1] == -1) {
m <- merges[i, 1]
if (m > 0) {
m1 <- merges[m, 1]
merges[m, 1] <- merges[m, 2]
merges[m, 2] <- m1
if (dir[m, 1] == dir[m, 2]) {
dir[m, ] <- -dir[m, ]
}
}
}
if (dir[i, 2] == -1) {
m <- merges[i, 2]
if (m > 0) {
m1 <- merges[m, 1]
merges[m, 1] <- merges[m, 2]
merges[m, 2] <- m1
if (dir[m, 1] == dir[m, 2]) {
dir[m, ] <- -dir[m, ]
}
}
}
}
clusters <- as.list(1:n)
for (i in 1:n) {
j <- merges[[i, 1]]
k <- merges[[i, 2]]
if ((j < 0) && (k < 0)) {
clusters[[i]] <- c(-j, -k)
} else if (j < 0) {
clusters[[i]] <- c(-j, clusters[[k]])
} else if (k < 0) {
clusters[[i]] <- c(clusters[[j]], -k)
} else {
clusters[[i]] <- c(clusters[[j]], clusters[[k]])
}
}
x1 <- x
x1$merge <- merges
x1$order <- clusters[[n]]
return(x1)
}
================================================
FILE: R/mvgam_setup.R
================================================
#' Generic GAM setup function
#' @importFrom stats na.fail
#' @noRd
mvgam_setup <- function(
formula,
knots,
family = gaussian(),
dat = list(),
na.action,
drop.unused.levels = FALSE,
maxit = 5
) {
if (missing(knots)) {
out <- init_gam(formula(formula), data = dat, family = family)
attr(out, 'knots') <- NULL
} else {
if (!is.list(knots)) {
stop('all "knot" arguments must be supplied as lists', call. = FALSE)
}
out <- init_gam(
formula(formula),
data = dat,
family = family,
knots = knots
)
attr(out, 'knots') <- knots
}
out
}
#' Generic JAGAM setup function
#' @noRd
#'
jagam_setup <- function(
ss_gam,
formula,
data_train,
family,
family_char,
knots
) {
# Change the formula to a Poisson-like formula if this is a cbind Binomial,
# as jagam will fail if it sees that
if (family$family %in% c('binomial', 'beta_binomial')) {
resp_terms <- as.character(terms(formula(formula))[[2]])
if (any(grepl('cbind', resp_terms))) {
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
out_name <- resp_terms[1]
} else {
stop(
'Binomial family requires the cbind() left-hand side formula syntax',
call. = FALSE
)
}
formula <- update(formula, paste(out_name, '~ .'))
family <- poisson()
}
# Set file save location in tempdir
file_name <- tempfile(pattern = 'base_gam', fileext = '.txt')
if (length(ss_gam$smooth) == 0) {
smooths_included <- FALSE
# If no smooth terms are included, jagam will fail; so add a fake one and remove
# it from the model and data structures later
data_train$fakery <- rnorm(length(data_train$y))
form_fake <- update.formula(formula, ~ . + s(fakery, k = 3))
fakery_names <- names(
mvgam_setup(
formula = form_fake,
family = family_to_mgcvfam(family),
dat = data_train,
drop.unused.levels = FALSE
)$coefficients
)
xcols_drop <- grep('s(fakery', fakery_names, fixed = TRUE)
if (!missing(knots)) {
ss_jagam <- mgcv::jagam(
form_fake,
data = data_train,
family = family_to_jagamfam(family_char),
file = file_name,
sp.prior = 'gamma',
diagonalize = FALSE,
knots = knots,
drop.unused.levels = FALSE
)
} else {
ss_jagam <- mgcv::jagam(
form_fake,
data = data_train,
family = family_to_jagamfam(family_char),
file = file_name,
sp.prior = 'gamma',
diagonalize = FALSE,
drop.unused.levels = FALSE
)
}
data_train$fakery <- NULL
} else {
smooths_included <- TRUE
xcols_drop <- NULL
# If smooth terms included, use the original formula
if (!missing(knots)) {
ss_jagam <- mgcv::jagam(
formula,
data = data_train,
family = family_to_jagamfam(family_char),
file = file_name,
sp.prior = 'gamma',
diagonalize = FALSE,
knots = knots,
drop.unused.levels = FALSE
)
} else {
ss_jagam <- mgcv::jagam(
formula,
data = data_train,
family = family_to_jagamfam(family_char),
file = file_name,
sp.prior = 'gamma',
diagonalize = FALSE,
drop.unused.levels = FALSE
)
}
}
return(list(
file_name = file_name,
ss_jagam = ss_jagam,
smooths_included = smooths_included,
xcols_drop = xcols_drop
))
}
#' @noRd
get_offset <- function(model) {
nm1 <- names(attributes(model$terms)$dataClasses)
if ('(offset)' %in% nm1) {
deparse(as.list(model$call)$offset)
} else {
sub("offset\\((.*)\\)$", "\\1", grep('offset', nm1, value = TRUE))
}
}
#' @noRd
trim_mgcv <- function(mgcv_model) {
mgcv_model$fitted.values <- mgcv_model$residuals <- mgcv_model$linear.predictors <-
mgcv_model$working.weights <- mgcv_model$z <- NULL
mgcv_model
}
#' Fill in missing observations in data_train so the size of the dataset is correct when
#' building the initial JAGS model
#' @noRd
replace_nas = function(var) {
if (all(is.na(var))) {
# Sampling from uniform[0.1,0.99] will allow all the gam models
# to work, even though the Poisson / Negative Binomial will issue
# warnings. This is ok as we just need to produce the linear predictor matrix
# and store the coefficient names
var <- runif(length(var), 0.1, 0.99)
} else {
# If there are some non-missing observations,
# sample from the observed values to ensure
# distributional assumptions are met without warnings
var[which(is.na(var))] <-
sample(var[which(!is.na(var))], length(which(is.na(var))), replace = TRUE)
}
var
}
#' The below functions are mostly perfect copies of functions
#' written originally by Prof Simon Wood
#' All credit goes to Prof Wood and the mgcv development team.
#' They only exist in mvgam because of CRAN restrictions on
#' calling internal functions from other packages
#' @noRd
rmvn <- function(n, mu, sig) {
L <- mgcv::mroot(sig)
m <- ncol(L)
t(mu + L %*% matrix(rnorm(m * n), m, n))
}
#' @noRd
init_gam <- function(
formula,
family = gaussian(),
data = list(),
na.action = na.omit,
knots = NULL,
drop.unused.levels = FALSE,
control = mgcv::gam.control(),
centred = TRUE,
diagonalize = FALSE,
sp = NULL
) {
if (is.character(family)) {
family <- eval(parse(text = family))
}
if (is.function(family)) {
family <- family()
}
if (is.null(family$family)) {
stop("family not recognized")
}
gp <- mgcv::interpret.gam(formula) # interpret the formula
cl <- match.call() # call needed in gam object for update to work
mf <- match.call(expand.dots = FALSE)
mf$formula <- gp$fake.formula
mf$family <- mf$knots <- mf$sp <- mf$file <- mf$control <-
mf$centred <- mf$sp.prior <- mf$diagonalize <- NULL
mf$drop.unused.levels <- drop.unused.levels
mf[[1]] <- quote(stats::model.frame) ##as.name("model.frame")
pmf <- mf
pmf$formula <- gp$pf
pmf <- eval(pmf, parent.frame())
pterms <- attr(pmf, "terms")
rm(pmf)
mf <- eval(mf, parent.frame())
if (nrow(mf) < 2) {
stop("Not enough (non-NA) data to do anything meaningful")
}
terms <- attr(mf, "terms")
## summarize the *raw* input variables
## note can't use get_all_vars here -- buggy with matrices
vars <- all.vars(gp$fake.formula[-2]) ## drop response here
inp <- parse(text = paste("list(", paste(vars, collapse = ","), ")"))
if (!is.list(data) && !is.data.frame(data)) {
data <- as.data.frame(data)
}
dl <- eval(inp, data, parent.frame())
if (!control$keepData) {
rm(data)
} ## save space
names(dl) <- vars ## list of all variables needed
var.summary <- variable_summary(gp$pf, dl, nrow(mf)) ## summarize the input data
rm(dl)
G <- gam_setup(
gp,
pterms = pterms,
data = mf,
knots = knots,
sp = sp,
H = NULL,
absorb.cons = centred,
sparse.cons = FALSE,
select = TRUE,
idLinksBases = TRUE,
scale.penalty = control$scalePenalty,
diagonal.penalty = diagonalize
)
G$model <- mf
G$terms <- terms
G$family <- family
G$call <- cl
G$var.summary <- var.summary
lambda <- initial_spg(
G$X,
G$y,
G$w,
family,
G$S,
G$rank,
G$off,
offset = G$offset,
L = G$L
)
jags.ini <- list()
lam <- if (is.null(G$L)) lambda else G$L %*% lambda
#jin <- mgcv:::jini(G,lam)
G$formula <- formula
G$coefficients <- rep(0, length(G$term.names))
names(G$coefficients) <- G$term.names
G$residuals <- rnorm(NROW(G$X))
G$edf <- rep(1, length(G$coefficients))
names(G$edf) <- G$term.names
G$edf1 <- rep(1, length(G$coefficients))
names(G$edf1) <- G$term.names
G$sig2 <- 1
G$rank <- ncol(G$X)
G$Vp <- G$Ve <- diag(rep(1, length(G$coefficients)))
G$sp <- exp(G$sp)
G$scale.estimated <- FALSE
G$method <- 'UBRE'
G$pred.formula <- gp$pred.formula
class(G) <- c('gam', 'glm', 'lm')
G$R <- model.matrix(G)
return(G)
}
#'@importFrom mgcv gam.side smoothCon get.var Rrank interpret.gam initial.sp
#'@importFrom stats .getXlevels model.matrix model.offset na.omit
#'@importFrom methods cbind2
#'@noRd
gam_setup <- function(
formula,
pterms,
data = stop("No data supplied to gam_setup"),
knots = NULL,
sp = NULL,
min.sp = NULL,
H = NULL,
absorb.cons = TRUE,
sparse.cons = 0,
select = FALSE,
idLinksBases = TRUE,
scale.penalty = TRUE,
paraPen = NULL,
gamm.call = FALSE,
drop.intercept = FALSE,
diagonal.penalty = FALSE,
apply.by = TRUE,
list.call = FALSE,
modCon = 0
) {
if (inherits(formula, "split.gam.formula")) {
split <- formula
} else if (inherits(formula, "formula")) {
split <- mgcv::interpret.gam(formula)
} else {
stop("First argument is no sort of formula!")
}
if (length(split$smooth.spec) == 0) {
if (split$pfok == 0) {
stop("You've got no model....")
}
m <- 0
} else {
m <- length(split$smooth.spec)
}
G <- list(
m = m,
min.sp = min.sp,
H = H,
pearson.extra = 0,
dev.extra = 0,
n.true = -1,
pterms = pterms
)
if (is.null(attr(data, "terms"))) {
mf <- model.frame(split$pf, data, drop.unused.levels = FALSE)
} else {
mf <- data
}
G$intercept <- attr(attr(mf, "terms"), "intercept") > 0
if (list.call) {
offi <- attr(pterms, "offset")
if (!is.null(offi)) {
G$offset <- mf[[names(attr(pterms, "dataClasses"))[offi]]]
}
} else {
G$offset <- model.offset(mf)
}
if (!is.null(G$offset)) {
G$offset <- as.numeric(G$offset)
}
if (drop.intercept) {
attr(pterms, "intercept") <- 1
}
X <- model.matrix(pterms, mf)
if (drop.intercept) {
xat <- attributes(X)
ind <- xat$assign > 0
X <- X[, ind, drop = FALSE]
xat$assign <- xat$assign[ind]
xat$dimnames[[2]] <- xat$dimnames[[2]][ind]
xat$dim[2] <- xat$dim[2] - 1
attributes(X) <- xat
G$intercept <- FALSE
}
rownames(X) <- NULL
G$nsdf <- ncol(X)
G$contrasts <- attr(X, "contrasts")
G$xlevels <- .getXlevels(pterms, mf)
G$assign <- attr(X, "assign")
PP <- parametric_penalty(pterms, G$assign, paraPen, sp)
if (!is.null(PP)) {
ind <- 1:length(PP$sp)
if (!is.null(sp)) {
sp <- sp[-ind]
}
if (!is.null(min.sp)) {
PP$min.sp <- min.sp[ind]
min.sp <- min.sp[-ind]
}
}
G$smooth <- list()
G$S <- list()
if (gamm.call) {
if (m > 0) {
for (i in 1:m) {
attr(split$smooth.spec[[i]], "gamm") <- TRUE
}
}
}
if (m > 0 && idLinksBases) {
id.list <- list()
for (i in 1:m) {
if (!is.null(split$smooth.spec[[i]]$id)) {
id <- as.character(split$smooth.spec[[i]]$id)
if (length(id.list) && id %in% names(id.list)) {
ni <- length(id.list[[id]]$sm.i)
id.list[[id]]$sm.i[ni + 1] <- i
base.i <- id.list[[id]]$sm.i[1]
split$smooth.spec[[i]] <- clone_smooth_spec(
split$smooth.spec[[base.i]],
split$smooth.spec[[i]]
)
temp.term <- split$smooth.spec[[i]]$term
for (j in 1:length(temp.term)) {
id.list[[id]]$data[[j]] <- cbind(
id.list[[id]]$data[[j]],
mgcv::get.var(temp.term[j], data, vecMat = FALSE)
)
}
} else {
id.list[[id]] <- list(sm.i = i)
id.list[[id]]$data <- list()
term <- split$smooth.spec[[i]]$term
for (j in 1:length(term)) {
id.list[[id]]$data[[j]] <- mgcv::get.var(
term[j],
data,
vecMat = FALSE
)
}
}
}
}
}
G$off <- array(0, 0)
first.para <- G$nsdf + 1
sm <- list()
newm <- 0
if (m > 0) {
for (i in 1:m) {
id <- split$smooth.spec[[i]]$id
if (is.null(id) || !idLinksBases) {
sml <- mgcv::smoothCon(
split$smooth.spec[[i]],
data,
knots,
absorb.cons,
scale.penalty = scale.penalty,
null.space.penalty = select,
sparse.cons = sparse.cons,
diagonal.penalty = diagonal.penalty,
apply.by = apply.by,
modCon = modCon
)
} else {
names(id.list[[id]]$data) <- split$smooth.spec[[i]]$term
sml <- mgcv::smoothCon(
split$smooth.spec[[i]],
id.list[[id]]$data,
knots,
absorb.cons,
n = nrow(data),
dataX = data,
scale.penalty = scale.penalty,
null.space.penalty = select,
sparse.cons = sparse.cons,
diagonal.penalty = diagonal.penalty,
apply.by = apply.by,
modCon = modCon
)
}
ind <- 1:length(sml)
sm[ind + newm] <- sml[ind]
newm <- newm + length(sml)
}
}
G$m <- m <- newm
if (m > 0) {
sm <- mgcv::gam.side(sm, X, tol = .Machine$double.eps^0.5)
if (!apply.by) {
for (i in 1:length(sm)) {
if (!is.null(sm[[i]]$X0)) {
ind <- attr(sm[[i]], "del.index")
sm[[i]]$X <- if (is.null(ind)) {
sm[[i]]$X0
} else {
sm[[i]]$X0[, -ind, drop = FALSE]
}
}
}
}
}
idx <- list()
L <- matrix(0, 0, 0)
lsp.names <- sp.names <- rep("", 0)
if (m > 0) {
for (i in 1:m) {
id <- sm[[i]]$id
length.S <- if (is.null(sm[[i]]$updateS)) {
length(sm[[i]]$S)
} else {
sm[[i]]$n.sp
}
Li <- if (is.null(sm[[i]]$L)) diag(length.S) else sm[[i]]$L
if (length.S > 0) {
if (length.S == 1) {
lspn <- sm[[i]]$label
} else {
Sname <- names(sm[[i]]$S)
lspn <- if (is.null(Sname)) {
paste(sm[[i]]$label, 1:length.S, sep = "")
} else {
paste(sm[[i]]$label, Sname, sep = "")
}
}
spn <- lspn[1:ncol(Li)]
}
if (is.null(id) || is.null(idx[[id]])) {
if (!is.null(id)) {
idx[[id]]$c <- ncol(L) + 1
idx[[id]]$nc <- ncol(Li)
}
L <- rbind(
cbind(L, matrix(0, nrow(L), ncol(Li))),
cbind(matrix(0, nrow(Li), ncol(L)), Li)
)
if (length.S > 0) {
sp.names <- c(sp.names, spn)
lsp.names <- c(lsp.names, lspn)
}
} else {
L0 <- matrix(0, nrow(Li), ncol(L))
if (ncol(Li) > idx[[id]]$nc) {
stop(
"Later terms sharing an `id' can not have more smoothing parameters than the first such term"
)
}
L0[, idx[[id]]$c:(idx[[id]]$c + ncol(Li) - 1)] <- Li
L <- rbind(L, L0)
if (length.S > 0) {
lsp.names <- c(lsp.names, lspn)
}
}
}
}
Xp <- NULL
if (m > 0) {
for (i in 1:m) {
n.para <- ncol(sm[[i]]$X)
sm[[i]]$first.para <- first.para
first.para <- first.para + n.para
sm[[i]]$last.para <- first.para - 1
Xoff <- attr(sm[[i]]$X, "offset")
if (!is.null(Xoff)) {
if (is.null(G$offset)) G$offset <- Xoff else G$offset <- G$offset + Xoff
}
if (is.null(sm[[i]]$Xp)) {
if (!is.null(Xp)) Xp <- cbind2(Xp, sm[[i]]$X)
} else {
if (is.null(Xp)) {
Xp <- X
}
Xp <- cbind2(Xp, sm[[i]]$Xp)
sm[[i]]$Xp <- NULL
}
X <- cbind2(X, sm[[i]]$X)
sm[[i]]$X <- NULL
G$smooth[[i]] <- sm[[i]]
}
}
if (is.null(Xp)) {
G$cmX <- colMeans(X)
} else {
G$cmX <- colMeans(Xp)
qrx <- qr(Xp, LAPACK = TRUE)
R <- qr.R(qrx)
p <- ncol(R)
rank <- mgcv::Rrank(R)
QtX <- qr.qty(qrx, X)[1:rank, ]
if (rank < p) {
R <- R[1:rank, ]
qrr <- qr(t(R), tol = 0)
R <- qr.R(qrr)
G$P <- forwardsolve(t(R), QtX)
} else {
G$P <- backsolve(R, QtX)
}
if (rank < p) {
G$P <- qr.qy(qrr, rbind(G$P, matrix(0, p - rank, p)))
}
G$P[qrx$pivot, ] <- G$P
}
G$X <- X
rm(X)
n.p <- ncol(G$X)
if (!is.null(sp)) {
ok <- TRUE
if (length(sp) < ncol(L)) {
warning("Supplied smoothing parameter vector is too short - ignored.")
ok <- FALSE
}
if (sum(is.na(sp))) {
warning("NA's in supplied smoothing parameter vector - ignoring.")
ok <- FALSE
}
} else {
ok <- FALSE
}
G$sp <- if (ok) sp[1:ncol(L)] else rep(-1, ncol(L))
names(G$sp) <- sp.names
k <- 1
if (m > 0) {
for (i in 1:m) {
id <- sm[[i]]$id
if (is.null(sm[[i]]$L)) {
Li <- diag(length(sm[[i]]$S))
} else {
Li <- sm[[i]]$L
}
if (is.null(id)) {
spi <- sm[[i]]$sp
if (!is.null(spi)) {
if (length(spi) != ncol(Li)) {
stop(
"incorrect number of smoothing parameters supplied for a smooth term"
)
}
G$sp[k:(k + ncol(Li) - 1)] <- spi
}
k <- k + ncol(Li)
} else {
spi <- sm[[i]]$sp
if (is.null(idx[[id]]$sp.done)) {
if (!is.null(spi)) {
if (length(spi) != ncol(Li)) {
stop(
"incorrect number of smoothing parameters supplied for a smooth term"
)
}
G$sp[idx[[id]]$c:(idx[[id]]$c + idx[[id]]$nc - 1)] <- spi
}
idx[[id]]$sp.done <- TRUE
k <- k + idx[[id]]$nc
}
}
}
}
k <- 1
if (length(idx)) {
for (i in 1:length(idx)) {
idx[[i]]$sp.done <- FALSE
}
}
if (m > 0) {
for (i in 1:m) {
id <- sm[[i]]$id
if (!is.null(id)) {
if (idx[[id]]$nc > 0) {
G$smooth[[i]]$sp <- G$sp[
idx[[id]]$c:(idx[[id]]$c +
idx[[id]]$nc -
1)
]
}
if (!idx[[id]]$sp.done) {
idx[[id]]$sp.done <- TRUE
k <- k + idx[[id]]$nc
}
} else {
if (is.null(sm[[i]]$L)) {
nc <- length(sm[[i]]$S)
} else {
nc <- ncol(sm[[i]]$L)
}
if (nc > 0) {
G$smooth[[i]]$sp <- G$sp[k:(k + nc - 1)]
}
k <- k + nc
}
}
}
if (!is.null(min.sp)) {
if (length(min.sp) < nrow(L)) {
stop("length of min.sp is wrong.")
}
if (nrow(L) > 0) {
min.sp <- min.sp[1:nrow(L)]
}
if (sum(is.na(min.sp))) {
stop("NA's in min.sp.")
}
if (sum(min.sp < 0)) stop("elements of min.sp must be non negative.")
}
k.sp <- 0
G$rank <- array(0, 0)
if (m > 0) {
for (i in 1:m) {
sm <- G$smooth[[i]]
if (length(sm$S) > 0) {
for (j in 1:length(sm$S)) {
k.sp <- k.sp + 1
G$off[k.sp] <- sm$first.para
G$S[[k.sp]] <- sm$S[[j]]
G$rank[k.sp] <- sm$rank[j]
if (!is.null(min.sp)) {
if (is.null(H)) {
H <- matrix(0, n.p, n.p)
}
H[sm$first.para:sm$last.para, sm$first.para:sm$last.para] <- H[
sm$first.para:sm$last.para,
sm$first.para:sm$last.para
] +
min.sp[k.sp] *
sm$S[[j]]
}
}
}
}
}
if (!is.null(PP)) {
L <- rbind(
cbind(L, matrix(0, nrow(L), ncol(PP$L))),
cbind(matrix(0, nrow(PP$L), ncol(L)), PP$L)
)
G$off <- c(PP$off, G$off)
G$S <- c(PP$S, G$S)
G$rank <- c(PP$rank, G$rank)
G$sp <- c(PP$sp, G$sp)
lsp.names <- c(PP$full.sp.names, lsp.names)
G$n.paraPen <- length(PP$off)
if (!is.null(PP$min.sp)) {
if (is.null(H)) {
H <- matrix(0, n.p, n.p)
}
for (i in 1:length(PP$S)) {
ind <- PP$off[i]:(PP$off[i] + ncol(PP$S[[i]]) - 1)
H[ind, ind] <- H[ind, ind] + PP$min.sp[i] * PP$S[[i]]
}
}
} else {
G$n.paraPen <- 0
}
fix.ind <- G$sp >= 0
if (sum(fix.ind)) {
lsp0 <- G$sp[fix.ind]
ind <- lsp0 == 0
ef0 <- indi <- (1:length(ind))[ind]
if (length(indi) > 0) {
for (i in 1:length(indi)) {
ii <- G$off[i]:(G$off[i] + ncol(G$S[[i]]) - 1)
ef0[i] <- norm(G$X[, ii], type = "F")^2 /
norm(G$S[[i]], type = "F") *
.Machine$double.eps *
0.1
}
}
lsp0[!ind] <- log(lsp0[!ind])
lsp0[ind] <- log(ef0)
lsp0 <- as.numeric(L[, fix.ind, drop = FALSE] %*% lsp0)
L <- L[, !fix.ind, drop = FALSE]
G$sp <- G$sp[!fix.ind]
} else {
lsp0 <- rep(0, nrow(L))
}
G$H <- H
if (ncol(L) == nrow(L) && !sum(L != diag(ncol(L)))) {
L <- NULL
}
G$L <- L
G$lsp0 <- lsp0
names(G$lsp0) <- lsp.names
if (absorb.cons == FALSE) {
G$C <- matrix(0, 0, n.p)
if (m > 0) {
for (i in 1:m) {
if (is.null(G$smooth[[i]]$C)) {
n.con <- 0
} else {
n.con <- nrow(G$smooth[[i]]$C)
}
C <- matrix(0, n.con, n.p)
C[, G$smooth[[i]]$first.para:G$smooth[[i]]$last.para] <- G$smooth[[i]]$C
G$C <- rbind(G$C, C)
G$smooth[[i]]$C <- NULL
}
rm(C)
}
}
G$y <- drop(data[[split$response]])
ydim <- dim(G$y)
if (!is.null(ydim) && length(ydim) < 2) {
dim(G$y) <- NULL
}
G$n <- nrow(data)
if (is.null(data$"(weights)")) {
G$w <- rep(1, G$n)
} else {
G$w <- data$"(weights)"
}
if (G$nsdf > 0) {
term.names <- colnames(G$X)[1:G$nsdf]
} else {
term.names <- array("", 0)
}
n.smooth <- length(G$smooth)
n.sp0 <- 0
if (n.smooth) {
for (i in 1:n.smooth) {
k <- 1
jj <- G$smooth[[i]]$first.para:G$smooth[[i]]$last.para
if (G$smooth[[i]]$df > 0) {
for (j in jj) {
term.names[j] <- paste(
G$smooth[[i]]$label,
".",
as.character(k),
sep = ""
)
k <- k + 1
}
}
n.sp <- length(G$smooth[[i]]$S)
if (n.sp) {
G$smooth[[i]]$first.sp <- n.sp0 + 1
n.sp0 <- G$smooth[[i]]$last.sp <- n.sp0 + n.sp
}
if (!is.null(G$smooth[[i]]$g.index)) {
if (is.null(G$g.index)) {
G$g.index <- rep(FALSE, n.p)
}
G$g.index[jj] <- G$smooth[[i]]$g.index
}
}
}
G$term.names <- term.names
G$pP <- PP
G
}
#' @noRd
parametric_penalty <- function(pterms, assign, paraPen, sp0) {
S <- list()
off <- rep(0, 0)
rank <- rep(0, 0)
sp <- rep(0, 0)
full.sp.names <- rep("", 0)
L <- matrix(0, 0, 0)
k <- 0
tind <- unique(assign)
n.t <- length(tind)
if (n.t > 0) {
for (j in 1:n.t) {
if (tind[j] > 0) {
term.label <- attr(pterms[tind[j]], "term.label")
P <- paraPen[[term.label]]
if (!is.null(P)) {
ind <- (1:length(assign))[assign == tind[j]]
Li <- P$L
P$L <- NULL
spi <- P$sp
P$sp <- NULL
ranki <- P$rank
P$rank <- NULL
np <- length(P)
if (!is.null(ranki) && length(ranki) != np) {
stop("`rank' has wrong length in `paraPen'")
}
if (np) {
for (i in 1:np) {
k <- k + 1
S[[k]] <- P[[i]]
off[k] <- min(ind)
if (ncol(P[[i]]) != nrow(P[[i]]) || nrow(P[[i]]) != length(ind)) {
stop(" a parametric penalty has wrong dimension")
}
if (is.null(ranki)) {
ev <- eigen(S[[k]], symmetric = TRUE, only.values = TRUE)$values
rank[k] <- sum(ev > max(ev) * .Machine$double.eps * 10)
} else {
rank[k] <- ranki[i]
}
}
}
if (np) {
if (is.null(Li)) {
Li <- diag(np)
}
if (nrow(Li) != np) {
stop("L has wrong dimension in `paraPen'")
}
L <- rbind(
cbind(L, matrix(0, nrow(L), ncol(Li))),
cbind(matrix(0, nrow(Li), ncol(L)), Li)
)
ind <- (length(sp) + 1):(length(sp) + ncol(Li))
ind2 <- (length(sp) + 1):(length(sp) + nrow(Li))
if (is.null(spi)) {
sp[ind] <- -1
} else {
if (length(spi) != ncol(Li)) {
stop("`sp' dimension wrong in `paraPen'")
}
sp[ind] <- spi
}
if (length(ind) > 1) {
names(sp)[ind] <- paste(
term.label,
ind -
ind[1] +
1,
sep = ""
)
} else {
names(sp)[ind] <- term.label
}
if (length(ind2) > 1) {
full.sp.names[ind2] <- paste(
term.label,
ind2 - ind2[1] + 1,
sep = ""
)
} else {
full.sp.names[ind2] <- term.label
}
}
}
}
}
}
if (k == 0) {
return(NULL)
}
if (!is.null(sp0)) {
if (length(sp0) < length(sp)) {
stop("`sp' too short")
}
sp0 <- sp0[1:length(sp)]
sp[sp < 0] <- sp0[sp < 0]
}
list(
S = S,
off = off,
sp = sp,
L = L,
rank = rank,
full.sp.names = full.sp.names
)
}
#' @noRd
clone_smooth_spec <- function(specb, spec) {
if (specb$dim != spec$dim) {
stop("`id' linked smooths must have same number of arguments")
}
if (inherits(specb, c("tensor.smooth.spec", "t2.smooth.spec"))) {
specb$term <- spec$term
specb$label <- spec$label
specb$by <- spec$by
k <- 1
for (i in 1:length(specb$margin)) {
if (is.null(spec$margin)) {
for (j in 1:length(specb$margin[[i]]$term)) {
specb$margin[[i]]$term[j] <- spec$term[k]
k <- k + 1
}
specb$margin[[i]]$label <- ""
} else {
specb$margin[[i]]$term <- spec$margin[[i]]$term
specb$margin[[i]]$label <- spec$margin[[i]]$label
specb$margin[[i]]$xt <- spec$margin[[i]]$xt
}
}
} else {
specb$term <- spec$term
specb$label <- spec$label
specb$by <- spec$by
specb$xt <- spec$xt
}
specb
}
#' Summarize all the variables in a list of variables
#'
#' This function is derived from \code{mgcv:::variable.summary}
#'
#' @author Simon N Wood with modifications by Nicholas Clark
#' @noRd
variable_summary <- function(pf, dl, n) {
v.n <- length(dl)
v.name <- v.name1 <- names(dl)
if (v.n) {
k <- 0
for (i in 1:v.n) {
if (length(dl[[i]]) >= n) {
k <- k + 1
v.name[k] <- v.name1[i]
}
}
if (k > 0) v.name <- v.name[1:k] else v.name <- rep("", k)
}
p.name <- all.vars(pf[-2])
vs <- list()
v.n <- length(v.name)
if (v.n > 0) {
for (i in 1:v.n) {
if (v.name[i] %in% p.name) {
para <- TRUE
} else {
para <- FALSE
}
if (para && is.matrix(dl[[v.name[i]]]) && ncol(dl[[v.name[i]]]) > 1) {
x <- matrix(
apply(
dl[[v.name[i]]],
2,
quantile,
probs = 0.5,
type = 3,
na.rm = TRUE
),
1,
ncol(dl[[v.name[i]]])
)
} else {
x <- dl[[v.name[i]]]
if (is.character(x)) {
x <- as.factor(x)
}
if (is.factor(x)) {
x <- x[!is.na(x)]
lx <- levels(x)
freq <- tabulate(x)
ii <- min((1:length(lx))[freq == max(freq)])
x <- factor(lx[ii], levels = lx)
} else {
x <- as.numeric(x)
x <- c(
min(x, na.rm = TRUE),
as.numeric(quantile(x, probs = 0.5, type = 3, na.rm = TRUE)),
max(x, na.rm = TRUE)
)
}
}
vs[[v.name[i]]] <- x
}
}
vs
}
#' @importFrom stats lm
#' @noRd
initial_spg <- function(
x,
y,
weights,
family,
S,
rank,
off,
offset = NULL,
L = NULL,
lsp0 = NULL,
type = 1,
start = NULL,
mustart = NULL,
etastart = NULL,
E = NULL,
...
) {
if (length(S) == 0) {
return(rep(0, 0))
}
nobs <- nrow(x)
if (is.null(mustart)) {
mukeep <- NULL
} else {
mukeep <- mustart
}
eval(family$initialize)
if (inherits(family, "general.family")) {
lbb <- family$ll(
y,
x,
start,
weights,
family,
offset = offset,
deriv = 1
)$lbb
pcount <- rep(0, ncol(lbb))
for (i in 1:length(S)) {
ind <- off[i]:(off[i] + ncol(S[[i]]) - 1)
dlb <- -diag(lbb[ind, ind, drop = FALSE])
indp <- rowSums(abs(S[[i]])) > max(S[[i]]) * .Machine$double.eps^0.75 &
dlb != 0
ind <- ind[indp]
pcount[ind] <- pcount[ind] + 1
}
lambda <- rep(0, length(S))
for (i in 1:length(S)) {
ind <- off[i]:(off[i] + ncol(S[[i]]) - 1)
lami <- 1
dlb <- abs(diag(lbb[ind, ind, drop = FALSE]))
dS <- diag(S[[i]])
pc <- pcount[ind]
ind <- rowSums(abs(S[[i]])) > max(S[[i]]) * .Machine$double.eps^0.75 &
dlb != 0
dlb <- dlb[ind] / pc[ind]
dS <- dS[ind]
rm <- max(length(dS) / rank[i], 1)
while (
sqrt(
mean(dlb / (dlb + lami * dS * rm)) *
mean(dlb) /
mean(
dlb +
lami * dS * rm
)
) >
0.4
) {
lami <- lami * 5
}
while (
sqrt(
mean(dlb / (dlb + lami * dS * rm)) *
mean(dlb) /
mean(
dlb +
lami * dS * rm
)
) <
0.4
) {
lami <- lami / 5
}
lambda[i] <- lami
}
} else {
if (is.null(mukeep)) {
if (!is.null(start)) {
etastart <- drop(x %*% start)
}
if (!is.null(etastart)) mustart <- family$linkinv(etastart)
} else {
mustart <- mukeep
}
if (inherits(family, "extended.family")) {
theta <- family$getTheta()
Ddo <- family$Dd(y, mustart, theta, weights)
mu.eta2 <- family$mu.eta(family$linkfun(mustart))^2
w <- 0.5 * as.numeric(Ddo$Dmu2 * mu.eta2)
if (any(w < 0)) w <- 0.5 * as.numeric(Ddo$EDmu2 * mu.eta2)
} else {
w <- as.numeric(
weights *
family$mu.eta(family$linkfun(mustart))^2 /
family$variance(mustart)
)
}
w <- sqrt(w)
if (type == 1) {
lambda <- mgcv::initial.sp(w * x, S, off)
} else {
csX <- colSums((w * x)^2)
lambda <- rep(0, length(S))
for (i in 1:length(S)) {
ind <- off[i]:(off[i] + ncol(S[[i]]) - 1)
lambda[i] <- sum(csX[ind]) / sqrt(sum(S[[i]]^2))
}
}
}
if (!is.null(L)) {
lsp <- log(lambda)
if (is.null(lsp0)) {
lsp0 <- rep(0, nrow(L))
}
lsp <- as.numeric(coef(lm(lsp ~ L - 1 + offset(lsp0))))
lambda <- exp(lsp)
}
lambda
}
#' Set up JAGS data and model file for fitting GAMs
#'
#' This function is derived from \code{mgcv:::jagam}
#'
#' @author Simon N Wood with modifications by Nicholas Clark
#' @importFrom mgcv gam.control interpret.gam
#' @noRd
jagam <- function(
formula,
family = gaussian,
data = list(),
file,
weights = NULL,
na.action,
offset = NULL,
knots = NULL,
sp = NULL,
drop.unused.levels = FALSE,
control = mgcv::gam.control(),
centred = TRUE,
diagonalize = FALSE
) {
## Start the model specification
cat("model {\n", file = file)
sp.prior <- 'gamma'
# Evaluate family
if (is.character(family)) {
family <- eval(parse(text = family))
}
if (is.function(family)) {
family <- family()
}
if (is.null(family$family)) {
stop("family not recognized")
}
# Interpret the formula and initialize the model.frame object
gp <- mgcv::interpret.gam(formula)
gp$pfok <- 1
cl <- match.call()
mf <- match.call(expand.dots = FALSE)
mf$formula <- gp$fake.formula
mf$family <- mf$knots <- mf$sp <- mf$file <- mf$control <-
mf$centred <- mf$sp.prior <- mf$diagonalize <- NULL
mf$drop.unused.levels <- drop.unused.levels
mf[[1]] <- quote(stats::model.frame)
pmf <- mf
# Extract fixed effect terms
# Multiple formula objects
if (is.list(formula)) {
environment(formula) <- environment(formula[[1]])
pterms <- list()
tlab <- rep("", 0)
for (i in 1:length(formula)) {
pmf$formula <- gp[[i]]$pf
pterms[[i]] <- attr(eval(pmf, parent.frame()), "terms")
tlabi <- attr(pterms[[i]], "term.labels")
if (i > 1 && length(tlabi) > 0) {
tlabi <- paste(tlabi, i - 1, sep = ".")
}
tlab <- c(tlab, tlabi)
}
attr(pterms, "term.labels") <- tlab
# Single linear predictor case
} else {
pmf$formula <- gp$pf
pmf <- eval(pmf, parent.frame())
pterms <- attr(pmf, "terms")
}
mf <- eval(mf, parent.frame())
if (nrow(mf) < 2) {
stop("Not enough (non-NA) data to do anything meaningful")
}
terms <- attr(mf, "terms")
# Summarize the *raw* input variables
vars <- all.vars(gp$fake.formula[-2])
inp <- parse(text = paste("list(", paste(vars, collapse = ","), ")"))
if (!is.list(data) && !is.data.frame(data)) {
data <- as.data.frame(data)
}
dl <- eval(inp, data, parent.frame())
rm(data)
names(dl) <- vars
var.summary <- variable_summary(gp$pf, dl, nrow(mf))
rm(dl)
gsname <- if (is.list(formula)) "gam_setup.list" else "gam_setup"
G <- do.call(
gsname,
list(
formula = gp,
pterms = pterms,
data = mf,
knots = knots,
sp = sp,
H = NULL,
absorb.cons = TRUE,
sparse.cons = FALSE,
select = TRUE,
idLinksBases = TRUE,
scale.penalty = control$scalePenalty
)
)
G$model <- mf
G$terms <- terms
G$family <- family
G$call <- cl
G$var.summary <- var.summary
## write JAGS code producing linear predictor and linking linear predictor to
## response....
use.weights <- if (is.null(weights)) FALSE else TRUE
use.weights <- write_jagslp(
"y",
family = poisson(),
file,
use.weights,
!is.null(G$offset)
)
if (is.null(weights) && use.weights) {
weights <- rep(1, nrow(G$X))
}
## start the JAGS data list...
jags.stuff <- list(y = G$y, n = length(G$y), X = G$X)
if (!is.null(G$offset)) {
jags.stuff$offset <- G$offset
}
if (use.weights) {
jags.stuff$w <- weights
}
if (family$family == "binomial") {
jags.stuff$y <- G$y * weights
}
## set the fixed effect priors...
lambda <- rep(1, length(G$S))
jags.ini <- list()
jags.ini$b <- rep(0, NCOL(G$X))
prior.tau <- 10
ptau <- 10
if (is.list(formula)) {
for (i in 1:length(G$nsdf)) {
if (G$nsdf[i] > 0) {
if (i == 1) {
cat(
" ## Parametric effect priors CHECK tau=1/",
signif(1 / sqrt(ptau), 2),
"^2 is appropriate!\n",
file = file,
append = TRUE,
sep = ""
)
cat(
" for (i in 1:",
G$nsdf[i],
") { b[i] ~ dnorm(0,",
ptau,
") }\n",
file = file,
append = TRUE,
sep = ""
)
} else {
cat(
" ## Parametric effect priors CHECK tau=1/",
signif(1 / sqrt(ptau), 2),
"^2 is appropriate!\n",
file = file,
append = TRUE,
sep = ""
)
cat(
" for (i in ",
attr(G$nsdf, 'pstart')[i],
':',
attr(G$nsdf, 'pstart')[i] + G$nsdf[i],
") { b[i] ~ dnorm(0,",
ptau,
") }\n",
file = file,
append = TRUE,
sep = ""
)
}
}
}
} else {
if (sum(G$nsdf) > 0) {
cat(
" ## Parametric effect priors CHECK tau=1/",
signif(1 / sqrt(ptau), 2),
"^2 is appropriate!\n",
file = file,
append = TRUE,
sep = ""
)
cat(
" for (i in 1:",
sum(G$nsdf),
") { b[i] ~ dnorm(0,",
ptau,
") }\n",
file = file,
append = TRUE,
sep = ""
)
}
}
## Work through smooths.
n.sp <- 0 ## count the smoothing parameters....
for (i in 1:length(G$smooth)) {
## Are penalties seperable...
seperable <- FALSE
M <- length(G$smooth[[i]]$S)
p <- G$smooth[[i]]$last.para - G$smooth[[i]]$first.para + 1 ## number of params
if (M <= 1) {
seperable <- TRUE
} else {
overlap <- rowSums(G$smooth[[i]]$S[[1]])
for (j in 2:M) {
overlap <- overlap & rowSums(G$smooth[[i]]$S[[j]])
}
if (!sum(overlap)) seperable <- TRUE
}
if (seperable) {
## double check that they are diagonal
if (M > 0) {
for (j in 1:M) {
if (
max(abs(
G$smooth[[i]]$S[[j]] - diag(diag(G$smooth[[i]]$S[[j]]), nrow = p)
)) >
0
) {
seperable <- FALSE
}
}
}
}
cat(
" ## prior for ",
G$smooth[[i]]$label,
"... \n",
file = file,
append = TRUE,
sep = ""
)
if (seperable) {
b0 <- G$smooth[[i]]$first.para
b1 <- G$smooth[[i]]$last.para
if (M == 0) {
cat(
" ## Note fixed vague prior, CHECK tau = 1/",
signif(1 / sqrt(ptau), 2),
"^2...\n",
file = file,
append = TRUE,
sep = ""
)
#b1 <- G$smooth[[i]]$last.para
ptau <- min(prior.tau[b0:b1])
cat(
" for (i in ",
b0,
":",
b1,
") { b[i] ~ dnorm(0,",
ptau,
") }\n",
file = file,
append = TRUE,
sep = ""
)
} else {
for (j in 1:M) {
D <- diag(G$smooth[[i]]$S[[j]]) > 0
#b1 <- sum(as.numeric(D)) + b0 - 1
n.sp <- n.sp + 1
#cat(" for (i in ",b0,":",b1,") { b[i] ~ dnorm(0, lambda[",n.sp,"]) }\n",file=file,append=TRUE,sep="")
#b0 <- b1 + 1
cat(
" for (i in ",
compress_iseq((b0:b1)[D]),
") { b[i] ~ dnorm(0, lambda[",
n.sp,
"]) }\n",
file = file,
append = TRUE,
sep = ""
)
}
}
} else {
## inseperable - requires the penalty matrices to be supplied to JAGS...
b0 <- G$smooth[[i]]$first.para
b1 <- G$smooth[[i]]$last.para
Kname <- paste("K", i, sep = "") ## total penalty matrix in JAGS
Sname <- paste("S", i, sep = "") ## components of total penalty in R & JAGS
cat(
" ",
Kname,
" <- ",
Sname,
"[1:",
p,
",1:",
p,
"] * lambda[",
n.sp + 1,
"] ",
file = file,
append = TRUE,
sep = ""
)
if (M > 1) {
## code to form total precision matrix...
for (j in 2:M) {
cat(
" + ",
Sname,
"[1:",
p,
",",
(j - 1) * p + 1,
":",
j * p,
"] * lambda[",
n.sp + j,
"]",
file = file,
append = TRUE,
sep = ""
)
}
}
cat(
"\n b[",
b0,
":",
b1,
"] ~ dmnorm(zero[",
b0,
":",
b1,
"],",
Kname,
") \n",
file = file,
append = TRUE,
sep = ""
)
n.sp <- n.sp + M
Sc <- G$smooth[[i]]$S[[1]]
if (M > 1) {
for (j in 2:M) {
Sc <- cbind(Sc, G$smooth[[i]]$S[[j]])
}
}
jags.stuff[[Sname]] <- Sc
jags.stuff$zero <- rep(0, ncol(G$X))
}
} ## smoothing penalties finished
## Write the smoothing parameter prior code, using L if it exists.
cat(
" ## smoothing parameter priors CHECK...\n",
file = file,
append = TRUE,
sep = ""
)
if (is.null(G$L)) {
if (sp.prior == "log.uniform") {
cat(" for (i in 1:", n.sp, ") {\n", file = file, append = TRUE, sep = "")
cat(" rho[i] ~ dunif(-12,12)\n", file = file, append = TRUE, sep = "")
cat(
" lambda[i] <- exp(rho[i])\n",
file = file,
append = TRUE,
sep = ""
)
cat(" }\n", file = file, append = TRUE, sep = "")
jags.ini$rho <- log(lambda)
} else {
## gamma priors
cat(" for (i in 1:", n.sp, ") {\n", file = file, append = TRUE, sep = "")
cat(
" lambda[i] ~ dgamma(.05,.005)\n",
file = file,
append = TRUE,
sep = ""
)
cat(
" rho[i] <- log(lambda[i])\n",
file = file,
append = TRUE,
sep = ""
)
cat(" }\n", file = file, append = TRUE, sep = "")
jags.ini$lambda <- lambda
}
} else {
jags.stuff$L <- G$L
rho.lo <- FALSE
if (any(G$lsp0 != 0)) {
jags.stuff$rho.lo <- G$lsp0
rho.lo <- TRUE
}
nr <- ncol(G$L)
if (sp.prior == "log.uniform") {
cat(
" for (i in 1:",
nr,
") { rho0[i] ~ dunif(-12,12) }\n",
file = file,
append = TRUE,
sep = ""
)
if (rho.lo) {
cat(
" rho <- rho.lo + L %*% rho0\n",
file = file,
append = TRUE,
sep = ""
)
} else {
cat(" rho <- L %*% rho0\n", file = file, append = TRUE, sep = "")
}
cat(
" for (i in 1:",
n.sp,
") { lambda[i] <- exp(rho[i]) }\n",
file = file,
append = TRUE,
sep = ""
)
jags.ini$rho0 <- log(lambda)
} else {
## gamma prior
cat(" for (i in 1:", nr, ") {\n", file = file, append = TRUE, sep = "")
cat(
" lambda0[i] ~ dgamma(.05,.005)\n",
file = file,
append = TRUE,
sep = ""
)
cat(
" rho0[i] <- log(lambda0[i])\n",
file = file,
append = TRUE,
sep = ""
)
cat(" }\n", file = file, append = TRUE, sep = "")
if (rho.lo) {
cat(
" rho <- rho.lo + L %*% rho0\n",
file = file,
append = TRUE,
sep = ""
)
} else {
cat(" rho <- L %*% rho0\n", file = file, append = TRUE, sep = "")
}
cat(
" for (i in 1:",
n.sp,
") { lambda[i] <- exp(rho[i]) }\n",
file = file,
append = TRUE,
sep = ""
)
jags.ini$lambda0 <- lambda
}
}
cat("}", file = file, append = TRUE)
G$formula = formula
G$rank = ncol(G$X) ## to Gibbs sample we force full rank!
list(pregam = G, jags.data = jags.stuff, jags.ini = jags.ini)
} ## new_jagam
#' Initialize a gam object using a list of formulae
#'
#' This function is derived from \code{mgcv:::gam.setup.list}
#'
#' @author Simon N Wood with modifications by Nicholas Clark
#' @noRd
gam_setup.list <- function(
formula,
pterms,
data = stop("No data supplied to gam.setup"),
knots = NULL,
sp = NULL,
min.sp = NULL,
H = NULL,
absorb.cons = TRUE,
sparse.cons = 0,
select = FALSE,
idLinksBases = TRUE,
scale.penalty = TRUE,
paraPen = NULL,
gamm.call = FALSE,
drop.intercept = NULL,
apply.by = TRUE,
modCon = 0
) {
# version of gam.setup for when gam is called with a list of formulae,
# specifying several linear predictors...
# key difference to gam.setup is an attribute to the model matrix,
# "lpi", which is a list
# of column indices for each linear predictor
d <- length(pterms)
if (is.null(drop.intercept)) {
drop.intercept <- rep(FALSE, d)
}
if (length(drop.intercept) != d) {
stop("length(drop.intercept) should be equal to number of model formulas")
}
lp.overlap <- if (formula$nlp < d) TRUE else FALSE
G <- gam_setup(
formula[[1]],
pterms[[1]],
data,
knots,
sp,
min.sp,
H,
absorb.cons,
sparse.cons,
select,
idLinksBases,
scale.penalty,
paraPen,
gamm.call,
drop.intercept[1],
apply.by = apply.by,
list.call = TRUE,
modCon = modCon
)
G$pterms <- pterms
G$offset <- list(G$offset)
G$xlevels <- list(G$xlevels)
G$assign <- list(G$assign)
used.sp <- length(G$lsp0)
if (!is.null(sp) && used.sp > 0) {
sp <- sp[-(1:used.sp)]
}
if (!is.null(min.sp) && nrow(G$L) > 0) {
min.sp <- min.sp[-(1:nrow(G$L))]
}
flpi <- lpi <- list()
for (i in 1:formula$nlp) {
lpi[[i]] <- rep(0, 0)
}
lpi[[1]] <- 1:ncol(G$X)
flpi[[1]] <- formula[[1]]$lpi
pof <- ncol(G$X)
pstart <- rep(0, d)
pstart[1] <- 1
if (d > 1) {
for (i in 2:d) {
if (is.null(formula[[i]]$response)) {
formula[[i]]$response <- formula$response
mv.response <- FALSE
} else {
mv.response <- TRUE
}
formula[[i]]$pfok <- 1
um <- gam_setup(
formula[[i]],
pterms[[i]],
data,
knots,
sp,
min.sp,
H,
absorb.cons,
sparse.cons,
select,
idLinksBases,
scale.penalty,
paraPen,
gamm.call,
drop.intercept[i],
apply.by = apply.by,
list.call = TRUE,
modCon = modCon
)
used.sp <- length(um$lsp0)
if (!is.null(sp) && used.sp > 0) {
sp <- sp[-(1:used.sp)]
}
if (!is.null(min.sp) && nrow(um$L) > 0) {
min.sp <- min.sp[-(1:nrow(um$L))]
}
flpi[[i]] <- formula[[i]]$lpi
for (j in formula[[i]]$lpi) {
lpi[[j]] <- c(lpi[[j]], pof + 1:ncol(um$X))
}
if (mv.response) {
G$y <- cbind(G$y, um$y)
}
if (i > formula$nlp && !is.null(um$offset)) {
stop("shared offsets not allowed")
}
G$offset[[i]] <- um$offset
if (!is.null(um$contrasts)) {
G$contrasts <- c(G$contrasts, um$contrasts)
}
G$xlevels[[i]] <- um$xlevels
G$assign[[i]] <- um$assign
G$rank <- c(G$rank, um$rank)
pstart[i] <- pof + 1
G$X <- cbind(G$X, um$X)
k <- G$m
if (um$m) {
for (j in 1:um$m) {
um$smooth[[j]]$first.para <- um$smooth[[j]]$first.para + pof
um$smooth[[j]]$last.para <- um$smooth[[j]]$last.para + pof
k <- k + 1
G$smooth[[k]] <- um$smooth[[j]]
}
}
ks <- length(G$S)
M <- length(um$S)
if (!is.null(um$L) || !is.null(G$L)) {
if (is.null(G$L)) {
G$L <- diag(1, nrow = ks)
}
if (is.null(um$L)) {
um$L <- diag(1, nrow = M)
}
G$L <- rbind(
cbind(G$L, matrix(0, nrow(G$L), ncol(um$L))),
cbind(matrix(0, nrow(um$L), ncol(G$L)), um$L)
)
}
G$off <- c(G$off, um$off + pof)
if (M) {
for (j in 1:M) {
ks <- ks + 1
G$S[[ks]] <- um$S[[j]]
}
}
G$m <- G$m + um$m
G$nsdf[i] <- um$nsdf
if (!is.null(um$P) || !is.null(G$P)) {
if (is.null(G$P)) {
G$P <- diag(1, nrow = pof)
}
k <- ncol(um$X)
if (is.null(um$P)) {
um$P <- diag(1, nrow = k)
}
G$P <- rbind(
cbind(G$P, matrix(0, pof, k)),
cbind(matrix(0, k, pof), um$P)
)
}
G$cmX <- c(G$cmX, um$cmX)
if (um$nsdf > 0) {
um$term.names[1:um$nsdf] <- paste(
um$term.names[1:um$nsdf],
i - 1,
sep = "."
)
}
G$term.names <- c(G$term.names, um$term.names)
G$lsp0 <- c(G$lsp0, um$lsp0)
G$sp <- c(G$sp, um$sp)
pof <- ncol(G$X)
}
}
## If there is overlap then there is a danger of lack of identifiability of the
## parameteric terms, especially if there are factors present in shared components.
## The following code deals with this possibility...
if (lp.overlap) {
rt <- olid(G$X, G$nsdf, pstart, flpi, lpi)
if (length(rt$dind) > 0) {
warning(
"dropping unidentifiable parametric terms from model",
call. = FALSE
)
G$X <- G$X[, -rt$dind]
G$cmX <- G$cmX[-rt$dind]
G$term.names <- G$term.names[-rt$dind]
for (i in 1:length(G$smooth)) {
k <- sum(rt$dind < G$smooth[[i]]$first.para)
G$smooth[[i]]$first.para <- G$smooth[[i]]$first.para - k
G$smooth[[i]]$last.para <- G$smooth[[i]]$last.para - k
}
for (i in 1:length(G$off)) {
G$off[i] <- G$off[i] - sum(rt$dind < G$off[i])
}
attr(G$nsdf, "drop.ind") <- rt$dind ## store drop index
}
}
attr(lpi, "overlap") <- lp.overlap
attr(G$X, "lpi") <- lpi
attr(G$nsdf, "pstart") <- pstart
G$g.index <- rep(FALSE, ncol(G$X))
n.sp0 <- 0
if (length(G$smooth)) {
for (i in 1:length(G$smooth)) {
if (!is.null(G$smooth[[i]]$g.index)) {
G$g.index[
G$smooth[[i]]$first.para:G$smooth[[i]]$last.para
] <- G$smooth[[i]]$g.index
}
n.sp <- length(G$smooth[[i]]$S)
if (n.sp) {
G$smooth[[i]]$first.sp <- n.sp0 + 1
n.sp0 <- G$smooth[[i]]$last.sp <- n.sp0 + n.sp
}
}
}
if (!any(G$g.index)) {
G$g.index <- NULL
}
G
}
#' Takes a set of non-negative integers and returns minimal code for generating it
#'
#' This function is derived from \code{mgcv:::compress.iseq}
#'
#' @author Simon N Wood with modifications by Nicholas Clark
#' @noRd
compress_iseq <- function(x) {
x1 <- sort(x)
br <- diff(x1) != 1 ## TRUE at sequence breaks
txt <- paste(x1[c(TRUE, br)], x1[c(br, TRUE)], sep = ":") ## subsequences
txt1 <- paste(x1[c(TRUE, br)]) ## subseq starts
ii <- x1[c(TRUE, br)] == x1[c(br, TRUE)] ## index start and end equal
txt[ii] <- txt1[ii] ## replace length on sequences with integers
paste("c(", paste(txt, collapse = ","), ")", sep = "")
}
#' Returns a vector dind of columns of X to drop for identifiability
#'
#' This function is derived from \code{mgcv:::olid}
#'
#' @author Simon N Wood with modifications by Nicholas Clark
#' @noRd
olid <- function(X, nsdf, pstart, flpi, lpi) {
nlp <- length(lpi) ## number of linear predictors
n <- nrow(X)
nf <- length(nsdf) ## number of formulae blocks
Xp <- matrix(0, n * nlp, sum(nsdf))
start <- 1
ii <- 1:n
tind <- rep(0, 0) ## complete index of all parametric columns in X
## create a block matrix, Xp, with the same identifiability properties as
## unpenalized part of model...
for (i in 1:nf) {
stop <- start - 1 + nsdf[i]
if (stop >= start) {
ind <- pstart[i] + 1:nsdf[i] - 1
for (k in flpi[[i]]) {
Xp[ii + (k - 1) * n, start:stop] <- X[, ind]
}
tind <- c(tind, ind)
start <- start + nsdf[i]
}
}
## rank deficiency of Xp will reveal number of redundant parametric
## terms, and a pivoted QR will reveal which to drop to restore
## full rank...
qrx <- qr(Xp, LAPACK = TRUE, tol = 0.0) ## unidentifiable columns get pivoted to final cols
r <- mgcv::Rrank(qr.R(qrx)) ## get rank from R factor of pivoted QR
if (r == ncol(Xp)) {
## full rank, all fine, drop nothing
dind <- rep(0, 0)
} else {
## reduced rank, drop some columns
dind <- tind[sort(qrx$pivot[(r + 1):ncol(X)], decreasing = TRUE)] ## columns to drop
## now we need to adjust nsdf, pstart and lpi
for (d in dind) {
## working down through drop indices
## following commented out code is useful should it ever prove necessary to
## adjust pstart and nsdf, but at present these are only used in prediction,
## and it is cleaner to leave them unchanged, and simply drop using dind during prediction.
#k <- if (d>=pstart[nf]) nlp else which(d >= pstart[1:(nf-1)] & d < pstart[2:nf])
#nsdf[k] <- nsdf[k] - 1 ## one less unpenalized column in this block
#if (k 0) {
lpi[[i]] <- lpi[[i]][-k]
} ## drop row
k <- which(lpi[[i]] > d)
if (length(k) > 0) lpi[[i]][k] <- lpi[[i]][k] - 1 ## close up
}
} ## end of drop index loop
}
list(dind = dind, lpi = lpi) ##,pstart=pstart,nsdf=nsdf)
}
#' Write linear predictor section of a jagam file
#'
#' This function is derived from \code{mgcv:::write.jagslp}
#'
#' @author Simon N Wood with modifications by Nicholas Clark
#' @noRd
write_jagslp <- function(resp, family, file, use.weights, offset = FALSE) {
## write the JAGS code for the linear predictor
## and response distribution.
iltab <- ## table of inverse link functions
c(
"eta[i]",
"exp(eta[i])",
"ilogit(eta[i])",
"phi(eta[i])",
"1/eta[i]",
"eta[i]^2"
)
names(iltab) <- c("identity", "log", "logit", "probit", "inverse", "sqrt")
if (!family$link %in% names(iltab)) {
stop("sorry link not yet handled")
}
## code linear predictor and expected response...
if (family$link == "identity") {
if (offset) {
cat(
" mu <- X %*% b + offset ## expected response\n",
file = file,
append = TRUE
)
} else {
cat(" mu <- X %*% b ## expected response\n", file = file, append = TRUE)
}
} else {
if (offset) {
cat(
" eta <- X %*% b + offset ## linear predictor\n",
file = file,
append = TRUE
)
} else {
cat(" eta <- X %*% b ## linear predictor\n", file = file, append = TRUE)
}
cat(
" for (i in 1:n) { mu[i] <- ",
iltab[family$link],
"} ## expected response\n",
file = file,
append = TRUE
)
}
## code the response given mu and any scale parameter prior...
#scale <- TRUE ## is scale parameter free?
cat(" for (i in 1:n) { ", file = file, append = TRUE)
if (family$family == "gaussian") {
if (use.weights) {
cat(
resp,
"[i] ~ dnorm(mu[i],tau*w[i]) } ## response \n",
sep = "",
file = file,
append = TRUE
)
} else {
cat(
resp,
"[i] ~ dnorm(mu[i],tau) } ## response \n",
sep = "",
file = file,
append = TRUE
)
}
cat(
" scale <- 1/tau ## convert tau to standard GLM scale\n",
file = file,
append = TRUE
)
cat(
" tau ~ dgamma(.05,.005) ## precision parameter prior \n",
file = file,
append = TRUE
)
} else if (family$family == "poisson") {
# scale <- FALSE
cat(
resp,
"[i] ~ dpois(mu[i]) } ## response \n",
sep = "",
file = file,
append = TRUE
)
if (use.weights) {
warning("weights ignored")
}
use.weights <- FALSE
} else if (family$family == "binomial") {
# scale <- FALSE
cat(
resp,
"[i] ~ dbin(mu[i],w[i]) } ## response \n",
sep = "",
file = file,
append = TRUE
)
use.weights <- TRUE
} else if (family$family == "Gamma") {
if (use.weights) {
cat(
resp,
"[i] ~ dgamma(r*w[i],r*w[i]/mu[i]) } ## response \n",
sep = "",
file = file,
append = TRUE
)
} else {
cat(
resp,
"[i] ~ dgamma(r,r/mu[i]) } ## response \n",
sep = "",
file = file,
append = TRUE
)
}
cat(
" r ~ dgamma(.05,.005) ## scale parameter prior \n",
file = file,
append = TRUE
)
cat(
" scale <- 1/r ## convert r to standard GLM scale\n",
file = file,
append = TRUE
)
} else {
stop("family not implemented yet")
}
use.weights
}
================================================
FILE: R/mvgam_trend_types.R
================================================
#' Specify autoregressive dynamic processes in \pkg{mvgam}
#'
#' Set up autoregressive or autoregressive moving average trend models in
#' \pkg{mvgam}. These functions do not evaluate their arguments – they exist
#' purely to help set up a model with particular autoregressive trend models.
#'
#' @param ma \code{Logical}. Include moving average terms of order \code{1}?
#' Default is \code{FALSE}.
#'
#' @param cor \code{Logical}. Include correlated process errors as part of a
#' multivariate normal process model? If \code{TRUE} and if
#' \code{n_series > 1} in the supplied data, a fully structured covariance
#' matrix will be estimated for the process errors. Default is \code{FALSE}.
#'
#' @param p A non-negative integer specifying the autoregressive (AR) order.
#' Default is \code{1}. Cannot currently be larger than \code{3} for `AR`
#' terms, and cannot be anything other than `1` for continuous time AR
#' (`CAR`) terms.
#'
#' @param gr An optional grouping variable, which must be a `factor` in the
#' supplied `data`, for setting up hierarchical residual correlation
#' structures. If specified, this will automatically set `cor = TRUE` and set
#' up a model where the residual correlations for a specific level of `gr`
#' are modelled hierarchically:
#'
#' \eqn{\Omega_{group} = \alpha_{cor}\Omega_{global} +
#' (1 - \alpha_{cor})\Omega_{group, local}},
#'
#' where \eqn{\Omega_{global}} is a *global* correlation matrix,
#' \eqn{\Omega_{group, local}} is a *local deviation* correlation matrix and
#' \eqn{\alpha_{cor}} is a weighting parameter controlling how strongly the
#' local correlation matrix \eqn{\Omega_{group}} is shrunk towards the global
#' correlation matrix \eqn{\Omega_{global}} (larger values of
#' \eqn{\alpha_{cor}} indicate a greater degree of shrinkage, i.e. a greater
#' degree of partial pooling).
#'
#' When used within a `VAR()` model, this essentially sets up a hierarchical
#' panel vector autoregression where both the autoregressive and correlation
#' matrices are learned hierarchically. If `gr` is supplied then `subgr`
#' *must* also be supplied.
#'
#' @param subgr A subgrouping `factor` variable specifying which element in
#' `data` represents the different time series. Defaults to `series`, but
#' note that models that use the hierarchical correlations, where the
#' `subgr` time series are measured in each level of `gr`, *should not*
#' include a `series` element in `data`. Rather, this element will be created
#' internally based on the supplied variables for `gr` and `subgr`.
#'
#' For example, if you are modelling temporal counts for a group of species
#' (labelled as `species` in `data`) across three different geographical
#' regions (labelled as `region`), and you would like the residuals to be
#' correlated within regions, then you should specify `gr = region` and
#' `subgr = species`. Internally, `mvgam()` will create the `series` element
#' for the data using:
#'
#' `series = interaction(group, subgroup, drop = TRUE)`
#'
#' @return An object of class \code{mvgam_trend}, which contains a list of
#' arguments to be interpreted by the parsing functions in \pkg{mvgam}.
#'
#' @rdname RW
#'
#' @details Use `vignette("mvgam_overview")` to see the full details of
#' available stochastic trend types in \pkg{mvgam}, or view the rendered
#' version on the package website at:
#' https://nicholasjclark.github.io/mvgam/articles/mvgam_overview.html
#'
#' @author Nicholas J Clark
#'
#' @examples
#' \dontrun{
#' # A short example to illustrate CAR(1) models
#' # Function to simulate CAR1 data with seasonality
#' sim_corcar1 = function(n = 125,
#' phi = 0.5,
#' sigma = 2,
#' sigma_obs = 0.75) {
#' # Sample irregularly spaced time intervals
#' time_dis <- c(1, runif(n - 1, 0, 5))
#'
#' # Set up the latent dynamic process
#' x <- vector(length = n); x[1] <- -0.3
#' for (i in 2:n) {
#' # zero-distances will cause problems in sampling, so mvgam uses a
#' # minimum threshold; this simulation function emulates that process
#' if (time_dis[i] == 0) {
#' x[i] <- rnorm(
#' 1,
#' mean = (phi^1e-3) * x[i - 1],
#' sd = sigma * (1 - phi^(2 * 1e-3)) / (1 - phi^2)
#' )
#' } else {
#' x[i] <- rnorm(
#' 1,
#' mean = (phi^time_dis[i]) * x[i - 1],
#' sd = sigma * (1 - phi^(2 * time_dis[i])) / (1 - phi^2)
#' )
#' }
#' }
#'
#' # Add 12-month seasonality
#' cov1 <- sin(2 * pi * (1:n) / 12)
#' cov2 <- cos(2 * pi * (1:n) / 12)
#' beta1 <- runif(1, 0.3, 0.7)
#' beta2 <- runif(1, 0.2, 0.5)
#' seasonality <- beta1 * cov1 + beta2 * cov2
#'
#' # Take Gaussian observations with error and return
#' data.frame(
#' y = rnorm(n, mean = x + seasonality, sd = sigma_obs),
#' season = rep(1:12, 20)[1:n],
#' time = cumsum(time_dis)
#' )
#' }
#'
#' # Sample two time series
#' dat <- rbind(
#' dplyr::bind_cols(
#' sim_corcar1(phi = 0.65, sigma_obs = 0.55),
#' data.frame(series = 'series1')
#' ),
#' dplyr::bind_cols(
#' sim_corcar1(phi = 0.8, sigma_obs = 0.35),
#' data.frame(series = 'series2')
#' )
#' ) %>%
#' dplyr::mutate(series = as.factor(series))
#'
#' # mvgam with CAR(1) trends and series-level seasonal smooths
#' mod <- mvgam(
#' formula = y ~ -1,
#' trend_formula = ~ s(season, bs = 'cc', k = 5, by = trend),
#' trend_model = CAR(),
#' priors = c(
#' prior(exponential(3), class = sigma),
#' prior(beta(4, 4), class = sigma_obs)
#' ),
#' data = dat,
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#'
#' # View usual summaries and plots
#' summary(mod)
#' conditional_effects(mod, type = 'expected')
#' plot(mod, type = 'trend', series = 1)
#' plot(mod, type = 'trend', series = 2)
#' plot(mod, type = 'residuals', series = 1)
#' plot(mod, type = 'residuals', series = 2)
#' mcmc_plot(
#' mod,
#' variable = 'ar1',
#' regex = TRUE,
#' type = 'hist'
#' )
#'
#' # Now an example illustrating hierarchical dynamics
#' set.seed(123)
#'
#' # Simulate three species monitored in three different regions
#' simdat1 <- sim_mvgam(
#' trend_model = VAR(cor = TRUE),
#' prop_trend = 0.95,
#' n_series = 3,
#' mu = c(1, 2, 3)
#' )
#' simdat2 <- sim_mvgam(
#' trend_model = VAR(cor = TRUE),
#' prop_trend = 0.95,
#' n_series = 3,
#' mu = c(1, 2, 3)
#' )
#' simdat3 <- sim_mvgam(
#' trend_model = VAR(cor = TRUE),
#' prop_trend = 0.95,
#' n_series = 3,
#' mu = c(1, 2, 3)
#' )
#'
#' # Set up the data but DO NOT include 'series'
#' all_dat <- rbind(
#' simdat1$data_train %>%
#' dplyr::mutate(region = 'qld'),
#' simdat2$data_train %>%
#' dplyr::mutate(region = 'nsw'),
#' simdat3$data_train %>%
#' dplyr::mutate(region = 'vic')
#' ) %>%
#' dplyr::mutate(
#' species = gsub('series', 'species', series),
#' species = as.factor(species),
#' region = as.factor(region)
#' ) %>%
#' dplyr::arrange(series, time) %>%
#' dplyr::select(-series)
#'
#' # Check priors for a hierarchical AR1 model
#' get_mvgam_priors(
#' formula = y ~ species,
#' trend_model = AR(gr = region, subgr = species),
#' data = all_dat
#' )
#'
#' # Fit the model
#' mod <- mvgam(
#' formula = y ~ species,
#' trend_model = AR(gr = region, subgr = species),
#' data = all_dat,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Check standard outputs
#' summary(mod)
#'
#' # Inspect posterior estimates for the correlation weighting parameter
#' mcmc_plot(mod, variable = 'alpha_cor', type = 'hist')
#' }
#' @export
RW = function(ma = FALSE, cor = FALSE, gr = NA, subgr = NA) {
# Validate the supplied groupings and correlation argument
gr <- deparse0(substitute(gr))
subgr <- deparse0(substitute(subgr))
if (gr == 'NA') {
subgr <- 'series'
}
if (gr != 'NA') {
if (subgr == 'NA') {
stop(
'argument "subgr" must be supplied if "gr" is also supplied',
call. = FALSE
)
} else if (subgr == 'series') {
stop(
'argument "subgr" cannot be set to "series" if "gr" is also supplied',
call. = FALSE
)
} else {
cor <- TRUE
}
}
out <- structure(
list(
trend_model = 'RW',
ma = ma,
cor = cor,
unit = 'time',
gr = gr,
subgr = subgr,
label = match.call()
),
class = 'mvgam_trend',
param_info = list(
param_names = c(
'trend',
'tau',
'sigma',
'theta',
'Sigma',
'error',
'drift'
),
labels = c(
'trend_estimates',
'precision_parameter',
'standard_deviation',
'moving_average_coef',
'covariance_matrix',
'process_errors',
'drift_parameter'
)
)
)
}
#' @rdname RW
#' @export
AR = function(p = 1, ma = FALSE, cor = FALSE, gr = NA, subgr = NA) {
validate_pos_integer(p)
if (p > 3) {
stop("Argument 'p' must be <= 3", call. = FALSE)
}
# Validate the supplied groupings and correlation argument
gr <- deparse0(substitute(gr))
subgr <- deparse0(substitute(subgr))
if (gr == 'NA') {
subgr <- 'series'
}
if (gr != 'NA') {
if (subgr == 'NA') {
stop(
'argument "subgr" must be supplied if "gr" is also supplied',
call. = FALSE
)
} else if (subgr == 'series') {
stop(
'argument "subgr" cannot be set to "series" if "gr" is also supplied',
call. = FALSE
)
} else {
cor <- TRUE
}
}
# Determine parameter names based on AR order
ar_params <- paste0('ar', 1:p)
param_names <- c(
'trend',
'tau',
'sigma',
ar_params,
'theta',
'Sigma',
'error',
'drift'
)
param_labels <- c(
'trend_estimates',
'precision_parameter',
'standard_deviation',
paste0('autoregressive_coef_', 1:p),
'moving_average_coef',
'covariance_matrix',
'process_errors',
'drift_parameter'
)
out <- structure(
list(
trend_model = paste0('AR', p),
ma = ma,
cor = cor,
unit = 'time',
gr = gr,
subgr = subgr,
label = match.call()
),
class = 'mvgam_trend',
param_info = list(
param_names = param_names,
labels = param_labels
)
)
}
#' @rdname RW
#' @export
CAR = function(p = 1) {
validate_pos_integer(p)
if (p > 1) {
stop("Argument 'p' must be = 1", call. = FALSE)
}
out <- structure(
list(
trend_model = paste0('CAR', p),
ma = FALSE,
cor = FALSE,
unit = 'time',
gr = 'NA',
subgr = 'series',
label = match.call()
),
class = 'mvgam_trend',
param_info = list(
param_names = c('trend', 'tau', 'sigma', 'ar1', 'Sigma'),
labels = c(
'trend_estimates',
'precision_parameter',
'standard_deviation',
'autoregressive_coef',
'covariance_matrix'
)
)
)
}
#' @rdname RW
#' @export
VAR = function(ma = FALSE, cor = FALSE, gr = NA, subgr = NA) {
# Validate the supplied groupings and correlation argument
gr <- deparse0(substitute(gr))
subgr <- deparse0(substitute(subgr))
if (gr == 'NA') {
subgr <- 'series'
}
if (gr != 'NA') {
if (subgr == 'NA') {
stop(
'argument "subgr" must be supplied if "gr" is also supplied',
call. = FALSE
)
} else if (subgr == 'series') {
stop(
'argument "subgr" cannot be set to "series" if "gr" is also supplied',
call. = FALSE
)
} else {
cor <- TRUE
}
}
out <- structure(
list(
trend_model = 'VAR',
ma = ma,
cor = cor,
unit = 'time',
gr = gr,
subgr = subgr,
label = match.call()
),
class = 'mvgam_trend',
param_info = list(
param_names = c(
'trend',
'A',
'Sigma',
'P_real',
'sigma',
'theta',
'error',
'drift'
),
labels = c(
'trend_estimates',
'var_coefficient_matrix',
'covariance_matrix',
'stationary_precision',
'standard_deviation',
'moving_average_matrix',
'process_errors',
'drift_parameter'
)
)
)
}
#' Specify dynamic Gaussian process trends in \pkg{mvgam} models
#'
#' Set up low-rank approximate Gaussian Process trend models using Hilbert
#' basis expansions in \pkg{mvgam}. This function does not evaluate its
#' arguments – it exists purely to help set up a model with particular GP
#' trend models.
#'
#' @param ... unused
#'
#' @return An object of class \code{mvgam_trend}, which contains a list of
#' arguments to be interpreted by the parsing functions in \pkg{mvgam}.
#'
#' @details A GP trend is estimated for each series using Hilbert space
#' approximate Gaussian Processes. In `mvgam`, latent squared exponential GP
#' trends are approximated using by default \code{20} basis functions and
#' using a multiplicative factor of `c = 5/4`, which saves computational
#' costs compared to fitting full GPs while adequately estimating GP
#' \code{alpha} and \code{rho} parameters.
#'
#' @rdname GP
#'
#' @author Nicholas J Clark
#'
#' @references Riutort-Mayol G, Burkner PC, Andersen MR, Solin A and Vehtari A
#' (2023). Practical Hilbert space approximate Bayesian Gaussian processes for
#' probabilistic programming. Statistics and Computing 33, 1.
#' https://doi.org/10.1007/s11222-022-10167-2
#'
#' @seealso \code{\link[brms]{gp}}
#'
#' @export
GP = function(...) {
out <- structure(
list(
trend_model = 'GP',
ma = FALSE,
cor = FALSE,
unit = 'time',
gr = 'NA',
subgr = 'series',
label = match.call()
),
class = 'mvgam_trend',
param_info = list(
param_names = c('trend', 'alpha_gp', 'rho_gp', 'b_gp'),
labels = c(
'trend_estimates',
'marginal_deviation',
'length_scale',
'basis_coefficients'
)
)
)
}
#' Specify piecewise linear or logistic trends in \pkg{mvgam} models
#'
#' Set up piecewise linear or logistic trend models in \code{mvgam}. These
#' functions do not evaluate their arguments – they exist purely to help set up
#' a model with particular piecewise trend models.
#'
#' @param n_changepoints A non-negative integer specifying the number of
#' potential changepoints. Potential changepoints are selected uniformly from
#' the first `changepoint_range` proportion of timepoints in \code{data}.
#' Default is `10`.
#'
#' @param changepoint_range Proportion of history in \code{data} in which trend
#' changepoints will be estimated. Defaults to `0.8` for the first 80%.
#'
#' @param changepoint_scale Parameter modulating the flexibility of the
#' automatic changepoint selection by altering the scale parameter of a
#' Laplace distribution. The resulting prior will be
#' `double_exponential(0, changepoint_scale)`. Large values will allow many
#' changepoints and a more flexible trend, while small values will allow few
#' changepoints. Default is `0.05`.
#'
#' @param growth Character string specifying either `'linear'` or `'logistic'`
#' growth of the trend. If `'logistic'`, a variable labelled `cap` MUST be in
#' \code{data} to specify the maximum saturation point for the trend (see
#' details and examples in \code{\link{mvgam}} for more information). Default
#' is `'linear'`.
#'
#' @author Nicholas J Clark
#'
#' @references Taylor, Sean J., and Benjamin Letham. "Forecasting at scale."
#' The American Statistician 72.1 (2018): 37–45.
#'
#' @return An object of class \code{mvgam_trend}, which contains a list of
#' arguments to be interpreted by the parsing functions in \code{mvgam}.
#'
#' @details
#' *Offsets and intercepts*:
#' For each of these trend models, an offset parameter is included in the trend
#' estimation process. This parameter will be incredibly difficult to identify
#' if you also include an intercept in the observation formula. For that
#' reason, it is highly recommended that you drop the intercept from the
#' formula (i.e. `y ~ x + 0` or `y ~ x - 1`, where `x` are your optional
#' predictor terms).
#'
#' *Logistic growth and the cap variable*:
#' When forecasting growth, there is often some maximum achievable point that a
#' time series can reach. For example, total market size, total population size
#' or carrying capacity in population dynamics. It can be advantageous for the
#' forecast to saturate at or near this point so that predictions are more
#' sensible.
#'
#' This function allows you to make forecasts using a logistic growth trend
#' model, with a specified carrying capacity. Note that this capacity does not
#' need to be static over time; it can vary with each series × timepoint
#' combination if necessary. But you must supply a `cap` value for each
#' observation in the data when using `growth = 'logistic'`.
#'
#' For observation families that use a non-identity link function, the `cap`
#' value will be internally transformed to the link scale (i.e. your specified
#' `cap` will be log-transformed if you are using a `poisson()` or `nb()`
#' family). It is therefore important that you specify the `cap` values on the
#' scale of your outcome. Note also that no missing values are allowed in
#' `cap`.
#'
#' @rdname piecewise_trends
#'
#' @examples
#' \dontrun{
#' # Example of logistic growth with possible changepoints
#' dNt = function(r, N, k) {
#' r * N * (k - N)
#' }
#'
#' Nt = function(r, N, t, k) {
#' for (i in 1:(t - 1)) {
#' if (i %in% c(5, 15, 25, 41, 45, 60, 80)) {
#' N[i + 1] <- max(
#' 1,
#' N[i] + dNt(r + runif(1, -0.1, 0.1), N[i], k)
#' )
#' } else {
#' N[i + 1] <- max(1, N[i] + dNt(r, N[i], k))
#' }
#' }
#' N
#' }
#'
#' set.seed(11)
#' expected <- Nt(0.004, 2, 100, 30)
#' plot(expected, xlab = 'Time')
#'
#' y <- rpois(100, expected)
#' plot(y, xlab = 'Time')
#'
#' mod_data <- data.frame(
#' y = y,
#' time = 1:100,
#' cap = 35,
#' series = as.factor('series_1')
#' )
#' plot_mvgam_series(data = mod_data)
#'
#' mod <- mvgam(
#' y ~ 0,
#' trend_model = PW(growth = 'logistic'),
#' family = poisson(),
#' data = mod_data,
#' chains = 2,
#' silent = 2
#' )
#' summary(mod)
#'
#' hc <- hindcast(mod)
#' plot(hc)
#'
#' library(ggplot2)
#' mcmc_plot(mod, variable = 'delta_trend', regex = TRUE) +
#' scale_y_discrete(labels = mod$trend_model$changepoints) +
#' labs(
#' y = 'Potential changepoint',
#' x = 'Rate change'
#' )
#'
#' how_to_cite(mod)
#' }
#'
#' @export
PW = function(
n_changepoints = 10,
changepoint_range = 0.8,
changepoint_scale = 0.05,
growth = 'linear'
) {
growth <- match.arg(growth, choices = c('linear', 'logistic'))
validate_proportional(changepoint_range)
validate_pos_integer(n_changepoints)
validate_pos_real(changepoint_scale)
trend_model <- 'PWlinear'
if (growth == 'logistic') {
trend_model = 'PWlogistic'
}
out <- structure(
list(
trend_model = trend_model,
n_changepoints = n_changepoints,
changepoint_range = changepoint_range,
changepoint_scale = changepoint_scale,
ma = FALSE,
cor = FALSE,
unit = 'time',
gr = 'NA',
subgr = 'series',
label = match.call()
),
class = 'mvgam_trend',
param_info = list(
param_names = c('trend', 'delta_trend', 'k_trend', 'm_trend'),
labels = c(
'trend_estimates',
'rate_changes',
'growth_rate',
'offset_parameter'
)
)
)
}
#' Specify correlated residual processes in \pkg{mvgam}
#'
#' Set up latent correlated multivariate Gaussian residual processes in
#' \pkg{mvgam}. This function does not evaluate its arguments – it exists
#' purely to help set up a model with particular error processes
#'
#' @param unit The unquoted name of the variable that represents the unit of
#' analysis in `data` over which latent residuals should be correlated. This
#' variable should be either a `numeric` or `integer` variable in the
#' supplied `data`. Defaults to `time` to be consistent with other
#' functionalities in \pkg{mvgam}, though note that the data need not be time
#' series in this case. See examples below for further details and
#' explanations
#'
#' @param gr An optional grouping variable, which must be a `factor` in the
#' supplied `data`, for setting up hierarchical residual correlation
#' structures. If specified, this will automatically set up a model where the
#' residual correlations for a specific level of `gr` are modelled
#' hierarchically:
#'
#' \eqn{\Omega_{group} = p\Omega_{global} + (1 - p)\Omega_{group, local}},
#'
#' where \eqn{\Omega_{global}} is a *global* correlation matrix,
#' \eqn{\Omega_{group, local}} is a *local deviation* correlation matrix, and
#' \eqn{p} is a weighting parameter controlling how strongly the local
#' correlation matrix \eqn{\Omega_{group}} is shrunk towards the global
#' correlation matrix \eqn{\Omega_{global}}. If `gr` is supplied then `subgr`
#' *must* also be supplied
#'
#' @param subgr A subgrouping `factor` variable specifying which element in
#' `data` represents the different observational units. Defaults to `series`
#' to be consistent with other functionalities in \pkg{mvgam}, though note
#' that the data need not be time series in this case
#'
#' Models that use the hierarchical correlations (by supplying a value for
#' `gr`) *should not* include a `series` element in `data`. Rather, this
#' element will be created internally based on the supplied variables for `gr`
#' and `subgr`
#'
#' For example, if you are modelling counts for a group of species (labelled
#' as `species` in the data) across sampling sites (labelled as `site` in the
#' data) in three different geographical regions (labelled as `region`), and
#' you would like the residuals to be correlated within regions, then you
#' should specify `unit = site`, `gr = region`, and `subgr = species`
#'
#' Internally, `mvgam()` will appropriately order the data by `unit` (in this
#' case, by `site`) and create the `series` element for the data using
#' something like:
#'
#' `series = as.factor(paste0(group, '_', subgroup))`
#'
#' @return An object of class \code{mvgam_trend}, which contains a list of
#' arguments to be interpreted by the parsing functions in \pkg{mvgam}
#'
#' @examples
#' \dontrun{
#' # Simulate counts of four species over ten sampling locations
#' site_dat <- data.frame(
#' site = rep(1:10, 4),
#' species = as.factor(sort(rep(letters[1:4], 10))),
#' y = c(NA, rpois(39, 3))
#' )
#' head(site_dat)
#'
#' # Set up a correlated residual (i.e. Joint Species Distribution) model
#' trend_model <- ZMVN(unit = site, subgr = species)
#' mod <- mvgam(
#' y ~ species,
#' trend_model = ZMVN(unit = site, subgr = species),
#' data = site_dat,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Inspect the estimated species-species residual covariances
#' mcmc_plot(mod, variable = 'Sigma', regex = TRUE, type = 'hist')
#'
#' # A hierarchical correlation example
#' Sigma <- matrix(
#' c(1, -0.4, 0.5,
#' -0.4, 1, 0.3,
#' 0.5, 0.3, 1),
#' byrow = TRUE,
#' nrow = 3
#' )
#'
#' make_site_dat <- function(...) {
#' errors <- mgcv::rmvn(
#' n = 30,
#' mu = c(0.6, 0.8, 1.8),
#' V = Sigma
#' )
#' site_dat <- do.call(rbind, lapply(1:3, function(spec) {
#' data.frame(
#' y = rpois(30, lambda = exp(errors[, spec])),
#' species = paste0('species', spec),
#' site = 1:30
#' )
#' }))
#' site_dat
#' }
#'
#' site_dat <- rbind(
#' make_site_dat() %>%
#' dplyr::mutate(group = 'group1'),
#' make_site_dat() %>%
#' dplyr::mutate(group = 'group2')
#' ) %>%
#' dplyr::mutate(
#' species = as.factor(species),
#' group = as.factor(group)
#' )
#'
#' # Fit the hierarchical correlated residual model
#' mod <- mvgam(
#' y ~ species,
#' trend_model = ZMVN(unit = site, gr = group, subgr = species),
#' data = site_dat,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Inspect the estimated species-species residual covariances
#' mcmc_plot(mod, variable = 'Sigma', regex = TRUE, type = 'hist')
#' }
#'
#' @export
ZMVN = function(unit = time, gr = NA, subgr = series) {
# Validate the supplied groupings and correlation argument
unit <- deparse0(substitute(unit))
gr <- deparse0(substitute(gr))
subgr <- deparse0(substitute(subgr))
if (subgr == 'NA') {
stop('argument "subgr" cannot be NA', call. = FALSE)
}
if (unit == 'NA') {
stop('argument "unit" cannot be NA', call. = FALSE)
}
out <- structure(
list(
trend_model = 'ZMVN',
ma = FALSE,
cor = TRUE,
unit = unit,
gr = gr,
subgr = subgr,
label = match.call()
),
class = 'mvgam_trend',
param_info = list(
param_names = c('trend', 'tau', 'sigma', 'theta', 'Sigma', 'error'),
labels = c(
'trend_estimates',
'precision_parameter',
'standard_deviation',
'correlation_parameter',
'covariance_matrix',
'process_errors'
)
)
)
}
================================================
FILE: R/noncent_trend.R
================================================
#' Internal functiosn to change dynamic AR or RW trends
#' to a non-centred parameterisation for potentially big speed gains
#' @noRd
noncent_trend = function(model_file, trend_model, drift) {
# Replace trend with trend_raw in params
model_file[grep("matrix[n, n_series] trend;", model_file, fixed = TRUE)] <-
"matrix[n, n_series] trend_raw;"
model_file[grep("// latent trends", model_file, fixed = TRUE)] <-
"// raw latent trends"
# Add trend to transformed params
if (drift) {
drift_text <- ' drift[s] +'
} else {
drift_text <- NULL
}
if (trend_model == 'RW') {
model_file[grep("vector[num_basis] b;", model_file, fixed = TRUE)] <-
paste0(
"vector[num_basis] b;\n\n",
"// latent trends\n",
"matrix[n, n_series] trend;\n",
"trend = trend_raw .* rep_matrix(sigma', rows(trend_raw));\n",
"for (s in 1 : n_series) {\n",
"trend[2 : n, s] +=",
drift_text,
" trend[1 : (n - 1), s];\n",
"}\n"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR1') {
model_file[grep("vector[num_basis] b;", model_file, fixed = TRUE)] <-
paste0(
"vector[num_basis] b;\n\n",
"// latent trends\n",
"matrix[n, n_series] trend;\n",
"trend = trend_raw .* rep_matrix(sigma', rows(trend_raw));\n",
"for (s in 1 : n_series) {\n",
"trend[2 : n, s] +=",
drift_text,
" ar1[s] * trend[1 : (n - 1), s];\n",
"}\n"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'CAR1') {
model_file[grep("vector[num_basis] b;", model_file, fixed = TRUE)] <-
paste0(
"vector[num_basis] b;\n\n",
"// latent trends\n",
"matrix[n, n_series] trend;\n",
"trend = trend_raw .* rep_matrix(sigma', n) .*",
"(1 - rep_matrix(ar1', n) .^ (2 * to_matrix(time_dis))) ./",
"(1 - rep_matrix(ar1', n) .^ 2);\n",
"for (s in 1 : n_series) {\n",
"trend[2 : n, s] +=",
drift_text,
" pow(ar1[s], to_vector(time_dis[2 : n, s])) .* trend[1 : (n - 1), s];\n",
"}\n"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR2') {
model_file[grep("vector[num_basis] b;", model_file, fixed = TRUE)] <-
paste0(
"vector[num_basis] b;\n\n",
"// latent trends\n",
"matrix[n, n_series] trend;\n",
"trend = trend_raw .* rep_matrix(sigma', rows(trend_raw));\n",
"for (s in 1 : n_series) {\n",
"trend[2, s] +=",
drift_text,
" ar1[s] * trend[1, s];\n",
"trend[3 : n, s] +=",
drift_text,
" ar1[s] * trend[2 : (n - 1), s] + ar2[s] * trend[1:(n - 2), s];\n",
"}\n"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR3') {
model_file[grep("vector[num_basis] b;", model_file, fixed = TRUE)] <-
paste0(
"vector[num_basis] b;\n\n",
"// latent trends\n",
"matrix[n, n_series] trend;\n",
"trend = trend_raw .* rep_matrix(sigma', rows(trend_raw));\n",
"for (s in 1 : n_series) {\n",
"trend[2, s] +=",
drift_text,
" ar1[s] * trend[1, s];\n",
"trend[3, s] +=",
drift_text,
" ar1[s] * trend[2, s] + ar2[s] * trend[1, s] ;\n",
"trend[4 : n, s] +=",
drift_text,
" ar1[s] * trend[3 : (n - 1), s] + ar2[s] * trend[2:(n - 2), s] + ar3[s] * trend[1:(n - 3), s];\n",
"}\n"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
# Remove trend statements from model block and replace with the
# z scores
trend_start <- grep("// trend estimates", model_file, fixed = TRUE)
end_braces <- grep("}", model_file, fixed = TRUE)
p <- function(f, b) function(a) f(a, b)
trend_end <- end_braces[Position(p(`==`, 1), sign(end_braces - trend_start))]
model_file <- model_file[-(trend_start:trend_end)]
model_file[
grep(
"// priors for latent trend variance parameters",
model_file,
fixed = TRUE
) +
1
] <-
paste0(
model_file[
grep(
"// priors for latent trend variance parameters",
model_file,
fixed = TRUE
) +
1
],
'\n',
"to_vector(trend_raw) ~ std_normal();"
)
model_file <- readLines(textConnection(model_file), n = -1)
model_file
}
#' @noRd
noncent_lv = function(model_file, trend_model, drift) {
# Replace LV with LV_raw in params
model_file[grep("matrix[n, n_lv] LV;", model_file, fixed = TRUE)] <-
"matrix[n, n_lv] LV_raw;"
model_file[grep("// latent states", model_file, fixed = TRUE)] <-
"// raw latent states"
# Add LV to transformed params
model_file[grep("vector[num_basis] b;", model_file, fixed = TRUE)] <-
paste0(
"vector[num_basis] b;\n\n",
"// latent states\n",
"matrix[n, n_lv] LV;\n"
)
model_file <- readLines(textConnection(model_file), n = -1)
# Add LV calculations in transformed params
if (trend_model == 'None') {
model_file[grep(
"trend_mus = X_trend * b_trend;",
model_file,
fixed = TRUE
)] <-
paste0(
"trend_mus = X_trend * b_trend;\n\n",
"LV = LV_raw .* rep_matrix(sigma', rows(LV_raw));\n",
"for(j in 1:n_lv){\n",
"for(i in 1:n){\n",
"LV[i, j] += trend_mus[ytimes_trend[i, j]];\n",
"}\n",
"}"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'RW') {
model_file[grep(
"trend_mus = X_trend * b_trend;",
model_file,
fixed = TRUE
)] <-
paste0(
"trend_mus = X_trend * b_trend;\n\n",
"LV = LV_raw .* rep_matrix(sigma', rows(LV_raw));\n",
"for(j in 1:n_lv){\n",
"LV[1, j] += trend_mus[ytimes_trend[1, j]];\n",
"for(i in 2:n){\n",
"LV[i, j] += trend_mus[ytimes_trend[i, j]] + 1 * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]);\n",
"}\n",
"}"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR1') {
model_file[grep(
"trend_mus = X_trend * b_trend;",
model_file,
fixed = TRUE
)] <-
paste0(
"trend_mus = X_trend * b_trend;\n\n",
"LV = LV_raw .* rep_matrix(sigma', rows(LV_raw));\n",
"for(j in 1:n_lv){\n",
"LV[1, j] += trend_mus[ytimes_trend[1, j]];\n",
"for(i in 2:n){\n",
"LV[i, j] += trend_mus[ytimes_trend[i, j]] + ar1[j] * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]);\n",
"}\n",
"}"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'CAR1') {
model_file[grep(
"trend_mus = X_trend * b_trend;",
model_file,
fixed = TRUE
)] <-
paste0(
"trend_mus = X_trend * b_trend;\n\n",
"LV = LV_raw .* rep_matrix(sigma', rows(LV_raw));\n",
"for(j in 1:n_lv){\n",
"LV[1, j] += trend_mus[ytimes_trend[1, j]];\n",
"for(i in 2:n){\n",
"LV[i, j] += trend_mus[ytimes_trend[i, j]] + pow(ar1[j], time_dis[i, j]) * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]);\n",
"}\n",
"}"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR2') {
model_file[grep(
"trend_mus = X_trend * b_trend;",
model_file,
fixed = TRUE
)] <-
paste0(
"trend_mus = X_trend * b_trend;\n\n",
"LV = LV_raw .* rep_matrix(sigma', rows(LV_raw));\n",
"for(j in 1:n_lv){\n",
"LV[1, j] += trend_mus[ytimes_trend[1, j]];\n",
"LV[2, j] += trend_mus[ytimes_trend[2, j]] + ar1[j] * (LV[1, j] - trend_mus[ytimes_trend[1, j]]);\n",
"for(i in 3:n){\n",
"LV[i, j] += trend_mus[ytimes_trend[i, j]] + ar1[j] * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]) + ar2[j] * (LV[i - 2, j] - trend_mus[ytimes_trend[i - 2, j]]);\n",
"}\n",
"}"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
if (trend_model == 'AR3') {
model_file[grep(
"trend_mus = X_trend * b_trend;",
model_file,
fixed = TRUE
)] <-
paste0(
"trend_mus = X_trend * b_trend;\n\n",
"LV = LV_raw .* rep_matrix(sigma', rows(LV_raw));\n",
"for(j in 1:n_lv){\n",
"LV[1, j] += trend_mus[ytimes_trend[1, j]];\n",
"LV[2, j] += trend_mus[ytimes_trend[2, j]] + ar1[j] * (LV[1, j] - trend_mus[ytimes_trend[1, j]]);\n",
"LV[3, j] += trend_mus[ytimes_trend[2, j]] + ar1[j] * (LV[2, j] - trend_mus[ytimes_trend[2, j]]) + ar2[j] * (LV[1, j] - trend_mus[ytimes_trend[1, j]]);\n",
"for(i in 4:n){\n",
"LV[i, j] += trend_mus[ytimes_trend[i, j]] + ar1[j] * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]) + ar2[j] * (LV[i - 2, j] - trend_mus[ytimes_trend[i - 2, j]]) + ar3[j] * (LV[i - 3, j] - trend_mus[ytimes_trend[i - 3, j]]);\n",
"}\n",
"}"
)
model_file <- readLines(textConnection(model_file), n = -1)
}
# Remove LV statements from model block and replace with the
# z scores
if (trend_model == 'None') {
trend_start <- grep(
"LV[i, j] ~ normal(trend_mus[ytimes_trend[i, j]], sigma[j]);",
model_file,
fixed = TRUE
) -
2
trend_end <- grep(
"LV[i, j] ~ normal(trend_mus[ytimes_trend[i, j]], sigma[j]);",
model_file,
fixed = TRUE
) +
2
} else {
if (
any(grepl(
"LV[1, j] ~ normal(trend_mus[ytimes_trend[1, j]], sigma[j]);",
model_file,
fixed = TRUE
))
) {
trend_start <- grep(
"LV[1, j] ~ normal(trend_mus[ytimes_trend[1, j]], sigma[j]);",
model_file,
fixed = TRUE
) -
1
} else {
trend_start <- grep(
"LV[1, 1:n_lv] ~ normal(0, sigma);",
model_file,
fixed = TRUE
) -
1
}
end_braces <- grep("}", model_file, fixed = TRUE)
p <- function(f, b) function(a) f(a, b)
trend_end <- end_braces[Position(
p(`==`, 1),
sign(end_braces - trend_start)
)] +
1
}
model_file <- model_file[-(trend_start:trend_end)]
if (
any(grepl(
"// priors for latent state SD parameters",
model_file,
fixed = TRUE
))
) {
model_file[
grep(
"// priors for latent state SD parameters",
model_file,
fixed = TRUE
) +
1
] <-
paste0(
model_file[
grep(
"// priors for latent state SD parameters",
model_file,
fixed = TRUE
) +
1
],
'\n',
"to_vector(LV_raw) ~ std_normal();"
)
} else {
model_file[
grep("// priors for factor SD parameters", model_file, fixed = TRUE) + 1
] <-
paste0(
model_file[
grep("// priors for factor SD parameters", model_file, fixed = TRUE) +
1
],
'\n',
"to_vector(LV_raw) ~ std_normal();"
)
}
model_file <- readLines(textConnection(model_file), n = -1)
model_file
}
#' @noRd
check_noncent = function(
model_file,
noncentred,
use_lv,
trend_map,
add_ma,
add_cor,
trend_model,
drift,
silent,
nmix
) {
if (!missing(trend_map)) {
trendmap <- TRUE
} else {
trendmap <- FALSE
}
# Haven't yet implemented noncentering for trend_map models that don't
# use the trend_formula
if (
trendmap &
!any(grepl('trend_mus', model_file, fixed = TRUE)) &
use_lv
) {
trendmap <- FALSE
noncentred <- FALSE
}
if (!noncentred & use_lv & trendmap & trend_model == 'None' & !nmix) {
if (silent <= 1L) {
message('Your model may benefit from using "noncentred = TRUE"')
}
}
if (
!noncentred &
!add_ma &
!add_cor &
!nmix &
trend_model %in% c('RW', 'AR1', 'AR2', 'AR3', 'CAR1')
) {
if (use_lv & trendmap) {
if (silent <= 1L) {
message('Your model may benefit from using "noncentred = TRUE"')
}
}
if (!use_lv) {
if (silent <= 1L) {
message('Your model may benefit from using "noncentred = TRUE"')
}
}
}
if (
noncentred &
!add_ma &
!add_cor &
trend_model %in% c('RW', 'AR1', 'AR2', 'AR3', 'CAR1', 'None')
) {
if (use_lv & trendmap) {
model_file <- noncent_lv(
model_file = model_file,
trend_model = trend_model,
drift = FALSE
)
} else {
model_file <- noncent_trend(
model_file = model_file,
trend_model = trend_model,
drift = drift
)
}
}
return(list(model_file = model_file, noncentred = noncentred))
}
================================================
FILE: R/onAttach.R
================================================
.onAttach = function(libname, pkgname) {
options("marginaleffects_model_classes" = "mvgam")
version <- utils::packageVersion("mvgam")
packageStartupMessage(
insight::format_message(
paste0(
"Loading 'mvgam' (version ",
version,
"). Useful instructions can be found by typing help('mvgam'). A more detailed introduction to the package is available through vignette('mvgam_overview')."
)
)
)
}
================================================
FILE: R/ordinate.jsdgam.R
================================================
#' Latent variable ordination plots from jsdgam objects
#'
#' Plot an ordination of latent variables and their factor loadings from
#' \code{jsdgam} models
#'
#' @name ordinate.jsdgam
#'
#' @param object \code{list} object of class \code{jsdgam} resulting from a
#' call to [jsdgam()]
#'
#' @param which_lvs A `vector` of indices indicating the two latent variables
#' to be plotted (if number of the latent variables specified in the model
#' was more than 2). Defaults to \code{c(1, 2)}
#'
#' @param biplot `Logical`. If `TRUE`, both the site and the species scores
#' will be plotted, with names for the taxa interpreted based on the
#' `species` argument in the original call to [jsdgam()]. If `FALSE`, only
#' the site scores will be plotted
#'
#' @param alpha A proportional numeric scalar between `0` and `1` that
#' controls the relative scaling of the latent variables and their loading
#' coefficients
#'
#' @param label_sites \code{Logical} flag. If `TRUE`, site scores will be
#' plotted as labels using names based on the `unit` argument in the
#' original call to [jsdgam()]. If `FALSE`, site scores will be shown as
#' points only
#'
#' @param ... ignored
#'
#' @details
#' This function constructs a two-dimensional scatterplot in ordination space.
#' The chosen latent variables are first re-rotated using singular value
#' decomposition, so that the first plotted latent variable does not have to
#' be the first latent variable that was estimated in the original model.
#' Posterior median estimates of the variables and the species' loadings on
#' these variables are then used to construct the resulting plot. Some attempt
#' at de-cluttering the resulting plot is made by using `geom_label_repel()`
#' and `geom_text_repel` from the \pkg{ggrepel} package, but if there are many
#' sites and/or species then some labels may be removed automatically. Note
#' that you can typically get better, more readable plot layouts if you also
#' have the \pkg{ggarrow} and \pkg{ggpp} packages installed
#'
#' @return An `ggplot` object
#'
#' @author Nicholas J Clark
#'
#' @seealso [jsdgam()], [residual_cor()]
#'
#' @examples
#'\dontrun{
#' # Fit a JSDGAM to the portal_data captures
#' mod <- jsdgam(
#' formula = captures ~
#' # Fixed effects of NDVI and mintemp, row effect as a GP of time
#' ndvi_ma12:series + mintemp:series + gp(time, k = 15),
#' factor_formula = ~ -1,
#' data = portal_data,
#' unit = time,
#' species = series,
#' family = poisson(),
#' n_lv = 2,
#' silent = 2,
#' chains = 2
#' )
#'
#' # Plot a residual ordination biplot
#' ordinate(
#' mod,
#' alpha = 0.7
#' )
#'
#' # Compare to a residual correlation plot
#' plot(
#' residual_cor(mod)
#' )
#' }
#'
#' @export
ordinate <- function(object, ...) {
UseMethod("ordinate", object)
}
#' @rdname ordinate.jsdgam
#' @method ordinate jsdgam
#' @importFrom grid arrow unit
#' @export
ordinate.jsdgam <- function(
object,
which_lvs = c(1, 2),
biplot = TRUE,
alpha = 0.5,
label_sites = TRUE,
...
) {
insight::check_if_installed(
'ggrepel',
reason = 'to adequately plot ordination scores'
)
if (!requireNamespace('ggpp', quietly = TRUE)) {
rlang::inform(
message = paste0(
'Package "ggpp" can enable more readable ordination plots\n',
'Please consider installing it'
),
.frequency = 'once',
.frequency_id = 'ggpp_ordinate'
)
}
if (!requireNamespace('ggarrow', quietly = TRUE)) {
rlang::inform(
message = paste0(
'Package "ggarrow" can enable more readable ordination plots\n',
'Please consider installing it'
),
.frequency = 'once',
.frequency_id = 'ggarrow_ordinate'
)
}
# Check arguments
if (length(which_lvs) != 2L) {
stop("argument 'which_lvs' must be a vector of length 2", call. = FALSE)
}
if (object$n_lv > 2 & any(which_lvs > object$n_lv)) {
stop(
"Fewer latent variables available than those chosen by which_lvs",
call. = FALSE
)
}
validate_proportional(alpha)
# Get indices of LV estimates
ends <- seq(
0,
dim(mcmc_chains(object$model_output, 'LV'))[2],
length.out = object$n_lv + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, object$n_lv + 1)])
ends <- ends[-1]
# Loop across each lv and calculate median estimates
lv_estimates <- do.call(
cbind,
lapply(1:object$n_lv, function(x) {
inds_lv <- seq(
x,
dim(mcmc_chains(object$model_output, 'LV'))[2],
by = object$n_lv
)
preds <- mcmc_chains(object$model_output, 'LV')[, inds_lv]
# Keep only the in-sample observations of the factors
preds <- preds[, 1:(length(object$obs_data$y) / NCOL(object$ytimes))]
# Calculate posterior medians
apply(preds, 2, median)
})
)
# Extract loadings, compute the SVD to re-rotate the variables and loadings
# Credit for much of this code goes to Francis Hui, original author of the BORAL
# R package (https://github.com/emitanaka/boral)
lv_estimates <- as.matrix(lv_estimates)
lv_coefs <- apply(mcmc_chains(object$model_output, 'lv_coefs'), 2, median)
lv_coefs <- t(matrix(lv_coefs, nrow = object$n_lv))
testcov <- tcrossprod(lv_estimates, lv_coefs)
do_svd <- svd(testcov, object$n_lv, object$n_lv)
choose_lvs <- scale(
do_svd$u *
matrix(
do_svd$d[1:object$n_lv]^alpha,
nrow = NROW(lv_estimates),
ncol = object$n_lv,
byrow = TRUE
),
center = TRUE,
scale = FALSE
)
choose_lv_coefs <- scale(
do_svd$v *
matrix(
do_svd$d[1:object$n_lv]^(1 - alpha),
nrow = NROW(lv_coefs),
ncol = object$n_lv,
byrow = TRUE
),
center = TRUE,
scale = FALSE
)
largest_lnorms <- order(
rowSums(choose_lv_coefs^2),
decreasing = TRUE
)[1:NROW(lv_coefs)]
# Extract site and species loadings into dataframes for plotting
sp_dat <- data.frame(choose_lv_coefs)[, which_lvs]
colnames(sp_dat) <- c('x', 'y')
site_dat <- data.frame(choose_lvs)[, which_lvs]
colnames(site_dat) <- c('x', 'y')
plot_dat <- rbind(
sp_dat,
site_dat
)
# Get taxa names
sp_names <- object$trend_map$series
# Get site names
unit_name <- attr(object$model_data, 'prepped_trend_model')$unit
site_names <- unique(
object$obs_data[[unit_name]]
)
# Create the base ggplot
base_plot <- ggplot2::ggplot(plot_dat, ggplot2::aes(x, y)) +
ggplot2::labs(
x = paste("Latent variable", which_lvs[1]),
y = paste("Latent variable", which_lvs[2])
)
# Add layers accordingly
if (label_sites) {
p <- base_plot +
ggrepel::geom_text_repel(
data = site_dat,
aes(label = site_names),
alpha = 0.75,
size = 3,
max.overlaps = 20,
colour = 'grey40',
segment.color = NA
) +
ggplot2::geom_point(
data = site_dat,
pch = 21,
fill = 'grey20',
colour = 'white'
)
} else {
p <- base_plot +
ggplot2::geom_point(
data = site_dat,
pch = 21,
fill = 'grey20',
colour = 'white'
)
}
if (biplot) {
if (
requireNamespace('ggarrow', quietly = TRUE) &
requireNamespace('ggpp', quietly = TRUE)
) {
sp_dat$group <- paste('gr', 1:NROW(sp_dat))
sp_arrow_dat <- do.call(
rbind,
lapply(1:nlevels(sp_names), function(x) {
data.frame(
x = seq(0, sp_dat$x[x], length.out = 20),
y = seq(0, sp_dat$y[x], length.out = 20),
group = sp_dat$group[x]
)
})
) %>%
dplyr::mutate(lw = abs(x) + abs(y))
p <- p +
ggarrow::geom_arrow(
data = sp_arrow_dat,
ggplot2::aes(
x = x,
y = y,
group = group,
linewidth = lw
),
colour = 'darkred',
stroke_colour = 'white',
stroke_width = 0.1,
alpha = 0.5,
show.legend = FALSE
) +
ggplot2::scale_linewidth(range = c(0.45, 1.75)) +
ggrepel::geom_label_repel(
data = sp_dat,
ggplot2::aes(label = sp_names),
color = 'darkred',
box.padding = 0.1,
label.size = 0.1,
alpha = 0.75,
max.overlaps = 20,
segment.color = NA,
position = ggpp::position_nudge_center(0.025, 0.025, 0, 0)
)
} else {
p <- p +
ggplot2::geom_segment(
data = sp_dat,
ggplot2::aes(
x = 0,
y = 0,
xend = x,
yend = y
),
arrow = arrow(
length = unit(0.1, "cm"),
type = 'closed'
),
alpha = 0.5,
color = 'darkred'
) +
ggrepel::geom_label_repel(
data = sp_dat,
ggplot2::aes(label = sp_names),
color = 'darkred',
box.padding = 0.1,
label.size = 0.1,
alpha = 0.75,
max.overlaps = 20
)
}
}
# Return the plot
p <- p + ggplot2::theme_classic()
return(p)
}
================================================
FILE: R/pairs.mvgam.R
================================================
#' Create a matrix of output plots from a \code{mvgam} object
#'
#' A \code{\link[graphics:pairs]{pairs}}
#' method that is customized for MCMC output.
#'
#' @param x An object of class \code{mvgam} or \code{jsdgam}
#' @inheritParams mcmc_plot.mvgam
#' @param ... Further arguments to be passed to
#' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}.
#'
#' @return Plottable objects whose classes depend on the arguments supplied.
#' See \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}} for details.
#' @details For a detailed description see
#' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}.
#'
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam(n_series = 1, trend_model = 'AR1')
#' mod <- mvgam(y ~ s(season, bs = 'cc'),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2)
#' pairs(mod)
#' pairs(mod, variable = c('ar1', 'sigma'), regex = TRUE)
#' }
#'
#' @export
pairs.mvgam <- function(
x,
variable = NULL,
regex = FALSE,
use_alias = TRUE,
...
) {
# Set red colour scheme
col_scheme <- attr(color_scheme_get(), 'scheme_name')
color_scheme_set('red')
# Set default params to plot
# By default, don't plot the Betas as there can be hundreds
# of them in spline models
if (is.null(variable)) {
all_pars <- variables(x)
variable <- c(
all_pars$observation_pars[, 1],
all_pars$observation_smoothpars[, 1],
all_pars$observation_re_params[, 1],
all_pars$trend_pars[, 1],
all_pars$trend_smoothpars[, 1],
all_pars$trend_re_params[, 1]
)
regex <- FALSE
}
draws <- as.array(
x,
variable = variable,
regex = regex,
use_alias = use_alias
)
# Generate plot and reset colour scheme
out_plot <- bayesplot::mcmc_pairs(draws, ...)
color_scheme_set(col_scheme)
# Return the plot
return(out_plot)
}
================================================
FILE: R/piecewise_trends.R
================================================
#' Updates for adding piecewise trends
#' @noRd
add_piecewise = function(
model_file,
model_data,
data_train,
data_test = NULL,
orig_trend_model,
family
) {
trend_model <- orig_trend_model$trend_model
n_changepoints <- orig_trend_model$n_changepoints
changepoint_range <- orig_trend_model$changepoint_range
changepoint_scale <- orig_trend_model$changepoint_scale
if (family$family == 'Gamma') {
family <- Gamma(link = 'log')
}
if (trend_model == 'PWlogistic') {
if (!(exists('cap', where = data_train))) {
stop(
'Capacities must be supplied as a variable named "cap" for logistic growth',
call. = FALSE
)
}
if (any(is.na(data_train$cap))) {
stop('Missing values found for some "cap" terms', call. = FALSE)
}
if (any(is.infinite(data_train$cap))) {
stop('Infinite values found for some "cap" terms', call. = FALSE)
}
# Matrix of capacities per series (these must operate on the link scale)
all_caps <- data.frame(
series = as.numeric(data_train$series),
time = data_train$time,
cap = suppressWarnings(linkfun(data_train$cap, link = family$link))
) %>%
dplyr::arrange(time, series)
if (any(is.na(all_caps$cap)) | any(is.infinite(all_caps$cap))) {
stop(
paste0(
'Missing or infinite values found for some "cap" terms\n',
'after transforming to the ',
family$link,
' link scale'
),
call. = FALSE
)
}
if (!is.null(data_test)) {
if (!(exists('cap', where = data_test))) {
stop(
'Capacities must also be supplied in "newdata" for logistic growth predictions',
call. = FALSE
)
}
all_caps <- rbind(
all_caps,
data.frame(
series = as.numeric(data_test$series),
time = data_test$time,
cap = suppressWarnings(linkfun(data_test$cap, link = family$link))
)
) %>%
dplyr::arrange(time, series)
if (any(is.na(all_caps$cap)) | any(is.infinite(all_caps$cap))) {
stop(
paste0(
'Missing or infinite values found for some "cap" terms\n',
'after transforming to the ',
family$link,
' link scale'
),
call. = FALSE
)
}
}
cap <- matrix(
NA,
nrow = length(unique(all_caps$time)),
ncol = length(unique(all_caps$series))
)
for (i in 1:length(unique(all_caps$series))) {
cap[, i] <- all_caps$cap[which(all_caps$series == i)]
}
} else {
cap <- NULL
}
#### Distribute possible changepoints ####
scaled_time <- unique(data_train$time - min(data_train$time) + 1)
max_time <- max(scaled_time)
hist_size <- floor(max_time * changepoint_range)
t_change <- unique(round(seq.int(
1,
hist_size,
length.out = (n_changepoints + 1)
)[-1]))
n_changepoints <- length(t_change)
change_freq <- n_changepoints / hist_size
if (!is.null(data_test)) {
# Get forecast horizon changepoints
# This can go in with the data if newdata is supplied; else it needs
# to be used when extrapolating the trend forward
n_new_changes <- stats::rpois(
1,
(change_freq *
(max(data_test$time) -
min(data_test$time)))
)
# Spread the forecast changepoints evenly across the forecast
# horizon
scaled_test_time <- unique(data_test$time - min(data_train$time) + 1)
t_change_new <- unique(floor(seq.int(
min(scaled_test_time),
max(scaled_test_time),
length.out = n_new_changes
)))
t_change <- c(t_change, t_change_new)
n_changepoints <- n_changepoints + n_new_changes
scaled_time <- c(scaled_time, scaled_test_time)
}
# Add changepoint info to the data
model_data$n_changepoints <- n_changepoints
model_data$change_freq <- change_freq
model_data$t_change <- t_change
model_data$time <- scaled_time
model_data$changepoint_scale <- changepoint_scale
model_data$cap <- cap
#### Update the model file appropriately ####
# Add the piecewise functions
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'matrix get_changepoint_matrix(vector t, vector t_change, int T, int S) {\n',
'/* Function to sort changepoints */\n',
'/* credit goes to the Prophet development team at Meta (https://github.com/facebook/prophet/tree/main)*/\n',
'matrix[T, S] A;\n',
'row_vector[S] a_row;\n',
'int cp_idx;\n',
'A = rep_matrix(0, T, S);\n',
'a_row = rep_row_vector(0, S);\n',
'cp_idx = 1;\n',
'for (i in 1:T) {\n',
'while ((cp_idx <= S) && (t[i] >= t_change[cp_idx])) {\n',
'a_row[cp_idx] = 1;\n',
'cp_idx = cp_idx + 1;\n',
'}\n',
'A[i] = a_row;\n',
'}\n',
'return A;\n',
'}\n',
'// logistic trend functions\n',
'vector logistic_gamma(real k, real m, vector delta, vector t_change, int S) {\n',
'/* Function to compute a logistic trend with changepoints */\n',
'/* credit goes to the Prophet development team at Meta (https://github.com/facebook/prophet/tree/main)*/\n',
'vector[S] gamma; // adjusted offsets, for piecewise continuity\n',
'vector[S + 1] k_s; // actual rate in each segment\n',
'real m_pr;\n',
'k_s = append_row(k, k + cumulative_sum(delta));\n',
'm_pr = m; // The offset in the previous segment\n',
'for (i in 1:S) {\n',
'gamma[i] = (t_change[i] - m_pr) * (1 - k_s[i] / k_s[i + 1]);\n',
'm_pr = m_pr + gamma[i]; // update for the next segment\n',
'}\n',
'return gamma;\n',
'}\n',
'vector logistic_trend(\n',
'real k,\n',
'real m,\n',
'vector delta,\n',
'vector t,\n',
'vector cap,\n',
'matrix A,\n',
'vector t_change,\n',
'int S\n',
') {\n',
'/* Function to adjust a logistic trend using a carrying capacity */\n',
'/* credit goes to the Prophet development team at Meta (https://github.com/facebook/prophet/tree/main)*/\n',
'vector[S] gamma;\n',
'gamma = logistic_gamma(k, m, delta, t_change, S);\n',
'return cap .* inv_logit((k + A * delta) .* (t - (m + A * gamma)));\n',
'}\n',
'// linear trend function\n',
'/* Function to compute a linear trend with changepoints */\n',
'/* credit goes to the Prophet development team at Meta (https://github.com/facebook/prophet/tree/main)*/\n',
'vector linear_trend(\n',
'real k,\n',
'real m,\n',
'vector delta,\n',
'vector t,\n',
'matrix A,\n',
'vector t_change\n',
') {\n',
'return (k + A * delta) .* t + (m + A * (-t_change .* delta));\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'matrix get_changepoint_matrix(vector t, vector t_change, int T, int S) {\n',
'/* Function to sort changepoints */\n',
'/* credit goes to the Prophet development team at Meta (https://github.com/facebook/prophet/tree/main)*/\n',
'matrix[T, S] A;\n',
'row_vector[S] a_row;\n',
'int cp_idx;\n',
'A = rep_matrix(0, T, S);\n',
'a_row = rep_row_vector(0, S);\n',
'cp_idx = 1;\n',
'for (i in 1:T) {\n',
'while ((cp_idx <= S) && (t[i] >= t_change[cp_idx])) {\n',
'a_row[cp_idx] = 1;\n',
'cp_idx = cp_idx + 1;\n',
'}\n',
'A[i] = a_row;\n',
'}\n',
'return A;\n',
'}\n',
'// logistic trend functions\n',
'vector logistic_gamma(real k, real m, vector delta, vector t_change, int S) {\n',
'/* Function to compute a logistic trend with changepoints */\n',
'/* credit goes to the Prophet development team at Meta (https://github.com/facebook/prophet/tree/main)*/\n',
'vector[S] gamma; // adjusted offsets, for piecewise continuity\n',
'vector[S + 1] k_s; // actual rate in each segment\n',
'real m_pr;\n',
'k_s = append_row(k, k + cumulative_sum(delta));\n',
'm_pr = m; // The offset in the previous segment\n',
'for (i in 1:S) {\n',
'gamma[i] = (t_change[i] - m_pr) * (1 - k_s[i] / k_s[i + 1]);\n',
'm_pr = m_pr + gamma[i]; // update for the next segment\n',
'}\n',
'return gamma;\n',
'}\n',
'vector logistic_trend(\n',
'real k,\n',
'real m,\n',
'vector delta,\n',
'vector t,\n',
'vector cap,\n',
'matrix A,\n',
'vector t_change,\n',
'int S\n',
') {\n',
'/* Function to adjust a logistic trend using a carrying capacity */\n',
'/* credit goes to the Prophet development team at Meta (https://github.com/facebook/prophet/tree/main)*/\n',
'vector[S] gamma;\n',
'gamma = logistic_gamma(k, m, delta, t_change, S);\n',
'return cap .* inv_logit((k + A * delta) .* (t - (m + A * gamma)));\n',
'}\n',
'// linear trend function\n',
'/* Function to compute a linear trend with changepoints */\n',
'/* credit goes to the Prophet development team at Meta (https://github.com/facebook/prophet/tree/main)*/\n',
'vector linear_trend(\n',
'real k,\n',
'real m,\n',
'vector delta,\n',
'vector t,\n',
'matrix A,\n',
'vector t_change\n',
') {\n',
'return (k + A * delta) .* t + (m + A * (-t_change .* delta));\n',
'}\n}\n'
)
}
# Update the data block
model_file[grep('int num_basis;', model_file, fixed = TRUE)] <-
paste0(
"int num_basis; // total number of basis coefficients\n",
"vector[n] time; // index of time for changepoint model\n",
"int n_changepoints; // number of potential trend changepoints\n",
"vector[n_changepoints] t_change; // times of potential changepoints\n",
if (trend_model == 'PWlogistic') {
"matrix[n, n_series] cap; // carrying capacities for logistic trends\n"
} else {
NULL
},
'real changepoint_scale; // scale of changepoint shock prior\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
# Update the transformed data block
if (any(grepl('transformed data {', model_file, fixed = TRUE))) {
model_file[grep('transformed data {', model_file, fixed = TRUE)] <-
paste0(
'transformed data {\n',
'// sorted changepoint matrix\n',
'matrix[n, n_changepoints] A = get_changepoint_matrix(time, t_change, n, n_changepoints);\n'
)
} else {
model_file[grep('parameters {', model_file, fixed = TRUE)[1]] <-
paste0(
'transformed data {\n',
'// sorted changepoint matrix\n',
'matrix[n, n_changepoints] A = get_changepoint_matrix(time, t_change, n, n_changepoints);\n',
'}\nparameters {'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
# Update the parameters block
model_file <- model_file[
-c(
grep(
'// latent trend variance parameters',
model_file,
fixed = TRUE
):(grep('// latent trend variance parameters', model_file, fixed = TRUE) +
1)
)
]
model_file <- model_file[
-c(
grep('// latent trends', model_file, fixed = TRUE):(grep(
'// latent trends',
model_file,
fixed = TRUE
) +
1)
)
]
model_file[grep("vector[num_basis] b_raw;", model_file, fixed = TRUE)] <-
paste0(
"vector[num_basis] b_raw;\n",
"// base trend growth rates\n",
"vector[n_series] k_trend;\n\n",
"// trend offset parameters\n",
"vector[n_series] m_trend;\n\n",
"// trend rate adjustments per series\n",
"matrix[n_changepoints, n_series] delta_trend;\n"
)
model_file <- readLines(textConnection(model_file), n = -1)
# Update the transformed parameters block
model_file[grep("transformed parameters {", model_file, fixed = TRUE)] <-
paste0(
"transformed parameters {\n",
"// latent trends\n",
"matrix[n, n_series] trend;\n"
)
max_rawline <- max(grep('= b_raw', model_file))
model_file[max_rawline] <- paste0(
model_file[max_rawline],
'\n\n',
'// trend estimates\n',
'for (s in 1 : n_series) {\n',
if (trend_model == 'PWlogistic') {
'trend[1 : n, s] = logistic_trend(k_trend[s], m_trend[s], to_vector(delta_trend[,s]), time, to_vector(cap[,s]), A, t_change, n_changepoints);\n'
} else {
'trend[1 : n, s] = linear_trend(k_trend[s], m_trend[s], to_vector(delta_trend[,s]), time, A, t_change);\n'
},
'}\n'
)
model_file <- readLines(textConnection(model_file), n = -1)
# Update the model block
model_file <- model_file[
-c(
grep(
'// priors for latent trend variance parameters',
model_file,
fixed = TRUE
):(grep(
'// priors for latent trend variance parameters',
model_file,
fixed = TRUE
) +
1)
)
]
rw_start <- grep(
"trend[1, 1:n_series] ~ normal(0, sigma);",
model_file,
fixed = TRUE
)
rw_lines <- (rw_start - 1):(rw_start + 3)
model_file <- model_file[-rw_lines]
model_file[grep("// likelihood functions", model_file, fixed = TRUE) - 1] <-
paste0(
'// trend parameter priors\n',
'm_trend ~ student_t(3, 0, 2.5);\n',
'k_trend ~ std_normal();\n',
'to_vector(delta_trend) ~ double_exponential(0, changepoint_scale);\n',
model_file[grep("// likelihood functions", model_file, fixed = TRUE) - 1]
)
model_file <- readLines(textConnection(model_file), n = -1)
# Update the generated quantities block
model_file <- model_file[
-grep("vector[n_series] tau;", model_file, fixed = TRUE)
]
tau_start <- grep("tau[s] = pow(sigma[s], -2.0);", model_file, fixed = TRUE) -
1
model_file <- model_file[-c(tau_start:(tau_start + 2))]
model_file <- readLines(textConnection(model_file), n = -1)
#### Return ####
return(list(model_file = model_file, model_data = model_data))
}
================================================
FILE: R/plot.mvgam.R
================================================
#' Default plots for \pkg{mvgam} models
#'
#' This function takes a fitted \code{mvgam} object and produces plots of
#' smooth functions, forecasts, trends and uncertainty components
#'
#' @param x \code{list} object returned from \code{mvgam}. See [mvgam()]
#'
#' @param type \code{character} specifying which type of plot to return.
#' Options are: `"series"`, `"residuals"`, `"smooths"`, `"re"` (random effect smooths),
#' `"pterms"` (parametric effects), `"forecast"`, `"trend"`, `"uncertainty"`,
#' `"factors"`
#'
#' @param residuals \code{logical}. If \code{TRUE} and `type = 'smooths'`,
#' posterior quantiles of partial residuals are added to plots of 1-D
#' smooths as a series of ribbon rectangles. Partial residuals for a
#' smooth term are the median Dunn-Smyth residuals that would be obtained
#' by dropping the term concerned from the model, while leaving all other
#' estimates fixed (i.e. the estimates for the term plus the original
#' median Dunn-Smyth residuals). Note that because \code{mvgam} works with
#' Dunn-Smyth residuals and not working residuals, which are used by
#' \code{mgcv}, the magnitudes of partial residuals will be different to
#' what you would expect from \code{\link[mgcv]{plot.gam}}. Interpretation
#' is similar though, as these partial residuals should be evenly scattered
#' around the smooth function if the function is well estimated
#'
#' @param series \code{integer} specifying which series in the set is to be
#' plotted. This is ignored if \code{type == 're'}
#'
#' @param newdata Optional \code{dataframe} or \code{list} of test data
#' containing at least 'series' and 'time' in addition to any other
#' variables included in the linear predictor of the original
#' \code{formula}. This argument is optional when plotting out of sample
#' forecast period observations (when \code{type = forecast}) and required
#' when plotting uncertainty components (\code{type = uncertainty}).
#'
#' @param trend_effects logical. If `TRUE` and a `trend_formula` was used in
#' model fitting, terms from the trend (i.e. process) model will be plotted
#'
#' @param data_test Deprecated. Still works in place of \code{newdata} but
#' users are recommended to use \code{newdata} instead for more seamless
#' integration into `R` workflows
#'
#' @param ... Additional arguments for each individual plotting function.
#'
#' @details These plots are useful for getting an overview of the fitted
#' model and its estimated random effects or smooth functions, but the
#' individual plotting functions and the functions from the `marginaleffects`
#' and `gratia` packages offer far more customisation.
#'
#' @seealso \code{\link{plot_mvgam_resids}},
#' \code{\link{plot_mvgam_smooth}},
#' \code{\link{plot_mvgam_fc}},
#' \code{\link{plot_mvgam_trend}},
#' \code{\link{plot_mvgam_uncertainty}},
#' \code{\link{plot_mvgam_factors}},
#' \code{\link{plot_mvgam_randomeffects}},
#' \code{\link{conditional_effects.mvgam}},
#' \code{\link[marginaleffects]{plot_predictions}},
#' \code{\link[marginaleffects]{plot_slopes}},
#' \code{\link{gratia_mvgam_enhancements}}
#'
#' @author Nicholas J Clark
#'
#' @return A base R plot or set of plots
#'
#' @examples
#' \dontrun{
#' # Simulate some time series
#' dat <- sim_mvgam(
#' T = 80,
#' n_series = 3
#' )
#'
#' # Fit a basic model
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc') + s(series, bs = 're'),
#' data = dat$data_train,
#' trend_model = RW(),
#' chains = 2,
#' silent = 2
#' )
#'
#' # Plot predictions and residuals for each series
#' plot(mod, type = 'forecast', series = 1)
#' plot(mod, type = 'forecast', series = 2)
#' plot(mod, type = 'forecast', series = 3)
#' plot(mod, type = 'residuals', series = 1)
#' plot(mod, type = 'residuals', series = 2)
#' plot(mod, type = 'residuals', series = 3)
#'
#' # Plot model effects
#' plot(mod, type = 'smooths')
#' plot(mod, type = 're')
#'
#' # More flexible plots with 'marginaleffects' utilities
#' library(marginaleffects)
#'
#' plot_predictions(
#' mod,
#' condition = 'season',
#' type = 'link'
#' )
#'
#' plot_predictions(
#' mod,
#' condition = c('season', 'series', 'series'),
#' type = 'link'
#' )
#'
#' plot_predictions(
#' mod,
#' condition = 'series',
#' type = 'link'
#' )
#'
#' # When using a State-Space model with predictors on the process
#' # model, set trend_effects = TRUE to visualise process effects
#' mod <- mvgam(
#' y ~ -1,
#' trend_formula = ~ s(season, bs = 'cc'),
#' data = dat$data_train,
#' trend_model = RW(),
#' chains = 2,
#' silent = 2
#' )
#'
#' plot(mod, type = 'smooths', trend_effects = TRUE)
#'
#' # But 'marginaleffects' functions work without any modification
#' plot_predictions(
#' mod,
#' condition = 'season',
#' type = 'link'
#' )
#' }
#'
#' @export
plot.mvgam = function(
x,
type = 'residuals',
series = 1,
residuals = FALSE,
newdata,
data_test,
trend_effects = FALSE,
...
) {
object <- x
# Argument checks
type <- match.arg(
arg = type,
choices = c(
"residuals",
"smooths",
"re",
"pterms",
"forecast",
"trend",
"uncertainty",
"factors",
"series"
)
)
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
if (!missing("newdata")) {
data_test <- newdata
}
# Other errors and warnings will propagate from individual functions below
if (type == 'series') {
print(plot_mvgam_series(object, series = series, newdata = data_test, ...))
}
if (type == 're') {
plot_mvgam_randomeffects(object, trend_effects = trend_effects, ...)
}
if (type == 'pterms') {
plot_mvgam_pterms(object, trend_effects = trend_effects, ...)
}
if (type == 'residuals') {
return(plot_mvgam_resids(object, series = series, ...))
}
if (type == 'factors') {
if (!object$use_lv) {
stop('no latent variables were fitted in the model')
} else {
return(plot_mvgam_factors(object))
}
}
if (type == 'forecast') {
if (missing(data_test)) {
plot_mvgam_fc(object, series = series, ...)
} else {
plot_mvgam_fc(object, series = series, data_test = data_test, ...)
}
}
if (type == 'trend') {
if (missing(data_test)) {
return(plot_mvgam_trend(object, series = series, ...))
} else {
return(plot_mvgam_trend(
object,
series = series,
data_test = data_test,
...
))
}
}
if (type == 'uncertainty') {
if (missing(data_test)) {
stop('data_test is required for plotting uncertainty contributions')
} else {
plot_mvgam_uncertainty(
object,
series = series,
data_test = data_test,
...
)
}
}
if (type == 'smooths') {
object2 <- object
if (trend_effects) {
if (is.null(object$trend_call)) {
stop('no trend_formula exists so there no trend-level smooths to plot')
}
object2$mgcv_model <- object2$trend_mgcv_model
}
# Get labels of all included smooths from the object2
smooth_labs <- do.call(
rbind,
lapply(seq_along(object2$mgcv_model$smooth), function(x) {
data.frame(
label = object2$mgcv_model$smooth[[x]]$label,
class = class(object2$mgcv_model$smooth[[x]])[1],
mgcv_plottable = object2$mgcv_model$smooth[[x]]$plot.me
)
})
)
n_smooths <- NROW(smooth_labs)
if (n_smooths == 0) {
stop(
"No smooth terms to plot. Use plot_predictions() to visualise other effects",
call. = FALSE
)
}
smooth_labs$smooth_index <- 1:NROW(smooth_labs)
# Leave out random effects and MRF smooths, and any others that are not
# considered plottable by mgcv
smooth_labs %>%
dplyr::filter(class != 'random.effect') %>%
dplyr::filter(class != 'mrf.smooth') %>%
dplyr::filter(mgcv_plottable) -> smooth_labs
if (length(smooth_labs$label) == 0) {
stop("No terms to plot - nothing for plot.mvgam() to do.")
}
# Check which ones plot_mvgam_smooth can handle (no more than 3 dimensions)
plottable = function(x) {
length(unlist(strsplit(x, ','))) <= 3 &
length(unlist(strsplit(x, ':'))) <= 3
}
which_to_plot <- (smooth_labs$smooth_index)[sapply(
as.character(smooth_labs$label),
plottable
)]
n_smooths <- length(which_to_plot)
# For remaining plots, get the needed page numbers
n_plots <- n_smooths
if (n_plots == 0) {
stop(
"No suitable terms to plot - plot.mvgam() only handles smooths of 2 or fewer dimensions."
)
}
pages <- 1
if (n_plots > 4) {
pages <- 2
}
if (n_plots > 8) {
pages <- 3
}
if (n_plots > 12) {
pages <- 4
}
if (pages != 0) {
ppp <- n_plots %/% pages
if (n_plots %% pages != 0) {
ppp <- ppp + 1
while (ppp * (pages - 1) >= n_plots) {
pages <- pages - 1
}
}
# Configure layout matrix
c <- r <- trunc(sqrt(ppp))
if (c < 1) {
r <- c <- 1
}
if (c * r < ppp) {
c <- c + 1
}
if (c * r < ppp) {
r <- r + 1
}
.pardefault <- par(no.readonly = T)
on.exit(par(.pardefault))
oldpar <- par(mfrow = c(r, c))
} else {
ppp <- 1
oldpar <- par()
}
# Plot the smooths
for (i in which_to_plot) {
plot_mvgam_smooth(
object = object2,
smooth = i,
series = series,
residuals = residuals,
trend_effects = trend_effects,
...
)
}
layout(1)
}
}
================================================
FILE: R/plot_mvgam_factors.R
================================================
#' Latent factor summaries for a fitted \pkg{mvgam} object
#'
#' This function takes a fitted \code{mvgam} object and returns plots and
#' summary statistics for the latent dynamic factors
#'
#' @param object \code{list} object returned from \code{mvgam}. See [mvgam()]
#'
#' @param plot \code{logical} specifying whether factors should be plotted
#'
#' @author Nicholas J Clark
#'
#' @details If the model in \code{object} was estimated using dynamic factors,
#' it is possible that not all factors contributed to the estimated trends.
#' This is due to the regularisation penalty that acts independently on each
#' factor's Gaussian precision, which will squeeze un-needed factors to a
#' white noise process (effectively dropping that factor from the model). In
#' this function, each factor is tested against a null hypothesis of white
#' noise by calculating the sum of the factor's 2nd derivatives. A factor
#' that has a larger contribution will have a larger sum due to the weaker
#' penalty on the factor's precision. If \code{plot == TRUE}, the factors
#' are also plotted.
#'
#' @return A \code{data.frame} of factor contributions
#'
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam()
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' use_lv = TRUE,
#' n_lv = 2,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' plot_mvgam_factors(mod)
#' }
#'
#' @export
plot_mvgam_factors = function(object, plot = TRUE) {
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
# Check object has latent dynamic factors
if (!object$use_lv) {
stop('No latent factors used in object')
}
# Get indices of LV estimates
ends <- seq(
0,
dim(mcmc_chains(object$model_output, 'LV'))[2],
length.out = object$n_lv + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, object$n_lv + 1)])
ends <- ends[-1]
probs <- c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
# Loop across each lv and calculate probability that the lv was dropped
lv_estimates <- do.call(
rbind,
lapply(1:object$n_lv, function(x) {
if (object$fit_engine == 'stan') {
inds_lv <- seq(
x,
dim(mcmc_chains(object$model_output, 'LV'))[2],
by = object$n_lv
)
preds <- mcmc_chains(object$model_output, 'LV')[, inds_lv]
} else {
preds <- mcmc_chains(object$model_output, 'LV')[, starts[x]:ends[x]]
}
# Keep only the in-sample observations for testing against the null of white noise
preds <- preds[, 1:(length(object$obs_data$y) / NCOL(object$ytimes))]
cred <- as.data.frame(t(sapply(
1:NCOL(preds),
function(n) quantile(preds[, n], probs = probs, na.rm = TRUE)
))) %>%
dplyr::mutate(lv = paste0('Factor ', x), time = 1:NCOL(preds))
colnames(cred) <- c(
paste0('lower', 1:4),
'med',
paste0('upper', 4:1),
'lv',
'time'
)
cred
})
)
# If plot = TRUE, plot the LVs
if (plot) {
p <- ggplot2::ggplot(
data = lv_estimates,
mapping = ggplot2::aes(x = time, y = med)
) +
ggplot2::facet_wrap(~lv) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower1, ymax = upper1),
fill = "#DCBCBC"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower2, ymax = upper2),
fill = "#C79999"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower3, ymax = upper3),
fill = "#B97C7C"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower4, ymax = upper4),
fill = "#A25050"
) +
ggplot2::geom_line(
mapping = ggplot2::aes(x = time, y = med),
col = "#8F2727",
linewidth = 1
) +
ggplot2::theme_bw() +
ggplot2::labs(x = 'Time', y = 'Posterior prediction')
}
# Calculate second derivatives of empirical medians and upper / lower intervals;
# factors with small second derivatives are moving in roughly a straight line and not
# likely contributing much (or at all) to the latent trend estimates
lv_contributions <- lv_estimates %>%
dplyr::group_by(lv) %>%
dplyr::reframe(
med_deriv = abs(diff(diff(med))),
upper_deriv = abs(diff(diff(upper2))),
lower_deriv = abs(diff(diff(lower2)))
) %>%
dplyr::rowwise() %>%
dplyr::mutate(contribution = sum(med_deriv, upper_deriv, lower_deriv)) %>%
dplyr::group_by(lv) %>%
dplyr::summarise(sum_contribution = sum(contribution)) %>%
dplyr::ungroup() %>%
dplyr::mutate(
total = sum(sum_contribution),
Contribution = sum_contribution / total,
Factor = lv
) %>%
dplyr::select(Factor, Contribution)
if (plot) {
print(p)
}
lv_contributions
}
================================================
FILE: R/plot_mvgam_fc.R
================================================
#' Plot posterior forecast predictions from \pkg{mvgam} models
#'
#' @importFrom stats formula terms
#'
#' @param object \code{list} object of class \code{mvgam}. See [mvgam()]
#'
#' @param series \code{integer} specifying which series in the set is to be
#' plotted
#'
#' @param newdata Optional \code{dataframe} or \code{list} of test data
#' containing at least 'series' and 'time' in addition to any other
#' variables included in the linear predictor of the original
#' \code{formula}. If included, the covariate information in \code{newdata}
#' will be used to generate forecasts from the fitted model equations. If
#' this same \code{newdata} was originally included in the call to
#' \code{mvgam}, then forecasts have already been produced by the generative
#' model and these will simply be extracted and plotted. However if no
#' \code{newdata} was supplied to the original model call, an assumption is
#' made that the \code{newdata} supplied here comes sequentially after the
#' data supplied as \code{data} in the original model (i.e. we assume there
#' is no time gap between the last observation of series 1 in \code{data}
#' and the first observation for series 1 in \code{newdata}). If
#' \code{newdata} contains observations in column \code{y}, these
#' observations will be used to compute a Discrete Rank Probability Score
#' for the forecast distribution
#'
#' @param data_test Deprecated. Still works in place of \code{newdata} but
#' users are recommended to use \code{newdata} instead for more seamless
#' integration into `R` workflows
#'
#' @param realisations \code{logical}. If \code{TRUE}, forecast realisations
#' are shown as a spaghetti plot, making it easier to visualise the
#' diversity of possible forecasts. If \code{FALSE}, the default, empirical
#' quantiles of the forecast distribution are shown
#'
#' @param n_realisations \code{integer} specifying the number of posterior
#' realisations to plot, if \code{realisations = TRUE}. Ignored otherwise
#'
#' @param n_cores \code{integer} specifying number of cores for generating
#' forecasts in parallel
#'
#' @param hide_xlabels \code{logical}. If \code{TRUE}, no xlabels are printed
#' to allow the user to add custom labels using \code{axis} from base
#' \code{R}
#'
#' @param xlab Label for x axis
#'
#' @param ylab Label for y axis
#'
#' @param ylim Optional \code{vector} of y-axis limits (min, max)
#'
#' @param ... Further \code{\link[graphics]{par}} graphical parameters
#'
#' @param return_forecasts \code{logical}. If \code{TRUE}, the function will
#' plot the forecast as well as returning the forecast object (as a
#' \code{matrix} of dimension \code{n_samples} x \code{horizon})
#'
#' @param return_score \code{logical}. If \code{TRUE} and out of sample test
#' data is provided as \code{newdata}, a probabilistic score will be
#' calculated and returned. The score used will depend on the observation
#' family from the fitted model. Discrete families (\code{poisson},
#' \code{negative binomial}, \code{tweedie}) use the Discrete Rank
#' Probability Score. Other families use the Continuous Rank Probability
#' Score. The value returned is the \code{sum} of all scores within the out
#' of sample forecast horizon
#'
#' @author Nicholas J Clark
#'
#' @details `plot_mvgam_fc` generates posterior predictions from an object of
#' class \code{mvgam}, calculates posterior empirical quantiles and plots
#' them against the observed data. If `realisations = FALSE`, the returned
#' plot shows 90, 60, 40 and 20 percent posterior quantiles (as ribbons of
#' increasingly darker shades of red) as well as the posterior median (as a
#' dark red line). If `realisations = TRUE`, a set of `n_realisations`
#' posterior draws are shown. This function produces an older style base
#' \code{R} plot, as opposed to `plot.mvgam_forecast`
#'
#' `plot.mvgam_forecast` takes an object of class `mvgam_forecast`, in which
#' forecasts have already been computed, and plots the resulting forecast
#' distribution as a `ggplot` object. This function is therefore more
#' versatile and is recommended over the older and clunkier
#' `plot_mvgam_fc` version
#'
#' If \code{realisations = FALSE}, these posterior quantiles are plotted
#' along with the true observed data that was used to train the model.
#' Otherwise, a spaghetti plot is returned to show possible forecast paths.
#'
#' @return A base \code{R} graphics plot (for `plot_mvgam_fc`) or a `ggplot`
#' object (for `plot.mvgam_forecast`) and an optional \code{list} containing
#' the forecast distribution and the out of sample probabilistic forecast
#' score
#'
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam(
#' n_series = 3,
#' trend_model = AR()
#' )
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Hindcasts on response scale
#' hc <- hindcast(mod)
#' str(hc)
#' plot(hc, series = 1)
#' plot(hc, series = 2)
#' plot(hc, series = 3)
#'
#' # Forecasts on response scale
#' fc <- forecast(
#' mod,
#' newdata = simdat$data_test
#' )
#' str(fc)
#' plot(fc, series = 1)
#' plot(fc, series = 2)
#' plot(fc, series = 3)
#'
#' # Forecasts as expectations
#' fc <- forecast(
#' mod,
#' newdata = simdat$data_test,
#' type = 'expected'
#' )
#' plot(fc, series = 1)
#' plot(fc, series = 2)
#' plot(fc, series = 3)
#'
#' # Dynamic trend extrapolations
#' fc <- forecast(
#' mod,
#' newdata = simdat$data_test,
#' type = 'trend'
#' )
#' plot(fc, series = 1)
#' plot(fc, series = 2)
#' plot(fc, series = 3)
#' }
#'
#' @name plot_mvgam_forecasts
NULL
#' @rdname plot_mvgam_forecasts
#' @export
plot_mvgam_fc = function(
object,
series = 1,
newdata,
data_test,
realisations = FALSE,
n_realisations = 15,
hide_xlabels = FALSE,
xlab,
ylab,
ylim,
n_cores = 1,
return_forecasts = FALSE,
return_score = FALSE,
...
) {
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
if (sign(series) != 1) {
stop('argument "series" must be a positive integer', call. = FALSE)
} else {
if (series %% 1 != 0) {
stop('argument "series" must be a positive integer', call. = FALSE)
}
}
if (series > NCOL(object$ytimes)) {
stop(
paste0(
'object only contains data / predictions for ',
NCOL(object$ytimes),
' series'
),
call. = FALSE
)
}
if (sign(n_realisations) != 1) {
stop('argument "n_realisations" must be a positive integer', call. = FALSE)
} else {
if (n_realisations %% 1 != 0) {
stop(
'argument "n_realisations" must be a positive integer',
call. = FALSE
)
}
}
if (return_score) {
return_forecasts <- TRUE
}
if (missing(data_test) & missing("newdata")) {
# Check if newdata already included in the model
if (!is.null(object$test_data)) {
data_test <- object$test_data
}
}
if (!missing("newdata")) {
data_test <- newdata
# Ensure outcome is labelled 'y' when feeding data to the model for simplicity
if (terms(formula(object$call))[[2]] != 'y') {
data_test$y <- data_test[[terms(formula(object$call))[[2]]]]
}
}
# Prediction indices for the particular series
data_train <- object$obs_data
ends <- seq(
0,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
length.out = NCOL(object$ytimes) + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, (NCOL(object$ytimes) + 1))])
ends <- ends[-1]
if (object$fit_engine == 'stan') {
# For stan objects, ypred is stored as a vector in column-major order
preds <- mcmc_chains(object$model_output, 'ypred')[,
seq(
series,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
by = NCOL(object$ytimes)
),
drop = FALSE
]
} else {
preds <- mcmc_chains(object$model_output, 'ypred')[,
starts[series]:ends[series],
drop = FALSE
]
}
# Add variables to data_test if missing
s_name <- levels(data_train$series)[series]
if (!missing(data_test)) {
# Ensure outcome is labelled 'y' when feeding data to the model for simplicity
if (terms(formula(object$call))[[2]] != 'y') {
if (object$family %in% c('binomial', 'beta_binomial')) {
resp_terms <- as.character(terms(formula(object$call))[[2]])
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
trial_name <- resp_terms[2]
data_test$y <- data_test[[resp_terms[1]]]
if (!exists(trial_name, data_test)) {
stop(
paste0('Variable ', trial_name, ' not found in newdata'),
call. = FALSE
)
}
} else {
data_test$y <- data_test[[terms(formula(object$call))[[2]]]]
}
}
if (!'y' %in% names(data_test)) {
data_test$y <- rep(NA, NROW(data_test))
}
if (inherits(data_test, 'list')) {
if (!'time' %in% names(data_test)) {
stop('data_test does not contain a "time" column')
}
if (!'series' %in% names(data_test)) {
data_test$series <- factor('series1')
}
} else {
if (!'time' %in% colnames(data_test)) {
stop('data_test does not contain a "time" column')
}
if (!'series' %in% colnames(data_test)) {
data_test$series <- factor('series1')
}
}
# If the posterior predictions do not already cover the data_test period, the forecast needs to be
# generated using the latent trend dynamics; note, this assumes that there is no gap between the training and
# testing datasets
if (inherits(data_test, 'list')) {
all_obs <- c(
data.frame(
y = data_train$y,
series = data_train$series,
time = data_train$time
) %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y),
data.frame(
y = data_test$y,
series = data_test$series,
time = data_test$time
) %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
)
} else {
all_obs <- c(
data_train %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y),
data_test %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
)
}
if (dim(preds)[2] != length(all_obs)) {
s_name <- levels(object$obs_data$series)[series]
if (attr(object$model_data, 'trend_model') == 'None') {
if (class(object$obs_data)[1] == 'list') {
series_obs <- which(data_test$series == s_name)
series_test <- lapply(data_test, function(x) {
if (is.matrix(x)) {
matrix(x[series_obs, ], ncol = NCOL(x))
} else {
x[series_obs]
}
})
} else {
series_test = data_test %>%
dplyr::filter(series == s_name)
}
fc_preds <- predict.mvgam(
object,
newdata = series_test,
type = 'response',
n_cores = n_cores
)
} else {
fc_preds <- forecast.mvgam(
object,
data_test = data_test,
n_cores = n_cores
)$forecasts[[series]]
}
preds <- cbind(preds, fc_preds)
}
}
# Plot quantiles of the forecast distribution
preds_last <- preds[1, ]
probs = c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
cred <- sapply(
1:NCOL(preds),
function(n) quantile(preds[, n], probs = probs, na.rm = TRUE)
)
c_light <- c("#DCBCBC")
c_light_highlight <- c("#C79999")
c_mid <- c("#B97C7C")
c_mid_highlight <- c("#A25050")
c_dark <- c("#8F2727")
c_dark_highlight <- c("#7C0000")
if (missing(ylim)) {
ytrain <- data.frame(
series = data_train$series,
time = data_train$time,
y = data_train$y
) %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
if (tolower(object$family) %in% c('beta', 'bernoulli')) {
ylim <- c(
min(cred, min(ytrain, na.rm = TRUE)),
max(cred, max(ytrain, na.rm = TRUE))
)
ymin <- max(0, ylim[1])
ymax <- min(1, ylim[2])
ylim <- c(ymin, ymax)
} else if (tolower(object$family) %in% c('lognormal', 'gamma')) {
ylim <- c(
min(cred, min(ytrain, na.rm = TRUE)),
max(cred, max(ytrain, na.rm = TRUE))
)
ymin <- max(0, ylim[1])
ymax <- max(ylim)
ylim <- c(ymin, ymax)
} else {
ylim <- c(
min(cred, min(ytrain, na.rm = TRUE)),
max(cred, max(ytrain, na.rm = TRUE))
)
}
}
if (missing(ylab)) {
ylab <- paste0('Predicitons for ', levels(data_train$series)[series])
}
if (missing(xlab)) {
xlab <- 'Time'
}
pred_vals <- seq(1:length(preds_last))
if (hide_xlabels) {
plot(
1,
type = "n",
bty = 'L',
xlab = '',
xaxt = 'n',
ylab = ylab,
xlim = c(0, length(preds_last)),
ylim = ylim,
...
)
} else {
plot(
1,
type = "n",
bty = 'L',
xlab = xlab,
ylab = ylab,
xaxt = 'n',
xlim = c(0, length(preds_last)),
ylim = ylim,
...
)
if (!missing(data_test)) {
axis(
side = 1,
at = floor(seq(
0,
max(data_test$time) -
(min(object$obs_data$time) - 1),
length.out = 6
)),
labels = floor(seq(
min(object$obs_data$time),
max(data_test$time),
length.out = 6
))
)
} else {
axis(
side = 1,
at = floor(seq(
0,
max(object$obs_data$time) -
(min(object$obs_data$time) - 1),
length.out = 6
)),
labels = floor(seq(
min(object$obs_data$time),
max(object$obs_data$time),
length.out = 6
))
)
}
}
if (realisations) {
for (i in 1:n_realisations) {
lines(x = pred_vals, y = preds[i, ], col = 'white', lwd = 2.5)
lines(
x = pred_vals,
y = preds[i, ],
col = sample(
c("#DCBCBC", "#C79999", "#B97C7C", "#A25050", "#7C0000"),
1
),
lwd = 2.25
)
}
} else {
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[1, ], rev(cred[9, ])),
col = c_light,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[2, ], rev(cred[8, ])),
col = c_light_highlight,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[3, ], rev(cred[7, ])),
col = c_mid,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[4, ], rev(cred[6, ])),
col = c_mid_highlight,
border = NA
)
lines(pred_vals, cred[5, ], col = c_dark, lwd = 2.5)
}
box(bty = 'L', lwd = 2)
if (!missing(data_test)) {
if (class(data_train)[1] == 'list') {
data_train <- data.frame(
series = data_train$series,
y = data_train$y,
time = data_train$time
)
data_test <- data.frame(
series = data_test$series,
y = data_test$y,
time = data_test$time
)
}
last_train <- (NROW(data_train) / NCOL(object$ytimes))
# Show historical (hindcast) distribution in grey
if (!realisations) {
polygon(
c(
pred_vals[1:(NROW(data_train) / NCOL(object$ytimes))],
rev(pred_vals[1:(NROW(data_train) / NCOL(object$ytimes))])
),
c(
cred[1, 1:(NROW(data_train) / NCOL(object$ytimes))],
rev(cred[9, 1:(NROW(data_train) / NCOL(object$ytimes))])
),
col = 'grey70',
border = NA
)
lines(
pred_vals[1:(NROW(data_train) / NCOL(object$ytimes))],
cred[5, 1:(NROW(data_train) / NCOL(object$ytimes))],
col = 'grey70',
lwd = 2.5
)
}
# Plot training and testing points
points(
dplyr::bind_rows(data_train, data_test) %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y),
pch = 16,
col = "white",
cex = 0.8
)
points(
dplyr::bind_rows(data_train, data_test) %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y),
pch = 16,
col = "black",
cex = 0.65
)
abline(v = last_train, col = '#FFFFFF60', lwd = 2.85)
abline(v = last_train, col = 'black', lwd = 2.5, lty = 'dashed')
# Calculate out of sample probabilistic score
truth <- as.matrix(
data_test %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
)
last_train <- length(
data_train %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
)
fc <- preds[, (last_train + 1):NCOL(preds)]
if (all(is.na(truth))) {
score <- NULL
message(
'No non-missing values in data_test$y; cannot calculate forecast score'
)
} else {
if (
object$family %in%
c(
'poisson',
'negative binomial',
'tweedie',
'binomial',
'beta_binomial'
)
) {
if (max(fc, na.rm = TRUE) > 50000) {
score <- sum(
crps_mcmc_object(as.vector(truth), fc)[, 1],
na.rm = TRUE
)
message(paste0('Out of sample CRPS:\n', score))
} else {
score <- sum(
drps_mcmc_object(as.vector(truth), fc)[, 1],
na.rm = TRUE
)
message(paste0('Out of sample DRPS:\n', score))
}
} else {
score <- sum(crps_mcmc_object(as.vector(truth), fc)[, 1], na.rm = TRUE)
message(paste0('Out of sample CRPS:\n', score))
}
}
} else {
if (class(data_train)[1] == 'list') {
data_train <- data.frame(
series = data_train$series,
y = data_train$y,
time = data_train$time
)
}
points(
data_train %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y),
pch = 16,
col = "white",
cex = 0.8
)
points(
data_train %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y),
pch = 16,
col = "black",
cex = 0.65
)
}
if (return_forecasts) {
if (return_score) {
if (!missing(data_test)) {
return(list(
forecast = preds[, (last_train + 1):NCOL(preds)],
score = score
))
} else {
return(list(forecast = preds, score = NULL))
}
} else {
if (!missing(data_test)) {
return(preds[, (last_train + 1):NCOL(preds)])
} else {
return(preds)
}
}
}
}
#' @rdname plot_mvgam_forecasts
#'
#' @param x Object of class `mvgam_forecast`
#'
#' @method plot mvgam_forecast
#'
#' @export
plot.mvgam_forecast = function(
x,
series = 1,
realisations = FALSE,
n_realisations = 15,
xlab,
ylab,
ylim,
...
) {
object <- x
validate_pos_integer(series)
validate_pos_integer(n_realisations)
if (series > length(object$series_names)) {
stop(
paste0(
'object only contains data / predictions for ',
length(object$series_names),
' series'
),
call. = FALSE
)
}
s_name <- object$series_names[series]
if (!s_name %in% names(object$hindcasts)) {
stop(
paste0('forecasts for ', s_name, ' have not yet been computed'),
call. = FALSE
)
}
# Extract hindcast and forecast predictions
type <- object$type
preds <- cbind(
object$hindcasts[[which(names(object$hindcasts) == s_name)]],
object$forecasts[[which(names(object$forecasts) == s_name)]]
)
# Plot quantiles of the forecast distribution
probs <- c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
cred <- sapply(
1:NCOL(preds),
function(n) quantile(preds[, n], probs = probs, na.rm = TRUE)
)
if (type == 'trend') {
if (missing(ylab)) {
ylab <- paste0('Estimated trend for ', s_name)
}
}
if (type == 'link') {
if (missing(ylab)) {
ylab <- paste0('Linear predictions for ', s_name)
}
}
if (type == 'expected') {
if (missing(ylab)) {
ylab <- paste0('Expectations for ', s_name)
}
}
if (type == 'detection') {
if (missing(ylab)) {
ylab <- paste0('Pr(detection) for ', s_name)
}
}
if (type == 'latent_N') {
if (missing(ylab)) {
ylab <- paste0('Latent abundance for ', s_name)
}
}
if (type == 'response') {
if (missing(ylab)) {
ylab <- paste0('Predictions for ', s_name)
}
}
if (missing(xlab)) {
xlab <- 'Time'
}
# Create a base plot using posterior credible intervals and observations
# for the specified series
plot_dat <- data.frame(
time = c(
object$train_times[[which(names(object$hindcasts) == s_name)]],
object$test_times[[which(names(object$hindcasts) == s_name)]]
),
med = cred[5, ],
lower1 = cred[1, ],
lower2 = cred[2, ],
lower3 = cred[3, ],
lower4 = cred[4, ],
upper1 = cred[9, ],
upper2 = cred[8, ],
upper3 = cred[7, ],
upper4 = cred[6, ],
truth = c(
object$train_observations[[s_name]],
object$test_observations[[s_name]]
)
)
base_plot <- ggplot2::ggplot(
data = plot_dat,
mapping = ggplot2::aes(x = time, y = truth)
) +
ggplot2::theme_classic() +
ggplot2::labs(x = xlab, y = ylab)
# Add to the base plot accordingly
if (realisations) {
for (i in 1:n_realisations) {
base_plot <- base_plot +
ggplot2::geom_line(
data = data.frame(
y = preds[i, ],
time = c(
object$train_times[[which(names(object$hindcasts) == s_name)]],
object$test_times[[which(names(object$hindcasts) == s_name)]]
)
),
mapping = ggplot2::aes(x = time, y = y),
col = "white",
linewidth = 1
) +
ggplot2::geom_line(
data = data.frame(
y = preds[i, ],
time = c(
object$train_times[[which(names(object$hindcasts) == s_name)]],
object$test_times[[which(names(object$hindcasts) == s_name)]]
)
),
mapping = ggplot2::aes(x = time, y = y),
col = sample(
c("#DCBCBC", "#C79999", "#B97C7C", "#A25050", "#7C0000"),
1
),
linewidth = 0.75
)
}
} else {
base_plot <- base_plot +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower1, ymax = upper1),
fill = "#DCBCBC"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower2, ymax = upper2),
fill = "#C79999"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower3, ymax = upper3),
fill = "#B97C7C"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower4, ymax = upper4),
fill = "#A25050"
) +
ggplot2::geom_line(
mapping = ggplot2::aes(x = time, y = med),
col = "#8F2727",
linewidth = 1
)
}
# Show historical (hindcast) distribution in grey if this object
# contains forecasts
train_times <- object$train_times[[s_name]]
last_train <- length(object$train_observations[[s_name]])
if (type == 'response' & !is.null(object$forecasts)) {
if (!realisations) {
base_plot <- base_plot +
ggplot2::geom_line(
data = data.frame(
time = train_times,
lower1 = cred[1, 1:last_train],
upper1 = cred[9, 1:last_train],
med = cred[5, 1:last_train],
truth = 0
),
mapping = ggplot2::aes(x = time, y = med),
col = "white",
linewidth = 1
) +
ggplot2::geom_ribbon(
data = data.frame(
time = train_times,
lower1 = cred[1, 1:last_train],
upper1 = cred[9, 1:last_train],
truth = 0
),
mapping = ggplot2::aes(ymin = lower1, ymax = upper1),
fill = "grey70"
)
}
}
if (
type == 'response' || c(type == 'expected' & object$family == 'bernoulli')
) {
# Plot training and testing points
base_plot <- base_plot +
ggplot2::geom_point(pch = 21, col = 'white', fill = 'black')
# Calculate out of sample probabilistic score;
# need to ensure fc is a matrix, even if only a single
# out of sample observation was forecasted (#111)
if (!is.null(object$forecasts)) {
fc <- as.matrix(object$forecasts[[s_name]])
} else {
fc <- NULL
}
truth <- object$test_observations[[s_name]]
if (all(is.na(truth))) {
score <- NULL
message(paste0(
'No non-missing values in test_observations; cannot calculate forecast score\n'
))
} else {
if (
object$family %in%
c(
'poisson',
'negative binomial',
'tweedie',
'binomial',
'beta_binomial'
)
) {
if (max(fc, na.rm = TRUE) > 50000) {
score <- sum(
crps_mcmc_object(as.vector(truth), fc)[, 1],
na.rm = TRUE
)
message(paste0('Out of sample CRPS:\n', score))
} else {
score <- sum(
drps_mcmc_object(as.vector(truth), fc)[, 1],
na.rm = TRUE
)
message(paste0('Out of sample DRPS:\n', score))
}
} else if (object$family == 'bernoulli') {
score <- sum(brier_mcmc_object(as.vector(truth), fc)[, 1], na.rm = TRUE)
message(paste0('Out of sample Brier:\n', score))
} else {
score <- sum(crps_mcmc_object(as.vector(truth), fc)[, 1], na.rm = TRUE)
message(paste0('Out of sample CRPS:\n', score))
}
}
}
if (!is.null(object$forecasts)) {
base_plot <- base_plot +
ggplot2::geom_vline(
xintercept = max(train_times),
linetype = 'dashed'
)
}
if (!missing(ylim)) {
base_plot <- base_plot +
ggplot2::scale_y_continuous(limits = ylim)
}
base_plot
}
================================================
FILE: R/plot_mvgam_pterms.R
================================================
#' Plot parametric term partial effects for \pkg{mvgam} models
#'
#' This function plots posterior empirical quantiles for partial effects of
#' parametric terms
#'
#' @importFrom graphics layout title rug bxp
#'
#' @importFrom stats coef predict
#'
#' @inheritParams plot.mvgam
#'
#' @param object \code{list} object of class \code{mvgam}. See [mvgam()]
#'
#' @details Posterior empirical quantiles of each parametric term's partial
#' effect estimates (on the link scale) are calculated and visualised as
#' ribbon plots. These effects can be interpreted as the partial effect that
#' a parametric term contributes when all other terms in the model have been
#' set to \code{0}
#'
#' @return A base \code{R} graphics plot
#'
#' @author Nicholas J Clark
#'
#' @export
plot_mvgam_pterms = function(object, trend_effects = FALSE) {
# General plotting colours and empirical quantile probabilities
c_light <- c("#DCBCBC")
c_light_trans <- c("#DCBCBC70")
c_light_highlight <- c("#C79999")
c_mid <- c("#B97C7C")
c_mid_highlight <- c("#A25050")
c_mid_highlight_trans <- c("#A2505095")
c_dark <- c("#8F2727")
c_dark_highlight <- c("#7C0000")
probs = c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
object2 <- object
if (trend_effects) {
if (is.null(object$trend_call)) {
stop('no trend_formula exists so there no trend-level smooths to plot')
}
object2$mgcv_model <- object2$trend_mgcv_model
}
# Look for parametric terms in the model
pterms <- attr(object2$mgcv_model$pterms, 'term.labels')
if (length(pterms) > 0) {
# Graphical parameters
.pardefault <- par(no.readonly = T)
on.exit(par(.pardefault))
if (length(pterms) == 1) {
par(mfrow = c(1, 1), mar = c(4, 4.5, 3, 4))
}
if (length(pterms) == 2) {
par(
mfrow = c(2, 1),
mar = c(2.5, 2.3, 2, 2),
oma = c(1, 1, 0, 0),
mgp = c(1.5, 0.5, 0)
)
}
if (length(pterms) %in% c(3, 4)) {
par(
mfrow = c(2, 2),
mar = c(2.5, 2.3, 2, 2),
oma = c(1, 1, 0, 0),
mgp = c(1.5, 0.5, 0)
)
}
for (i in 1:length(pterms)) {
# Find out which beta corresponds to the associated parametric term
betas_keep <- grepl(
paste0('^(?=.*', pterms[i], ')(?!.*s\\()'),
colnames(predict(object2$mgcv_model, type = 'lpmatrix')),
perl = TRUE
)
if (trend_effects) {
betas <- mcmc_chains(object2$model_output, 'b_trend')[, betas_keep]
} else {
betas <- mcmc_chains(object2$model_output, 'b')[, betas_keep]
}
# Generate linear predictor matrix from fitted mgcv model
Xp <- obs_Xp_matrix(
newdata = object2$obs_data,
mgcv_model = object2$mgcv_model
)
# Zero out all other columns in Xp
Xp[, !betas_keep] <- 0
# X-axis values
if (inherits(object2$obs_data, 'list')) {
pred_vals_orig <- sort(object2$obs_data[[pterms[i]]])
} else {
pred_vals_orig <- sort(
object2$obs_data %>%
dplyr::pull(pterms[i])
)
}
if (inherits(object2$obs_data[[pterms[i]]], 'factor')) {
# Use a simple Boxplot for factor terms for now
if (is.matrix(betas)) {
beta_creds <- apply(
betas,
2,
function(x) {
quantile(
x,
probs = c(0, 0.05, 0.5, 0.95, 1),
na.rm = TRUE
)
}
)
} else {
beta_creds <- matrix(quantile(
betas,
probs = c(0, 0.05, 0.5, 0.95, 1),
na.rm = TRUE
))
}
colnames(beta_creds) <-
substr(
names(coef(object2$mgcv_model))[grepl(
paste0('^(?=.*', pterms[i], ')(?!.*s\\()'),
colnames(predict(object2$mgcv_model, type = 'lpmatrix')),
perl = TRUE
)],
nchar(pterms[i]) + 1,
1000000L
)
bp <- boxplot(beta_creds, range = 0, plot = FALSE)
bxp(
bp,
whisklty = 0,
staplelty = 0,
boxfill = c_light,
boxcol = c_light,
medcol = c_dark,
frame.plot = FALSE,
ylab = paste0('Partial effect')
)
if (is.matrix(betas)) {
bp$stats <- apply(
betas,
2,
function(x) {
quantile(
x,
probs = c(0, 0.3, 0.5, 0.7, 1),
na.rm = TRUE
)
}
)
} else {
bp$stats <- matrix(quantile(
betas,
probs = c(0, 0.3, 0.5, 0.7, 1),
na.rm = TRUE
))
}
bxp(
bp,
whisklty = 0,
staplelty = 0,
add = TRUE,
frame.plot = FALSE,
boxcol = c_light_highlight,
medcol = c_dark,
boxfill = c_light_highlight
)
if (is.matrix(betas)) {
bp$stats <- apply(
betas,
2,
function(x) {
quantile(
x,
probs = c(0, 0.2, 0.5, 0.8, 1),
na.rm = TRUE
)
}
)
} else {
bp$stats <- matrix(quantile(
betas,
probs = c(0, 0.2, 0.5, 0.8, 1),
na.rm = TRUE
))
}
bxp(
bp,
whisklty = 0,
staplelty = 0,
add = TRUE,
frame.plot = FALSE,
boxcol = c_mid,
medcol = c_dark,
boxfill = c_mid
)
if (is.matrix(betas)) {
bp$stats <- apply(
betas,
2,
function(x) {
quantile(
x,
probs = c(0, 0.4, 0.5, 0.6, 1),
na.rm = TRUE
)
}
)
} else {
bp$stats <- matrix(quantile(
betas,
probs = c(0, 0.4, 0.5, 0.6, 1),
na.rm = TRUE
))
}
bxp(
bp,
whisklty = 0,
staplelty = 0,
add = TRUE,
frame.plot = FALSE,
boxcol = c_mid_highlight,
medcol = c_dark,
boxfill = c_mid_highlight
)
box(bty = 'L', lwd = 2)
title(pterms[i], adj = 0)
} else {
beta_creds <- quantile(betas, probs = probs, na.rm = TRUE)
pred_vals <- seq(
min(pred_vals_orig),
max(pred_vals_orig),
length.out = 500
)
cred <- as.matrix(beta_creds) %*% pred_vals
# Plot
plot(
1,
type = "n",
bty = 'L',
xlab = pterms[i],
ylab = paste0('Partial effect'),
xlim = c(min(pred_vals), max(pred_vals)),
ylim = c(min(cred), max(cred))
)
title(pterms[i], adj = 0)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[1, ], rev(cred[9, ])),
col = c_light,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[2, ], rev(cred[8, ])),
col = c_light_highlight,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[3, ], rev(cred[7, ])),
col = c_mid,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[4, ], rev(cred[6, ])),
col = c_mid_highlight,
border = NA
)
lines(pred_vals, cred[5, ], col = c_dark, lwd = 2.5)
rug(pred_vals_orig, lwd = 1.75, ticksize = 0.025, col = c_mid_highlight)
box(bty = 'L', lwd = 2)
}
}
layout(1)
} else {
message('No parametric terms in model formula')
}
}
================================================
FILE: R/plot_mvgam_randomeffects.R
================================================
#' Plot random effect terms from \pkg{mvgam} models
#'
#' This function plots posterior empirical quantiles for random effect
#' smooths (bs = re)
#'
#' @importFrom graphics layout title
#'
#' @inheritParams plot.mvgam
#'
#' @param object \code{list} object of class \code{mvgam}. See [mvgam()]
#'
#' @details Posterior empirical quantiles of random effect coefficient
#' estimates (on the link scale) are calculated and visualised as ribbon
#' plots. Labels for coefficients are taken from the levels of the original
#' factor variable that was used to specify the smooth in the model's
#' formula
#'
#' @return A base \code{R} graphics plot
#'
#' @author Nicholas J Clark
#'
#' @export
#'
plot_mvgam_randomeffects = function(object, trend_effects = FALSE) {
# General plotting colours and empirical quantile probabilities
c_light <- c("#DCBCBC")
c_light_trans <- c("#DCBCBC70")
c_light_highlight <- c("#C79999")
c_mid <- c("#B97C7C")
c_mid_highlight <- c("#A25050")
c_mid_highlight_trans <- c("#A2505095")
c_dark <- c("#8F2727")
c_dark_highlight <- c("#7C0000")
probs = c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
object2 <- object
if (trend_effects) {
if (is.null(object$trend_call)) {
stop('no trend_formula exists so there no trend-level smooths to plot')
}
object2$mgcv_model <- object2$trend_mgcv_model
}
# Labels of smooths in formula
smooth_labs <- do.call(
rbind,
lapply(seq_along(object2$mgcv_model$smooth), function(x) {
data.frame(
label = object2$mgcv_model$smooth[[x]]$label,
class = class(object2$mgcv_model$smooth[[x]])[1]
)
})
)
# Check if any smooths were bs = "re"; if not, return a message
if (any(smooth_labs$class == 'random.effect')) {
re_smooths <- smooth_labs %>%
dplyr::mutate(smooth_num = dplyr::row_number()) %>%
dplyr::filter(class == 'random.effect') %>%
dplyr::pull(label)
if (trend_effects) {
re_smooths <- gsub('series', 'trend', re_smooths, fixed = TRUE)
}
.pardefault <- par(no.readonly = T)
on.exit(par(.pardefault))
if (length(re_smooths) == 1) {
par(mfrow = c(1, 1))
}
if (length(re_smooths) == 2) {
par(mfrow = c(2, 1))
}
if (length(re_smooths) %in% c(3, 4)) {
par(mfrow = c(2, 2))
}
for (i in 1:length(re_smooths)) {
# Find out which betas correspond to the associated random effect estimates
(smooth_labs %>%
dplyr::mutate(smooth_num = dplyr::row_number()) %>%
dplyr::filter(class == 'random.effect') %>%
dplyr::pull(smooth_num))[i] -> smooth_number
betas_keep <- object2$mgcv_model$smooth[[
smooth_number
]]$first.para:object2$mgcv_model$smooth[[smooth_number]]$last.para
if (trend_effects) {
betas <- mcmc_chains(object2$model_output, 'b_trend')[, betas_keep]
} else {
betas <- mcmc_chains(object2$model_output, 'b')[, betas_keep]
}
# Plot the random effect estimates
beta_creds <- sapply(
1:NCOL(betas),
function(n) quantile(betas[, n], probs = probs, na.rm = TRUE)
)
N <- NCOL(betas)
x <- 1:N
idx <- rep(1:N, each = 2)
repped_x <- rep(x, each = 2)
x <- sapply(
1:length(idx),
function(k) {
if (k %% 2 == 0) {
repped_x[k] + min(diff(x)) / 2
} else {
repped_x[k] - min(diff(x)) / 2
}
}
)
plot(
1,
type = "n",
bty = 'L',
ylab = 'Partial effect',
xlab = '',
xlim = range(x),
xaxt = 'n',
ylim = range(c(as.vector(beta_creds)))
)
title(re_smooths[i], adj = 0)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = as.numeric(c(beta_creds[9, ])),
ybottom = as.numeric(c(beta_creds[1, ])),
col = c_light,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = as.numeric(c(beta_creds[8, ])),
ybottom = as.numeric(c(beta_creds[2, ])),
col = c_light_highlight,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = as.numeric(c(beta_creds[7, ])),
ybottom = as.numeric(c(beta_creds[3, ])),
col = c_mid,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = as.numeric(c(beta_creds[6, ])),
ybottom = as.numeric(c(beta_creds[4, ])),
col = c_mid_highlight,
border = 'transparent'
)
for (k in 1:(N)) {
lines(
x = c(x[seq(1, N * 2, by = 2)][k], x[seq(2, N * 2, by = 2)][k]),
y = c(beta_creds[5, k], beta_creds[5, k]),
col = c_dark,
lwd = 2
)
}
box(bty = 'L', lwd = 2)
# Label x-axis with the factor variable levels
factor_var_name <- tail(
strsplit(gsub('\\)', '', gsub('s\\(', '', re_smooths[i])), ',')[[1]],
1
)
if (trend_effects & factor_var_name == 'trend') {
# Just use trend labels
axis(side = 1, at = 1:N, labels = paste0('trend_', 1:N))
} else {
if (inherits(object2$obs_data, 'list')) {
axis(
side = 1,
at = 1:N,
labels = levels(object2$obs_data[[factor_var_name]])
)
} else {
axis(
side = 1,
at = 1:N,
labels = levels(
object2$obs_data %>%
dplyr::pull(factor_var_name)
)
)
}
}
}
layout(1)
} else {
message('No random effect smooths (bs = "re") in model formula')
}
}
================================================
FILE: R/plot_mvgam_resids.R
================================================
#' Residual diagnostics for a fitted \pkg{mvgam} object
#'
#' This function takes a fitted \code{mvgam} object and returns various
#' residual diagnostic plots
#'
#' @importFrom graphics layout title
#'
#' @importFrom stats complete.cases qqnorm qqline acf pacf na.pass
#'
#' @importFrom mgcv bam
#'
#' @param object \code{list} object returned from \code{mvgam}. See [mvgam()]
#'
#' @param series \code{integer} specifying which series in the set is to be
#' plotted
#'
#' @param n_draws \code{integer} specifying the number of posterior residual
#' draws to use for calculating uncertainty in the `"ACF"` and `"pACF"` frames.
#' Default is `100`
#'
#' @param n_points \code{integer} specifying the maximum number of points to
#' show in the "Resids vs Fitted" and "Normal Q-Q Plot" frames. Default is
#' `1000`
#'
#' @author Nicholas J Clark
#'
#' @details A total of four ggplot plots are generated to examine posterior
#' Dunn-Smyth residuals for the specified series. Plots include a residuals
#' vs fitted values plot, a Q-Q plot, and two plots to check for any
#' remaining temporal autocorrelation in the residuals. Note, all plots only
#' report statistics from a sample of up to `100` posterior draws (to save
#' computational time), so uncertainty in these relationships may not be
#' adequately represented.
#'
#' @return A facetted `ggplot` object
#'
#' @author Nicholas J Clark and Matthijs Hollanders
#'
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam(
#' n_series = 3,
#' trend_model = AR()
#' )
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Plot Dunn Smyth residuals for some series
#' plot_mvgam_resids(mod)
#' plot_mvgam_resids(mod, series = 2)
#' }
#'
#' @export
plot_mvgam_resids = function(
object,
series = 1,
n_draws = 100L,
n_points = 1000L
) {
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
validate_pos_integer(series)
validate_pos_integer(n_draws)
validate_pos_integer(n_points)
if (series > NCOL(object$ytimes)) {
stop(
paste0(
'object only contains data / predictions for ',
NCOL(object$ytimes),
' series'
),
call. = FALSE
)
}
# Take a sample of posterior draws to compute autocorrelation statistics
# This is because acf(posterior_median_residual) can induce spurious patterns
# due to the randomness of DS residuals;
# rather, we want median(acf(residual_i)), where i indexes all possible draws
# But this is computationally expensive for some models so we compromise
# by only taking a few draws
n_total_draws <- NROW(object$resids[[series]])
n_samps <- min(n_draws, n_total_draws)
hcs <- hindcast(object, type = 'expected')$hindcasts[[series]]
resids <- object$resids[[series]]
resid_df <- do.call(
rbind,
lapply(seq_len(n_samps), function(x) {
data.frame(preds = hcs[x, ], resids = resids[x, ], .draw = x) %>%
dplyr::filter(!is.na(resids))
})
)
# Plot predictions and residuals (but limit number of points to n_points to
# speed up plotting)
if (NROW(resid_df) > n_points) {
resid_df <- resid_df[sample(1:NROW(resid_df), n_points, replace = FALSE), ]
}
fvr_plot <- ggplot2::ggplot(resid_df, ggplot2::aes(preds, resids)) +
ggplot2::geom_point(shape = 16, col = 'white', size = 1.25, alpha = 0.4) +
ggplot2::geom_point(shape = 16, col = 'black', size = 1, alpha = 0.4) +
ggplot2::geom_smooth(
method = "gam",
formula = y ~ s(x, bs = "cs"),
colour = "#7C000060",
fill = "#7C000040"
) +
ggplot2::labs(
title = "Resids vs Fitted",
x = "Fitted values",
y = "DS residuals"
) +
ggplot2::theme_bw()
# Q-Q plot
qq_plot <- ggplot2::ggplot(resid_df, ggplot2::aes(sample = resids)) +
ggplot2::stat_qq_line(colour = "#8F2727", linewidth = 1) +
ggplot2::stat_qq(shape = 16, col = 'white', size = 1.25, alpha = 0.4) +
ggplot2::stat_qq(shape = 16, col = 'black', size = 1, alpha = 0.4) +
ggplot2::labs(
title = "Normal Q-Q Plot",
x = "Theoretical Quantiles",
y = "Sample Quantiles"
) +
ggplot2::theme_bw()
# ACF plot
acf_stats <- do.call(
rbind,
lapply(seq_len(n_samps), function(x) {
acf_calc <- acf(resids[x, ], plot = FALSE, na.action = na.pass)
data.frame(
acf = acf_calc$acf[,, 1],
lag = acf_calc$lag[, 1, 1],
denom = sqrt(acf_calc$n.used)
) %>%
dplyr::filter(lag > 0)
})
) %>%
dplyr::group_by(lag) %>%
dplyr::mutate(
ylow = quantile(acf, probs = 0.05, na.rm = TRUE),
yqlow = quantile(acf, probs = 0.2, na.rm = TRUE),
ymidlow = quantile(acf, probs = 0.25, na.rm = TRUE),
ymidhigh = quantile(acf, probs = 0.75, na.rm = TRUE),
yqhigh = quantile(acf, probs = 0.8, na.rm = TRUE),
yhigh = quantile(acf, probs = 0.95, na.rm = TRUE)
) %>%
dplyr::select(-acf) %>%
dplyr::distinct()
acf_plot <- ggplot2::ggplot(acf_stats, ggplot2::aes(x = lag)) +
ggplot2::geom_hline(
yintercept = c(-1, 1) *
qnorm((1 + 0.95) / 2) /
acf_stats$denom[1],
linetype = "dashed"
) +
ggplot2::geom_hline(yintercept = 0, colour = "#7C0000", linewidth = 0.25) +
ggplot2::geom_segment(
colour = "#DCBCBC",
linewidth = 1.5,
ggplot2::aes(y = ylow, yend = yhigh)
) +
ggplot2::geom_segment(
colour = "#B97C7C",
linewidth = 1.5,
ggplot2::aes(y = yqlow, yend = yqhigh)
) +
ggplot2::geom_segment(
colour = "#7C0000",
linewidth = 1.5,
ggplot2::aes(y = ymidlow, yend = ymidhigh)
) +
ggplot2::labs(title = "ACF", x = "Lag", y = "Autocorrelation") +
ggplot2::theme_bw()
# PACF plot
pacf_stats <- do.call(
rbind,
lapply(seq_len(n_samps), function(x) {
acf_calc <- pacf(resids[x, ], plot = FALSE, na.action = na.pass)
data.frame(
pacf = acf_calc$acf[,, 1],
lag = acf_calc$lag[, 1, 1],
denom = sqrt(acf_calc$n.used)
) %>%
dplyr::filter(lag > 0)
})
) %>%
dplyr::group_by(lag) %>%
dplyr::mutate(
ylow = quantile(pacf, probs = 0.05, na.rm = TRUE),
yqlow = quantile(pacf, probs = 0.2, na.rm = TRUE),
ymidlow = quantile(pacf, probs = 0.25, na.rm = TRUE),
ymidhigh = quantile(pacf, probs = 0.75, na.rm = TRUE),
yqhigh = quantile(pacf, probs = 0.8, na.rm = TRUE),
yhigh = quantile(pacf, probs = 0.95, na.rm = TRUE)
) %>%
dplyr::select(-pacf) %>%
dplyr::distinct()
pacf_plot <- ggplot2::ggplot(pacf_stats, ggplot2::aes(x = lag)) +
ggplot2::geom_hline(
yintercept = c(-1, 1) *
qnorm((1 + 0.95) / 2) /
pacf_stats$denom[1],
linetype = "dashed"
) +
ggplot2::geom_hline(yintercept = 0, colour = "#7C0000", linewidth = 0.25) +
ggplot2::geom_segment(
colour = "#DCBCBC",
linewidth = 1.5,
ggplot2::aes(y = ylow, yend = yhigh)
) +
ggplot2::geom_segment(
colour = "#B97C7C",
linewidth = 1.5,
ggplot2::aes(y = yqlow, yend = yqhigh)
) +
ggplot2::geom_segment(
colour = "#7C0000",
linewidth = 1.5,
ggplot2::aes(y = ymidlow, yend = ymidhigh)
) +
ggplot2::labs(title = "pACF", x = "Lag", y = "Partial autocorrelation") +
ggplot2::theme_bw()
# return
patchwork::wrap_plots(
fvr_plot,
qq_plot,
acf_plot,
pacf_plot,
ncol = 2,
nrow = 2,
byrow = TRUE
)
}
================================================
FILE: R/plot_mvgam_series.R
================================================
#' Plot observed time series used for \pkg{mvgam} modelling
#'
#' This function takes either a fitted \code{mvgam} object or a
#' \code{data.frame} object and produces plots of observed time series, ACF,
#' CDF and histograms for exploratory data analysis
#'
#' @importFrom stats lag
#'
#' @param object Optional \code{list} object returned from \code{mvgam}. Either
#' \code{object} or \code{data} must be supplied
#'
#' @param data Optional \code{data.frame} or \code{list} of training data
#' containing at least 'series' and 'time'. Use this argument if training
#' data have been gathered in the correct format for \code{mvgam} modelling
#' but no model has yet been fitted.
#'
#' @param newdata Optional \code{data.frame} or \code{list} of test data
#' containing at least 'series' and 'time' for the forecast horizon, in
#' addition to any other variables included in the linear predictor of
#' \code{formula}. If included, the observed values in the test data are
#' compared to the model's forecast distribution for exploring biases in
#' model predictions
#'
#' @param y Character. What is the name of the outcome variable in the supplied
#' data? Defaults to \code{'y'}
#'
#' @param lines Logical. If \code{TRUE}, line plots are used for visualizing
#' time series. If \code{FALSE}, points are used.
#'
#' @param series Either an \code{integer} specifying which series in the set is
#' to be plotted or the string 'all', which plots all series available in the
#' supplied data
#'
#' @param n_bins \code{integer} specifying the number of bins to use for
#' binning observed values when plotting a histogram. Default is to use the
#' number of bins returned by a call to `hist` in base `R`
#'
#' @param log_scale \code{logical}. If \code{series == 'all'}, this flag is
#' used to control whether the time series plot is shown on the log scale
#' (using `log(Y + 1)`). This can be useful when visualizing many series that
#' may have different observed ranges. Default is \code{FALSE}
#'
#' @author Nicholas J Clark and Matthijs Hollanders
#'
#' @return A set of ggplot objects. If \code{series} is an integer, the plots
#' will show observed time series, autocorrelation and cumulative
#' distribution functions, and a histogram for the series. If
#' \code{series == 'all'}, a set of observed time series plots is returned in
#' which all series are shown on each plot but only a single focal series is
#' highlighted, with all remaining series shown as faint gray lines.
#'
#' @examples
#' # Simulate and plot series with observations bounded at 0 and 1 (Beta responses)
#' sim_data <- sim_mvgam(
#' family = betar(),
#' trend_model = RW(),
#' prop_trend = 0.6
#' )
#'
#' plot_mvgam_series(
#' data = sim_data$data_train,
#' series = 'all'
#' )
#'
#' plot_mvgam_series(
#' data = sim_data$data_train,
#' newdata = sim_data$data_test,
#' series = 1
#' )
#'
#' # Now simulate series with overdispersed discrete observations
#' sim_data <- sim_mvgam(
#' family = nb(),
#' trend_model = RW(),
#' prop_trend = 0.6,
#' phi = 10
#' )
#'
#' plot_mvgam_series(
#' data = sim_data$data_train,
#' series = 'all'
#' )
#'
#' @export
plot_mvgam_series <- function(
object,
data,
newdata,
y = 'y',
lines = TRUE,
series = 1,
n_bins = NULL,
log_scale = FALSE
) {
# Validate series
if (is.character(series)) {
if (series != 'all') {
stop(
'argument "series" must be either a positive integer or "all"',
call. = FALSE
)
}
} else {
if (sign(series) != 1) {
stop(
'argument "series" must be either a positive integer or "all"',
call. = FALSE
)
} else {
if (series %% 1 != 0) {
stop(
'argument "series" must be either a positive integer or "all"',
call. = FALSE
)
}
}
}
# Extract training data
if (!missing(object)) {
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
if (!missing("data")) {
warning('both "object" and "data" were supplied; only using "object"')
}
data_train <- object$obs_data
# What is the response variable?
resp_terms <- as.character(terms(formula(object$call))[[2]])
if (length(resp_terms) == 1) {
y <- as.character(terms(object$call)[[2]])
} else {
if (any(grepl('cbind', resp_terms))) {
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
y <- resp_terms[1]
}
}
} else {
data_train <- data
}
# Validate data
data_train <- validate_plot_data(data_train, y)
if (!missing(newdata)) {
data_test <- validate_plot_data(newdata, y)
}
# Determine what to plot
if (is.character(series) && series == 'all') {
# Only return a plot of the time series
dat <- dplyr::as_tibble(data_train) %>%
dplyr::distinct(time, y, series)
# Create time series plot
plot_ts <- plot_time_series(dat, lines, log_scale, y, series)
# Return
return(plot_ts)
} else {
# Return multiple plots for one time series
s_name <- levels(data_train$series)[series]
# Bind test data if supplied
dat <- dplyr::as_tibble(data_train) %>%
dplyr::filter(series == s_name) %>%
dplyr::distinct(time, y) %>%
dplyr::mutate(data = "train")
if (!missing(newdata)) {
dat <- dplyr::bind_rows(
dat,
dplyr::as_tibble(data_test) %>%
dplyr::filter(series == s_name) %>%
dplyr::distinct(time, y) %>%
dplyr::mutate(data = "validate")
)
}
# Create each plot component
plot_ts <- plot_time_series(dat, lines, log_scale, y, series)
plot_hist <- plot_histogram(dat, y, n_bins)
plot_acf_obj <- plot_acf(dat)
plot_ecdf_obj <- plot_ecdf(dat, y)
# Wrap plots using patchwork
return(
patchwork::wrap_plots(
plot_ts,
plot_hist,
plot_acf_obj,
plot_ecdf_obj,
ncol = 2,
nrow = 2,
byrow = TRUE
)
)
}
}
#' Helper function to validate and format input plotting data
#' @noRd
validate_plot_data <- function(data, y) {
# Check if data is not a list
if (!inherits(data, 'list')) {
# If 'series' column is missing, create a default factor
if (!'series' %in% colnames(data)) {
data$series <- factor('series1')
}
# If 'time' column is missing, stop with error
if (!'time' %in% colnames(data)) {
stop('data does not contain a "time" column', call. = FALSE)
}
} else {
# If data is a list, check for 'series' and 'time' in names
if (!'series' %in% names(data)) {
data$series <- factor('series1')
}
if (!'time' %in% names(data)) {
stop('data does not contain a "time" column')
}
}
# Check if the outcome variable 'y' exists in data
if (!y %in% names(data)) {
stop(paste0('variable "', y, '" not found in data'), call. = FALSE)
} else {
# Assign the outcome variable to a standard column 'y'
data$y <- data[[y]]
}
# Drop unused factor levels in 'series'
data$series <- droplevels(data$series)
# Return the validated and formatted data
return(data)
}
#' Function to generate time series plots
#' @noRd
plot_time_series <- function(
dat,
lines = TRUE,
log_scale = FALSE,
ylab = 'y',
series = 'all'
) {
# Determine scale and y label
if (log_scale) {
dat$y <- log(dat$y + 1)
ylab <- paste0('log(', ylab, ' + 1)')
}
# Create time series plot
if (series == 'all') {
p <- ggplot2::ggplot(dat, ggplot2::aes(time, y)) +
ggplot2::facet_wrap(~series) +
ggplot2::labs(x = "Time", y = ylab) +
ggplot2::theme_bw()
if (lines) {
p <- p + ggplot2::geom_line(colour = "#8F2727", linewidth = 0.75)
} else {
p <- p + ggplot2::geom_point(colour = "#8F2727")
}
} else {
p <- ggplot2::ggplot(dat, ggplot2::aes(time, y, colour = data)) +
ggplot2::labs(title = "Time series", x = "Time", y = ylab) +
ggplot2::geom_vline(
xintercept = dat %>%
dplyr::filter(data == "validate") %>%
dplyr::pull(time) %>%
min(c(., Inf)),
linetype = "dashed",
colour = "black"
) +
ggplot2::scale_colour_manual(values = c("#8F2727", "black")) +
ggplot2::theme_bw()
if (lines) {
p <- p + ggplot2::geom_line(show.legend = F, linewidth = 0.75)
} else {
p <- p + ggplot2::geom_point(show.legend = F)
}
}
return(p)
}
#' Function to create histogram of observed values
#' @noRd
plot_histogram <- function(dat, ylab = 'y', n_bins = NULL) {
# Determine bins
if (is.null(n_bins)) {
n_bins <- max(c(length(hist(c(dat$y), plot = F)$breaks), 20))
}
# Plot the histogram
ggplot2::ggplot(dat, ggplot2::aes(y)) +
ggplot2::geom_histogram(bins = n_bins, fill = "#8F2727", col = 'white') +
ggplot2::labs(title = "Histogram", x = ylab, y = "Count") +
ggplot2::theme_bw()
}
#' Function to compute and plot autocorrelation
#' @noRd
plot_acf <- function(dat) {
# Compute empirical ACF
acf_y <- acf(dat$y, plot = F, na.action = na.pass)
# Plot
data.frame(acf = acf_y$acf[,, 1], lag = acf_y$lag[, 1, 1]) %>%
ggplot2::ggplot(ggplot2::aes(x = lag, y = 0, yend = acf)) +
ggplot2::geom_hline(
yintercept = c(-1, 1) * qnorm((1 + 0.95) / 2) / sqrt(acf_y$n.used),
linetype = "dashed"
) +
ggplot2::geom_hline(
yintercept = 0,
colour = "#8F2727",
linewidth = 0.25
) +
ggplot2::geom_segment(colour = "#8F2727", linewidth = 1) +
ggplot2::labs(title = "ACF", x = "Lag", y = "Autocorrelation") +
ggplot2::theme_bw()
}
#' Function to generate empirical cumulative distribution
#' @noRd
plot_ecdf <- function(dat, ylab = 'y') {
# Compute empriical ECDF
range_y <- range(dat$y, na.rm = T)
data.frame(x = seq(range_y[1], range_y[2], length.out = 100)) %>%
dplyr::mutate(y = ecdf(dat$y)(x)) %>%
# Plot
ggplot2::ggplot(ggplot2::aes(x, y)) +
ggplot2::geom_line(colour = "#8F2727", linewidth = 0.75) +
ggplot2::scale_y_continuous(limits = c(0, 1)) +
ggplot2::labs(
title = "CDF",
x = ylab,
y = "Empirical CDF"
) +
ggplot2::theme_bw()
}
================================================
FILE: R/plot_mvgam_smooth.R
================================================
#' Plot smooth terms from \pkg{mvgam} models
#'
#' This function plots posterior empirical quantiles for a series-specific
#' smooth term
#'
#' @importFrom grDevices hcl.colors
#'
#' @importFrom stats quantile predict
#'
#' @inheritParams plot.mvgam
#'
#' @param object \code{list} object of class \code{mvgam}. See [mvgam()]
#'
#' @param series \code{integer} specifying which series in the set is to be
#' plotted
#'
#' @param smooth Either a \code{character} or \code{integer} specifying which
#' smooth term to be plotted
#'
#' @param residuals \code{logical}. If \code{TRUE}, posterior quantiles of
#' partial residuals are added to plots of 1-D smooths as a series of ribbon
#' rectangles. Partial residuals for a smooth term are the median Dunn-Smyth
#' residuals that would be obtained by dropping the term concerned from the
#' model, while leaving all other estimates fixed (i.e. the estimates for the
#' term plus the original median Dunn-Smyth residuals). Note that because
#' \code{mvgam} works with Dunn-Smyth residuals and not working residuals,
#' which are used by \code{mgcv}, the magnitudes of partial residuals will be
#' different to what you would expect from \code{\link[mgcv]{plot.gam}}.
#' Interpretation is similar though, as these partial residuals should be
#' evenly scattered around the smooth function if the function is well
#' estimated
#'
#' @param n_resid_bins \code{integer} specifying the number of bins to group
#' the covariate into when plotting partial residuals. Setting this argument
#' too high can make for messy plots that are difficult to interpret, while
#' setting it too low will likely mask some potentially useful patterns in
#' the partial residuals. Default is \code{25}
#'
#' @param derivatives \code{logical}. If \code{TRUE}, an additional plot will
#' be returned to show the estimated 1st derivative for the specified smooth
#' (Note: this only works for univariate smooths)
#'
#' @param realisations \code{logical}. If \code{TRUE}, posterior realisations
#' are shown as a spaghetti plot, making it easier to visualise the diversity
#' of possible functions. If \code{FALSE}, the default, empirical quantiles
#' of the posterior distribution are shown
#'
#' @param n_realisations \code{integer} specifying the number of posterior
#' realisations to plot, if \code{realisations = TRUE}. Ignored otherwise
#'
#' @param newdata Optional \code{dataframe} for predicting the smooth,
#' containing at least 'series' in addition to any other variables included
#' in the linear predictor of the original model's \code{formula}. Note that
#' this currently is only supported for plotting univariate smooths
#'
#' @details Smooth functions are shown as empirical quantiles (or spaghetti
#' plots) of posterior partial expectations across a sequence of values
#' between the variable's \code{min} and \code{max}, while zeroing out
#' effects of all other variables. At present, only univariate and bivariate
#' smooth plots are allowed, though note that bivariate smooths rely on
#' default behaviour from \code{\link[mgcv]{plot.gam}}. `plot_mvgam_smooth`
#' generates posterior predictions from an object of class \code{mvgam},
#' calculates posterior empirical quantiles and plots them. If
#' `realisations = FALSE`, the returned plot shows 90, 60, 40 and 20 percent
#' posterior quantiles (as ribbons of increasingly darker shades of red) as
#' well as the posterior median (as a dark red line). If
#' `realisations = TRUE`, a set of `n_realisations` posterior draws are
#' shown. For more nuanced visualisation, supply \code{newdata} just as you
#' would when predicting from a \code{\link[mgcv]{gam}} model or use the more
#' flexible \code{\link{conditional_effects.mvgam}}. Alternatively, if you
#' prefer to use partial effect plots in the style of `gratia`, and if you
#' have the `gratia` package installed, you can use `draw.mvgam`. See
#' \code{\link{gratia_mvgam_enhancements}} for details.
#'
#' @return A base \code{R} graphics plot
#'
#' @seealso \code{\link[mgcv]{plot.gam}},
#' \code{\link{conditional_effects.mvgam}},
#' \code{\link{gratia_mvgam_enhancements}}
#'
#' @author Nicholas J Clark
#'
#' @export
plot_mvgam_smooth = function(
object,
trend_effects = FALSE,
series = 1,
smooth,
residuals = FALSE,
n_resid_bins = 25,
realisations = FALSE,
n_realisations = 15,
derivatives = FALSE,
newdata
) {
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
object2 <- object
if (trend_effects) {
if (is.null(object$trend_call)) {
stop(
'no trend_formula exists so there are no trend-level smooths to plot'
)
}
residuals <- FALSE
object2$mgcv_model <- object2$trend_mgcv_model
}
if (sign(series) != 1) {
stop('argument "series" must be a positive integer', call. = FALSE)
} else {
if (series %% 1 != 0) {
stop('argument "series" must be a positive integer', call. = FALSE)
}
}
if (series > NCOL(object2$ytimes)) {
stop(
paste0(
'object only contains data / predictions for ',
NCOL(object2$ytimes),
' series'
),
call. = FALSE
)
}
if (sign(n_resid_bins) != 1) {
stop('argument "n_resid_bins" must be a positive integer', call. = FALSE)
} else {
if (n_resid_bins %% 1 != 0) {
stop('argument "n_resid_bins" must be a positive integer', call. = FALSE)
}
}
if (missing(smooth)) {
smooth <- 1
}
# Get smooth term names
s_name <- levels(object2$obs_data$series)[series]
data_train <- object2$obs_data
smooth_terms <- unlist(purrr::map(object2$mgcv_model$smooth, 'label'))
if (is.character(smooth)) {
if (!grepl('\\(', smooth)) {
smooth <- paste0('s(', smooth, ')')
}
if (!smooth %in% smooth_terms) {
stop(
smooth,
' not found in smooth terms of object2\nAppropriate names are: ',
paste(smooth_terms, collapse = ', ')
)
}
smooth_int <- which(smooth_terms == smooth)
} else {
smooth_int <- smooth
}
# Check whether this type of smooth is even plottable
if (!object2$mgcv_model$smooth[[smooth_int]]$plot.me) {
stop(
paste0(
'unable to plot ',
object2$mgcv_model$smooth[[smooth_int]]$label,
' (class = ',
attr(object2$mgcv_model$smooth[[smooth_int]], 'class')[1]
),
')'
)
}
if (is.numeric(smooth)) {
if (!smooth %in% seq_along(smooth_terms)) {
stop(smooth, ' not found in smooth terms of object')
}
smooth_int <- smooth
smooth <- smooth_terms[smooth]
}
if (length(unlist(strsplit(smooth, ','))) > 3) {
stop('mvgam cannot yet plot smooths of more than 3 dimensions')
}
# Check that this is not a random effect smooth
smooth_labs <- do.call(
rbind,
lapply(seq_along(object2$mgcv_model$smooth), function(x) {
data.frame(
label = object2$mgcv_model$smooth[[x]]$label,
class = class(object2$mgcv_model$smooth[[x]])[1]
)
})
)
if (smooth_labs$class[smooth_int] == 'random.effect') {
message('use function "plot_mvgam_randomeffects" to plot "re" bases')
return(invisible)
}
# Be sure that parametric and by variables are included in newdata
smooth_terms <- unique(trimws(strsplit(
gsub('\\+', ',', as.character(object2$mgcv_model$pred.formula)[2]),
','
)[[1L]]))
# Remove comma separated names as these won't match the column names in data
smooth_terms[!grepl(',', smooth_terms)] -> smooth_terms
# Change smooth name to the covariate that needs a sequence of prediction values
smooth <- all.vars(parse(text = object2$mgcv_model$smooth[[smooth_int]]$term))
# Predictions and plots for multi-dimensional smooths
if (length(unlist(strsplit(smooth, ','))) >= 2L) {
# Use default mgcv plotting for bivariate smooths as it is quicker
object2$mgcv_model <- relabel_gps(object2$mgcv_model)
if (
inherits(object2$mgcv_model$smooth[[smooth_int]], 'tprs.smooth') |
inherits(object2$mgcv_model$smooth[[smooth_int]], 't2smooth') |
inherits(object2$mgcv_model$smooth[[smooth_int]], 'tensor.smooth')
) {
suppressWarnings(plot(
object2$mgcv_model,
select = smooth_int,
residuals = residuals,
scheme = 2,
main = '',
too.far = 0,
contour.col = 'black',
hcolors = hcl.colors(25, palette = 'Reds 2'),
lwd = 1,
seWithMean = TRUE
))
box(col = 'white')
box(bty = 'l', lwd = 2)
} else {
suppressWarnings(plot(
object2$mgcv_model,
select = smooth_int,
residuals = residuals,
scheme = 2,
main = '',
too.far = 0,
contour.col = 'black',
hcolors = hcl.colors(25, palette = 'Reds 2'),
lwd = 1,
seWithMean = TRUE,
ylab = 'Partial effect'
))
box(col = 'white')
box(bty = 'l', lwd = 2)
}
if (trend_effects) {
title(
sub(
'series',
'trend',
object2$mgcv_model$smooth[[smooth_int]]$label,
fixed = TRUE
),
adj = 0
)
} else {
title(object2$mgcv_model$smooth[[smooth_int]]$label, adj = 0)
}
} else {
# Use posterior predictions to generate univariate smooth plots
if (missing(newdata) && !inherits(data_train, 'list')) {
data_train %>%
dplyr::select(c(series, smooth_terms)) %>%
dplyr::filter(series == s_name) %>%
dplyr::mutate(series = s_name) -> pred_dat
# Use a larger sample size when estimating derivatives so they can be better approximated
if (derivatives) {
pred_dat %>%
dplyr::select(-smooth) %>%
dplyr::distinct() %>%
dplyr::slice_head(n = 1) %>%
dplyr::slice(rep(1:dplyr::n(), each = 1000)) %>%
dplyr::mutate(
smooth.var = seq(
min(pred_dat[, smooth]),
max(pred_dat[, smooth]),
length.out = 1000
)
) -> pred_dat
} else {
pred_dat %>%
dplyr::select(-smooth) %>%
dplyr::distinct() %>%
dplyr::slice_head(n = 1) %>%
dplyr::slice(rep(1:dplyr::n(), each = 500)) %>%
dplyr::mutate(
smooth.var = seq(
min(pred_dat[, smooth]),
max(pred_dat[, smooth]),
length.out = 500
)
) -> pred_dat
}
colnames(pred_dat) <- gsub('smooth.var', smooth, colnames(pred_dat))
} else if (missing(newdata) && inherits(object2$obs_data, 'list')) {
# Make fake data by zeroing all other terms apart from the selected smooth
# and the series indicator
pred_dat <- vector(mode = 'list')
for (x in 1:length(data_train)) {
if (is.matrix(data_train[[x]])) {
pred_dat[[x]] <- matrix(0, nrow = 500, ncol = NCOL(data_train[[x]]))
} else {
pred_dat[[x]] <- rep(0, 500)
}
}
names(pred_dat) <- names(object2$obs_data)
pred_dat$series <- rep((levels(data_train$series)[series]), 500)
if (!is.matrix(pred_dat[[smooth]])) {
pred_dat[[smooth]] <- seq(
min(data_train[[smooth]]),
max(data_train[[smooth]]),
length.out = 500
)
} else {
pred_dat[[smooth]] <- matrix(
seq(
min(data_train[[smooth]]),
max(data_train[[smooth]]),
length.out = length(pred_dat[[smooth]])
),
nrow = nrow(pred_dat[[smooth]]),
ncol = ncol(pred_dat[[smooth]])
)
}
if ('lag' %in% names(pred_dat)) {
pred_dat[['lag']] <- matrix(
0:(NCOL(data_train$lag) - 1),
nrow(pred_dat$lag),
NCOL(data_train$lag),
byrow = TRUE
)
}
} else {
pred_dat <- newdata
# Add series factor variable if missing
if (class(pred_dat)[1] != 'list') {
if (!'series' %in% colnames(pred_dat)) {
pred_dat$series <- factor('series1')
}
}
if (class(pred_dat)[1] == 'list') {
if (!'series' %in% names(pred_dat)) {
pred_dat$series <- factor('series1')
}
}
}
# Generate linear predictor matrix from fitted mgcv model
if (trend_effects) {
Xp <- trend_Xp_matrix(
newdata = pred_dat,
trend_map = object2$trend_map,
mgcv_model = object2$trend_mgcv_model
)
} else {
Xp <- obs_Xp_matrix(newdata = pred_dat, mgcv_model = object2$mgcv_model)
}
# Zero out all other columns in Xp
keeps <- object2$mgcv_model$smooth[[
smooth_int
]]$first.para:object2$mgcv_model$smooth[[smooth_int]]$last.para
Xp[, !seq_len(length.out = NCOL(Xp)) %in% keeps] <- 0
# Prediction x-axis values
if (class(pred_dat)[1] == 'list') {
if (is.matrix(pred_dat[[smooth]])) {
pred_vals <- as.vector(as.matrix(pred_dat[[smooth]][, 1]))
} else {
pred_vals <- as.vector(as.matrix(pred_dat[[smooth]]))
}
} else {
pred_vals <- as.vector(as.matrix(pred_dat[, smooth]))
}
# If this term has a by variable, need to use mgcv's plotting utilities
if (object2$mgcv_model$smooth[[smooth_int]]$by != "NA") {
# Check if this is a gp() term
gp_term <- FALSE
if (!is.null(attr(object2$mgcv_model, 'gp_att_table'))) {
gp_term <- object2$mgcv_model$smooth[[smooth_int]]$gp_term
}
if (gp_term) {
object2$mgcv_model$smooth[[smooth_int]]$label <-
gsub(
's\\(|ti\\(',
'gp(',
object2$mgcv_model$smooth[[smooth_int]]$label
)
# Check if this is a factor by variable
is_fac <- is.factor(object2$obs_data[[
object2$mgcv_model$smooth[[smooth_int]]$by
]])
if (is_fac) {
fac_levels <- levels(object2$obs_data[[
object2$mgcv_model$smooth[[smooth_int]]$by
]])
whichlevel <- vector()
for (i in seq_along(fac_levels)) {
whichlevel[i] <- grepl(
fac_levels[i],
object2$mgcv_model$smooth[[smooth_int]]$label,
fixed = TRUE
)
}
pred_dat[[object2$mgcv_model$smooth[[smooth_int]]$by]] <-
rep(fac_levels[whichlevel], length(pred_dat$series))
}
if (!is_fac) {
pred_dat[[object2$mgcv_model$smooth[[smooth_int]]$by]] <-
rep(1, length(pred_dat$series))
}
if (trend_effects) {
Xp_term <- trend_Xp_matrix(
newdata = pred_dat,
trend_map = object2$trend_map,
mgcv_model = object2$trend_mgcv_model
)
} else {
Xp_term <- obs_Xp_matrix(
newdata = pred_dat,
mgcv_model = object2$mgcv_model
)
}
Xp[,
object2$mgcv_model$smooth[[
smooth_int
]]$first.para:object2$mgcv_model$smooth[[smooth_int]]$last.para
] <-
Xp_term[,
object2$mgcv_model$smooth[[
smooth_int
]]$first.para:object2$mgcv_model$smooth[[smooth_int]]$last.para
]
} else {
# Deal with by variables in non-gp() smooths
by <- rep(1, length(pred_vals))
dat <- data.frame(x = pred_vals, by = by)
names(dat) <- c(
object2$mgcv_model$smooth[[smooth_int]]$term,
object2$mgcv_model$smooth[[smooth_int]]$by
)
Xp_term <- mgcv::PredictMat(
object2$mgcv_model$smooth[[smooth_int]],
dat
)
Xp[,
object2$mgcv_model$smooth[[
smooth_int
]]$first.para:object2$mgcv_model$smooth[[smooth_int]]$last.para
] <- Xp_term
}
}
# Extract GAM coefficients
if (trend_effects) {
betas <- mcmc_chains(object2$model_output, 'b_trend')
} else {
betas <- mcmc_chains(object2$model_output, 'b')
}
# Calculate posterior marginal predictions
preds <- matrix(NA, nrow = NROW(betas), ncol = NROW(Xp))
for (i in 1:NROW(betas)) {
preds[i, ] <- (Xp %*% betas[i, ])
}
if (residuals) {
# Need to predict from a reduced set that zeroes out all terms apart from the
# smooth of interest
if (trend_effects) {
Xp2 <- trend_Xp_matrix(
newdata = object2$obs_data,
trend_map = object2$trend_map,
mgcv_model = object2$trend_mgcv_model
)
} else {
Xp2 <- obs_Xp_matrix(
newdata = object2$obs_data,
mgcv_model = object2$mgcv_model
)
}
if (!missing(newdata)) {
stop('Partial residual plots not available when using newdata')
}
if (object2$mgcv_model$smooth[[smooth_int]]$by != "NA") {
by <- rep(1, length(object2$obs_data$series))
dat <- data.frame(
x = object2$obs_data[[object2$mgcv_model$smooth[[smooth_int]]$term]],
by = by
)
names(dat) <- c(
object2$mgcv_model$smooth[[smooth_int]]$term,
object2$mgcv_model$smooth[[smooth_int]]$by
)
Xp_term <- mgcv::PredictMat(
object2$mgcv_model$smooth[[smooth_int]],
dat
)
Xp2[,
object2$mgcv_model$smooth[[
smooth_int
]]$first.para:object2$mgcv_model$smooth[[smooth_int]]$last.para
] <- Xp_term
}
# Find index for the end of training for this series and keep only those training
# observations for the particular series
if (class(pred_dat)[1] == 'list') {
end_train <- length(which(
object2$obs_data[['series']] == (levels(data_train$series)[series])
))
} else {
end_train <- object2$obs_data %>%
dplyr::filter(series == s_name) %>%
NROW()
}
Xp2 <- Xp2[object2$ytimes[, series][1:end_train], ]
# # Zero out all other columns in Xp2
Xp2[, !grepl(paste0('(', smooth, ')'), colnames(Xp), fixed = T)] <- 0
# Calculate residuals from full prediction set
all_resids <- object2$resids[[series]][, 1:end_train]
partial_resids <- matrix(NA, nrow = nrow(betas), ncol = NCOL(all_resids))
for (i in 1:NROW(betas)) {
partial_resids[i, ] <- (Xp2 %*% betas[i, ]) + all_resids[i, ]
}
}
# Plot quantiles of the smooth function, along with observed values
# if specified
probs = c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
cred <- sapply(
1:NCOL(preds),
function(n) quantile(preds[, n], probs = probs, na.rm = TRUE)
)
c_light <- c("#DCBCBC")
c_light_highlight <- c("#C79999")
c_mid <- c("#B97C7C")
c_mid_highlight <- c("#A25050")
c_dark <- c("#8F2727")
c_dark_highlight <- c("#7C0000")
if (derivatives) {
.pardefault <- par(no.readonly = T)
on.exit(par(.pardefault))
par(mfrow = c(2, 1))
if (residuals) {
plot(
1,
type = "n",
bty = 'L',
xlab = smooth,
ylab = 'Partial effect',
xlim = c(min(pred_vals), max(pred_vals)),
ylim = c(
min(min(partial_resids, min(cred) - 0.4 * sd(preds), na.rm = T)),
max(max(partial_resids, max(cred) + 0.4 * sd(preds), na.rm = T))
)
)
if (object2$mgcv_model$smooth[[smooth_int]]$by != "NA") {
if (trend_effects) {
title(
sub(
'series',
'trend',
object2$mgcv_model$smooth[[smooth_int]]$label,
fixed = TRUE
),
adj = 0
)
} else {
title(object2$mgcv_model$smooth[[smooth_int]]$label, adj = 0)
}
} else {
if (trend_effects) {
title(paste0('s(', smooth, ')'), adj = 0)
} else {
title(paste0('s(', smooth, ')'), adj = 0)
}
}
} else {
plot(
1,
type = "n",
bty = 'L',
xlab = smooth,
ylab = 'Partial effect',
xlim = c(min(pred_vals), max(pred_vals)),
ylim = c(min(cred) - 0.9 * sd(preds), max(cred) + 0.9 * sd(preds))
)
if (object2$mgcv_model$smooth[[smooth_int]]$by != "NA") {
if (trend_effects) {
title(
sub(
'series',
'trend',
object2$mgcv_model$smooth[[smooth_int]]$label,
fixed = TRUE
),
adj = 0
)
} else {
title(object2$mgcv_model$smooth[[smooth_int]]$label, adj = 0)
}
} else {
if (trend_effects) {
title(paste0('s(', smooth, ')'), adj = 0)
} else {
title(paste0('s(', smooth, ')'), adj = 0)
}
}
}
if (realisations) {
for (i in 1:n_realisations) {
index <- sample(1:NROW(preds), 1, replace = TRUE)
lines(x = pred_vals, y = preds[index, ], col = 'white', lwd = 2.5)
lines(
x = pred_vals,
y = preds[index, ],
col = sample(
c("#DCBCBC", "#C79999", "#B97C7C", "#A25050", "#7C0000"),
1
),
lwd = 2.25
)
}
} else {
if (residuals) {
# Get x-axis values and bin if necessary to prevent overplotting
sorted_x <- sort(unique(round(object2$obs_data[[smooth]], 6)))
s_name <- levels(object2$obs_data$series)[series]
obs_x <- round(
data.frame(
series = object2$obs_data$series,
smooth_vals = object2$obs_data[[smooth]]
) %>%
dplyr::filter(series == s_name) %>%
dplyr::pull(smooth_vals),
6
)
if (length(sorted_x) > n_resid_bins) {
sorted_x <- seq(
min(sorted_x),
max(sorted_x),
length.out = n_resid_bins
)
resid_probs <- do.call(
rbind,
lapply(2:n_resid_bins, function(i) {
quantile(
as.vector(partial_resids[, which(
obs_x <= sorted_x[i] &
obs_x > sorted_x[i - 1]
)]),
probs = probs,
na.rm = TRUE
)
})
)
resid_probs <- rbind(
quantile(
as.vector(partial_resids[, which(obs_x == sorted_x[1])]),
probs = probs,
na.rm = TRUE
),
resid_probs
)
} else {
resid_probs <- do.call(
rbind,
lapply(sorted_x, function(i) {
quantile(
as.vector(partial_resids[, which(obs_x == i)]),
probs = probs,
na.rm = TRUE
)
})
)
}
# Get polygon coordinates and plot
N <- length(sorted_x)
idx <- rep(1:N, each = 2)
repped_x <- rep(sorted_x, each = 2)
x <- sapply(
1:length(idx),
function(k) {
if (k %% 2 == 0) {
repped_x[k] + min(diff(sorted_x)) / 2
} else {
repped_x[k] - min(diff(sorted_x)) / 2
}
}
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = resid_probs[, 9],
ybottom = resid_probs[, 1],
col = c_light,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = resid_probs[, 8],
ybottom = resid_probs[, 2],
col = c_light_highlight,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = resid_probs[, 7],
ybottom = resid_probs[, 3],
col = c_mid,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = resid_probs[, 6],
ybottom = resid_probs[, 4],
col = c_mid_highlight,
border = 'transparent'
)
for (k in 1:N) {
lines(
x = c(x[seq(1, N * 2, by = 2)][k], x[seq(2, N * 2, by = 2)][k]),
y = c(resid_probs[k, 5], resid_probs[k, 5]),
col = c_dark,
lwd = 2
)
}
# Overlay a minimalist version of the estimated smooth function
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[1, ], rev(cred[9, ])),
col = rgb(
red = 0,
green = 0,
blue = 0,
alpha = 30,
maxColorValue = 200
),
border = NA
)
lines(
pred_vals,
cred[5, ],
col = rgb(
red = 0,
green = 0,
blue = 0,
alpha = 45,
maxColorValue = 200
),
lwd = 3
)
box(bty = 'L', lwd = 2)
} else {
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[1, ], rev(cred[9, ])),
col = c_light,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[2, ], rev(cred[8, ])),
col = c_light_highlight,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[3, ], rev(cred[7, ])),
col = c_mid,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[4, ], rev(cred[6, ])),
col = c_mid_highlight,
border = NA
)
lines(pred_vals, cred[5, ], col = c_dark, lwd = 2.5)
}
}
box(bty = 'L', lwd = 2)
# Show observed values of the smooth as a rug
if (class(object2$obs_data)[1] == 'list') {
rug(
(as.vector(as.matrix(pred_dat[[smooth]])))[which(
pred_dat[['series']] == levels(pred_dat[['series']])[series]
)],
lwd = 1.75,
ticksize = 0.025,
col = c_mid_highlight
)
} else {
rug(
(as.vector(as.matrix(data_train[, smooth])))[which(
data_train$series == levels(data_train$series)[series]
)],
lwd = 1.75,
ticksize = 0.025,
col = c_mid_highlight
)
}
# Compute 1st derivatives
first_derivs <- cbind(rep(NA, NROW(preds)), t(apply(preds, 1, diff)))
cred <- sapply(
1:NCOL(first_derivs),
function(n) quantile(first_derivs[, n], probs = probs, na.rm = T)
)
plot(
1,
type = "n",
bty = 'L',
xlab = smooth,
ylab = '1st derivative',
xlim = c(min(pred_vals), max(pred_vals)),
ylim = c(
min(cred, na.rm = T) - sd(first_derivs, na.rm = T),
max(cred, na.rm = T) + sd(first_derivs, na.rm = T)
)
)
if (realisations) {
for (i in 1:n_realisations) {
index <- sample(1:NROW(first_derivs), 1, replace = TRUE)
lines(
x = pred_vals,
y = first_derivs[index, ],
col = 'white',
lwd = 2.5
)
lines(
x = pred_vals,
y = first_derivs[index, ],
col = sample(
c("#DCBCBC", "#C79999", "#B97C7C", "#A25050", "#7C0000"),
1
),
lwd = 2.25
)
}
} else {
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[1, ], rev(cred[9, ])),
col = c_light,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[2, ], rev(cred[8, ])),
col = c_light_highlight,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[3, ], rev(cred[7, ])),
col = c_mid,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[4, ], rev(cred[6, ])),
col = c_mid_highlight,
border = NA
)
lines(pred_vals, cred[5, ], col = c_dark, lwd = 2.5)
}
box(bty = 'L', lwd = 2)
abline(h = 0, lty = 'dashed', lwd = 2)
invisible()
} else {
if (residuals) {
plot(
1,
type = "n",
bty = 'L',
xlab = smooth,
ylab = 'Partial effect',
xlim = c(min(pred_vals), max(pred_vals)),
ylim = c(
min(min(partial_resids, min(cred) - 0.4 * sd(preds), na.rm = T)),
max(max(partial_resids, max(cred) + 0.4 * sd(preds), na.rm = T))
)
)
if (object2$mgcv_model$smooth[[smooth_int]]$by != "NA") {
if (trend_effects) {
title(
sub(
'series',
'trend',
object2$mgcv_model$smooth[[smooth_int]]$label,
fixed = TRUE
),
adj = 0
)
} else {
title(object2$mgcv_model$smooth[[smooth_int]]$label, adj = 0)
}
} else {
if (trend_effects) {
title(paste0('s(', smooth, ')'), adj = 0)
} else {
title(paste0('s(', smooth, ')'), adj = 0)
}
}
# Get x-axis values and bin if necessary to prevent overplotting
sorted_x <- sort(unique(round(object2$obs_data[[smooth]], 6)))
s_name <- levels(object2$obs_data$series)[series]
obs_x <- round(
data.frame(
series = object2$obs_data$series,
smooth_vals = object2$obs_data[[smooth]]
) %>%
dplyr::filter(series == s_name) %>%
dplyr::pull(smooth_vals),
6
)
if (length(sorted_x) > n_resid_bins) {
sorted_x <- seq(
min(sorted_x),
max(sorted_x),
length.out = n_resid_bins
)
resid_probs <- do.call(
rbind,
lapply(2:n_resid_bins, function(i) {
quantile(
as.vector(partial_resids[, which(
obs_x <= sorted_x[i] &
obs_x > sorted_x[i - 1]
)]),
probs = probs,
na.rm = TRUE
)
})
)
resid_probs <- rbind(
quantile(
as.vector(partial_resids[, which(obs_x == sorted_x[1])]),
probs = probs,
na.rm = TRUE
),
resid_probs
)
} else {
resid_probs <- do.call(
rbind,
lapply(sorted_x, function(i) {
quantile(
as.vector(partial_resids[, which(obs_x == i)]),
probs = probs,
na.rm = TRUE
)
})
)
}
# Get polygon coordinates and plot
N <- length(sorted_x)
idx <- rep(1:N, each = 2)
repped_x <- rep(sorted_x, each = 2)
x <- sapply(
1:length(idx),
function(k) {
if (k %% 2 == 0) {
repped_x[k] + min(diff(sorted_x)) / 2
} else {
repped_x[k] - min(diff(sorted_x)) / 2
}
}
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = resid_probs[, 9],
ybottom = resid_probs[, 1],
col = c_light,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = resid_probs[, 8],
ybottom = resid_probs[, 2],
col = c_light_highlight,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = resid_probs[, 7],
ybottom = resid_probs[, 3],
col = c_mid,
border = 'transparent'
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = resid_probs[, 6],
ybottom = resid_probs[, 4],
col = c_mid_highlight,
border = 'transparent'
)
for (k in 1:N) {
lines(
x = c(x[seq(1, N * 2, by = 2)][k], x[seq(2, N * 2, by = 2)][k]),
y = c(resid_probs[k, 5], resid_probs[k, 5]),
col = c_dark,
lwd = 2
)
}
# Overlay a minimalist version of the estimated smooth function
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[1, ], rev(cred[9, ])),
col = rgb(
red = 0,
green = 0,
blue = 0,
alpha = 30,
maxColorValue = 200
),
border = NA
)
lines(
pred_vals,
cred[5, ],
col = rgb(
red = 0,
green = 0,
blue = 0,
alpha = 45,
maxColorValue = 200
),
lwd = 3
)
box(bty = 'L', lwd = 2)
} else {
plot(
1,
type = "n",
bty = 'L',
xlab = smooth,
ylab = 'Partial effect',
xlim = c(min(pred_vals), max(pred_vals)),
ylim = c(min(cred) - 0.9 * sd(preds), max(cred) + 0.9 * sd(preds))
)
if (object2$mgcv_model$smooth[[smooth_int]]$by != "NA") {
if (trend_effects) {
title(
sub(
'series',
'trend',
object2$mgcv_model$smooth[[smooth_int]]$label,
fixed = TRUE
),
adj = 0
)
} else {
title(object2$mgcv_model$smooth[[smooth_int]]$label, adj = 0)
}
} else {
if (trend_effects) {
title(paste0('s(', smooth, ')'), adj = 0)
} else {
title(paste0('s(', smooth, ')'), adj = 0)
}
}
if (realisations) {
for (i in 1:n_realisations) {
index <- sample(1:NROW(preds), 1, replace = TRUE)
lines(x = pred_vals, y = preds[index, ], col = 'white', lwd = 2.5)
lines(
x = pred_vals,
y = preds[index, ],
col = sample(
c("#DCBCBC", "#C79999", "#B97C7C", "#A25050", "#7C0000"),
1
),
lwd = 2.25
)
}
} else {
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[1, ], rev(cred[9, ])),
col = c_light,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[2, ], rev(cred[8, ])),
col = c_light_highlight,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[3, ], rev(cred[7, ])),
col = c_mid,
border = NA
)
polygon(
c(pred_vals, rev(pred_vals)),
c(cred[4, ], rev(cred[6, ])),
col = c_mid_highlight,
border = NA
)
lines(pred_vals, cred[5, ], col = c_dark, lwd = 2.5)
}
box(bty = 'L', lwd = 2)
}
# Show observed values of the smooth as a rug
if (class(object2$obs_data)[1] == 'list') {
rug(
(as.vector(as.matrix(data_train[[smooth]])))[which(
data_train$series == levels(data_train$series)[series]
)],
lwd = 1.75,
ticksize = 0.025,
col = c_mid_highlight
)
} else {
rug(
(as.vector(as.matrix(data_train[, smooth])))[which(
data_train$series == levels(data_train$series)[series]
)],
lwd = 1.75,
ticksize = 0.025,
col = c_mid_highlight
)
}
}
}
}
================================================
FILE: R/plot_mvgam_trend.R
================================================
#' Plot latent trend predictions from \pkg{mvgam} models
#'
#' @importFrom graphics par lines polygon box abline
#'
#' @importFrom stats sd quantile
#'
#' @param object \code{list} object returned from \code{mvgam}. See [mvgam()]
#'
#' @param series \code{integer} specifying which series in the set is to be
#' plotted
#'
#' @param newdata Optional \code{dataframe} or \code{list} of test data
#' containing at least 'series' and 'time' in addition to any other
#' variables included in the linear predictor of the original \code{formula}.
#'
#' @param data_test Deprecated. Still works in place of \code{newdata} but
#' users are recommended to use \code{newdata} instead for more seamless
#' integration into `R` workflows
#'
#' @param derivatives \code{logical}. If \code{TRUE}, an additional plot will
#' be returned to show the estimated 1st derivative for the estimated trend
#'
#' @param realisations \code{logical}. If \code{TRUE}, posterior trend
#' realisations are shown as a spaghetti plot, making it easier to visualise
#' the diversity of possible trend paths. If \code{FALSE}, the default,
#' empirical quantiles of the posterior distribution are shown
#'
#' @param n_realisations \code{integer} specifying the number of posterior
#' realisations to plot, if \code{realisations = TRUE}. Ignored otherwise
#'
#' @param n_cores Deprecated. Parallel processing is no longer supported
#'
#' @param xlab Label for x axis
#'
#' @param ylab Label for y axis
#'
#' @return A `ggplot` object
#'
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam(
#' n_series = 3,
#' trend_model = AR()
#' )
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2
#' )
#'
#' # Plot estimated trends for some series
#' plot_mvgam_trend(mod)
#' plot_mvgam_trend(mod, series = 2)
#'
#' # Extrapolate trends forward in time and plot on response scale
#' plot_mvgam_trend(
#' mod,
#' newdata = simdat$data_test
#' )
#'
#' plot_mvgam_trend(
#' mod,
#' newdata = simdat$data_test,
#' series = 2
#' )
#'
#' # But it is recommended to compute extrapolations for all series
#' # first and then plot
#' trend_fc <- forecast(
#' mod,
#' newdata = simdat$data_test
#' )
#'
#' plot(trend_fc, series = 1)
#' plot(trend_fc, series = 2)
#' }
#'
#' @author Nicholas J Clark
#'
#' @export
plot_mvgam_trend = function(
object,
series = 1,
newdata,
data_test,
realisations = FALSE,
n_realisations = 15,
n_cores = 1,
derivatives = FALSE,
xlab,
ylab
) {
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
validate_pos_integer(series)
if (series > NCOL(object$ytimes)) {
stop(
paste0(
'object only contains data / predictions for ',
NCOL(object$ytimes),
' series'
),
call. = FALSE
)
}
if (
attr(object$model_data, 'trend_model') == 'None' &
!object$use_lv
) {
stop('no trend was estimated in object', call. = FALSE)
}
if (!missing("newdata")) {
data_test <- newdata
}
# Prediction indices for the particular series
data_train <- object$obs_data
ends <- seq(
0,
dim(mcmc_chains(object$model_output, 'trend'))[2],
length.out = NCOL(object$ytimes) + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, (NCOL(object$ytimes) + 1))])
ends <- ends[-1]
if (object$fit_engine == 'stan') {
preds <- mcmc_chains(object$model_output, 'trend')[, seq(
series,
dim(mcmc_chains(object$model_output, 'trend'))[2],
by = NCOL(object$ytimes)
)]
} else {
preds <- mcmc_chains(object$model_output, 'trend')[,
starts[series]:ends[series]
]
}
# If the posterior predictions do not already cover the data_test period, the forecast needs to be
# generated using the latent trend dynamics; note, this assumes that there is no gap between the training and
# testing datasets
# Add variables to data_test if missing
s_name <- levels(data_train$series)[series]
if (!missing(data_test)) {
if (!'y' %in% names(data_test)) {
data_test$y <- rep(NA, NROW(data_test))
}
if (!'series' %in% names(data_test)) {
data_test$series <- factor('series1')
}
if (!'time' %in% names(data_test)) {
stop('data_test does not contain a "time" column')
}
if (inherits(data_test, 'list')) {
all_obs <- c(
data.frame(
y = data_train$y,
series = data_train$series,
time = data_train$time
) %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y),
data.frame(
y = data_test$y,
series = data_test$series,
time = data_test$time
) %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
)
} else {
all_obs <- c(
data_train %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y),
data_test %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
)
}
if (dim(preds)[2] != length(all_obs)) {
fc_preds <- forecast(
object,
data_test = data_test,
type = 'trend',
n_cores = n_cores
)$forecasts[[series]]
preds <- cbind(preds, fc_preds)
}
}
preds_last <- preds[1, ]
pred_vals <- seq(1:length(preds_last))
# Plot quantiles of the smooth function, along with observed values
# if specified
probs <- c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
cred <- sapply(1:NCOL(preds), function(n) {
quantile(preds[, n], probs = probs, na.rm = TRUE)
})
if (missing(xlab)) {
xlab <- 'Time'
}
if (missing(ylab)) {
ylab <- paste0('Estimated trend for ', levels(data_train$series)[series])
}
# Create a base plot using posterior credible intervals and observations
# for the specified series
plot_dat <- data.frame(
time = 1:NCOL(cred),
med = cred[5, ],
lower1 = cred[1, ],
lower2 = cred[2, ],
lower3 = cred[3, ],
lower4 = cred[4, ],
upper1 = cred[9, ],
upper2 = cred[8, ],
upper3 = cred[7, ],
upper4 = cred[6, ]
)
base_plot <- ggplot2::ggplot(
data = plot_dat,
mapping = ggplot2::aes(x = time, y = med)
) +
ggplot2::theme_classic() +
ggplot2::labs(x = xlab, y = ylab)
# Add to the base plot accordingly
if (realisations) {
for (i in 1:n_realisations) {
base_plot <- base_plot +
ggplot2::geom_line(
data = data.frame(
y = preds[i, ],
time = 1:NCOL(cred)
),
mapping = ggplot2::aes(x = time, y = y),
col = "white",
linewidth = 1
) +
ggplot2::geom_line(
data = data.frame(
y = preds[i, ],
time = 1:NCOL(cred)
),
mapping = ggplot2::aes(x = time, y = y),
col = sample(
c("#DCBCBC", "#C79999", "#B97C7C", "#A25050", "#7C0000"),
1
),
linewidth = 0.75
)
}
} else {
base_plot <- base_plot +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower1, ymax = upper1),
fill = "#DCBCBC"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower2, ymax = upper2),
fill = "#C79999"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower3, ymax = upper3),
fill = "#B97C7C"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower4, ymax = upper4),
fill = "#A25050"
) +
ggplot2::geom_line(
mapping = ggplot2::aes(x = time, y = med),
col = "#8F2727",
linewidth = 1
)
}
if (!missing(data_test)) {
if (class(data_train)[1] == 'list') {
base_plot <- base_plot +
ggplot2::geom_vline(
xintercept = length(data_train$y) / NCOL(object$ytimes),
linetype = 'dashed'
)
} else {
base_plot <- base_plot +
ggplot2::geom_vline(
xintercept = NROW(data_train) / NCOL(object$ytimes),
linetype = 'dashed'
)
}
}
# Add the 1st derivative plot if necessary
if (derivatives) {
first_derivs <- cbind(rep(0, NROW(preds)), t(apply(preds, 1, diff)))
cred <- sapply(
1:NCOL(first_derivs),
function(n) quantile(first_derivs[, n], probs = probs, na.rm = TRUE)
)
plot_dat <- data.frame(
time = 1:NCOL(cred),
med = cred[5, ],
lower1 = cred[1, ],
lower2 = cred[2, ],
lower3 = cred[3, ],
lower4 = cred[4, ],
upper1 = cred[9, ],
upper2 = cred[8, ],
upper3 = cred[7, ],
upper4 = cred[6, ]
)
deriv_plot <- ggplot2::ggplot(
data = plot_dat,
mapping = ggplot2::aes(x = time, y = med)
) +
ggplot2::theme_classic() +
ggplot2::labs(x = xlab, y = '1st derivative')
# Add to the base plot accordingly
if (realisations) {
for (i in 1:n_realisations) {
deriv_plot <- deriv_plot +
ggplot2::geom_line(
data = data.frame(
y = first_derivs[i, ],
time = 1:NCOL(cred)
),
mapping = ggplot2::aes(x = time, y = y),
col = "white",
linewidth = 1
) +
ggplot2::geom_line(
data = data.frame(
y = first_derivs[i, ],
time = 1:NCOL(cred)
),
mapping = ggplot2::aes(x = time, y = y),
col = sample(
c("#DCBCBC", "#C79999", "#B97C7C", "#A25050", "#7C0000"),
1
),
linewidth = 0.75
)
}
} else {
deriv_plot <- deriv_plot +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower1, ymax = upper1),
fill = "#DCBCBC"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower2, ymax = upper2),
fill = "#C79999"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower3, ymax = upper3),
fill = "#B97C7C"
) +
ggplot2::geom_ribbon(
mapping = ggplot2::aes(ymin = lower4, ymax = upper4),
fill = "#A25050"
) +
ggplot2::geom_line(
mapping = ggplot2::aes(x = time, y = med),
col = "#8F2727",
linewidth = 1
)
}
if (!missing(data_test)) {
if (class(data_train)[1] == 'list') {
deriv_plot <- deriv_plot +
ggplot2::geom_vline(
xintercept = length(data_train$y) / NCOL(object$ytimes),
linetype = 'dashed'
)
} else {
deriv_plot <- deriv_plot +
ggplot2::geom_vline(
xintercept = NROW(data_train) / NCOL(object$ytimes),
linetype = 'dashed'
)
}
}
out <- patchwork::wrap_plots(base_plot, deriv_plot, ncol = 1)
} else {
out <- base_plot
}
return(out)
}
================================================
FILE: R/plot_mvgam_uncertainty.R
================================================
#' Plot forecast uncertainty contributions from \pkg{mvgam} models
#'
#' @importFrom graphics legend
#' @importFrom stats predict
#'
#' @param object \code{list} object returned from \code{mvgam}. See [mvgam()]
#'
#' @param series \code{integer} specifying which series in the set is to be
#' plotted
#'
#' @param newdata A \code{dataframe} or \code{list} containing at least 'series'
#' and 'time' for the forecast horizon, in addition to any other variables
#' included in the linear predictor of \code{formula}
#'
#' @param data_test Deprecated. Still works in place of \code{newdata} but users
#' are recommended to use \code{newdata} instead for more seamless integration
#' into `R` workflows
#'
#' @param legend_position The location may also be specified by setting x to a
#' single keyword from the list: "none", "bottomright", "bottom", "bottomleft",
#' "left", "topleft", "top", "topright", "right" and "center". This places the
#' legend on the inside of the plot frame at the given location (if it is not
#' "none").
#'
#' @param hide_xlabels \code{logical}. If \code{TRUE}, no xlabels are printed to
#' allow the user to add custom labels using \code{axis} from base \code{R}
#'
#' @details The basic idea of this function is to compute forecasts by ignoring
#' one of the two primary components in a correlated residual model (i.e. by
#' either ignoring the linear predictor effects or by ignoring the residual
#' dynamics). Some caution is required however, as this function was designed
#' early in the \pkg{mvgam} development cycle and there are now many types of
#' models that it cannot handle very well. For example, models with shared
#' latent states, or any type of State-Space models that include terms in the
#' `trend_formula`, will either fail or give nonsensical results. Improvements
#' are in the works to provide a more general way to decompose forecast
#' uncertainties, so please check back at a later date.
#'
#' @return A base \code{R} graphics plot
#'
#' @export
plot_mvgam_uncertainty = function(
object,
series = 1,
newdata,
data_test,
legend_position = 'topleft',
hide_xlabels = FALSE
) {
# Check arguments
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
if (!is.null(object$trend_call)) {
stop(
'cannot yet plot uncertainty decompositions for models with trend_formulae',
call. = FALSE
)
}
if (sign(series) != 1) {
stop('argument "series" must be a positive integer', call. = FALSE)
} else {
if (series %% 1 != 0) {
stop('argument "series" must be a positive integer', call. = FALSE)
}
}
if (series > NCOL(object$ytimes)) {
stop(
paste0(
'object only contains data / predictions for ',
NCOL(object$ytimes),
' series'
),
call. = FALSE
)
}
if (!missing(newdata)) {
data_test <- newdata
}
if (missing(data_test) & missing(newdata)) {
if (!is.null(object$test_data)) {
data_test <- object$test_data
} else {
stop(
'No newdata supplied; cannot calculate uncertainty contributions',
call. = FALSE
)
}
}
# Prediction indices for the particular series
data_train <- object$obs_data
ends <- seq(
0,
dim(mcmc_chains(object$model_output, 'ypred'))[2],
length.out = NCOL(object$ytimes) + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, (NCOL(object$ytimes) + 1))])
ends <- ends[-1]
# Add series factor variable if missing
if (class(data_train)[1] != 'list') {
if (!'series' %in% colnames(data_test)) {
data_test$series <- factor('series1')
}
}
if (class(data_train)[1] == 'list') {
if (!'series' %in% names(data_test)) {
data_test$series <- factor('series1')
}
}
# Generate linear predictor matrix for specified series
if (class(data_test)[1] == 'list') {
list_names <- names(data_test)
indices_keep <- which(data_test$series == levels(data_train$series)[series])
series_test <- lapply(data_test, function(x) {
if (is.matrix(x)) {
matrix(x[indices_keep, ], ncol = NCOL(x))
} else {
x[indices_keep]
}
})
names(series_test) <- list_names
} else {
series_test <- data_test[
which(data_test$series == levels(data_train$series)[series]),
]
}
Xp <- obs_Xp_matrix(newdata = series_test, object$mgcv_model)
# Extract beta coefs
betas <- mcmc_chains(object$model_output, 'b')
# Extract current trend estimates
if (object$fit_engine == 'stan') {
trend <- mcmc_chains(object$model_output, 'trend')[, seq(
series,
dim(mcmc_chains(object$model_output, 'trend'))[2],
by = NCOL(object$ytimes)
)]
} else {
trend <- mcmc_chains(object$model_output, 'trend')[,
starts[series]:ends[series]
]
}
if (length(unique(data_train$series)) == 1) {
trend <- matrix(trend[, NCOL(trend)])
} else {
if (class(data_test)[1] == 'list') {
trend <- trend[,
(length(data_train$series) / NCOL(object$ytimes) + 1):NCOL(trend)
]
} else {
trend <- trend[, (NROW(data_train) / NCOL(object$ytimes) + 1):NCOL(trend)]
}
}
# Function to calculate intersection of two uncertainty distributions
intersect_hist = function(fullpreds, gampreds) {
from <- min(min(fullpreds, na.rm = T), min(gampreds, na.rm = T))
to <- max(max(fullpreds, na.rm = T), max(gampreds, na.rm = T))
fullhist <- hist(
fullpreds,
breaks = seq(from, to, length.out = 100),
plot = F
)
gamhist <- hist(
gampreds,
breaks = seq(from, to, length.out = 100),
plot = F
)
sum(gamhist$density / max(gamhist$density)) /
sum(fullhist$density / max(fullhist$density))
}
# Full predictions
n_samples <- NROW(trend)
if (class(data_test)[1] == 'list') {
ncols <- length(series_test$series)
} else {
ncols <- NROW(series_test)
}
fullpreds <- matrix(NA, nrow = n_samples, ncol = ncols)
for (i in 1:n_samples) {
fullpreds[i, ] <- Xp %*% betas[i, ] + trend[i, ] + attr(Xp, 'model.offset')
}
# GAM only predictions
gampreds <- matrix(NA, nrow = n_samples, ncol = ncols)
for (i in 1:n_samples) {
gampreds[i, ] <- Xp %*% betas[i, ] + attr(Xp, 'model.offset')
}
# GAM uncertainty contributions at each forecast horizon
gam_cont <- vector()
for (i in 1:NCOL(fullpreds)) {
gam_cont[i] <- intersect_hist(fullpreds[, i], gampreds[, i])
}
gam_cont[is.na(gam_cont)] <- 0.5
gam_cont[gam_cont > 1] <- 1
# Plot and return
if (hide_xlabels) {
plot(
gam_cont,
bty = "L",
ylim = c(0, 1),
type = 'n',
ylab = paste0(
'Uncertainty contributions for ',
levels(data_train$series)[series]
),
xlab = "",
xaxt = 'n'
)
} else {
plot(
gam_cont,
bty = 'L',
ylim = c(0, 1),
type = 'n',
ylab = paste0(
'Uncertainty contributions for ',
levels(data_train$series)[series]
),
xlab = "Forecast horizon"
)
}
polygon(
c(seq(1:(NCOL(gampreds))), rev(seq(1:NCOL(gampreds)))),
c(gam_cont, rep(0, NCOL(gampreds))),
col = "#7C0000",
border = NA
)
polygon(
c(seq(1:(NCOL(gampreds))), rev(seq(1:NCOL(gampreds)))),
c(gam_cont, rep(1, NCOL(gampreds))),
col = '#DCBCBC',
border = NA
)
box(bty = 'L', lwd = 2)
if (legend_position != 'none') {
legend(
legend_position,
legend = c("Trend", "GAM"),
bg = 'white',
col = c('#DCBCBC', "#7C0000"),
lty = 1,
lwd = 6
)
}
}
================================================
FILE: R/portal_data.R
================================================
#' Portal Project rodent capture survey data
#'
#' A dataset containing time series of total captures (across all control plots) for select rodent species from the Portal Project
#'
#' @format A `data.frame` containing the following fields:
#' \describe{
#' \item{time}{time of sampling, in lunar monthly cycles}
#' \item{series}{factor indicator of the time series, i.e. the species}
#' \item{captures}{total captures across all control plots at each time point}
#' \item{ndvi_ma12}{12-month moving average of the mean Normalised Difference Vegetation Index}
#' \item{mintemp}{monthly mean of minimum temperature}
#' }
#' @source \url{https://github.com/weecology/PortalData/blob/main/SiteandMethods/Methods.md}
"portal_data"
================================================
FILE: R/posterior_epred.mvgam.R
================================================
#' Draws from the expected value of the posterior predictive distribution for \pkg{mvgam} objects
#'
#' Compute posterior draws of the expected value of the posterior predictive
#' distribution (i.e. the conditional expectation). 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.mvgam}} method.
#' This is because only the uncertainty in the expected value of the posterior
#' predictive distribution is incorporated in the draws computed by
#' \code{posterior_epred} while the residual error is ignored there. However,
#' the estimated means of both methods averaged across draws should be very
#' similar.
#'
#' @inheritParams predict.mvgam
#'
#' @param ndraws Positive \code{integer} indicating how many posterior draws
#' should be used. If \code{NULL} (the default) all draws are used.
#'
#' @param process_error \code{logical}. If \code{TRUE} and \code{newdata} is
#' supplied, expected uncertainty in the process model is accounted for by
#' using draws from any latent trend SD parameters. If \code{FALSE},
#' uncertainty in the latent trend component is ignored when calculating
#' predictions. If no \code{newdata} is supplied, draws from the fitted
#' model's posterior predictive distribution will be used (which will always
#' include uncertainty in any latent trend components)
#'
#' @method posterior_epred mvgam
#'
#' @details Note that for all types of predictions for models that did not
#' include a `trend_formula`, uncertainty in the dynamic trend component can
#' be ignored by setting \code{process_error = FALSE}. However, if a
#' `trend_formula` was supplied in the model, predictions for this component
#' cannot be ignored. If \code{process_error = TRUE}, trend predictions will
#' ignore autocorrelation coefficients or GP length scale coefficients,
#' ultimately assuming the process is stationary. This method is similar to
#' the types of posterior predictions returned from `brms` models when using
#' autocorrelated error predictions for newdata. This function is therefore
#' more suited to posterior simulation from the GAM components of a
#' \code{mvgam} model, while the forecasting functions
#' \code{\link{plot_mvgam_fc}} and \code{\link{forecast.mvgam}} are better
#' suited to generate h-step ahead forecasts that respect the temporal
#' dynamics of estimated latent trends.
#'
#' @return A \code{matrix} of dimension \code{n_samples x n_obs}, where
#' \code{n_samples} is the number of posterior samples from the fitted object
#' and \code{n_obs} is the number of observations in \code{newdata}
#'
#' @seealso \code{\link{hindcast.mvgam}},
#' \code{\link{posterior_linpred.mvgam}},
#' \code{\link{posterior_predict.mvgam}}
#'
#' @examples
#' \dontrun{
#' # Simulate some data and fit a model
#' simdat <- sim_mvgam(
#' n_series = 1,
#' trend_model = AR()
#' )
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc'),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Compute posterior expectations
#' expectations <- posterior_epred(mod)
#' str(expectations)
#' }
#'
#' @author Nicholas J Clark
#'
#' @export
posterior_epred.mvgam = function(
object,
newdata,
data_test,
ndraws = NULL,
process_error = TRUE,
...
) {
if (missing(newdata) & missing(data_test)) {
out <- .mvgam_fitted(object, type = 'expected')
} else {
out <- predict(
object,
newdata = newdata,
data_test = data_test,
process_error = process_error,
type = 'expected',
summary = FALSE
)
}
if (!is.null(ndraws)) {
validate_pos_integer(ndraws)
if (ndraws > NROW(out)) {} else {
idx <- sample(1:NROW(out), ndraws, replace = FALSE)
out <- out[idx, ]
}
}
return(out)
}
#' Posterior draws of the linear predictor for \pkg{mvgam} objects
#'
#' 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.mvgam
#'
#' @param transform \code{logical}; if \code{FALSE} (the default), draws of
#' the linear predictor are returned. If \code{TRUE}, draws of the
#' transformed linear predictor, i.e. the conditional expectation, are
#' returned.
#'
#' @method posterior_linpred mvgam
#'
#' @details Note that for all types of predictions for models that did not
#' include a `trend_formula`, uncertainty in the dynamic trend component can
#' be ignored by setting \code{process_error = FALSE}. However, if a
#' `trend_formula` was supplied in the model, predictions for this component
#' cannot be ignored. If \code{process_error = TRUE}, trend predictions will
#' ignore autocorrelation coefficients or GP length scale coefficients,
#' ultimately assuming the process is stationary. This method is similar to
#' the types of posterior predictions returned from `brms` models when using
#' autocorrelated error predictions for newdata. This function is therefore
#' more suited to posterior simulation from the GAM components of a
#' \code{mvgam} model, while the forecasting functions
#' \code{\link{plot_mvgam_fc}} and \code{\link{forecast.mvgam}} are better
#' suited to generate h-step ahead forecasts that respect the temporal
#' dynamics of estimated latent trends.
#'
#' @return A \code{matrix} of dimension \code{n_samples x n_obs}, where
#' \code{n_samples} is the number of posterior samples from the fitted object
#' and \code{n_obs} is the number of observations in \code{newdata}
#'
#' @seealso \code{\link{hindcast.mvgam}},
#' \code{\link{posterior_epred.mvgam}},
#' \code{\link{posterior_predict.mvgam}}
#'
#' @examples
#' \dontrun{
#' # Simulate some data and fit a model
#' simdat <- sim_mvgam(
#' n_series = 1,
#' trend_model = AR()
#' )
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc'),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract linear predictor values
#' linpreds <- posterior_linpred(mod)
#' str(linpreds)
#' }
#'
#' @author Nicholas J Clark
#'
#' @export
posterior_linpred.mvgam = function(
object,
transform = FALSE,
newdata,
ndraws = NULL,
data_test,
process_error = TRUE,
...
) {
if (transform) {
type <- 'expected'
} else {
type <- 'link'
}
out <- predict(
object,
newdata = newdata,
data_test = data_test,
process_error = process_error,
type = type,
summary = FALSE
)
if (!is.null(ndraws)) {
validate_pos_integer(ndraws)
if (ndraws > NROW(out)) {} else {
idx <- sample(1:NROW(out), ndraws, replace = FALSE)
out <- out[idx, ]
}
}
return(out)
}
#' Draws from the posterior predictive distribution for \pkg{mvgam} objects
#'
#' 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 expected value of the posterior predictive distribution computed by
#' \code{\link{posterior_epred.mvgam}}. 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 predict.mvgam
#'
#' @inheritParams posterior_epred.mvgam
#'
#' @param process_error Logical. If \code{TRUE} and \code{newdata} is supplied,
#' expected uncertainty in the process model is accounted for by using draws
#' from any latent trend SD parameters. If \code{FALSE}, uncertainty in the
#' latent trend component is ignored when calculating predictions. If no
#' \code{newdata} is supplied, draws from the fitted model's posterior
#' predictive distribution will be used (which will always include uncertainty
#' in any latent trend components)
#'
#' @method posterior_predict mvgam
#'
#' @details Note that for all types of predictions for models that did not
#' include a `trend_formula`, uncertainty in the dynamic trend component can
#' be ignored by setting \code{process_error = FALSE}. However, if a
#' `trend_formula` was supplied in the model, predictions for this component
#' cannot be ignored. If \code{process_error = TRUE}, trend predictions will
#' ignore autocorrelation coefficients or GP length scale coefficients,
#' ultimately assuming the process is stationary. This method is similar to
#' the types of posterior predictions returned from `brms` models when using
#' autocorrelated error predictions for newdata. This function is therefore
#' more suited to posterior simulation from the GAM components of a
#' \code{mvgam} model, while the forecasting functions
#' \code{\link{plot_mvgam_fc}} and \code{\link{forecast.mvgam}} are better
#' suited to generate h-step ahead forecasts that respect the temporal
#' dynamics of estimated latent trends.
#'
#' @return A \code{matrix} of dimension \code{n_samples x new_obs}, where
#' \code{n_samples} is the number of posterior samples from the fitted object
#' and \code{n_obs} is the number of observations in \code{newdata}
#'
#' @seealso
#' \code{\link{hindcast.mvgam}},
#' \code{\link{posterior_linpred.mvgam}},
#' \code{\link{posterior_epred.mvgam}}
#'
#' @examples
#' \dontrun{
#' # Simulate some data and fit a model
#' simdat <- sim_mvgam(n_series = 1, trend_model = AR())
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc'),
#' trend_model = AR(),
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Compute posterior predictions
#' predictions <- posterior_predict(mod)
#' str(predictions)
#' }
#'
#' @author Nicholas J Clark
#'
#' @export
posterior_predict.mvgam = function(
object,
newdata,
data_test,
ndraws = NULL,
process_error = TRUE,
...
) {
out <- predict(
object,
newdata = newdata,
data_test = data_test,
process_error = process_error,
type = 'response',
summary = FALSE
)
if (!is.null(ndraws)) {
validate_pos_integer(ndraws)
if (ndraws > NROW(out)) {} else {
idx <- sample(1:NROW(out), ndraws, replace = FALSE)
out <- out[idx, ]
}
}
return(out)
}
#' @export
#' @importFrom rstantools posterior_predict
rstantools::posterior_predict
#' @export
#' @importFrom rstantools posterior_epred
rstantools::posterior_epred
#' @export
#' @importFrom rstantools posterior_linpred
rstantools::posterior_linpred
#' Expected values of the posterior predictive distribution for \pkg{mvgam} objects
#'
#' This method extracts posterior estimates of the fitted values (i.e. the
#' actual predictions, including estimates for any trend states, that were
#' obtained when fitting the model). It also includes an option for obtaining
#' summaries of the computed draws.
#'
#' @inheritParams brms::fitted.brmsfit
#'
#' @inheritParams predict.mvgam
#'
#' @param object An object of class `mvgam`
#'
#' @details This method gives the actual fitted values from the model (i.e. what
#' you will see if you generate hindcasts from the fitted model using
#' \code{\link{hindcast.mvgam}} with `type = 'expected'`). These predictions
#' can be overly precise if a flexible dynamic trend component was included in
#' the model. This is in contrast to the set of predict functions (i.e.
#' \code{\link{posterior_epred.mvgam}} or \code{\link{predict.mvgam}}), which
#' will assume any dynamic trend component has reached stationarity when
#' returning hypothetical predictions.
#'
#' @return An \code{array} of predicted \emph{mean} response values.
#'
#' If \code{summary = FALSE} the output resembles those of
#' \code{\link{posterior_epred.mvgam}} and \code{\link{predict.mvgam}}.
#'
#' If \code{summary = TRUE} the output is an \code{n_observations} x \code{E}
#' matrix. The number of summary statistics \code{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}.
#'
#' @seealso
#' \code{\link{hindcast.mvgam}}
#'
#' @examples
#' \dontrun{
#' # Simulate some data and fit a model
#' simdat <- sim_mvgam(n_series = 1, trend_model = AR())
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc'),
#' trend_model = AR(),
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract fitted values (posterior expectations)
#' expectations <- fitted(mod)
#' str(expectations)
#' }
#'
#' @author Nicholas J Clark
#'
#' @export
fitted.mvgam <- function(
object,
process_error = TRUE,
scale = c("response", "linear"),
summary = TRUE,
robust = FALSE,
probs = c(0.025, 0.975),
...
) {
if (length(probs) != 2L) {
stop("argument 'probs' must be a vector of length 2", call. = FALSE)
}
scale <- match.arg(scale)
type <- switch(scale, "response" = "expected", "linear" = "link")
preds <- .mvgam_fitted(object = object, type = type)
# Preserve original data ordering
data.frame(
time = object$obs_data$index..time..index,
order = object$obs_data$index..orig..order,
series = object$obs_data$series
) %>%
dplyr::arrange(time, series) %>%
dplyr::pull(order) -> orig_order
preds <- preds[, order(orig_order)]
if (summary) {
Qupper <- apply(preds, 2, quantile, probs = max(probs), na.rm = TRUE)
Qlower <- apply(preds, 2, quantile, probs = min(probs), na.rm = TRUE)
if (robust) {
estimates <- apply(preds, 2, median, na.rm = TRUE)
errors <- apply(abs(preds - estimates), 2, median, na.rm = TRUE)
} else {
estimates <- apply(preds, 2, mean, na.rm = TRUE)
errors <- apply(preds, 2, sd, na.rm = TRUE)
}
out <- cbind(estimates, errors, Qlower, Qupper)
colnames(out) <- c(
'Estimate',
'Est.Error',
paste0('Q', 100 * min(probs)),
paste0('Q', 100 * max(probs))
)
} else {
out <- preds
}
return(out)
}
#' @noRd
.mvgam_fitted = function(object, type = 'expected') {
# Extract the linear predictor draws
mus <- mcmc_chains(object$model_output, 'mus')
# Need to know which series each observation belongs to so we can
# pull out appropriate family-level parameters (overdispersions, shapes, etc...)
if (is.null(object$test_data)) {
all_dat <- data.frame(
series = object$obs_data$series,
time = object$obs_data$time,
y = object$obs_data$y
) %>%
dplyr::arrange(series, time)
} else {
all_dat <- data.frame(
series = c(object$obs_data$series, object$test_data$series),
time = c(object$obs_data$time, object$test_data$time),
y = c(object$obs_data$y, object$test_data$y)
) %>%
dplyr::arrange(series, time)
}
obs <- all_dat$y
series_obs <- as.numeric(all_dat$series)
# Family-specific parameters
family <- object$family
family_pars <- extract_family_pars(object = object)
n_series <- NCOL(object$ytimes)
# Family parameters spread into a vector
family_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
as.vector(family_pars[[j]][, series_obs])
} else {
family_pars[[j]][]
}
})
names(family_extracts) <- names(family_pars)
# Add trial information if this is a Binomial model
if (object$family %in% c('binomial', 'beta_binomial')) {
trials <- as.vector(matrix(
rep(as.vector(attr(object$mgcv_model, 'trials')), NROW(mus)),
nrow = NROW(mus),
byrow = TRUE
))
family_extracts$trials <- trials
}
# Expectations as a vector
Xp <- as.matrix(as.vector(mus))
attr(Xp, 'model.offset') <- 0
if (family == 'nmix') {
latent_lambdas <- exp(as.vector(mcmc_chains(object$model_output, 'trend')))
n_draws <- dim(mcmc_chains(object$model_output, 'ypred'))[1]
cap <- as.vector(t(replicate(n_draws, object$obs_data$cap)))
} else {
latent_lambdas <- NULL
cap <- NULL
}
pred_vec <- mvgam_predict(
family = family,
family_pars = family_extracts,
latent_lambdas = latent_lambdas,
cap = cap,
type = type,
Xp = Xp,
betas = 1
)
# Convert back to matrix and return
pred_mat <- matrix(pred_vec, nrow = NROW(mus))
return(pred_mat)
}
================================================
FILE: R/ppc.mvgam.R
================================================
#' @title Plot conditional posterior predictive checks from \pkg{mvgam} models
#'
#' @importFrom stats quantile density ecdf formula terms
#' @importFrom graphics hist abline box rect lines polygon par
#' @importFrom grDevices rgb
#'
#' @name ppc.mvgam
#'
#' @param object \code{list} object returned from \code{mvgam}. See [mvgam()]
#'
#' @param newdata Optional \code{dataframe} or \code{list} of test data
#' containing at least 'series' and 'time' for the forecast horizon, in
#' addition to any other variables included in the linear predictor of
#' \code{formula}. If included, the observed values in the test data are
#' compared to the model's forecast distribution for exploring biases in
#' model predictions. Note this is only useful if the same \code{newdata}
#' was also included when fitting the original model.
#'
#' @param data_test Deprecated. Still works in place of \code{newdata} but
#' users are recommended to use \code{newdata} instead for more seamless
#' integration into `R` workflows
#'
#' @param series \code{integer} specifying which series in the set is to be
#' plotted
#'
#' @param type \code{character} specifying the type of posterior predictive
#' check to calculate and plot. Valid options are: 'rootogram', 'mean',
#' 'hist', 'density', 'prop_zero', 'pit' and 'cdf'
#'
#' @param n_bins \code{integer} specifying the number of bins to use for
#' binning observed values when plotting a rootogram or histogram. Default
#' is `50` bins for a rootogram, which means that if there are >50 unique
#' observed values, bins will be used to prevent overplotting and facilitate
#' interpretation. Default for a histogram is to use the number of bins
#' returned by a call to `hist` in base `R`
#'
#' @param legend_position The location may also be specified by setting x to a
#' single keyword from the list "bottomright", "bottom", "bottomleft",
#' "left", "topleft", "top", "topright", "right" and "center". This places
#' the legend on the inside of the plot frame at the given location. Or
#' alternatively, use "none" to hide the legend.
#'
#' @param xlab Label for x axis
#'
#' @param ylab Label for y axis
#'
#' @param ... Further \code{\link[graphics]{par}} graphical parameters
#'
#' @details Conditional posterior predictions are drawn from the fitted
#' \code{mvgam} and compared against the empirical distribution of the
#' observed data for a specified series to help evaluate the model's ability
#' to generate unbiased predictions. For all plots apart from
#' `type = 'rootogram'`, posterior predictions can also be compared to out
#' of sample observations as long as these observations were included as
#' 'data_test' in the original model fit and supplied here. Rootograms are
#' currently only plotted using the 'hanging' style.
#'
#'
#' Note that the predictions used for these plots are *conditional on
#' the observed data*, i.e. they are those predictions that have been
#' generated directly within the `mvgam()` model. They can be misleading if
#' the model included flexible dynamic trend components. For a broader range
#' of posterior checks that are created using *unconditional* "new data"
#' predictions, see \code{\link{pp_check.mvgam}}
#'
#' @return A base \code{R} graphics plot showing either a posterior rootogram
#' (for \code{type == 'rootogram'}), the predicted vs observed mean for the
#' series (for \code{type == 'mean'}), predicted vs observed proportion of
#' zeroes for the series (for \code{type == 'prop_zero'}), predicted vs
#' observed histogram for the series (for \code{type == 'hist'}), kernel
#' density or empirical CDF estimates for posterior predictions (for
#' \code{type == 'density'} or \code{type == 'cdf'}) or a Probability
#' Integral Transform histogram (for \code{type == 'pit'}).
#'
#' @author Nicholas J Clark
#'
#' @seealso \code{\link{pp_check.mvgam}}, \code{\link{predict.mvgam}}
#'
#' @examples
#' \dontrun{
#' # Simulate some smooth effects and fit a model
#' set.seed(0)
#'
#' dat <- mgcv::gamSim(
#' 1,
#' n = 200,
#' scale = 2
#' )
#'
#' mod <- mvgam(
#' y ~ s(x0) + s(x1) + s(x2) + s(x3),
#' data = dat,
#' family = gaussian(),
#' chains = 2,
#' silent = 2
#' )
#'
#' # Posterior checks
#' ppc(mod, type = "hist")
#' ppc(mod, type = "density")
#' ppc(mod, type = "cdf")
#'
#' # Many more options are available with pp_check()
#' pp_check(mod)
#' pp_check(mod, type = "ecdf_overlay")
#' pp_check(mod, type = "freqpoly")
#' }
#'
#' @export
ppc <- function(object, ...) {
UseMethod("ppc", object)
}
#' @rdname ppc.mvgam
#' @method ppc mvgam
#' @export
ppc.mvgam <- function(
object,
newdata,
data_test,
series = 1,
type = "hist",
n_bins,
legend_position,
xlab,
ylab,
...
) {
# Check arguments
type <- match.arg(
arg = type,
choices = c(
"rootogram",
"mean",
"histogram",
"density",
"pit",
"cdf",
"prop_zero"
)
)
if (type == "histogram") {
type <- "hist"
}
if (type == "rootogram") {
if (
!object$family %in%
c(
"poisson",
"negative binomial",
"tweedie",
"nmix",
"binomial",
"beta_binomial"
)
) {
stop(
"Rootograms not supported for checking non-count data",
call. = FALSE
)
}
}
optional_args <- list(...)
if (!(inherits(object, "mvgam"))) {
stop('argument "object" must be of class "mvgam"')
}
if (sign(series) != 1) {
stop('argument "series" must be a positive integer', call. = FALSE)
} else {
if (series %% 1 != 0) {
stop('argument "series" must be a positive integer', call. = FALSE)
}
}
if (series > NCOL(object$ytimes)) {
stop(
paste0(
"object only contains data / predictions for ",
NCOL(object$ytimes),
" series"
),
call. = FALSE
)
}
if (type == "rootogram" & missing(n_bins)) {
n_bins <- 50
if (sign(n_bins) != 1) {
stop('argument "n_bins" must be a positive integer', call. = FALSE)
} else {
if (n_bins %% 1 != 0) {
stop('argument "n_bins" must be a positive integer', call. = FALSE)
}
}
}
if (!missing("newdata")) {
data_test <- newdata
# Ensure outcome is labelled 'y' when feeding data to the model for simplicity
if (terms(formula(object$call))[[2]] != "y") {
data_test$y <- data_test[[terms(formula(object$call))[[2]]]]
}
}
# Pull out observations and posterior predictions for the specified series
data_train <- object$obs_data
ends <- seq(
0,
dim(mcmc_chains(object$model_output, "ypred"))[2],
length.out = NCOL(object$ytimes) + 1
)
starts <- ends + 1
starts <- c(1, starts[-c(1, (NCOL(object$ytimes) + 1))])
ends <- ends[-1]
# Colours needed for plotting quantiles
c_light <- c("#DCBCBC")
c_light_highlight <- c("#C79999")
c_mid <- c("#B97C7C")
c_mid_highlight <- c("#A25050")
c_dark <- c("#8F2727")
c_dark_highlight <- c("#7C0000")
s_name <- levels(data_train$series)[series]
if (!missing(data_test)) {
if (class(data_test)[1] == "list") {
if (!"time" %in% names(data_test)) {
stop('data_test does not contain a "time" column')
}
if (!"series" %in% names(data_test)) {
data_test$series <- factor("series1")
}
} else {
if (!"time" %in% colnames(data_test)) {
stop('data_test does not contain a "time" column')
}
if (!"series" %in% colnames(data_test)) {
data_test$series <- factor("series1")
}
}
if (class(object$obs_data)[1] == "list") {
truths <- data.frame(
y = data_test$y,
time = data_test$time,
series = data_test$series
) %>%
dplyr::arrange(time, series) %>%
dplyr::filter(series == s_name) %>%
dplyr::pull(y)
if (object$fit_engine == "stan") {
# For stan objects, ypred is stored as a vector in column-major order
preds <- mcmc_chains(object$model_output, "ypred")[, seq(
series,
dim(mcmc_chains(object$model_output, "ypred"))[2],
by = NCOL(object$ytimes)
)]
} else {
preds <- mcmc_chains(object$model_output, "ypred")[,
starts[series]:ends[series]
]
}
preds <- preds[,
((length(data_train$y) / NCOL(object$ytimes)) + 1):((length(
data_train$y
) /
NCOL(object$ytimes)) +
length(truths))
]
} else {
truths <- data_test %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
if (object$fit_engine == "stan") {
# For stan objects, ypred is stored as a vector in column-major order
preds <- mcmc_chains(object$model_output, "ypred")[, seq(
series,
dim(mcmc_chains(object$model_output, "ypred"))[2],
by = NCOL(object$ytimes)
)]
} else {
preds <- mcmc_chains(object$model_output, "ypred")[,
starts[series]:ends[series]
]
}
preds <- preds[,
((NROW(data_train) / NCOL(object$ytimes)) + 1):((NROW(data_train) /
NCOL(object$ytimes)) +
length(truths))
]
}
if (NROW(preds) > 4000) {
preds <- preds[sample(1:NROW(preds), 4000, F), ]
}
} else {
if (class(object$obs_data)[1] == "list") {
truths <- data.frame(
y = data_train$y,
time = data_train$time,
series = data_train$series
) %>%
dplyr::arrange(series, time) %>%
dplyr::filter(series == s_name) %>%
dplyr::pull(y)
} else {
truths <- data_train %>%
dplyr::filter(series == s_name) %>%
dplyr::select(time, y) %>%
dplyr::distinct() %>%
dplyr::arrange(time) %>%
dplyr::pull(y)
}
if (object$fit_engine == "stan") {
# For stan objects, ypred is stored as a vector in column-major order
preds <- mcmc_chains(object$model_output, "ypred")[, seq(
series,
dim(mcmc_chains(object$model_output, "ypred"))[2],
by = NCOL(object$ytimes)
)]
} else {
preds <- mcmc_chains(object$model_output, "ypred")[,
starts[series]:ends[series]
]
}
preds <- preds[, 1:length(truths), drop = FALSE]
if (NROW(preds) > 4000) {
preds <- preds[sample(1:NROW(preds), 4000, F), ]
}
}
# Can't deal with missing values in these diagnostic plots
preds[is.nan(preds)] <- NA
preds <- preds[, !is.na(truths)]
truths <- truths[!is.na(truths)]
probs <- c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
if (type == "prop_zero") {
pred_props <- apply(preds, 1, function(x) length(which(x == 0)) / length(x))
lower <- quantile(pred_props, probs = 0.01, na.rm = TRUE)
upper <- quantile(pred_props, probs = 0.99, na.rm = TRUE)
if (lower == 0 & upper == 0) {
stop("No predictions covered zero")
}
pred_props <- pred_props[-which(pred_props > upper)]
if (lower != 0) {
pred_props <- pred_props[-which(pred_props < lower)]
}
obs_prop <- length(which(truths == 0)) / length(truths)
if (missing(ylab)) {
ylab <- "Density"
}
if (missing(xlab)) {
xlab <- paste0(
"Predicted proportion of zeroes for ",
levels(data_train$series)[series]
)
}
hist(
pred_props,
lwd = 2,
xlim = c(
min(min(pred_props), min(obs_prop)),
max(max(pred_props), max(obs_prop))
),
main = "",
breaks = seq(min(pred_props), max(pred_props), length.out = 15),
border = "#B97C7C",
col = "#C79999",
ylab = ylab,
xlab = xlab,
...
)
abline(v = obs_prop, lwd = 3, col = "white")
abline(v = obs_prop, lwd = 2.5, col = "black")
box(bty = "L", lwd = 2)
if (missing(legend_position)) {
legend_position <- "topright"
}
if (legend_position != "none") {
legend(
legend_position,
legend = c(expression(hat(y)[propzero]), expression(y[propzero])),
bg = "white",
col = c(c_mid, "black"),
lty = 1,
lwd = 2,
bty = "n"
)
}
}
if (type == "rootogram") {
ymax <- floor(max(max(truths), quantile(preds, prob = 0.99, na.rm = TRUE)))
ymin <- 0L
xpos <- ymin:ymax
# Bin if necessary to prevent overplotting
if (length(xpos) > n_bins) {
cutpoints <- seq(ymin, ymax, length.out = n_bins)
xpos <- floor(cutpoints)
# Find the cutpoint interval that each prediction falls in
tpreds <- as.list(rep(NA, NROW(preds)))
for (i in seq_along(tpreds)) {
tpreds[[i]] <- table(xpos[findInterval(preds[i, ], cutpoints)])
matches <- match(xpos, rownames(tpreds[[i]]))
tpreds[[i]] <- as.numeric(tpreds[[i]][matches])
}
tpreds <- do.call(rbind, tpreds)
tpreds[is.na(tpreds)] <- 0
tyquantile <- sqrt(t(apply(
tpreds,
2,
quantile,
probs = probs,
na.rm = TRUE
)))
tyexp <- tyquantile[, 5]
# Repeat for truths
ty <- table(xpos[findInterval(truths, cutpoints)])
ty <- sqrt(as.numeric(ty[match(xpos, rownames(ty))]))
} else {
tpreds <- as.list(rep(NA, NROW(preds)))
for (i in seq_along(tpreds)) {
tpreds[[i]] <- table(as.vector(preds[i, ]))
matches <- match(xpos, rownames(tpreds[[i]]))
tpreds[[i]] <- as.numeric(tpreds[[i]][matches])
}
tpreds <- do.call(rbind, tpreds)
tpreds[is.na(tpreds)] <- 0
tyquantile <- sqrt(t(apply(
tpreds,
2,
quantile,
probs = probs,
na.rm = TRUE
)))
tyexp <- tyquantile[, 5]
ty <- table(truths)
ty <- sqrt(as.numeric(ty[match(xpos, rownames(ty))]))
}
ty[is.na(ty)] <- 0
ypos <- ty / 2
ypos <- tyexp - ypos
data <- data.frame(xpos, ypos, ty, tyexp, tyquantile)
N <- length(xpos)
idx <- rep(1:N, each = 2)
repped_x <- rep(xpos, each = 2)
x <- sapply(
1:length(idx),
function(k) {
if (k %% 2 == 0) {
repped_x[k] + min(diff(xpos)) / 2
} else {
repped_x[k] - min(diff(xpos)) / 2
}
}
)
if (missing(xlab)) {
xlab <- expression(y)
}
if (missing(ylab)) {
ylab <- expression(sqrt(frequency))
}
# Plot the rootogram
plot(
1,
type = "n",
bty = "L",
xlab = xlab,
ylab = ylab,
xlim = range(xpos),
ylim = range(c(data$tyexp, data[, 13], data[, 5], data$tyexp - data$ty)),
...
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = data$tyexp,
ybottom = data$tyexp - data$ty,
col = "grey80",
border = "grey10",
lwd = 2
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = data[, 13],
ybottom = data[, 5],
col = "#DCBCBC85",
border = "transparent"
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = data[, 12],
ybottom = data[, 6],
col = "#C7999985",
border = "transparent"
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = data[, 11],
ybottom = data[, 7],
col = "#B97C7C85",
border = "transparent"
)
rect(
xleft = x[seq(1, N * 2, by = 2)],
xright = x[seq(2, N * 2, by = 2)],
ytop = data[, 10],
ybottom = data[, 8],
col = "#A2505085",
border = "transparent"
)
abline(h = 0, col = "white", lwd = 3)
abline(h = 0, col = "black", lwd = 2.5)
for (k in 1:N) {
lines(
x = c(x[seq(1, N * 2, by = 2)][k], x[seq(2, N * 2, by = 2)][k]),
y = c(data[k, 9], data[k, 9]),
col = "#8F2727",
lwd = 3
)
}
box(bty = "L", lwd = 2)
}
if (type == "mean") {
# Plot observed and predicted means
pred_means <- apply(preds, 1, mean, na.rm = TRUE)
lower <- quantile(pred_means, probs = 0.01, na.rm = TRUE)
upper <- quantile(pred_means, probs = 0.99, na.rm = TRUE)
pred_means <- pred_means[-which(pred_means > upper)]
if (lower != 0) {
pred_means <- pred_means[-which(pred_means < lower)]
}
obs_mean <- mean(truths)
if (missing(ylab)) {
ylab <- "Density"
}
if (missing(xlab)) {
xlab <- paste0("Predicted mean for ", levels(data_train$series)[series])
}
hist(
pred_means,
xlim = c(
min(min(pred_means, na.rm = TRUE), min(obs_mean, na.rm = TRUE)),
max(max(pred_means, na.rm = TRUE), max(obs_mean, na.rm = TRUE))
),
lwd = 2,
main = "",
breaks = seq(
min(pred_means, na.rm = TRUE),
max(pred_means, na.rm = TRUE),
length.out = 20
),
border = "#B97C7C",
col = "#C79999",
ylab = ylab,
xlab = xlab,
...
)
abline(v = obs_mean, lwd = 3, col = "white")
abline(v = obs_mean, lwd = 2.5, col = "black")
box(bty = "L", lwd = 2)
if (missing(legend_position)) {
legend_position <- "topright"
}
if (legend_position != "none") {
legend(
legend_position,
legend = c(expression(hat(mu)), expression(mu)),
bg = "white",
col = c(c_mid, "black"),
lty = 1,
lwd = 2,
bty = "n"
)
}
}
# Generate a sample sequence and plot
if (type == "density") {
max_x <- max(
max(density(preds[1, ], na.rm = TRUE)$x),
max(density(truths, na.rm = TRUE)$x)
)
min_x <- min(
min(density(preds[1, ], na.rm = TRUE)$x),
min(density(truths, na.rm = TRUE)$x)
)
pred_densities <- do.call(
rbind,
(lapply(1:NROW(preds), function(x) {
if (length(which(is.na(preds[x, ]))) > (length(preds[x, ]) - 3)) {
rep(
0,
length(density(truths, from = min_x, to = max_x, na.rm = TRUE)$y)
)
} else {
dens <- density(preds[x, ], from = min_x, to = max_x, na.rm = TRUE)
dens$y
}
}))
)
cred <- sapply(
1:NCOL(pred_densities),
function(n) quantile(pred_densities[, n], probs = probs, na.rm = TRUE)
)
true_dens <- density(truths, from = min_x, to = max_x, na.rm = TRUE)
ymax <- max(c(max(cred, na.rm = TRUE), max(true_dens$y, na.rm = TRUE)))
if (missing(ylab)) {
ylab <- paste0(
"Predictive density for ",
levels(data_train$series)[series]
)
}
if (missing(xlab)) {
xlab <- ""
}
if (object$family == "beta") {
xlimits <- c(0, 1)
} else if (
object$family %in% c("poisson", "negative binomial", "lognormal", "Gamma")
) {
xlimits <- c(0, max_x)
} else {
xlimits <- c(min_x, max_x)
}
plot(
1,
type = "n",
bty = "L",
xlab = xlab,
ylab = ylab,
xlim = xlimits,
ylim = c(0, ymax),
...
)
polygon(
c(true_dens$x, rev(true_dens$x)),
c(cred[1, ], rev(cred[9, ])),
col = c_light,
border = NA
)
polygon(
c(true_dens$x, rev(true_dens$x)),
c(cred[2, ], rev(cred[8, ])),
col = c_light_highlight,
border = NA
)
polygon(
c(true_dens$x, rev(true_dens$x)),
c(cred[3, ], rev(cred[7, ])),
col = c_mid,
border = NA
)
polygon(
c(true_dens$x, rev(true_dens$x)),
c(cred[4, ], rev(cred[6, ])),
col = c_mid_highlight,
border = NA
)
lines(true_dens$x, cred[5, ], col = c_dark, lwd = 2.5)
lines(x = true_dens$x, y = true_dens$y, lwd = 3, col = "white")
lines(x = true_dens$x, y = true_dens$y, lwd = 2.5, col = "black")
if (missing(legend_position)) {
legend_position <- "topright"
}
if (legend_position != "none") {
legend(
legend_position,
legend = c(expression(hat(y)), "y"),
bg = "white",
col = c(c_mid, "black"),
lty = 1,
lwd = 2,
bty = "n"
)
}
box(bty = "L", lwd = 2)
}
if (type == "hist") {
if (missing(n_bins)) {
n_bins <- max(c(
length(hist(c(truths, as.vector(preds)), plot = F)$breaks),
20
))
}
if (sign(n_bins) != 1) {
stop('argument "n_bins" must be a positive integer', call. = FALSE)
} else {
if (n_bins %% 1 != 0) {
stop('argument "n_bins" must be a positive integer', call. = FALSE)
}
}
xlim <- c(
min(
min(density(preds[1, ], na.rm = TRUE)$x),
min(density(truths, na.rm = TRUE)$x)
),
max(
max(density(preds[1, ], na.rm = TRUE)$x),
max(density(truths, na.rm = TRUE)$x)
)
)
if (object$family == "beta") {
xlim <- c(0, 1)
} else if (
object$family %in% c("poisson", "negative binomial", "lognormal", "Gamma")
) {
xlim <- c(0, xlim[2])
} else {
xlim <- xlim
}
breaks <- seq(xlim[1], xlim[2], length.out = n_bins)
truths <- truths[truths <= xlim[2]]
truths <- truths[truths >= xlim[1]]
preds <- preds[preds <= xlim[2]]
preds <- preds[preds >= xlim[1]]
ylim <- c(
0,
max(
c(
max(hist(truths, breaks = breaks, plot = F)$density, na.rm = TRUE),
max(hist(preds, breaks = breaks, plot = F)$density, na.rm = TRUE)
),
na.rm = TRUE
)
)
if (missing(xlab)) {
xlab <- paste0("Count")
}
if (missing(ylab)) {
ylab <- ""
}
hist(
preds,
breaks = breaks,
lwd = 2,
main = "",
xlab = xlab,
ylab = ylab,
ylim = ylim,
xlim = xlim,
border = "#B97C7C",
col = "#C79999",
freq = F,
...
)
par(lwd = 2)
hist(
truths,
breaks = breaks,
main = "",
xlab = "",
ylim = ylim,
xlim = xlim,
ylab = "",
yaxt = "n",
col = rgb(red = 0, green = 0, blue = 0, alpha = 0),
border = "black",
add = T,
freq = F
)
par(lwd = 1)
box(bty = "L", lwd = 2)
if (missing(legend_position)) {
legend_position <- "topright"
}
if (legend_position != "none") {
legend(
legend_position,
legend = c(expression(hat(y)), "y"),
bg = "white",
col = c(c_mid, "black"),
lty = 1,
lwd = 2,
bty = "n"
)
}
}
if (type == "cdf") {
ecdf_plotdat <- function(vals, x) {
if (length(which(is.na(vals))) > (length(vals) - 3)) {} else {
func <- ecdf(vals)
func(x)
}
}
plot_x <- seq(
from = min(truths, na.rm = T),
to = max(truths, na.rm = T),
length.out = 100
)
pred_cdfs <- do.call(
rbind,
(lapply(1:NROW(preds), function(x) {
ecdf_plotdat(preds[x, ], x = plot_x)
}))
)
probs <- c(0.05, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.95)
cred <- sapply(
1:NCOL(pred_cdfs),
function(n) quantile(pred_cdfs[, n], probs = probs, na.rm = TRUE)
)
if (missing(ylab)) {
ylab <- paste0("Predictive CDF for ", levels(data_train$series)[series])
}
if (missing(xlab)) {
xlab <- ""
}
plot(
1,
type = "n",
bty = "L",
xlab = xlab,
ylab = ylab,
xlim = c(min(plot_x, na.rm = TRUE), max(plot_x, na.rm = TRUE)),
ylim = c(0, 1),
...
)
polygon(
c(plot_x, rev(plot_x)),
c(cred[1, ], rev(cred[9, ])),
col = c_light,
border = NA
)
polygon(
c(plot_x, rev(plot_x)),
c(cred[2, ], rev(cred[8, ])),
col = c_light_highlight,
border = NA
)
polygon(
c(plot_x, rev(plot_x)),
c(cred[3, ], rev(cred[7, ])),
col = c_mid,
border = NA
)
polygon(
c(plot_x, rev(plot_x)),
c(cred[4, ], rev(cred[6, ])),
col = c_mid_highlight,
border = NA
)
lines(plot_x, cred[5, ], col = c_dark, lwd = 2.5)
lines(x = plot_x, y = ecdf_plotdat(truths, plot_x), col = "white", lwd = 3)
lines(
x = plot_x,
y = ecdf_plotdat(truths, plot_x),
col = "black",
lwd = 2.5
)
if (missing(legend_position)) {
legend_position <- "bottomright"
}
if (legend_position != "none") {
legend(
legend_position,
legend = c(expression(hat(y)), "y"),
bg = "white",
col = c(c_mid, "black"),
lty = 1,
lwd = 2,
bty = "n"
)
}
box(bty = "L", lwd = 2)
}
if (type == "pit") {
# Calculate emipirical cumulative distribution function as the
# portion of (y_predicted <= y_true)
n_pred <- ncol(preds)
P_x <- vapply(
seq_along(truths),
function(i) {
sum(preds[i, ] <= truths[i]) / n_pred
},
.0
)
P_xm1 <- vapply(
seq_along(truths),
function(i) {
sum(preds[i, ] <= truths[i] - 1.e-6) / n_pred
},
.0
)
# 1000 replicates for randomised PIT
u <- replicate(1000, P_xm1 + stats::runif(length(truths)) * (P_x - P_xm1))
pit_hist <- hist(u, breaks = seq(0, 1, by = 0.1), plot = F)$density
pit_hist <- (pit_hist / sum(pit_hist)) * 10
barplot(
pit_hist,
lwd = 2,
col = "#B97C7C",
xlab = paste0("Predictive PIT for ", levels(data_train$series)[series]),
border = NA,
...
)
abline(h = 1, col = "#FFFFFF60", lwd = 2.85)
abline(h = 1, col = "black", lwd = 2.5, lty = "dashed")
box(bty = "L", lwd = 2)
}
}
#' Posterior Predictive Checks for \code{mvgam} models
#'
#' Perform unconditional posterior predictive checks with the help
#' of the \pkg{bayesplot} package.
#'
#' @aliases pp_check
#'
#' @inheritParams brms::pp_check
#' @inheritParams brms::prepare_predictions.brmsfit
#'
#' @importFrom insight get_predictors
#' @importFrom brms do_call
#' @importFrom bayesplot pp_check
#'
#' @param object An object of class \code{mvgam}
#'
#' @param newdata Optional \code{dataframe} or \code{list} of test data containing the
#' variables included in the linear predictor of \code{formula}. If not supplied,
#' predictions are generated for the original observations used for the model fit.
#' Ignored if using one of the residual plots (i.e. 'resid_hist')
#'
#' @param ... Further arguments passed to \code{\link{predict.mvgam}}
#' as well as to the PPC function specified in \code{type}
#'
#' @return A ggplot object that can be further
#' customized using the \pkg{ggplot2} package.
#'
#' @details Unlike the conditional posterior checks provided by \code{\link{ppc}},
#' This function computes *unconditional* posterior predictive checks (i.e. it generates
#' predictions for fake data without considering the true observations associated with those
#' fake data). 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.
#'
#' @seealso \code{\link{ppc}}, \code{\link{predict.mvgam}}
#'
#' @examples
#' \dontrun{
#' simdat <- sim_mvgam(seasonality = "hierarchical")
#' mod <- mvgam(
#' y ~ series +
#' s(season, bs = "cc", k = 6) +
#' s(season, series, bs = "fs", k = 4),
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Use pp_check(mod, type = "xyz") for a list of available plot types
#'
#' # Default is a density overlay for all observations
#' pp_check(mod)
#'
#' # Rootograms particularly useful for count data
#' pp_check(mod, type = "rootogram")
#'
#' # Grouping plots by series is useful
#' pp_check(mod,
#' type = "bars_grouped",
#' group = "series", ndraws = 50
#' )
#' pp_check(mod,
#' type = "ecdf_overlay_grouped",
#' group = "series", ndraws = 50
#' )
#' pp_check(mod,
#' type = "stat_freqpoly_grouped",
#' group = "series", ndraws = 50
#' )
#'
#' # Several types can be used to plot distributions of randomized
#' # quantile residuals
#' pp_check(
#' object = mod,
#' x = "season",
#' type = "resid_ribbon"
#' )
#' pp_check(
#' object = mod,
#' x = "season",
#' group = "series",
#' type = "resid_ribbon_grouped"
#' )
#' pp_check(mod,
#' ndraws = 5,
#' type = "resid_hist_grouped",
#' group = "series"
#' )
#'
#' # Custom functions accepted
#' pp_check(mod, type = "stat", stat = function(x) mean(x == 0))
#' pp_check(mod,
#' type = "stat_grouped",
#' stat = function(x) mean(x == 0),
#' group = "series"
#' )
#'
#' # Some functions accept covariates to set the x-axes
#' pp_check(mod,
#' x = "season",
#' type = "ribbon_grouped",
#' prob = 0.5,
#' prob_outer = 0.8,
#' group = "series"
#' )
#'
#' # Many plots can be made without the observed data
#' pp_check(mod, prefix = "ppd")
#' }
#'
#' @export pp_check
#'
#' @author Nicholas J Clark
#'
#' @export
pp_check.mvgam <- function(
object,
type,
ndraws = NULL,
prefix = c("ppc", "ppd"),
group = NULL,
x = NULL,
newdata = NULL,
...
) {
# Set red colour scheme
col_scheme <- attr(color_scheme_get(), "scheme_name")
color_scheme_set("red")
dots <- list(...)
if (missing(type)) {
type <- "dens_overlay"
}
prefix <- match.arg(prefix)
ndraws_given <- "ndraws" %in% names(match.call())
if (is.null(newdata)) {
newdata <- object$obs_data
}
if (prefix == "ppc") {
# No type checking for prefix 'ppd' yet
valid_types <- sort(
c(
as.character(bayesplot::available_ppc("")),
"ppc_resid_hist",
"ppc_resid_hist_grouped",
"ppc_resid_ribbon",
"ppc_resid_ribbon_grouped"
)
)
valid_types <- sub("^ppc_", "", valid_types)
if (!type %in% valid_types) {
stop(
"Type '",
type,
"' is not a valid ppc type. ",
"Valid types are:\n",
paste0("'", valid_types, "'", collapse = ", "),
call. = FALSE
)
}
}
bptype <- type
if (bptype %in% c("resid_hist", "resid_hist_grouped")) {
if (is.null(object$resids)) {
object <- add_residuals(object)
}
bptype <- sub("resid", "error", bptype)
}
if (bptype %in% c("resid_ribbon", "resid_ribbon_grouped")) {
if (is.null(object$resids)) {
object <- add_residuals(object)
}
bptype <- sub("resid_", "", bptype)
}
ppc_fun <- get(paste0(prefix, "_", bptype), asNamespace("bayesplot"))
family <- object$family
if (family == "nmix") {
stop("'pp_check' is not implemented for this family.", call. = FALSE)
}
valid_vars <- names(get_predictors(object))
if ("group" %in% names(formals(ppc_fun))) {
if (is.null(group)) {
stop(
"Argument 'group' is required for ppc type '",
type,
"'.",
call. = FALSE
)
}
if (!group %in% valid_vars) {
stop(
"Variable '",
group,
"' could not be found in the data.",
call. = FALSE
)
}
}
if ("x" %in% names(formals(ppc_fun))) {
if (!is.null(x) && !x %in% valid_vars) {
stop("Variable '", x, "' could not be found in the data.", call. = FALSE)
}
}
if (type == "error_binned") {
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_intervals",
"loo_pit",
"loo_pit_overlay",
"loo_pit_qq",
"loo_ribbon",
"pit_ecdf",
"pit_ecdf_grouped",
"ribbon",
"ribbon_grouped",
"rootogram",
"scatter_avg",
"scatter_avg_grouped",
"stat",
"stat_2d",
"stat_freqpoly_grouped",
"stat_grouped",
"violin_grouped"
)
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; get the response variable,
# but take care that binomial models use the cbind() lhs
resp_terms <- as.character(terms(formula(object$call))[[2]])
if (length(resp_terms) == 1) {
out_name <- as.character(terms(object$call)[[2]])
} else {
if (any(grepl("cbind", resp_terms))) {
resp_terms <- resp_terms[-grepl("cbind", resp_terms)]
out_name <- resp_terms[1]
}
}
y <- newdata[[out_name]]
}
# For plotting DS residuals, set y to zero and take
# -1 * residual so that errors are in the correct direction
if (grepl("resid", type)) {
y[!is.na(y)] <- 0
yrep <- t(-1 * residuals(object, summary = FALSE))
if (!is.null(ndraws)) {
yrep <- yrep[1:ndraws, ]
}
} else {
pred_args <- list(
object,
newdata = newdata,
ndraws = ndraws,
...
)
yrep <- do_call(method, pred_args)
}
if (anyNA(y)) {
warning("NA responses are not shown in 'pp_check'.")
take <- !is.na(y)
y <- y[take]
yrep <- yrep[, take, drop = FALSE]
} else {
take <- NULL
}
# 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)) {
if (!exists(group, newdata)) {
stop(paste0("Variable ", group, " not in newdata"), call. = FALSE)
}
ppc_args$group <- newdata[[group]]
if (!is.null(take)) {
ppc_args$group <- ppc_args$group[take]
}
}
is_like_factor <- function(x) {
is.factor(x) || is.character(x) || is.logical(x)
}
if (!is.null(x)) {
ppc_args$x <- newdata[[x]]
if (!is_like_factor(ppc_args$x)) {
ppc_args$x <- as.numeric(ppc_args$x)
}
if (!is.null(take)) {
ppc_args$x <- ppc_args$x[take]
}
}
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")
# )
# compute_loo() not available yet for mvgam
ppc_args$psis_object <- NULL
}
if ("lw" %in% setdiff(names(formals(ppc_fun)), names(ppc_args))) {
# ppc_args$lw <- weights(
# do_call(compute_loo, c(pred_args, criterion = "psis"))
# )
# compute_loo() not available yet for mvgam
ppc_args$lw <- NULL
}
# Most ... arguments are meant for the prediction function
for_pred <- names(dots) %in% names(formals(posterior_predict.mvgam))
ppc_args <- c(ppc_args, dots[!for_pred])
# Generate plot
out_plot <- do_call(ppc_fun, ppc_args)
if ("x" %in% names(formals(ppc_fun)) && !is.null(x)) {
out_plot <- out_plot +
ggplot2::labs(x = x)
}
# Improve labels for residual plots
if (type %in% c("resid_hist", "resid_hist_grouped")) {
out_plot <- out_plot +
ggplot2::labs(x = "DS residuals")
}
if (type %in% c("resid_ribbon", "resid_ribbon_grouped")) {
out_plot <- out_plot +
ggplot2::theme(legend.position = "none") +
ggplot2::labs(y = "DS residuals")
}
# Reset color scheme and return the plot
color_scheme_set(col_scheme)
return(out_plot)
}
================================================
FILE: R/predict.mvgam.R
================================================
#' Predict from a fitted \pkg{mvgam} model
#'
#' @importFrom stats predict
#'
#' @inheritParams brms::fitted.brmsfit
#'
#' @param object \code{list} object of class \code{mvgam} or \code{jsdgam}.
#' See [mvgam()]
#'
#' @param newdata Optional \code{dataframe} or \code{list} of test data
#' containing the same variables that were included in the original `data`
#' used to fit the model. If not supplied, predictions are generated for the
#' original observations used for the model fit.
#'
#' @param data_test Deprecated. Still works in place of \code{newdata} but
#' users are recommended to use \code{newdata} instead for more seamless
#' integration into `R` workflows
#'
#' @param type When this has the value \code{link} (default) the linear
#' predictor is calculated on the link scale. If \code{expected} is used,
#' predictions reflect the expectation of the response (the mean) but ignore
#' uncertainty in the observation process. When \code{response} is used, the
#' predictions take uncertainty in the observation process into account to
#' return predictions on the outcome scale. When \code{variance} is used, the
#' variance of the response with respect to the mean (mean-variance
#' relationship) is returned. When `type = "terms"`, each component of the
#' linear predictor is returned separately in the form of a `list` (possibly
#' with standard errors, if `summary = TRUE`): this includes parametric model
#' components, followed by each smooth component, but excludes any offset and
#' any intercept. Two special cases are also allowed: type `latent_N` will
#' return the estimated latent abundances from an N-mixture distribution,
#' while type `detection` will return the estimated detection probability from
#' an N-mixture distribution
#'
#' @param process_error Logical. If \code{TRUE} and a dynamic trend model was
#' fit, expected uncertainty in the process model is accounted for by using
#' draws from a stationary, zero-centred multivariate Normal distribution
#' using any estimated process variance-covariance parameters. If
#' \code{FALSE}, uncertainty in the latent trend component is ignored when
#' calculating predictions
#'
#' @param ... Ignored
#'
#' @details Note that if your model included a latent temporal trend (i.e. if
#' you used something other than `"None"` for the `trend_model` argument), the
#' predictions returned by this function will ignore autocorrelation
#' coefficients or GP length scale coefficients by *assuming the process is
#' stationary*. This approach is similar to how predictions are computed from
#' other types of regression models that can include correlated residuals,
#' *ultimately treating the temporal dynamics as random effect nuisance
#' parameters*. The `predict` function is therefore more suited to
#' scenario-based posterior simulation from the GAM components of a
#' \code{mvgam} model, while the hindcast / forecast functions
#' [hindcast.mvgam()] and [forecast.mvgam()] are better suited to generate
#' predictions that respect the temporal dynamics of estimated latent trends
#' at the actual time points supplied in `data` and `newdata`.
#'
#' @return Predicted values on the appropriate scale.
#'
#' If \code{summary = FALSE} and `type != "terms"`, the output is a matrix of
#' dimension `n_draw x n_observations` containing predicted values for each
#' posterior draw in `object`.
#'
#' If \code{summary = TRUE} and `type != "terms"`, the output is an
#' \code{n_observations} x \code{E} matrix. The number of summary statistics
#' \code{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}.
#'
#' If `type = "terms"` and `summary = FALSE`, the output is a named `list`
#' containing a separate slot for each effect, with the effects returned as
#' matrices of dimension `n_draw x 1`. If `summary = TRUE`, the output
#' resembles that from \code{\link[mgcv]{predict.gam}} when using the call
#' `predict.gam(object, type = "terms", se.fit = TRUE)`, where mean
#' contributions from each effect are returned in `matrix` form while standard
#' errors (representing the interval: `(max(probs) - min(probs)) / 2`) are
#' returned in a separate `matrix`
#'
#' @author Nicholas J Clark
#'
#' @seealso
#' [hindcast.mvgam()],
#' [forecast.mvgam()],
#' [fitted.mvgam()],
#' [augment.mvgam()]
#'
#' @examples
#' \dontrun{
#' # Simulate 4 time series with hierarchical seasonality
#' # and independent AR1 dynamic processes
#' set.seed(123)
#' simdat <- sim_mvgam(
#' seasonality = 'hierarchical',
#' prop_trend = 0.75,
#' trend_model = AR(),
#' family = gaussian()
#' )
#'
#' # Fit a model with shared seasonality
#' # and AR(1) dynamics
#' mod1 <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' data = simdat$data_train,
#' family = gaussian(),
#' trend_model = AR(),
#' noncentred = TRUE,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Generate predictions against observed data
#' preds <- predict(
#' mod1,
#' summary = TRUE
#' )
#' head(preds)
#'
#' # Generate predictions against test data
#' preds <- predict(
#' mod1,
#' newdata = simdat$data_test,
#' summary = TRUE
#' )
#' head(preds)
#'
#' # Use plot_predictions(), which relies on predict()
#' # to more easily see how the latent AR(1) dynamics are
#' # being ignored when using predict()
#' plot_predictions(
#' mod1,
#' by = c('time', 'series', 'series'),
#' points = 0.5
#' )
#'
#' # Using the hindcast() function will give a more accurate
#' # representation of how the AR(1) processes were estimated to give
#' # accurate predictions to the in-sample training data
#' hc <- hindcast(mod1)
#' plot(hc) +
#' plot(hc, series = 2) +
#' plot(hc, series = 3)
#' }
#'
#' @export
predict.mvgam = function(
object,
newdata,
data_test,
type = 'link',
process_error = FALSE,
summary = TRUE,
robust = FALSE,
probs = c(0.025, 0.975),
...
) {
# Argument checks
if (!missing("data_test")) {
newdata <- data_test
}
if (missing(newdata)) {
newdata <- object$obs_data
}
if (length(probs) != 2L) {
stop("argument 'probs' must be a vector of length 2", call. = FALSE)
}
validate_proportional(min(probs))
validate_proportional(max(probs))
# Check names of supplied variables against those required
# for prediction
validate_predictors(object, newdata)
# newdata needs to have a 'series' indicator in it for integrating
# over the trend uncertainties
if (inherits(object, 'jsdgam')) {
newdata <- validate_series_time(
data = newdata,
trend_model = attr(object$model_data, 'prepped_trend_model'),
check_levels = FALSE,
check_times = FALSE
)
} else {
newdata <- validate_series_time(
data = newdata,
trend_model = object$trend_model,
check_levels = FALSE,
check_times = FALSE
)
}
type <- match.arg(
arg = type,
choices = c(
"link",
"expected",
"response",
"variance",
"latent_N",
"detection",
"terms"
)
)
if (type == 'latent_N' & object$family != 'nmix') {
stop('"latent_N" type only available for N-mixture models', call. = FALSE)
}
if (type == 'detection' & object$family != 'nmix') {
stop('"detection" type only available for N-mixture models', call. = FALSE)
}
# terms is the easiest return type, so evaluate it first
if (type == 'terms') {
out <- list()
out$obs_effects <- terms_preds(
object = object,
newdata = newdata,
summary = summary,
robust = robust,
probs = probs,
trend_effects = FALSE
)
if (!is.null(object$trend_call)) {
out$process_effects <- terms_preds(
object = object,
newdata = newdata,
summary = summary,
robust = robust,
probs = probs,
trend_effects = TRUE
)
}
} else {
# If a linear predictor was supplied for the latent process models, calculate
# predictions by assuming the trend is stationary (this is basically what brms
# does when predicting for autocor() models)
if (!is.null(object$trend_call)) {
# Linear predictor matrix for the latent process models
Xp <- trend_Xp_matrix(
newdata = newdata,
trend_map = object$trend_map,
series = 'all',
mgcv_model = object$trend_mgcv_model
)
# Extract process error estimates
if (
attr(object$model_data, 'trend_model') %in%
c('None', 'RW', 'AR1', 'AR2', 'AR3', 'CAR1', 'ZMVN')
) {
if (object$family == 'nmix') {
family_pars <- list(sigma_obs = .Machine$double.eps)
} else {
family_pars <- list(
sigma_obs = mcmc_chains(object$model_output, 'sigma')
)
}
}
if (attr(object$model_data, 'trend_model') %in% c('VAR1')) {
if (object$use_lv) {
family_pars <- list(
sigma_obs = mcmc_chains(object$model_output, 'Sigma')[,
seq(1, object$n_lv^2, by = object$n_lv + 1)
]
)
} else {
family_pars <- list(
sigma_obs = mcmc_chains(object$model_output, 'Sigma')[,
seq(1, NCOL(object$ytimes)^2, by = NCOL(object$ytimes) + 1)
]
)
}
}
# Indicators of which trend to use for each observation
if (inherits(newdata, 'list')) {
data.frame(series = newdata$series) %>%
dplyr::left_join(object$trend_map, by = 'series') %>%
dplyr::pull(trend) -> trend_inds
newdata_trend <- newdata
newdata_trend$trend <- trend_inds
} else {
newdata %>%
dplyr::left_join(object$trend_map, by = 'series') -> newdata_trend
}
trend_ind <- as.numeric(newdata_trend$trend)
# Beta coefficients for GAM process model component
betas <- mcmc_chains(object$model_output, 'b_trend')
# Family parameters spread into a vector
family_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
as.vector(family_pars[[j]][, trend_ind])
} else {
family_pars[[j]]
}
})
names(family_extracts) <- names(family_pars)
# Trend stationary predictions
if (!process_error) {
family_extracts <- list(sigma_obs = .Machine$double.eps)
}
if (inherits(object, 'jsdgam')) {
# JSDMs should generate one set of predictions per latent variable and then
# create a weighted set of predictions based on the loading estimates
lv_coefs <- mcmc_chains(object$model_output, 'lv_coefs')
n_draws <- dim(mcmc_chains(object$model_output, 'b'))[1]
series_ind <- as.numeric(newdata$series)
trend_predictions_raw <- lapply(1:object$n_lv, function(x) {
# Linear predictor matrix for the latent process models
Xp <- trend_Xp_matrix(
newdata = newdata,
trend_map = data.frame(
trend = x,
series = unique(object$trend_map$series)
),
series = 'all',
mgcv_model = object$trend_mgcv_model
)
all_linpreds <- as.matrix(as.vector(t(apply(
as.matrix(betas),
1,
function(row) Xp %*% row + attr(Xp, 'model.offset')
))))
attr(all_linpreds, 'model.offset') <- 0
pred_vec <- mvgam_predict(
family = 'gaussian',
Xp = all_linpreds,
type = 'response',
betas = 1,
family_pars = family_extracts
)
matrix(pred_vec, nrow = NROW(betas))
})
# Create weighted set of predictions using the loadings
weighted_mat = function(pred_matrices, weights, draw = 1, obs = 1) {
lv_draws <- unlist(
lapply(pred_matrices, function(x) x[draw, obs]),
use.names = FALSE
)
as.vector(lv_draws %*% weights)
}
trend_predictions <- matrix(
NA,
nrow = n_draws,
ncol = length(newdata[[1]])
)
n_lv <- object$n_lv
for (i in 1:n_draws) {
for (x in 1:length(newdata[[1]])) {
trend_predictions[i, x] <- weighted_mat(
trend_predictions_raw,
matrix(lv_coefs[i, ], nrow = n_lv)[, series_ind[x]],
draw = i,
obs = x
)
}
}
trend_predictions <- as.vector(trend_predictions)
} else {
# Pre-multiply the linear predictors
all_linpreds <- as.matrix(as.vector(t(apply(
as.matrix(betas),
1,
function(row) Xp %*% row + attr(Xp, 'model.offset')
))))
attr(all_linpreds, 'model.offset') <- 0
trend_predictions <- mvgam_predict(
family = 'gaussian',
Xp = all_linpreds,
type = 'response',
betas = 1,
family_pars = family_extracts
)
}
} else if (
attr(object$model_data, 'trend_model') != 'None' & process_error
) {
# If no linear predictor for the trends but a dynamic trend model was used,
# and the process_error flag is set to TRUE,
# simulate from stationary time series to capture uncertainty
# in the dynamic trend component
n_draws <- dim(mcmc_chains(object$model_output, 'b'))[1]
series_ind <- as.numeric(newdata$series)
# Draw from fixed sigma for latent variable models
if (object$use_lv & is.null(object$trend_map)) {
if (attr(object$model_data, 'trend_model') != 'GP') {
trends <- array(
rnorm(
n_draws * object$n_lv * length(newdata[[1]]),
mean = 0,
sd = 0.1
),
dim = c(n_draws, object$n_lv, length(newdata[[1]]))
)
} else {
trends <- array(
rnorm(
n_draws * object$n_lv * length(newdata[[1]]),
mean = 0,
sd = 0.25
),
dim = c(n_draws, object$n_lv, length(newdata[[1]]))
)
}
lv_coefs <- mcmc_chains(object$model_output, 'lv_coefs')
trend_predictions <- matrix(
NA,
nrow = n_draws,
ncol = length(newdata[[1]])
)
for (i in 1:n_draws) {
for (x in 1:length(newdata[[1]])) {
trend_predictions[i, x] <- t(trends[i, , series_ind[x]]) %*%
matrix(lv_coefs[i, ], nrow = object$n_lv)[, series_ind[x]]
}
}
trend_predictions <- as.vector(trend_predictions)
}
if (!object$use_lv | !is.null(object$trend_map)) {
if (
attr(object$model_data, 'trend_model') %in%
c('RW', 'AR1', 'AR2', 'AR3', 'VAR1', 'CAR1', 'ZMVN')
) {
family_pars <- list(
sigma_obs = mcmc_chains(object$model_output, 'sigma')
)
}
if (attr(object$model_data, 'trend_model') %in% c('GP')) {
family_pars <- list(
sigma_obs = mcmc_chains(object$model_output, 'alpha_gp')
)
}
if (
attr(object$model_data, 'trend_model') %in%
c('PWlogistic', 'PWlinear')
) {
trend_hcs <- hindcast(object, type = 'trend')
sigma_obs <- unlist(
lapply(seq_along(trend_hcs$hindcasts), function(x) {
mean(apply(trend_hcs$hindcasts[[x]], 2, sd))
}),
use.names = FALSE
)
family_pars <- list(
sigma_obs = sigma_obs
)
}
# Indicators of which trend to use for each observation
if (!is.null(object$trend_map)) {
newdata %>%
dplyr::left_join(object$trend_map, by = 'series') -> newdata_trend
trend_ind <- as.numeric(newdata_trend$trend)
} else {
trend_ind <- as.numeric(newdata$series)
}
# Create a fake design matrix of 1s
betas <- matrix(
0,
ncol = 1,
nrow = dim(mcmc_chains(object$model_output, 'b'))[1]
)
Xp <- matrix(1, ncol = 1, nrow = length(newdata$time))
attr(Xp, 'model.offset') <- 0
# Family parameters spread into a vector
family_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
as.vector(family_pars[[j]][, trend_ind])
} else {
family_pars[[j]]
}
})
names(family_extracts) <- names(family_pars)
# Pre-multiply the linear predictors
all_linpreds <- as.matrix(as.vector(t(apply(
as.matrix(betas),
1,
function(row) Xp %*% row + attr(Xp, 'model.offset')
))))
attr(all_linpreds, 'model.offset') <- 0
# Trend stationary predictions
trend_predictions <- mvgam_predict(
family = 'gaussian',
Xp = all_linpreds,
type = 'response',
betas = 1,
family_pars = family_extracts
)
}
} else {
# If no trend_model was used, or if process_error == FALSE,
# ignore uncertainty in any latent trend component
trend_predictions <- 0
}
#### Once trend predictions are made, calculate observation predictions ####
# Generate linear predictor matrix from the mgcv observation model
Xp <- obs_Xp_matrix(newdata = newdata, mgcv_model = object$mgcv_model)
# Beta coefficients for GAM component
betas <- mcmc_chains(object$model_output, 'b')
# Family of model
family <- object$family
# Family-specific parameters
family_pars <- extract_family_pars(object = object)
# Determine which series each observation belongs to
series_ind <- as.numeric(newdata$series)
# Family parameters spread into long vectors
family_extracts <- lapply(seq_along(family_pars), function(j) {
if (is.matrix(family_pars[[j]])) {
as.vector(family_pars[[j]][, series_ind])
} else {
as.vector(matrix(
rep(family_pars[[j]], NROW(Xp)),
nrow = NROW(betas),
byrow = FALSE
))
}
})
names(family_extracts) <- names(family_pars)
# Add trial information if this is a Binomial model
if (object$family %in% c('binomial', 'beta_binomial')) {
resp_terms <- as.character(terms(formula(object))[[2]])
resp_terms <- resp_terms[-grepl('cbind', resp_terms)]
trial_name <- resp_terms[2]
if (!trial_name %in% names(newdata)) {
stop(
paste0('variable ', trial_name, ' not found in newdata'),
call. = FALSE
)
}
trials <- newdata[[trial_name]]
trials <- as.vector(matrix(
rep(as.vector(trials), NROW(betas)),
nrow = NROW(betas),
byrow = TRUE
))
family_extracts$trials <- trials
}
# Pre-multiply the linear predictors, including any offset and trend
# predictions if applicable
if (family == 'nmix') {
all_linpreds <- as.matrix(as.vector(t(apply(
as.matrix(betas),
1,
function(row) Xp %*% row + attr(Xp, 'model.offset')
))))
latent_lambdas <- exp(trend_predictions)
if (!(exists('cap', where = newdata))) {
stop(
'Max abundances must be supplied as a variable named "cap" for N-mixture models',
call. = FALSE
)
}
validate_pos_integers(newdata$cap)
if (any(is.na(newdata$cap)) | any(is.infinite(newdata$cap))) {
stop(
paste0('Missing or infinite values found for some "cap" terms'),
call. = FALSE
)
}
cap <- as.vector(t(replicate(NROW(betas), newdata$cap)))
} else {
all_linpreds <- as.matrix(
as.vector(t(apply(
as.matrix(betas),
1,
function(row) Xp %*% row + attr(Xp, 'model.offset')
))) +
trend_predictions
)
latent_lambdas <- NULL
cap <- NULL
}
attr(all_linpreds, 'model.offset') <- 0
# Calculate vectorized predictions
predictions_vec <- mvgam_predict(
family = family,
Xp = all_linpreds,
latent_lambdas = latent_lambdas,
cap = cap,
type = type,
betas = 1,
family_pars = family_extracts
)
# Convert back to matrix
preds <- matrix(predictions_vec, nrow = NROW(betas))
if (summary) {
Qupper <- apply(preds, 2, quantile, probs = max(probs), na.rm = TRUE)
Qlower <- apply(preds, 2, quantile, probs = min(probs), na.rm = TRUE)
if (robust) {
estimates <- apply(preds, 2, median, na.rm = TRUE)
errors <- apply(abs(preds - estimates), 2, median, na.rm = TRUE)
} else {
estimates <- apply(preds, 2, mean, na.rm = TRUE)
errors <- apply(preds, 2, sd, na.rm = TRUE)
}
out <- cbind(estimates, errors, Qlower, Qupper)
colnames(out) <- c(
'Estimate',
'Est.Error',
paste0('Q', 100 * min(probs)),
paste0('Q', 100 * max(probs))
)
} else {
out <- preds
}
}
return(out)
}
#' Term-specific predictions and uncertainties
#' @noRd
terms_preds = function(
object,
newdata,
summary = TRUE,
robust = FALSE,
probs = c(0.025, 0.975),
trend_effects = FALSE
) {
if (trend_effects) {
Xp <- trend_Xp_matrix(
newdata = newdata,
trend_map = object$trend_map,
series = 'all',
mgcv_model = object$trend_mgcv_model
)
betas <- mcmc_chains(object$model_output, 'b_trend')
effect_names <- colnames(predict(
relabel_gps(object$trend_mgcv_model),
type = 'terms',
se.fit = FALSE
))
effect_names <- gsub('series', 'trend', effect_names, fixed = TRUE)
coef_names <- names(coef(object$trend_mgcv_model))
coef_names <- gsub('series', 'trend', coef_names, fixed = TRUE)
} else {
Xp <- obs_Xp_matrix(newdata = newdata, mgcv_model = object$mgcv_model)
betas <- mcmc_chains(object$model_output, 'b')
effect_names <- colnames(predict(
relabel_gps(object$mgcv_model),
type = 'terms',
se.fit = FALSE
))
coef_names <- names(coef(object$mgcv_model))
}
# Contributions considering full uncertainties
contributions <- serrors <- vector(
mode = 'list',
length = length(effect_names)
)
for (i in seq_along(effect_names)) {
effect_idxs <- grep(effect_names[i], coef_names, fixed = TRUE)
linpred <- as.matrix(as.vector(t(apply(
as.matrix(betas[, effect_idxs, drop = FALSE]),
1,
function(row) Xp[, effect_idxs, drop = FALSE] %*% row
))))
contributions[[i]] <- matrix(linpred, nrow = NROW(betas))
if (summary) {
serrors[[i]] <- (apply(
contributions[[i]],
2,
function(x) quantile(x, probs = max(probs), na.rm = TRUE)
) -
apply(
contributions[[i]],
2,
function(x) quantile(x, probs = min(probs), na.rm = TRUE)
)) /
2
if (robust) {
contributions[[i]] <- apply(contributions[[i]], 2, median)
} else {
contributions[[i]] <- apply(contributions[[i]], 2, mean)
}
}
}
if (summary) {
out <- list()
contributions <- do.call(cbind, contributions)
serrors <- do.call(cbind, serrors)
colnames(contributions) <- colnames(serrors) <- effect_names
out$fit <- contributions
out$se.fit <- serrors
} else {
names(contributions) <- effect_names
out <- contributions
}
return(out)
}
================================================
FILE: R/print.mvgam.R
================================================
#' Print a fitted \pkg{mvgam} object
#'
#' This function takes a fitted \code{mvgam} or \code{jsdgam} object and prints
#' a quick summary.
#'
#' @param x \code{list} object returned from \code{mvgam}
#'
#' @param ... Ignored
#'
#' @details A brief summary of the model's call is printed
#'
#' @return A \code{list} is printed on-screen
#'
#' @author Nicholas J Clark
#'
#' @export
print.mvgam = function(x, ...) {
object <- x
# Use shared extractor functions to eliminate code duplication
model_spec <- extract_model_spec(object)
sampling_info <- extract_sampling_info(object)
# Print model specification with simplified logic for print.mvgam
print_model_specification_simple(model_spec)
# Print sampling information using shared helper
print_sampling_information(sampling_info)
}
#' Print model specification section for print.mvgam (simplified version)
#' @param model_spec Model specification from extract_model_spec
#' @noRd
print_model_specification_simple <- function(model_spec) {
# Print formulas
if (!is.null(model_spec$formulas$process)) {
cat("GAM observation formula:\n")
print(model_spec$formulas$observation)
cat("\nGAM process formula:\n")
print(model_spec$formulas$process)
} else {
cat("GAM formula:\n")
print(model_spec$formulas$observation)
}
# Print family and link
cat("\nFamily:\n")
cat(paste0(model_spec$family, '\n'))
cat("\nLink function:\n")
cat(paste0(model_spec$link, '\n'))
# Print trend model
if (!model_spec$is_jsdgam) {
cat("\nTrend model:\n")
if (is.call(model_spec$trend_model)) {
print(model_spec$trend_model)
cat('\n')
} else {
cat(paste0(model_spec$trend_model, '\n'))
}
}
# Print latent variable info (simplified - always "latent factors" for print.mvgam)
if (!is.null(model_spec$latent_variables)) {
cat("\nN latent factors:\n")
cat(model_spec$latent_variables$count, '\n')
}
# Print dimensions
if (model_spec$is_jsdgam) {
cat('\nN species:\n')
cat(model_spec$dimensions$n_species, '\n')
cat('\nN sites:\n')
cat(model_spec$dimensions$n_sites, '\n')
} else {
cat('\nN series:\n')
cat(model_spec$dimensions$n_series, '\n')
cat('\nN timepoints:\n')
cat(model_spec$dimensions$n_timepoints, '\n')
}
# Print upper bounds if present
if (!is.null(model_spec$upper_bounds)) {
cat('\nUpper bounds:\n')
cat(model_spec$upper_bounds, '\n')
}
}
#'@export
print.mvgam_prefit = function(x, ...) {
object <- x
# Use shared extractor function for model specification
model_spec <- extract_model_spec(object)
# Print model specification using shared helper
print_model_specification(model_spec)
# Add prefit-specific status message
cat('\nStatus:\n')
cat('Not fitted', '\n')
}
================================================
FILE: R/residual_cor.R
================================================
#' Extract residual correlations based on latent factors
#'
#' Compute residual correlation estimates from Joint Species Distribution
#' (\code{jsdgam}) or \code{mvgam} models that either used latent factors
#' or included correlated process errors directly
#'
#' @name residual_cor.jsdgam
#'
#' @inheritParams brms::residuals.brmsfit
#'
#' @param object \code{list} object of class \code{mvgam} resulting from a
#' call to [jsdgam()] or a call to [mvgam()] in which either
#' `use_lv = TRUE` or a multivariate process was used with `cor = TRUE`
#' (see [RW()] and [VAR()] for examples)
#'
#' @param robust If `FALSE` (the default) the mean is used as a measure of
#' central tendency. If `TRUE`, the median is used instead. Only used if
#' `summary` is `TRUE`
#'
#' @param ... ignored
#'
#' @return If `summary = TRUE`, a `list` of
#' \code{\link{mvgam_residcor-class}} with the following components:
#' \item{cor, cor_lower, cor_upper}{A set of \eqn{p \times p} correlation
#' matrices, containing either the posterior median or mean estimate, plus
#' lower and upper limits of the corresponding credible intervals supplied
#' to `probs`}
#' \item{sig_cor}{A \eqn{p \times p} correlation matrix containing only
#' correlations whose credible interval does not contain zero. All other
#' correlations are set to zero}
#' \item{prec, prec_lower, prec_upper}{A set of \eqn{p \times p} precision
#' matrices, containing either the posterior median or mean estimate, plus
#' lower and upper limits of the corresponding credible intervals supplied
#' to `probs`}
#' \item{sig_prec}{A \eqn{p \times p} precision matrix containing only
#' precisions whose credible interval does not contain zero. All other
#' precisions are set to zero}
#' \item{cov}{A \eqn{p \times p} posterior median or mean covariance
#' matrix}
#' \item{trace}{The median/mean point estimator of the trace (sum of the
#' diagonal elements) of the residual covariance matrix `cov`}
#'
#' If `summary = FALSE`, this function returns a `list` containing the
#' following components:
#' \item{all_cormat}{A \eqn{n_{draws} \times p \times p} `array` of
#' posterior residual correlation matrix draws}
#' \item{all_covmat}{A \eqn{n_{draws} \times p \times p} `array` of
#' posterior residual covariance matrix draws}
#' \item{all_presmat}{A \eqn{n_{draws} \times p \times p} `array` of
#' posterior residual precision matrix draws}
#' \item{all_trace}{A \eqn{n_{draws}} `vector` of posterior covariance
#' trace draws}
#'
#' @details
#' See \code{\link{mvgam_residcor-class}} for a description of the quantities
#' that are computed and returned by this function, along with key references.
#'
#' @references Hui, F. K. C. (2016). boral – Bayesian Ordination and
#' Regression Analysis of Multivariate Abundance Data in r. \emph{Methods
#' in Ecology and Evolution}, 7(6), 744-750.
#' \doi{10.1111/2041-210X.12514}
#'
#' @seealso [jsdgam()], [lv_correlations()], \code{\link{mvgam_residcor-class}}
#'
#' @export
residual_cor <- function(object, ...) {
UseMethod("residual_cor", object)
}
#' @rdname residual_cor.jsdgam
#' @method residual_cor mvgam
#' @export
residual_cor.mvgam <- function(
object,
summary = TRUE,
robust = FALSE,
probs = c(0.025, 0.975),
...
) {
# Only applicable if this is a dynamic factor model or a model
# that included a process error variance-covariance matrix
if (
any(
grepl(
'Sigma',
variables(object)$trend_pars$orig_name
)
) |
object$use_lv
) {
class(object) <- c('jsdgam', 'mvgam')
return(
residual_cor(
object,
object = object,
summary = summary,
robust = robust,
probs = probs,
...
)
)
} else {
stop(
paste0(
'Cannot compute residual correlations if no latent factors ',
'or correlated process errors were modelled'
),
call. = FALSE
)
}
}
#' @rdname residual_cor.jsdgam
#' @method residual_cor jsdgam
#' @examples
#'\dontrun{
#' # Fit a JSDGAM to the portal_data captures
#' mod <- jsdgam(
#' formula = captures ~
#' # Fixed effects of NDVI and mintemp, row effect as a GP of time
#' ndvi_ma12:series + mintemp:series + gp(time, k = 15),
#' factor_formula = ~ -1,
#' data = portal_data,
#' unit = time,
#' species = series,
#' family = poisson(),
#' n_lv = 2,
#' silent = 2,
#' chains = 2
#' )
#'
#' # Plot residual correlations
#' plot(
#' residual_cor(mod)
#' )
#'
#' # Compare to a residual ordination biplot
#' if(requireNamespace('ggrepel', quietly = TRUE)){
#' ordinate(mod)
#' }
#'
#' # Not needed for general use; cleans up connections for automated testing
#' closeAllConnections()
#' }
#' @export
residual_cor.jsdgam <- function(
object,
summary = TRUE,
robust = FALSE,
probs = c(0.025, 0.975),
...
) {
insight::check_if_installed("corpcor")
if (length(probs) != 2L) {
stop("argument 'probs' must be a vector of length 2", call. = FALSE)
}
validate_proportional(min(probs))
validate_proportional(max(probs))
# Initiate objects to store all posterior correlation and covariance matrices
p <- NCOL(object$ytimes)
sp_names <- levels(object$obs_data$series)
ndraws <- brms::ndraws(as_draws_array(object, variable = 'betas'))
all_cormat <- all_covmat <- all_precmat <- array(
0,
dim = c(ndraws, p, p)
)
all_trace_rescor <- numeric(ndraws)
# Check whether this model included a full variance-covariance matrix
use_lv <- TRUE
if (
any(
grepl(
'Sigma',
variables(object)$trend_pars$orig_name
)
)
) {
# Use the factors if they were supplied; otherwise
# use the full variance-covariance matrix
if (object$use_lv) {
use_lv <- TRUE
} else {
use_lv <- FALSE
}
}
if (use_lv) {
# Take draws of factor loadings to compute residual correlations,
# covariances, and precisions
n_lv <- object$n_lv
loadings <- as.matrix(object$model_output, 'lv_coefs')
# Calculate posterior covariance, correlation, precision and trace estimates
for (i in 1:ndraws) {
lv_coefs <- matrix(loadings[i, ], nrow = p, ncol = n_lv)
lambdalambdaT <- tcrossprod(lv_coefs)
all_covmat[i, , ] <- lambdalambdaT
all_trace_rescor[i] <- sum(diag(lambdalambdaT))
all_cormat[i, , ] <- cov2cor(lambdalambdaT)
all_precmat[i, , ] <- corpcor::cor2pcor(lambdalambdaT)
}
} else {
# If the model already included a variance-covariance matrix,
# compute directly
Sigma_post <- as.matrix(
object,
variable = "Sigma",
regex = TRUE
)
for (i in 1:ndraws) {
cov <- matrix(
Sigma_post[i, ],
nrow = p,
ncol = p
)
all_covmat[i, , ] <- cov
all_trace_rescor[i] <- sum(diag(cov))
all_cormat[i, , ] <- cov2cor(cov)
all_precmat[i, , ] <- corpcor::cor2pcor(cov)
}
}
if (!summary) {
out <- list(
all_cormat = all_cormat,
all_covmat = all_covmat,
all_precmat = all_precmat,
all_trace = all_trace_rescor
)
} else {
#### If summary, calculate summary statistics ####
# Initiate summary correlation and covariance matrices
sig_cormat <- cormat <- cormat_lower <- cormat_upper <-
sig_precmat <- precmat <- precmat_lower <- precmat_upper <-
covmat <- matrix(0, nrow = p, ncol = p)
rownames(cormat) <- rownames(cormat_lower) <- rownames(cormat_upper) <-
rownames(sig_cormat) <- rownames(precmat) <- rownames(precmat_lower) <-
rownames(precmat_upper) <- rownames(sig_precmat) <- rownames(covmat) <-
colnames(cormat) <- colnames(cormat_lower) <- colnames(
cormat_upper
) <-
colnames(sig_cormat) <- colnames(precmat) <- colnames(
precmat_lower
) <-
colnames(precmat_upper) <- colnames(sig_precmat) <- colnames(
covmat
) <-
sp_names
# Calculate posterior summaries
for (j in 1:p) {
for (j2 in 1:p) {
if (robust) {
covmat[j, j2] <- median(all_covmat[, j, j2])
cormat[j, j2] <- median(all_cormat[, j, j2])
precmat[j, j2] <- median(all_precmat[, j, j2])
} else {
covmat[j, j2] <- mean(all_covmat[, j, j2])
cormat[j, j2] <- mean(all_cormat[, j, j2])
precmat[j, j2] <- mean(all_precmat[, j, j2])
}
sig_cormat[j, j2] <- cormat[j, j2]
cormat_lower[j, j2] <- quantile(
all_cormat[, j, j2],
probs = min(probs),
na.rm = TRUE
)
cormat_upper[j, j2] <- quantile(
all_cormat[, j, j2],
probs = max(probs),
na.rm = TRUE
)
if (0 > cormat_lower[j, j2] & 0 < cormat_upper[j, j2]) {
sig_cormat[j, j2] <- 0
}
sig_precmat[j, j2] <- precmat[j, j2]
precmat_lower[j, j2] <- quantile(
all_precmat[, j, j2],
probs = min(probs),
na.rm = TRUE
)
precmat_upper[j, j2] <- quantile(
all_precmat[, j, j2],
probs = max(probs),
na.rm = TRUE
)
if (0 > precmat_lower[j, j2] & 0 < precmat_upper[j, j2]) {
sig_precmat[j, j2] <- 0
}
}
}
if (robust) {
final_trace <- median(all_trace_rescor)
} else {
final_trace <- mean(all_trace_rescor)
}
out <- structure(
list(
cor = cormat,
cor_lower = cormat_lower,
cor_upper = cormat_upper,
sig_cor = sig_cormat,
cov = covmat,
prec = precmat,
prec_lower = precmat_lower,
prec_upper = precmat_upper,
sig_prec = sig_precmat,
trace = final_trace
),
class = 'mvgam_residcor'
)
}
return(out)
}
================================================
FILE: R/residuals.mvgam.R
================================================
#' Posterior draws of residuals from \pkg{mvgam} models
#'
#' This method extracts posterior draws of Dunn-Smyth (randomized quantile)
#' residuals in the order in which the data were supplied to the model. It
#' includes additional arguments for obtaining summaries of the computed
#' residuals.
#'
#' @inheritParams brms::residuals.brmsfit
#'
#' @param object An object of class `mvgam`
#'
#' @param ... Ignored
#'
#' @details This method gives residuals as Dunn-Smyth (randomized quantile)
#' residuals. Any observations that were missing (i.e. `NA`) in the original
#' data will have missing values in the residuals.
#'
#' @return An \code{array} of randomized quantile residual values.
#'
#' If \code{summary = FALSE} the output resembles those of
#' \code{\link{posterior_epred.mvgam}} and \code{\link{predict.mvgam}}.
#'
#' If \code{summary = TRUE} the output is an \code{n_observations} x \code{E}
#' matrix. The number of summary statistics \code{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}.
#'
#' @seealso
#' \code{\link{augment.mvgam}}
#'
#' @author Nicholas J Clark
#'
#' @examples
#' \dontrun{
#' # Simulate some data and fit a model
#' simdat <- sim_mvgam(n_series = 1, trend_model = AR())
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc'),
#' trend_model = AR(),
#' noncentred = TRUE,
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract posterior residuals
#' resids <- residuals(mod)
#' str(resids)
#'
#' # Or add them directly to the observed data, along with fitted values
#' augment(mod, robust = FALSE, probs = c(0.25, 0.75))
#' }
#'
#' @export
residuals.mvgam <- function(
object,
summary = TRUE,
robust = FALSE,
probs = c(0.025, 0.975),
...
) {
if (length(probs) != 2L) {
stop("argument 'probs' must be a vector of length 2", call. = FALSE)
}
validate_proportional(min(probs))
validate_proportional(max(probs))
# What was the original time / series order?
orig_order <- data.frame(
series = object$obs_data$series,
time = object$obs_data$index..time..index
)
series_numeric <- as.numeric(orig_order$series)
time_numeric <- match(orig_order$time, unique(orig_order$time))
# Build a matrix to return residuals in this order
resid_matrix <- matrix(
NA,
nrow = NROW(orig_order),
ncol = NROW(object$resids[[1]])
)
for (i in 1:NROW(resid_matrix)) {
resid_matrix[i, ] <- object$resids[[series_numeric[i]]][, time_numeric[i]]
}
if (summary) {
Qupper <- apply(resid_matrix, 1, quantile, probs = max(probs), na.rm = TRUE)
Qlower <- apply(resid_matrix, 1, quantile, probs = min(probs), na.rm = TRUE)
if (robust) {
estimates <- apply(resid_matrix, 1, median, na.rm = TRUE)
errors <- apply(abs(resid_matrix - estimates), 1, median, na.rm = TRUE)
} else {
estimates <- apply(resid_matrix, 1, mean, na.rm = TRUE)
errors <- apply(resid_matrix, 1, sd, na.rm = TRUE)
}
out <- cbind(estimates, errors, Qlower, Qupper)
colnames(out) <- c(
'Estimate',
'Est.Error',
paste0('Q', 100 * min(probs)),
paste0('Q', 100 * max(probs))
)
} else {
out <- resid_matrix
}
return(out)
}
================================================
FILE: R/sanitise_modelfile.R
================================================
#' Clean up a stan file
#' @noRd
sanitise_modelfile = function(model_file) {
# Remove empty lines
clean_up <- vector()
for (x in 1:length(model_file)) {
clean_up[x] <- trimws(model_file[x]) == "" |
trimws(model_file[x]) == "NA"
}
clean_up[is.na(clean_up)] <- FALSE
model_file <- model_file[!clean_up]
# Expand on backslashes to make model more readable
hashes <- vector()
hashes[1] <- FALSE
for (x in 2:length(model_file)) {
hashes[x] <- grepl('//', model_file[x], fixed = TRUE) &
trimws(model_file[x - 1]) != "" &
(!grepl('{', model_file[x - 1], fixed = TRUE) |
grepl('}', model_file[x - 1], fixed = TRUE)) &
!grepl(';', model_file[x], fixed = TRUE)
}
if (any(hashes)) {
model_file[hashes] <- paste0('\n', model_file[hashes])
}
model_file <- readLines(textConnection(model_file), n = -1)
return(model_file)
}
================================================
FILE: R/score.mvgam_forecast.R
================================================
#' @title Compute probabilistic forecast scores for \pkg{mvgam} models
#'
#' @param object `mvgam_forecast` object. See [forecast.mvgam()]. If the test
#' data supplied to \code{forecast.mvgam} contained out of sample test
#' observations, the calibration of probabilistic forecasts can be scored
#' using proper scoring rules
#'
#' @param ... Ignored
#'
#' @param score \code{character} specifying the type of proper scoring rule
#' to use for evaluation. Options are: `sis` (i.e. the Scaled Interval
#' Score), `energy`, `variogram`, `elpd` (i.e. the Expected log pointwise
#' Predictive Density), `drps` (i.e. the Discrete Rank Probability Score),
#' `crps` (the Continuous Rank Probability Score) or `brier` (the latter
#' of which is only applicable for `bernoulli` models. Note that when
#' choosing `elpd`, the supplied object must have forecasts on the `link`
#' scale so that expectations can be calculated prior to scoring. If
#' choosing `brier`, the object must have forecasts on the `expected` scale
#' (i.e. probability predictions). For all other scores, forecasts should
#' be supplied on the `response` scale (i.e. posterior predictions)
#'
#' @param log \code{logical}. Should the forecasts and truths be logged
#' prior to scoring? This is often appropriate for comparing performance
#' of models when series vary in their observation ranges. Ignored if
#' `score = 'brier'`
#'
#' @param weights optional \code{vector} of weights (where
#' \code{length(weights) == n_series}) for weighting pairwise correlations
#' when evaluating the variogram score for multivariate forecasts. Useful
#' for down-weighting series that have larger magnitude observations or
#' that are of less interest when forecasting. Ignored if
#' \code{score != 'variogram'}
#'
#' @param interval_width proportional value on `[0.05,0.95]` defining the
#' forecast interval for calculating coverage and, if `score = 'sis'`, for
#' calculating the interval score. Ignored if `score = 'brier'`
#'
#' @param n_cores \code{integer} specifying number of cores for calculating
#' scores in parallel
#'
#' @return A \code{list} containing scores and interval coverages per
#' forecast horizon. If \code{score %in% c('drps', 'crps', 'elpd', 'brier')},
#' the list will also contain return the sum of all series-level scores
#' per horizon. If \code{score %in% c('energy','variogram')}, no
#' series-level scores are computed and the only score returned will be
#' for all series. For all scores apart from `elpd` and `brier`, the
#' `in_interval` column in each series-level slot is a binary indicator of
#' whether or not the true value was within the forecast's corresponding
#' posterior empirical quantiles. Intervals are not calculated when using
#' `elpd` because forecasts will only contain the linear predictors
#'
#' @author Nicholas J Clark
#'
#' @method score mvgam_forecast
#'
#' @references Gneiting, T. and Raftery, A. E. (2007). Strictly Proper
#' Scoring Rules, Prediction, and Estimation. \emph{Journal of the American
#' Statistical Association}, 102(477), 359-378.
#' \doi{10.1198/016214506000001437}
#'
#' @seealso \code{\link{forecast.mvgam}}, \code{\link{ensemble}}
#'
#' @examples
#' \dontrun{
#' # Simulate observations for three count-valued time series
#' data <- sim_mvgam()
#'
#' # Fit a dynamic model using 'newdata' to automatically produce forecasts
#' mod <- mvgam(
#' y ~ 1,
#' trend_model = RW(),
#' data = data$data_train,
#' newdata = data$data_test,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract forecasts into a 'mvgam_forecast' object
#' fc <- forecast(mod)
#' plot(fc)
#'
#' # Compute Discrete Rank Probability Scores and 0.90 interval coverages
#' fc_scores <- score(fc, score = 'drps')
#' str(fc_scores)
#'
#' # An example using binary data
#' data <- sim_mvgam(family = bernoulli())
#'
#' mod <- mvgam(
#' y ~ s(season, bs = 'cc', k = 6),
#' trend_model = AR(),
#' data = data$data_train,
#' newdata = data$data_test,
#' family = bernoulli(),
#' chains = 2,
#' silent = 2
#' )
#'
#' # Extract forecasts on the expectation (probability) scale
#' fc <- forecast(mod, type = 'expected')
#' plot(fc)
#'
#' # Compute Brier scores
#' fc_scores <- score(fc, score = 'brier')
#' str(fc_scores)
#' }
#'
#' @export
score.mvgam_forecast = function(
object,
score = 'crps',
log = FALSE,
weights,
interval_width = 0.9,
n_cores = 1,
...
) {
score <- match.arg(
arg = score,
choices = c('crps', 'drps', 'brier', 'elpd', 'sis', 'energy', 'variogram')
)
if (object$type == 'trend') {
stop(
'cannot evaluate accuracy of latent trend forecasts. Use "type == response" when forecasting instead',
call. = FALSE
)
}
if (object$type != 'link' & score == 'elpd') {
stop(
'cannot evaluate elpd scores unless linear predictors are supplied. Use "type == link" when forecasting instead',
call. = FALSE
)
}
if (object$type != 'expected' & score == 'brier') {
stop(
'cannot evaluate brier scores unless probability predictions are supplied. Use "type == expected" when forecasting instead',
call. = FALSE
)
}
validate_pos_integer(n_cores)
validate_proportional(interval_width)
if (interval_width < 0.05 || interval_width > 0.95) {
stop('interval width must be between 0.05 and 0.95, inclusive')
}
# Get truths (out of sample) into correct format
n_series <- length(object$series_names)
truths <- do.call(
rbind,
lapply(seq_len(n_series), function(series) {
object$test_observations[[series]]
})
)
if (score == 'elpd') {
# Get linear predictor forecasts into the correct format
linpreds <- do.call(cbind, object$forecasts)
# Build a dataframe for indexing which series each observation belongs to
newdata <- data.frame(
series = factor(
sort(rep(object$series_names, NCOL(object$forecasts[[1]]))),
levels = levels(object$series_names)
),
y = unname(unlist(object$test_observations))
)
class(object) <- c('mvgam', class(object))
# Calculate log-likelihoods
elpd_score <- logLik(
object = object,
linpreds = linpreds,
newdata = newdata,
family_pars = object$family_pars,
n_cores = n_cores
)
elpd_score <- apply(elpd_score, 2, log_mean_exp)
# Construct series-level score dataframes
series_score <- lapply(seq_len(n_series), function(series) {
DRPS <- data.frame(drps_mcmc_object(
truths[series, ],
object$forecasts[[series]],
log = log,
interval_width = interval_width
))
data.frame(
score = elpd_score[which(
newdata$series == levels(object$series_names)[series]
)],
eval_horizon = seq(1, NCOL(object$forecasts[[1]])),
score_type = 'elpd'
)
})
names(series_score) <- object$series_names
all_scores <- data.frame(
score = rowSums(do.call(
cbind,
lapply(seq_len(n_series), function(series) {
series_score[[series]]$score
})
)),
eval_horizon = seq(1, NCOL(object$forecasts[[1]])),
score_type = 'sum_elpd'
)
series_score$all_series <- all_scores
}
if (score %in% c('energy', 'variogram')) {
if (missing(weights)) {
weights <- rep(1, length(object$series_names))
}
# Calculate coverage using one of the univariate scores
series_score <- lapply(seq_len(n_series), function(series) {
DRPS <- data.frame(drps_mcmc_object(
truths[series, ],
object$forecasts[[series]],
log = log,
interval_width = interval_width
))
colnames(DRPS) <- c('score', 'in_interval')
DRPS$interval_width <- interval_width
DRPS$eval_horizon <- seq(1, NCOL(object$forecasts[[1]]))
DRPS[, 2:4]
})
names(series_score) <- object$series_names
if (score == 'variogram') {
var_score <- variogram_mcmc_object(
truths = truths,
fcs = object$forecasts,
log = log,
weights = weights
)
series_score$all_series <- data.frame(
score = var_score,
eval_horizon = 1:NCOL(object$forecasts[[1]]),
score_type = 'variogram'
)
}
if (score == 'energy') {
en_score <- energy_mcmc_object(
truths = truths,
fcs = object$forecasts,
log = log
)
series_score$all_series <- data.frame(
score = en_score,
eval_horizon = 1:NCOL(object$forecasts[[1]]),
score_type = 'energy'
)
}
}
if (score == 'sis') {
series_score <- lapply(seq_len(n_series), function(series) {
SIS <- data.frame(sis_mcmc_object(
truths[series, ],
object$forecasts[[series]],
log = log,
interval_width = interval_width
))
colnames(SIS) <- c('score', 'in_interval')
SIS$interval_width <- interval_width
SIS$eval_horizon <- seq(1, NCOL(object$forecasts[[1]]))
SIS$score_type <- 'sis'
SIS
})
names(series_score) <- object$series_names
all_scores <- data.frame(
score = rowSums(do.call(
cbind,
lapply(seq_len(n_series), function(series) {
series_score[[series]]$score
})
)),
eval_horizon = seq(1, NCOL(object$forecasts[[1]])),
score_type = 'sum_sis'
)
series_score$all_series <- all_scores
}
if (score == 'drps') {
series_score <- lapply(seq_len(n_series), function(series) {
DRPS <- data.frame(drps_mcmc_object(
truths[series, ],
object$forecasts[[series]],
log = log,
interval_width = interval_width
))
colnames(DRPS) <- c('score', 'in_interval')
DRPS$interval_width <- interval_width
DRPS$eval_horizon <- seq(1, NCOL(object$forecasts[[1]]))
DRPS$score_type <- 'drps'
DRPS
})
names(series_score) <- object$series_names
all_scores <- data.frame(
score = rowSums(do.call(
cbind,
lapply(seq_len(n_series), function(series) {
series_score[[series]]$score
})
)),
eval_horizon = seq(1, NCOL(object$forecasts[[1]])),
score_type = 'sum_drps'
)
series_score$all_series <- all_scores
}
if (score == 'crps') {
series_score <- lapply(seq_len(n_series), function(series) {
CRPS <- data.frame(crps_mcmc_object(
truths[series, ],
object$forecasts[[series]],
log = log,
interval_width = interval_width
))
colnames(CRPS) <- c('score', 'in_interval')
CRPS$interval_width <- interval_width
CRPS$eval_horizon <- seq(1, NCOL(object$forecasts[[1]]))
CRPS$score_type <- 'crps'
CRPS
})
names(series_score) <- object$series_names
all_scores <- data.frame(
score = rowSums(do.call(
cbind,
lapply(seq_len(n_series), function(series) {
series_score[[series]]$score
})
)),
eval_horizon = seq(1, NCOL(object$forecasts[[1]])),
score_type = 'sum_crps'
)
series_score$all_series <- all_scores
}
if (score == 'brier') {
if (object$family != 'bernoulli') {
stop('brier score only applicable for Bernoulli forecasts', call. = FALSE)
}
series_score <- lapply(seq_len(n_series), function(series) {
BRIER <- data.frame(brier_mcmc_object(
truths[series, ],
object$forecasts[[series]],
log = log
))
colnames(BRIER) <- c('score', 'in_interval')
BRIER$interval_width <- interval_width
BRIER$eval_horizon <- seq(1, NCOL(object$forecasts[[1]]))
BRIER$score_type <- 'brier'
BRIER
})
names(series_score) <- object$series_names
all_scores <- data.frame(
score = rowSums(do.call(
cbind,
lapply(seq_len(n_series), function(series) {
series_score[[series]]$score
})
)),
eval_horizon = seq(1, NCOL(object$forecasts[[1]])),
score_type = 'sum_brier'
)
series_score$all_series <- all_scores
}
series_score
}
#'@name score.mvgam_forecast
#'@param object `mvgam_forecast` object. See [forecast.mvgam()].
#'@param ... Ignored
#'@export
score = function(object, ...) {
UseMethod("score", object)
}
================================================
FILE: R/series_to_mvgam.R
================================================
#' Convert timeseries object to format necessary for \pkg{mvgam} models
#'
#' This function converts univariate or multivariate time series (\code{xts} or
#' \code{ts} objects) to the format necessary for \code{\link{mvgam}}.
#'
#' @importFrom stats is.ts ts start time frequency
#'
#' @importFrom utils head
#'
#' @param series \code{\link[xts]{xts}} or \code{\link[stats]{ts}} object to be
#' converted to \code{\link{mvgam}} format
#'
#' @param freq \code{integer}. The seasonal frequency of the series
#'
#' @param train_prop \code{numeric} stating the proportion of data to use for
#' training. Should be between \code{0.25} and \code{0.95}
#'
#' @return A \code{list} object containing outputs needed for
#' \code{\link{mvgam}}, including 'data_train' and 'data_test'
#'
#' @examples
#' # A ts object example
#' data("sunspots")
#' series <- cbind(sunspots, sunspots)
#' colnames(series) <- c('blood', 'bone')
#' head(series)
#' series_to_mvgam(series, frequency(series), 0.85)
#'
#' # An xts object example
#' library(xts)
#' dates <- seq(as.Date("2001-05-01"), length = 30, by = "quarter")
#'
#' data <- cbind(
#' c(gas = rpois(30, cumprod(1 + rnorm(30, mean = 0.01, sd = 0.001)))),
#' c(oil = rpois(30, cumprod(1 + rnorm(30, mean = 0.01, sd = 0.001))))
#' )
#'
#' series <- xts(x = data, order.by = dates)
#' colnames(series) <- c('gas', 'oil')
#' head(series)
#' series_to_mvgam(series, freq = 4, train_prop = 0.85)
#'
#' @export
series_to_mvgam <- function(series, freq, train_prop = 0.85) {
# Check for xts and lubridate packages
insight::check_if_installed("xts")
insight::check_if_installed("lubridate")
# Check series format
type <- 'wrong'
if (is.ts(series)) {
type <- 'ts'
}
if (xts::is.xts(series)) {
type <- 'xts'
}
if (type == 'wrong') {
stop("series must be either a ts or xts object")
}
# Extract information on years and seasons from the series object
if (type == 'ts') {
dates <- lubridate::date_decimal(as.numeric(time(series)))
years <- lubridate::year(dates)
seasons <- as.vector(1 + ((time(series) %% 1) * frequency(series)))
}
# Function to convert xts to ts object
xts.to.ts <- function(x, freq = 52) {
start_time <- head(
1 +
(round(
(lubridate::yday(lubridate::date(time(series))) / 365) *
freq,
0
)),
1
)
ts(
as.numeric(x),
start = c(lubridate::year(start(x)), start_time),
frequency = freq
)
}
if (type == 'xts') {
dates <- lubridate::date(time(series))
years <- lubridate::year(time(series))
seasons <- as.vector(
1 +
((time(xts.to.ts(series[, 1], freq = freq)) %% 1) *
freq)
)
}
# Extract remaining information and put into correct format
n_series <- NCOL(series)
T <- NROW(series)
series_names <- factor(colnames(series), levels = colnames(series))
if (length(levels(series_names)) == 0) {
series_names <- factor(
paste0('series_', seq(1, n_series)),
levels = paste0('series_', seq(1, n_series))
)
}
mvgam_data = data.frame(
y = as.vector(series),
season = rep(seasons, n_series),
year = rep(years, n_series),
date = rep(dates, n_series),
series = as.factor(sort(rep(series_names, T)))
) %>%
dplyr::arrange(year, season, series)
mvgam_data %>%
dplyr::left_join(
mvgam_data %>%
dplyr::select(year, season) %>%
dplyr::distinct() %>%
dplyr::arrange(year, season) %>%
dplyr::mutate(time = dplyr::row_number()),
by = c('season', 'year')
) -> mvgam_data
# Split into training and testing and return
last_time <- floor(max(mvgam_data$time) * train_prop)
return(list(
data_train = mvgam_data %>%
dplyr::filter(time <= last_time),
data_test = mvgam_data %>%
dplyr::filter(time > last_time)
))
}
================================================
FILE: R/shared_obs_params.R
================================================
#' Updates for allowing shared observation params across series
#' @noRd
shared_obs_params = function(model_file, family) {
if (family == 'poisson') {
message(
'Context share_obs_params: Poisson family has no additional observation params'
)
model_file <- model_file
}
if (family == 'nmix') {
message(
'Context share_obs_params: nmix family has no additional observation params'
)
model_file <- model_file
}
if (family %in% c('student', 'gaussian', 'lognormal')) {
model_file[grep(
"vector[n_series] sigma_obs;",
model_file,
fixed = TRUE
)] <-
"real sigma_obs;"
model_file <- model_file[
-grep(
"flat_sigma_obs = rep_each(sigma_obs, n)[obs_ind];",
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep("vector[n_nonmissing] flat_sigma_obs;", model_file, fixed = TRUE)
]
model_file[grep("flat_sigma_obs);", model_file, fixed = TRUE)] <-
'sigma_obs);'
if (any(grepl("flat_sigma_obs,", model_file, fixed = TRUE))) {
model_file[grep("flat_sigma_obs,", model_file, fixed = TRUE)] <-
"sigma_obs,"
model_file[grep(
"data vector Y, matrix X, vector b, vector sigma_obs, real alpha) {",
model_file,
fixed = TRUE
)] <-
"data vector Y, matrix X, vector b, real sigma_obs, real alpha) {"
model_file[grep(
"ptarget += normal_id_glm_lpdf(Y[start:end] | X[start:end], alpha, b, sigma_obs[start:end]);",
model_file,
fixed = TRUE
)] <-
"ptarget += normal_id_glm_lpdf(Y[start:end] | X[start:end], alpha, b, sigma_obs);"
}
model_file[grep(
"sigma_obs_vec[1:n,s] = rep_vector(sigma_obs[s], n);",
model_file,
fixed = TRUE
)] <-
"sigma_obs_vec[1:n,s] = rep_vector(sigma_obs, n);"
}
if (family == 'student') {
model_file[grep(
"vector[n_series] nu;",
model_file,
fixed = TRUE
)] <-
"real nu;"
model_file <- model_file[
-grep("flat_nu = rep_each(nu, n)[obs_ind];", model_file, fixed = TRUE)
]
model_file <- model_file[
-grep("vector[n_nonmissing] flat_nu;", model_file, fixed = TRUE)
]
model_file[grep(
"flat_ys ~ student_t(flat_nu,",
model_file,
fixed = TRUE
)] <-
"flat_ys ~ student_t(nu,"
model_file[grep(
"nu_vec[1:n,s] = rep_vector(nu[s], n);",
model_file,
fixed = TRUE
)] <-
"nu_vec[1:n,s] = rep_vector(nu, n);"
}
if (family == 'negative binomial') {
model_file[grep(
'vector[n_series] phi_inv;',
model_file,
fixed = TRUE
)] <-
'real phi_inv;'
model_file <- model_file[
-grep(
'flat_phis = to_array_1d(rep_each(phi_inv, n)[obs_ind]);',
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep("real flat_phis[n_nonmissing];", model_file, fixed = TRUE)
]
model_file[grep("inv(flat_phis));", model_file, fixed = TRUE)] <-
'inv(phi_inv));'
model_file[grep("phi = inv(phi_inv);", model_file, fixed = TRUE)] <-
"phi = rep_vector(inv(phi_inv), n_series);"
}
if (family == 'beta') {
model_file[grep(
'vector[n_series] phi;',
model_file,
fixed = TRUE
)] <-
'real phi;'
model_file <- model_file[
-grep('flat_phis = rep_each(phi, n)[obs_ind];', model_file, fixed = TRUE)
]
model_file <- model_file[
-grep("vector[n_nonmissing] flat_phis;", model_file, fixed = TRUE)
]
model_file[grep(
"inv_logit(flat_xs * b) .* flat_phis,",
model_file,
fixed = TRUE
)] <-
"inv_logit(flat_xs * b) .* phi,"
model_file[grep(
"(1 - inv_logit(flat_xs * b)) .* flat_phis);",
model_file,
fixed = TRUE
)] <-
"(1 - inv_logit(flat_xs * b)) .* phi);"
model_file[grep(
"inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0)) .* flat_phis,",
model_file,
fixed = TRUE
)] <-
"inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0)) .* phi,"
model_file[grep(
"(1 - inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0))) .* flat_phis);",
model_file,
fixed = TRUE
)] <-
"(1 - inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0))) .* phi);"
model_file[grep(
"phi_vec[1:n,s] = rep_vector(phi[s], n);",
model_file,
fixed = TRUE
)] <-
"phi_vec[1:n,s] = rep_vector(phi, n);"
}
if (family == 'Gamma') {
model_file[grep(
"vector[n_series] shape;",
model_file,
fixed = TRUE
)] <-
"real shape;"
model_file <- model_file[
-grep(
"flat_shapes = rep_each(shape, n)[obs_ind];",
model_file,
fixed = TRUE
)
]
model_file <- model_file[
-grep("vector[n_nonmissing] flat_shapes;", model_file, fixed = TRUE)
]
model_file[grep(
"flat_shapes, flat_shapes ./ exp(flat_xs * b));",
model_file,
fixed = TRUE
)] <-
"shape, shape ./ exp(flat_xs * b));"
model_file[grep(
"flat_shapes, flat_shapes ./ exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0)));",
model_file,
fixed = TRUE
)] <-
"shape, shape ./ exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0)));"
model_file[grep(
"shape_vec[1:n,s] = rep_vector(shape[s], n);",
model_file,
fixed = TRUE
)] <-
"shape_vec[1:n,s] = rep_vector(shape, n);"
}
return(model_file)
}
================================================
FILE: R/sim_mvgam.R
================================================
#' Simulate a set of time series for modelling in \pkg{mvgam}
#'
#' This function simulates sets of time series data for fitting a
#' multivariate GAM that includes shared seasonality and dependence on
#' State-Space latent dynamic factors. Random dependencies among series,
#' i.e. correlations in their long-term trends, are included in the form of
#' correlated loadings on the latent dynamic factors
#'
#' @importFrom stats rnorm rbeta rpois rlnorm rgamma cor cov2cor cov ts
#' @importFrom brms lognormal
#'
#' @param T \code{integer}. Number of observations (timepoints)
#'
#' @param n_series \code{integer}. Number of discrete time series
#'
#' @param seasonality \code{character}. Either \code{shared}, meaning that
#' all series share the exact same seasonal pattern, or
#' \code{hierarchical}, meaning that there is a global seasonality but
#' each series' pattern can deviate slightly
#'
#' @param use_lv \code{logical}. If \code{TRUE}, use dynamic factors to
#' estimate series' latent trends in a reduced dimension format. If
#' \code{FALSE}, estimate independent latent trends for each series
#'
#' @param n_lv \code{integer}. Number of latent dynamic factors for
#' generating the series' trends. Defaults to `0`, meaning that dynamics
#' are estimated independently for each series
#'
#' @param trend_model \code{character} specifying the time series dynamics
#' for the latent trend. Options are:
#' \itemize{
#' \item `None` (no latent trend component; i.e. the GAM component is
#' all that contributes to the linear predictor, and the observation
#' process is the only source of error; similarly to what is estimated
#' by \code{\link[mgcv]{gam}})
#' \item `RW` (random walk with possible drift)
#' \item `AR1` (with possible drift)
#' \item `AR2` (with possible drift)
#' \item `AR3` (with possible drift)
#' \item `VAR1` (contemporaneously uncorrelated VAR1)
#' \item `VAR1cor` (contemporaneously correlated VAR1)
#' \item `GP` (Gaussian Process with squared exponential kernel)
#' }
#' See [mvgam_trends] for more details
#'
#' @param drift \code{logical}, simulate a drift term for each trend
#'
#' @param prop_trend \code{numeric}. Relative importance of the trend for
#' each series. Should be between \code{0} and \code{1}
#'
#' @param trend_rel Deprecated. Use `prop_trend` instead
#'
#' @param freq \code{integer}. The seasonal frequency of the series
#'
#' @param family \code{family} specifying the exponential observation
#' family for the series. Currently supported families are: `nb()`,
#' `poisson()`, `bernoulli()`, `tweedie()`, `gaussian()`, `betar()`,
#' `lognormal()`, `student()` and `Gamma()`
#'
#' @param phi \code{vector} of dispersion parameters for the series
#' (i.e. `size` for `nb()` or `phi` for `betar()`). If
#' \code{length(phi) < n_series}, the first element of `phi` will be
#' replicated `n_series` times. Defaults to \code{5} for `nb()` and
#' `tweedie()`; \code{10} for `betar()`
#'
#' @param shape \code{vector} of shape parameters for the series
#' (i.e. `shape` for `gamma()`). If \code{length(shape) < n_series},
#' the first element of `shape` will be replicated `n_series` times.
#' Defaults to \code{10}
#'
#' @param sigma \code{vector} of scale parameters for the series
#' (i.e. `sd` for `gaussian()` or `student()`, `log(sd)` for
#' `lognormal()`). If \code{length(sigma) < n_series}, the first element
#' of `sigma` will be replicated `n_series` times. Defaults to
#' \code{0.5} for `gaussian()` and `student()`; \code{0.2} for
#' `lognormal()`
#'
#' @param nu \code{vector} of degrees of freedom parameters for the series
#' (i.e. `nu` for `student()`). If \code{length(nu) < n_series}, the
#' first element of `nu` will be replicated `n_series` times. Defaults
#' to \code{3}
#'
#' @param mu \code{vector} of location parameters for the series. If
#' \code{length(mu) < n_series}, the first element of `mu` will be
#' replicated `n_series` times. Defaults to small random values between
#' `-0.5` and `0.5` on the link scale
#'
#' @param prop_missing \code{numeric} stating proportion of observations
#' that are missing. Should be between \code{0} and \code{0.8}, inclusive
#'
#' @param prop_train \code{numeric} stating the proportion of data to use
#' for training. Should be between \code{0.2} and \code{1}
#'
#' @return A \code{list} object containing outputs needed for
#' \code{\link{mvgam}}, including 'data_train' and 'data_test', as well
#' as some additional information about the simulated seasonality and
#' trend dependencies
#'
#' @references Clark, N. J. and Wells, K. (2022). Dynamic generalised
#' additive models (DGAMs) for forecasting discrete ecological time
#' series. \emph{Methods in Ecology and Evolution}, 13(11), 2388-2404.
#' \doi{10.1111/2041-210X.13974}
#'
#' @examples
#' # Simulate series with observations bounded at 0 and 1 (Beta responses)
#' sim_data <- sim_mvgam(
#' family = betar(),
#' trend_model = RW(),
#' prop_trend = 0.6
#' )
#' plot_mvgam_series(data = sim_data$data_train, series = 'all')
#'
#' # Now simulate series with overdispersed discrete observations
#' sim_data <- sim_mvgam(
#' family = nb(),
#' trend_model = RW(),
#' prop_trend = 0.6,
#' phi = 10
#' )
#' plot_mvgam_series(data = sim_data$data_train, series = 'all')
#'
#' @export
sim_mvgam = function(
T = 100,
n_series = 3,
seasonality = 'shared',
use_lv = FALSE,
n_lv = 0,
trend_model = RW(),
drift = FALSE,
prop_trend = 0.2,
trend_rel,
freq = 12,
family = poisson(),
phi,
shape,
sigma,
nu,
mu,
prop_missing = 0,
prop_train = 0.85
) {
# Validate the family argument
family <- validate_family(family)
family_char <- match.arg(
arg = family$family,
choices = c(
'negative binomial',
"poisson",
"bernoulli",
"tweedie",
"beta",
"gaussian",
"lognormal",
"student",
"Gamma"
)
)
# Validate the trend arguments
trend_model <- validate_trend_model(trend_model, drift = drift, warn = FALSE)
if (trend_model %in% c('VAR1', 'VAR1cor')) {
use_lv <- FALSE
}
if (trend_model %in% c('RWcor', 'AR1cor', 'AR2cor', 'AR3cor')) {
warning(paste0(
'Simulation of correlated AR or RW trends not yet supported.\n',
'Reverting to uncorrelated trends'
))
}
if (missing(trend_rel)) {
trend_rel <- prop_trend
}
validate_proportional(trend_rel)
# Check n_series
validate_pos_integer(n_series)
# Check prop_missing
validate_proportional(prop_missing)
# Check n_lv
if (n_lv == 0) {
use_lv <- FALSE
n_lv <- n_series
} else {
validate_pos_integer(n_lv)
use_lv <- TRUE
}
if (use_lv) {
if (n_lv > n_series) {
warning(
'Argument "n_lv" cannot be greater than n_series; changing n_lv to match n_series'
)
n_lv <- n_series
}
}
# Check seasonality
if (!seasonality %in% c('shared', 'hierarchical')) {
stop('seasonality must be either shared or hierarchical')
}
# Check family-specific parameters
if (missing(phi)) {
if (family_char == 'beta') {
phi <- rep(10, n_series)
} else {
phi <- rep(5, n_series)
}
}
if (any(phi <= 0)) {
stop('Argument "phi" must be a non-negative real number', call. = FALSE)
}
if (missing(shape)) {
shape <- rep(1, n_series)
}
if (any(shape <= 0)) {
stop('Argument "shape" must be a non-negative real number', call. = FALSE)
}
if (missing(sigma)) {
if (family_char == 'lognormal') {
sigma <- rep(0.2, n_series)
} else {
sigma <- rep(0.5, n_series)
}
}
if (any(sigma <= 0)) {
stop('Argument "sigma" must be a non-negative real number', call. = FALSE)
}
if (missing(nu)) {
nu <- rep(3, n_series)
}
if (any(nu <= 0)) {
stop('Argument "nu" must be a non-negative real number', call. = FALSE)
}
if (missing(mu)) {
mu <- sample(seq(-0.5, 0.5), n_series, TRUE)
}
if (length(phi) < n_series) {
phi <- rep(phi[1], n_series)
}
if (length(shape) < n_series) {
shape <- rep(shape[1], n_series)
}
if (length(sigma) < n_series) {
sigma <- rep(sigma[1], n_series)
}
if (length(nu) < n_series) {
nu <- rep(nu[1], n_series)
}
if (length(mu) < n_series) {
mu <- rep(mu[1], n_series)
}
# Check data splitting
if (missing(prop_train)) {
prop_train <- 0.75
}
if (prop_train < 0.2 || prop_train > 1) {
stop(
'Argument "prop_train" must be a proportion ranging from 0.2 to 1, inclusive',
call. = FALSE
)
}
# Set trend parameters
if (trend_model %in% c('RW', 'RWcor')) {
ar1s <- rep(1, n_lv)
ar2s <- rep(0, n_lv)
ar3s <- rep(0, n_lv)
}
if (trend_model %in% c('AR1', 'AR1cor')) {
ar1s <- rnorm(n_lv, sd = 0.5)
ar2s <- rep(0, n_lv)
ar3s <- rep(0, n_lv)
}
if (trend_model %in% c('AR2', 'AR2cor')) {
ar1s <- rnorm(n_lv, sd = 0.5)
ar2s <- rnorm(n_lv, sd = 0.5)
ar3s <- rep(0, n_lv)
}
if (trend_model %in% c('AR3', 'AR3cor')) {
ar1s <- rnorm(n_lv, sd = 0.5)
ar2s <- rnorm(n_lv, sd = 0.5)
ar3s <- rnorm(n_lv, sd = 0.5)
}
if (trend_model %in% c('RW', 'AR1', 'AR2', 'AR3', 'VAR1', 'VAR1cor')) {
# Sample trend drift terms so they are (hopefully) not too correlated
if (drift) {
trend_alphas <- rnorm(n_lv, sd = 0.5)
} else {
trend_alphas <- rep(0, n_lv)
}
# Simulate latent trends
if (!trend_model %in% c('VAR1', 'VAR1cor')) {
trends <- do.call(
cbind,
lapply(seq_len(n_lv), function(x) {
sim_ar3(
drift = 0,
ar1 = ar1s[x],
ar2 = ar2s[x],
ar3 = ar3s[x],
tau = 1,
last_trends = rnorm(3),
h = T
) +
trend_alphas[x] * 1:T
})
)
}
if (trend_model %in% c('VAR1', 'VAR1cor')) {
if (trend_model == 'VAR1') {
# Simulate the Sigma matrix (contemporaneously uncorrelated)
Sigma <- matrix(0, n_lv, n_lv)
sigma <- runif(n_lv, 0.4, 1.2)
diag(Sigma) <- sigma
}
if (trend_model == 'VAR1cor') {
# Use the LKJ distribution to sample correlation matrices
# with nice properties
# Sample trend SD parameters and construct Sigma
sigma <- runif(n_lv, 0.4, 1.2)
Sigma <- outer(sigma, sigma) * lkj_corr(n_series = n_lv)
}
# Create a stationary VAR coefficient matrix
A <- stationary_VAR_phi(p = 1, n_series = n_lv)[[1]]
# Simulate the VAR trends
trends <- sim_var1(
drift = trend_alphas,
A = A,
Sigma = Sigma,
last_trends = mvnfast::rmvn(n = 1, mu = rep(0, n_lv), sigma = Sigma),
h = T
)
}
}
if (trend_model == 'GP') {
# Sample alpha and rho parameters
trend_alphas <- runif(n_lv, 0.75, 1.25)
trend_rhos <- runif(n_lv, 3, 8)
# Generate latent GP trends
trends <- do.call(
cbind,
lapply(seq_len(n_lv), function(lv) {
Sigma <- trend_alphas[lv]^2 *
exp(-0.5 * ((outer(1:T, 1:T, "-") / trend_rhos[lv])^2)) +
diag(1e-9, T)
mvnfast::rmvn(1, mu = rep(0, T), sigma = Sigma)[1, ]
})
)
}
if (use_lv) {
Sigma <- random_Sigma(n_series)
loadings <- as.matrix(matrix(
mvnfast::rmvn(n = n_lv, mu = rep(0, n_series), sigma = Sigma),
ncol = n_series
))
} else {
# Else use independent trend loadings
loadings <- diag(n_lv)
}
# Simulate the global seasonal pattern
glob_season <- periodic_gp(T, period = freq, rho = runif(1, 0.5, 1.2))
# Simulate observed series as dependent on seasonality and trend
obs_trends <- matrix(NA, nrow = T, ncol = n_series)
for (s in 1:n_series) {
obs_trends[, s] <- as.vector(scale(as.vector(loadings[, s] %*% t(trends))))
}
obs_ys <- c(unlist(lapply(seq_len(n_series), function(x) {
if (seasonality == 'shared') {
dynamics <- (glob_season * (1 - trend_rel)) +
(obs_trends[, x] * trend_rel)
} else {
yseason <- as.vector(scale(stats::stl(
ts(rnorm(T, glob_season, sd = 2), frequency = freq),
'periodic'
)$time.series[, 1]))
dynamics <- (yseason * (1 - trend_rel)) +
(obs_trends[, x] * trend_rel)
}
if (family_char == 'negative binomial') {
out <- rnbinom(
length(dynamics),
size = phi[x],
mu = exp(mu[x] + dynamics)
)
}
if (family_char == 'poisson') {
out <- rpois(length(dynamics), lambda = exp(mu[x] + dynamics))
}
if (family_char == 'bernoulli') {
out <- rbinom(length(dynamics), size = 1, prob = plogis(mu[x] + dynamics))
}
if (family_char == 'tweedie') {
out <- rpois(
n = length(dynamics),
lambda = tweedie::rtweedie(
length(dynamics),
mu = exp(mu[x] + dynamics),
power = 1.5,
phi = phi[x]
)
)
}
if (family_char == 'gaussian') {
out <- rnorm(length(dynamics), mean = mu[x] + dynamics, sd = sigma[x])
}
if (family_char == 'student') {
out <- rstudent_t(
n = length(dynamics),
df = nu[x],
mu = mu[x] + dynamics,
sigma = sigma[x]
)
}
if (family_char == 'lognormal') {
out <- rlnorm(
length(dynamics),
meanlog = mu[x] + (dynamics * 0.3),
sdlog = sigma[x]
)
}
if (family_char == 'Gamma') {
out <- rgamma(
length(dynamics),
rate = shape[x] / exp(mu[x] + dynamics),
shape = shape[x]
)
}
if (family_char == 'beta') {
shape_pars <- beta_shapes(mu = plogis(mu[x] + dynamics), phi = phi[x])
out <- rbeta(
length(dynamics),
shape1 = shape_pars$shape1,
shape2 = shape_pars$shape2
)
}
out[is.infinite(out)] <- NA
if (prop_missing > 0) {
out[sample(seq(1, length(out)), floor(length(out) * prop_missing))] <- NA
}
out
})))
# Return simulated data in the format that is ready for mvgam analysis
sim_data = data.frame(
y = obs_ys,
season = rep(rep(seq(1, freq), ceiling(T / freq))[1:T], n_series),
year = rep(sort(rep(seq(1, ceiling(T / freq)), freq))[1:T], n_series),
series = as.factor(paste0('series_', sort(rep(seq(1, n_series), T))))
) %>%
dplyr::group_by(series) %>%
dplyr::arrange(year, season) %>%
dplyr::mutate(time = 1:dplyr::n()) %>%
dplyr::ungroup()
data_train <- sim_data %>%
dplyr::filter(time <= floor(max(sim_data$time) * prop_train)) %>%
dplyr::ungroup() %>%
dplyr::group_by(series) %>%
dplyr::arrange(time)
data_test <- sim_data %>%
dplyr::filter(time > max(data_train$time)) %>%
dplyr::ungroup() %>%
dplyr::group_by(series) %>%
dplyr::arrange(time)
if (!use_lv) {
if (trend_model %in% c('RW', 'AR1', 'AR2', 'AR3')) {
trend_params = list(ar1 = ar1s, ar2 = ar2s, ar3 = ar3s)
}
if (trend_model %in% c('VAR1', 'VAR1cor')) {
trend_params = list(var1 = A, Sigma = Sigma)
}
if (trend_model == 'GP') {
trend_params = list(alpha = trend_alphas, rho = trend_rhos)
}
out <- list(
data_train = data.frame(data_train),
data_test = data.frame(data_test),
true_corrs = cov2cor(cov(obs_trends)),
true_trends = obs_trends,
global_seasonality = glob_season,
trend_params = trend_params
)
} else {
out <- list(
data_train = data.frame(data_train),
data_test = data.frame(data_test),
true_corrs = cov2cor(cov(obs_trends)),
true_trends = obs_trends,
global_seasonality = glob_season
)
}
return(out)
}
#' Simulate a fixed seasonal pattern
#' @noRd
sim_seasonal = function(T, freq = 12) {
beta1 <- runif(1, 0.2, 0.6)
beta2 <- runif(1, -0.5, 0.5)
cov1 <- sin(2 * pi * (1:T) / freq)
cov2 <- cos(2 * pi * (1:T) / freq)
rnorm(T, mean = beta1 * cov1 + beta2 * cov2, sd = 0.1)
}
#' Simulate from a periodic GP
#' @noRd
periodic_gp <- function(T, period = 12, rho = 1) {
time <- 1:T
cov_matrix = array(0, c(length(time), length(time)))
for (i in 1:length(time)) {
cov_matrix[i, i] = 1 + 0.00000001
if (i < length(time)) {
for (j in (i + 1):length(time)) {
covariance = exp(
-2 * (sin(pi * abs(time[i] - time[j]) / period)^2) / (rho^2)
)
cov_matrix[i, j] = covariance
cov_matrix[j, i] = covariance
}
}
}
chol_cov <- t(chol(cov_matrix))
values <- as.vector(scale(chol_cov %*% rnorm(length(time))))
return(values)
}
#' Simulate from the LKJ distribution
#' @noRd
lkj_corr <- function(n_series, eta = 0.8) {
alpha <- eta + (n_series - 2) / 2
r12 <- 2 * rbeta(1, alpha, alpha) - 1
R <- matrix(0, n_series, n_series)
R[1, 1] <- 1
R[1, 2] <- r12
R[2, 2] <- sqrt(1 - r12^2)
if (n_series > 2) {
for (m in 2:(n_series - 1)) {
alpha <- alpha - 0.5
y <- rbeta(1, m / 2, alpha)
z <- rnorm(m, 0, 1)
z <- z / sqrt(crossprod(z)[1])
R[1:m, m + 1] <- sqrt(y) * z
R[m + 1, m + 1] <- sqrt(1 - y)
}
}
return(crossprod(R))
}
#' Generate a random covariance matrix
#' @noRd
random_Sigma = function(N) {
L_Omega <- matrix(0, N, N)
L_Omega[1, 1] <- 1
for (i in 2:N) {
bound <- 1
for (j in 1:(i - 1)) {
is_sparse <- rbinom(1, 1, 0.6)
if (is_sparse) {
L_Omega[i, j] <- runif(1, -0.05, 0.05)
} else {
L_Omega[i, j] <- runif(1, -sqrt(bound), sqrt(bound))
}
bound <- bound - L_Omega[i, j]^2
}
L_Omega[i, i] <- sqrt(bound)
}
Sigma <- L_Omega %*% t(L_Omega)
return(Sigma)
}
================================================
FILE: R/stability.R
================================================
#' Calculate measures of latent VAR community stability
#'
#' Compute reactivity, return rates and contributions of interactions to
#' stationary forecast variance from \pkg{mvgam} models with Vector
#' Autoregressive dynamics.
#'
#' @name stability.mvgam
#'
#' @param object \code{list} object of class \code{mvgam} resulting from a call
#' to [mvgam()] that used a Vector Autoregressive latent process model (either
#' as `VAR(cor = FALSE)` or `VAR(cor = TRUE)`)
#'
#' @param ... Ignored
#'
#' @details These measures of stability can be used to assess how important
#' inter-series dependencies are to the variability of a multivariate system
#' and to ask how systems are expected to respond to environmental
#' perturbations. Using the formula for a latent VAR(1) as:
#'
#' \deqn{
#' \mu_t \sim \text{MVNormal}(A(\mu_{t - 1}), \Sigma)
#' }
#'
#' this function will calculate the long-term stationary forecast distribution
#' of the system, which has mean \eqn{\mu_{\infty}} and variance
#' \eqn{\Sigma_{\infty}}, to then calculate the following quantities:
#'
#' \itemize{
#' \item `prop_int`: Proportion of the volume of the stationary forecast
#' distribution that is attributable to lagged interactions:
#' \deqn{ det(A)^2 }
#'
#' \item `prop_int_adj`: Same as `prop_int` but scaled by the number of
#' series \eqn{p}:
#' \deqn{ det(A)^{2/p} }
#'
#' \item `prop_int_offdiag`: Sensitivity of `prop_int` to inter-series
#' interactions (off-diagonals of \eqn{A}):
#' \deqn{ [2~det(A) (A^{-1})^T] }
#'
#' \item `prop_int_diag`: Sensitivity of `prop_int` to intra-series
#' interactions (diagonals of \eqn{A}):
#' \deqn{ [2~det(A) (A^{-1})^T] }
#'
#' \item `prop_cov_offdiag`: Sensitivity of \eqn{\Sigma_{\infty}} to
#' inter-series error correlations:
#' \deqn{ [2~det(\Sigma_{\infty}) (\Sigma_{\infty}^{-1})^T] }
#'
#' \item `prop_cov_diag`: Sensitivity of \eqn{\Sigma_{\infty}} to error
#' variances:
#' \deqn{ [2~det(\Sigma_{\infty}) (\Sigma_{\infty}^{-1})^T] }
#'
#' \item `reactivity`: Degree to which the system moves away from a stable
#' equilibrium following a perturbation. If \eqn{\sigma_{max}(A)} is the
#' largest singular value of \eqn{A}:
#' \deqn{ \log\sigma_{max}(A) }
#'
#' \item `mean_return_rate`: Asymptotic return rate of the mean of the
#' transition distribution to the stationary mean:
#' \deqn{ \max(\lambda_{A}) }
#'
#' \item `var_return_rate`: Asymptotic return rate of the variance of the
#' transition distribution to the stationary variance:
#' \deqn{ \max(\lambda_{A \otimes A}) }
#' }
#'
#' Major advantages of using \pkg{mvgam} to compute these metrics are that
#' well-calibrated uncertainties are available and that VAR processes are
#' forced to be stationary. These properties make it simple and insightful to
#' calculate and inspect aspects of both long-term and short-term stability.
#'
#' You can also inspect interactions among the time series in a latent VAR
#' process using \code{\link{irf}} for impulse response functions or
#' \code{\link{fevd}} for forecast error variance decompositions.
#'
#' @return A \code{data.frame} containing posterior draws for each stability
#' metric.
#'
#' @references
#' AR Ives, B Dennis, KL Cottingham & SR Carpenter (2003). Estimating
#' community stability and ecological interactions from time-series data.
#' *Ecological Monographs*, 73, 301–330.
#'
#' @author Nicholas J Clark
#'
#' @seealso
#' \code{\link{VAR}},
#' \code{\link{irf}},
#' \code{\link{fevd}}
#'
#' @examples
#' \dontrun{
#' # Simulate some time series that follow a latent VAR(1) process
#' simdat <- sim_mvgam(
#' family = gaussian(),
#' n_series = 4,
#' trend_model = VAR(cor = TRUE),
#' prop_trend = 1
#' )
#'
#' plot_mvgam_series(data = simdat$data_train, series = 'all')
#'
#' # Fit a model that uses a latent VAR(1)
#' mod <- mvgam(
#' y ~ -1,
#' trend_formula = ~ 1,
#' trend_model = VAR(cor = TRUE),
#' family = gaussian(),
#' data = simdat$data_train,
#' chains = 2,
#' silent = 2
#' )
#'
#' # Calculate stability metrics for this system
#' metrics <- stability(mod)
#'
#' # Proportion of stationary forecast distribution attributable to interactions
#' hist(
#' metrics$prop_int,
#' xlim = c(0, 1),
#' xlab = 'Prop_int',
#' main = '',
#' col = '#B97C7C',
#' border = 'white'
#' )
#'
#' # Inter- vs intra-series interaction contributions
#' layout(matrix(1:2, nrow = 2))
#' hist(
#' metrics$prop_int_offdiag,
#' xlim = c(0, 1),
#' xlab = '',
#' main = 'Inter-series interactions',
#' col = '#B97C7C',
#' border = 'white'
#' )
#'
#' hist(
#' metrics$prop_int_diag,
#' xlim = c(0, 1),
#' xlab = 'Contribution to interaction effect',
#' main = 'Intra-series interactions (density dependence)',
#' col = 'darkblue',
#' border = 'white'
#' )
#' layout(1)
#'
#' # Inter- vs intra-series contributions to forecast variance
#' layout(matrix(1:2, nrow = 2))
#' hist(
#' metrics$prop_cov_offdiag,
#' xlim = c(0, 1),
#' xlab = '',
#' main = 'Inter-series covariances',
#' col = '#B97C7C',
#' border = 'white'
#' )
#'
#' hist(
#' metrics$prop_cov_diag,
#' xlim = c(0, 1),
#' xlab = 'Contribution to forecast variance',
#' main = 'Intra-series variances',
#' col = 'darkblue',
#' border = 'white'
#' )
#' layout(1)
#'
#' # Reactivity: system response to perturbation
#' hist(
#' metrics$reactivity,
#' main = '',
#' xlab = 'Reactivity',
#' col = '#B97C7C',
#' border = 'white',
#' xlim = c(
#' -1 * max(abs(metrics$reactivity)),
#' max(abs(metrics$reactivity))
#' )
#' )
#' abline(v = 0, lwd = 2.5)
#' }
#'
#' @export
stability <- function(object, ...) {
UseMethod("stability", object)
}
#'@rdname stability.mvgam
#'@method stability mvgam
#'@export
stability.mvgam = function(object, ...) {
# Check trend_model
trend_model <- attr(object$model_data, 'trend_model')
if (!trend_model %in% c('VAR', 'VARcor', 'VAR1', 'VAR1cor')) {
stop(
'Only VAR(1) models currently supported for calculating stability metrics',
call. = FALSE
)
}
# Take posterior draws of the interaction matrix
B_post <- mcmc_chains(object$model_output, 'A')
# Take posterior draws of Sigma
Sigma_post <- mcmc_chains(object$model_output, 'Sigma')
# Number of series in the VAR process
n_series <- object$n_lv
if (is.null(n_series)) {
n_series <- nlevels(object$obs_data$series)
}
metrics <- do.call(
rbind,
lapply(seq_len(NROW(B_post)), function(i) {
B <- matrix(B_post[i, ], nrow = n_series, ncol = n_series, byrow = TRUE)
p <- dim(B)[1]
# If we want to get the variance of the stationary distribution (Sigma_inf)
Sigma <- matrix(
Sigma_post[i, ],
nrow = n_series,
ncol = n_series,
byrow = TRUE
)
vecS_inf <- solve(diag(p * p) - kronecker(B, B)) %*% as.vector(Sigma)
Sigma_inf <- matrix(vecS_inf, nrow = p)
# The difference in volume between Sigma_inf and Sigma is:
# det(Sigma_inf - Sigma) = det(Sigma_inf) * det(B) ^ 2
# according to Ives et al 2003 (eqn 24)
# We can take partial derivatives to determine which elements of
# Sigma_inf contribute most to rates of change in the
# proportion of Sigma_inf that is due to process error
# Thanks to Mark Scheuerell for providing inspirational code
# https://github.com/mdscheuerell/safs-quant-sem-2022/blob/main/lwa_analysis.R
int_env <- det(Sigma_inf) * t(solve(Sigma_inf))
# Proportion of inter-series covariance to
# to overall environmental variation contribution (i.e. how important are
# correlated errors for controlling the shape of the stationary forecast
# distribution?)
dat <- data.frame(
prop_cov_offdiag = mean(abs(int_env[lower.tri(int_env)])) /
(mean(abs(diag(int_env))) + mean(abs(int_env[lower.tri(int_env)])))
)
# Proportion of error variances to stationary forecast distribution
dat$prop_cov_diag <- 1 - dat$prop_cov_offdiag
# Proportion of volume of Sigma_inf attributable to series interactions,
# measuring the degree to which interactions increase
# the variance of the stationary distribution (Sigma_inf) relative
# to the variance of the process error (Sigma)
# lower values = more stability
dat$prop_int = abs(det(B))^2
# Ives et al 2003 suggest to scale this by the number of series for more direct
# comparisons among different studies
dat$prop_int_adj <- abs(det(B))^(2 / p)
# Sensitivity of the species interaction proportion to particular
# interactions is also calculated using partial derivatives
# (note the use of 2 here because we squared det(B) in the above eqn)
int_sens <- 2 * det(B) * t(solve(B))
# Proportion of interspecific contributions to
# to overall interaction contribution
dat$prop_int_offdiag <- mean(abs(int_sens[lower.tri(int_sens)])) /
(mean(abs(diag(int_sens))) + mean(abs(int_sens[lower.tri(int_sens)])))
# Proportion of density dependent contributions to
# to overall interaction contribution
dat$prop_int_diag <- 1 - dat$prop_int_offdiag
# Reactivity, measuring the degree to which the system moves
# away from a stable equilibrium following a perturbation
# values > 0 suggest the system is reactive, whereby a
# perturbation of the system in one period can be amplified in the next period
# Following Neubert et al 2009 Ecology (Detecting reactivity)
dat$reactivity <- log(max(svd(B)$d))
# Return rate of transition distribution to the stationary distribution
# Asymptotic return rate of the mean
# lower values = more stability
dat$mean_return_rate <- max(abs(eigen(B)$values))
# Asymptotic return rate of the variance
# lower values = more stability
dat$var_return_rate <- max(abs(eigen(B %x% B)$values))
dat
})
)
return(metrics)
}
================================================
FILE: R/stan_utils.R
================================================
#' Stan code and data objects for \pkg{mvgam} models
#'
#' Generate Stan code and data objects for \pkg{mvgam} models
#'
#' @param object An object of class `mvgam` or `mvgam_prefit`,
#' returned from a call to \code{mvgam}
#' @return Either a character string containing the fully commented \pkg{Stan} code
#' to fit a \pkg{mvgam} model or a named list containing the data objects needed
#' to fit the model in Stan.
#' @export
#' @examples
#'\dontrun{
#' simdat <- sim_mvgam()
#' mod <- mvgam(y ~ s(season) +
#' s(time, by = series),
#' family = poisson(),
#' data = simdat$data_train,
#' run_model = FALSE)
#'
#' # View Stan model code
#' stancode(mod)
#'
#' # View Stan model data
#' sdata <- standata(mod)
#' str(sdata)
#' }
#'
code = function(object) {
if (!inherits(object, c('mvgam', 'mvgam_prefit'))) {
stop('argument "object" must be of class "mvgam" or "mvgam_prefit"')
}
scode <- readLines(textConnection(object$model_file), n = -1)
class(scode) <- c("character", "mvgammodel")
scode
}
#' @export
print.mvgammodel = function(x, ...) {
cat(x, sep = '\n')
invisible(x)
}
#' @export
#' @importFrom brms stancode
brms::stancode
#' @export
#' @param ... ignored
#' @rdname code
stancode.mvgam_prefit = function(object, ...) {
code(object)
}
#' @export
#' @rdname code
stancode.mvgam = function(object, ...) {
code(object)
}
#' @export
#' @importFrom brms standata
brms::standata
#' @export
#' @param ... ignored
#' @rdname code
standata.mvgam_prefit = function(object, ...) {
object$model_data
}
#' @noRd
remove_likelihood = function(model_file) {
like_line <- grep('// likelihood functions', model_file)
all_open_braces <- grep('{', model_file, fixed = TRUE)
all_close_braces <- grep('}', model_file, fixed = TRUE)
open_distances <- like_line - all_open_braces
open_distances[open_distances < 0] <- NA
start_remove <- all_open_braces[
which.min(open_distances)
]
close_distances <- like_line - all_close_braces
close_distances[close_distances > 0] <- NA
end_remove <- all_close_braces[
which.max(close_distances)
]
model_file[-(start_remove:end_remove)]
}
#### Replacement for MCMCvis functions to remove dependence on rstan for working
# with stanfit objects ####
#' @noRd
mcmc_summary = function(
object,
params = 'all',
excl = NULL,
ISB = TRUE,
exact = TRUE,
probs = c(0.025, 0.5, 0.975),
hpd_prob = 0.95,
HPD = FALSE,
pg0 = FALSE,
digits = NULL,
round = NULL,
Rhat = TRUE,
n.eff = TRUE,
func = NULL,
func_name = NULL,
variational = FALSE
) {
if (variational) {
Rhat <- FALSE
n.eff <- FALSE
}
# SORTING BLOCK
if (methods::is(object, 'matrix')) {
object2 <- mcmc_chains(
object,
params,
excl,
ISB,
exact = exact,
mcmc.list = FALSE
)
} else {
if (methods::is(object, 'stanfit')) {
object2 <- object
} else {
# rstanarm
if (methods::is(object, 'stanreg')) {
object2 <- object$stanfit
} else {
# brms
if (methods::is(object, 'brmsfit')) {
object2 <- object$fit
} else {
#jagsUI
if (methods::is(object, 'jagsUI')) {
object2 <- mcmc_chains(object)
} else {
object2 <- mcmc_chains(
object,
params,
excl,
ISB,
exact = exact,
mcmc.list = TRUE
)
}
}
}
}
}
#--------------------------------------------------------------------------------------------------------------
# PROCESSING BLOCK - JAGS AND MATRIX MCMC OUTPUT
if (coda::is.mcmc.list(object2) == TRUE | methods::is(object, 'matrix')) {
if (methods::is(object, 'matrix')) {
np <- NCOL(object2)
ch_bind <- object2
} else {
np <- NCOL(object2[[1]])
if (np > 1) {
ch_bind <- do.call("rbind", object2)
} else {
ch_bind <- as.matrix(object2)
}
}
x <- list()
# mean, sd, and quantiles
if (!is.null(digits)) {
if (!is.null(round)) {
warning(
"'digits' and 'round' arguments cannot be used together. Using 'digits'."
)
}
bind_mn <- data.frame(signif(apply(ch_bind, 2, mean), digits = digits))
bind_sd <- data.frame(signif(
apply(ch_bind, 2, stats::sd),
digits = digits
))
colnames(bind_mn) <- "mean"
colnames(bind_sd) <- "sd"
if (HPD == FALSE) {
if (length(probs) == 1) {
bind_q <- data.frame(signif(
apply(ch_bind, 2, stats::quantile, probs = probs),
digits = digits
))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
bind_q <- data.frame(t(signif(
apply(ch_bind, 2, stats::quantile, probs = probs),
digits = digits
)))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
}
}
if (HPD == TRUE) {
if (length(hpd_prob) > 1) {
stop(
'specify only a single probability for HPD interval computation.'
)
}
bind_q <- data.frame(signif(
coda::HPDinterval(coda::as.mcmc(ch_bind), prob = hpd_prob),
digits = digits
))
colnames(bind_q) <- c(
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDL"),
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDU")
)
}
}
if (is.null(digits) & !is.null(round)) {
bind_mn <- data.frame(round(apply(ch_bind, 2, mean), digits = round))
bind_sd <- data.frame(round(apply(ch_bind, 2, stats::sd), digits = round))
colnames(bind_mn) <- "mean"
colnames(bind_sd) <- "sd"
if (HPD == FALSE) {
if (length(probs) == 1) {
bind_q <- data.frame(round(
apply(ch_bind, 2, stats::quantile, probs = probs),
digits = round
))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
bind_q <- data.frame(t(round(
apply(ch_bind, 2, stats::quantile, probs = probs),
digits = round
)))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
}
}
if (HPD == TRUE) {
if (length(hpd_prob) > 1) {
stop(
'specify only a single probability for HPD interval computation.'
)
}
bind_q <- data.frame(round(
coda::HPDinterval(coda::as.mcmc(ch_bind), prob = hpd_prob),
digits = round
))
colnames(bind_q) <- c(
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDL"),
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDU")
)
}
}
if (is.null(digits) & is.null(round)) {
bind_mn <- data.frame(apply(ch_bind, 2, mean))
bind_sd <- data.frame(apply(ch_bind, 2, stats::sd))
colnames(bind_mn) <- "mean"
colnames(bind_sd) <- "sd"
if (HPD == FALSE) {
if (length(probs) == 1) {
bind_q <- data.frame(apply(
ch_bind,
2,
stats::quantile,
probs = probs
))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
bind_q <- data.frame(t(apply(
ch_bind,
2,
stats::quantile,
probs = probs
)))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
}
}
if (HPD == TRUE) {
if (length(hpd_prob) > 1) {
stop(
'specify only a single probability for HPD interval computation.'
)
}
bind_q <- data.frame(coda::HPDinterval(
coda::as.mcmc(ch_bind),
prob = hpd_prob
))
colnames(bind_q) <- c(
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDL"),
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDU")
)
}
}
x[[1]] <- cbind(bind_mn, bind_sd, bind_q)
# rhat
if (Rhat == TRUE) {
if (!methods::is(object, 'matrix')) {
if (length(object2) > 1) {
# If > 750 params use loop to calculate Rhat
if (NCOL(object2[[1]]) > 750) {
r_hat <- c(rep(NA, NCOL(object2[[1]])))
for (v in 1:length(r_hat)) {
r_hat[v] <- round(
coda::gelman.diag(object2[, v])$psrf[, 1],
digits = 2
)
}
r_hat <- data.frame(r_hat)
colnames(r_hat) <- "Rhat"
} else {
r_hat <- data.frame(round(
coda::gelman.diag(object2, multivariate = FALSE)$psrf[, 1],
digits = 2
))
colnames(r_hat) <- "Rhat"
}
} else {
warning(
"Rhat statistic cannot be calculated with one chain. NAs inserted."
)
r_hat <- data.frame(rep(NA, np))
colnames(r_hat) <- "Rhat"
}
} else {
warning(
"Rhat statistic cannot be calculated with one chain (matrix input). NAs inserted."
)
r_hat <- data.frame(rep(NA, np))
colnames(r_hat) <- "Rhat"
}
x[[(length(x) + 1)]] <- r_hat
}
# neff
if (n.eff == TRUE) {
if (!methods::is(object, 'matrix')) {
neff <- data.frame(round(coda::effectiveSize(object2), digits = 0))
colnames(neff) <- "n_eff"
} else {
warning(
'Number of effective samples cannot be calculated without individual chains (matrix input). NAs inserted.'
)
neff <- data.frame(rep(NA, np))
colnames(neff) <- "n_eff"
}
x[[(length(x) + 1)]] <- neff
}
# p>0
if (pg0 == TRUE) {
tpg <- data.frame(apply(
ch_bind,
2,
function(x) round(sum(x > 0) / length(x), 2)
))
colnames(tpg) <- 'p>0'
x[[(length(x) + 1)]] <- tpg
}
# custom function
if (!is.null(func)) {
if (!is.null(digits)) {
tmp <- signif(apply(ch_bind, 2, func), digits = digits)
}
if (is.null(digits) & !is.null(round)) {
tmp <- round(apply(ch_bind, 2, func), digits = round)
}
if (is.null(digits) & is.null(round)) {
tmp <- apply(ch_bind, 2, func)
}
if (!is.null(dim(tmp))) {
tmp <- data.frame(t(tmp))
} else {
tmp <- data.frame(tmp)
}
if (!is.null(func_name)) {
if (length(func_name) != NCOL(tmp)) {
stop("length(func_name) must equal number of func outputs")
}
colnames(tmp) <- func_name
} else {
colnames(tmp) <- 'func'
}
x[[(length(x) + 1)]] <- tmp
}
# bind them
mcmc_summary <- do.call("cbind", x)
}
#--------------------------------------------------------------------------------------------------------------
# PROCESSING BLOCK - STAN OR JAGSUI MCMC OUTPUT
if (methods::is(object2, 'stanfit') | methods::is(object, 'jagsUI')) {
if (methods::is(object2, 'stanfit')) {
# rhat and n_eff directly from rstan output
all_params <- row.names(rstan::summary(object2)$summary)
rs_df <- data.frame(rstan::summary(object2)$summary)
#if brms, reassign names without b_ and r_ (as in MCMCchains)
if (methods::is(object, 'brmsfit')) {
sp_names_p <- names(object2@sim$samples[[1]])
#remove b_ and r_
st_nm <- substr(sp_names_p, start = 1, stop = 2)
sp_names <- rep(NA, length(sp_names_p))
b_idx <- which(st_nm == 'b_')
r_idx <- which(st_nm == 'r_')
ot_idx <- which(st_nm != 'b_' & st_nm != 'r_')
#fill names vec with b_ and r_ removed
sp_names[b_idx] <- gsub('b_', '', sp_names_p[b_idx])
sp_names[r_idx] <- gsub('r_', '', sp_names_p[r_idx])
sp_names[ot_idx] <- sp_names_p[ot_idx]
#assign names to df
all_params <- sp_names
row.names(rs_df) <- all_params
}
}
if (methods::is(object, 'jagsUI')) {
all_params <- row.names(object$summary)
rs_df <- data.frame(object$summary)
}
# filtering of parameters from rstan/jagsUI object - from MCMCchains
if (ISB == TRUE) {
names <- vapply(
strsplit(all_params, split = "[", fixed = TRUE),
`[`,
1,
FUN.VALUE = character(1)
)
} else {
names <- all_params
}
x <- list()
# INDEX BLOCK exclusions
if (!is.null(excl)) {
rm_ind <- c()
for (i in 1:length(excl)) {
if (ISB == TRUE) {
n_excl <- vapply(
strsplit(excl, split = "[", fixed = TRUE),
`[`,
1,
FUN.VALUE = character(1)
)
} else {
n_excl <- excl
}
if (exact == TRUE) {
ind_excl <- which(names %in% n_excl[i])
} else {
ind_excl <- grep(n_excl[i], names, fixed = FALSE)
}
if (length(ind_excl) < 1) {
warning(paste0(
"\"",
excl[i],
"\"",
" not found in MCMC output. Check 'ISB'' and 'exact' arguments to make sure the desired parsing methods are being used."
))
}
rm_ind <- c(rm_ind, ind_excl)
}
if (length(rm_ind) > 0) {
dups <- which(duplicated(rm_ind))
if (length(dups) > 0) {
rm_ind2 <- rm_ind[-dups]
} else {
rm_ind2 <- rm_ind
}
} else {
excl <- NULL
}
}
# selections
if (length(params) == 1) {
if (params == "all") {
if (is.null(excl)) {
f_ind <- 1:length(names)
} else {
f_ind <- (1:length(names))[-rm_ind2]
}
} else {
if (exact == TRUE) {
get_ind <- which(names %in% params)
} else {
get_ind <- grep(paste(params), names, fixed = FALSE)
}
if (length(get_ind) < 1) {
stop(paste0(
"\"",
params,
"\"",
" not found in MCMC output. Check 'ISB' and 'exact' arguments to make sure the desired parsing methods are being used."
))
}
if (!is.null(excl)) {
if (identical(get_ind, rm_ind2)) {
stop("No parameters selected.")
}
matched <- stats::na.omit(match(rm_ind2, get_ind))
if (length(matched) > 0) {
f_ind <- get_ind[-matched]
} else {
f_ind <- get_ind
}
} else {
f_ind <- get_ind
}
}
} else {
grouped <- c()
for (i in 1:length(params)) {
if (exact == TRUE) {
get_ind <- which(names %in% params[i])
} else {
get_ind <- grep(paste(params[i]), names, fixed = FALSE)
}
if (length(get_ind) < 1) {
warning(paste0(
"\"",
params[i],
"\"",
" not found in MCMC output. Check 'ISB' and 'exact' arguments to make sure the desired parsing methods are being used."
))
(next)()
}
grouped <- c(grouped, get_ind)
}
if (!is.null(excl)) {
if (identical(grouped, rm_ind2)) {
stop("No parameters selected.")
}
matched <- stats::na.omit(match(rm_ind2, grouped))
if (length(matched) > 0) {
t_ind <- grouped[-matched]
} else {
t_ind <- grouped
}
to.rm <- which(duplicated(t_ind))
if (length(to.rm) > 0) {
f_ind <- t_ind[-to.rm]
} else {
f_ind <- t_ind
}
} else {
to.rm <- which(duplicated(grouped))
if (length(to.rm) > 0) {
f_ind <- grouped[-to.rm]
} else {
f_ind <- grouped
}
}
}
# end sort
# convert object to matrix if computing non default intervals or using custom func
if (
!is.null(func) |
HPD == TRUE |
identical(probs, c(0.025, 0.5, 0.975)) == FALSE |
pg0 == TRUE
) {
if (methods::is(object2, 'stanfit')) {
#ensure is matrix, not vector
ch_bind <- as.matrix(as.matrix(object2)[, f_ind])
}
if (methods::is(object, 'jagsUI')) {
ch_bind <- mcmc_chains(object, params, excl, ISB)
}
}
# mean, sd, and quantiles
if (!is.null(digits)) {
if (!is.null(round)) {
warning(
"'digits' and 'round' arguments cannot be used together. Using 'digits'."
)
}
bind_mn <- data.frame(signif(rs_df["mean"][f_ind, 1], digits = digits))
bind_sd <- data.frame(signif(rs_df["sd"][f_ind, 1], digits = digits))
colnames(bind_mn) <- "mean"
colnames(bind_sd) <- "sd"
if (HPD == FALSE) {
if (length(probs) == 1) {
bind_q <- data.frame(signif(
apply(ch_bind, 2, stats::quantile, probs = probs),
digits = digits
))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
if (identical(probs, c(0.025, 0.5, 0.975)) == TRUE) {
bind_LCI <- signif(rs_df["X2.5."][f_ind, 1], digits = digits)
bind_med <- signif(rs_df["X50."][f_ind, 1], digits = digits)
bind_UCI <- signif(rs_df["X97.5."][f_ind, 1], digits = digits)
bind_q <- data.frame(cbind(bind_LCI, bind_med, bind_UCI))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
bind_q <- data.frame(t(signif(
apply(ch_bind, 2, stats::quantile, probs = probs),
digits = digits
)))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
}
}
}
if (HPD == TRUE) {
if (length(hpd_prob) > 1) {
stop(
'Specify only a single probability for HPD interval computation.'
)
}
bind_q <- data.frame(signif(
coda::HPDinterval(coda::as.mcmc(ch_bind), prob = hpd_prob),
digits = digits
))
colnames(bind_q) <- c(
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDL"),
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDU")
)
}
}
if (is.null(digits) & !is.null(round)) {
bind_mn <- data.frame(round(rs_df["mean"][f_ind, 1], digits = round))
bind_sd <- data.frame(round(rs_df["sd"][f_ind, 1], digits = round))
colnames(bind_mn) <- "mean"
colnames(bind_sd) <- "sd"
if (HPD == FALSE) {
if (length(probs) == 1) {
bind_q <- data.frame(round(
apply(ch_bind, 2, stats::quantile, probs = probs),
digits = round
))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
if (identical(probs, c(0.025, 0.5, 0.975)) == TRUE) {
bind_LCI <- round(rs_df["X2.5."][f_ind, 1], digits = round)
bind_med <- round(rs_df["X50."][f_ind, 1], digits = round)
bind_UCI <- round(rs_df["X97.5."][f_ind, 1], digits = round)
bind_q <- data.frame(cbind(bind_LCI, bind_med, bind_UCI))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
bind_q <- data.frame(t(round(
apply(ch_bind, 2, stats::quantile, probs = probs),
digits = round
)))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
}
}
}
if (HPD == TRUE) {
if (length(hpd_prob) > 1) {
stop(
'Specify only a single probability for HPD interval computation.'
)
}
bind_q <- data.frame(round(
coda::HPDinterval(coda::as.mcmc(ch_bind), prob = hpd_prob),
digits = round
))
colnames(bind_q) <- c(
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDL"),
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDU")
)
}
}
if (is.null(digits) & is.null(round)) {
bind_mn <- data.frame(rs_df["mean"][f_ind, 1])
bind_sd <- data.frame(rs_df["sd"][f_ind, 1])
colnames(bind_mn) <- "mean"
colnames(bind_sd) <- "sd"
if (HPD == FALSE) {
if (length(probs) == 1) {
bind_q <- data.frame(apply(
ch_bind,
2,
stats::quantile,
probs = probs
))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
if (identical(probs, c(0.025, 0.5, 0.975)) == TRUE) {
bind_LCI <- rs_df["X2.5."][f_ind, 1]
bind_med <- rs_df["X50."][f_ind, 1]
bind_UCI <- rs_df["X97.5."][f_ind, 1]
bind_q <- data.frame(cbind(bind_LCI, bind_med, bind_UCI))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
} else {
bind_q <- data.frame(t(apply(
ch_bind,
2,
stats::quantile,
probs = probs
)))
colnames(bind_q) <- paste0(signif(probs * 100, digits = 3), "%")
}
}
}
if (HPD == TRUE) {
if (length(hpd_prob) > 1) {
stop(
'Specify only a single probability for HPD interval computation.'
)
}
bind_q <- data.frame(coda::HPDinterval(
coda::as.mcmc(ch_bind),
prob = hpd_prob
))
colnames(bind_q) <- c(
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDL"),
paste0(signif(hpd_prob * 100, digits = 3), "%_HPDU")
)
}
}
x[[1]] <- cbind(bind_mn, bind_sd, bind_q)
# rhat - rhat in Stan calculated within chain (different than with coda package)
if (Rhat == TRUE) {
r_hat <- data.frame(round(rs_df["Rhat"][f_ind, 1], digits = 2))
colnames(r_hat) <- "Rhat"
x[[(length(x) + 1)]] <- r_hat
}
# neff - neff in Stan is calculated within chain (different than with coda package)
if (n.eff == TRUE) {
if (methods::is(object2, 'stanfit')) {
neff <- data.frame(round(rs_df["n_eff"][f_ind, 1], digits = 0))
}
if (methods::is(object, 'jagsUI')) {
neff <- data.frame(round(rs_df["n.eff"][f_ind, 1], digits = 0))
}
colnames(neff) <- "n_eff"
x[[(length(x) + 1)]] <- neff
}
# p>0
if (pg0 == TRUE) {
tpg <- data.frame(apply(
ch_bind,
2,
function(x) round(sum(x > 0) / length(x), 2)
))
colnames(tpg) <- 'p>0'
x[[(length(x) + 1)]] <- tpg
}
# custom function
if (!is.null(func)) {
if (!is.null(digits)) {
tmp <- signif(apply(ch_bind, 2, func), digits = digits)
}
if (is.null(digits) & !is.null(round)) {
tmp <- round(apply(ch_bind, 2, func), digits = round)
}
if (is.null(digits) & is.null(round)) {
tmp <- apply(ch_bind, 2, func)
}
if (!is.null(dim(tmp))) {
tmp <- data.frame(t(tmp))
} else {
tmp <- data.frame(tmp)
}
if (!is.null(func_name)) {
if (length(func_name) != NCOL(tmp)) {
stop("length(func_name) must equal number of func outputs")
}
colnames(tmp) <- func_name
} else {
colnames(tmp) <- 'func'
}
x[[(length(x) + 1)]] <- tmp
}
# bind them
mcmc_summary <- do.call("cbind", x)
row.names(mcmc_summary) <- all_params[f_ind]
if (variational) {
mcmc_summary$Rhat <- NaN
mcmc_summary$n.eff <- NaN
}
}
return(mcmc_summary)
}
#' @noRd
mcmc_chains = function(
object,
params = 'all',
excl = NULL,
ISB = TRUE,
exact = TRUE,
mcmc.list = FALSE,
chain_num = NULL
) {
#for rstanarm/brms objects - set to NULL by default
sp_names <- NULL
#if mcmc object (from nimble) - convert to mcmc.list
if (methods::is(object, 'mcmc')) {
object <- coda::mcmc.list(object)
}
#if list object of matrices (from nimble) - convert to mcmc.list
if (methods::is(object, 'list')) {
object <- coda::mcmc.list(lapply(object, function(x) coda::mcmc(x)))
}
if (
coda::is.mcmc.list(object) != TRUE &
!methods::is(object, 'matrix') &
!methods::is(object, 'mcmc') &
!methods::is(object, 'list') &
!methods::is(object, 'rjags') &
!methods::is(object, 'stanfit') &
!methods::is(object, 'brmsfit') &
!methods::is(object, 'jagsUI') &
!methods::is(object, 'CmdStanMCMC')
) {
stop(
'Invalid object type. Input must be stanfit object (rstan), CmdStanMCMC object (cmdstanr), stanreg object (rstanarm), brmsfit object (brms), mcmc.list object (coda/rjags), mcmc object (coda/nimble), list object (nimble), rjags object (R2jags), jagsUI object (jagsUI), or matrix with MCMC chains.'
)
}
#NAME SORTING BLOCK
if (methods::is(object, 'stanfit')) {
#convert to mcmc.list
temp_in <- rstan::As.mcmc.list(object)
#assign new colnames for mcmc.list object if object exists (for stanreg and brms objs so parameter names are interpretable) - do not rename params for model fit directly with Stan
if (!is.null(sp_names)) {
coda::varnames(temp_in) <- sp_names
}
if (ISB == TRUE) {
names <- vapply(
strsplit(colnames(temp_in[[1]]), split = '[', fixed = TRUE),
`[`,
1,
FUN.VALUE = character(1)
)
} else {
names <- colnames(temp_in[[1]])
}
}
if (methods::is(object, 'jagsUI')) {
object <- object$samples
}
if (methods::is(object, 'CmdStanMCMC')) {
object <- cmdstanr::as_mcmc.list(object)
}
if (coda::is.mcmc.list(object) == TRUE) {
temp_in <- object
if (is.null(colnames(temp_in[[1]]))) {
warning('No parameter names provided. Assigning arbitrary names.')
sub_cn <- paste0('Param_', 1:NCOL(temp_in[[1]]))
colnames(temp_in[[1]]) <- sub_cn
}
if (ISB == TRUE) {
names <- vapply(
strsplit(colnames(temp_in[[1]]), split = "[", fixed = TRUE),
`[`,
1,
FUN.VALUE = character(1)
)
} else {
names <- colnames(temp_in[[1]])
}
}
if (methods::is(object, 'matrix')) {
temp_in <- object
if (is.null(colnames(temp_in))) {
warning(
'No parameter names (column names) provided. Assigning arbitrary names.'
)
sub_cn <- paste0('Param_', 1:NCOL(temp_in))
colnames(temp_in) <- sub_cn
}
if (ISB == TRUE) {
names <- vapply(
strsplit(colnames(temp_in), split = "[", fixed = TRUE),
`[`,
1,
FUN.VALUE = character(1)
)
} else {
names <- colnames(temp_in)
}
}
if (methods::is(object, 'rjags')) {
temp_in <- object$BUGSoutput$sims.matrix
if (ISB == TRUE) {
names <- vapply(
strsplit(
rownames(object$BUGSoutput$summary),
split = "[",
fixed = TRUE
),
`[`,
1,
FUN.VALUE = character(1)
)
} else {
names <- rownames(object$BUGSoutput$summary)
}
}
#INDEX BLOCK
#exclusions
if (!is.null(excl)) {
rm_ind <- c()
for (i in 1:length(excl)) {
if (ISB == TRUE) {
n_excl <- vapply(
strsplit(excl, split = "[", fixed = TRUE),
`[`,
1,
FUN.VALUE = character(1)
)
} else {
n_excl <- excl
}
if (exact == TRUE) {
ind_excl <- which(names %in% n_excl[i])
} else {
ind_excl <- grep(n_excl[i], names, fixed = FALSE)
}
if (length(ind_excl) < 1) {
warning(paste0(
"\"",
excl[i],
"\"",
" not found in MCMC output. Check 'ISB' and 'exact' arguments to make sure the desired parsing methods are being used."
))
}
rm_ind <- c(rm_ind, ind_excl)
}
if (length(rm_ind) > 0) {
dups <- which(duplicated(rm_ind))
if (length(dups) > 0) {
rm_ind2 <- rm_ind[-dups]
} else {
rm_ind2 <- rm_ind
}
} else {
excl <- NULL
}
}
#selections
if (length(params) == 1) {
if (params == 'all') {
if (is.null(excl)) {
f_ind <- 1:length(names)
} else {
f_ind <- (1:length(names))[-rm_ind2]
}
} else {
if (exact == TRUE) {
get_ind <- which(names %in% params)
} else {
get_ind <- grep(paste(params), names, fixed = FALSE)
}
if (length(get_ind) < 1) {
stop(paste0(
"\"",
params,
"\"",
" not found in MCMC output. Check `ISB` and `exact` arguments to make sure the desired parsing methods are being used."
))
}
if (!is.null(excl)) {
if (identical(get_ind, rm_ind2)) {
stop('No parameters selected.')
}
matched <- stats::na.omit(match(rm_ind2, get_ind))
if (length(matched) > 0) {
f_ind <- get_ind[-matched]
} else {
f_ind <- get_ind
}
} else {
f_ind <- get_ind
}
}
} else {
grouped <- c()
for (i in 1:length(params)) {
if (exact == TRUE) {
get_ind <- which(names %in% params[i])
} else {
get_ind <- grep(paste(params[i]), names, fixed = FALSE)
}
if (length(get_ind) < 1) {
warning(paste0(
"\"",
params[i],
"\"",
" not found in MCMC output. Check 'ISB' and 'exact' arguments to make sure the desired parsing methods are being used."
))
next()
}
grouped <- c(grouped, get_ind)
}
if (!is.null(excl)) {
if (identical(grouped, rm_ind2)) {
stop('No parameters selected.')
}
matched <- stats::na.omit(match(rm_ind2, grouped))
if (length(matched) > 0) {
t_ind <- grouped[-matched]
} else {
t_ind <- grouped
}
to.rm <- which(duplicated(t_ind))
if (length(to.rm) > 0) {
f_ind <- t_ind[-to.rm]
} else {
f_ind <- t_ind
}
} else {
to.rm <- which(duplicated(grouped))
if (length(to.rm) > 0) {
f_ind <- grouped[-to.rm]
} else {
f_ind <- grouped
}
}
}
#PROCESSING BLOCK
if (is.null(chain_num)) {
if (coda::is.mcmc.list(object) == TRUE | typeof(object) == 'S4') {
if (length(f_ind) > 1) {
dsort_mcmc <- do.call(coda::mcmc.list, temp_in[, f_ind])
OUT <- do.call('rbind', dsort_mcmc)
} else {
dsort_mcmc <- do.call(coda::mcmc.list, temp_in[, f_ind, drop = FALSE])
OUT <- as.matrix(
do.call(coda::mcmc.list, temp_in[, f_ind, drop = FALSE]),
ncol = 1
)
}
}
if (methods::is(object, 'matrix')) {
OUT <- temp_in[, f_ind, drop = FALSE]
if (mcmc.list == TRUE) {
stop('Cannot produce mcmc.list output with matrix input')
}
}
if (methods::is(object, 'rjags')) {
OUT <- temp_in[, f_ind, drop = FALSE]
if (mcmc.list == TRUE) {
#modified coda::as.mcmc (removing ordering of param names)
x <- object$BUGSoutput
mclist <- vector("list", x$n.chains)
mclis <- vector("list", x$n.chains)
ord <- dimnames(x$sims.array)[[3]]
for (i in 1:x$n.chains) {
tmp1 <- x$sims.array[, i, ord]
mclis[[i]] <- coda::mcmc(tmp1, thin = x$n.thin)
}
temp2 <- coda::as.mcmc.list(mclis)
#end mod as.mcmc
dsort_mcmc <- do.call(coda::mcmc.list, temp2[, f_ind, drop = FALSE])
}
}
}
if (!is.null(chain_num)) {
if (coda::is.mcmc.list(object) == TRUE | typeof(object) == 'S4') {
if (length(f_ind) > 1) {
dsort <- do.call(coda::mcmc.list, temp_in[, f_ind])
if (chain_num > length(dsort)) {
stop('Invalid value for chain_num specified.')
}
dsort_mcmc <- dsort[[chain_num]]
OUT <- as.matrix(dsort_mcmc)
} else {
dsort <- do.call(coda::mcmc.list, temp_in[, f_ind, drop = FALSE])
if (chain_num > length(dsort)) {
stop('Invalid value for chain_num specified.')
}
dsort_mcmc <- dsort[[chain_num]]
OUT <- as.matrix(dsort_mcmc)
}
}
if (methods::is(object, 'matrix')) {
stop(
'Cannot extract posterior information for individual chains from matrix input.'
)
}
if (methods::is(object, 'rjags')) {
#modified coda::as.mcmc (removing ordering of param names)
x <- object$BUGSoutput
mclist <- vector("list", x$n.chains)
mclis <- vector("list", x$n.chains)
ord <- dimnames(x$sims.array)[[3]]
for (i in 1:x$n.chains) {
tmp1 <- x$sims.array[, i, ord]
mclis[[i]] <- coda::mcmc(tmp1, thin = x$n.thin)
}
temp2 <- coda::as.mcmc.list(mclis)
#end mod as.mcmc
dsort <- do.call(coda::mcmc.list, temp2[, f_ind, drop = FALSE])
if (chain_num > length(dsort)) {
stop('Invalid value for chain_num specified.')
}
dsort_mcmc <- dsort[[chain_num]]
OUT <- as.matrix(dsort_mcmc)
}
}
if (mcmc.list == FALSE) {
return(OUT)
}
if (mcmc.list == TRUE) {
return(dsort_mcmc)
}
}
#### Vectorise a stan model's likelihood for quicker computation ####
#' @noRd
#' @param model_file Stan model file to be edited
#' @param model_data Prepared mvgam data for Stan modelling
#' @param family \code{character}
#' @param trend_model \code{character} specifying the time series dynamics for the latent trend.
#' @param offset \code{logical}
#' @param drift \code{logical}
#' @param threads \code{integer} Experimental option to use multithreading for within-chain
#'parallelisation in \code{Stan}. We recommend its use only if you are experienced with
#'\code{Stan}'s `reduce_sum` function and have a slow running model that cannot be sped
#'up by any other means
#' @return A `list` containing the updated Stan model and model data
vectorise_stan_lik = function(
model_file,
model_data,
family = 'poisson',
trend_model = 'None',
use_lv = FALSE,
offset = FALSE,
drift = FALSE,
threads = 1
) {
if (family %in% c('binomial', 'beta_binomial', 'bernoulli')) {
family <- 'poisson'
}
if (use_lv & trend_model %in% c('None', 'ZMVN')) {
trend_model <- 'RW'
}
# Hack for adding VAR1 models
if (trend_model %in% c('VAR1', 'VAR1cor')) {
VAR1 <- TRUE
trend_model <- 'RW'
} else {
VAR1 <- FALSE
}
# Similar hack for adding piecewise trends
if (trend_model %in% c('PWlinear', 'PWlogistic')) {
trend_model <- 'RW'
}
#### Family specifications ####
if (threads > 1) {
if (family == 'gaussian') {
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'real partial_log_lik(int[] seq, int start, int end,\n',
ifelse(
offset,
'data vector Y, matrix X, vector b, vector sigma_obs, vector alpha) {\n',
'data vector Y, matrix X, vector b, vector sigma_obs, real alpha) {\n'
),
'real ptarget = 0;\n',
ifelse(
offset,
'ptarget += normal_id_glm_lpdf(Y[start:end] | X[start:end], alpha[start:end], b, sigma_obs[start:end]);\n',
'ptarget += normal_id_glm_lpdf(Y[start:end] | X[start:end], alpha, b, sigma_obs[start:end]);\n'
),
'return ptarget;\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'real partial_log_lik(int[] seq, int start, int end,\n',
ifelse(
offset,
'data vector Y, matrix X, vector b, vector sigma_obs, vector alpha) {\n',
'data vector Y, matrix X, vector b, vector sigma_obs, real alpha) {\n'
),
'real ptarget = 0;\n',
ifelse(
offset,
'ptarget += normal_id_glm_lpdf(Y[start:end] | X[start:end], alpha[start:end], b, sigma_obs[start:end]);\n',
'ptarget += normal_id_glm_lpdf(Y[start:end] | X[start:end], alpha, b, sigma_obs[start:end]);\n'
),
'return ptarget;\n',
'}\n}\n'
)
}
}
if (family == 'poisson') {
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'real partial_log_lik(int[] seq, int start, int end,\n',
ifelse(
offset,
'data array[] int Y, matrix X, vector b, vector alpha) {\n',
'data array[] int Y, matrix X, vector b, real alpha) {\n'
),
'real ptarget = 0;\n',
ifelse(
offset,
'ptarget += poisson_log_glm_lpmf(Y[start:end] | X[start:end], alpha[start:end], b);\n',
'ptarget += poisson_log_glm_lpmf(Y[start:end] | X[start:end], alpha, b);\n'
),
'return ptarget;\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'real partial_log_lik(int[] seq, int start, int end,\n',
ifelse(
offset,
'data array[] int Y, matrix X, vector b, vector alpha) {\n',
'data array[] int Y, matrix X, vector b, real alpha) {\n'
),
'real ptarget = 0;\n',
ifelse(
offset,
'ptarget += poisson_log_glm_lpmf(Y[start:end] | X[start:end], alpha[start:end], b);\n',
'ptarget += poisson_log_glm_lpmf(Y[start:end] | X[start:end], alpha, b);\n'
),
'return ptarget;\n',
'}\n}\n'
)
}
}
if (family == 'lognormal') {
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data vector Y, vector mu, vector sigma_obs) {\n',
'real ptarget = 0;\n',
'ptarget += lognormal_lpdf(Y[start:end] | mu[start:end],\n',
'sigma_obs[start:end]);\n',
'return ptarget;\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data vector Y, vector mu, vector sigma_obs) {\n',
'real ptarget = 0;\n',
'ptarget += lognormal_lpdf(Y[start:end] | mu[start:end],\n',
'sigma_obs[start:end]);\n',
'return ptarget;\n',
'}\n}'
)
}
}
if (family == 'beta') {
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data vector Y, vector mu, vector phi) {\n',
'real ptarget = 0;\n',
'ptarget += beta_lpdf(Y[start:end] | inv_logit(mu[start:end]) .* phi[start:end],\n',
'(1 - inv_logit(mu[start:end])) .* phi[start:end]);\n',
'return ptarget;\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data vector Y, vector mu, vector phi) {\n',
'real ptarget = 0;\n',
'ptarget += beta_lpdf(Y[start:end] | inv_logit(mu[start:end]) .* phi[start:end],\n',
'(1 - inv_logit(mu[start:end])) .* phi[start:end]);\n',
'return ptarget;\n',
'}\n}'
)
}
}
if (family == 'student') {
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data vector Y, vector mu, vector sigma_obs, vector nu) {\n',
'real ptarget = 0;\n',
'ptarget += student_t_lpdf(Y[start:end] | nu[start:end], mu[start:end],\n',
'sigma_obs[start:end]);\n',
'return ptarget;\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data vector Y, vector mu, vector sigma_obs, vector nu) {\n',
'real ptarget = 0;\n',
'ptarget += student_t_lpdf(Y[start:end] | nu[start:end], mu[start:end],\n',
'sigma_obs[start:end]);\n',
'return ptarget;\n',
'}\n}'
)
}
}
if (family == 'negative binomial') {
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data array[] int Y, vector mu, array[] real phi) {\n',
'real ptarget = 0;\n',
'ptarget += neg_binomial_2_lpmf(Y[start:end] | mu[start:end],\n',
'inv(phi[start:end]));\n',
'return ptarget;\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data array[] int Y, vector mu, array[] real phi) {\n',
'real ptarget = 0;\n',
'ptarget += neg_binomial_2_lpmf(Y[start:end] | mu[start:end],\n',
'inv(phi[start:end]));\n',
'return ptarget;\n',
'}\n}'
)
}
}
if (family == 'Gamma') {
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data vector Y, vector mu, vector shape) {\n',
'real ptarget = 0;\n',
'ptarget += gamma_lpdf(Y[start:end] | shape[start:end], shape[start:end] ./ mu[start:end]);\n',
'return ptarget;\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'real partial_log_lik(array[] int seq, int start, int end,\n',
'data vector Y, vector mu, vector shape) {\n',
'real ptarget = 0;\n',
'ptarget += gamma_lpdf(Y[start:end] | shape[start:end], shape[start:end] ./ mu[start:end]);\n',
'return ptarget;\n',
'}\n}'
)
}
}
model_file <- readLines(textConnection(model_file), n = -1)
}
lik_line <- grep('// likelihood functions', model_file, fixed = TRUE)
model_file <- model_file[-c(lik_line:(lik_line + 6))]
if (family == 'gaussian') {
if (threads > 1) {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_sigma_obs;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_sigma_obs = rep_each(sigma_obs, n)[obs_ind];\n',
'target += reduce_sum(partial_log_lik, seq,\n',
'grainsize,\n',
'flat_ys,\n',
'append_col(flat_xs, flat_trends),\n',
'append_row(b, 1.0),\n',
'flat_sigma_obs,\n',
ifelse(offset, 'offset[obs_ind],\n);\n}\n', '0.0);\n}\n}\n')
)
} else {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_sigma_obs;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_sigma_obs = rep_each(sigma_obs, n)[obs_ind];\n',
'flat_ys ~ normal_id_glm(append_col(flat_xs, flat_trends),\n',
ifelse(offset, 'offset[obs_ind],', '0.0,'),
'append_row(b, 1.0),\n',
'flat_sigma_obs);\n}\n}\n'
)
}
}
if (family == 'poisson') {
if (threads > 1) {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'target += reduce_sum(partial_log_lik, seq,\n',
'grainsize,\n',
'flat_ys,\n',
'append_col(flat_xs, flat_trends),\n',
'append_row(b, 1.0),\n',
ifelse(offset, 'offset[obs_ind]);\n}\n', '0.0);\n}\n}\n')
)
} else {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends),\n',
ifelse(offset, 'offset[obs_ind],', '0.0,'),
'append_row(b, 1.0));\n}\n}\n'
)
}
}
if (family == 'lognormal') {
if (threads > 1) {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_sigma_obs;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_sigma_obs = rep_each(sigma_obs, n)[obs_ind];\n',
'target += reduce_sum(partial_log_lik, seq,\n',
'grainsize,\n',
'flat_ys,\n',
ifelse(
offset,
'append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind],\n',
'append_col(flat_xs, flat_trends) * append_row(b, 1.0),\n'
),
'flat_sigma_obs);\n}\n}\n'
)
} else {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_sigma_obs;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_sigma_obs = rep_each(sigma_obs, n)[obs_ind];\n',
'flat_ys ~ lognormal(\n',
ifelse(
offset,
'append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind],\n',
'append_col(flat_xs, flat_trends) * append_row(b, 1.0),\n'
),
'flat_sigma_obs);\n}\n}\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (family == 'beta') {
if (threads > 1) {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_phis;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_phis = rep_each(phi, n)[obs_ind];\n',
'target += reduce_sum(partial_log_lik, seq,\n',
'grainsize,\n',
'flat_ys,\n',
ifelse(
offset,
'append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind],\n',
'append_col(flat_xs, flat_trends) * append_row(b, 1.0),\n'
),
'flat_phis);\n}\n}\n'
)
} else {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_phis;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_phis = rep_each(phi, n)[obs_ind];\n',
'flat_ys ~ beta(\n',
ifelse(
offset,
'inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind]) .* flat_phis,\n',
'inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0)) .* flat_phis,\n'
),
ifelse(
offset,
'(1 - inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind])) .* flat_phis);\n}\n}\n',
'(1 - inv_logit(append_col(flat_xs, flat_trends) * append_row(b, 1.0))) .* flat_phis);\n}\n}\n'
)
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (family == 'Gamma') {
if (threads > 1) {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_shapes;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_shapes = rep_each(shape, n)[obs_ind];\n',
'target += reduce_sum(partial_log_lik, seq,\n',
'grainsize,\n',
'flat_ys,\n',
ifelse(
offset,
'exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind]),\n',
'exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0)),\n'
),
'flat_shapes);\n}\n}\n'
)
} else {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_shapes;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_shapes = rep_each(shape, n)[obs_ind];\n',
'flat_ys ~ gamma(\n',
'flat_shapes, flat_shapes ./ ',
ifelse(
offset,
'exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind])',
'exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0))'
),
');\n}\n}\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (family == 'student') {
if (threads > 1) {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_sigma_obs;\n',
'vector[n_nonmissing] flat_nu;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_sigma_obs = rep_each(sigma_obs, n)[obs_ind];\n',
'flat_nu = rep_each(nu, n)[obs_ind];\n',
'target += reduce_sum(partial_log_lik, seq,\n',
'grainsize,\n',
'flat_ys,\n',
ifelse(
offset,
'append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind],\n',
'append_col(flat_xs, flat_trends) * append_row(b, 1.0),\n'
),
'flat_sigma_obs, flat_nu);\n}\n}\n'
)
} else {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'vector[n_nonmissing] flat_sigma_obs;\n',
'vector[n_nonmissing] flat_nu;\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_sigma_obs = rep_each(sigma_obs, n)[obs_ind];\n',
'flat_nu = rep_each(nu, n)[obs_ind];\n',
'flat_ys ~ student_t(flat_nu,\n',
ifelse(
offset,
'append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind],\n',
'append_col(flat_xs, flat_trends) * append_row(b, 1.0),\n'
),
'flat_sigma_obs);\n}\n}\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
if (family == 'negative binomial') {
if (threads > 1) {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'real flat_phis[n_nonmissing];\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_phis = to_array_1d(rep_each(phi_inv, n)[obs_ind]);\n',
'target += reduce_sum(partial_log_lik, seq,\n',
'grainsize,\n',
'flat_ys,\n',
ifelse(
offset,
'exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind]),\n',
'exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0)),\n'
),
'flat_phis);\n}\n}\n'
)
} else {
model_file[lik_line] <- paste0(
'{\n// likelihood functions\n',
'vector[n_nonmissing] flat_trends;\n',
'real flat_phis[n_nonmissing];\n',
'flat_trends = (to_vector(trend))[obs_ind];\n',
'flat_phis = to_array_1d(rep_each(phi_inv, n)[obs_ind]);\n',
'flat_ys ~ neg_binomial_2(\n',
ifelse(
offset,
'exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0) + offset[obs_ind]),\n',
'exp(append_col(flat_xs, flat_trends) * append_row(b, 1.0)),\n'
),
'inv(flat_phis));\n}\n}\n'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
# Add the rep_each function to replicate series-varying parameters for particular families
if (
family %in%
c(
'negative binomial',
'gaussian',
'lognormal',
'student',
'Gamma',
'beta'
)
) {
model_file <- readLines(textConnection(model_file), n = -1)
if (any(grepl('functions {', model_file, fixed = TRUE))) {
model_file[grep('functions {', model_file, fixed = TRUE)] <-
paste0(
'functions {\n',
'vector rep_each(vector x, int K) {\n',
'int N = rows(x);\n',
'vector[N * K] y;\n',
'int pos = 1;\n',
'for (n in 1:N) {\n',
'for (k in 1:K) {\n',
'y[pos] = x[n];\n',
'pos += 1;\n',
'}\n',
'}\n',
'return y;\n',
'}\n'
)
} else {
model_file[grep('Stan model code', model_file)] <-
paste0(
'// Stan model code generated by package mvgam\n',
'functions {\n',
'vector rep_each(vector x, int K) {\n',
'int N = rows(x);\n',
'vector[N * K] y;\n',
'int pos = 1;\n',
'for (n in 1:N) {\n',
'for (k in 1:K) {\n',
'y[pos] = x[n];\n',
'pos += 1;\n',
'}\n',
'}\n',
'return y;\n',
'}\n}'
)
}
model_file <- readLines(textConnection(model_file), n = -1)
}
#### Data modifications ####
# Gather the number of nonmissing observations
model_data$n_nonmissing <- length(which(model_data$y_observed == 1))
# Grab indices of nonmissing ys and include reduced sets of ys and Xs
model_data$obs_ind <- which(as.vector(model_data$y_observed) == 1)
model_data$flat_ys <- as.vector(model_data$y)[which(
as.vector(model_data$y_observed) == 1
)]
model_data$X <- t(model_data$X)
model_data$flat_xs <- as.matrix(model_data$X[
as.vector(model_data$ytimes)[model_data$obs_ind],
])
# Add a grainsize integer
if (threads > 1) {
model_data$seq <- 1:model_data$n_nonmissing
model_data$grainsize <- max(
100,
floor(length(as.vector(model_data$y)) / threads)
)
}
# Update the data statement
obs_line <- grep(
'int y_observed[n, n_series]; // indices of missing vs observed',
model_file,
fixed = TRUE
)
model_file <- model_file[-c(obs_line:(obs_line + 2))]
obs_format <- 'int flat_ys[n_nonmissing];'
if (family %in% c('gaussian', 'student')) {
obs_format <- 'vector[n_nonmissing] flat_ys;'
}
if (family %in% c('Gamma', 'lognormal')) {
obs_format <- 'vector[n_nonmissing] flat_ys;'
}
if (family == 'beta') {
obs_format <- 'vector[n_nonmissing] flat_ys;'
}
if (threads > 1) {
model_file[obs_line] <- paste0(
'int n_nonmissing;',
' // number of nonmissing observations\n',
obs_format,
' // flattened nonmissing observations\n',
'matrix[n_nonmissing, num_basis] flat_xs;',
' // X values for nonmissing observations\n',
'int obs_ind[n_nonmissing];',
' // indices of nonmissing observations\n',
'int grainsize;',
' // grainsize for reduce_sum threading\n',
'int seq[n_nonmissing];',
' // an integer sequence for reduce_sum slicing\n',
'}'
)
} else {
model_file[obs_line] <- paste0(
'int n_nonmissing;',
' // number of nonmissing observations\n',
obs_format,
' // flattened nonmissing observations\n',
'matrix[n_nonmissing, num_basis] flat_xs;',
' // X values for nonmissing observations\n',
'int obs_ind[n_nonmissing];',
' // indices of nonmissing observations\n',
'}'
)
}
# Some final edits to improve efficiency of the Stan models
model_file <- gsub(
'row_vector[num_basis] b_raw;',
'vector[num_basis] b_raw;',
model_file,
fixed = TRUE
)
model_file <- gsub(
'row_vector[num_basis] b;',
'vector[num_basis] b;',
model_file,
fixed = TRUE
)
model_file <- gsub(
'matrix[num_basis, total_obs] X; // transposed mgcv GAM design matrix',
'matrix[total_obs, num_basis] X; // mgcv GAM design matrix',
model_file,
fixed = TRUE
)
model_file <- model_file[
-(grep(
'// GAM contribution to expectations (log scale)',
model_file,
fixed = TRUE
):(grep(
'// GAM contribution to expectations (log scale)',
model_file,
fixed = TRUE
) +
5))
]
if (trend_model == 'GP') {
model_file <- model_file[
-(grep('eta = to_vector(b * X);', model_file, fixed = TRUE))
]
model_file <- model_file[
-((grep(
'mus[1:n, s] = eta[ytimes[1:n, s]] + trend[1:n, s];',
model_file,
fixed = TRUE
) -
1):(grep(
'mus[1:n, s] = eta[ytimes[1:n, s]] + trend[1:n, s];',
model_file,
fixed = TRUE
) +
1))
]
} else {
model_file <- model_file[
-(grep('eta = to_vector(b * X);', model_file, fixed = TRUE):(grep(
'eta = to_vector(b * X);',
model_file,
fixed = TRUE
) +
4))
]
}
model_file <- model_file[
-((grep('// posterior predictions', model_file, fixed = TRUE) + 1):(grep(
'// posterior predictions',
model_file,
fixed = TRUE
) +
3))
]
model_file[grep(
'generated quantities {',
model_file,
fixed = TRUE
)] <- paste0(
'generated quantities {\n',
'vector[total_obs] eta;\n',
'matrix[n, n_series] mus;'
)
if (family == 'poisson') {
model_file[grep(
'// posterior predictions',
model_file,
fixed = TRUE
)] <- paste0(
'// posterior predictions\n',
ifelse(offset, 'eta = X * b + offset;\n', 'eta = X * b;\n'),
'for(s in 1:n_series){ \n',
'mus[1:n, s] = eta[ytimes[1:n, s]] + trend[1:n, s];\n',
'ypred[1:n, s] = poisson_log_rng(mus[1:n, s]);\n',
'}'
)
}
if (family == 'negative binomial') {
model_file[grep(
'// posterior predictions',
model_file,
fixed = TRUE
)] <- paste0(
'// posterior predictions\n',
ifelse(offset, 'eta = X * b + offset;\n', 'eta = X * b;\n'),
'for(s in 1:n_series){ \n',
'mus[1:n, s] = eta[ytimes[1:n, s]] + trend[1:n, s];\n',
'ypred[1:n, s] = neg_binomial_2_rng(exp(mus[1:n, s]), phi_vec[1:n, s]);\n',
'}'
)
}
if (family == 'gaussian') {
model_file[grep(
'array[n, n_series] int ypred;',
model_file,
fixed = TRUE
)] <- 'array[n, n_series] real ypred;'
model_file = readLines(textConnection(model_file), n = -1)
model_file[grep(
'vector[num_basis] b_raw;',
model_file,
fixed = TRUE
)] <- paste0(
'vector[num_basis] b_raw;\n',
'// gaussian observation error\n',
'vector[n_series] sigma_obs;'
)
model_file[
grep('// likelihood functions', model_file, fixed = TRUE) - 1
] <- paste0(
'// priors for observation error parameters\n',
'sigma_obs ~ student_t(3, 0, 2);\n',
'{'
)
model_file[grep(
'matrix[n, n_series] mus;',
model_file,
fixed = TRUE
)] <- paste0(
'matrix[n, n_series] sigma_obs_vec;\n',
'matrix[n, n_series] mus;'
)
model_file[grep(
'// posterior predictions',
model_file,
fixed = TRUE
)] <- paste0(
'// posterior predictions\n',
ifelse(offset, 'eta = X * b + offset;\n', 'eta = X * b;\n'),
'for (s in 1:n_series) {\n',
'sigma_obs_vec[1:n,s] = rep_vector(sigma_obs[s], n);\n',
'}\n',
'for(s in 1:n_series){ \n',
'mus[1:n, s] = eta[ytimes[1:n, s]] + trend[1:n, s];\n',
'ypred[1:n, s] = normal_rng(mus[1:n, s], sigma_obs_vec[1:n, s]);\n',
'}'
)
}
if (family == 'student') {
model_file[grep(
'array[n, n_series] int ypred;',
model_file,
fixed = TRUE
)] <- 'array[n, n_series] real ypred;'
model_file = readLines(textConnection(model_file), n = -1)
model_file[grep(
'vector[num_basis] b_raw;',
model_file,
fixed = TRUE
)] <- paste0(
'vector[num_basis] b_raw;\n',
'// student-t observation error\n',
'vector[n_series] sigma_obs;\n',
'// student-t df parameters\n',
'vector[n_series] nu;'
)
model_file[
grep('// likelihood functions', model_file, fixed = TRUE) - 1
] <- paste0(
'// priors for observation error parameters\n',
'sigma_obs ~ student_t(3, 0, 2);\n',
'// priors for df parameters\n',
'nu ~ gamma(2, 0.1);\n',
'{'
)
model_file[grep(
'matrix[n, n_series] mus;',
model_file,
fixed = TRUE
)] <- paste0(
'matrix[n, n_series] sigma_obs_vec;\n',
'matrix[n, n_series] nu_vec;\n',
'matrix[n, n_series] mus;'
)
model_file[grep(
'// posterior predictions',
model_file,
fixed = TRUE
)] <- paste0(
'// posterior predictions\n',
ifelse(offset, 'eta = X * b + offset;\n', 'eta = X * b;\n'),
'for (s in 1:n_series) {\n',
'sigma_obs_vec[1:n,s] = rep_vector(sigma_obs[s], n);\n',
'nu_vec[1:n,s] = rep_vector(nu[s], n);\n',
'}\n',
'for(s in 1:n_series){ \n',
'mus[1:n, s] = eta[ytimes[1:n, s]] + trend[1:n, s];\n',
'ypred[1:n, s] = student_t_rng(nu_vec[1:n, s], mus[1:n, s], sigma_obs_vec[1:n, s]);\n',
'}'
)
}
if (family == 'lognormal') {
model_file[grep(
'array[n, n_series] int ypred;',
model_file,
fixed = TRUE
)] <- 'real ypred[n, n_series];'
model_file = readLines(textConnection(model_file), n = -1)
model_file[grep(
'vector[num_basis] b_raw;',
model_file,
fixed = TRUE
)] <- paste0(
'vector[num_basis] b_raw;\n',
'// lognormal observation error\n',
'vector[n_series] sigma_obs;'
)
model_file[
grep('// likelihood functions', model_file, fixed = TRUE) - 1
] <- paste0(
'// priors for log(observation error) parameters\n',
'sigma_obs ~ student_t(3, 0, 1);\n',
'{'
)
model_file[grep(
'matrix[n, n_series] mus;',
model_file,
fixed = TRUE
)] <- paste0(
'matrix[n, n_series] sigma_obs_vec;\n',
'matrix[n, n_series] mus;'
)
model_file[grep(
'// posterior predictions',
model_file,
fixed = TRUE
)] <- paste0(
'// posterior predictions\n',
ifelse(offset, 'eta = X * b + offset;\n', 'eta = X * b;\n'),
'for (s in 1:n_series) {\n',
'sigma_obs_vec[1:n,s] = rep_vector(sigma_obs[s], n);\n',
'}\n',
'for(s in 1:n_series){ \n',
'mus[1:n, s] = eta[ytimes[1:n, s]] + trend[1:n, s];\n',
'ypred[1:n, s] = lognormal_rng(mus[1:n, s], sigma_obs_vec[1:n, s]);\n',
'}'
)
}
if (family == 'beta') {
model_file[grep(
'array[n, n_series] int ypred;',
model_file,
fixed = TRUE
)] <- 'real ypred[n, n_series];'
model_file = readLines(textConnection(model_file), n = -1)
model_file[grep(
'vector[num_basis] b_raw;',
model_file,
fixed = TRUE
)] <- paste0(
'vector[num_basis] b_raw;\n',
'// Beta precision parameters\n',
'vector