diff --git a/.github/workflows/R-CMD-check-rstan.yaml b/.github/workflows/R-CMD-check-rstan.yaml index edeebcfb..8aa46ded 100644 --- a/.github/workflows/R-CMD-check-rstan.yaml +++ b/.github/workflows/R-CMD-check-rstan.yaml @@ -56,6 +56,8 @@ jobs: wrswoR tweedie splines2 + scoringRules + matrixStats xts collapse rmarkdown diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index e160b031..05268857 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -54,6 +54,8 @@ jobs: wrswoR tweedie splines2 + scoringRules + matrixStats xts collapse rmarkdown diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 9ac6623c..8c2fa932 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -38,6 +38,8 @@ jobs: wrswoR tweedie splines2 + scoringRules + matrixStats xts collapse rmarkdown diff --git a/DESCRIPTION b/DESCRIPTION index c9ac642d..6385ce76 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: mvgam Title: Multivariate (Dynamic) Generalized Additive Models Version: 1.1.2 -Date: 2024-05-10 +Date: 2024-06-28 Authors@R: person("Nicholas J", "Clark", , "nicholas.j.clark1214@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0001-7131-3301")) Description: Fit Bayesian Dynamic Generalized Additive Models to sets of time series. Users can build dynamic 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 (2022) . URL: https://github.com/nicholasjclark/mvgam, https://nicholasjclark.github.io/mvgam/ @@ -9,26 +9,24 @@ BugReports: https://github.com/nicholasjclark/mvgam/issues License: MIT + file LICENSE Depends: R (>= 3.6.0), + brms (>= 2.17) +Imports: + methods, mgcv (>= 1.8-13), - Rcpp (>= 0.12.0), - brms (>= 2.17), - marginaleffects, insight (>= 0.19.1), - methods -Imports: + marginaleffects (>= 0.16.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 (>= 2.0.0), - matrixStats, parallel, pbapply, mvnfast, purrr, zoo, - scoringRules, smooth, dplyr, magrittr, @@ -39,6 +37,8 @@ LazyData: true Roxygen: list(markdown = TRUE) RoxygenNote: 7.2.3 Suggests: + scoringRules, + matrixStats, cmdstanr (>= 0.5.0), tweedie, splines2, diff --git a/NAMESPACE b/NAMESPACE index 4745a50f..e2ffd6a7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -68,6 +68,7 @@ export(PW) export(RW) export(VAR) export(add_residuals) +export(betar) export(code) export(compare_mvgams) export(dynamic) @@ -78,6 +79,7 @@ export(hindcast) export(lfo_cv) export(lv_correlations) export(mvgam) +export(nb) export(neff_ratio) export(nmix) export(nuts_params) @@ -97,8 +99,11 @@ export(score) export(series_to_mvgam) export(sim_mvgam) export(student_t) +export(te) +export(ti) export(tweedie) export(variables) +importFrom(Matrix,nearPD) importFrom(Rcpp,evalCpp) importFrom(bayesplot,color_scheme_get) importFrom(bayesplot,color_scheme_set) @@ -189,7 +194,6 @@ importFrom(rlang,warn) importFrom(rstantools,posterior_epred) importFrom(rstantools,posterior_linpred) importFrom(rstantools,posterior_predict) -importFrom(scoringRules,es_sample) importFrom(stats,.getXlevels) importFrom(stats,Gamma) importFrom(stats,acf) diff --git a/NEWS.md b/NEWS.md index 62779fdf..b88cf387 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # mvgam 1.1.2 * 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, diff --git a/R/conditional_effects.R b/R/conditional_effects.R index 31d39098..99c6d560 100644 --- a/R/conditional_effects.R +++ b/R/conditional_effects.R @@ -44,7 +44,7 @@ #' @author Nicholas J Clark #' @seealso \code{\link[marginaleffects]{plot_predictions}}, \code{\link[marginaleffects]{plot_slopes}} #' @examples -#' \dontrun{ +#' \donttest{ #' # Simulate some data #' simdat <- sim_mvgam(family = poisson(), #' seasonality = 'hierarchical') @@ -53,9 +53,7 @@ #' mod <- mvgam(y ~ s(season, by = series, k = 5) + year:series, #' family = poisson(), #' data = simdat$data_train, -#' chains = 2, -#' burnin = 300, -#' samples = 300) +#' chains = 2) #' #' # Plot all main effects on the response scale #' conditional_effects(mod) @@ -73,9 +71,7 @@ #' mod <- mvgam(y ~ te(x0, x1, k = 5) + s(x2, k = 6) + s(x3, k = 6), #' data = dat, #' family = gaussian(), -#' chains = 2, -#' burnin = 300, -#' samples = 300) +#' chains = 2) #' conditional_effects(mod) #' conditional_effects(mod, conf_level = 0.5, type = 'link') #' } @@ -200,7 +196,6 @@ conditional_effects.mvgam = function(x, class(out) <- 'mvgam_conditional_effects' return(out) - } #' @rdname conditional_effects.mvgam diff --git a/R/dynamic.R b/R/dynamic.R index 9b465cdb..6c9f86fd 100644 --- a/R/dynamic.R +++ b/R/dynamic.R @@ -39,7 +39,7 @@ #' @rdname dynamic #' @return a `list` object for internal usage in 'mvgam' #'@examples -#'\dontrun{ +#'\donttest{ #'# Simulate a time-varying coefficient #'#(as a Gaussian Process with length scale = 10) #'set.seed(1111) diff --git a/R/evaluate_mvgams.R b/R/evaluate_mvgams.R index 1f82a820..7ae31883 100644 --- a/R/evaluate_mvgams.R +++ b/R/evaluate_mvgams.R @@ -714,9 +714,11 @@ sis_score <- function(truth, fc, interval_width = 0.9, } #' Compute the multivariate energy score -#' @importFrom scoringRules es_sample #' @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] @@ -724,7 +726,7 @@ energy_score <- function(truth, fc, log = FALSE) { truth <- log(truth + 0.001) fc <- log(fc + 0.001) } - es <- es_sample(y = truth, dat = fc) + es <- scoringRules::es_sample(y = truth, dat = fc) return(es) } diff --git a/R/families.R b/R/families.R index 4fd09afa..7b552339 100644 --- a/R/families.R +++ b/R/families.R @@ -3,8 +3,10 @@ #' @importFrom stats pnorm ppois plogis gaussian poisson Gamma dnbinom rnbinom dnorm dbeta #' @importFrom stats binomial rbinom pbinom dbinom qbinom qlogis #' @importFrom brms lognormal student bernoulli rstudent_t qstudent_t dstudent_t pstudent_t dbeta_binomial rbeta_binomial pbeta_binomial +#' @importFrom mgcv betar nb #' @param link a specification for the family link function. At present these cannot #' be changed +#' @param ... Arguments to be passed to the \pkg{mgcv} version of the associated functions #' @details \code{mvgam} currently supports the following standard observation families: #'\itemize{ #' \item \code{\link[stats]{gaussian}} with identity link, for real-valued data @@ -66,9 +68,21 @@ student_t = function(link = 'identity'){ class = c("extended.family", "family")) } +#' @rdname mvgam_families +#' @export +betar = function(...){ + mgcv::betar(...) +} + +#' @rdname mvgam_families +#' @export +nb = function(...){ + mgcv::nb(...) +} + #' @rdname mvgam_families #' @examples -#' \dontrun{ +#' \donttest{ #' # Example showing how to set up N-mixture models #' set.seed(999) #'# Simulate observations for species 1, which shows a declining trend and 0.7 detection probability @@ -162,15 +176,13 @@ student_t = function(link = 'identity'){ #' # priors can be set in the usual way #' priors = c(prior(std_normal(), class = b), #' prior(normal(1, 1.5), class = Intercept_trend)), -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #' # The usual diagnostics #' summary(mod) #' #' # Plotting conditional effects -#' library(ggplot2) +#' library(ggplot2); library(marginaleffects) #' plot_predictions(mod, condition = 'species', #' type = 'detection') + #' ylab('Pr(detection)') + diff --git a/R/forecast.mvgam.R b/R/forecast.mvgam.R index bfe7984e..6b1ac9c0 100644 --- a/R/forecast.mvgam.R +++ b/R/forecast.mvgam.R @@ -28,13 +28,12 @@ forecast <- function(object, ...){ #'@rdname forecast.mvgam #'@method forecast mvgam #' @examples -#' \dontrun{ -#' simdat <- sim_mvgam(n_series = 3, trend_model = 'AR1') +#' \donttest{ +#' 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, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #' # Hindcasts on response scale diff --git a/R/get_mvgam_priors.R b/R/get_mvgam_priors.R index bef9cdab..345ce90a 100644 --- a/R/get_mvgam_priors.R +++ b/R/get_mvgam_priors.R @@ -424,7 +424,7 @@ get_mvgam_priors = function(formula, data_train[[out_name]] <- replace_nas(data_train[[out_name]]) # Some general family-level restrictions can now be checked - validate_family_resrictions(response = data_train[[out_name]], + validate_family_restrictions(response = data_train[[out_name]], family = family) # Use a small fit from mgcv to extract relevant information on smooths included diff --git a/R/hindcast.mvgam.R b/R/hindcast.mvgam.R index 0a8e49b2..7715fd78 100644 --- a/R/hindcast.mvgam.R +++ b/R/hindcast.mvgam.R @@ -7,7 +7,8 @@ #'organized into a convenient format #'@return An object of class \code{mvgam_forecast} containing hindcast distributions. #'See \code{\link{mvgam_forecast-class}} for details. -#'#'@seealso \code{\link{forecast.mvgam}} +#' +#'@seealso \code{\link{forecast.mvgam}} #'@export hindcast <- function(object, ...){ UseMethod("hindcast", object) @@ -16,13 +17,12 @@ hindcast <- function(object, ...){ #'@rdname hindcast.mvgam #'@method hindcast mvgam #' @examples -#' \dontrun{ -#' simdat <- sim_mvgam(n_series = 3, trend_model = 'AR1') +#' \donttest{ +#' 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, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #' # Hindcasts on response scale diff --git a/R/loo.mvgam.R b/R/loo.mvgam.R index 318eb1d8..799f3106 100644 --- a/R/loo.mvgam.R +++ b/R/loo.mvgam.R @@ -39,7 +39,7 @@ #' forecast evaluations for further scrutiny of models (see for example \code{\link{forecast.mvgam}}, #' \code{\link{score.mvgam_forecast}} and \code{\link{lfo_cv}}) #'@examples -#'\dontrun{ +#'\donttest{ #'# Simulate 4 time series with hierarchical seasonality #'# and independent AR1 dynamic processes #'set.seed(111) diff --git a/R/mcmc_plot.mvgam.R b/R/mcmc_plot.mvgam.R index 67a9b0db..66432bad 100644 --- a/R/mcmc_plot.mvgam.R +++ b/R/mcmc_plot.mvgam.R @@ -23,12 +23,11 @@ #' that can be used for argument `variable` #' @examples #' \dontrun{ -#' simdat <- sim_mvgam(n_series = 1, trend_model = 'AR1') +#' 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, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' mcmc_plot(mod) #' mcmc_plot(mod, type = 'neff_hist') diff --git a/R/monotonic.R b/R/monotonic.R index 4da7cca8..5f042e03 100644 --- a/R/monotonic.R +++ b/R/monotonic.R @@ -44,7 +44,7 @@ #' @author Nicholas J Clark #' @name monotonic #' @examples -#' \dontrun{ +#' \donttest{ #' # Simulate data from a monotonically increasing function #' set.seed(123123) #' x <- runif(80) * 4 - 1 @@ -54,6 +54,7 @@ #' 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, @@ -72,8 +73,6 @@ #' mod2 <- mvgam(y ~ s(x, bs = 'moi', k = 18), #' data = mod_data, #' family = gaussian(), -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #' plot_predictions(mod2, @@ -108,8 +107,6 @@ #' mod <- mvgam(y ~ s(x, bs = 'moi', by = fac, k = 8), #' data = mod_data, #' family = gaussian(), -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #' # Visualise the different monotonic functions diff --git a/R/mvgam.R b/R/mvgam.R index 7cf62b29..725d9aef 100644 --- a/R/mvgam.R +++ b/R/mvgam.R @@ -339,6 +339,7 @@ #' data = dat$data_train, #' trend_model = AR(), #' family = poisson(), +#' noncentred = TRUE, #' use_stan = TRUE, #' run_model = FALSE) #' @@ -383,6 +384,7 @@ #' plot(mod1, type = 'smooths', realisations = TRUE) #' #' # Plot conditional response predictions using marginaleffects +#' library(marginaleffects) #' conditional_effects(mod1) #' plot_predictions(mod1, condition = 'season', points = 0.5) #' @@ -477,7 +479,8 @@ #' # 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') +#' 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) @@ -736,7 +739,7 @@ mvgam = function(formula, # Some general family-level restrictions can now be checked orig_y <- data_train$y if(any(!is.na(orig_y))){ - validate_family_resrictions(response = orig_y, family = family) + validate_family_restrictions(response = orig_y, family = family) } # Fill in missing observations in data_train so the size of the dataset is correct when diff --git a/R/mvgam_diagnostics.R b/R/mvgam_diagnostics.R index 47059877..969b3b08 100644 --- a/R/mvgam_diagnostics.R +++ b/R/mvgam_diagnostics.R @@ -15,13 +15,12 @@ #' #' @return The exact form of the output depends on the method. #' @examples -#' \dontrun{ +#' \donttest{ #' 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, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' np <- nuts_params(mod) #' head(np) @@ -79,6 +78,8 @@ rhat.mvgam <- function(x, pars = NULL, ...) { #' @export neff_ratio #' @export neff_ratio.mvgam <- function(object, pars = NULL, ...) { + insight::check_if_installed("matrixStats", + reason = 'to calculate effective sample sizes') # bayesplot uses outdated ess code from rstan # bayesplot::neff_ratio(object$fit, pars = pars, ...) if(is.null(pars)){ @@ -105,6 +106,8 @@ neff_ratio.mvgam <- function(object, pars = NULL, ...) { #' @export neff_ratio #' @export neff_ratio.mvgam <- function(object, pars = NULL, ...) { + insight::check_if_installed("matrixStats", + reason = 'to calculate effective sample sizes') # bayesplot uses outdated ess code from rstan # bayesplot::neff_ratio(object$fit, pars = pars, ...) if(is.null(pars)){ diff --git a/R/noncent_trend.R b/R/noncent_trend.R index d5cd0641..d990c4c7 100644 --- a/R/noncent_trend.R +++ b/R/noncent_trend.R @@ -232,8 +232,15 @@ noncent_lv = function(model_file, trend_model, drift){ trend_end <- grep("LV[i, j] ~ normal(trend_mus[ytimes_trend[i, j]], sigma[j]);", model_file, fixed = TRUE) + 2 } else { - trend_start <- grep("LV[1, j] ~ normal(trend_mus[ytimes_trend[1, j]], sigma[j]);", - model_file, fixed = TRUE) - 1 + 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) @@ -243,12 +250,23 @@ noncent_lv = function(model_file, trend_model, drift){ model_file <- model_file[-(trend_start:trend_end)] - 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();") + 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 @@ -271,6 +289,14 @@ check_noncent = function(model_file, 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'){ if(silent <= 1L){ message('Your model may benefit from using "noncentred = TRUE"') diff --git a/R/pairs.mvgam.R b/R/pairs.mvgam.R index 2c4f769c..dc29fc7f 100644 --- a/R/pairs.mvgam.R +++ b/R/pairs.mvgam.R @@ -14,10 +14,11 @@ #' \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. #' #' @examples -#' \dontrun{ +#' \donttest{ #' 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) diff --git a/R/piecewise_trends.R b/R/piecewise_trends.R index 08ffc6d8..b4d82016 100644 --- a/R/piecewise_trends.R +++ b/R/piecewise_trends.R @@ -48,7 +48,7 @@ #' #' @rdname piecewise_trends #' @examples -#' \dontrun{ +#' \donttest{ #' # Example of logistic growth with possible changepoints #' # Simple logistic growth model #' dNt = function(r, N, k){ diff --git a/R/plot.mvgam.R b/R/plot.mvgam.R index acf34373..63233f5e 100644 --- a/R/plot.mvgam.R +++ b/R/plot.mvgam.R @@ -44,7 +44,7 @@ #'@author Nicholas J Clark #'@return A base R plot or set of plots #'@examples -#'\dontrun{ +#'\donttest{ #'# Simulate some time series #'dat <- sim_mvgam(T = 80, n_series = 3) #' @@ -52,8 +52,6 @@ #'mod <- mvgam(y ~ s(season, bs = 'cc') + s(series, bs = 're'), #' data = dat$data_train, #' trend_model = RW(), -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #'# Plot predictions and residuals for each series @@ -69,6 +67,7 @@ #'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'), @@ -81,8 +80,6 @@ #' trend_formula = ~ s(season, bs = 'cc'), #' data = dat$data_train, #' trend_model = RW(), -#' burnin = 300, -#' samples = 300, #' chains = 2) #'plot(mod, type = 'smooths', trend_effects = TRUE) #' diff --git a/R/plot_mvgam_factors.R b/R/plot_mvgam_factors.R index 50329426..bf0b0762 100644 --- a/R/plot_mvgam_factors.R +++ b/R/plot_mvgam_factors.R @@ -16,7 +16,7 @@ #'@return A \code{dataframe} of factor contributions and, #'optionally, a series of base \code{R} plots #'@examples -#'\dontrun{ +#'\donttest{ #'simdat <- sim_mvgam() #'mod <- mvgam(y ~ s(season, bs = 'cc', #' k = 6), diff --git a/R/plot_mvgam_series.R b/R/plot_mvgam_series.R index 490623cb..a1e2141e 100644 --- a/R/plot_mvgam_series.R +++ b/R/plot_mvgam_series.R @@ -35,12 +35,15 @@ #'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) +#'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) +#'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) +#'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, diff --git a/R/plot_mvgam_trend.R b/R/plot_mvgam_trend.R index f08a4014..abe4db01 100644 --- a/R/plot_mvgam_trend.R +++ b/R/plot_mvgam_trend.R @@ -26,9 +26,8 @@ #' simdat <- sim_mvgam(n_series = 3, trend_model = 'AR1') #' mod <- mvgam(y ~ s(season, bs = 'cc', k = 6), #' trend_model = AR(), +#' noncentred = TRUE, #' data = simdat$data_train, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #' # Plot estimated trends for some series diff --git a/R/posterior_epred.mvgam.R b/R/posterior_epred.mvgam.R index f64f8b34..56ea36ac 100644 --- a/R/posterior_epred.mvgam.R +++ b/R/posterior_epred.mvgam.R @@ -39,11 +39,12 @@ #' @seealso \code{\link{hindcast.mvgam}} \code{\link{posterior_linpred.mvgam}} \code{\link{posterior_predict.mvgam}} #' @aliases posterior_epred #' @examples -#' \dontrun{ +#' \donttest{ #' # Simulate some data and fit a model #' 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) #' #'# Compute posterior expectations @@ -110,14 +111,13 @@ posterior_epred.mvgam = function(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{ +#' \donttest{ #' # Simulate some data and fit a model #' simdat <- sim_mvgam(n_series = 1, trend_model = 'AR1') #' mod <- mvgam(y ~ s(season, bs = 'cc'), -#' trend_model = 'AR1', +#' trend_model = AR(), +#' noncentred = TRUE, #' data = simdat$data_train, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #'# Extract linear predictor values diff --git a/R/ppc.mvgam.R b/R/ppc.mvgam.R index 45fac305..7e4b9d8c 100644 --- a/R/ppc.mvgam.R +++ b/R/ppc.mvgam.R @@ -47,15 +47,13 @@ #'@author Nicholas J Clark #'@seealso \code{\link{pp_check.mvgam}}, \code{\link{predict.mvgam}} #' @examples -#' \dontrun{ +#' \donttest{ #' # 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(), -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #' # Posterior checks diff --git a/R/predict.mvgam.R b/R/predict.mvgam.R index f776f8e8..cdb08826 100644 --- a/R/predict.mvgam.R +++ b/R/predict.mvgam.R @@ -61,7 +61,7 @@ #' 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` #'@examples -#'\dontrun{ +#'\donttest{ #'# Simulate 4 time series with hierarchical seasonality #'# and independent AR1 dynamic processes #'set.seed(111) @@ -74,8 +74,7 @@ #' data = simdat$data_train, #' family = gaussian(), #' trend_model = AR(), -#' burnin = 300, -#' samples = 300, +#' noncentred = TRUE, #' chains = 2) #' #'# Generate predictions against observed data diff --git a/R/residuals.mvgam.R b/R/residuals.mvgam.R index 5e02945e..ee035c77 100644 --- a/R/residuals.mvgam.R +++ b/R/residuals.mvgam.R @@ -22,14 +22,13 @@ #' \code{robust}). The remaining columns starting with \code{Q} contain #' quantile estimates as specified via argument \code{probs}. #' @examples -#' \dontrun{ +#' \donttest{ #' # Simulate some data and fit a model #' simdat <- sim_mvgam(n_series = 1, trend_model = 'AR1') #' mod <- mvgam(y ~ s(season, bs = 'cc'), -#' trend_model = 'AR1', +#' trend_model = AR(), +#' noncentred = TRUE, #' data = simdat$data_train, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #'# Extract posterior residuals diff --git a/R/score.mvgam_forecast.R b/R/score.mvgam_forecast.R index afdfef3e..02d11e31 100644 --- a/R/score.mvgam_forecast.R +++ b/R/score.mvgam_forecast.R @@ -31,7 +31,7 @@ #'posterior empirical quantiles. Intervals are not calculated when using `elpd` because forecasts #'will only contain the linear predictors #'@examples -#'\dontrun{ +#'\donttest{ #'# Simulate observations for three count-valued time series #'data <- sim_mvgam() #'# Fit a dynamic model using 'newdata' to automatically produce forecasts @@ -39,8 +39,6 @@ #' trend_model = RW(), #' data = data$data_train, #' newdata = data$data_test, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' #'# Extract forecasts into a 'mvgam_forecast' object diff --git a/R/sim_mvgam.R b/R/sim_mvgam.R index 38ffb082..3193d768 100644 --- a/R/sim_mvgam.R +++ b/R/sim_mvgam.R @@ -6,6 +6,7 @@ #' #'@importFrom stats rnorm rbeta rpois rlnorm rgamma cor cov2cor cov stl ts #'@importFrom brms lognormal +#'@importFrom Matrix nearPD #'@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, diff --git a/R/ti.R b/R/ti.R new file mode 100644 index 00000000..086cb643 --- /dev/null +++ b/R/ti.R @@ -0,0 +1,48 @@ +# This file contains functions dealing with the extended +# formula syntax to specify smooth terms via mgcv + +#' Defining smooths in \pkg{mvgam} formulae +#' +#' Functions used in definition of smooth terms within model formulae. +#' The functions do not evaluate a (spline) smooth - they exist purely +#' to help set up mvgam models using spline based smooths. +#' +#' @param ... Arguments passed to \code{\link[mgcv:ti]{mgcv::ti}} or +#' \code{\link[mgcv:ti]{mgcv::te}} +#' +#' @details The functions defined here are just simple wrappers of the respective +#' functions of the \pkg{mgcv} package. When using them, please cite the +#' appropriate references obtained via \code{citation("mgcv")}. +#' +#' @seealso \code{\link[mgcv:ti]{mgcv::ti}}, \code{\link[mgcv:ti]{mgcv::te}} +#' +#' +#' @examples +#' \donttest{ +#' # Simulate some data +#' dat <- mgcv::gamSim(1, n = 200, scale = 2) +#' +#' # Fit univariate smooths for all predictors +#' fit1 <- mvgam(y ~ s(x0) + s(x1) + s(x2) + s(x3), +#' data = dat, chains = 2, family = gaussian()) +#' summary(fit1) +#' conditional_effects(fit1) +#' +#' # Fit a more complicated smooth model +#' fit2 <- mvgam(y ~ te(x0, x1) + s(x2, by = x3), +#' data = dat, chains = 2, family = gaussian()) +#' summary(fit2) +#' conditional_effects(fit2) +#' } +#' +#' @rdname ti +#' @export +ti <- function(...) { + mgcv::ti(...) +} + +#' @rdname ti +#' @export +te <- function(...) { + mgcv::te(...) +} diff --git a/R/update.mvgam.R b/R/update.mvgam.R index f338dd8a..5fbdf295 100644 --- a/R/update.mvgam.R +++ b/R/update.mvgam.R @@ -16,20 +16,20 @@ #' 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{ +#' \donttest{ #' # Simulate some data and fit a Poisson AR1 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, -#' burnin = 300, -#' samples = 300, #' chains = 2) #' summary(mod) #' conditional_effects(mod, type = 'link') #' #' # Update to an AR2 model -#' updated_mod <- update(mod, trend_model = AR(p = 2)) +#' updated_mod <- update(mod, trend_model = AR(p = 2), +#' noncentred = TRUE) #' summary(updated_mod) #' conditional_effects(updated_mod, type = 'link') #' @@ -38,6 +38,7 @@ #' simdat$data_train$trials <- max(simdat$data_train$y) + 15 #' updated_mod <- update(mod, #' formula = cbind(y, trials) ~ s(season, bs = 'cc'), +#' noncentred = TRUE, #' data = simdat$data_train, #' family = binomial()) #' summary(updated_mod) diff --git a/R/validations.R b/R/validations.R index 8e8b09e1..8fef2738 100644 --- a/R/validations.R +++ b/R/validations.R @@ -204,7 +204,7 @@ validate_family = function(family, use_stan = TRUE){ } #'@noRd -validate_family_resrictions = function(response, family){ +validate_family_restrictions = function(response, family){ response <- response[!is.na(response)] diff --git a/README.Rmd b/README.Rmd index bac0a580..729b9f03 100644 --- a/README.Rmd +++ b/README.Rmd @@ -116,14 +116,14 @@ Inspect the series in a bit more detail using `mvgam`'s plotting utility plot_mvgam_series(data = lynx_train, y = 'population') ``` -Formulate an `mvgam` model; this model fits a GAM in which a cyclic smooth function for `season` is estimated jointly with a full time series model for the temporal process (in this case an `AR3` process). We assume the outcome follows a Poisson distribution and will condition the model in `Stan` using MCMC sampling with the `Cmdstan` interface: +Formulate an `mvgam` model; this model fits a GAM in which a cyclic smooth function for `season` is estimated jointly with a full time series model for the temporal process (in this case an `AR1` process). We assume the outcome follows a Poisson distribution and will condition the model in `Stan` using MCMC sampling with the `Cmdstan` interface: ```{r, include=FALSE} lynx_mvgam <- mvgam(data = lynx_train, newdata = lynx_test, formula = population ~ s(season, bs = 'cc', k = 12), knots = list(season = c(0.5, 19.5)), family = poisson(), - trend_model = AR(p = 3), + trend_model = AR(p = 1), noncentred = TRUE, use_stan = TRUE) ``` @@ -134,7 +134,7 @@ lynx_mvgam <- mvgam(population ~ s(season, bs = 'cc', k = 12), data = lynx_train, newdata = lynx_test, family = poisson(), - trend_model = AR(p = 3), + trend_model = AR(p = 1), backend = 'cmdstanr') ``` @@ -182,7 +182,7 @@ plot_mvgam_smooth(lynx_mvgam, series = 1, As for many types of regression models, it is often more useful to plot model effects on the outcome scale. `mvgam` has support for the wonderful `marginaleffects` package, allowing a wide variety of posterior contrasts, averages, conditional and marginal predictions to be calculated and plotted. Below is the conditional effect of season plotted on the outcome scale, for example: ```{r, fig.alt = "Using marginaleffects and mvgam to plot GAM smooth functions in R"} -require(ggplot2) +require(ggplot2); require(marginaleffects) plot_predictions(lynx_mvgam, condition = 'season', points = 0.5) + theme_classic() ``` @@ -206,7 +206,7 @@ text(1, 0.8, cex = 1.5, label="Trend component", pos = 4, col="#7C0000", family = 'serif') ``` -Both components contribute to forecast uncertainty. Diagnostics of the model can also be performed using `mvgam`. Have a look at the model's residuals, which are posterior empirical quantiles of Dunn-Smyth randomised quantile residuals so should follow approximate normality. We are primarily looking for a lack of autocorrelation, which would suggest our AR3 model is appropriate for the latent trend +Both components contribute to forecast uncertainty. Diagnostics of the model can also be performed using `mvgam`. Have a look at the model's residuals, which are posterior empirical quantiles of Dunn-Smyth randomised quantile residuals so should follow approximate normality. We are primarily looking for a lack of autocorrelation, which would suggest our AR1 model is appropriate for the latent trend ```{r, fig.width=6.5, fig.height=6.5, dpi=160, fig.alt = "Plotting Dunn-Smyth residuals for time series analysis in mvgam and R"} plot(lynx_mvgam, type = 'residuals') ``` diff --git a/README.md b/README.md index 42e1d984..5c6d535a 100644 --- a/README.md +++ b/README.md @@ -189,7 +189,7 @@ plot_mvgam_series(data = lynx_train, y = 'population') Formulate an `mvgam` model; this model fits a GAM in which a cyclic smooth function for `season` is estimated jointly with a full time -series model for the temporal process (in this case an `AR3` process). +series model for the temporal process (in this case an `AR1` process). We assume the outcome follows a Poisson distribution and will condition the model in `Stan` using MCMC sampling with the `Cmdstan` interface: @@ -199,7 +199,7 @@ lynx_mvgam <- mvgam(population ~ s(season, bs = 'cc', k = 12), data = lynx_train, newdata = lynx_test, family = poisson(), - trend_model = AR(p = 3), + trend_model = AR(p = 1), backend = 'cmdstanr') ``` @@ -219,7 +219,7 @@ summary(lynx_mvgam) #> log #> #> Trend model: -#> AR(p = 3) +#> AR(p = 1) #> #> N series: #> 1 @@ -234,31 +234,29 @@ summary(lynx_mvgam) #> #> #> GAM coefficient (beta) estimates: -#> 2.5% 50% 97.5% Rhat n_eff -#> (Intercept) 6.20 6.600 6.90 1 1177 -#> s(season).1 -0.55 -0.052 0.47 1 1078 -#> s(season).2 0.54 1.200 1.90 1 943 -#> s(season).3 1.10 1.900 2.60 1 920 -#> s(season).4 -0.11 0.540 1.20 1 1126 -#> s(season).5 -1.30 -0.580 0.14 1 757 -#> s(season).6 -1.10 -0.370 0.44 1 1156 -#> s(season).7 -0.24 0.670 1.50 1 1167 -#> s(season).8 0.12 1.100 1.90 1 630 -#> s(season).9 -0.54 0.050 0.66 1 977 -#> s(season).10 -1.40 -0.940 -0.53 1 1130 +#> 2.5% 50% 97.5% Rhat n_eff +#> (Intercept) 6.400 6.60 6.900 1 709 +#> s(season).1 -0.680 -0.13 0.360 1 1111 +#> s(season).2 0.730 1.30 1.900 1 1091 +#> s(season).3 1.200 1.90 2.500 1 733 +#> s(season).4 -0.085 0.54 1.100 1 900 +#> s(season).5 -1.300 -0.68 -0.089 1 850 +#> s(season).6 -1.200 -0.54 0.130 1 1139 +#> s(season).7 0.074 0.71 1.400 1 1063 +#> s(season).8 0.620 1.30 2.100 1 715 +#> s(season).9 -0.380 0.21 0.830 1 839 +#> s(season).10 -1.400 -0.85 -0.350 1 871 #> #> Approximate significance of GAM smooths: -#> edf Ref.df Chi.sq p-value -#> s(season) 9.98 10 38892 0.0012 ** +#> edf Ref.df Chi.sq p-value +#> s(season) 9.97 10 48.3 <2e-16 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 #> -#> Latent trend AR parameter estimates: -#> 2.5% 50% 97.5% Rhat n_eff -#> ar1[1] 0.610 0.86 0.99 1 1330 -#> ar2[1] 0.055 0.45 0.83 1 496 -#> ar3[1] 0.068 0.45 0.95 1 413 -#> sigma[1] 0.370 0.46 0.58 1 907 +#> Latent trend parameter AR estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> ar1[1] 0.60 0.83 0.97 1 656 +#> sigma[1] 0.39 0.47 0.62 1 715 #> #> Stan MCMC diagnostics: #> n_eff / iter looks reasonable for all parameters @@ -267,7 +265,7 @@ summary(lynx_mvgam) #> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%) #> E-FMI indicated no pathological behavior #> -#> Samples were drawn using NUTS(diag_e) at Wed Jun 12 9:37:37 AM 2024. +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 8:32:43 AM 2024. #> For each parameter, n_eff is a crude measure of effective sample size, #> and Rhat is the potential scale reduction factor on split MCMC chains #> (at convergence, Rhat = 1) @@ -374,7 +372,8 @@ be calculated and plotted. Below is the conditional effect of season plotted on the outcome scale, for example: ``` r -require(ggplot2) +require(ggplot2); require(marginaleffects) +#> Loading required package: marginaleffects plot_predictions(lynx_mvgam, condition = 'season', points = 0.5) + theme_classic() ``` @@ -387,7 +386,7 @@ series (testing and training) ``` r plot(lynx_mvgam, type = 'forecast', newdata = lynx_test) #> Out of sample DRPS: -#> 1879.7308065 +#> 2420.7128115 ``` Plotting forecast distributions using mvgam in R @@ -424,7 +423,7 @@ model can also be performed using `mvgam`. Have a look at the model’s residuals, which are posterior empirical quantiles of Dunn-Smyth randomised quantile residuals so should follow approximate normality. We are primarily looking for a lack of autocorrelation, which would suggest -our AR3 model is appropriate for the latent trend +our AR1 model is appropriate for the latent trend ``` r plot(lynx_mvgam, type = 'residuals') @@ -517,41 +516,41 @@ summary(mod, include_betas = FALSE) #> #> Observation precision parameter estimates: #> 2.5% 50% 97.5% Rhat n_eff -#> phi[1] 5.6 8.3 12 1 1528 -#> phi[2] 5.8 8.8 13 1 1347 -#> phi[3] 5.7 8.4 12 1 1430 +#> phi[1] 5.4 8.3 12 1 1248 +#> phi[2] 5.7 8.6 13 1 1312 +#> phi[3] 5.6 8.5 12 1 1724 #> #> GAM coefficient (beta) estimates: -#> 2.5% 50% 97.5% Rhat n_eff -#> (Intercept) -0.15 0.19 0.45 1 1001 +#> 2.5% 50% 97.5% Rhat n_eff +#> (Intercept) -0.2 0.19 0.46 1.01 566 #> #> Approximate significance of GAM smooths: #> edf Ref.df Chi.sq p-value -#> s(season) 4.297 5 39.37 <2e-16 *** -#> s(season):seriesseries_1 0.936 4 0.50 0.98 -#> s(season):seriesseries_2 0.935 4 0.39 0.99 -#> s(season):seriesseries_3 0.645 4 2.81 0.86 +#> s(season) 3.872 5 29.63 1.6e-05 *** +#> s(season):seriesseries_1 0.615 4 0.77 0.98 +#> s(season):seriesseries_2 1.012 4 0.30 0.99 +#> s(season):seriesseries_3 1.106 4 1.54 0.81 #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 #> #> Latent trend marginal deviation (alpha) and length scale (rho) estimates: #> 2.5% 50% 97.5% Rhat n_eff -#> alpha_gp[1] 0.078 0.42 0.90 1.00 877 -#> alpha_gp[2] 0.380 0.73 1.30 1.00 1130 -#> alpha_gp[3] 0.170 0.47 0.97 1.00 886 -#> rho_gp[1] 1.200 3.70 14.00 1.01 797 -#> rho_gp[2] 1.700 7.30 34.00 1.02 463 -#> rho_gp[3] 1.300 4.70 20.00 1.00 722 +#> alpha_gp[1] 0.051 0.41 0.92 1.01 525 +#> alpha_gp[2] 0.360 0.72 1.20 1.00 946 +#> alpha_gp[3] 0.150 0.46 1.00 1.00 659 +#> rho_gp[1] 1.100 3.80 15.00 1.01 370 +#> rho_gp[2] 1.900 7.80 37.00 1.01 365 +#> rho_gp[3] 1.400 5.10 21.00 1.00 645 #> #> Stan MCMC diagnostics: #> n_eff / iter looks reasonable for all parameters #> Rhat looks reasonable for all parameters -#> 4 of 2000 iterations ended with a divergence (0.2%) +#> 12 of 2000 iterations ended with a divergence (0.6%) #> *Try running with larger adapt_delta to remove the divergences #> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%) #> E-FMI indicated no pathological behavior #> -#> Samples were drawn using NUTS(diag_e) at Wed Jun 12 9:38:57 AM 2024. +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 8:34:07 AM 2024. #> For each parameter, n_eff is a crude measure of effective sample size, #> and Rhat is the potential scale reduction factor on split MCMC chains #> (at convergence, Rhat = 1) diff --git a/cran-comments.md b/cran-comments.md index 85114a96..d77db677 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,8 +1,7 @@ -## Version 1.1.1 +## Version 1.1.2 -## Response to previous check comments -* 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. I presume this was triggered by a memory 'Invalid read of size' message from `valgrind`, which occurred in one of the examples and one of the tests. Strangely this behaviour did not occur in other examples that use identical codes, so I suspect it may have been a false positive. But nevertheless I have made some changes and re-checked with `valgrind` (see '`valgrind` memory check results' below) -* Also reduced sizes of vignette html files in response to several NOTEs about the large package install size +## Summary of changes +This version brings a few efficiency updates and added functionality to enhance the user interface. There are no major structural changes or modifications that would break pre-existing workflows ## Test environments * Windows install: R 4.3.1 diff --git a/doc/forecast_evaluation.R b/doc/forecast_evaluation.R index 28942b03..8412f550 100644 --- a/doc/forecast_evaluation.R +++ b/doc/forecast_evaluation.R @@ -7,10 +7,11 @@ knitr::opts_chunk$set( eval = NOT_CRAN ) + ## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, - dpi = 150, + dpi = 100, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -19,39 +20,31 @@ library(mvgam) library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) + ## ----------------------------------------------------------------------------- set.seed(2345) simdat <- sim_mvgam(T = 100, n_series = 3, - trend_model = 'GP', + trend_model = GP(), prop_trend = 0.75, family = poisson(), prop_missing = 0.10) + ## ----------------------------------------------------------------------------- str(simdat) -## ----fig.alt = "Simulating data for dynamic GAM models in mvgam"-------------- -plot(simdat$global_seasonality[1:12], - type = 'l', lwd = 2, - ylab = 'Relative effect', - xlab = 'Season', - bty = 'l') ## ----fig.alt = "Plotting time series features for GAM models in mvgam"-------- plot_mvgam_series(data = simdat$data_train, series = 'all') + ## ----fig.alt = "Plotting time series features for GAM models in mvgam"-------- plot_mvgam_series(data = simdat$data_train, newdata = simdat$data_test, series = 1) -plot_mvgam_series(data = simdat$data_train, - newdata = simdat$data_test, - series = 2) -plot_mvgam_series(data = simdat$data_train, - newdata = simdat$data_test, - series = 3) + ## ----include=FALSE------------------------------------------------------------ mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + @@ -60,18 +53,23 @@ mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + trend_model = 'None', data = simdat$data_train) + ## ----eval=FALSE--------------------------------------------------------------- -# mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + -# s(time, by = series, bs = 'cr', k = 20), -# knots = list(season = c(0.5, 12.5)), -# trend_model = 'None', -# data = simdat$data_train) +## mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + +## s(time, by = series, bs = 'cr', k = 20), +## knots = list(season = c(0.5, 12.5)), +## trend_model = 'None', +## data = simdat$data_train, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(mod1, include_betas = FALSE) + ## ----fig.alt = "Plotting GAM smooth functions using mvgam"-------------------- -plot(mod1, type = 'smooths') +conditional_effects(mod1, type = 'link') + ## ----include=FALSE------------------------------------------------------------ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + @@ -80,42 +78,45 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) + ## ----eval=FALSE--------------------------------------------------------------- -# mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + -# gp(time, by = series, c = 5/4, k = 20, -# scale = FALSE), -# knots = list(season = c(0.5, 12.5)), -# trend_model = 'None', -# data = simdat$data_train) +## mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + +## gp(time, by = series, c = 5/4, k = 20, +## scale = FALSE), +## knots = list(season = c(0.5, 12.5)), +## trend_model = 'None', +## data = simdat$data_train, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(mod2, include_betas = FALSE) + ## ----fig.alt = "Summarising latent Gaussian Process parameters in mvgam"------ mcmc_plot(mod2, variable = c('alpha_gp'), regex = TRUE, type = 'areas') + ## ----fig.alt = "Summarising latent Gaussian Process parameters in mvgam"------ mcmc_plot(mod2, variable = c('rho_gp'), regex = TRUE, type = 'areas') -## ----fig.alt = "Plotting Gaussian Process effects in mvgam"------------------- -plot(mod2, type = 'smooths') -## ----fig.alt = "Summarising latent Gaussian Process parameters in mvgam and marginaleffects"---- -require('ggplot2') -plot_predictions(mod2, - condition = c('time', 'series', 'series'), - type = 'link') + - theme(legend.position = 'none') +## ----fig.alt = "Plotting latent Gaussian Process effects in mvgam and marginaleffects"---- +conditional_effects(mod2, type = 'link') + ## ----------------------------------------------------------------------------- fc_mod1 <- forecast(mod1, newdata = simdat$data_test) fc_mod2 <- forecast(mod2, newdata = simdat$data_test) + ## ----------------------------------------------------------------------------- str(fc_mod1) + ## ----------------------------------------------------------------------------- plot(fc_mod1, series = 1) plot(fc_mod2, series = 1) @@ -123,8 +124,6 @@ plot(fc_mod2, series = 1) plot(fc_mod1, series = 2) plot(fc_mod2, series = 2) -plot(fc_mod1, series = 3) -plot(fc_mod2, series = 3) ## ----include=FALSE------------------------------------------------------------ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + @@ -134,43 +133,54 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + trend_model = 'None', data = simdat$data_train, newdata = simdat$data_test, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) + ## ----eval=FALSE--------------------------------------------------------------- -# mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + -# gp(time, by = series, c = 5/4, k = 20, -# scale = FALSE), -# knots = list(season = c(0.5, 12.5)), -# trend_model = 'None', -# data = simdat$data_train, -# newdata = simdat$data_test) +## mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + +## gp(time, by = series, c = 5/4, k = 20, +## scale = FALSE), +## knots = list(season = c(0.5, 12.5)), +## trend_model = 'None', +## data = simdat$data_train, +## newdata = simdat$data_test, +## silent = 2) + ## ----------------------------------------------------------------------------- fc_mod2 <- forecast(mod2) + ## ----warning=FALSE, fig.alt = "Plotting posterior forecast distributions using mvgam and R"---- plot(fc_mod2, series = 1) + ## ----warning=FALSE------------------------------------------------------------ crps_mod1 <- score(fc_mod1, score = 'crps') str(crps_mod1) crps_mod1$series_1 + ## ----warning=FALSE------------------------------------------------------------ crps_mod1 <- score(fc_mod1, score = 'crps', interval_width = 0.6) crps_mod1$series_1 + ## ----------------------------------------------------------------------------- link_mod1 <- forecast(mod1, newdata = simdat$data_test, type = 'link') score(link_mod1, score = 'elpd')$series_1 + ## ----------------------------------------------------------------------------- energy_mod2 <- score(fc_mod2, score = 'energy') str(energy_mod2) + ## ----------------------------------------------------------------------------- energy_mod2$all_series + ## ----------------------------------------------------------------------------- crps_mod1 <- score(fc_mod1, score = 'crps') crps_mod2 <- score(fc_mod2, score = 'crps') diff --git a/doc/forecast_evaluation.Rmd b/doc/forecast_evaluation.Rmd index 36ea6227..8979593d 100644 --- a/doc/forecast_evaluation.Rmd +++ b/doc/forecast_evaluation.Rmd @@ -23,7 +23,7 @@ knitr::opts_chunk$set( ```{r setup, include=FALSE} knitr::opts_chunk$set( echo = TRUE, - dpi = 150, + dpi = 100, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -36,12 +36,12 @@ theme_set(theme_bw(base_size = 12, base_family = 'serif')) The purpose of this vignette is to show how the `mvgam` package can be used to produce probabilistic forecasts and to evaluate those forecasts using a variety of proper scoring rules. ## Simulating discrete time series -We begin by simulating some data to show how forecasts are computed and evaluated in `mvgam`. The `sim_mvgam()` function can be used to simulate series that come from a variety of response distributions as well as seasonal patterns and/or dynamic temporal patterns. Here we simulate a collection of three time count-valued series. These series all share the same seasonal pattern but have different temporal dynamics. By setting `trend_model = 'GP'` and `prop_trend = 0.75`, we are generating time series that have smooth underlying temporal trends (evolving as Gaussian Processes with squared exponential kernel) and moderate seasonal patterns. The observations are Poisson-distributed and we allow 10% of observations to be missing. +We begin by simulating some data to show how forecasts are computed and evaluated in `mvgam`. The `sim_mvgam()` function can be used to simulate series that come from a variety of response distributions as well as seasonal patterns and/or dynamic temporal patterns. Here we simulate a collection of three time count-valued series. These series all share the same seasonal pattern but have different temporal dynamics. By setting `trend_model = GP()` and `prop_trend = 0.75`, we are generating time series that have smooth underlying temporal trends (evolving as Gaussian Processes with squared exponential kernel) and moderate seasonal patterns. The observations are Poisson-distributed and we allow 10% of observations to be missing. ```{r} set.seed(2345) simdat <- sim_mvgam(T = 100, n_series = 3, - trend_model = 'GP', + trend_model = GP(), prop_trend = 0.75, family = poisson(), prop_missing = 0.10) @@ -52,32 +52,17 @@ The returned object is a `list` containing training and testing data (`sim_mvgam str(simdat) ``` -Each series in this case has a shared seasonal pattern, which we can visualise: -```{r, fig.alt = "Simulating data for dynamic GAM models in mvgam"} -plot(simdat$global_seasonality[1:12], - type = 'l', lwd = 2, - ylab = 'Relative effect', - xlab = 'Season', - bty = 'l') -``` - -The resulting time series are similar to what we might encounter when dealing with count-valued data that can take small counts: +Each series in this case has a shared seasonal pattern. The resulting time series are similar to what we might encounter when dealing with count-valued data that can take small counts: ```{r, fig.alt = "Plotting time series features for GAM models in mvgam"} plot_mvgam_series(data = simdat$data_train, series = 'all') ``` -For each individual series, we can plot the training and testing data, as well as some more specific features of the observed data: +For individual series, we can plot the training and testing data, as well as some more specific features of the observed data: ```{r, fig.alt = "Plotting time series features for GAM models in mvgam"} plot_mvgam_series(data = simdat$data_train, newdata = simdat$data_test, series = 1) -plot_mvgam_series(data = simdat$data_train, - newdata = simdat$data_test, - series = 2) -plot_mvgam_series(data = simdat$data_train, - newdata = simdat$data_test, - series = 3) ``` ### Modelling dynamics with splines @@ -95,7 +80,8 @@ mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + s(time, by = series, bs = 'cr', k = 20), knots = list(season = c(0.5, 12.5)), trend_model = 'None', - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The model fits without issue: @@ -103,9 +89,9 @@ The model fits without issue: summary(mod1, include_betas = FALSE) ``` -And we can plot the partial effects of the splines to see that they are estimated to be highly nonlinear +And we can plot the conditional effects of the splines (on the link scale) to see that they are estimated to be highly nonlinear ```{r, fig.alt = "Plotting GAM smooth functions using mvgam"} -plot(mod1, type = 'smooths') +conditional_effects(mod1, type = 'link') ``` ### Modelling dynamics with GPs @@ -117,7 +103,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) ``` ```{r eval=FALSE} @@ -126,7 +113,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + scale = FALSE), knots = list(season = c(0.5, 12.5)), trend_model = 'None', - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The summary for this model now contains information on the GP parameters for each time series: @@ -144,17 +132,9 @@ And now the length scale ($\rho$) parameters: mcmc_plot(mod2, variable = c('rho_gp'), regex = TRUE, type = 'areas') ``` -We can also plot the nonlinear effects as before: -```{r, fig.alt = "Plotting Gaussian Process effects in mvgam"} -plot(mod2, type = 'smooths') -``` -These can also be plotted using `marginaleffects` utilities: -```{r, fig.alt = "Summarising latent Gaussian Process parameters in mvgam and marginaleffects"} -require('ggplot2') -plot_predictions(mod2, - condition = c('time', 'series', 'series'), - type = 'link') + - theme(legend.position = 'none') +We can again plot the nonlinear effects: +```{r, fig.alt = "Plotting latent Gaussian Process effects in mvgam and marginaleffects"} +conditional_effects(mod2, type = 'link') ``` The estimates for the temporal trends are fairly similar for the two models, but below we will see if they produce similar forecasts @@ -171,16 +151,13 @@ The objects we have created are of class `mvgam_forecast`, which contain informa str(fc_mod1) ``` -We can plot the forecasts for each series from each model using the `S3 plot` method for objects of this class: +We can plot the forecasts for some series from each model using the `S3 plot` method for objects of this class: ```{r} plot(fc_mod1, series = 1) plot(fc_mod2, series = 1) plot(fc_mod1, series = 2) plot(fc_mod2, series = 2) - -plot(fc_mod1, series = 3) -plot(fc_mod2, series = 3) ``` Clearly the two models do not produce equivalent forecasts. We will come back to scoring these forecasts in a moment. @@ -195,7 +172,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + trend_model = 'None', data = simdat$data_train, newdata = simdat$data_test, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) ``` ```{r eval=FALSE} @@ -205,7 +183,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - newdata = simdat$data_test) + newdata = simdat$data_test, + silent = 2) ``` Because the model already contains a forecast distribution, we do not need to feed `newdata` to the `forecast()` function: diff --git a/doc/forecast_evaluation.html b/doc/forecast_evaluation.html index 570bab86..ae761ae5 100644 --- a/doc/forecast_evaluation.html +++ b/doc/forecast_evaluation.html @@ -12,7 +12,7 @@ - + Forecasting and forecast evaluation in mvgam @@ -341,7 +341,7 @@

Forecasting and forecast evaluation in mvgam

Nicholas J Clark

-

2024-04-18

+

2024-07-01

@@ -378,7 +378,7 @@

Simulating discrete time series

temporal patterns. Here we simulate a collection of three time count-valued series. These series all share the same seasonal pattern but have different temporal dynamics. By setting -trend_model = 'GP' and prop_trend = 0.75, we +trend_model = GP() and prop_trend = 0.75, we are generating time series that have smooth underlying temporal trends (evolving as Gaussian Processes with squared exponential kernel) and moderate seasonal patterns. The observations are Poisson-distributed and @@ -386,7 +386,7 @@

Simulating discrete time series

set.seed(2345)
 simdat <- sim_mvgam(T = 100, 
                     n_series = 3, 
-                    trend_model = 'GP',
+                    trend_model = GP(),
                     prop_trend = 0.75,
                     family = poisson(),
                     prop_missing = 0.10)
@@ -414,33 +414,18 @@

Simulating discrete time series

#> $ trend_params :List of 2 #> ..$ alpha: num [1:3] 0.767 0.988 0.897 #> ..$ rho : num [1:3] 6.02 6.94 5.04
-

Each series in this case has a shared seasonal pattern, which we can -visualise:

-
plot(simdat$global_seasonality[1:12], 
-     type = 'l', lwd = 2,
-     ylab = 'Relative effect',
-     xlab = 'Season',
-     bty = 'l')
-

Simulating data for dynamic GAM models in mvgam

-

The resulting time series are similar to what we might encounter when -dealing with count-valued data that can take small counts:

+

Each series in this case has a shared seasonal pattern. The resulting +time series are similar to what we might encounter when dealing with +count-valued data that can take small counts:

+
plot_mvgam_series(data = simdat$data_train, 
+                  series = 'all')
+

Plotting time series features for GAM models in mvgam

+

For individual series, we can plot the training and testing data, as +well as some more specific features of the observed data:

plot_mvgam_series(data = simdat$data_train, 
-                  series = 'all')
-

Plotting time series features for GAM models in mvgam

-

For each individual series, we can plot the training and testing -data, as well as some more specific features of the observed data:

-
plot_mvgam_series(data = simdat$data_train, 
-                  newdata = simdat$data_test,
-                  series = 1)
-

Plotting time series features for GAM models in mvgam

-
plot_mvgam_series(data = simdat$data_train, 
-                  newdata = simdat$data_test,
-                  series = 2)
-

Plotting time series features for GAM models in mvgam

-
plot_mvgam_series(data = simdat$data_train, 
-                  newdata = simdat$data_test,
-                  series = 3)
-

Plotting time series features for GAM models in mvgam

+ newdata = simdat$data_test, + series = 1) +

Plotting time series features for GAM models in mvgam

Modelling dynamics with splines

The first model we will fit uses a shared cyclic spline to capture @@ -448,17 +433,91 @@

Modelling dynamics with splines

capture the long-term dynamics. We allow the temporal splines to be fairly complex so they can capture as much of the temporal variation as possible:

-
mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + 
-                s(time, by = series, bs = 'cr', k = 20),
-              knots = list(season = c(0.5, 12.5)),
-              trend_model = 'None',
-              data = simdat$data_train)
+
mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + 
+                s(time, by = series, bs = 'cr', k = 20),
+              knots = list(season = c(0.5, 12.5)),
+              trend_model = 'None',
+              data = simdat$data_train,
+              silent = 2)

The model fits without issue:

-
summary(mod1, include_betas = FALSE)
+
summary(mod1, include_betas = FALSE)
+#> GAM formula:
+#> y ~ s(season, bs = "cc", k = 8) + s(time, by = series, bs = "cr", 
+#>     k = 20)
+#> <environment: 0x000001b67206d110>
+#> 
+#> Family:
+#> poisson
+#> 
+#> Link function:
+#> log
+#> 
+#> Trend model:
+#> None
+#> 
+#> N series:
+#> 3 
+#> 
+#> N timepoints:
+#> 75 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> GAM coefficient (beta) estimates:
+#>              2.5%   50%  97.5% Rhat n_eff
+#> (Intercept) -0.41 -0.21 -0.052    1   855
+#> 
+#> Approximate significance of GAM smooths:
+#>                         edf Ref.df Chi.sq p-value   
+#> s(season)              3.82      6   19.6  0.0037 **
+#> s(time):seriesseries_1 7.25     19   13.2  0.7969   
+#> s(time):seriesseries_2 9.81     19  173.3  0.0019 **
+#> s(time):seriesseries_3 6.05     19   19.4  0.7931   
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:26:51 AM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

+
And we can plot the conditional effects of the splines (on the link
+scale) to see that they are estimated to be highly nonlinear

+
conditional_effects(mod1, type = 'link')

+
Plotting GAM smooth functions using mvgamPlotting GAM smooth functions using mvgam

+
+
+

Modelling dynamics with GPs

+

Before showing how to produce and evaluate forecasts, we will fit a +second model to these data so the two models can be compared. This model +is equivalent to the above, except we now use Gaussian Processes to +model series-specific dynamics. This makes use of the gp() +function from brms, which can fit Hilbert space approximate +GPs. See ?brms::gp for more details.

+
mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + 
+                gp(time, by = series, c = 5/4, k = 20,
+                   scale = FALSE),
+              knots = list(season = c(0.5, 12.5)),
+              trend_model = 'None',
+              data = simdat$data_train,
+              silent = 2)
+

The summary for this model now contains information on the GP +parameters for each time series:

+
summary(mod2, include_betas = FALSE)
 #> GAM formula:
-#> y ~ s(season, bs = "cc", k = 8) + s(time, by = series, bs = "cr", 
-#>     k = 20)
-#> <environment: 0x0000029cbf2b3570>
+#> y ~ s(season, bs = "cc", k = 8) + gp(time, by = series, c = 5/4, 
+#>     k = 20, scale = FALSE)
+#> <environment: 0x000001b67206d110>
 #> 
 #> Family:
 #> poisson
@@ -482,129 +541,49 @@ 
Modelling dynamics with splines

 #> 
 #> 
 #> GAM coefficient (beta) estimates:
-#>              2.5%   50%  97.5% Rhat n_eff
-#> (Intercept) -0.41 -0.21 -0.039    1   813
+#>             2.5%   50% 97.5% Rhat n_eff
+#> (Intercept) -1.1 -0.51  0.34    1   694
 #> 
-#> Approximate significance of GAM smooths:
-#>                         edf Ref.df Chi.sq p-value    
-#> s(season)              3.77      6   21.8   0.004 ** 
-#> s(time):seriesseries_1 6.50     19   15.3   0.848    
-#> s(time):seriesseries_2 9.49     19  226.0  <2e-16 ***
-#> s(time):seriesseries_3 5.93     19   18.3   0.867    
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> GAM gp term marginal deviation (alpha) and length scale (rho) estimates:
+#>                               2.5%   50% 97.5% Rhat n_eff
+#> alpha_gp(time):seriesseries_1 0.21  0.78   2.2    1   819
+#> alpha_gp(time):seriesseries_2 0.73  1.30   2.9    1   761
+#> alpha_gp(time):seriesseries_3 0.46  1.10   2.8    1  1262
+#> rho_gp(time):seriesseries_1   1.30  5.40  22.0    1   682
+#> rho_gp(time):seriesseries_2   2.10 10.00  17.0    1   450
+#> rho_gp(time):seriesseries_3   1.50  8.80  24.0    1   769
 #> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Thu Apr 18 8:31:33 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
-

And we can plot the partial effects of the splines to see that they -are estimated to be highly nonlinear

-
plot(mod1, type = 'smooths')
-

Plotting GAM smooth functions using mvgam

-
-
-

Modelling dynamics with GPs

-

Before showing how to produce and evaluate forecasts, we will fit a -second model to these data so the two models can be compared. This model -is equivalent to the above, except we now use Gaussian Processes to -model series-specific dynamics. This makes use of the gp() -function from brms, which can fit Hilbert space approximate -GPs. See ?brms::gp for more details.

-
mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + 
-                gp(time, by = series, c = 5/4, k = 20,
-                   scale = FALSE),
-              knots = list(season = c(0.5, 12.5)),
-              trend_model = 'None',
-              data = simdat$data_train)
-

The summary for this model now contains information on the GP -parameters for each time series:

-
summary(mod2, include_betas = FALSE)
-#> GAM formula:
-#> y ~ s(season, bs = "cc", k = 8) + gp(time, by = series, c = 5/4, 
-#>     k = 20, scale = FALSE)
-#> <environment: 0x0000029cbf2b3570>
-#> 
-#> Family:
-#> poisson
-#> 
-#> Link function:
-#> log
-#> 
-#> Trend model:
-#> None
-#> 
-#> N series:
-#> 3 
-#> 
-#> N timepoints:
-#> 75 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> GAM coefficient (beta) estimates:
-#>             2.5%   50% 97.5% Rhat n_eff
-#> (Intercept) -1.1 -0.52  0.31    1   768
-#> 
-#> GAM gp term marginal deviation (alpha) and length scale (rho) estimates:
-#>                               2.5%  50% 97.5% Rhat n_eff
-#> alpha_gp(time):seriesseries_1 0.21  0.8   2.1 1.01   763
-#> alpha_gp(time):seriesseries_2 0.74  1.4   2.9 1.00  1028
-#> alpha_gp(time):seriesseries_3 0.50  1.1   2.8 1.00  1026
-#> rho_gp(time):seriesseries_1   1.20  5.1  23.0 1.00   681
-#> rho_gp(time):seriesseries_2   2.20 10.0  17.0 1.00   644
-#> rho_gp(time):seriesseries_3   1.50  8.8  23.0 1.00   819
-#> 
-#> Approximate significance of GAM smooths:
-#>            edf Ref.df Chi.sq p-value    
-#> s(season) 4.12      6   25.9 0.00053 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 4 of 2000 iterations ended with a divergence (0.2%)
-#>  *Try running with larger adapt_delta to remove the divergences
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Thu Apr 18 8:33:03 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
+#> Approximate significance of GAM smooths: +#> edf Ref.df Chi.sq p-value +#> s(season) 3.36 6 21.1 0.0093 ** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> +#> Stan MCMC diagnostics: +#> n_eff / iter looks reasonable for all parameters +#> Rhat looks reasonable for all parameters +#> 1 of 2000 iterations ended with a divergence (0.05%) +#> *Try running with larger adapt_delta to remove the divergences +#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%) +#> E-FMI indicated no pathological behavior +#> +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:27:28 AM 2024. +#> For each parameter, n_eff is a crude measure of effective sample size, +#> and Rhat is the potential scale reduction factor on split MCMC chains +#> (at convergence, Rhat = 1)

We can plot the posteriors for these parameters, and for any other parameter for that matter, using bayesplot routines. First the marginal deviation (\(\alpha\)) parameters:

-
mcmc_plot(mod2, variable = c('alpha_gp'), regex = TRUE, type = 'areas')
-

Summarising latent Gaussian Process parameters in mvgam

+
mcmc_plot(mod2, variable = c('alpha_gp'), regex = TRUE, type = 'areas')
+

Summarising latent Gaussian Process parameters in mvgam

And now the length scale (\(\rho\)) parameters:

-
mcmc_plot(mod2, variable = c('rho_gp'), regex = TRUE, type = 'areas')
-

Summarising latent Gaussian Process parameters in mvgam

-

We can also plot the nonlinear effects as before:

-
plot(mod2, type = 'smooths')
-

Plotting Gaussian Process effects in mvgam -These can also be plotted using marginaleffects -utilities:

-
require('ggplot2')
-plot_predictions(mod2, 
-                 condition = c('time', 'series', 'series'),
-                 type = 'link') +
-  theme(legend.position = 'none')
-

Summarising latent Gaussian Process parameters in mvgam and marginaleffects

+
mcmc_plot(mod2, variable = c('rho_gp'), regex = TRUE, type = 'areas')
+

Summarising latent Gaussian Process parameters in mvgam

+

We can again plot the nonlinear effects:

+
conditional_effects(mod2, type = 'link')
+

Plotting latent Gaussian Process effects in mvgam and marginaleffectsPlotting latent Gaussian Process effects in mvgam and marginaleffects

The estimates for the temporal trends are fairly similar for the two models, but below we will see if they produce similar forecasts

@@ -627,80 +606,71 @@

Forecasting with the forecast() function

?forecast.mvgam for details). We will use the default and produce forecasts on the response scale, which is the most common way to evaluate forecast distributions

-
fc_mod1 <- forecast(mod1, newdata = simdat$data_test)
-fc_mod2 <- forecast(mod2, newdata = simdat$data_test)
+
fc_mod1 <- forecast(mod1, newdata = simdat$data_test)
+fc_mod2 <- forecast(mod2, newdata = simdat$data_test)

The objects we have created are of class mvgam_forecast, which contain information on hindcast distributions, forecast distributions and true observations for each series in the data:

-
str(fc_mod1)
-#> List of 16
-#>  $ call              :Class 'formula'  language y ~ s(season, bs = "cc", k = 8) + s(time, by = series, bs = "cr", k = 20)
-#>   .. ..- attr(*, ".Environment")=<environment: 0x0000029cbf2b3570> 
-#>  $ trend_call        : NULL
-#>  $ family            : chr "poisson"
-#>  $ family_pars       : NULL
-#>  $ trend_model       : chr "None"
-#>  $ drift             : logi FALSE
-#>  $ use_lv            : logi FALSE
-#>  $ fit_engine        : chr "stan"
-#>  $ type              : chr "response"
-#>  $ series_names      : Factor w/ 3 levels "series_1","series_2",..: 1 2 3
-#>  $ train_observations:List of 3
-#>   ..$ series_1: int [1:75] 0 0 1 1 0 0 0 0 0 0 ...
-#>   ..$ series_2: int [1:75] 1 0 0 1 1 0 1 0 1 2 ...
-#>   ..$ series_3: int [1:75] 3 0 3 NA 2 1 1 1 1 3 ...
-#>  $ train_times       : int [1:75] 1 2 3 4 5 6 7 8 9 10 ...
-#>  $ test_observations :List of 3
-#>   ..$ series_1: int [1:25] 0 0 2 NA 0 2 2 1 1 1 ...
-#>   ..$ series_2: int [1:25] 1 0 2 1 1 3 0 1 0 NA ...
-#>   ..$ series_3: int [1:25] 1 0 0 1 0 0 1 0 1 0 ...
-#>  $ test_times        : int [1:25] 76 77 78 79 80 81 82 83 84 85 ...
-#>  $ hindcasts         :List of 3
-#>   ..$ series_1: num [1:2000, 1:75] 1 1 0 0 0 1 1 1 0 0 ...
-#>   .. ..- attr(*, "dimnames")=List of 2
-#>   .. .. ..$ : NULL
-#>   .. .. ..$ : chr [1:75] "ypred[1,1]" "ypred[2,1]" "ypred[3,1]" "ypred[4,1]" ...
-#>   ..$ series_2: num [1:2000, 1:75] 0 0 0 0 0 0 0 1 0 0 ...
-#>   .. ..- attr(*, "dimnames")=List of 2
-#>   .. .. ..$ : NULL
-#>   .. .. ..$ : chr [1:75] "ypred[1,2]" "ypred[2,2]" "ypred[3,2]" "ypred[4,2]" ...
-#>   ..$ series_3: num [1:2000, 1:75] 3 0 2 1 0 1 2 1 5 1 ...
-#>   .. ..- attr(*, "dimnames")=List of 2
-#>   .. .. ..$ : NULL
-#>   .. .. ..$ : chr [1:75] "ypred[1,3]" "ypred[2,3]" "ypred[3,3]" "ypred[4,3]" ...
-#>  $ forecasts         :List of 3
-#>   ..$ series_1: num [1:2000, 1:25] 1 3 2 1 0 0 1 1 0 0 ...
-#>   ..$ series_2: num [1:2000, 1:25] 6 0 0 0 0 2 0 0 0 0 ...
-#>   ..$ series_3: num [1:2000, 1:25] 0 1 1 3 3 1 3 2 4 2 ...
-#>  - attr(*, "class")= chr "mvgam_forecast"
-

We can plot the forecasts for each series from each model using the +

str(fc_mod1)
+#> List of 16
+#>  $ call              :Class 'formula'  language y ~ s(season, bs = "cc", k = 8) + s(time, by = series, bs = "cr", k = 20)
+#>   .. ..- attr(*, ".Environment")=<environment: 0x000001b67206d110> 
+#>  $ trend_call        : NULL
+#>  $ family            : chr "poisson"
+#>  $ family_pars       : NULL
+#>  $ trend_model       : chr "None"
+#>  $ drift             : logi FALSE
+#>  $ use_lv            : logi FALSE
+#>  $ fit_engine        : chr "stan"
+#>  $ type              : chr "response"
+#>  $ series_names      : Factor w/ 3 levels "series_1","series_2",..: 1 2 3
+#>  $ train_observations:List of 3
+#>   ..$ series_1: int [1:75] 0 0 1 1 0 0 0 0 0 0 ...
+#>   ..$ series_2: int [1:75] 1 0 0 1 1 0 1 0 1 2 ...
+#>   ..$ series_3: int [1:75] 3 0 3 NA 2 1 1 1 1 3 ...
+#>  $ train_times       : int [1:75] 1 2 3 4 5 6 7 8 9 10 ...
+#>  $ test_observations :List of 3
+#>   ..$ series_1: int [1:25] 0 0 2 NA 0 2 2 1 1 1 ...
+#>   ..$ series_2: int [1:25] 1 0 2 1 1 3 0 1 0 NA ...
+#>   ..$ series_3: int [1:25] 1 0 0 1 0 0 1 0 1 0 ...
+#>  $ test_times        : int [1:25] 76 77 78 79 80 81 82 83 84 85 ...
+#>  $ hindcasts         :List of 3
+#>   ..$ series_1: num [1:2000, 1:75] 1 1 0 0 0 0 0 0 0 0 ...
+#>   .. ..- attr(*, "dimnames")=List of 2
+#>   .. .. ..$ : NULL
+#>   .. .. ..$ : chr [1:75] "ypred[1,1]" "ypred[2,1]" "ypred[3,1]" "ypred[4,1]" ...
+#>   ..$ series_2: num [1:2000, 1:75] 0 0 0 0 0 0 0 0 0 0 ...
+#>   .. ..- attr(*, "dimnames")=List of 2
+#>   .. .. ..$ : NULL
+#>   .. .. ..$ : chr [1:75] "ypred[1,2]" "ypred[2,2]" "ypred[3,2]" "ypred[4,2]" ...
+#>   ..$ series_3: num [1:2000, 1:75] 1 4 0 4 4 1 1 6 3 1 ...
+#>   .. ..- attr(*, "dimnames")=List of 2
+#>   .. .. ..$ : NULL
+#>   .. .. ..$ : chr [1:75] "ypred[1,3]" "ypred[2,3]" "ypred[3,3]" "ypred[4,3]" ...
+#>  $ forecasts         :List of 3
+#>   ..$ series_1: num [1:2000, 1:25] 0 1 0 0 0 1 1 0 0 3 ...
+#>   ..$ series_2: num [1:2000, 1:25] 0 2 0 1 0 2 1 0 1 0 ...
+#>   ..$ series_3: num [1:2000, 1:25] 1 8 4 2 2 1 2 0 2 0 ...
+#>  - attr(*, "class")= chr "mvgam_forecast"
+

We can plot the forecasts for some series from each model using the S3 plot method for objects of this class:

-
plot(fc_mod1, series = 1)
-

-
#> Out of sample CRPS:
-#> [1] 14.62964
-plot(fc_mod2, series = 1)
-

-
#> Out of sample DRPS:
-#> [1] 10.92516
-
-plot(fc_mod1, series = 2)
-

-
#> Out of sample CRPS:
-#> [1] 84201962708
-plot(fc_mod2, series = 2)
-

-
#> Out of sample DRPS:
-#> [1] 14.31152
-
-plot(fc_mod1, series = 3)
-

-
#> Out of sample CRPS:
-#> [1] 32.44136
-plot(fc_mod2, series = 3)
-

-
#> Out of sample DRPS:
-#> [1] 15.44332
+
plot(fc_mod1, series = 1)
+#> Out of sample CRPS:
+#> 14.89051875
+

+
plot(fc_mod2, series = 1)
+#> Out of sample DRPS:
+#> 10.84228725
+

+

+plot(fc_mod1, series = 2)
+#> Out of sample CRPS:
+#> 495050222726067
+

+
plot(fc_mod2, series = 2)
+#> Out of sample CRPS:
+#> 14.7121945
+

Clearly the two models do not produce equivalent forecasts. We will come back to scoring these forecasts in a moment.

@@ -714,23 +684,24 @@

Forecasting with newdata in mvgam()

block in Stan. As an example, we can refit mod2 but include the testing data for automatic forecasts:

-
mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + 
-                gp(time, by = series, c = 5/4, k = 20,
-                   scale = FALSE),
-              knots = list(season = c(0.5, 12.5)),
-              trend_model = 'None',
-              data = simdat$data_train,
-              newdata = simdat$data_test)
+
mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + 
+                gp(time, by = series, c = 5/4, k = 20,
+                   scale = FALSE),
+              knots = list(season = c(0.5, 12.5)),
+              trend_model = 'None',
+              data = simdat$data_train,
+              newdata = simdat$data_test,
+              silent = 2)

Because the model already contains a forecast distribution, we do not need to feed newdata to the forecast() function:

-
fc_mod2 <- forecast(mod2)
+
fc_mod2 <- forecast(mod2)

The forecasts will be nearly identical to those calculated previously:

-
plot(fc_mod2, series = 1)
-

Plotting posterior forecast distributions using mvgam and R

-
#> Out of sample DRPS:
-#> [1] 10.85762
+
plot(fc_mod2, series = 1)
+#> Out of sample DRPS:
+#> 10.78167525
+

Plotting posterior forecast distributions using mvgam and R

Scoring forecast distributions

@@ -741,58 +712,58 @@

Scoring forecast distributions

that are available. A useful scoring metric is the Continuous Rank Probability Score (CRPS). A CRPS value is similar to what we might get if we calculated a weighted absolute error using the full forecast distribution.

-
crps_mod1 <- score(fc_mod1, score = 'crps')
-str(crps_mod1)
-#> List of 4
-#>  $ series_1  :'data.frame':  25 obs. of  5 variables:
-#>   ..$ score         : num [1:25] 0.1938 0.1366 1.355 NA 0.0348 ...
-#>   ..$ in_interval   : num [1:25] 1 1 1 NA 1 1 1 1 1 1 ...
-#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
-#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
-#>   ..$ score_type    : chr [1:25] "crps" "crps" "crps" "crps" ...
-#>  $ series_2  :'data.frame':  25 obs. of  5 variables:
-#>   ..$ score         : num [1:25] 0.379 0.306 0.941 0.5 0.573 ...
-#>   ..$ in_interval   : num [1:25] 1 1 1 1 1 1 1 1 1 NA ...
-#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
-#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
-#>   ..$ score_type    : chr [1:25] "crps" "crps" "crps" "crps" ...
-#>  $ series_3  :'data.frame':  25 obs. of  5 variables:
-#>   ..$ score         : num [1:25] 0.32 0.556 0.379 0.362 0.219 ...
-#>   ..$ in_interval   : num [1:25] 1 1 1 1 1 1 1 1 1 1 ...
-#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
-#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
-#>   ..$ score_type    : chr [1:25] "crps" "crps" "crps" "crps" ...
-#>  $ all_series:'data.frame':  25 obs. of  3 variables:
-#>   ..$ score       : num [1:25] 0.892 0.999 2.675 NA 0.827 ...
-#>   ..$ eval_horizon: int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
-#>   ..$ score_type  : chr [1:25] "sum_crps" "sum_crps" "sum_crps" "sum_crps" ...
-crps_mod1$series_1
-#>         score in_interval interval_width eval_horizon score_type
-#> 1  0.19375525           1            0.9            1       crps
-#> 2  0.13663925           1            0.9            2       crps
-#> 3  1.35502175           1            0.9            3       crps
-#> 4          NA          NA            0.9            4       crps
-#> 5  0.03482775           1            0.9            5       crps
-#> 6  1.55416700           1            0.9            6       crps
-#> 7  1.51028900           1            0.9            7       crps
-#> 8  0.62121225           1            0.9            8       crps
-#> 9  0.62630125           1            0.9            9       crps
-#> 10 0.59853100           1            0.9           10       crps
-#> 11 1.30998625           1            0.9           11       crps
-#> 12 2.04829775           1            0.9           12       crps
-#> 13 0.61251800           1            0.9           13       crps
-#> 14 0.14052300           1            0.9           14       crps
-#> 15 0.65110800           1            0.9           15       crps
-#> 16 0.07973125           1            0.9           16       crps
-#> 17 0.07675600           1            0.9           17       crps
-#> 18 0.09382375           1            0.9           18       crps
-#> 19 0.12356725           1            0.9           19       crps
-#> 20         NA          NA            0.9           20       crps
-#> 21 0.20173600           1            0.9           21       crps
-#> 22 0.84066825           1            0.9           22       crps
-#> 23         NA          NA            0.9           23       crps
-#> 24 1.06489225           1            0.9           24       crps
-#> 25 0.75528825           1            0.9           25       crps
+
crps_mod1 <- score(fc_mod1, score = 'crps')
+str(crps_mod1)
+#> List of 4
+#>  $ series_1  :'data.frame':  25 obs. of  5 variables:
+#>   ..$ score         : num [1:25] 0.186 0.129 1.372 NA 0.037 ...
+#>   ..$ in_interval   : num [1:25] 1 1 1 NA 1 1 1 1 1 1 ...
+#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
+#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
+#>   ..$ score_type    : chr [1:25] "crps" "crps" "crps" "crps" ...
+#>  $ series_2  :'data.frame':  25 obs. of  5 variables:
+#>   ..$ score         : num [1:25] 0.354 0.334 0.947 0.492 0.542 ...
+#>   ..$ in_interval   : num [1:25] 1 1 1 1 1 1 1 1 1 NA ...
+#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
+#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
+#>   ..$ score_type    : chr [1:25] "crps" "crps" "crps" "crps" ...
+#>  $ series_3  :'data.frame':  25 obs. of  5 variables:
+#>   ..$ score         : num [1:25] 0.31 0.616 0.4 0.349 0.215 ...
+#>   ..$ in_interval   : num [1:25] 1 1 1 1 1 1 1 1 1 1 ...
+#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
+#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
+#>   ..$ score_type    : chr [1:25] "crps" "crps" "crps" "crps" ...
+#>  $ all_series:'data.frame':  25 obs. of  3 variables:
+#>   ..$ score       : num [1:25] 0.85 1.079 2.719 NA 0.794 ...
+#>   ..$ eval_horizon: int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
+#>   ..$ score_type  : chr [1:25] "sum_crps" "sum_crps" "sum_crps" "sum_crps" ...
+crps_mod1$series_1
+#>         score in_interval interval_width eval_horizon score_type
+#> 1  0.18582425           1            0.9            1       crps
+#> 2  0.12933350           1            0.9            2       crps
+#> 3  1.37181050           1            0.9            3       crps
+#> 4          NA          NA            0.9            4       crps
+#> 5  0.03698600           1            0.9            5       crps
+#> 6  1.53997900           1            0.9            6       crps
+#> 7  1.50467675           1            0.9            7       crps
+#> 8  0.63460725           1            0.9            8       crps
+#> 9  0.61682725           1            0.9            9       crps
+#> 10 0.62428875           1            0.9           10       crps
+#> 11 1.33824700           1            0.9           11       crps
+#> 12 2.06378300           1            0.9           12       crps
+#> 13 0.59247200           1            0.9           13       crps
+#> 14 0.13560025           1            0.9           14       crps
+#> 15 0.66512975           1            0.9           15       crps
+#> 16 0.08238525           1            0.9           16       crps
+#> 17 0.08152900           1            0.9           17       crps
+#> 18 0.09446425           1            0.9           18       crps
+#> 19 0.12084700           1            0.9           19       crps
+#> 20         NA          NA            0.9           20       crps
+#> 21 0.21286925           1            0.9           21       crps
+#> 22 0.85799700           1            0.9           22       crps
+#> 23         NA          NA            0.9           23       crps
+#> 24 1.14954750           1            0.9           24       crps
+#> 25 0.85131425           1            0.9           25       crps

The returned list contains a data.frame for each series in the data that shows the CRPS score for each evaluation in the testing data, along with some other useful information about the fit of the @@ -803,34 +774,34 @@

Scoring forecast distributions

in_interval column take a 1 approximately 90% of the time. This value can be changed if you wish to compute different coverages, say using a 60% interval:

-
crps_mod1 <- score(fc_mod1, score = 'crps', interval_width = 0.6)
-crps_mod1$series_1
-#>         score in_interval interval_width eval_horizon score_type
-#> 1  0.19375525           1            0.6            1       crps
-#> 2  0.13663925           1            0.6            2       crps
-#> 3  1.35502175           0            0.6            3       crps
-#> 4          NA          NA            0.6            4       crps
-#> 5  0.03482775           1            0.6            5       crps
-#> 6  1.55416700           0            0.6            6       crps
-#> 7  1.51028900           0            0.6            7       crps
-#> 8  0.62121225           1            0.6            8       crps
-#> 9  0.62630125           1            0.6            9       crps
-#> 10 0.59853100           1            0.6           10       crps
-#> 11 1.30998625           0            0.6           11       crps
-#> 12 2.04829775           0            0.6           12       crps
-#> 13 0.61251800           1            0.6           13       crps
-#> 14 0.14052300           1            0.6           14       crps
-#> 15 0.65110800           1            0.6           15       crps
-#> 16 0.07973125           1            0.6           16       crps
-#> 17 0.07675600           1            0.6           17       crps
-#> 18 0.09382375           1            0.6           18       crps
-#> 19 0.12356725           1            0.6           19       crps
-#> 20         NA          NA            0.6           20       crps
-#> 21 0.20173600           1            0.6           21       crps
-#> 22 0.84066825           1            0.6           22       crps
-#> 23         NA          NA            0.6           23       crps
-#> 24 1.06489225           1            0.6           24       crps
-#> 25 0.75528825           1            0.6           25       crps
+
crps_mod1 <- score(fc_mod1, score = 'crps', interval_width = 0.6)
+crps_mod1$series_1
+#>         score in_interval interval_width eval_horizon score_type
+#> 1  0.18582425           1            0.6            1       crps
+#> 2  0.12933350           1            0.6            2       crps
+#> 3  1.37181050           0            0.6            3       crps
+#> 4          NA          NA            0.6            4       crps
+#> 5  0.03698600           1            0.6            5       crps
+#> 6  1.53997900           0            0.6            6       crps
+#> 7  1.50467675           0            0.6            7       crps
+#> 8  0.63460725           1            0.6            8       crps
+#> 9  0.61682725           1            0.6            9       crps
+#> 10 0.62428875           1            0.6           10       crps
+#> 11 1.33824700           0            0.6           11       crps
+#> 12 2.06378300           0            0.6           12       crps
+#> 13 0.59247200           1            0.6           13       crps
+#> 14 0.13560025           1            0.6           14       crps
+#> 15 0.66512975           1            0.6           15       crps
+#> 16 0.08238525           1            0.6           16       crps
+#> 17 0.08152900           1            0.6           17       crps
+#> 18 0.09446425           1            0.6           18       crps
+#> 19 0.12084700           1            0.6           19       crps
+#> 20         NA          NA            0.6           20       crps
+#> 21 0.21286925           1            0.6           21       crps
+#> 22 0.85799700           1            0.6           22       crps
+#> 23         NA          NA            0.6           23       crps
+#> 24 1.14954750           1            0.6           24       crps
+#> 25 0.85131425           1            0.6           25       crps

We can also compare forecasts against out of sample observations using the Expected Log Predictive Density (ELPD; also known as the log score). The ELPD is a strictly proper scoring rule that can be @@ -838,34 +809,34 @@

Scoring forecast distributions

predictions on the link scale rather than on the outcome scale. This is where it is advantageous to change the type of prediction we can get using the forecast() function:

-
link_mod1 <- forecast(mod1, newdata = simdat$data_test, type = 'link')
-score(link_mod1, score = 'elpd')$series_1
-#>         score eval_horizon score_type
-#> 1  -0.5304414            1       elpd
-#> 2  -0.4298955            2       elpd
-#> 3  -2.9617583            3       elpd
-#> 4          NA            4       elpd
-#> 5  -0.2007644            5       elpd
-#> 6  -3.3781408            6       elpd
-#> 7  -3.2729088            7       elpd
-#> 8  -2.0363750            8       elpd
-#> 9  -2.0670612            9       elpd
-#> 10 -2.0844818           10       elpd
-#> 11 -3.0576463           11       elpd
-#> 12 -3.6291058           12       elpd
-#> 13 -2.1692669           13       elpd
-#> 14 -0.2960899           14       elpd
-#> 15 -2.3738851           15       elpd
-#> 16 -0.2160804           16       elpd
-#> 17 -0.2036782           17       elpd
-#> 18 -0.2115539           18       elpd
-#> 19 -0.2235072           19       elpd
-#> 20         NA           20       elpd
-#> 21 -0.2413680           21       elpd
-#> 22 -2.6791984           22       elpd
-#> 23         NA           23       elpd
-#> 24 -2.6851981           24       elpd
-#> 25 -0.2836901           25       elpd
+
link_mod1 <- forecast(mod1, newdata = simdat$data_test, type = 'link')
+score(link_mod1, score = 'elpd')$series_1
+#>         score eval_horizon score_type
+#> 1  -0.5343784            1       elpd
+#> 2  -0.4326190            2       elpd
+#> 3  -2.9699450            3       elpd
+#> 4          NA            4       elpd
+#> 5  -0.1998425            5       elpd
+#> 6  -3.3976729            6       elpd
+#> 7  -3.2989297            7       elpd
+#> 8  -2.0490633            8       elpd
+#> 9  -2.0690163            9       elpd
+#> 10 -2.0822051           10       elpd
+#> 11 -3.1101639           11       elpd
+#> 12 -3.7240924           12       elpd
+#> 13 -2.1578701           13       elpd
+#> 14 -0.2899481           14       elpd
+#> 15 -2.3811862           15       elpd
+#> 16 -0.2085375           16       elpd
+#> 17 -0.1960501           17       elpd
+#> 18 -0.2036978           18       elpd
+#> 19 -0.2154374           19       elpd
+#> 20         NA           20       elpd
+#> 21 -0.2341597           21       elpd
+#> 22 -2.6552948           22       elpd
+#> 23         NA           23       elpd
+#> 24 -2.6652717           24       elpd
+#> 25 -0.2759126           25       elpd

Finally, when we have multiple time series it may also make sense to use a multivariate proper scoring rule. mvgam offers two such options: the Energy score and the Variogram score. The first @@ -873,108 +844,108 @@

Scoring forecast distributions

the truth, while the second penalizes forecasts that do not capture the observed true correlation structure. Which score to use depends on your goals, but both are very easy to compute:

-
energy_mod2 <- score(fc_mod2, score = 'energy')
-str(energy_mod2)
-#> List of 4
-#>  $ series_1  :'data.frame':  25 obs. of  3 variables:
-#>   ..$ in_interval   : num [1:25] 1 1 1 NA 1 1 1 1 1 1 ...
-#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
-#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
-#>  $ series_2  :'data.frame':  25 obs. of  3 variables:
-#>   ..$ in_interval   : num [1:25] 1 1 1 1 1 1 1 1 1 NA ...
-#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
-#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
-#>  $ series_3  :'data.frame':  25 obs. of  3 variables:
-#>   ..$ in_interval   : num [1:25] 1 1 1 1 1 1 1 1 1 1 ...
-#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
-#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
-#>  $ all_series:'data.frame':  25 obs. of  3 variables:
-#>   ..$ score       : num [1:25] 0.773 1.147 1.226 NA 0.458 ...
-#>   ..$ eval_horizon: int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
-#>   ..$ score_type  : chr [1:25] "energy" "energy" "energy" "energy" ...
+
energy_mod2 <- score(fc_mod2, score = 'energy')
+str(energy_mod2)
+#> List of 4
+#>  $ series_1  :'data.frame':  25 obs. of  3 variables:
+#>   ..$ in_interval   : num [1:25] 1 1 1 NA 1 1 1 1 1 1 ...
+#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
+#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
+#>  $ series_2  :'data.frame':  25 obs. of  3 variables:
+#>   ..$ in_interval   : num [1:25] 1 1 1 1 1 1 1 1 1 NA ...
+#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
+#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
+#>  $ series_3  :'data.frame':  25 obs. of  3 variables:
+#>   ..$ in_interval   : num [1:25] 1 1 1 1 1 1 1 1 1 1 ...
+#>   ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ...
+#>   ..$ eval_horizon  : int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
+#>  $ all_series:'data.frame':  25 obs. of  3 variables:
+#>   ..$ score       : num [1:25] 0.771 1.133 1.26 NA 0.443 ...
+#>   ..$ eval_horizon: int [1:25] 1 2 3 4 5 6 7 8 9 10 ...
+#>   ..$ score_type  : chr [1:25] "energy" "energy" "energy" "energy" ...

The returned object still provides information on interval coverage for each individual series, but there is only a single score per horizon now (which is provided in the all_series slot):

-
energy_mod2$all_series
-#>        score eval_horizon score_type
-#> 1  0.7728517            1     energy
-#> 2  1.1469836            2     energy
-#> 3  1.2258781            3     energy
-#> 4         NA            4     energy
-#> 5  0.4577536            5     energy
-#> 6  1.8094487            6     energy
-#> 7  1.4887317            7     energy
-#> 8  0.7651593            8     energy
-#> 9  1.1180634            9     energy
-#> 10        NA           10     energy
-#> 11 1.5008324           11     energy
-#> 12 3.2142460           12     energy
-#> 13 1.6129732           13     energy
-#> 14 1.2704438           14     energy
-#> 15 1.1335958           15     energy
-#> 16 1.8717420           16     energy
-#> 17        NA           17     energy
-#> 18 0.7953392           18     energy
-#> 19 0.9919119           19     energy
-#> 20        NA           20     energy
-#> 21 1.2461964           21     energy
-#> 22 1.5170615           22     energy
-#> 23        NA           23     energy
-#> 24 2.3824552           24     energy
-#> 25 1.5314557           25     energy
+
energy_mod2$all_series
+#>        score eval_horizon score_type
+#> 1  0.7705198            1     energy
+#> 2  1.1330328            2     energy
+#> 3  1.2600785            3     energy
+#> 4         NA            4     energy
+#> 5  0.4427578            5     energy
+#> 6  1.8848308            6     energy
+#> 7  1.4186997            7     energy
+#> 8  0.7280518            8     energy
+#> 9  1.0467755            9     energy
+#> 10        NA           10     energy
+#> 11 1.4172423           11     energy
+#> 12 3.2326925           12     energy
+#> 13 1.5987732           13     energy
+#> 14 1.1798872           14     energy
+#> 15 1.0311968           15     energy
+#> 16 1.8261356           16     energy
+#> 17        NA           17     energy
+#> 18 0.7170961           18     energy
+#> 19 0.8927311           19     energy
+#> 20        NA           20     energy
+#> 21 1.0544501           21     energy
+#> 22 1.3280321           22     energy
+#> 23        NA           23     energy
+#> 24 2.1843621           24     energy
+#> 25 1.2352041           25     energy

You can use your score(s) of choice to compare different models. For example, we can compute and plot the difference in CRPS scores for each series in data. Here, a negative value means the Gaussian Process model (mod2) is better, while a positive value means the spline model (mod1) is better.

-
crps_mod1 <- score(fc_mod1, score = 'crps')
-crps_mod2 <- score(fc_mod2, score = 'crps')
-
-diff_scores <- crps_mod2$series_1$score -
-  crps_mod1$series_1$score
-plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
-     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
-              max(abs(diff_scores), na.rm = TRUE)),
-     bty = 'l',
-     xlab = 'Forecast horizon',
-     ylab = expression(CRPS[GP]~-~CRPS[spline]))
-abline(h = 0, lty = 'dashed', lwd = 2)
-gp_better <- length(which(diff_scores < 0))
-title(main = paste0('GP better in ', gp_better, ' of 25 evaluations',
-                    '\nMean difference = ', 
-                    round(mean(diff_scores, na.rm = TRUE), 2)))
-

-

-
-diff_scores <- crps_mod2$series_2$score -
-  crps_mod1$series_2$score
-plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
-     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
-              max(abs(diff_scores), na.rm = TRUE)),
-     bty = 'l',
-     xlab = 'Forecast horizon',
-     ylab = expression(CRPS[GP]~-~CRPS[spline]))
-abline(h = 0, lty = 'dashed', lwd = 2)
-gp_better <- length(which(diff_scores < 0))
-title(main = paste0('GP better in ', gp_better, ' of 25 evaluations',
-                    '\nMean difference = ', 
-                    round(mean(diff_scores, na.rm = TRUE), 2)))
-

-

-diff_scores <- crps_mod2$series_3$score -
-  crps_mod1$series_3$score
-plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
-     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
-              max(abs(diff_scores), na.rm = TRUE)),
-     bty = 'l',
-     xlab = 'Forecast horizon',
-     ylab = expression(CRPS[GP]~-~CRPS[spline]))
-abline(h = 0, lty = 'dashed', lwd = 2)
-gp_better <- length(which(diff_scores < 0))
-title(main = paste0('GP better in ', gp_better, ' of 25 evaluations',
-                    '\nMean difference = ', 
-                    round(mean(diff_scores, na.rm = TRUE), 2)))
-

+
crps_mod1 <- score(fc_mod1, score = 'crps')
+crps_mod2 <- score(fc_mod2, score = 'crps')
+
+diff_scores <- crps_mod2$series_1$score -
+  crps_mod1$series_1$score
+plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
+     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
+              max(abs(diff_scores), na.rm = TRUE)),
+     bty = 'l',
+     xlab = 'Forecast horizon',
+     ylab = expression(CRPS[GP]~-~CRPS[spline]))
+abline(h = 0, lty = 'dashed', lwd = 2)
+gp_better <- length(which(diff_scores < 0))
+title(main = paste0('GP better in ', gp_better, ' of 25 evaluations',
+                    '\nMean difference = ', 
+                    round(mean(diff_scores, na.rm = TRUE), 2)))
+

+

+
+diff_scores <- crps_mod2$series_2$score -
+  crps_mod1$series_2$score
+plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
+     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
+              max(abs(diff_scores), na.rm = TRUE)),
+     bty = 'l',
+     xlab = 'Forecast horizon',
+     ylab = expression(CRPS[GP]~-~CRPS[spline]))
+abline(h = 0, lty = 'dashed', lwd = 2)
+gp_better <- length(which(diff_scores < 0))
+title(main = paste0('GP better in ', gp_better, ' of 25 evaluations',
+                    '\nMean difference = ', 
+                    round(mean(diff_scores, na.rm = TRUE), 2)))
+

+

+diff_scores <- crps_mod2$series_3$score -
+  crps_mod1$series_3$score
+plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
+     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
+              max(abs(diff_scores), na.rm = TRUE)),
+     bty = 'l',
+     xlab = 'Forecast horizon',
+     ylab = expression(CRPS[GP]~-~CRPS[spline]))
+abline(h = 0, lty = 'dashed', lwd = 2)
+gp_better <- length(which(diff_scores < 0))
+title(main = paste0('GP better in ', gp_better, ' of 25 evaluations',
+                    '\nMean difference = ', 
+                    round(mean(diff_scores, na.rm = TRUE), 2)))
+

The GP model consistently gives better forecasts, and the difference between scores grows quickly as the forecast horizon increases. This is not unexpected given the way that splines linearly extrapolate outside diff --git a/doc/shared_states.R b/doc/shared_states.R index 4eabc053..3619bf06 100644 --- a/doc/shared_states.R +++ b/doc/shared_states.R @@ -7,10 +7,11 @@ knitr::opts_chunk$set( eval = NOT_CRAN ) + ## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, - dpi = 150, + dpi = 100, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -19,9 +20,10 @@ library(mvgam) library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) + ## ----------------------------------------------------------------------------- set.seed(122) -simdat <- sim_mvgam(trend_model = 'AR1', +simdat <- sim_mvgam(trend_model = AR(), prop_trend = 0.6, mu = c(0, 1, 2), family = poisson()) @@ -29,9 +31,11 @@ trend_map <- data.frame(series = unique(simdat$data_train$series), trend = c(1, 1, 2)) trend_map + ## ----------------------------------------------------------------------------- all.equal(levels(trend_map$series), levels(simdat$data_train$series)) + ## ----------------------------------------------------------------------------- fake_mod <- mvgam(y ~ # observation model formula, which has a @@ -43,8 +47,10 @@ fake_mod <- mvgam(y ~ trend_formula = ~ s(season, bs = 'cc', k = 6), # AR1 dynamics (each latent process model has DIFFERENT) - # dynamics - trend_model = 'AR1', + # dynamics; processes are estimated using the noncentred + # parameterisation for improved efficiency + trend_model = AR(), + noncentred = TRUE, # supplied trend_map trend_map = trend_map, @@ -54,48 +60,51 @@ fake_mod <- mvgam(y ~ data = simdat$data_train, run_model = FALSE) + ## ----------------------------------------------------------------------------- code(fake_mod) + ## ----------------------------------------------------------------------------- fake_mod$model_data$Z + ## ----full_mod, include = FALSE, results='hide'-------------------------------- full_mod <- mvgam(y ~ series - 1, trend_formula = ~ s(season, bs = 'cc', k = 6), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, trend_map = trend_map, family = poisson(), - data = simdat$data_train) + data = simdat$data_train, + silent = 2) + ## ----eval=FALSE--------------------------------------------------------------- -# full_mod <- mvgam(y ~ series - 1, -# trend_formula = ~ s(season, bs = 'cc', k = 6), -# trend_model = 'AR1', -# trend_map = trend_map, -# family = poisson(), -# data = simdat$data_train) +## full_mod <- mvgam(y ~ series - 1, +## trend_formula = ~ s(season, bs = 'cc', k = 6), +## trend_model = AR(), +## noncentred = TRUE, +## trend_map = trend_map, +## family = poisson(), +## data = simdat$data_train, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(full_mod) -## ----------------------------------------------------------------------------- -plot(conditional_effects(full_mod, type = 'link'), ask = FALSE) ## ----------------------------------------------------------------------------- plot(full_mod, type = 'trend', series = 1) plot(full_mod, type = 'trend', series = 2) plot(full_mod, type = 'trend', series = 3) -## ----------------------------------------------------------------------------- -plot(full_mod, type = 'forecast', series = 1) -plot(full_mod, type = 'forecast', series = 2) -plot(full_mod, type = 'forecast', series = 3) ## ----------------------------------------------------------------------------- -set.seed(543210) +set.seed(0) # simulate a nonlinear relationship using the mgcv function gamSim -signal_dat <- gamSim(n = 100, eg = 1, scale = 1) +signal_dat <- mgcv::gamSim(n = 100, eg = 1, scale = 1) # productivity is one of the variables in the simulated data productivity <- signal_dat$x2 @@ -106,22 +115,17 @@ productivity <- signal_dat$x2 true_signal <- as.vector(scale(signal_dat$y) + arima.sim(100, model = list(ar = 0.8, sd = 0.1))) + ## ----------------------------------------------------------------------------- plot(true_signal, type = 'l', bty = 'l', lwd = 2, ylab = 'True signal', xlab = 'Time') -## ----------------------------------------------------------------------------- -plot(true_signal ~ productivity, - pch = 16, bty = 'l', - ylab = 'True signal', - xlab = 'Productivity') ## ----------------------------------------------------------------------------- -set.seed(543210) sim_series = function(n_series = 3, true_signal){ - temp_effects <- gamSim(n = 100, eg = 7, scale = 0.1) + temp_effects <- mgcv::gamSim(n = 100, eg = 7, scale = 0.1) temperature <- temp_effects$y alphas <- rnorm(n_series, sd = 2) @@ -141,10 +145,12 @@ sim_series = function(n_series = 3, true_signal){ model_dat <- sim_series(true_signal = true_signal) %>% dplyr::mutate(series = factor(series)) + ## ----------------------------------------------------------------------------- plot_mvgam_series(data = model_dat, y = 'observed', series = 'all') + ## ----------------------------------------------------------------------------- plot(observed ~ temperature, data = model_dat %>% dplyr::filter(series == 'sensor_1'), @@ -162,6 +168,7 @@ plot_mvgam_series(data = model_dat, y = 'observed', ylab = 'Sensor 3', xlab = 'Temperature') + ## ----sensor_mod, include = FALSE, results='hide'------------------------------ mod <- mvgam(formula = # formula for observations, allowing for different @@ -178,7 +185,8 @@ mod <- mvgam(formula = trend_model = # in addition to productivity effects, the signal is # assumed to exhibit temporal autocorrelation - 'AR1', + AR(), + noncentred = TRUE, trend_map = # trend_map forces all sensors to track the same @@ -195,61 +203,61 @@ mod <- mvgam(formula = family = gaussian(), burnin = 600, adapt_delta = 0.95, - data = model_dat) + data = model_dat, + silent = 2) + ## ----eval=FALSE--------------------------------------------------------------- -# mod <- mvgam(formula = -# # formula for observations, allowing for different -# # intercepts and hierarchical smooth effects of temperature -# observed ~ series + -# s(temperature, k = 10) + -# s(series, temperature, bs = 'sz', k = 8), -# -# trend_formula = -# # formula for the latent signal, which can depend -# # nonlinearly on productivity -# ~ s(productivity, k = 8), -# -# trend_model = -# # in addition to productivity effects, the signal is -# # assumed to exhibit temporal autocorrelation -# 'AR1', -# -# trend_map = -# # trend_map forces all sensors to track the same -# # latent signal -# data.frame(series = unique(model_dat$series), -# trend = c(1, 1, 1)), -# -# # informative priors on process error -# # and observation error will help with convergence -# priors = c(prior(normal(2, 0.5), class = sigma), -# prior(normal(1, 0.5), class = sigma_obs)), -# -# # Gaussian observations -# family = gaussian(), -# data = model_dat) +## mod <- mvgam(formula = +## # formula for observations, allowing for different +## # intercepts and hierarchical smooth effects of temperature +## observed ~ series + +## s(temperature, k = 10) + +## s(series, temperature, bs = 'sz', k = 8), +## +## trend_formula = +## # formula for the latent signal, which can depend +## # nonlinearly on productivity +## ~ s(productivity, k = 8), +## +## trend_model = +## # in addition to productivity effects, the signal is +## # assumed to exhibit temporal autocorrelation +## AR(), +## noncentred = TRUE, +## +## trend_map = +## # trend_map forces all sensors to track the same +## # latent signal +## data.frame(series = unique(model_dat$series), +## trend = c(1, 1, 1)), +## +## # informative priors on process error +## # and observation error will help with convergence +## priors = c(prior(normal(2, 0.5), class = sigma), +## prior(normal(1, 0.5), class = sigma_obs)), +## +## # Gaussian observations +## family = gaussian(), +## data = model_dat, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(mod, include_betas = FALSE) -## ----------------------------------------------------------------------------- -plot(mod, type = 'smooths', trend_effects = TRUE) ## ----------------------------------------------------------------------------- -plot(mod, type = 'smooths') +conditional_effects(mod, type = 'link') -## ----------------------------------------------------------------------------- -plot(conditional_effects(mod, type = 'link'), ask = FALSE) ## ----------------------------------------------------------------------------- +require(marginaleffects) plot_predictions(mod, condition = c('temperature', 'series', 'series'), points = 0.5) + theme(legend.position = 'none') -## ----------------------------------------------------------------------------- -pairs(mod, variable = c('sigma[1]', 'sigma_obs[1]')) ## ----------------------------------------------------------------------------- plot(mod, type = 'trend') diff --git a/doc/shared_states.Rmd b/doc/shared_states.Rmd index e0f36689..bc79aa71 100644 --- a/doc/shared_states.Rmd +++ b/doc/shared_states.Rmd @@ -23,7 +23,7 @@ knitr::opts_chunk$set( ```{r setup, include=FALSE} knitr::opts_chunk$set( echo = TRUE, - dpi = 150, + dpi = 100, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -39,7 +39,7 @@ This vignette gives an example of how `mvgam` can be used to estimate models whe The `trend_map` argument in the `mvgam()` function is an optional `data.frame` that can be used to specify which series should depend on which latent process models (called "trends" in `mvgam`). This can be particularly useful if we wish to force multiple observed time series to depend on the same latent trend process, but with different observation processes. If this argument is supplied, a latent factor model is set up by setting `use_lv = TRUE` and using the supplied `trend_map` to set up the shared trends. Users familiar with the `MARSS` family of packages will recognize this as a way of specifying the $Z$ matrix. This `data.frame` needs to have column names `series` and `trend`, with integer values in the `trend` column to state which trend each series should depend on. The `series` column should have a single unique entry for each time series in the data, with names that perfectly match the factor levels of the `series` variable in `data`). For example, if we were to simulate a collection of three integer-valued time series (using `sim_mvgam`), the following `trend_map` would force the first two series to share the same latent trend process: ```{r} set.seed(122) -simdat <- sim_mvgam(trend_model = 'AR1', +simdat <- sim_mvgam(trend_model = AR(), prop_trend = 0.6, mu = c(0, 1, 2), family = poisson()) @@ -66,8 +66,10 @@ fake_mod <- mvgam(y ~ trend_formula = ~ s(season, bs = 'cc', k = 6), # AR1 dynamics (each latent process model has DIFFERENT) - # dynamics - trend_model = 'AR1', + # dynamics; processes are estimated using the noncentred + # parameterisation for improved efficiency + trend_model = AR(), + noncentred = TRUE, # supplied trend_map trend_map = trend_map, @@ -93,19 +95,23 @@ Though this model doesn't perfectly match the data-generating process (which all ```{r full_mod, include = FALSE, results='hide'} full_mod <- mvgam(y ~ series - 1, trend_formula = ~ s(season, bs = 'cc', k = 6), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, trend_map = trend_map, family = poisson(), - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` ```{r eval=FALSE} full_mod <- mvgam(y ~ series - 1, trend_formula = ~ s(season, bs = 'cc', k = 6), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, trend_map = trend_map, family = poisson(), - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The summary of this model is informative as it shows that only two latent process models have been estimated, even though we have three observed time series. The model converges well @@ -113,31 +119,21 @@ The summary of this model is informative as it shows that only two latent proces summary(full_mod) ``` -Quick plots of all main effects can be made using `conditional_effects()`: -```{r} -plot(conditional_effects(full_mod, type = 'link'), ask = FALSE) -``` - -Even more informative are the plots of the latent processes. Both series 1 and 2 share the exact same estimates, while the estimates for series 3 are different: +Both series 1 and 2 share the exact same latent process estimates, while the estimates for series 3 are different: ```{r} plot(full_mod, type = 'trend', series = 1) plot(full_mod, type = 'trend', series = 2) plot(full_mod, type = 'trend', series = 3) ``` -However, the forecasts for series' 1 and 2 differ because they have different intercepts in the observation model -```{r} -plot(full_mod, type = 'forecast', series = 1) -plot(full_mod, type = 'forecast', series = 2) -plot(full_mod, type = 'forecast', series = 3) -``` +However, forecasts for series' 1 and 2 will differ because they have different intercepts in the observation model ## Example: signal detection Now we will explore a more complicated example. Here we simulate a true hidden signal that we are trying to track. This signal depends nonlinearly on some covariate (called `productivity`, which represents a measure of how productive the landscape is). The signal also demonstrates a fairly large amount of temporal autocorrelation: ```{r} -set.seed(543210) +set.seed(0) # simulate a nonlinear relationship using the mgcv function gamSim -signal_dat <- gamSim(n = 100, eg = 1, scale = 1) +signal_dat <- mgcv::gamSim(n = 100, eg = 1, scale = 1) # productivity is one of the variables in the simulated data productivity <- signal_dat$x2 @@ -157,19 +153,10 @@ plot(true_signal, type = 'l', xlab = 'Time') ``` -And plot the relationship between the signal and the `productivity` covariate: -```{r} -plot(true_signal ~ productivity, - pch = 16, bty = 'l', - ylab = 'True signal', - xlab = 'Productivity') -``` - Next we simulate three sensors that are trying to track the same hidden signal. All of these sensors have different observation errors that can depend nonlinearly on a second external covariate, called `temperature` in this example. Again this makes use of `gamSim` ```{r} -set.seed(543210) sim_series = function(n_series = 3, true_signal){ - temp_effects <- gamSim(n = 100, eg = 7, scale = 0.1) + temp_effects <- mgcv::gamSim(n = 100, eg = 7, scale = 0.1) temperature <- temp_effects$y alphas <- rnorm(n_series, sd = 2) @@ -233,7 +220,8 @@ mod <- mvgam(formula = trend_model = # in addition to productivity effects, the signal is # assumed to exhibit temporal autocorrelation - 'AR1', + AR(), + noncentred = TRUE, trend_map = # trend_map forces all sensors to track the same @@ -250,7 +238,8 @@ mod <- mvgam(formula = family = gaussian(), burnin = 600, adapt_delta = 0.95, - data = model_dat) + data = model_dat, + silent = 2) ``` ```{r eval=FALSE} @@ -269,7 +258,8 @@ mod <- mvgam(formula = trend_model = # in addition to productivity effects, the signal is # assumed to exhibit temporal autocorrelation - 'AR1', + AR(), + noncentred = TRUE, trend_map = # trend_map forces all sensors to track the same @@ -284,7 +274,8 @@ mod <- mvgam(formula = # Gaussian observations family = gaussian(), - data = model_dat) + data = model_dat, + silent = 2) ``` View a reduced version of the model summary because there will be many spline coefficients in this model @@ -293,35 +284,21 @@ summary(mod, include_betas = FALSE) ``` ### Inspecting effects on both process and observation models -Don't pay much attention to the approximate *p*-values of the smooth terms. The calculation for these values is incredibly sensitive to the estimates for the smoothing parameters so I don't tend to find them to be very meaningful. What are meaningful, however, are prediction-based plots of the smooth functions. For example, here is the estimated response of the underlying signal to `productivity`: -```{r} -plot(mod, type = 'smooths', trend_effects = TRUE) -``` - -And here are the estimated relationships between the sensor observations and the `temperature` covariate: -```{r} -plot(mod, type = 'smooths') -``` - -All main effects can be quickly plotted with `conditional_effects`: +Don't pay much attention to the approximate *p*-values of the smooth terms. The calculation for these values is incredibly sensitive to the estimates for the smoothing parameters so I don't tend to find them to be very meaningful. What are meaningful, however, are prediction-based plots of the smooth functions. All main effects can be quickly plotted with `conditional_effects`: ```{r} -plot(conditional_effects(mod, type = 'link'), ask = FALSE) +conditional_effects(mod, type = 'link') ``` `conditional_effects` is simply a wrapper to the more flexible `plot_predictions` function from the `marginaleffects` package. We can get more useful plots of these effects using this function for further customisation: ```{r} +require(marginaleffects) plot_predictions(mod, condition = c('temperature', 'series', 'series'), points = 0.5) + theme(legend.position = 'none') ``` -We have successfully estimated effects, some of them nonlinear, that impact the hidden process AND the observations. All in a single joint model. But there can always be challenges with these models, particularly when estimating both process and observation error at the same time. For example, a `pairs` plot for the observation error for sensor 1 and the hidden process error shows some strong correlations that we might want to deal with by using a more structured prior: -```{r} -pairs(mod, variable = c('sigma[1]', 'sigma_obs[1]')) -``` - -But we will leave the model as-is for this example +We have successfully estimated effects, some of them nonlinear, that impact the hidden process AND the observations. All in a single joint model. But there can always be challenges with these models, particularly when estimating both process and observation error at the same time. ### Recovering the hidden signal A final but very key question is whether we can successfully recover the true hidden signal. The `trend` slot in the returned model parameters has the estimates for this signal, which we can easily plot using the `mvgam` S3 method for `plot`. We can also overlay the true values for the hidden signal, which shows that our model has done a good job of recovering it: @@ -336,7 +313,7 @@ points(true_signal, pch = 16, cex = 0.8) ## Further reading The following papers and resources offer a lot of useful material about other types of State-Space models and how they can be applied in practice: -Holmes, Elizabeth E., Eric J. Ward, and Wills Kellie. "[MARSS: multivariate autoregressive state-space models for analyzing time-series data.](https://d1wqtxts1xzle7.cloudfront.net/30588864/rjournal_2012-1_holmes_et_al-libre.pdf?1391843792=&response-content-disposition=inline%3B+filename%3DMARSS_Multivariate_Autoregressive_State.pdf&Expires=1695861526&Signature=TCRXULs0mUKRM4m1pmvZxwE10bUqS6vzLcuKeUBCj57YIjx23iTxS1fEgBpV0fs2wb5XAw7ZkG84XyMaoS~vjiqZ-DpheQDHwAHpIWG-TcckHQjEjPWTNajFvAemToUdCiHnDa~yrhW9HRgXjgncdalkjzjvjT3HLSW8mcjBDhQN-WJ3MKQFSXtxoBpWfcuPYbf-HC1E1oSl7957y~w0I1gcIVdu6LHjP~CEKXa0BQzS4xuarL2nz~tHD2MverbNJYMrDGrAxIi-MX6i~lfHWuwV6UKRdoOZ0pXIcMYWBTv9V5xYey76aMKTICiJ~0NqXLZdXO5qlS4~~2nFEO7b7w__&Key-Pair-Id=APKAJLOHF5GGSLRBV4ZA)" *R Journal*. 4.1 (2012): 11. +Holmes, Elizabeth E., Eric J. Ward, and Wills Kellie. "[MARSS: multivariate autoregressive state-space models for analyzing time-series data.](https://journal.r-project.org/archive/2012/RJ-2012-002/index.html)" *R Journal*. 4.1 (2012): 11. Ward, Eric J., et al. "[Inferring spatial structure from time‐series data: using multivariate state‐space models to detect metapopulation structure of California sea lions in the Gulf of California, Mexico.](https://besjournals.onlinelibrary.wiley.com/doi/full/10.1111/j.1365-2664.2009.01745.x)" *Journal of Applied Ecology* 47.1 (2010): 47-56. diff --git a/doc/shared_states.html b/doc/shared_states.html index 77372995..db2dac3b 100644 --- a/doc/shared_states.html +++ b/doc/shared_states.html @@ -12,7 +12,7 @@ - + Shared latent states in mvgam @@ -340,7 +340,7 @@

Shared latent states in mvgam

Nicholas J Clark

-

2024-04-16

+

2024-07-01

@@ -393,7 +393,7 @@

The trend_map argument

sim_mvgam), the following trend_map would force the first two series to share the same latent trend process:

set.seed(122)
-simdat <- sim_mvgam(trend_model = 'AR1',
+simdat <- sim_mvgam(trend_model = AR(),
                     prop_trend = 0.6,
                     mu = c(0, 1, 2),
                     family = poisson())
@@ -432,16 +432,18 @@ 
Checking trend_map with
                   trend_formula = ~ s(season, bs = 'cc', k = 6),
                   
                   # AR1 dynamics (each latent process model has DIFFERENT)
-                  # dynamics
-                  trend_model = 'AR1',
-                  
-                  # supplied trend_map
-                  trend_map = trend_map,
-                  
-                  # data and observation family
-                  family = poisson(),
-                  data = simdat$data_train,
-                  run_model = FALSE)
+ # dynamics; processes are estimated using the noncentred + # parameterisation for improved efficiency + trend_model = AR(), + noncentred = TRUE, + + # supplied trend_map + trend_map = trend_map, + + # data and observation family + family = poisson(), + data = simdat$data_train, + run_model = FALSE)

Inspecting the Stan code shows how this model is a dynamic factor model in which the loadings are constructed to reflect the supplied trend_map:

@@ -479,96 +481,99 @@

Checking trend_map with #> vector<lower=0>[n_lv] sigma; #> #> // latent state AR1 terms -#> vector<lower=-1.5, upper=1.5>[n_lv] ar1; +#> vector<lower=-1, upper=1>[n_lv] ar1; #> -#> // latent states -#> matrix[n, n_lv] LV; +#> // raw latent states +#> matrix[n, n_lv] LV_raw; #> #> // smoothing parameters #> vector<lower=0>[n_sp_trend] lambda_trend; #> } #> transformed parameters { -#> // latent states and loading matrix +#> // raw latent states #> vector[n * n_lv] trend_mus; #> matrix[n, n_series] trend; #> #> // basis coefficients #> vector[num_basis] b; -#> vector[num_basis_trend] b_trend; -#> -#> // observation model basis coefficients -#> b[1 : num_basis] = b_raw[1 : num_basis]; +#> +#> // latent states +#> matrix[n, n_lv] LV; +#> vector[num_basis_trend] b_trend; #> -#> // process model basis coefficients -#> b_trend[1 : num_basis_trend] = b_raw_trend[1 : num_basis_trend]; +#> // observation model basis coefficients +#> b[1 : num_basis] = b_raw[1 : num_basis]; #> -#> // latent process linear predictors -#> trend_mus = X_trend * b_trend; +#> // process model basis coefficients +#> b_trend[1 : num_basis_trend] = b_raw_trend[1 : num_basis_trend]; #> -#> // derived latent states -#> for (i in 1 : n) { -#> for (s in 1 : n_series) { -#> trend[i, s] = dot_product(Z[s, : ], LV[i, : ]); -#> } -#> } -#> } -#> model { -#> // prior for seriesseries_1... -#> b_raw[1] ~ student_t(3, 0, 2); +#> // latent process linear predictors +#> trend_mus = X_trend * b_trend; +#> LV = LV_raw .* rep_matrix(sigma', rows(LV_raw)); +#> for (j in 1 : n_lv) { +#> LV[1, j] += trend_mus[ytimes_trend[1, j]]; +#> for (i in 2 : n) { +#> LV[i, j] += trend_mus[ytimes_trend[i, j]] +#> + ar1[j] * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]); +#> } +#> } #> -#> // prior for seriesseries_2... -#> b_raw[2] ~ student_t(3, 0, 2); -#> -#> // prior for seriesseries_3... -#> b_raw[3] ~ student_t(3, 0, 2); -#> -#> // priors for AR parameters -#> ar1 ~ std_normal(); -#> -#> // priors for latent state SD parameters -#> sigma ~ student_t(3, 0, 2.5); -#> -#> // dynamic process models +#> // derived latent states +#> for (i in 1 : n) { +#> for (s in 1 : n_series) { +#> trend[i, s] = dot_product(Z[s, : ], LV[i, : ]); +#> } +#> } +#> } +#> model { +#> // prior for seriesseries_1... +#> b_raw[1] ~ student_t(3, 0, 2); +#> +#> // prior for seriesseries_2... +#> b_raw[2] ~ student_t(3, 0, 2); #> -#> // prior for s(season)_trend... -#> b_raw_trend[1 : 4] ~ multi_normal_prec(zero_trend[1 : 4], -#> S_trend1[1 : 4, 1 : 4] -#> * lambda_trend[1]); -#> lambda_trend ~ normal(5, 30); -#> for (j in 1 : n_lv) { -#> LV[1, j] ~ normal(trend_mus[ytimes_trend[1, j]], sigma[j]); -#> for (i in 2 : n) { -#> LV[i, j] ~ normal(trend_mus[ytimes_trend[i, j]] -#> + ar1[j] -#> * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]), -#> sigma[j]); -#> } -#> } -#> { -#> // likelihood functions -#> vector[n_nonmissing] flat_trends; -#> flat_trends = to_vector(trend)[obs_ind]; -#> flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends), 0.0, -#> append_row(b, 1.0)); -#> } -#> } -#> generated quantities { -#> vector[total_obs] eta; -#> matrix[n, n_series] mus; -#> vector[n_sp_trend] rho_trend; -#> vector[n_lv] penalty; -#> array[n, n_series] int ypred; -#> penalty = 1.0 / (sigma .* sigma); -#> rho_trend = log(lambda_trend); -#> -#> matrix[n_series, n_lv] lv_coefs = Z; -#> // posterior predictions -#> eta = X * b; -#> for (s in 1 : n_series) { -#> mus[1 : n, s] = eta[ytimes[1 : n, s]] + trend[1 : n, s]; -#> ypred[1 : n, s] = poisson_log_rng(mus[1 : n, s]); -#> } -#> }

+#> // prior for seriesseries_3... +#> b_raw[3] ~ student_t(3, 0, 2); +#> +#> // priors for AR parameters +#> ar1 ~ std_normal(); +#> +#> // priors for latent state SD parameters +#> sigma ~ student_t(3, 0, 2.5); +#> to_vector(LV_raw) ~ std_normal(); +#> +#> // dynamic process models +#> +#> // prior for s(season)_trend... +#> b_raw_trend[1 : 4] ~ multi_normal_prec(zero_trend[1 : 4], +#> S_trend1[1 : 4, 1 : 4] +#> * lambda_trend[1]); +#> lambda_trend ~ normal(5, 30); +#> { +#> // likelihood functions +#> vector[n_nonmissing] flat_trends; +#> flat_trends = to_vector(trend)[obs_ind]; +#> flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends), 0.0, +#> append_row(b, 1.0)); +#> } +#> } +#> generated quantities { +#> vector[total_obs] eta; +#> matrix[n, n_series] mus; +#> vector[n_sp_trend] rho_trend; +#> vector[n_lv] penalty; +#> array[n, n_series] int ypred; +#> penalty = 1.0 / (sigma .* sigma); +#> rho_trend = log(lambda_trend); +#> +#> matrix[n_series, n_lv] lv_coefs = Z; +#> // posterior predictions +#> eta = X * b; +#> for (s in 1 : n_series) { +#> mus[1 : n, s] = eta[ytimes[1 : n, s]] + trend[1 : n, s]; +#> ypred[1 : n, s] = poisson_log_rng(mus[1 : n, s]); +#> } +#> }

Notice the line that states “lv_coefs = Z;”. This uses the supplied \(Z\) matrix to construct the loading coefficients. The supplied matrix now looks exactly like what you’d use @@ -587,103 +592,96 @@

Fitting and inspecting the model

can still fit it to show what the resulting inferences look like:

full_mod <- mvgam(y ~ series - 1,
                   trend_formula = ~ s(season, bs = 'cc', k = 6),
-                  trend_model = 'AR1',
-                  trend_map = trend_map,
-                  family = poisson(),
-                  data = simdat$data_train)
+ trend_model = AR(), + noncentred = TRUE, + trend_map = trend_map, + family = poisson(), + data = simdat$data_train, + silent = 2)

The summary of this model is informative as it shows that only two latent process models have been estimated, even though we have three observed time series. The model converges well

summary(full_mod)
 #> GAM observation formula:
 #> y ~ series - 1
-#> 
-#> GAM process formula:
-#> ~s(season, bs = "cc", k = 6)
-#> 
-#> Family:
-#> poisson
-#> 
-#> Link function:
-#> log
-#> 
-#> Trend model:
-#> AR1
-#> 
-#> N process models:
-#> 2 
-#> 
-#> N series:
-#> 3 
-#> 
-#> N timepoints:
-#> 75 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> GAM observation model coefficient (beta) estimates:
-#>                 2.5%   50% 97.5% Rhat n_eff
-#> seriesseries_1 -0.14 0.087  0.31    1  1303
-#> seriesseries_2  0.91 1.100  1.20    1  1076
-#> seriesseries_3  1.90 2.100  2.30    1   456
-#> 
-#> Process model AR parameter estimates:
-#>         2.5%     50% 97.5% Rhat n_eff
-#> ar1[1] -0.72 -0.4300 -0.04 1.00   572
-#> ar1[2] -0.28 -0.0074  0.26 1.01  1838
-#> 
-#> Process error parameter estimates:
-#>          2.5%  50% 97.5% Rhat n_eff
-#> sigma[1] 0.33 0.48  0.68    1   343
-#> sigma[2] 0.59 0.73  0.90    1  1452
-#> 
-#> GAM process model coefficient (beta) estimates:
-#>                    2.5%     50% 97.5% Rhat n_eff
-#> s(season).1_trend -0.21 -0.0076  0.20    1  1917
-#> s(season).2_trend -0.27 -0.0470  0.18    1  1682
-#> s(season).3_trend -0.15  0.0670  0.29    1  1462
-#> s(season).4_trend -0.15  0.0630  0.27    1  1574
-#> 
-#> Approximate significance of GAM process smooths:
-#>            edf Ref.df    F p-value
-#> s(season) 2.49      4 0.09    0.93
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Tue Apr 16 1:09:57 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
-

Quick plots of all main effects can be made using -conditional_effects():

-
plot(conditional_effects(full_mod, type = 'link'), ask = FALSE)
-

-

Even more informative are the plots of the latent processes. Both -series 1 and 2 share the exact same estimates, while the estimates for -series 3 are different:

-
plot(full_mod, type = 'trend', series = 1)
-

-
plot(full_mod, type = 'trend', series = 2)
-

-
plot(full_mod, type = 'trend', series = 3)
-

-

However, the forecasts for series’ 1 and 2 differ because they have +#> <environment: 0x000001f52b9e3130> +#> +#> GAM process formula: +#> ~s(season, bs = "cc", k = 6) +#> <environment: 0x000001f52b9e3130> +#> +#> Family: +#> poisson +#> +#> Link function: +#> log +#> +#> Trend model: +#> AR() +#> +#> N process models: +#> 2 +#> +#> N series: +#> 3 +#> +#> N timepoints: +#> 75 +#> +#> Status: +#> Fitted using Stan +#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 +#> Total post-warmup draws = 2000 +#> +#> +#> GAM observation model coefficient (beta) estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> seriesseries_1 -0.14 0.084 0.29 1.00 1720 +#> seriesseries_2 0.91 1.100 1.20 1.00 1374 +#> seriesseries_3 1.90 2.100 2.30 1.01 447 +#> +#> Process model AR parameter estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> ar1[1] -0.72 -0.430 -0.037 1.01 560 +#> ar1[2] -0.30 -0.017 0.270 1.01 286 +#> +#> Process error parameter estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> sigma[1] 0.34 0.49 0.65 1 819 +#> sigma[2] 0.59 0.73 0.90 1 573 +#> +#> GAM process model coefficient (beta) estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> s(season).1_trend -0.20 -0.003 0.21 1.01 857 +#> s(season).2_trend -0.27 -0.046 0.17 1.00 918 +#> s(season).3_trend -0.15 0.068 0.28 1.00 850 +#> s(season).4_trend -0.14 0.064 0.27 1.00 972 +#> +#> Approximate significance of GAM process smooths: +#> edf Ref.df Chi.sq p-value +#> s(season) 2.33 4 0.38 0.93 +#> +#> Stan MCMC diagnostics: +#> n_eff / iter looks reasonable for all parameters +#> Rhat looks reasonable for all parameters +#> 0 of 2000 iterations ended with a divergence (0%) +#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%) +#> E-FMI indicated no pathological behavior +#> +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:31:17 AM 2024. +#> For each parameter, n_eff is a crude measure of effective sample size, +#> and Rhat is the potential scale reduction factor on split MCMC chains +#> (at convergence, Rhat = 1) +

Both series 1 and 2 share the exact same latent process estimates, +while the estimates for series 3 are different:

+
plot(full_mod, type = 'trend', series = 1)
+

+
plot(full_mod, type = 'trend', series = 2)
+

+
plot(full_mod, type = 'trend', series = 3)
+

+

However, forecasts for series’ 1 and 2 will differ because they have different intercepts in the observation model

-
plot(full_mod, type = 'forecast', series = 1)
-

-
plot(full_mod, type = 'forecast', series = 2)
-

-
plot(full_mod, type = 'forecast', series = 3)
-

@@ -693,83 +691,75 @@

Example: signal detection

nonlinearly on some covariate (called productivity, which represents a measure of how productive the landscape is). The signal also demonstrates a fairly large amount of temporal autocorrelation:

-
set.seed(543210)
-# simulate a nonlinear relationship using the mgcv function gamSim
-signal_dat <- gamSim(n = 100, eg = 1, scale = 1)
-#> Gu & Wahba 4 term additive model
-
-# productivity is one of the variables in the simulated data
-productivity <- signal_dat$x2
-
-# simulate the true signal, which already has a nonlinear relationship
-# with productivity; we will add in a fairly strong AR1 process to 
-# contribute to the signal
-true_signal <- as.vector(scale(signal_dat$y) +
-                         arima.sim(100, model = list(ar = 0.8, sd = 0.1)))
+
set.seed(0)
+# simulate a nonlinear relationship using the mgcv function gamSim
+signal_dat <- mgcv::gamSim(n = 100, eg = 1, scale = 1)
+#> Gu & Wahba 4 term additive model
+
+# productivity is one of the variables in the simulated data
+productivity <- signal_dat$x2
+
+# simulate the true signal, which already has a nonlinear relationship
+# with productivity; we will add in a fairly strong AR1 process to 
+# contribute to the signal
+true_signal <- as.vector(scale(signal_dat$y) +
+                         arima.sim(100, model = list(ar = 0.8, sd = 0.1)))

Plot the signal to inspect it’s evolution over time

-
plot(true_signal, type = 'l',
-     bty = 'l', lwd = 2,
-     ylab = 'True signal',
-     xlab = 'Time')
-

-

And plot the relationship between the signal and the -productivity covariate:

-
plot(true_signal ~ productivity,
-     pch = 16, bty = 'l',
-     ylab = 'True signal',
-     xlab = 'Productivity')
-

+
plot(true_signal, type = 'l',
+     bty = 'l', lwd = 2,
+     ylab = 'True signal',
+     xlab = 'Time')
+

Next we simulate three sensors that are trying to track the same hidden signal. All of these sensors have different observation errors that can depend nonlinearly on a second external covariate, called temperature in this example. Again this makes use of gamSim

-
set.seed(543210)
-sim_series = function(n_series = 3, true_signal){
-  temp_effects <- gamSim(n = 100, eg = 7, scale = 0.1)
-  temperature <- temp_effects$y
-  alphas <- rnorm(n_series, sd = 2)
-
-  do.call(rbind, lapply(seq_len(n_series), function(series){
-    data.frame(observed = rnorm(length(true_signal),
-                                mean = alphas[series] +
-                                       1.5*as.vector(scale(temp_effects[, series + 1])) +
-                                       true_signal,
-                                sd = runif(1, 1, 2)),
-               series = paste0('sensor_', series),
-               time = 1:length(true_signal),
-               temperature = temperature,
-               productivity = productivity,
-               true_signal = true_signal)
-   }))
-  }
-model_dat <- sim_series(true_signal = true_signal) %>%
-  dplyr::mutate(series = factor(series))
-#> Gu & Wahba 4 term additive model, correlated predictors
+
sim_series = function(n_series = 3, true_signal){
+  temp_effects <- mgcv::gamSim(n = 100, eg = 7, scale = 0.1)
+  temperature <- temp_effects$y
+  alphas <- rnorm(n_series, sd = 2)
+
+  do.call(rbind, lapply(seq_len(n_series), function(series){
+    data.frame(observed = rnorm(length(true_signal),
+                                mean = alphas[series] +
+                                       1.5*as.vector(scale(temp_effects[, series + 1])) +
+                                       true_signal,
+                                sd = runif(1, 1, 2)),
+               series = paste0('sensor_', series),
+               time = 1:length(true_signal),
+               temperature = temperature,
+               productivity = productivity,
+               true_signal = true_signal)
+   }))
+  }
+model_dat <- sim_series(true_signal = true_signal) %>%
+  dplyr::mutate(series = factor(series))
+#> Gu & Wahba 4 term additive model, correlated predictors

Plot the sensor observations

-
plot_mvgam_series(data = model_dat, y = 'observed',
-                  series = 'all')
-

+
plot_mvgam_series(data = model_dat, y = 'observed',
+                  series = 'all')
+

And now plot the observed relationships between the three sensors and the temperature covariate

-
 plot(observed ~ temperature, data = model_dat %>%
-   dplyr::filter(series == 'sensor_1'),
-   pch = 16, bty = 'l',
-   ylab = 'Sensor 1',
-   xlab = 'Temperature')
-

-
 plot(observed ~ temperature, data = model_dat %>%
-   dplyr::filter(series == 'sensor_2'),
-   pch = 16, bty = 'l',
-   ylab = 'Sensor 2',
-   xlab = 'Temperature')
-

-
 plot(observed ~ temperature, data = model_dat %>%
-   dplyr::filter(series == 'sensor_3'),
-   pch = 16, bty = 'l',
-   ylab = 'Sensor 3',
-   xlab = 'Temperature')
-

+
 plot(observed ~ temperature, data = model_dat %>%
+   dplyr::filter(series == 'sensor_1'),
+   pch = 16, bty = 'l',
+   ylab = 'Sensor 1',
+   xlab = 'Temperature')
+

+
 plot(observed ~ temperature, data = model_dat %>%
+   dplyr::filter(series == 'sensor_2'),
+   pch = 16, bty = 'l',
+   ylab = 'Sensor 2',
+   xlab = 'Temperature')
+

+
 plot(observed ~ temperature, data = model_dat %>%
+   dplyr::filter(series == 'sensor_3'),
+   pch = 16, bty = 'l',
+   ylab = 'Sensor 3',
+   xlab = 'Temperature')
+

The shared signal model

Now we can formulate and fit a model that allows each sensor’s @@ -782,116 +772,117 @@

The shared signal model

variance components (process error and observation error), which reflect our prior belief that the observation error is smaller overall than the true process error

-
mod <- mvgam(formula =
-               # formula for observations, allowing for different
-               # intercepts and hierarchical smooth effects of temperature
-               observed ~ series + 
-               s(temperature, k = 10) +
-               s(series, temperature, bs = 'sz', k = 8),
-             
-             trend_formula =
-               # formula for the latent signal, which can depend
-               # nonlinearly on productivity
-               ~ s(productivity, k = 8),
-             
-             trend_model =
-               # in addition to productivity effects, the signal is
-               # assumed to exhibit temporal autocorrelation
-               'AR1',
-             
-             trend_map =
-               # trend_map forces all sensors to track the same
-               # latent signal
-               data.frame(series = unique(model_dat$series),
-                          trend = c(1, 1, 1)),
-             
-             # informative priors on process error
-             # and observation error will help with convergence
-             priors = c(prior(normal(2, 0.5), class = sigma),
-                        prior(normal(1, 0.5), class = sigma_obs)),
-             
-             # Gaussian observations
-             family = gaussian(),
-             data = model_dat)
+
mod <- mvgam(formula =
+               # formula for observations, allowing for different
+               # intercepts and hierarchical smooth effects of temperature
+               observed ~ series + 
+               s(temperature, k = 10) +
+               s(series, temperature, bs = 'sz', k = 8),
+             
+             trend_formula =
+               # formula for the latent signal, which can depend
+               # nonlinearly on productivity
+               ~ s(productivity, k = 8),
+             
+             trend_model =
+               # in addition to productivity effects, the signal is
+               # assumed to exhibit temporal autocorrelation
+               AR(),
+             noncentred = TRUE,
+             
+             trend_map =
+               # trend_map forces all sensors to track the same
+               # latent signal
+               data.frame(series = unique(model_dat$series),
+                          trend = c(1, 1, 1)),
+             
+             # informative priors on process error
+             # and observation error will help with convergence
+             priors = c(prior(normal(2, 0.5), class = sigma),
+                        prior(normal(1, 0.5), class = sigma_obs)),
+             
+             # Gaussian observations
+             family = gaussian(),
+             data = model_dat,
+             silent = 2)

View a reduced version of the model summary because there will be many spline coefficients in this model

-
summary(mod, include_betas = FALSE)
-#> GAM observation formula:
-#> observed ~ series + s(temperature, k = 10) + s(series, temperature, 
-#>     bs = "sz", k = 8)
-#> 
-#> GAM process formula:
-#> ~s(productivity, k = 8)
-#> 
-#> Family:
-#> gaussian
-#> 
-#> Link function:
-#> identity
-#> 
-#> Trend model:
-#> AR1
-#> 
-#> N process models:
-#> 1 
-#> 
-#> N series:
-#> 3 
-#> 
-#> N timepoints:
-#> 100 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1100; warmup = 600; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> Observation error parameter estimates:
-#>              2.5% 50% 97.5% Rhat n_eff
-#> sigma_obs[1]  1.6 1.9   2.2    1  1757
-#> sigma_obs[2]  1.4 1.7   2.0    1  1090
-#> sigma_obs[3]  1.3 1.5   1.8    1  1339
-#> 
-#> GAM observation model coefficient (beta) estimates:
-#>                 2.5%   50% 97.5% Rhat n_eff
-#> (Intercept)     0.72  1.70  2.50 1.01   360
-#> seriessensor_2 -2.10 -0.96  0.32 1.00  1068
-#> seriessensor_3 -3.40 -2.00 -0.39 1.00  1154
-#> 
-#> Approximate significance of GAM observation smooths:
-#>                        edf Ref.df    F p-value    
-#> s(temperature)        1.22      9 12.7  <2e-16 ***
-#> s(series,temperature) 1.92     16  1.0   0.011 *  
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Process model AR parameter estimates:
-#>        2.5%  50% 97.5% Rhat n_eff
-#> ar1[1] 0.33 0.59  0.83    1   492
-#> 
-#> Process error parameter estimates:
-#>          2.5% 50% 97.5% Rhat n_eff
-#> sigma[1] 0.72   1   1.3 1.01   392
-#> 
-#> Approximate significance of GAM process smooths:
-#>                 edf Ref.df    F p-value    
-#> s(productivity) 3.6      7 9.34 0.00036 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhats above 1.05 found for 28 parameters
-#>  *Diagnose further to investigate why the chains have not mixed
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Tue Apr 16 1:11:39 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
+
summary(mod, include_betas = FALSE)
+#> GAM observation formula:
+#> observed ~ series + s(temperature, k = 10) + s(series, temperature, 
+#>     bs = "sz", k = 8)
+#> <environment: 0x000001f52b9e3130>
+#> 
+#> GAM process formula:
+#> ~s(productivity, k = 8)
+#> <environment: 0x000001f52b9e3130>
+#> 
+#> Family:
+#> gaussian
+#> 
+#> Link function:
+#> identity
+#> 
+#> Trend model:
+#> AR()
+#> 
+#> N process models:
+#> 1 
+#> 
+#> N series:
+#> 3 
+#> 
+#> N timepoints:
+#> 100 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1100; warmup = 600; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> Observation error parameter estimates:
+#>              2.5% 50% 97.5% Rhat n_eff
+#> sigma_obs[1]  1.4 1.7   2.1    1  1298
+#> sigma_obs[2]  1.7 2.0   2.3    1  1946
+#> sigma_obs[3]  2.0 2.3   2.7    1  2569
+#> 
+#> GAM observation model coefficient (beta) estimates:
+#>                 2.5%  50% 97.5% Rhat n_eff
+#> (Intercept)    -3.40 -2.1 -0.69    1  1067
+#> seriessensor_2 -2.80 -1.4 -0.14    1  1169
+#> seriessensor_3  0.63  3.1  4.80    1  1055
+#> 
+#> Approximate significance of GAM observation smooths:
+#>                        edf Ref.df Chi.sq p-value    
+#> s(temperature)        1.39      9   0.11       1    
+#> s(series,temperature) 2.78     16 107.40 5.4e-05 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> 
+#> Process model AR parameter estimates:
+#>        2.5% 50% 97.5% Rhat n_eff
+#> ar1[1] 0.37 0.6   0.8 1.01   616
+#> 
+#> Process error parameter estimates:
+#>          2.5% 50% 97.5% Rhat n_eff
+#> sigma[1]  1.5 1.8   2.2 1.01   649
+#> 
+#> Approximate significance of GAM process smooths:
+#>                   edf Ref.df Chi.sq p-value
+#> s(productivity) 0.926      7   5.45       1
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:32:12 AM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

Inspecting effects on both process and observation models

@@ -899,39 +890,26 @@

Inspecting effects on both process and observation models

smooth terms. The calculation for these values is incredibly sensitive to the estimates for the smoothing parameters so I don’t tend to find them to be very meaningful. What are meaningful, however, are -prediction-based plots of the smooth functions. For example, here is the -estimated response of the underlying signal to -productivity:

-
plot(mod, type = 'smooths', trend_effects = TRUE)
-

-

And here are the estimated relationships between the sensor -observations and the temperature covariate:

-
plot(mod, type = 'smooths')
-

-

All main effects can be quickly plotted with -conditional_effects:

-
plot(conditional_effects(mod, type = 'link'), ask = FALSE)
-

+prediction-based plots of the smooth functions. All main effects can be +quickly plotted with conditional_effects:

+
conditional_effects(mod, type = 'link')
+

conditional_effects is simply a wrapper to the more flexible plot_predictions function from the marginaleffects package. We can get more useful plots of these effects using this function for further customisation:

-
plot_predictions(mod, 
-                 condition = c('temperature', 'series', 'series'),
-                 points = 0.5) +
-  theme(legend.position = 'none')
-

+
require(marginaleffects)
+#> Loading required package: marginaleffects
+plot_predictions(mod, 
+                 condition = c('temperature', 'series', 'series'),
+                 points = 0.5) +
+  theme(legend.position = 'none')
+

We have successfully estimated effects, some of them nonlinear, that impact the hidden process AND the observations. All in a single joint model. But there can always be challenges with these models, particularly when estimating both process and observation error at the -same time. For example, a pairs plot for the observation -error for sensor 1 and the hidden process error shows some strong -correlations that we might want to deal with by using a more structured -prior:

-
pairs(mod, variable = c('sigma[1]', 'sigma_obs[1]'))
-

-

But we will leave the model as-is for this example

+same time.

Recovering the hidden signal

@@ -941,12 +919,12 @@

Recovering the hidden signal

plot using the mvgam S3 method for plot. We can also overlay the true values for the hidden signal, which shows that our model has done a good job of recovering it:

-
plot(mod, type = 'trend')
-
-# Overlay the true simulated signal
-points(true_signal, pch = 16, cex = 1, col = 'white')
-points(true_signal, pch = 16, cex = 0.8)
-

+
plot(mod, type = 'trend')
+
+# Overlay the true simulated signal
+points(true_signal, pch = 16, cex = 1, col = 'white')
+points(true_signal, pch = 16, cex = 0.8)
+

@@ -954,7 +932,7 @@

Further reading

The following papers and resources offer a lot of useful material about other types of State-Space models and how they can be applied in practice:

-

Holmes, Elizabeth E., Eric J. Ward, and Wills Kellie. “MARSS: +

Holmes, Elizabeth E., Eric J. Ward, and Wills Kellie. “MARSS: multivariate autoregressive state-space models for analyzing time-series data.” R Journal. 4.1 (2012): 11.

Ward, Eric J., et al. “Inferring diff --git a/doc/time_varying_effects.R b/doc/time_varying_effects.R index f5415f2b..18caf805 100644 --- a/doc/time_varying_effects.R +++ b/doc/time_varying_effects.R @@ -7,10 +7,11 @@ knitr::opts_chunk$set( eval = NOT_CRAN ) + ## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, - dpi = 150, + dpi = 100, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -19,6 +20,7 @@ library(mvgam) library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) + ## ----------------------------------------------------------------------------- set.seed(1111) N <- 200 @@ -27,15 +29,18 @@ beta_temp <- mvgam:::sim_gp(rnorm(1), rho_gp = 10, h = N) + 0.5 + ## ----fig.alt = "Simulating time-varying effects in mvgam and R"--------------- plot(beta_temp, type = 'l', lwd = 3, bty = 'l', xlab = 'Time', ylab = 'Coefficient', col = 'darkred') box(bty = 'l', lwd = 2) + ## ----------------------------------------------------------------------------- temp <- rnorm(N, sd = 1) + ## ----fig.alt = "Simulating time-varying effects in mvgam and R"--------------- out <- rnorm(N, mean = 4 + beta_temp * temp, sd = 0.25) @@ -45,29 +50,30 @@ plot(out, type = 'l', lwd = 3, col = 'darkred') box(bty = 'l', lwd = 2) + ## ----------------------------------------------------------------------------- data <- data.frame(out, temp, time) data_train <- data[1:190,] data_test <- data[191:200,] -## ----------------------------------------------------------------------------- -plot_mvgam_series(data = data_train, newdata = data_test, y = 'out') ## ----include=FALSE------------------------------------------------------------ mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) + ## ----eval=FALSE--------------------------------------------------------------- -# mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), -# family = gaussian(), -# data = data_train) +## mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), +## family = gaussian(), +## data = data_train, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(mod, include_betas = FALSE) -## ----------------------------------------------------------------------------- -plot(mod, type = 'smooths') ## ----------------------------------------------------------------------------- plot_mvgam_smooth(mod, smooth = 1, newdata = data) @@ -75,7 +81,9 @@ abline(v = 190, lty = 'dashed', lwd = 2) lines(beta_temp, lwd = 2.5, col = 'white') lines(beta_temp, lwd = 2) + ## ----------------------------------------------------------------------------- +require(marginaleffects) range_round = function(x){ round(range(x, na.rm = TRUE), 2) } @@ -85,44 +93,42 @@ plot_predictions(mod, by = c('time', 'temp', 'temp'), type = 'link') + ## ----------------------------------------------------------------------------- fc <- forecast(mod, newdata = data_test) plot(fc) + ## ----include=FALSE------------------------------------------------------------ mod <- mvgam(out ~ dynamic(temp, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) + ## ----eval=FALSE--------------------------------------------------------------- -# mod <- mvgam(out ~ dynamic(temp, k = 40), -# family = gaussian(), -# data = data_train) +## mod <- mvgam(out ~ dynamic(temp, k = 40), +## family = gaussian(), +## data = data_train, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(mod, include_betas = FALSE) + ## ----------------------------------------------------------------------------- plot_mvgam_smooth(mod, smooth = 1, newdata = data) abline(v = 190, lty = 'dashed', lwd = 2) lines(beta_temp, lwd = 2.5, col = 'white') lines(beta_temp, lwd = 2) -## ----------------------------------------------------------------------------- -plot_predictions(mod, - newdata = datagrid(time = unique, - temp = range_round), - by = c('time', 'temp', 'temp'), - type = 'link') - -## ----------------------------------------------------------------------------- -fc <- forecast(mod, newdata = data_test) -plot(fc) ## ----------------------------------------------------------------------------- load(url('https://github.com/atsa-es/MARSS/raw/master/data/SalmonSurvCUI.rda')) dplyr::glimpse(SalmonSurvCUI) + ## ----------------------------------------------------------------------------- SalmonSurvCUI %>% # create a time variable @@ -137,57 +143,74 @@ SalmonSurvCUI %>% # convert logit-transformed survival back to proportional dplyr::mutate(survival = plogis(logit.s)) -> model_data + ## ----------------------------------------------------------------------------- dplyr::glimpse(model_data) + ## ----------------------------------------------------------------------------- plot_mvgam_series(data = model_data, y = 'survival') + ## ----include = FALSE---------------------------------------------------------- mod0 <- mvgam(formula = survival ~ 1, - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) + ## ----eval = FALSE------------------------------------------------------------- -# mod0 <- mvgam(formula = survival ~ 1, -# trend_model = 'RW', -# family = betar(), -# data = model_data) +## mod0 <- mvgam(formula = survival ~ 1, +## trend_model = AR(), +## noncentred = TRUE, +## family = betar(), +## data = model_data, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(mod0) + ## ----------------------------------------------------------------------------- plot(mod0, type = 'trend') -## ----------------------------------------------------------------------------- -plot(mod0, type = 'forecast') ## ----include=FALSE------------------------------------------------------------ mod1 <- mvgam(formula = survival ~ 1, trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), data = model_data, - adapt_delta = 0.99) + adapt_delta = 0.99, + silent = 2) + ## ----eval=FALSE--------------------------------------------------------------- -# mod1 <- mvgam(formula = survival ~ 1, -# trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), -# trend_model = 'RW', -# family = betar(), -# data = model_data) +## mod1 <- mvgam(formula = survival ~ 1, +## trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), +## trend_model = AR(), +## noncentred = TRUE, +## family = betar(), +## data = model_data, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(mod1, include_betas = FALSE) + ## ----------------------------------------------------------------------------- plot(mod1, type = 'trend') + ## ----------------------------------------------------------------------------- plot(mod1, type = 'forecast') + ## ----------------------------------------------------------------------------- # Extract estimates of the process error 'sigma' for each model mod0_sigma <- as.data.frame(mod0, variable = 'sigma', regex = TRUE) %>% @@ -197,34 +220,35 @@ mod1_sigma <- as.data.frame(mod1, variable = 'sigma', regex = TRUE) %>% sigmas <- rbind(mod0_sigma, mod1_sigma) # Plot using ggplot2 -library(ggplot2) +require(ggplot2) ggplot(sigmas, aes(y = `sigma[1]`, fill = model)) + geom_density(alpha = 0.3, colour = NA) + coord_flip() -## ----------------------------------------------------------------------------- -plot(mod1, type = 'smooth', trend_effects = TRUE) ## ----------------------------------------------------------------------------- -plot_predictions(mod1, newdata = datagrid(CUI.apr = range_round, - time = unique), - by = c('time', 'CUI.apr', 'CUI.apr')) +plot(mod1, type = 'smooths', trend_effects = TRUE) + ## ----------------------------------------------------------------------------- loo_compare(mod0, mod1) + ## ----include=FALSE------------------------------------------------------------ lfo_mod0 <- lfo_cv(mod0, min_t = 30) lfo_mod1 <- lfo_cv(mod1, min_t = 30) + ## ----eval=FALSE--------------------------------------------------------------- -# lfo_mod0 <- lfo_cv(mod0, min_t = 30) -# lfo_mod1 <- lfo_cv(mod1, min_t = 30) +## lfo_mod0 <- lfo_cv(mod0, min_t = 30) +## lfo_mod1 <- lfo_cv(mod1, min_t = 30) + ## ----------------------------------------------------------------------------- sum(lfo_mod0$elpds) sum(lfo_mod1$elpds) + ## ----fig.alt = "Comparing forecast skill for dynamic beta regression models in mvgam and R"---- plot(x = 1:length(lfo_mod0$elpds) + 30, y = lfo_mod0$elpds - lfo_mod1$elpds, diff --git a/doc/time_varying_effects.Rmd b/doc/time_varying_effects.Rmd index 271a907d..ec19a933 100644 --- a/doc/time_varying_effects.Rmd +++ b/doc/time_varying_effects.Rmd @@ -23,7 +23,7 @@ knitr::opts_chunk$set( ```{r setup, include=FALSE} knitr::opts_chunk$set( echo = TRUE, - dpi = 150, + dpi = 100, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -80,24 +80,20 @@ data_train <- data[1:190,] data_test <- data[191:200,] ``` -Plot the series -```{r} -plot_mvgam_series(data = data_train, newdata = data_test, y = 'out') -``` - - ### The `dynamic()` function Time-varying coefficients can be fairly easily set up using the `s()` or `gp()` wrapper functions in `mvgam` formulae by fitting a nonlinear effect of `time` and using the covariate of interest as the numeric `by` variable (see `?mgcv::s` or `?brms::gp` for more details). The `dynamic()` formula wrapper offers a way to automate this process, and will eventually allow for a broader variety of time-varying effects (such as random walk or AR processes). Depending on the arguments that are specified to `dynamic`, it will either set up a low-rank GP smooth function using `s()` with `bs = 'gp'` and a fixed value of the length scale parameter $\rho$, or it will set up a Hilbert space approximate GP using the `gp()` function with `c=5/4` so that $\rho$ is estimated (see `?dynamic` for more details). In this first example we will use the `s()` option, and will mis-specify the $\rho$ parameter here as, in practice, it is never known. This call to `dynamic()` will set up the following smooth: `s(time, by = temp, bs = "gp", m = c(-2, 8, 2), k = 40)` ```{r, include=FALSE} mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` ```{r, eval=FALSE} mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` Inspect the model summary, which shows how the `dynamic()` wrapper was used to construct a low-rank Gaussian Process smooth function: @@ -105,12 +101,7 @@ Inspect the model summary, which shows how the `dynamic()` wrapper was used to c summary(mod, include_betas = FALSE) ``` -Because this model used a spline with a `gp` basis, it's smooths can be visualised just like any other `gam`. Plot the estimated time-varying coefficient for the in-sample training period -```{r} -plot(mod, type = 'smooths') -``` - -We can also plot the estimates for the in-sample and out-of-sample periods to see how the Gaussian Process function produces sensible smooth forecasts. Here we supply the full dataset to the `newdata` argument in `plot_mvgam_smooth` to inspect posterior forecasts of the time-varying smooth function. Overlay the true simulated function to see that the model has adequately estimated it's dynamics in both the training and testing data partitions +Because this model used a spline with a `gp` basis, it's smooths can be visualised just like any other `gam`. We can plot the estimates for the in-sample and out-of-sample periods to see how the Gaussian Process function produces sensible smooth forecasts. Here we supply the full dataset to the `newdata` argument in `plot_mvgam_smooth` to inspect posterior forecasts of the time-varying smooth function. Overlay the true simulated function to see that the model has adequately estimated it's dynamics in both the training and testing data partitions ```{r} plot_mvgam_smooth(mod, smooth = 1, newdata = data) abline(v = 190, lty = 'dashed', lwd = 2) @@ -120,6 +111,7 @@ lines(beta_temp, lwd = 2) We can also use `plot_predictions` from the `marginaleffects` package to visualise the time-varying coefficient for what the effect would be estimated to be at different values of $temperature$: ```{r} +require(marginaleffects) range_round = function(x){ round(range(x, na.rm = TRUE), 2) } @@ -140,13 +132,15 @@ The syntax is very similar if we wish to estimate the parameters of the underlyi ```{r include=FALSE} mod <- mvgam(out ~ dynamic(temp, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` ```{r eval=FALSE} mod <- mvgam(out ~ dynamic(temp, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` This model summary now contains estimates for the marginal deviation and length scale parameters of the underlying Gaussian Process function: @@ -162,21 +156,6 @@ lines(beta_temp, lwd = 2.5, col = 'white') lines(beta_temp, lwd = 2) ``` -Both the above plot and the below `plot_predictions()` call show that the effect in this case is similar to what we estimated in the approximate GP smooth model above: -```{r} -plot_predictions(mod, - newdata = datagrid(time = unique, - temp = range_round), - by = c('time', 'temp', 'temp'), - type = 'link') -``` - -Forecasts are also similar: -```{r} -fc <- forecast(mod, newdata = data_test) -plot(fc) -``` - ## Salmon survival example Here we will use openly available data on marine survival of Chinook salmon to illustrate how time-varying effects can be used to improve ecological time series models. [Scheuerell and Williams (2005)](https://onlinelibrary.wiley.com/doi/abs/10.1111/j.1365-2419.2005.00346.x) used a dynamic linear model to examine the relationship between marine survival of Chinook salmon and an index of ocean upwelling strength along the west coast of the USA. The authors hypothesized that stronger upwelling in April should create better growing conditions for phytoplankton, which would then translate into more zooplankton and provide better foraging opportunities for juvenile salmon entering the ocean. The data on survival is measured as a proportional variable over 42 years (1964–2005) and is available in the `MARSS` package: ```{r} @@ -212,19 +191,23 @@ plot_mvgam_series(data = model_data, y = 'survival') ### A State-Space Beta regression -`mvgam` can easily handle data that are bounded at 0 and 1 with a Beta observation model (using the `mgcv` function `betar()`, see `?mgcv::betar` for details). First we will fit a simple State-Space model that uses a Random Walk dynamic process model with no predictors and a Beta observation model: +`mvgam` can easily handle data that are bounded at 0 and 1 with a Beta observation model (using the `mgcv` function `betar()`, see `?mgcv::betar` for details). First we will fit a simple State-Space model that uses an AR1 dynamic process model with no predictors and a Beta observation model: ```{r include = FALSE} mod0 <- mvgam(formula = survival ~ 1, - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) ``` ```{r eval = FALSE} mod0 <- mvgam(formula = survival ~ 1, - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) ``` The summary of this model shows good behaviour of the Hamiltonian Monte Carlo sampler and provides useful summaries on the Beta observation model parameters: @@ -237,29 +220,27 @@ A plot of the underlying dynamic component shows how it has easily handled the t plot(mod0, type = 'trend') ``` -Posterior hindcasts are also good and will automatically respect the observational data bounding at 0 and 1: -```{r} -plot(mod0, type = 'forecast') -``` - - ### Including time-varying upwelling effects Now we can increase the complexity of our model by constructing and fitting a State-Space model with a time-varying effect of the coastal upwelling index in addition to the autoregressive dynamics. We again use a Beta observation model to capture the restrictions of our proportional observations, but this time will include a `dynamic()` effect of `CUI.apr` in the latent process model. We do not specify the $\rho$ parameter, instead opting to estimate it using a Hilbert space approximate GP: ```{r include=FALSE} mod1 <- mvgam(formula = survival ~ 1, trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), data = model_data, - adapt_delta = 0.99) + adapt_delta = 0.99, + silent = 2) ``` ```{r eval=FALSE} mod1 <- mvgam(formula = survival ~ 1, trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) ``` The summary for this model now includes estimates for the time-varying GP parameters: @@ -286,25 +267,17 @@ mod1_sigma <- as.data.frame(mod1, variable = 'sigma', regex = TRUE) %>% sigmas <- rbind(mod0_sigma, mod1_sigma) # Plot using ggplot2 -library(ggplot2) +require(ggplot2) ggplot(sigmas, aes(y = `sigma[1]`, fill = model)) + geom_density(alpha = 0.3, colour = NA) + coord_flip() ``` -Why does the process error not need to be as flexible in the second model? Because the estimates of this dynamic process are now informed partly by the time-varying effect of upwelling, which we can visualise on the link scale using `plot()` with `trend_effects = TRUE`: +Why does the process error not need to be as flexible in the second model? Because the estimates of this dynamic process are now informed partly by the time-varying effect of upwelling, which we can visualise on the link scale using `plot()`: ```{r} -plot(mod1, type = 'smooth', trend_effects = TRUE) +plot(mod1, type = 'smooths', trend_effects = TRUE) ``` -Or on the outcome scale, at a range of possible `CUI.apr` values, using `plot_predictions()`: -```{r} -plot_predictions(mod1, newdata = datagrid(CUI.apr = range_round, - time = unique), - by = c('time', 'CUI.apr', 'CUI.apr')) -``` - - ### Comparing model predictive performances A key question when fitting multiple time series models is whether one of them provides better predictions than the other. There are several options in `mvgam` for exploring this quantitatively. First, we can compare models based on in-sample approximate leave-one-out cross-validation as implemented in the popular `loo` package: ```{r} @@ -340,7 +313,7 @@ plot(x = 1:length(lfo_mod0$elpds) + 30, abline(h = 0, lty = 'dashed') ``` -A useful exercise to further expand this model would be to think about what kinds of predictors might impact measurement error, which could easily be implemented into the observation formula in `mvgam`. But for now, we will leave the model as-is. +A useful exercise to further expand this model would be to think about what kinds of predictors might impact measurement error, which could easily be implemented into the observation formula in `mvgam()`. But for now, we will leave the model as-is. ## Further reading The following papers and resources offer a lot of useful material about dynamic linear models and how they can be applied / evaluated in practice: diff --git a/doc/time_varying_effects.html b/doc/time_varying_effects.html index 8d85f76b..341e817b 100644 --- a/doc/time_varying_effects.html +++ b/doc/time_varying_effects.html @@ -12,7 +12,7 @@ - + Time-varying effects in mvgam @@ -340,7 +340,7 @@

Time-varying effects in mvgam

Nicholas J Clark

-

2024-04-18

+

2024-07-01

@@ -407,7 +407,7 @@

Simulating time-varying effects

 bty = 'l', xlab = 'Time', ylab = 'Coefficient', col = 'darkred') box(bty = 'l', lwd = 2)
-

Simulating time-varying effects in mvgam and R

+

Simulating time-varying effects in mvgam and R

Next we need to simulate the values of the covariate, which we will call temp (to represent \(temperature\)). In this case we just use a standard normal distribution to simulate this covariate:

@@ -422,15 +422,12 @@

Simulating time-varying effects

bty = 'l', xlab = 'Time', ylab = 'Outcome', col = 'darkred') box(bty = 'l', lwd = 2)
-

Simulating time-varying effects in mvgam and R

+

Simulating time-varying effects in mvgam and R

Gather the data into a data.frame for fitting models, and split the data into training and testing folds.

data <- data.frame(out, temp, time)
 data_train <- data[1:190,]
 data_test <- data[191:200,]
-

Plot the series

-
plot_mvgam_series(data = data_train, newdata = data_test, y = 'out')
-

The dynamic() function

@@ -454,184 +451,168 @@

The dynamic() function

practice, it is never known. This call to dynamic() will set up the following smooth: s(time, by = temp, bs = "gp", m = c(-2, 8, 2), k = 40)

-
mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40),
-             family = gaussian(),
-             data = data_train)
+
mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40),
+             family = gaussian(),
+             data = data_train,
+             silent = 2)

Inspect the model summary, which shows how the dynamic() wrapper was used to construct a low-rank Gaussian Process smooth function:

-
summary(mod, include_betas = FALSE)
-#> GAM formula:
-#> out ~ s(time, by = temp, bs = "gp", m = c(-2, 8, 2), k = 40)
-#> <environment: 0x000001d9c44e71e0>
-#> 
-#> Family:
-#> gaussian
-#> 
-#> Link function:
-#> identity
-#> 
-#> Trend model:
-#> None
-#> 
-#> N series:
-#> 1 
-#> 
-#> N timepoints:
-#> 190 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> Observation error parameter estimates:
-#>              2.5%  50% 97.5% Rhat n_eff
-#> sigma_obs[1] 0.23 0.25  0.28    1  2222
-#> 
-#> GAM coefficient (beta) estimates:
-#>             2.5% 50% 97.5% Rhat n_eff
-#> (Intercept)    4   4   4.1    1  2893
-#> 
-#> Approximate significance of GAM smooths:
-#>              edf Ref.df    F p-value    
-#> s(time):temp  14     40 72.4  <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Thu Apr 18 8:39:49 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
+
summary(mod, include_betas = FALSE)
+#> GAM formula:
+#> out ~ s(time, by = temp, bs = "gp", m = c(-2, 8, 2), k = 40)
+#> <environment: 0x0000014d37f0f110>
+#> 
+#> Family:
+#> gaussian
+#> 
+#> Link function:
+#> identity
+#> 
+#> Trend model:
+#> None
+#> 
+#> N series:
+#> 1 
+#> 
+#> N timepoints:
+#> 190 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> Observation error parameter estimates:
+#>              2.5%  50% 97.5% Rhat n_eff
+#> sigma_obs[1] 0.23 0.25  0.28    1  2026
+#> 
+#> GAM coefficient (beta) estimates:
+#>             2.5% 50% 97.5% Rhat n_eff
+#> (Intercept)    4   4   4.1    1  2640
+#> 
+#> Approximate significance of GAM smooths:
+#>               edf Ref.df Chi.sq p-value    
+#> s(time):temp 15.4     40    173  <2e-16 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:35:21 AM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

Because this model used a spline with a gp basis, it’s -smooths can be visualised just like any other gam. Plot the -estimated time-varying coefficient for the in-sample training period

-
plot(mod, type = 'smooths')
-

-

We can also plot the estimates for the in-sample and out-of-sample -periods to see how the Gaussian Process function produces sensible -smooth forecasts. Here we supply the full dataset to the -newdata argument in plot_mvgam_smooth to -inspect posterior forecasts of the time-varying smooth function. Overlay -the true simulated function to see that the model has adequately -estimated it’s dynamics in both the training and testing data -partitions

-
plot_mvgam_smooth(mod, smooth = 1, newdata = data)
-abline(v = 190, lty = 'dashed', lwd = 2)
-lines(beta_temp, lwd = 2.5, col = 'white')
-lines(beta_temp, lwd = 2)
-

+smooths can be visualised just like any other gam. We can +plot the estimates for the in-sample and out-of-sample periods to see +how the Gaussian Process function produces sensible smooth forecasts. +Here we supply the full dataset to the newdata argument in +plot_mvgam_smooth to inspect posterior forecasts of the +time-varying smooth function. Overlay the true simulated function to see +that the model has adequately estimated it’s dynamics in both the +training and testing data partitions

+
plot_mvgam_smooth(mod, smooth = 1, newdata = data)
+abline(v = 190, lty = 'dashed', lwd = 2)
+lines(beta_temp, lwd = 2.5, col = 'white')
+lines(beta_temp, lwd = 2)
+

We can also use plot_predictions from the marginaleffects package to visualise the time-varying coefficient for what the effect would be estimated to be at different values of \(temperature\):

-
range_round = function(x){
-  round(range(x, na.rm = TRUE), 2)
-}
-plot_predictions(mod, 
-                 newdata = datagrid(time = unique,
-                                    temp = range_round),
-                 by = c('time', 'temp', 'temp'),
-                 type = 'link')
-

+
require(marginaleffects)
+#> Loading required package: marginaleffects
+range_round = function(x){
+  round(range(x, na.rm = TRUE), 2)
+}
+plot_predictions(mod, 
+                 newdata = datagrid(time = unique,
+                                    temp = range_round),
+                 by = c('time', 'temp', 'temp'),
+                 type = 'link')
+

This results in sensible forecasts of the observations as well

-
fc <- forecast(mod, newdata = data_test)
-plot(fc)
-

-
#> Out of sample CRPS:
-#> [1] 1.280347
+
fc <- forecast(mod, newdata = data_test)
+plot(fc)
+#> Out of sample CRPS:
+#> 1.30674285292277
+

The syntax is very similar if we wish to estimate the parameters of the underlying Gaussian Process, this time using a Hilbert space approximation. We simply omit the rho argument in dynamic to make this happen. This will set up a call similar to gp(time, by = 'temp', c = 5/4, k = 40).

-
mod <- mvgam(out ~ dynamic(temp, k = 40),
-             family = gaussian(),
-             data = data_train)
+
mod <- mvgam(out ~ dynamic(temp, k = 40),
+             family = gaussian(),
+             data = data_train,
+             silent = 2)

This model summary now contains estimates for the marginal deviation and length scale parameters of the underlying Gaussian Process function:

-
summary(mod, include_betas = FALSE)
-#> GAM formula:
-#> out ~ gp(time, by = temp, c = 5/4, k = 40, scale = TRUE)
-#> <environment: 0x000001d9c44e71e0>
-#> 
-#> Family:
-#> gaussian
-#> 
-#> Link function:
-#> identity
-#> 
-#> Trend model:
-#> None
-#> 
-#> N series:
-#> 1 
-#> 
-#> N timepoints:
-#> 190 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> Observation error parameter estimates:
-#>              2.5%  50% 97.5% Rhat n_eff
-#> sigma_obs[1] 0.24 0.26  0.29    1  2151
-#> 
-#> GAM coefficient (beta) estimates:
-#>             2.5% 50% 97.5% Rhat n_eff
-#> (Intercept)    4   4   4.1    1  2989
-#> 
-#> GAM gp term marginal deviation (alpha) and length scale (rho) estimates:
-#>                      2.5%   50% 97.5% Rhat n_eff
-#> alpha_gp(time):temp 0.640 0.890 1.400 1.01   745
-#> rho_gp(time):temp   0.028 0.053 0.069 1.00   888
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 1 of 2000 iterations ended with a divergence (0.05%)
-#>  *Try running with larger adapt_delta to remove the divergences
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Thu Apr 18 8:41:07 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
+
summary(mod, include_betas = FALSE)
+#> GAM formula:
+#> out ~ gp(time, by = temp, c = 5/4, k = 40, scale = TRUE)
+#> <environment: 0x0000014d37f0f110>
+#> 
+#> Family:
+#> gaussian
+#> 
+#> Link function:
+#> identity
+#> 
+#> Trend model:
+#> None
+#> 
+#> N series:
+#> 1 
+#> 
+#> N timepoints:
+#> 190 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> Observation error parameter estimates:
+#>              2.5%  50% 97.5% Rhat n_eff
+#> sigma_obs[1] 0.24 0.26   0.3    1  2183
+#> 
+#> GAM coefficient (beta) estimates:
+#>             2.5% 50% 97.5% Rhat n_eff
+#> (Intercept)    4   4   4.1    1  2733
+#> 
+#> GAM gp term marginal deviation (alpha) and length scale (rho) estimates:
+#>                      2.5%   50% 97.5% Rhat n_eff
+#> alpha_gp(time):temp 0.620 0.890 1.400 1.01   539
+#> rho_gp(time):temp   0.026 0.053 0.069 1.00   628
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:36:09 AM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

Effects for gp() terms can also be plotted as smooths:

-
plot_mvgam_smooth(mod, smooth = 1, newdata = data)
-abline(v = 190, lty = 'dashed', lwd = 2)
-lines(beta_temp, lwd = 2.5, col = 'white')
-lines(beta_temp, lwd = 2)
-

-

Both the above plot and the below plot_predictions() -call show that the effect in this case is similar to what we estimated -in the approximate GP smooth model above:

-
plot_predictions(mod, 
-                 newdata = datagrid(time = unique,
-                                    temp = range_round),
-                 by = c('time', 'temp', 'temp'),
-                 type = 'link')
-

-

Forecasts are also similar:

-
fc <- forecast(mod, newdata = data_test)
-plot(fc)
-

-
#> Out of sample CRPS:
-#> [1] 1.667521
+
plot_mvgam_smooth(mod, smooth = 1, newdata = data)
+abline(v = 190, lty = 'dashed', lwd = 2)
+lines(beta_temp, lwd = 2.5, col = 'white')
+lines(beta_temp, lwd = 2)
+

@@ -648,13 +629,13 @@

Salmon survival example

salmon entering the ocean. The data on survival is measured as a proportional variable over 42 years (1964–2005) and is available in the MARSS package:

-
load(url('https://github.com/atsa-es/MARSS/raw/master/data/SalmonSurvCUI.rda'))
-dplyr::glimpse(SalmonSurvCUI)
-#> Rows: 42
-#> Columns: 3
-#> $ year    <int> 1964, 1965, 1966, 1967, 1968, 1969, 1970, 1971, 1972, 1973, 19…
-#> $ logit.s <dbl> -3.46, -3.32, -3.58, -3.03, -3.61, -3.35, -3.93, -4.19, -4.82,…
-#> $ CUI.apr <int> 57, 5, 43, 11, 47, -21, 25, -2, -1, 43, 2, 35, 0, 1, -1, 6, -7…
+
load(url('https://github.com/atsa-es/MARSS/raw/master/data/SalmonSurvCUI.rda'))
+dplyr::glimpse(SalmonSurvCUI)
+#> Rows: 42
+#> Columns: 3
+#> $ year    <int> 1964, 1965, 1966, 1967, 1968, 1969, 1970, 1971, 1972, 1973, 19…
+#> $ logit.s <dbl> -3.46, -3.32, -3.58, -3.03, -3.61, -3.35, -3.93, -4.19, -4.82,…
+#> $ CUI.apr <int> 57, 5, 43, 11, 47, -21, 25, -2, -1, 43, 2, 35, 0, 1, -1, 6, -7…

First we need to prepare the data for modelling. The variable CUI.apr will be standardized to make it easier for the sampler to estimate underlying GP parameters for the time-varying @@ -663,104 +644,103 @@

Salmon survival example

time series packages cannot handle proportional data). As usual, we also need to create a time indicator and a series indicator for working in mvgam:

-
SalmonSurvCUI %>%
-  # create a time variable
-  dplyr::mutate(time = dplyr::row_number()) %>%
-
-  # create a series variable
-  dplyr::mutate(series = as.factor('salmon')) %>%
-
-  # z-score the covariate CUI.apr
-  dplyr::mutate(CUI.apr = as.vector(scale(CUI.apr))) %>%
-
-  # convert logit-transformed survival back to proportional
-  dplyr::mutate(survival = plogis(logit.s)) -> model_data
+
SalmonSurvCUI %>%
+  # create a time variable
+  dplyr::mutate(time = dplyr::row_number()) %>%
+
+  # create a series variable
+  dplyr::mutate(series = as.factor('salmon')) %>%
+
+  # z-score the covariate CUI.apr
+  dplyr::mutate(CUI.apr = as.vector(scale(CUI.apr))) %>%
+
+  # convert logit-transformed survival back to proportional
+  dplyr::mutate(survival = plogis(logit.s)) -> model_data

Inspect the data

-
dplyr::glimpse(model_data)
-#> Rows: 42
-#> Columns: 6
-#> $ year     <int> 1964, 1965, 1966, 1967, 1968, 1969, 1970, 1971, 1972, 1973, 1…
-#> $ logit.s  <dbl> -3.46, -3.32, -3.58, -3.03, -3.61, -3.35, -3.93, -4.19, -4.82…
-#> $ CUI.apr  <dbl> 2.37949804, 0.03330223, 1.74782994, 0.30401713, 1.92830654, -…
-#> $ time     <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18…
-#> $ series   <fct> salmon, salmon, salmon, salmon, salmon, salmon, salmon, salmo…
-#> $ survival <dbl> 0.030472033, 0.034891409, 0.027119717, 0.046088827, 0.0263393…
+
dplyr::glimpse(model_data)
+#> Rows: 42
+#> Columns: 6
+#> $ year     <int> 1964, 1965, 1966, 1967, 1968, 1969, 1970, 1971, 1972, 1973, 1…
+#> $ logit.s  <dbl> -3.46, -3.32, -3.58, -3.03, -3.61, -3.35, -3.93, -4.19, -4.82…
+#> $ CUI.apr  <dbl> 2.37949804, 0.03330223, 1.74782994, 0.30401713, 1.92830654, -…
+#> $ time     <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18…
+#> $ series   <fct> salmon, salmon, salmon, salmon, salmon, salmon, salmon, salmo…
+#> $ survival <dbl> 0.030472033, 0.034891409, 0.027119717, 0.046088827, 0.0263393…

Plot features of the outcome variable, which shows that it is a proportional variable with particular restrictions that we want to model:

-
plot_mvgam_series(data = model_data, y = 'survival')
-

+
plot_mvgam_series(data = model_data, y = 'survival')
+

A State-Space Beta regression

mvgam can easily handle data that are bounded at 0 and 1 with a Beta observation model (using the mgcv function betar(), see ?mgcv::betar for details). First -we will fit a simple State-Space model that uses a Random Walk dynamic -process model with no predictors and a Beta observation model:

-
mod0 <- mvgam(formula = survival ~ 1,
-             trend_model = 'RW',
-             family = betar(),
-             data = model_data)
+we will fit a simple State-Space model that uses an AR1 dynamic process +model with no predictors and a Beta observation model:

+
mod0 <- mvgam(formula = survival ~ 1,
+             trend_model = AR(),
+             noncentred = TRUE,
+             family = betar(),
+             data = model_data,
+             silent = 2)

The summary of this model shows good behaviour of the Hamiltonian Monte Carlo sampler and provides useful summaries on the Beta observation model parameters:

-
summary(mod0)
-#> GAM formula:
-#> survival ~ 1
-#> <environment: 0x000001d9c44e71e0>
-#> 
-#> Family:
-#> beta
-#> 
-#> Link function:
-#> logit
-#> 
-#> Trend model:
-#> RW
-#> 
-#> N series:
-#> 1 
-#> 
-#> N timepoints:
-#> 42 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> Observation precision parameter estimates:
-#>        2.5% 50% 97.5% Rhat n_eff
-#> phi[1]  160 310   580 1.01   612
-#> 
-#> GAM coefficient (beta) estimates:
-#>             2.5%  50% 97.5% Rhat n_eff
-#> (Intercept) -4.2 -3.4  -2.4 1.02   125
-#> 
-#> Latent trend variance estimates:
-#>          2.5%  50% 97.5% Rhat n_eff
-#> sigma[1] 0.18 0.33  0.55 1.02   276
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Thu Apr 18 8:42:35 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
+
summary(mod0)
+#> GAM formula:
+#> survival ~ 1
+#> <environment: 0x0000014d37f0f110>
+#> 
+#> Family:
+#> beta
+#> 
+#> Link function:
+#> logit
+#> 
+#> Trend model:
+#> AR()
+#> 
+#> N series:
+#> 1 
+#> 
+#> N timepoints:
+#> 42 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> Observation precision parameter estimates:
+#>        2.5% 50% 97.5% Rhat n_eff
+#> phi[1]   95 280   630 1.02   271
+#> 
+#> GAM coefficient (beta) estimates:
+#>             2.5%  50% 97.5% Rhat n_eff
+#> (Intercept) -4.7 -4.4    -4    1   625
+#> 
+#> Latent trend parameter AR estimates:
+#>            2.5%  50% 97.5% Rhat n_eff
+#> ar1[1]   -0.230 0.67  0.98 1.01   415
+#> sigma[1]  0.073 0.47  0.72 1.02   213
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:36:57 AM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

A plot of the underlying dynamic component shows how it has easily handled the temporal evolution of the time series:

-
plot(mod0, type = 'trend')
-

-

Posterior hindcasts are also good and will automatically respect the -observational data bounding at 0 and 1:

-
plot(mod0, type = 'forecast')
-

+
plot(mod0, type = 'trend')
+

Including time-varying upwelling effects

@@ -772,110 +752,108 @@

Including time-varying upwelling effects

of CUI.apr in the latent process model. We do not specify the \(\rho\) parameter, instead opting to estimate it using a Hilbert space approximate GP:

-
mod1 <- mvgam(formula = survival ~ 1,
-              trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE),
-              trend_model = 'RW',
-              family = betar(),
-              data = model_data)
+
mod1 <- mvgam(formula = survival ~ 1,
+              trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE),
+              trend_model = AR(),
+              noncentred = TRUE,
+              family = betar(),
+              data = model_data,
+              silent = 2)

The summary for this model now includes estimates for the time-varying GP parameters:

-
summary(mod1, include_betas = FALSE)
-#> GAM observation formula:
-#> survival ~ 1
-#> <environment: 0x000001d9c44e71e0>
-#> 
-#> GAM process formula:
-#> ~dynamic(CUI.apr, k = 25, scale = FALSE)
-#> <environment: 0x000001d9c44e71e0>
-#> 
-#> Family:
-#> beta
-#> 
-#> Link function:
-#> logit
-#> 
-#> Trend model:
-#> RW
-#> 
-#> N process models:
-#> 1 
-#> 
-#> N series:
-#> 1 
-#> 
-#> N timepoints:
-#> 42 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> Observation precision parameter estimates:
-#>        2.5% 50% 97.5% Rhat n_eff
-#> phi[1]  190 360   670    1   858
-#> 
-#> GAM observation model coefficient (beta) estimates:
-#>             2.5%  50% 97.5% Rhat n_eff
-#> (Intercept) -4.1 -3.2  -2.2 1.07    64
-#> 
-#> Process error parameter estimates:
-#>          2.5%  50% 97.5% Rhat n_eff
-#> sigma[1] 0.18 0.31  0.51 1.02   274
-#> 
-#> GAM process model gp term marginal deviation (alpha) and length scale (rho) estimates:
-#>                                2.5%  50% 97.5% Rhat n_eff
-#> alpha_gp_time_byCUI_apr_trend 0.028 0.32   1.5 1.02   205
-#> rho_gp_time_byCUI_apr_trend   1.400 6.50  40.0 1.02   236
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhats above 1.05 found for 30 parameters
-#>  *Diagnose further to investigate why the chains have not mixed
-#> 89 of 2000 iterations ended with a divergence (4.45%)
-#>  *Try running with larger adapt_delta to remove the divergences
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Thu Apr 18 8:44:05 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
+
summary(mod1, include_betas = FALSE)
+#> GAM observation formula:
+#> survival ~ 1
+#> <environment: 0x0000014d37f0f110>
+#> 
+#> GAM process formula:
+#> ~dynamic(CUI.apr, k = 25, scale = FALSE)
+#> <environment: 0x0000014d37f0f110>
+#> 
+#> Family:
+#> beta
+#> 
+#> Link function:
+#> logit
+#> 
+#> Trend model:
+#> AR()
+#> 
+#> N process models:
+#> 1 
+#> 
+#> N series:
+#> 1 
+#> 
+#> N timepoints:
+#> 42 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> Observation precision parameter estimates:
+#>        2.5% 50% 97.5% Rhat n_eff
+#> phi[1]  160 350   690    1   557
+#> 
+#> GAM observation model coefficient (beta) estimates:
+#>             2.5% 50% 97.5% Rhat n_eff
+#> (Intercept) -4.7  -4  -2.6    1   331
+#> 
+#> Process model AR parameter estimates:
+#>        2.5%  50% 97.5% Rhat n_eff
+#> ar1[1] 0.46 0.89  0.99 1.01   364
+#> 
+#> Process error parameter estimates:
+#>          2.5%  50% 97.5% Rhat n_eff
+#> sigma[1] 0.18 0.35  0.58    1   596
+#> 
+#> GAM process model gp term marginal deviation (alpha) and length scale (rho) estimates:
+#>                               2.5% 50% 97.5% Rhat n_eff
+#> alpha_gp_time_byCUI_apr_trend 0.02 0.3   1.2    1   760
+#> rho_gp_time_byCUI_apr_trend   1.30 5.5  28.0    1   674
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 79 of 2000 iterations ended with a divergence (3.95%)
+#>  *Try running with larger adapt_delta to remove the divergences
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:37:32 AM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

The estimates for the underlying dynamic process, and for the hindcasts, haven’t changed much:

-
plot(mod1, type = 'trend')
-

-
plot(mod1, type = 'forecast')
-

+
plot(mod1, type = 'trend')
+

+
plot(mod1, type = 'forecast')
+

But the process error parameter \(\sigma\) is slightly smaller for this model than for the first model:

-
# Extract estimates of the process error 'sigma' for each model
-mod0_sigma <- as.data.frame(mod0, variable = 'sigma', regex = TRUE) %>%
-  dplyr::mutate(model = 'Mod0')
-mod1_sigma <- as.data.frame(mod1, variable = 'sigma', regex = TRUE) %>%
-  dplyr::mutate(model = 'Mod1')
-sigmas <- rbind(mod0_sigma, mod1_sigma)
-
-# Plot using ggplot2
-library(ggplot2)
-ggplot(sigmas, aes(y = `sigma[1]`, fill = model)) +
-  geom_density(alpha = 0.3, colour = NA) +
-  coord_flip()
-

+
# Extract estimates of the process error 'sigma' for each model
+mod0_sigma <- as.data.frame(mod0, variable = 'sigma', regex = TRUE) %>%
+  dplyr::mutate(model = 'Mod0')
+mod1_sigma <- as.data.frame(mod1, variable = 'sigma', regex = TRUE) %>%
+  dplyr::mutate(model = 'Mod1')
+sigmas <- rbind(mod0_sigma, mod1_sigma)
+
+# Plot using ggplot2
+require(ggplot2)
+ggplot(sigmas, aes(y = `sigma[1]`, fill = model)) +
+  geom_density(alpha = 0.3, colour = NA) +
+  coord_flip()
+

Why does the process error not need to be as flexible in the second model? Because the estimates of this dynamic process are now informed partly by the time-varying effect of upwelling, which we can visualise -on the link scale using plot() with -trend_effects = TRUE:

-
plot(mod1, type = 'smooth', trend_effects = TRUE)
-

-

Or on the outcome scale, at a range of possible CUI.apr -values, using plot_predictions():

-
plot_predictions(mod1, newdata = datagrid(CUI.apr = range_round,
-                                          time = unique),
-                 by = c('time', 'CUI.apr', 'CUI.apr'))
-

+on the link scale using plot():

+
plot(mod1, type = 'smooths', trend_effects = TRUE)
+

Comparing model predictive performances

@@ -885,13 +863,13 @@

Comparing model predictive performances

First, we can compare models based on in-sample approximate leave-one-out cross-validation as implemented in the popular loo package:

-
loo_compare(mod0, mod1)
-#> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
-
-#> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
-#>      elpd_diff se_diff
-#> mod1  0.0       0.0   
-#> mod0 -2.3       1.6
+
loo_compare(mod0, mod1)
+#> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
+
+#> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
+#>      elpd_diff se_diff
+#> mod1  0.0       0.0   
+#> mod0 -6.5       2.7

The second model has the larger Expected Log Predictive Density (ELPD), meaning that it is slightly favoured over the simpler model that did not include the time-varying upwelling effect. However, the two @@ -906,30 +884,30 @@

Comparing model predictive performances

sampling to reweight posterior predictions, acting as a kind of particle filter so that we don’t need to refit the model too often (you can read more about how this process works in Bürkner et al. 2020).

-
lfo_mod0 <- lfo_cv(mod0, min_t = 30)
-lfo_mod1 <- lfo_cv(mod1, min_t = 30)
+
lfo_mod0 <- lfo_cv(mod0, min_t = 30)
+lfo_mod1 <- lfo_cv(mod1, min_t = 30)

The model with the time-varying upwelling effect tends to provides better 1-step ahead forecasts, with a higher total forecast ELPD

-
sum(lfo_mod0$elpds)
-#> [1] 35.11835
-sum(lfo_mod1$elpds)
-#> [1] 36.77461
+
sum(lfo_mod0$elpds)
+#> [1] 39.52656
+sum(lfo_mod1$elpds)
+#> [1] 40.81327

We can also plot the ELPDs for each model as a contrast. Here, values less than zero suggest the time-varying predictor model (Mod1) gives better 1-step ahead forecasts:

-
plot(x = 1:length(lfo_mod0$elpds) + 30,
-     y = lfo_mod0$elpds - lfo_mod1$elpds,
-     ylab = 'ELPDmod0 - ELPDmod1',
-     xlab = 'Evaluation time point',
-     pch = 16,
-     col = 'darkred',
-     bty = 'l')
-abline(h = 0, lty = 'dashed')
-

Comparing forecast skill for dynamic beta regression models in mvgam and R

+
plot(x = 1:length(lfo_mod0$elpds) + 30,
+     y = lfo_mod0$elpds - lfo_mod1$elpds,
+     ylab = 'ELPDmod0 - ELPDmod1',
+     xlab = 'Evaluation time point',
+     pch = 16,
+     col = 'darkred',
+     bty = 'l')
+abline(h = 0, lty = 'dashed')
+

Comparing forecast skill for dynamic beta regression models in mvgam and R

A useful exercise to further expand this model would be to think about what kinds of predictors might impact measurement error, which could easily be implemented into the observation formula in -mvgam. But for now, we will leave the model as-is.

+mvgam(). But for now, we will leave the model as-is.

diff --git a/doc/trend_formulas.R b/doc/trend_formulas.R index 4739e2e9..21ec225e 100644 --- a/doc/trend_formulas.R +++ b/doc/trend_formulas.R @@ -7,10 +7,11 @@ knitr::opts_chunk$set( eval = NOT_CRAN ) + ## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, - dpi = 150, + dpi = 100, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -19,12 +20,15 @@ library(mvgam) library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) + ## ----------------------------------------------------------------------------- load(url('https://github.com/atsa-es/MARSS/raw/master/data/lakeWAplankton.rda')) + ## ----------------------------------------------------------------------------- outcomes <- c('Greens', 'Bluegreens', 'Diatoms', 'Unicells', 'Other.algae') + ## ----------------------------------------------------------------------------- # loop across each plankton group to create the long datframe plankton_data <- do.call(rbind, lapply(outcomes, function(x){ @@ -52,20 +56,18 @@ plankton_data <- do.call(rbind, lapply(outcomes, function(x){ dplyr::mutate(time = dplyr::row_number()) %>% dplyr::ungroup() + ## ----------------------------------------------------------------------------- head(plankton_data) + ## ----------------------------------------------------------------------------- dplyr::glimpse(plankton_data) + ## ----------------------------------------------------------------------------- plot_mvgam_series(data = plankton_data, series = 'all') -## ----------------------------------------------------------------------------- -image(is.na(t(plankton_data)), axes = F, - col = c('grey80', 'darkred')) -axis(3, at = seq(0,1, len = NCOL(plankton_data)), - labels = colnames(plankton_data)) ## ----------------------------------------------------------------------------- plankton_data %>% @@ -80,6 +82,7 @@ plankton_data %>% xlab('Time') + ggtitle('Temperature (black) vs Other algae (red)') + ## ----------------------------------------------------------------------------- plankton_data %>% dplyr::filter(series == 'Diatoms') %>% @@ -93,18 +96,6 @@ plankton_data %>% xlab('Time') + ggtitle('Temperature (black) vs Diatoms (red)') -## ----------------------------------------------------------------------------- -plankton_data %>% - dplyr::filter(series == 'Greens') %>% - ggplot(aes(x = time, y = temp)) + - geom_line(size = 1.1) + - geom_line(aes(y = y), col = 'white', - size = 1.3) + - geom_line(aes(y = y), col = 'darkred', - size = 1.1) + - ylab('z-score') + - xlab('Time') + - ggtitle('Temperature (black) vs Greens (red)') ## ----------------------------------------------------------------------------- plankton_train <- plankton_data %>% @@ -112,6 +103,7 @@ plankton_train <- plankton_data %>% plankton_test <- plankton_data %>% dplyr::filter(time > 112) + ## ----notrend_mod, include = FALSE, results='hide'----------------------------- notrend_mod <- mvgam(y ~ te(temp, month, k = c(4, 4)) + @@ -121,67 +113,57 @@ notrend_mod <- mvgam(y ~ newdata = plankton_test, trend_model = 'None') + ## ----eval=FALSE--------------------------------------------------------------- -# notrend_mod <- mvgam(y ~ -# # tensor of temp and month to capture -# # "global" seasonality -# te(temp, month, k = c(4, 4)) + -# -# # series-specific deviation tensor products -# te(temp, month, k = c(4, 4), by = series), -# family = gaussian(), -# data = plankton_train, -# newdata = plankton_test, -# trend_model = 'None') -# +## notrend_mod <- mvgam(y ~ +## # tensor of temp and month to capture +## # "global" seasonality +## te(temp, month, k = c(4, 4)) + +## +## # series-specific deviation tensor products +## te(temp, month, k = c(4, 4), by = series), +## family = gaussian(), +## data = plankton_train, +## newdata = plankton_test, +## trend_model = 'None') +## + ## ----------------------------------------------------------------------------- plot_mvgam_smooth(notrend_mod, smooth = 1) -## ----------------------------------------------------------------------------- -plot_mvgam_smooth(notrend_mod, smooth = 2) ## ----------------------------------------------------------------------------- -plot_mvgam_smooth(notrend_mod, smooth = 3) +plot_mvgam_smooth(notrend_mod, smooth = 2) -## ----------------------------------------------------------------------------- -plot_mvgam_smooth(notrend_mod, smooth = 4) ## ----------------------------------------------------------------------------- -plot_mvgam_smooth(notrend_mod, smooth = 5) +plot_mvgam_smooth(notrend_mod, smooth = 3) -## ----------------------------------------------------------------------------- -plot_mvgam_smooth(notrend_mod, smooth = 6) ## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'forecast', series = 1) + ## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'forecast', series = 2) + ## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'forecast', series = 3) -## ----------------------------------------------------------------------------- -plot(notrend_mod, type = 'forecast', series = 4) - -## ----------------------------------------------------------------------------- -plot(notrend_mod, type = 'forecast', series = 5) ## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'residuals', series = 1) + ## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'residuals', series = 2) + ## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'residuals', series = 3) -## ----------------------------------------------------------------------------- -plot(notrend_mod, type = 'residuals', series = 4) - -## ----------------------------------------------------------------------------- -plot(notrend_mod, type = 'residuals', series = 5) ## ----------------------------------------------------------------------------- priors <- get_mvgam_priors( @@ -193,20 +175,24 @@ priors <- get_mvgam_priors( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train) + ## ----------------------------------------------------------------------------- priors[, 3] + ## ----------------------------------------------------------------------------- priors[, 4] + ## ----------------------------------------------------------------------------- priors <- c(prior(normal(0.5, 0.1), class = sigma_obs, lb = 0.2), prior(normal(0.5, 0.25), class = sigma)) + ## ----var_mod, include = FALSE, results='hide'--------------------------------- var_mod <- mvgam(y ~ -1, trend_formula = ~ @@ -219,36 +205,39 @@ var_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1', + trend_model = VAR(), priors = priors, + adapt_delta = 0.99, burnin = 1000) + ## ----eval=FALSE--------------------------------------------------------------- -# var_mod <- mvgam( -# # observation formula, which is empty -# y ~ -1, -# -# # process model formula, which includes the smooth functions -# trend_formula = ~ te(temp, month, k = c(4, 4)) + -# te(temp, month, k = c(4, 4), by = trend), -# -# # VAR1 model with uncorrelated process errors -# trend_model = 'VAR1', -# family = gaussian(), -# data = plankton_train, -# newdata = plankton_test, -# -# # include the updated priors -# priors = priors) +## var_mod <- mvgam( +## # observation formula, which is empty +## y ~ -1, +## +## # process model formula, which includes the smooth functions +## trend_formula = ~ te(temp, month, k = c(4, 4)) + +## te(temp, month, k = c(4, 4), by = trend), +## +## # VAR1 model with uncorrelated process errors +## trend_model = VAR(), +## family = gaussian(), +## data = plankton_train, +## newdata = plankton_test, +## +## # include the updated priors +## priors = priors, +## silent = 2) + ## ----------------------------------------------------------------------------- summary(var_mod, include_betas = FALSE) + ## ----------------------------------------------------------------------------- plot(var_mod, 'smooths', trend_effects = TRUE) -## ----warning=FALSE, message=FALSE--------------------------------------------- -mcmc_plot(var_mod, variable = 'A', regex = TRUE, type = 'hist') ## ----warning=FALSE, message=FALSE--------------------------------------------- A_pars <- matrix(NA, nrow = 5, ncol = 5) @@ -261,11 +250,6 @@ mcmc_plot(var_mod, variable = as.vector(t(A_pars)), type = 'hist') -## ----------------------------------------------------------------------------- -plot(var_mod, type = 'trend', series = 1) - -## ----------------------------------------------------------------------------- -plot(var_mod, type = 'trend', series = 3) ## ----warning=FALSE, message=FALSE--------------------------------------------- Sigma_pars <- matrix(NA, nrow = 5, ncol = 5) @@ -278,13 +262,16 @@ mcmc_plot(var_mod, variable = as.vector(t(Sigma_pars)), type = 'hist') + ## ----warning=FALSE, message=FALSE--------------------------------------------- mcmc_plot(var_mod, variable = 'sigma_obs', regex = TRUE, type = 'hist') + ## ----------------------------------------------------------------------------- priors <- c(prior(normal(0.5, 0.1), class = sigma_obs, lb = 0.2), prior(normal(0.5, 0.25), class = sigma)) + ## ----varcor_mod, include = FALSE, results='hide'------------------------------ varcor_mod <- mvgam(y ~ -1, trend_formula = ~ @@ -297,33 +284,31 @@ varcor_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), burnin = 1000, + adapt_delta = 0.99, priors = priors) + ## ----eval=FALSE--------------------------------------------------------------- -# varcor_mod <- mvgam( -# # observation formula, which remains empty -# y ~ -1, -# -# # process model formula, which includes the smooth functions -# trend_formula = ~ te(temp, month, k = c(4, 4)) + -# te(temp, month, k = c(4, 4), by = trend), -# -# # VAR1 model with correlated process errors -# trend_model = 'VAR1cor', -# family = gaussian(), -# data = plankton_train, -# newdata = plankton_test, -# -# # include the updated priors -# priors = priors) +## varcor_mod <- mvgam( +## # observation formula, which remains empty +## y ~ -1, +## +## # process model formula, which includes the smooth functions +## trend_formula = ~ te(temp, month, k = c(4, 4)) + +## te(temp, month, k = c(4, 4), by = trend), +## +## # VAR1 model with correlated process errors +## trend_model = VAR(cor = TRUE), +## family = gaussian(), +## data = plankton_train, +## newdata = plankton_test, +## +## # include the updated priors +## priors = priors, +## silent = 2) -## ----warning=FALSE, message=FALSE--------------------------------------------- -mcmc_plot(varcor_mod, type = 'rhat') + - labs(title = 'VAR1cor') -mcmc_plot(var_mod, type = 'rhat') + - labs(title = 'VAR1') ## ----warning=FALSE, message=FALSE--------------------------------------------- Sigma_pars <- matrix(NA, nrow = 5, ncol = 5) @@ -336,6 +321,7 @@ mcmc_plot(varcor_mod, variable = as.vector(t(Sigma_pars)), type = 'hist') + ## ----------------------------------------------------------------------------- Sigma_post <- as.matrix(varcor_mod, variable = 'Sigma', regex = TRUE) median_correlations <- cov2cor(matrix(apply(Sigma_post, 2, median), @@ -344,34 +330,6 @@ rownames(median_correlations) <- colnames(median_correlations) <- levels(plankto round(median_correlations, 2) -## ----warning=FALSE, message=FALSE--------------------------------------------- -A_pars <- matrix(NA, nrow = 5, ncol = 5) -for(i in 1:5){ - for(j in 1:5){ - A_pars[i, j] <- paste0('A[', i, ',', j, ']') - } -} -mcmc_plot(varcor_mod, - variable = as.vector(t(A_pars)), - type = 'hist') - -## ----------------------------------------------------------------------------- -plot(var_mod, type = 'forecast', series = 1, newdata = plankton_test) - -## ----------------------------------------------------------------------------- -plot(varcor_mod, type = 'forecast', series = 1, newdata = plankton_test) - -## ----------------------------------------------------------------------------- -plot(var_mod, type = 'forecast', series = 2, newdata = plankton_test) - -## ----------------------------------------------------------------------------- -plot(varcor_mod, type = 'forecast', series = 2, newdata = plankton_test) - -## ----------------------------------------------------------------------------- -plot(var_mod, type = 'forecast', series = 3, newdata = plankton_test) - -## ----------------------------------------------------------------------------- -plot(varcor_mod, type = 'forecast', series = 3, newdata = plankton_test) ## ----------------------------------------------------------------------------- # create forecast objects for each model @@ -389,6 +347,7 @@ plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', ylab = expression(variogram[VAR1cor]~-~variogram[VAR1])) abline(h = 0, lty = 'dashed') + ## ----------------------------------------------------------------------------- # plot the difference in energy scores; a negative value means the VAR1cor model is better, while a positive value means the VAR1 model is better diff_scores <- score(fcvarcor, score = 'energy')$all_series$score - diff --git a/doc/trend_formulas.Rmd b/doc/trend_formulas.Rmd index e65a4ce7..387a8708 100644 --- a/doc/trend_formulas.Rmd +++ b/doc/trend_formulas.Rmd @@ -23,7 +23,7 @@ knitr::opts_chunk$set( ```{r setup, include=FALSE} knitr::opts_chunk$set( echo = TRUE, - dpi = 150, + dpi = 100, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -97,14 +97,6 @@ Note that we have z-scored the counts in this example as that will make it easie plot_mvgam_series(data = plankton_data, series = 'all') ``` -It is always helpful to check the data for `NA`s before attempting any models: -```{r} -image(is.na(t(plankton_data)), axes = F, - col = c('grey80', 'darkred')) -axis(3, at = seq(0,1, len = NCOL(plankton_data)), - labels = colnames(plankton_data)) -``` - We have some missing observations, but this isn't an issue for modelling in `mvgam`. A useful property to understand about these counts is that they tend to be highly seasonal. Below are some plots of z-scored counts against the z-scored temperature measurements in the lake for each month: ```{r} plankton_data %>% @@ -135,20 +127,6 @@ plankton_data %>% ggtitle('Temperature (black) vs Diatoms (red)') ``` -```{r} -plankton_data %>% - dplyr::filter(series == 'Greens') %>% - ggplot(aes(x = time, y = temp)) + - geom_line(size = 1.1) + - geom_line(aes(y = y), col = 'white', - size = 1.3) + - geom_line(aes(y = y), col = 'darkred', - size = 1.1) + - ylab('z-score') + - xlab('Time') + - ggtitle('Temperature (black) vs Greens (red)') -``` - We will have to try and capture this seasonality in our process model, which should be easy to do given the flexibility of GAMs. Next we will split the data into training and testing splits: ```{r} plankton_train <- plankton_data %>% @@ -192,7 +170,7 @@ The "global" tensor product smooth function can be quickly visualized: plot_mvgam_smooth(notrend_mod, smooth = 1) ``` -On this plot, red indicates below-average linear predictors and white indicates above-average. We can then plot the deviation smooths for each algal group to see how they vary from the "global" pattern: +On this plot, red indicates below-average linear predictors and white indicates above-average. We can then plot the deviation smooths for a few algal groups to see how they vary from the "global" pattern: ```{r} plot_mvgam_smooth(notrend_mod, smooth = 2) ``` @@ -201,18 +179,6 @@ plot_mvgam_smooth(notrend_mod, smooth = 2) plot_mvgam_smooth(notrend_mod, smooth = 3) ``` -```{r} -plot_mvgam_smooth(notrend_mod, smooth = 4) -``` - -```{r} -plot_mvgam_smooth(notrend_mod, smooth = 5) -``` - -```{r} -plot_mvgam_smooth(notrend_mod, smooth = 6) -``` - These multidimensional smooths have done a good job of capturing the seasonal variation in our observations: ```{r} plot(notrend_mod, type = 'forecast', series = 1) @@ -226,15 +192,7 @@ plot(notrend_mod, type = 'forecast', series = 2) plot(notrend_mod, type = 'forecast', series = 3) ``` -```{r} -plot(notrend_mod, type = 'forecast', series = 4) -``` - -```{r} -plot(notrend_mod, type = 'forecast', series = 5) -``` - -This basic model gives us confidence that we can capture the seasonal variation in the observations. But the model has not captured the remaining temporal dynamics, which is obvious when we inspect Dunn-Smyth residuals for each series: +This basic model gives us confidence that we can capture the seasonal variation in the observations. But the model has not captured the remaining temporal dynamics, which is obvious when we inspect Dunn-Smyth residuals for a few series: ```{r} plot(notrend_mod, type = 'residuals', series = 1) ``` @@ -247,13 +205,6 @@ plot(notrend_mod, type = 'residuals', series = 2) plot(notrend_mod, type = 'residuals', series = 3) ``` -```{r} -plot(notrend_mod, type = 'residuals', series = 4) -``` - -```{r} -plot(notrend_mod, type = 'residuals', series = 5) -``` ### Multiseries dynamics Now it is time to get into multivariate State-Space models. We will fit two models that can both incorporate lagged cross-dependencies in the latent process models. The first model assumes that the process errors operate independently from one another, while the second assumes that there may be contemporaneous correlations in the process errors. Both models include a Vector Autoregressive component for the process means, and so both can model complex community dynamics. The models can be described mathematically as follows: @@ -280,7 +231,7 @@ priors <- get_mvgam_priors( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train) ``` @@ -314,8 +265,9 @@ var_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1', + trend_model = VAR(), priors = priors, + adapt_delta = 0.99, burnin = 1000) ``` @@ -329,13 +281,14 @@ var_mod <- mvgam( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train, newdata = plankton_test, # include the updated priors - priors = priors) + priors = priors, + silent = 2) ``` ### Inspecting SS models @@ -349,12 +302,7 @@ The convergence of this model isn't fabulous (more on this in a moment). But we plot(var_mod, 'smooths', trend_effects = TRUE) ``` -The VAR matrix is of particular interest here, as it captures lagged dependencies and cross-dependencies in the latent process model: -```{r warning=FALSE, message=FALSE} -mcmc_plot(var_mod, variable = 'A', regex = TRUE, type = 'hist') -``` - -Unfortunately `bayesplot` doesn't know this is a matrix of parameters so what we see is actually the transpose of the VAR matrix. A little bit of wrangling gives us these histograms in the correct order: +The VAR matrix is of particular interest here, as it captures lagged dependencies and cross-dependencies in the latent process model. Unfortunately `bayesplot` doesn't know this is a matrix of parameters so what we see is actually the transpose of the VAR matrix. A little bit of wrangling gives us these histograms in the correct order: ```{r warning=FALSE, message=FALSE} A_pars <- matrix(NA, nrow = 5, ncol = 5) for(i in 1:5){ @@ -367,15 +315,8 @@ mcmc_plot(var_mod, type = 'hist') ``` -There is a lot happening in this matrix. Each cell captures the lagged effect of the process in the column on the process in the row in the next timestep. So for example, the effect in cell [1,3], which is quite strongly negative, means that an *increase* in the process for series 3 (Greens) at time $t$ is expected to lead to a subsequent *decrease* in the process for series 1 (Bluegreens) at time $t+1$. The latent process model is now capturing these effects and the smooth seasonal effects, so the trend plot shows our best estimate of what the *true* count should have been at each time point: -```{r} -plot(var_mod, type = 'trend', series = 1) -``` - -```{r} -plot(var_mod, type = 'trend', series = 3) -``` - +There is a lot happening in this matrix. Each cell captures the lagged effect of the process in the column on the process in the row in the next timestep. So for example, the effect in cell [1,3] shows how an *increase* in the process for series 3 (Greens) at time $t$ is expected to impact the process for series 1 (Bluegreens) at time $t+1$. The latent process model is now capturing these effects and the smooth seasonal effects. + The process error $(\Sigma)$ captures unmodelled variation in the process models. Again, we fixed the off-diagonals to 0, so the histograms for these will look like flat boxes: ```{r warning=FALSE, message=FALSE} Sigma_pars <- matrix(NA, nrow = 5, ncol = 5) @@ -417,8 +358,9 @@ varcor_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), burnin = 1000, + adapt_delta = 0.99, priors = priors) ``` @@ -432,21 +374,14 @@ varcor_mod <- mvgam( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with correlated process errors - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), family = gaussian(), data = plankton_train, newdata = plankton_test, # include the updated priors - priors = priors) -``` - -Plot convergence diagnostics for the two models, which shows that both models display similar levels of convergence: -```{r warning=FALSE, message=FALSE} -mcmc_plot(varcor_mod, type = 'rhat') + - labs(title = 'VAR1cor') -mcmc_plot(var_mod, type = 'rhat') + - labs(title = 'VAR1') + priors = priors, + silent = 2) ``` The $(\Sigma)$ matrix now captures any evidence of contemporaneously correlated process error: @@ -462,7 +397,7 @@ mcmc_plot(varcor_mod, type = 'hist') ``` -This symmetric matrix tells us there is support for correlated process errors. For example, series 1 and 3 (Bluegreens and Greens) show negatively correlated process errors, while series 1 and 4 (Bluegreens and Other.algae) show positively correlated errors. But it is easier to interpret these estimates if we convert the covariance matrix to a correlation matrix. Here we compute the posterior median process error correlations: +This symmetric matrix tells us there is support for correlated process errors, as several of the off-diagonal entries are strongly non-zero. But it is easier to interpret these estimates if we convert the covariance matrix to a correlation matrix. Here we compute the posterior median process error correlations: ```{r} Sigma_post <- as.matrix(varcor_mod, variable = 'Sigma', regex = TRUE) median_correlations <- cov2cor(matrix(apply(Sigma_post, 2, median), @@ -472,45 +407,7 @@ rownames(median_correlations) <- colnames(median_correlations) <- levels(plankto round(median_correlations, 2) ``` -Because this model is able to capture correlated errors, the VAR matrix has changed slightly: -```{r warning=FALSE, message=FALSE} -A_pars <- matrix(NA, nrow = 5, ncol = 5) -for(i in 1:5){ - for(j in 1:5){ - A_pars[i, j] <- paste0('A[', i, ',', j, ']') - } -} -mcmc_plot(varcor_mod, - variable = as.vector(t(A_pars)), - type = 'hist') -``` - -We still have some evidence of lagged cross-dependence, but some of these interactions have now been pulled more toward zero. But which model is better? Forecasts don't appear to differ very much, at least qualitatively (here are forecasts for three of the series, for each model): -```{r} -plot(var_mod, type = 'forecast', series = 1, newdata = plankton_test) -``` - -```{r} -plot(varcor_mod, type = 'forecast', series = 1, newdata = plankton_test) -``` - -```{r} -plot(var_mod, type = 'forecast', series = 2, newdata = plankton_test) -``` - -```{r} -plot(varcor_mod, type = 'forecast', series = 2, newdata = plankton_test) -``` - -```{r} -plot(var_mod, type = 'forecast', series = 3, newdata = plankton_test) -``` - -```{r} -plot(varcor_mod, type = 'forecast', series = 3, newdata = plankton_test) -``` - -We can compute the variogram score for out of sample forecasts to get a sense of which model does a better job of capturing the dependence structure in the true evaluation set: +But which model is better? We can compute the variogram score for out of sample forecasts to get a sense of which model does a better job of capturing the dependence structure in the true evaluation set: ```{r} # create forecast objects for each model fcvar <- forecast(var_mod) @@ -551,7 +448,7 @@ Heaps, Sarah E. "[Enforcing stationarity through the prior in vector autoregress Hannaford, Naomi E., et al. "[A sparse Bayesian hierarchical vector autoregressive model for microbial dynamics in a wastewater treatment plant.](https://www.sciencedirect.com/science/article/pii/S0167947322002390)" *Computational Statistics & Data Analysis* 179 (2023): 107659. -Holmes, Elizabeth E., Eric J. Ward, and Wills Kellie. "[MARSS: multivariate autoregressive state-space models for analyzing time-series data.](https://d1wqtxts1xzle7.cloudfront.net/30588864/rjournal_2012-1_holmes_et_al-libre.pdf?1391843792=&response-content-disposition=inline%3B+filename%3DMARSS_Multivariate_Autoregressive_State.pdf&Expires=1695861526&Signature=TCRXULs0mUKRM4m1pmvZxwE10bUqS6vzLcuKeUBCj57YIjx23iTxS1fEgBpV0fs2wb5XAw7ZkG84XyMaoS~vjiqZ-DpheQDHwAHpIWG-TcckHQjEjPWTNajFvAemToUdCiHnDa~yrhW9HRgXjgncdalkjzjvjT3HLSW8mcjBDhQN-WJ3MKQFSXtxoBpWfcuPYbf-HC1E1oSl7957y~w0I1gcIVdu6LHjP~CEKXa0BQzS4xuarL2nz~tHD2MverbNJYMrDGrAxIi-MX6i~lfHWuwV6UKRdoOZ0pXIcMYWBTv9V5xYey76aMKTICiJ~0NqXLZdXO5qlS4~~2nFEO7b7w__&Key-Pair-Id=APKAJLOHF5GGSLRBV4ZA)" *R Journal*. 4.1 (2012): 11. +Holmes, Elizabeth E., Eric J. Ward, and Wills Kellie. "[MARSS: multivariate autoregressive state-space models for analyzing time-series data.](https://journal.r-project.org/archive/2012/RJ-2012-002/index.html)" *R Journal*. 4.1 (2012): 11. Ward, Eric J., et al. "[Inferring spatial structure from time‐series data: using multivariate state‐space models to detect metapopulation structure of California sea lions in the Gulf of California, Mexico.](https://besjournals.onlinelibrary.wiley.com/doi/full/10.1111/j.1365-2664.2009.01745.x)" *Journal of Applied Ecology* 47.1 (2010): 47-56. diff --git a/doc/trend_formulas.html b/doc/trend_formulas.html index e6e67bc0..5e2a8efc 100644 --- a/doc/trend_formulas.html +++ b/doc/trend_formulas.html @@ -12,7 +12,7 @@ - + State-Space models in mvgam @@ -340,7 +340,7 @@

State-Space models in mvgam

Nicholas J Clark

-

2024-04-16

+

2024-07-01

@@ -453,21 +453,31 @@

Lake Washington plankton data

necessary; it is often better to build a model that respects the properties of the actual outcome variables)

plot_mvgam_series(data = plankton_data, series = 'all')
-

-

It is always helpful to check the data for NAs before -attempting any models:

-
image(is.na(t(plankton_data)), axes = F,
-      col = c('grey80', 'darkred'))
-axis(3, at = seq(0,1, len = NCOL(plankton_data)), 
-     labels = colnames(plankton_data))
-

+

We have some missing observations, but this isn’t an issue for modelling in mvgam. A useful property to understand about these counts is that they tend to be highly seasonal. Below are some plots of z-scored counts against the z-scored temperature measurements in the lake for each month:

+
plankton_data %>%
+  dplyr::filter(series == 'Other.algae') %>%
+  ggplot(aes(x = time, y = temp)) +
+  geom_line(size = 1.1) +
+  geom_line(aes(y = y), col = 'white',
+            size = 1.3) +
+  geom_line(aes(y = y), col = 'darkred',
+            size = 1.1) +
+  ylab('z-score') +
+  xlab('Time') +
+  ggtitle('Temperature (black) vs Other algae (red)')
+#> Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
+#> ℹ Please use `linewidth` instead.
+#> This warning is displayed once every 8 hours.
+#> Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
+#> generated.
+

plankton_data %>%
-  dplyr::filter(series == 'Other.algae') %>%
+  dplyr::filter(series == 'Diatoms') %>%
   ggplot(aes(x = time, y = temp)) +
   geom_line(size = 1.1) +
   geom_line(aes(y = y), col = 'white',
@@ -476,44 +486,15 @@ 
Lake Washington plankton data

             size = 1.1) +
   ylab('z-score') +
   xlab('Time') +
-  ggtitle('Temperature (black) vs Other algae (red)')
-#> Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
-#> ℹ Please use `linewidth` instead.
-#> This warning is displayed once every 8 hours.
-#> Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
-#> generated.
-

-
plankton_data %>%
-  dplyr::filter(series == 'Diatoms') %>%
-  ggplot(aes(x = time, y = temp)) +
-  geom_line(size = 1.1) +
-  geom_line(aes(y = y), col = 'white',
-            size = 1.3) +
-  geom_line(aes(y = y), col = 'darkred',
-            size = 1.1) +
-  ylab('z-score') +
-  xlab('Time') +
-  ggtitle('Temperature (black) vs Diatoms (red)')
-

-
plankton_data %>%
-  dplyr::filter(series == 'Greens') %>%
-  ggplot(aes(x = time, y = temp)) +
-  geom_line(size = 1.1) +
-  geom_line(aes(y = y), col = 'white',
-            size = 1.3) +
-  geom_line(aes(y = y), col = 'darkred',
-            size = 1.1) +
-  ylab('z-score') +
-  xlab('Time') +
-  ggtitle('Temperature (black) vs Greens (red)')
-

+ ggtitle('Temperature (black) vs Diatoms (red)')
+

We will have to try and capture this seasonality in our process model, which should be easy to do given the flexibility of GAMs. Next we will split the data into training and testing splits:

-
plankton_train <- plankton_data %>%
-  dplyr::filter(time <= 112)
-plankton_test <- plankton_data %>%
-  dplyr::filter(time > 112)
+
plankton_train <- plankton_data %>%
+  dplyr::filter(time <= 112)
+plankton_test <- plankton_data %>%
+  dplyr::filter(time > 112)

Now time to fit some models. This requires a bit of thinking about how we can best tackle the seasonal variation and the likely dependence structure in the data. These algae are interacting as part of a complex @@ -541,70 +522,52 @@

Capturing seasonality

overall “global” seasonality. Note that we do not include series-specific intercepts in this model because each series was z-scored to have a mean of 0.

-
notrend_mod <- mvgam(y ~ 
-                       # tensor of temp and month to capture
-                       # "global" seasonality
-                       te(temp, month, k = c(4, 4)) +
-                       
-                       # series-specific deviation tensor products
-                       te(temp, month, k = c(4, 4), by = series),
-                     family = gaussian(),
-                     data = plankton_train,
-                     newdata = plankton_test,
-                     trend_model = 'None')
+
notrend_mod <- mvgam(y ~ 
+                       # tensor of temp and month to capture
+                       # "global" seasonality
+                       te(temp, month, k = c(4, 4)) +
+                       
+                       # series-specific deviation tensor products
+                       te(temp, month, k = c(4, 4), by = series),
+                     family = gaussian(),
+                     data = plankton_train,
+                     newdata = plankton_test,
+                     trend_model = 'None')

The “global” tensor product smooth function can be quickly visualized:

-
plot_mvgam_smooth(notrend_mod, smooth = 1)
-

+
plot_mvgam_smooth(notrend_mod, smooth = 1)
+

On this plot, red indicates below-average linear predictors and white -indicates above-average. We can then plot the deviation smooths for each -algal group to see how they vary from the “global” pattern:

-
plot_mvgam_smooth(notrend_mod, smooth = 2)
-

-
plot_mvgam_smooth(notrend_mod, smooth = 3)
-

-
plot_mvgam_smooth(notrend_mod, smooth = 4)
-

-
plot_mvgam_smooth(notrend_mod, smooth = 5)
-

-
plot_mvgam_smooth(notrend_mod, smooth = 6)
-

+indicates above-average. We can then plot the deviation smooths for a +few algal groups to see how they vary from the “global” pattern:

+
plot_mvgam_smooth(notrend_mod, smooth = 2)
+

+
plot_mvgam_smooth(notrend_mod, smooth = 3)
+

These multidimensional smooths have done a good job of capturing the seasonal variation in our observations:

-
plot(notrend_mod, type = 'forecast', series = 1)
-

-
#> Out of sample CRPS:
-#> [1] 6.795543
-
plot(notrend_mod, type = 'forecast', series = 2)
-

-
#> Out of sample CRPS:
-#> [1] 6.841293
-
plot(notrend_mod, type = 'forecast', series = 3)
-

-
#> Out of sample CRPS:
-#> [1] 4.109977
-
plot(notrend_mod, type = 'forecast', series = 4)
-

-
#> Out of sample CRPS:
-#> [1] 3.533645
-
plot(notrend_mod, type = 'forecast', series = 5)
-

-
#> Out of sample CRPS:
-#> [1] 2.859834
+
plot(notrend_mod, type = 'forecast', series = 1)
+#> Out of sample CRPS:
+#> 6.77172874237756
+

+
plot(notrend_mod, type = 'forecast', series = 2)
+#> Out of sample CRPS:
+#> 6.75657325046048
+

+
plot(notrend_mod, type = 'forecast', series = 3)
+#> Out of sample CRPS:
+#> 4.09992574037549
+

This basic model gives us confidence that we can capture the seasonal variation in the observations. But the model has not captured the remaining temporal dynamics, which is obvious when we inspect Dunn-Smyth -residuals for each series:

-
plot(notrend_mod, type = 'residuals', series = 1)
-

-
plot(notrend_mod, type = 'residuals', series = 2)
-

-
plot(notrend_mod, type = 'residuals', series = 3)
-

-
plot(notrend_mod, type = 'residuals', series = 4)
-

-
plot(notrend_mod, type = 'residuals', series = 5)
-

+residuals for a few series:

+
plot(notrend_mod, type = 'residuals', series = 1)
+

+
plot(notrend_mod, type = 'residuals', series = 2)
+

+
plot(notrend_mod, type = 'residuals', series = 3)
+

Multiseries dynamics

@@ -667,52 +630,52 @@

Multiseries dynamics

So let’s update the priors for these parameters. In doing so, you will get to see how the formula for the latent process (i.e. trend) model is used in mvgam:

-
priors <- get_mvgam_priors(
-  # observation formula, which has no terms in it
-  y ~ -1,
-  
-  # process model formula, which includes the smooth functions
-  trend_formula = ~ te(temp, month, k = c(4, 4)) +
-    te(temp, month, k = c(4, 4), by = trend),
-  
-  # VAR1 model with uncorrelated process errors
-  trend_model = 'VAR1',
-  family = gaussian(),
-  data = plankton_train)
+
priors <- get_mvgam_priors(
+  # observation formula, which has no terms in it
+  y ~ -1,
+  
+  # process model formula, which includes the smooth functions
+  trend_formula = ~ te(temp, month, k = c(4, 4)) +
+    te(temp, month, k = c(4, 4), by = trend),
+  
+  # VAR1 model with uncorrelated process errors
+  trend_model = VAR(),
+  family = gaussian(),
+  data = plankton_train)

Get names of all parameters whose priors can be modified:

-
priors[, 3]
-#>  [1] "(Intercept)"                                                                                                                                                                                                                                                           
-#>  [2] "process error sd"                                                                                                                                                                                                                                                      
-#>  [3] "diagonal autocorrelation population mean"                                                                                                                                                                                                                              
-#>  [4] "off-diagonal autocorrelation population mean"                                                                                                                                                                                                                          
-#>  [5] "diagonal autocorrelation population variance"                                                                                                                                                                                                                          
-#>  [6] "off-diagonal autocorrelation population variance"                                                                                                                                                                                                                      
-#>  [7] "shape1 for diagonal autocorrelation precision"                                                                                                                                                                                                                         
-#>  [8] "shape1 for off-diagonal autocorrelation precision"                                                                                                                                                                                                                     
-#>  [9] "shape2 for diagonal autocorrelation precision"                                                                                                                                                                                                                         
-#> [10] "shape2 for off-diagonal autocorrelation precision"                                                                                                                                                                                                                     
-#> [11] "observation error sd"                                                                                                                                                                                                                                                  
-#> [12] "te(temp,month) smooth parameters, te(temp,month):trendtrend1 smooth parameters, te(temp,month):trendtrend2 smooth parameters, te(temp,month):trendtrend3 smooth parameters, te(temp,month):trendtrend4 smooth parameters, te(temp,month):trendtrend5 smooth parameters"
+
priors[, 3]
+#>  [1] "(Intercept)"                                                                                                                                                                                                                                                           
+#>  [2] "process error sd"                                                                                                                                                                                                                                                      
+#>  [3] "diagonal autocorrelation population mean"                                                                                                                                                                                                                              
+#>  [4] "off-diagonal autocorrelation population mean"                                                                                                                                                                                                                          
+#>  [5] "diagonal autocorrelation population variance"                                                                                                                                                                                                                          
+#>  [6] "off-diagonal autocorrelation population variance"                                                                                                                                                                                                                      
+#>  [7] "shape1 for diagonal autocorrelation precision"                                                                                                                                                                                                                         
+#>  [8] "shape1 for off-diagonal autocorrelation precision"                                                                                                                                                                                                                     
+#>  [9] "shape2 for diagonal autocorrelation precision"                                                                                                                                                                                                                         
+#> [10] "shape2 for off-diagonal autocorrelation precision"                                                                                                                                                                                                                     
+#> [11] "observation error sd"                                                                                                                                                                                                                                                  
+#> [12] "te(temp,month) smooth parameters, te(temp,month):trendtrend1 smooth parameters, te(temp,month):trendtrend2 smooth parameters, te(temp,month):trendtrend3 smooth parameters, te(temp,month):trendtrend4 smooth parameters, te(temp,month):trendtrend5 smooth parameters"

And their default prior distributions:

-
priors[, 4]
-#>  [1] "(Intercept) ~ student_t(3, -0.1, 2.5);"
-#>  [2] "sigma ~ student_t(3, 0, 2.5);"         
-#>  [3] "es[1] = 0;"                            
-#>  [4] "es[2] = 0;"                            
-#>  [5] "fs[1] = sqrt(0.455);"                  
-#>  [6] "fs[2] = sqrt(0.455);"                  
-#>  [7] "gs[1] = 1.365;"                        
-#>  [8] "gs[2] = 1.365;"                        
-#>  [9] "hs[1] = 0.071175;"                     
-#> [10] "hs[2] = 0.071175;"                     
-#> [11] "sigma_obs ~ student_t(3, 0, 2.5);"     
-#> [12] "lambda_trend ~ normal(5, 30);"
+
priors[, 4]
+#>  [1] "(Intercept) ~ student_t(3, -0.1, 2.5);"
+#>  [2] "sigma ~ student_t(3, 0, 2.5);"         
+#>  [3] "es[1] = 0;"                            
+#>  [4] "es[2] = 0;"                            
+#>  [5] "fs[1] = sqrt(0.455);"                  
+#>  [6] "fs[2] = sqrt(0.455);"                  
+#>  [7] "gs[1] = 1.365;"                        
+#>  [8] "gs[2] = 1.365;"                        
+#>  [9] "hs[1] = 0.071175;"                     
+#> [10] "hs[2] = 0.071175;"                     
+#> [11] "sigma_obs ~ student_t(3, 0, 2.5);"     
+#> [12] "lambda_trend ~ normal(5, 30);"

Setting priors is easy in mvgam as you can use brms routines. Here we use more informative Normal priors for both error components, but we impose a lower bound of 0.2 for the observation errors:

-
priors <- c(prior(normal(0.5, 0.1), class = sigma_obs, lb = 0.2),
-            prior(normal(0.5, 0.25), class = sigma))
+
priors <- c(prior(normal(0.5, 0.1), class = sigma_obs, lb = 0.2),
+            prior(normal(0.5, 0.25), class = sigma))

You may have noticed something else unique about this model: there is no intercept term in the observation formula. This is because a shared intercept parameter can sometimes be unidentifiable with respect to the @@ -722,22 +685,23 @@

Multiseries dynamics

this parameter. mvgam accomplishes this by fixing the coefficient for the intercept to zero. Now we can fit the first model, which assumes that process errors are contemporaneously uncorrelated

-
var_mod <- mvgam(  
-  # observation formula, which is empty
-  y ~ -1,
-  
-  # process model formula, which includes the smooth functions
-  trend_formula = ~ te(temp, month, k = c(4, 4)) +
-    te(temp, month, k = c(4, 4), by = trend),
-  
-  # VAR1 model with uncorrelated process errors
-  trend_model = 'VAR1',
-  family = gaussian(),
-  data = plankton_train,
-  newdata = plankton_test,
-  
-  # include the updated priors
-  priors = priors)
+
var_mod <- mvgam(  
+  # observation formula, which is empty
+  y ~ -1,
+  
+  # process model formula, which includes the smooth functions
+  trend_formula = ~ te(temp, month, k = c(4, 4)) +
+    te(temp, month, k = c(4, 4), by = trend),
+  
+  # VAR1 model with uncorrelated process errors
+  trend_model = VAR(),
+  family = gaussian(),
+  data = plankton_train,
+  newdata = plankton_test,
+  
+  # include the updated priors
+  priors = priors,
+  silent = 2)

Inspecting SS models

@@ -752,187 +716,177 @@

Inspecting SS models

include_betas = FALSE to stop the summary from printing output for all of the spline coefficients, which can be dense and hard to interpret:

-
summary(var_mod, include_betas = FALSE)
-#> GAM observation formula:
-#> y ~ 1
-#> 
-#> GAM process formula:
-#> ~te(temp, month, k = c(4, 4)) + te(temp, month, k = c(4, 4), 
-#>     by = trend)
-#> 
-#> Family:
-#> gaussian
-#> 
-#> Link function:
-#> identity
-#> 
-#> Trend model:
-#> VAR1
-#> 
-#> N process models:
-#> 5 
-#> 
-#> N series:
-#> 5 
-#> 
-#> N timepoints:
-#> 112 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1500; warmup = 1000; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> Observation error parameter estimates:
-#>              2.5%  50% 97.5% Rhat n_eff
-#> sigma_obs[1] 0.21 0.26  0.35 1.01   376
-#> sigma_obs[2] 0.24 0.39  0.53 1.03   152
-#> sigma_obs[3] 0.43 0.64  0.83 1.10    43
-#> sigma_obs[4] 0.24 0.38  0.50 1.01   219
-#> sigma_obs[5] 0.29 0.42  0.54 1.03   173
-#> 
-#> GAM observation model coefficient (beta) estimates:
-#>             2.5% 50% 97.5% Rhat n_eff
-#> (Intercept)    0   0     0  NaN   NaN
-#> 
-#> Process model VAR parameter estimates:
-#>          2.5%    50% 97.5% Rhat n_eff
-#> A[1,1] -0.055  0.480 0.900 1.07    64
-#> A[1,2] -0.370 -0.039 0.210 1.01   295
-#> A[1,3] -0.500 -0.053 0.330 1.01   188
-#> A[1,4] -0.270  0.023 0.410 1.01   488
-#> A[1,5] -0.092  0.140 0.580 1.04   135
-#> A[2,1] -0.170  0.012 0.270 1.00   514
-#> A[2,2]  0.610  0.800 0.920 1.01   231
-#> A[2,3] -0.390 -0.120 0.048 1.01   223
-#> A[2,4] -0.044  0.100 0.340 1.01   241
-#> A[2,5] -0.063  0.061 0.210 1.01   371
-#> A[3,1] -0.300  0.014 0.820 1.06    54
-#> A[3,2] -0.540 -0.210 0.016 1.02   137
-#> A[3,3]  0.072  0.410 0.700 1.02   221
-#> A[3,4] -0.015  0.230 0.650 1.01   151
-#> A[3,5] -0.073  0.130 0.420 1.02   139
-#> A[4,1] -0.160  0.065 0.560 1.04    83
-#> A[4,2] -0.130  0.058 0.260 1.03   165
-#> A[4,3] -0.440 -0.120 0.120 1.03   143
-#> A[4,4]  0.480  0.730 0.960 1.03   144
-#> A[4,5] -0.230 -0.035 0.130 1.02   426
-#> A[5,1] -0.230  0.082 0.900 1.06    56
-#> A[5,2] -0.420 -0.120 0.079 1.02   128
-#> A[5,3] -0.650 -0.200 0.120 1.03    90
-#> A[5,4] -0.061  0.180 0.580 1.01   153
-#> A[5,5]  0.510  0.740 0.980 1.02   156
-#> 
-#> Process error parameter estimates:
-#>             2.5%  50% 97.5% Rhat n_eff
-#> Sigma[1,1] 0.019 0.28  0.65 1.11    32
-#> Sigma[1,2] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[1,3] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[1,4] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[1,5] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[2,1] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[2,2] 0.063 0.11  0.18 1.01   371
-#> Sigma[2,3] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[2,4] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[2,5] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[3,1] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[3,2] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[3,3] 0.056 0.16  0.31 1.03   106
-#> Sigma[3,4] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[3,5] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[4,1] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[4,2] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[4,3] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[4,4] 0.048 0.14  0.27 1.03   111
-#> Sigma[4,5] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[5,1] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[5,2] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[5,3] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[5,4] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[5,5] 0.098 0.20  0.36 1.02   131
-#> 
-#> Approximate significance of GAM process smooths:
-#>                              edf Ref.df    F p-value
-#> te(temp,month)              3.93     15 2.73    0.25
-#> te(temp,month):seriestrend1 1.22     15 0.16    1.00
-#> te(temp,month):seriestrend2 1.25     15 0.48    1.00
-#> te(temp,month):seriestrend3 3.98     15 3.53    0.24
-#> te(temp,month):seriestrend4 1.60     15 1.02    0.95
-#> te(temp,month):seriestrend5 1.97     15 0.32    1.00
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhats above 1.05 found for 24 parameters
-#>  *Diagnose further to investigate why the chains have not mixed
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> Chain 1: E-FMI = 0.179
-#> Chain 3: E-FMI = 0.1616
-#> Chain 4: E-FMI = 0.1994
-#>  *E-FMI below 0.2 indicates you may need to reparameterize your model
-#> 
-#> Samples were drawn using NUTS(diag_e) at Tue Apr 16 1:19:23 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
+
summary(var_mod, include_betas = FALSE)
+#> GAM observation formula:
+#> y ~ 1
+#> <environment: 0x00000241693f91f0>
+#> 
+#> GAM process formula:
+#> ~te(temp, month, k = c(4, 4)) + te(temp, month, k = c(4, 4), 
+#>     by = trend)
+#> <environment: 0x00000241693f91f0>
+#> 
+#> Family:
+#> gaussian
+#> 
+#> Link function:
+#> identity
+#> 
+#> Trend model:
+#> VAR()
+#> 
+#> N process models:
+#> 5 
+#> 
+#> N series:
+#> 5 
+#> 
+#> N timepoints:
+#> 120 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1500; warmup = 1000; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> Observation error parameter estimates:
+#>              2.5%  50% 97.5% Rhat n_eff
+#> sigma_obs[1] 0.20 0.25  0.34 1.01   508
+#> sigma_obs[2] 0.27 0.40  0.54 1.03   179
+#> sigma_obs[3] 0.43 0.64  0.82 1.13    20
+#> sigma_obs[4] 0.25 0.37  0.50 1.00   378
+#> sigma_obs[5] 0.30 0.43  0.54 1.03   229
+#> 
+#> GAM observation model coefficient (beta) estimates:
+#>             2.5% 50% 97.5% Rhat n_eff
+#> (Intercept)    0   0     0  NaN   NaN
+#> 
+#> Process model VAR parameter estimates:
+#>          2.5%    50% 97.5% Rhat n_eff
+#> A[1,1]  0.038  0.520 0.870 1.08    32
+#> A[1,2] -0.350 -0.030 0.200 1.00   497
+#> A[1,3] -0.530 -0.044 0.330 1.02   261
+#> A[1,4] -0.280  0.038 0.420 1.00   392
+#> A[1,5] -0.100  0.120 0.510 1.04   141
+#> A[2,1] -0.160  0.011 0.200 1.00  1043
+#> A[2,2]  0.620  0.790 0.910 1.01   418
+#> A[2,3] -0.400 -0.130 0.045 1.03   291
+#> A[2,4] -0.034  0.110 0.360 1.02   274
+#> A[2,5] -0.048  0.061 0.200 1.01   585
+#> A[3,1] -0.260  0.025 0.560 1.10    28
+#> A[3,2] -0.530 -0.200 0.027 1.02   167
+#> A[3,3]  0.069  0.430 0.740 1.01   256
+#> A[3,4] -0.022  0.230 0.660 1.02   162
+#> A[3,5] -0.094  0.120 0.390 1.02   208
+#> A[4,1] -0.150  0.058 0.360 1.03   137
+#> A[4,2] -0.110  0.063 0.270 1.01   360
+#> A[4,3] -0.430 -0.110 0.140 1.01   312
+#> A[4,4]  0.470  0.730 0.950 1.02   278
+#> A[4,5] -0.200 -0.036 0.130 1.01   548
+#> A[5,1] -0.190  0.083 0.650 1.08    41
+#> A[5,2] -0.460 -0.120 0.076 1.04   135
+#> A[5,3] -0.620 -0.180 0.130 1.04   153
+#> A[5,4] -0.062  0.190 0.660 1.04   140
+#> A[5,5]  0.510  0.740 0.930 1.00   437
+#> 
+#> Process error parameter estimates:
+#>             2.5%  50% 97.5% Rhat n_eff
+#> Sigma[1,1] 0.033 0.27  0.64 1.20     9
+#> Sigma[1,2] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[1,3] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[1,4] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[1,5] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[2,1] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[2,2] 0.066 0.12  0.18 1.01   541
+#> Sigma[2,3] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[2,4] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[2,5] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[3,1] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[3,2] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[3,3] 0.051 0.16  0.29 1.04   163
+#> Sigma[3,4] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[3,5] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[4,1] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[4,2] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[4,3] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[4,4] 0.054 0.14  0.28 1.03   182
+#> Sigma[4,5] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[5,1] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[5,2] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[5,3] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[5,4] 0.000 0.00  0.00  NaN   NaN
+#> Sigma[5,5] 0.100 0.21  0.35 1.01   343
+#> 
+#> Approximate significance of GAM process smooths:
+#>                               edf Ref.df Chi.sq p-value
+#> te(temp,month)              2.902     15  43.54    0.44
+#> te(temp,month):seriestrend1 2.001     15   1.66    1.00
+#> te(temp,month):seriestrend2 0.943     15   7.03    1.00
+#> te(temp,month):seriestrend3 5.867     15  45.04    0.21
+#> te(temp,month):seriestrend4 2.984     15   9.12    0.98
+#> te(temp,month):seriestrend5 1.986     15   4.66    1.00
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhats above 1.05 found for 33 parameters
+#>  *Diagnose further to investigate why the chains have not mixed
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:43:45 AM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

The convergence of this model isn’t fabulous (more on this in a moment). But we can again plot the smooth functions, which this time operate on the process model. We can see the same plot using trend_effects = TRUE in the plotting functions:

-
plot(var_mod, 'smooths', trend_effects = TRUE)
-

+
plot(var_mod, 'smooths', trend_effects = TRUE)
+

The VAR matrix is of particular interest here, as it captures lagged -dependencies and cross-dependencies in the latent process model:

-
mcmc_plot(var_mod, variable = 'A', regex = TRUE, type = 'hist')
-

-

Unfortunately bayesplot doesn’t know this is a matrix of +dependencies and cross-dependencies in the latent process model. +Unfortunately bayesplot doesn’t know this is a matrix of parameters so what we see is actually the transpose of the VAR matrix. A little bit of wrangling gives us these histograms in the correct order:

-
A_pars <- matrix(NA, nrow = 5, ncol = 5)
-for(i in 1:5){
-  for(j in 1:5){
-    A_pars[i, j] <- paste0('A[', i, ',', j, ']')
-  }
-}
-mcmc_plot(var_mod, 
-          variable = as.vector(t(A_pars)), 
-          type = 'hist')
-

+
A_pars <- matrix(NA, nrow = 5, ncol = 5)
+for(i in 1:5){
+  for(j in 1:5){
+    A_pars[i, j] <- paste0('A[', i, ',', j, ']')
+  }
+}
+mcmc_plot(var_mod, 
+          variable = as.vector(t(A_pars)), 
+          type = 'hist')
+

There is a lot happening in this matrix. Each cell captures the lagged effect of the process in the column on the process in the row in -the next timestep. So for example, the effect in cell [1,3], which is -quite strongly negative, means that an increase in the process -for series 3 (Greens) at time \(t\) is -expected to lead to a subsequent decrease in the process for +the next timestep. So for example, the effect in cell [1,3] shows how an +increase in the process for series 3 (Greens) at time \(t\) is expected to impact the process for series 1 (Bluegreens) at time \(t+1\). The latent process model is now capturing these effects and the smooth -seasonal effects, so the trend plot shows our best estimate of what the -true count should have been at each time point:

-
plot(var_mod, type = 'trend', series = 1)
-

-
plot(var_mod, type = 'trend', series = 3)
-

+seasonal effects.

The process error \((\Sigma)\) captures unmodelled variation in the process models. Again, we fixed the off-diagonals to 0, so the histograms for these will look like flat boxes:

-
Sigma_pars <- matrix(NA, nrow = 5, ncol = 5)
-for(i in 1:5){
-  for(j in 1:5){
-    Sigma_pars[i, j] <- paste0('Sigma[', i, ',', j, ']')
-  }
-}
-mcmc_plot(var_mod, 
-          variable = as.vector(t(Sigma_pars)), 
-          type = 'hist')
-

+
Sigma_pars <- matrix(NA, nrow = 5, ncol = 5)
+for(i in 1:5){
+  for(j in 1:5){
+    Sigma_pars[i, j] <- paste0('Sigma[', i, ',', j, ']')
+  }
+}
+mcmc_plot(var_mod, 
+          variable = as.vector(t(Sigma_pars)), 
+          type = 'hist')
+

The observation error estimates \((\sigma_{obs})\) represent how much the model thinks we might miss the true count when we take our imperfect measurements:

-
mcmc_plot(var_mod, variable = 'sigma_obs', regex = TRUE, type = 'hist')
-

+
mcmc_plot(var_mod, variable = 'sigma_obs', regex = TRUE, type = 'hist')
+

These are still a bit hard to identify overall, especially when trying to estimate both process and observation error. Often we need to make some strong assumptions about which of these is more important for @@ -943,137 +897,87 @@

Correlated process errors

Let’s see if these estimates improve when we allow the process errors to be correlated. Once again, we need to first update the priors for the observation errors:

-
priors <- c(prior(normal(0.5, 0.1), class = sigma_obs, lb = 0.2),
-            prior(normal(0.5, 0.25), class = sigma))
+
priors <- c(prior(normal(0.5, 0.1), class = sigma_obs, lb = 0.2),
+            prior(normal(0.5, 0.25), class = sigma))

And now we can fit the correlated process error model

-
varcor_mod <- mvgam(  
-  # observation formula, which remains empty
-  y ~ -1,
-  
-  # process model formula, which includes the smooth functions
-  trend_formula = ~ te(temp, month, k = c(4, 4)) +
-    te(temp, month, k = c(4, 4), by = trend),
-  
-  # VAR1 model with correlated process errors
-  trend_model = 'VAR1cor',
-  family = gaussian(),
-  data = plankton_train,
-  newdata = plankton_test,
-  
-  # include the updated priors
-  priors = priors)
-

Plot convergence diagnostics for the two models, which shows that -both models display similar levels of convergence:

-
mcmc_plot(varcor_mod, type = 'rhat') +
-  labs(title = 'VAR1cor')
-

-
mcmc_plot(var_mod, type = 'rhat') +
-  labs(title = 'VAR1')
-

+
varcor_mod <- mvgam(  
+  # observation formula, which remains empty
+  y ~ -1,
+  
+  # process model formula, which includes the smooth functions
+  trend_formula = ~ te(temp, month, k = c(4, 4)) +
+    te(temp, month, k = c(4, 4), by = trend),
+  
+  # VAR1 model with correlated process errors
+  trend_model = VAR(cor = TRUE),
+  family = gaussian(),
+  data = plankton_train,
+  newdata = plankton_test,
+  
+  # include the updated priors
+  priors = priors,
+  silent = 2)

The \((\Sigma)\) matrix now captures any evidence of contemporaneously correlated process error:

-
Sigma_pars <- matrix(NA, nrow = 5, ncol = 5)
-for(i in 1:5){
-  for(j in 1:5){
-    Sigma_pars[i, j] <- paste0('Sigma[', i, ',', j, ']')
-  }
-}
-mcmc_plot(varcor_mod, 
-          variable = as.vector(t(Sigma_pars)), 
-          type = 'hist')
-

+
Sigma_pars <- matrix(NA, nrow = 5, ncol = 5)
+for(i in 1:5){
+  for(j in 1:5){
+    Sigma_pars[i, j] <- paste0('Sigma[', i, ',', j, ']')
+  }
+}
+mcmc_plot(varcor_mod, 
+          variable = as.vector(t(Sigma_pars)), 
+          type = 'hist')
+

This symmetric matrix tells us there is support for correlated -process errors. For example, series 1 and 3 (Bluegreens and Greens) show -negatively correlated process errors, while series 1 and 4 (Bluegreens -and Other.algae) show positively correlated errors. But it is easier to -interpret these estimates if we convert the covariance matrix to a -correlation matrix. Here we compute the posterior median process error -correlations:

-
Sigma_post <- as.matrix(varcor_mod, variable = 'Sigma', regex = TRUE)
-median_correlations <- cov2cor(matrix(apply(Sigma_post, 2, median),
-                                      nrow = 5, ncol = 5))
-rownames(median_correlations) <- colnames(median_correlations) <- levels(plankton_train$series)
-
-round(median_correlations, 2)
-#>             Bluegreens Diatoms Greens Other.algae Unicells
-#> Bluegreens        1.00   -0.03   0.15       -0.05     0.32
-#> Diatoms          -0.03    1.00  -0.20        0.48     0.17
-#> Greens            0.15   -0.20   1.00        0.18     0.46
-#> Other.algae      -0.05    0.48   0.18        1.00     0.28
-#> Unicells          0.32    0.17   0.46        0.28     1.00
-

Because this model is able to capture correlated errors, the VAR -matrix has changed slightly:

-
A_pars <- matrix(NA, nrow = 5, ncol = 5)
-for(i in 1:5){
-  for(j in 1:5){
-    A_pars[i, j] <- paste0('A[', i, ',', j, ']')
-  }
-}
-mcmc_plot(varcor_mod, 
-          variable = as.vector(t(A_pars)), 
-          type = 'hist')
-

-

We still have some evidence of lagged cross-dependence, but some of -these interactions have now been pulled more toward zero. But which -model is better? Forecasts don’t appear to differ very much, at least -qualitatively (here are forecasts for three of the series, for each -model):

-
plot(var_mod, type = 'forecast', series = 1, newdata = plankton_test)
-

-
#> Out of sample CRPS:
-#> [1] 2.954187
-
plot(varcor_mod, type = 'forecast', series = 1, newdata = plankton_test)
-

-
#> Out of sample CRPS:
-#> [1] 3.114382
-
plot(var_mod, type = 'forecast', series = 2, newdata = plankton_test)
-

-
#> Out of sample CRPS:
-#> [1] 5.827133
-
plot(varcor_mod, type = 'forecast', series = 2, newdata = plankton_test)
-

-
#> Out of sample CRPS:
-#> [1] 5.503073
-
plot(var_mod, type = 'forecast', series = 3, newdata = plankton_test)
-

-
#> Out of sample CRPS:
-#> [1] 4.04051
-
plot(varcor_mod, type = 'forecast', series = 3, newdata = plankton_test)
-

-
#> Out of sample CRPS:
-#> [1] 4.007712
-

We can compute the variogram score for out of sample forecasts to get -a sense of which model does a better job of capturing the dependence -structure in the true evaluation set:

-
# create forecast objects for each model
-fcvar <- forecast(var_mod)
-fcvarcor <- forecast(varcor_mod)
-
-# plot the difference in variogram scores; a negative value means the VAR1cor model is better, while a positive value means the VAR1 model is better
-diff_scores <- score(fcvarcor, score = 'variogram')$all_series$score -
-  score(fcvar, score = 'variogram')$all_series$score
-plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
-     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
-              max(abs(diff_scores), na.rm = TRUE)),
-     bty = 'l',
-     xlab = 'Forecast horizon',
-     ylab = expression(variogram[VAR1cor]~-~variogram[VAR1]))
-abline(h = 0, lty = 'dashed')
-

+process errors, as several of the off-diagonal entries are strongly +non-zero. But it is easier to interpret these estimates if we convert +the covariance matrix to a correlation matrix. Here we compute the +posterior median process error correlations:

+
Sigma_post <- as.matrix(varcor_mod, variable = 'Sigma', regex = TRUE)
+median_correlations <- cov2cor(matrix(apply(Sigma_post, 2, median),
+                                      nrow = 5, ncol = 5))
+rownames(median_correlations) <- colnames(median_correlations) <- levels(plankton_train$series)
+
+round(median_correlations, 2)
+#>             Bluegreens Diatoms Greens Other.algae Unicells
+#> Bluegreens        1.00   -0.04   0.16       -0.05     0.29
+#> Diatoms          -0.04    1.00  -0.21        0.48     0.17
+#> Greens            0.16   -0.21   1.00        0.17     0.46
+#> Other.algae      -0.05    0.48   0.17        1.00     0.28
+#> Unicells          0.29    0.17   0.46        0.28     1.00
+

But which model is better? We can compute the variogram score for out +of sample forecasts to get a sense of which model does a better job of +capturing the dependence structure in the true evaluation set:

+
# create forecast objects for each model
+fcvar <- forecast(var_mod)
+fcvarcor <- forecast(varcor_mod)
+
+# plot the difference in variogram scores; a negative value means the VAR1cor model is better, while a positive value means the VAR1 model is better
+diff_scores <- score(fcvarcor, score = 'variogram')$all_series$score -
+  score(fcvar, score = 'variogram')$all_series$score
+plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
+     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
+              max(abs(diff_scores), na.rm = TRUE)),
+     bty = 'l',
+     xlab = 'Forecast horizon',
+     ylab = expression(variogram[VAR1cor]~-~variogram[VAR1]))
+abline(h = 0, lty = 'dashed')
+

And we can also compute the energy score for out of sample forecasts to get a sense of which model provides forecasts that are better calibrated:

-
# plot the difference in energy scores; a negative value means the VAR1cor model is better, while a positive value means the VAR1 model is better
-diff_scores <- score(fcvarcor, score = 'energy')$all_series$score -
-  score(fcvar, score = 'energy')$all_series$score
-plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
-     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
-              max(abs(diff_scores), na.rm = TRUE)),
-     bty = 'l',
-     xlab = 'Forecast horizon',
-     ylab = expression(energy[VAR1cor]~-~energy[VAR1]))
-abline(h = 0, lty = 'dashed')
-

+
# plot the difference in energy scores; a negative value means the VAR1cor model is better, while a positive value means the VAR1 model is better
+diff_scores <- score(fcvarcor, score = 'energy')$all_series$score -
+  score(fcvar, score = 'energy')$all_series$score
+plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', 
+     ylim = c(-1*max(abs(diff_scores), na.rm = TRUE),
+              max(abs(diff_scores), na.rm = TRUE)),
+     bty = 'l',
+     xlab = 'Forecast horizon',
+     ylab = expression(energy[VAR1cor]~-~energy[VAR1]))
+abline(h = 0, lty = 'dashed')
+

The models tend to provide similar forecasts, though the correlated error model does slightly better overall. We would probably need to use a more extensive rolling forecast evaluation exercise if we felt like we @@ -1094,7 +998,7 @@

Further reading

sparse Bayesian hierarchical vector autoregressive model for microbial dynamics in a wastewater treatment plant.” Computational Statistics & Data Analysis 179 (2023): 107659.

-

Holmes, Elizabeth E., Eric J. Ward, and Wills Kellie. “MARSS: +

Holmes, Elizabeth E., Eric J. Ward, and Wills Kellie. “MARSS: multivariate autoregressive state-space models for analyzing time-series data.” R Journal. 4.1 (2012): 11.

Ward, Eric J., et al. “Inferring diff --git a/docs/articles/forecast_evaluation.html b/docs/articles/forecast_evaluation.html index d774976e..804ac365 100644 --- a/docs/articles/forecast_evaluation.html +++ b/docs/articles/forecast_evaluation.html @@ -26,7 +26,7 @@ mvgam - 1.0.91 + 1.1.2

+ +
  • + Changelog

    • Covariates with no NAs

    levels = 'series1'), time = 1:10) miss_dat -#> outcome cov series time -#> 1 -0.3926197 NA series1 1 -#> 2 -0.1127277 1.3171518 series1 2 -#> 3 -1.5022493 -0.5112159 series1 3 -#> 4 1.2718119 -1.5898549 series1 4 -#> 5 0.3792046 -1.5860549 series1 5 -#> 6 1.0253017 -1.4026850 series1 6 -#> 7 -1.1546050 -0.6485981 series1 7 -#> 8 -0.1498811 -0.7392203 series1 8 -#> 9 2.0924367 0.5155418 series1 9 -#> 10 -0.5269962 -1.2443386 series1 10 +#> outcome cov series time +#> 1 0.77436859 NA series1 1 +#> 2 0.33222199 -0.2653819 series1 2 +#> 3 0.50385503 0.6658354 series1 3 +#> 4 -0.99577591 0.3541730 series1 4 +#> 5 -1.09812817 -2.3125954 series1 5 +#> 6 -0.49687774 -1.0778578 series1 6 +#> 7 -1.26666072 -0.1973507 series1 7 +#> 8 -0.11638041 -3.0585179 series1 8 +#> 9 0.08890432 1.7964928 series1 9 +#> 10 -0.64375459 0.7894733 series1 10 
    get_mvgam_priors(outcome ~ cov,
                  data = miss_dat,
                  family = gaussian())
 #> Error: Missing values found in data predictors:
-#>  Error in na.fail.default(structure(list(outcome = c(-0.392619741341104, : missing values in object
    +#> Error in na.fail.default(structure(list(outcome = c(0.774368589907313, : missing values in object

    Just like with the mgcv package, mvgam can also accept data as a list object. This is useful if you want to set up linear @@ -781,7 +779,7 @@

    Covariates with no NAs

    data = miss_dat, family = gaussian()) #> Error: Missing values found in data predictors: -#> Error in na.fail.default(structure(list(outcome = c(-0.494366970739628, : missing values in object +#> Error in na.fail.default(structure(list(outcome = c(-0.708736388395862, : missing values in object
    @@ -797,20 +795,20 @@

    Plotting with plot_mvgam_series

    plot_mvgam_series(data = simdat$data_train, 
                   y = 'y', 
                   series = 'all')
    -

    Plotting time series features for GAM models in mvgam

    +

    Plotting time series features for GAM models in mvgam

    Or we can look more closely at the distribution for the first time series:

    plot_mvgam_series(data = simdat$data_train, 
                   y = 'y', 
                   series = 1)
    -

    Plotting time series features for GAM models in mvgam

    +

    Plotting time series features for GAM models in mvgam

    If you have split your data into training and testing folds (i.e. for forecast evaluation), you can include the test data in your plots:

    plot_mvgam_series(data = simdat$data_train,
                   newdata = simdat$data_test,
                   y = 'y', 
                   series = 1)
    -

    Plotting time series features for GAM models in mvgam

    +

    Plotting time series features for GAM models in mvgam

    Example with NEON tick data

    @@ -967,12 +965,12 @@

    Example with NEON tick data

    #> $ S6 : num [1:8, 1:8] 1.037 -0.416 0.419 0.117 0.188 ... #> $ S7 : num [1:8, 1:8] 1.037 -0.416 0.419 0.117 0.188 ... #> $ S8 : num [1:8, 1:8] 1.037 -0.416 0.419 0.117 0.188 ... -#> $ p_coefs : Named num 0.775 +#> $ p_coefs : Named num 0.806 #> ..- attr(*, "names")= chr "(Intercept)" -#> $ p_taus : num 3285 +#> $ p_taus : num 301 #> $ ytimes : int [1:416, 1:8] 1 9 17 25 33 41 49 57 65 73 ... #> $ n_series : int 8 -#> $ sp : Named num [1:9] 5.46 8 28.79 5 2.65 ... +#> $ sp : Named num [1:9] 4.68 59.57 1.11 2.73 6.5 ... #> ..- attr(*, "names")= chr [1:9] "s(epiWeek):seriesBLAN_005" "s(epiWeek):seriesBLAN_012" "s(epiWeek):seriesSCBI_002" "s(epiWeek):seriesSCBI_013" ... #> $ y_observed : num [1:416, 1:8] 0 0 0 0 0 0 0 0 0 0 ... #> $ total_obs : int 3328 diff --git a/inst/doc/forecast_evaluation.R b/inst/doc/forecast_evaluation.R index 5515579a..8412f550 100644 --- a/inst/doc/forecast_evaluation.R +++ b/inst/doc/forecast_evaluation.R @@ -1,4 +1,4 @@ -## ----echo = FALSE------------------------------------------------------ +## ----echo = FALSE------------------------------------------------------------- NOT_CRAN <- identical(tolower(Sys.getenv("NOT_CRAN")), "true") knitr::opts_chunk$set( collapse = TRUE, @@ -8,7 +8,7 @@ knitr::opts_chunk$set( ) -## ----setup, include=FALSE---------------------------------------------- +## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, dpi = 100, @@ -21,32 +21,32 @@ library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- set.seed(2345) simdat <- sim_mvgam(T = 100, n_series = 3, - trend_model = 'GP', + trend_model = GP(), prop_trend = 0.75, family = poisson(), prop_missing = 0.10) -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- str(simdat) -## ----fig.alt = "Plotting time series features for GAM models in mvgam"---- +## ----fig.alt = "Plotting time series features for GAM models in mvgam"-------- plot_mvgam_series(data = simdat$data_train, series = 'all') -## ----fig.alt = "Plotting time series features for GAM models in mvgam"---- +## ----fig.alt = "Plotting time series features for GAM models in mvgam"-------- plot_mvgam_series(data = simdat$data_train, newdata = simdat$data_test, series = 1) -## ----include=FALSE----------------------------------------------------- +## ----include=FALSE------------------------------------------------------------ mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + s(time, by = series, bs = 'cr', k = 20), knots = list(season = c(0.5, 12.5)), @@ -54,71 +54,70 @@ mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + data = simdat$data_train) -## ----eval=FALSE-------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + ## s(time, by = series, bs = 'cr', k = 20), ## knots = list(season = c(0.5, 12.5)), ## trend_model = 'None', -## data = simdat$data_train) +## data = simdat$data_train, +## silent = 2) -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(mod1, include_betas = FALSE) -## ----fig.alt = "Plotting GAM smooth functions using mvgam"------------- -plot(mod1, type = 'smooths') +## ----fig.alt = "Plotting GAM smooth functions using mvgam"-------------------- +conditional_effects(mod1, type = 'link') -## ----include=FALSE----------------------------------------------------- +## ----include=FALSE------------------------------------------------------------ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + gp(time, by = series, c = 5/4, k = 20, scale = FALSE), knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) -## ----eval=FALSE-------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + ## gp(time, by = series, c = 5/4, k = 20, ## scale = FALSE), ## knots = list(season = c(0.5, 12.5)), ## trend_model = 'None', -## data = simdat$data_train) +## data = simdat$data_train, +## silent = 2) -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(mod2, include_betas = FALSE) -## ----fig.alt = "Summarising latent Gaussian Process parameters in mvgam"---- +## ----fig.alt = "Summarising latent Gaussian Process parameters in mvgam"------ mcmc_plot(mod2, variable = c('alpha_gp'), regex = TRUE, type = 'areas') -## ----fig.alt = "Summarising latent Gaussian Process parameters in mvgam"---- +## ----fig.alt = "Summarising latent Gaussian Process parameters in mvgam"------ mcmc_plot(mod2, variable = c('rho_gp'), regex = TRUE, type = 'areas') -## ----fig.alt = "Summarising latent Gaussian Process parameters in mvgam and marginaleffects"---- -require('ggplot2') -plot_predictions(mod2, - condition = c('time', 'series', 'series'), - type = 'link') + - theme(legend.position = 'none') +## ----fig.alt = "Plotting latent Gaussian Process effects in mvgam and marginaleffects"---- +conditional_effects(mod2, type = 'link') -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- fc_mod1 <- forecast(mod1, newdata = simdat$data_test) fc_mod2 <- forecast(mod2, newdata = simdat$data_test) -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- str(fc_mod1) -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(fc_mod1, series = 1) plot(fc_mod2, series = 1) @@ -126,7 +125,7 @@ plot(fc_mod1, series = 2) plot(fc_mod2, series = 2) -## ----include=FALSE----------------------------------------------------- +## ----include=FALSE------------------------------------------------------------ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + gp(time, by = series, c = 5/4, k = 20, scale = FALSE), @@ -134,20 +133,22 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + trend_model = 'None', data = simdat$data_train, newdata = simdat$data_test, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) -## ----eval=FALSE-------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + ## gp(time, by = series, c = 5/4, k = 20, ## scale = FALSE), ## knots = list(season = c(0.5, 12.5)), ## trend_model = 'None', ## data = simdat$data_train, -## newdata = simdat$data_test) +## newdata = simdat$data_test, +## silent = 2) -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- fc_mod2 <- forecast(mod2) @@ -155,32 +156,32 @@ fc_mod2 <- forecast(mod2) plot(fc_mod2, series = 1) -## ----warning=FALSE----------------------------------------------------- +## ----warning=FALSE------------------------------------------------------------ crps_mod1 <- score(fc_mod1, score = 'crps') str(crps_mod1) crps_mod1$series_1 -## ----warning=FALSE----------------------------------------------------- +## ----warning=FALSE------------------------------------------------------------ crps_mod1 <- score(fc_mod1, score = 'crps', interval_width = 0.6) crps_mod1$series_1 -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- link_mod1 <- forecast(mod1, newdata = simdat$data_test, type = 'link') score(link_mod1, score = 'elpd')$series_1 -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- energy_mod2 <- score(fc_mod2, score = 'energy') str(energy_mod2) -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- energy_mod2$all_series -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- crps_mod1 <- score(fc_mod1, score = 'crps') crps_mod2 <- score(fc_mod2, score = 'crps') diff --git a/inst/doc/forecast_evaluation.Rmd b/inst/doc/forecast_evaluation.Rmd index 8b6a9ec5..8979593d 100644 --- a/inst/doc/forecast_evaluation.Rmd +++ b/inst/doc/forecast_evaluation.Rmd @@ -36,12 +36,12 @@ theme_set(theme_bw(base_size = 12, base_family = 'serif')) The purpose of this vignette is to show how the `mvgam` package can be used to produce probabilistic forecasts and to evaluate those forecasts using a variety of proper scoring rules. ## Simulating discrete time series -We begin by simulating some data to show how forecasts are computed and evaluated in `mvgam`. The `sim_mvgam()` function can be used to simulate series that come from a variety of response distributions as well as seasonal patterns and/or dynamic temporal patterns. Here we simulate a collection of three time count-valued series. These series all share the same seasonal pattern but have different temporal dynamics. By setting `trend_model = 'GP'` and `prop_trend = 0.75`, we are generating time series that have smooth underlying temporal trends (evolving as Gaussian Processes with squared exponential kernel) and moderate seasonal patterns. The observations are Poisson-distributed and we allow 10% of observations to be missing. +We begin by simulating some data to show how forecasts are computed and evaluated in `mvgam`. The `sim_mvgam()` function can be used to simulate series that come from a variety of response distributions as well as seasonal patterns and/or dynamic temporal patterns. Here we simulate a collection of three time count-valued series. These series all share the same seasonal pattern but have different temporal dynamics. By setting `trend_model = GP()` and `prop_trend = 0.75`, we are generating time series that have smooth underlying temporal trends (evolving as Gaussian Processes with squared exponential kernel) and moderate seasonal patterns. The observations are Poisson-distributed and we allow 10% of observations to be missing. ```{r} set.seed(2345) simdat <- sim_mvgam(T = 100, n_series = 3, - trend_model = 'GP', + trend_model = GP(), prop_trend = 0.75, family = poisson(), prop_missing = 0.10) @@ -80,7 +80,8 @@ mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + s(time, by = series, bs = 'cr', k = 20), knots = list(season = c(0.5, 12.5)), trend_model = 'None', - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The model fits without issue: @@ -88,9 +89,9 @@ The model fits without issue: summary(mod1, include_betas = FALSE) ``` -And we can plot the partial effects of the splines to see that they are estimated to be highly nonlinear +And we can plot the conditional effects of the splines (on the link scale) to see that they are estimated to be highly nonlinear ```{r, fig.alt = "Plotting GAM smooth functions using mvgam"} -plot(mod1, type = 'smooths') +conditional_effects(mod1, type = 'link') ``` ### Modelling dynamics with GPs @@ -102,7 +103,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) ``` ```{r eval=FALSE} @@ -111,7 +113,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + scale = FALSE), knots = list(season = c(0.5, 12.5)), trend_model = 'None', - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The summary for this model now contains information on the GP parameters for each time series: @@ -129,13 +132,9 @@ And now the length scale ($\rho$) parameters: mcmc_plot(mod2, variable = c('rho_gp'), regex = TRUE, type = 'areas') ``` -We can also plot the nonlinear effects using `marginaleffects` utilities: -```{r, fig.alt = "Summarising latent Gaussian Process parameters in mvgam and marginaleffects"} -require('ggplot2') -plot_predictions(mod2, - condition = c('time', 'series', 'series'), - type = 'link') + - theme(legend.position = 'none') +We can again plot the nonlinear effects: +```{r, fig.alt = "Plotting latent Gaussian Process effects in mvgam and marginaleffects"} +conditional_effects(mod2, type = 'link') ``` The estimates for the temporal trends are fairly similar for the two models, but below we will see if they produce similar forecasts @@ -173,7 +172,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + trend_model = 'None', data = simdat$data_train, newdata = simdat$data_test, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) ``` ```{r eval=FALSE} @@ -183,7 +183,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - newdata = simdat$data_test) + newdata = simdat$data_test, + silent = 2) ``` Because the model already contains a forecast distribution, we do not need to feed `newdata` to the `forecast()` function: diff --git a/inst/doc/forecast_evaluation.html b/inst/doc/forecast_evaluation.html index 9058b21d..ae761ae5 100644 --- a/inst/doc/forecast_evaluation.html +++ b/inst/doc/forecast_evaluation.html @@ -12,7 +12,7 @@ - + Forecasting and forecast evaluation in mvgam @@ -341,7 +341,7 @@

    Forecasting and forecast evaluation in mvgam

    Nicholas J Clark

    -

    2024-05-09

    +

    2024-07-01

    @@ -378,7 +378,7 @@

    Simulating discrete time series

    temporal patterns. Here we simulate a collection of three time count-valued series. These series all share the same seasonal pattern but have different temporal dynamics. By setting -trend_model = 'GP' and prop_trend = 0.75, we +trend_model = GP() and prop_trend = 0.75, we are generating time series that have smooth underlying temporal trends (evolving as Gaussian Processes with squared exponential kernel) and moderate seasonal patterns. The observations are Poisson-distributed and @@ -386,7 +386,7 @@

    Simulating discrete time series

    set.seed(2345)
 simdat <- sim_mvgam(T = 100, 
                     n_series = 3, 
-                    trend_model = 'GP',
+                    trend_model = GP(),
                     prop_trend = 0.75,
                     family = poisson(),
                     prop_missing = 0.10)
    @@ -425,7 +425,7 @@

    Simulating discrete time series

    plot_mvgam_series(data = simdat$data_train, 
                   newdata = simdat$data_test,
                   series = 1)
    -

    Plotting time series features for GAM models in mvgam

    +

    Plotting time series features for GAM models in mvgam

    Modelling dynamics with splines

    The first model we will fit uses a shared cyclic spline to capture @@ -437,13 +437,14 @@

    Modelling dynamics with splines

    s(time, by = series, bs = 'cr', k = 20), knots = list(season = c(0.5, 12.5)), trend_model = 'None', - data = simdat$data_train)
    + data = simdat$data_train, + silent = 2)

    The model fits without issue:

    summary(mod1, include_betas = FALSE)
 #> GAM formula:
 #> y ~ s(season, bs = "cc", k = 8) + s(time, by = series, bs = "cr", 
 #>     k = 20)
-#> <environment: 0x000001ba309013f0>
+#> <environment: 0x000001b67206d110>
 #> 
 #> Family:
 #> poisson
@@ -468,14 +469,14 @@ 
    Modelling dynamics with splines
    
 #> 
 #> GAM coefficient (beta) estimates:
 #>              2.5%   50%  97.5% Rhat n_eff
-#> (Intercept) -0.41 -0.21 -0.039    1   813
+#> (Intercept) -0.41 -0.21 -0.052    1   855
 #> 
 #> Approximate significance of GAM smooths:
-#>                         edf Ref.df Chi.sq p-value    
-#> s(season)              3.77      6   21.9  0.0039 ** 
-#> s(time):seriesseries_1 6.50     19   14.6  0.8790    
-#> s(time):seriesseries_2 9.49     19  228.9  <2e-16 ***
-#> s(time):seriesseries_3 5.93     19   18.9  0.8515    
+#>                         edf Ref.df Chi.sq p-value   
+#> s(season)              3.82      6   19.6  0.0037 **
+#> s(time):seriesseries_1 7.25     19   13.2  0.7969   
+#> s(time):seriesseries_2 9.81     19  173.3  0.0019 **
+#> s(time):seriesseries_3 6.05     19   19.4  0.7931   
 #> ---
 #> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
 #> 
@@ -486,14 +487,14 @@ 
    Modelling dynamics with splines
    
 #> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
 #> E-FMI indicated no pathological behavior
 #> 
-#> Samples were drawn using NUTS(diag_e) at Thu May 09 6:54:44 PM 2024.
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:26:51 AM 2024.
 #> For each parameter, n_eff is a crude measure of effective sample size,
 #> and Rhat is the potential scale reduction factor on split MCMC chains
 #> (at convergence, Rhat = 1)
    -

    And we can plot the partial effects of the splines to see that they -are estimated to be highly nonlinear

    -
    plot(mod1, type = 'smooths')
    -

    Plotting GAM smooth functions using mvgam

    +

    And we can plot the conditional effects of the splines (on the link +scale) to see that they are estimated to be highly nonlinear

    +
    conditional_effects(mod1, type = 'link')
    +

    Plotting GAM smooth functions using mvgamPlotting GAM smooth functions using mvgam

    Modelling dynamics with GPs

    @@ -508,14 +509,15 @@

    Modelling dynamics with GPs

    scale = FALSE), knots = list(season = c(0.5, 12.5)), trend_model = 'None', - data = simdat$data_train)
    + data = simdat$data_train, + silent = 2)

    The summary for this model now contains information on the GP parameters for each time series:

    summary(mod2, include_betas = FALSE)
 #> GAM formula:
 #> y ~ s(season, bs = "cc", k = 8) + gp(time, by = series, c = 5/4, 
 #>     k = 20, scale = FALSE)
-#> <environment: 0x000001ba309013f0>
+#> <environment: 0x000001b67206d110>
 #> 
 #> Family:
 #> poisson
@@ -540,32 +542,32 @@ 
    Modelling dynamics with GPs
    
 #> 
 #> GAM coefficient (beta) estimates:
 #>             2.5%   50% 97.5% Rhat n_eff
-#> (Intercept) -1.1 -0.52  0.31    1   768
+#> (Intercept) -1.1 -0.51  0.34    1   694
 #> 
 #> GAM gp term marginal deviation (alpha) and length scale (rho) estimates:
-#>                               2.5%  50% 97.5% Rhat n_eff
-#> alpha_gp(time):seriesseries_1 0.21  0.8   2.1 1.01   763
-#> alpha_gp(time):seriesseries_2 0.74  1.4   2.9 1.00  1028
-#> alpha_gp(time):seriesseries_3 0.50  1.1   2.8 1.00  1026
-#> rho_gp(time):seriesseries_1   1.20  5.1  23.0 1.00   681
-#> rho_gp(time):seriesseries_2   2.20 10.0  17.0 1.00   644
-#> rho_gp(time):seriesseries_3   1.50  8.8  23.0 1.00   819
+#>                               2.5%   50% 97.5% Rhat n_eff
+#> alpha_gp(time):seriesseries_1 0.21  0.78   2.2    1   819
+#> alpha_gp(time):seriesseries_2 0.73  1.30   2.9    1   761
+#> alpha_gp(time):seriesseries_3 0.46  1.10   2.8    1  1262
+#> rho_gp(time):seriesseries_1   1.30  5.40  22.0    1   682
+#> rho_gp(time):seriesseries_2   2.10 10.00  17.0    1   450
+#> rho_gp(time):seriesseries_3   1.50  8.80  24.0    1   769
 #> 
 #> Approximate significance of GAM smooths:
-#>            edf Ref.df Chi.sq p-value    
-#> s(season) 4.12      6   25.9 0.00052 ***
+#>            edf Ref.df Chi.sq p-value   
+#> s(season) 3.36      6   21.1  0.0093 **
 #> ---
 #> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
 #> 
 #> Stan MCMC diagnostics:
 #> n_eff / iter looks reasonable for all parameters
 #> Rhat looks reasonable for all parameters
-#> 4 of 2000 iterations ended with a divergence (0.2%)
+#> 1 of 2000 iterations ended with a divergence (0.05%)
 #>  *Try running with larger adapt_delta to remove the divergences
 #> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
 #> E-FMI indicated no pathological behavior
 #> 
-#> Samples were drawn using NUTS(diag_e) at Thu May 09 6:55:28 PM 2024.
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:27:28 AM 2024.
 #> For each parameter, n_eff is a crude measure of effective sample size,
 #> and Rhat is the potential scale reduction factor on split MCMC chains
 #> (at convergence, Rhat = 1)
    @@ -574,19 +576,14 @@

    Modelling dynamics with GPs

    the marginal deviation (\(\alpha\)) parameters:

    mcmc_plot(mod2, variable = c('alpha_gp'), regex = TRUE, type = 'areas')
    -

    Summarising latent Gaussian Process parameters in mvgam

    +

    Summarising latent Gaussian Process parameters in mvgam

    And now the length scale (\(\rho\)) parameters:

    mcmc_plot(mod2, variable = c('rho_gp'), regex = TRUE, type = 'areas')
    -

    Summarising latent Gaussian Process parameters in mvgam

    -

    We can also plot the nonlinear effects using -marginaleffects utilities:

    -
    require('ggplot2')
-plot_predictions(mod2, 
-                 condition = c('time', 'series', 'series'),
-                 type = 'link') +
-  theme(legend.position = 'none')
    -

    Summarising latent Gaussian Process parameters in mvgam and marginaleffects

    +

    Summarising latent Gaussian Process parameters in mvgam

    +

    We can again plot the nonlinear effects:

    +
    conditional_effects(mod2, type = 'link')
    +

    Plotting latent Gaussian Process effects in mvgam and marginaleffectsPlotting latent Gaussian Process effects in mvgam and marginaleffects

    The estimates for the temporal trends are fairly similar for the two models, but below we will see if they produce similar forecasts

    @@ -617,7 +614,7 @@

    Forecasting with the forecast() function

    str(fc_mod1)
 #> List of 16
 #>  $ call              :Class 'formula'  language y ~ s(season, bs = "cc", k = 8) + s(time, by = series, bs = "cr", k = 20)
-#>   .. ..- attr(*, ".Environment")=<environment: 0x000001ba309013f0> 
+#>   .. ..- attr(*, ".Environment")=<environment: 0x000001b67206d110> 
 #>  $ trend_call        : NULL
 #>  $ family            : chr "poisson"
 #>  $ family_pars       : NULL
@@ -638,42 +635,42 @@ 
    Forecasting with the forecast() function
    
 #>   ..$ series_3: int [1:25] 1 0 0 1 0 0 1 0 1 0 ...
 #>  $ test_times        : int [1:25] 76 77 78 79 80 81 82 83 84 85 ...
 #>  $ hindcasts         :List of 3
-#>   ..$ series_1: num [1:2000, 1:75] 1 1 0 0 0 1 1 1 0 0 ...
+#>   ..$ series_1: num [1:2000, 1:75] 1 1 0 0 0 0 0 0 0 0 ...
 #>   .. ..- attr(*, "dimnames")=List of 2
 #>   .. .. ..$ : NULL
 #>   .. .. ..$ : chr [1:75] "ypred[1,1]" "ypred[2,1]" "ypred[3,1]" "ypred[4,1]" ...
-#>   ..$ series_2: num [1:2000, 1:75] 0 0 0 0 0 0 0 1 0 0 ...
+#>   ..$ series_2: num [1:2000, 1:75] 0 0 0 0 0 0 0 0 0 0 ...
 #>   .. ..- attr(*, "dimnames")=List of 2
 #>   .. .. ..$ : NULL
 #>   .. .. ..$ : chr [1:75] "ypred[1,2]" "ypred[2,2]" "ypred[3,2]" "ypred[4,2]" ...
-#>   ..$ series_3: num [1:2000, 1:75] 3 0 2 1 0 1 2 1 5 1 ...
+#>   ..$ series_3: num [1:2000, 1:75] 1 4 0 4 4 1 1 6 3 1 ...
 #>   .. ..- attr(*, "dimnames")=List of 2
 #>   .. .. ..$ : NULL
 #>   .. .. ..$ : chr [1:75] "ypred[1,3]" "ypred[2,3]" "ypred[3,3]" "ypred[4,3]" ...
 #>  $ forecasts         :List of 3
-#>   ..$ series_1: num [1:2000, 1:25] 1 3 2 1 0 0 1 1 0 0 ...
-#>   ..$ series_2: num [1:2000, 1:25] 6 0 0 0 0 2 0 0 0 0 ...
-#>   ..$ series_3: num [1:2000, 1:25] 0 1 1 3 3 1 3 2 4 2 ...
+#>   ..$ series_1: num [1:2000, 1:25] 0 1 0 0 0 1 1 0 0 3 ...
+#>   ..$ series_2: num [1:2000, 1:25] 0 2 0 1 0 2 1 0 1 0 ...
+#>   ..$ series_3: num [1:2000, 1:25] 1 8 4 2 2 1 2 0 2 0 ...
 #>  - attr(*, "class")= chr "mvgam_forecast"

    We can plot the forecasts for some series from each model using the S3 plot method for objects of this class:

    plot(fc_mod1, series = 1)
 #> Out of sample CRPS:
-#> 14.6296405
    -

    +#> 14.89051875 +

    plot(fc_mod2, series = 1)
 #> Out of sample DRPS:
-#> 10.92516425
    -

    +#> 10.84228725 +

    
 plot(fc_mod1, series = 2)
 #> Out of sample CRPS:
-#> 84201962707.6125
    -

    +#> 495050222726067 +

    plot(fc_mod2, series = 2)
-#> Out of sample DRPS:
-#> 14.311523
    -

    +#> Out of sample CRPS: +#> 14.7121945 +

    Clearly the two models do not produce equivalent forecasts. We will come back to scoring these forecasts in a moment.

    @@ -693,7 +690,8 @@

    Forecasting with newdata in mvgam()

    knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - newdata = simdat$data_test) + newdata = simdat$data_test, + silent = 2)

    Because the model already contains a forecast distribution, we do not need to feed newdata to the forecast() function:

    @@ -702,8 +700,8 @@

    Forecasting with newdata in mvgam()

    previously:

    plot(fc_mod2, series = 1)
 #> Out of sample DRPS:
-#> 10.8576175
    -

    Plotting posterior forecast distributions using mvgam and R

    +#> 10.78167525 +

    Plotting posterior forecast distributions using mvgam and R

    Scoring forecast distributions

    @@ -718,54 +716,54 @@

    Scoring forecast distributions

    str(crps_mod1) #> List of 4 #> $ series_1 :'data.frame': 25 obs. of 5 variables: -#> ..$ score : num [1:25] 0.1938 0.1366 1.355 NA 0.0348 ... +#> ..$ score : num [1:25] 0.186 0.129 1.372 NA 0.037 ... #> ..$ in_interval : num [1:25] 1 1 1 NA 1 1 1 1 1 1 ... #> ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ... #> ..$ eval_horizon : int [1:25] 1 2 3 4 5 6 7 8 9 10 ... #> ..$ score_type : chr [1:25] "crps" "crps" "crps" "crps" ... #> $ series_2 :'data.frame': 25 obs. of 5 variables: -#> ..$ score : num [1:25] 0.379 0.306 0.941 0.5 0.573 ... +#> ..$ score : num [1:25] 0.354 0.334 0.947 0.492 0.542 ... #> ..$ in_interval : num [1:25] 1 1 1 1 1 1 1 1 1 NA ... #> ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ... #> ..$ eval_horizon : int [1:25] 1 2 3 4 5 6 7 8 9 10 ... #> ..$ score_type : chr [1:25] "crps" "crps" "crps" "crps" ... #> $ series_3 :'data.frame': 25 obs. of 5 variables: -#> ..$ score : num [1:25] 0.32 0.556 0.379 0.362 0.219 ... +#> ..$ score : num [1:25] 0.31 0.616 0.4 0.349 0.215 ... #> ..$ in_interval : num [1:25] 1 1 1 1 1 1 1 1 1 1 ... #> ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ... #> ..$ eval_horizon : int [1:25] 1 2 3 4 5 6 7 8 9 10 ... #> ..$ score_type : chr [1:25] "crps" "crps" "crps" "crps" ... #> $ all_series:'data.frame': 25 obs. of 3 variables: -#> ..$ score : num [1:25] 0.892 0.999 2.675 NA 0.827 ... +#> ..$ score : num [1:25] 0.85 1.079 2.719 NA 0.794 ... #> ..$ eval_horizon: int [1:25] 1 2 3 4 5 6 7 8 9 10 ... #> ..$ score_type : chr [1:25] "sum_crps" "sum_crps" "sum_crps" "sum_crps" ... crps_mod1$series_1 #> score in_interval interval_width eval_horizon score_type -#> 1 0.19375525 1 0.9 1 crps -#> 2 0.13663925 1 0.9 2 crps -#> 3 1.35502175 1 0.9 3 crps +#> 1 0.18582425 1 0.9 1 crps +#> 2 0.12933350 1 0.9 2 crps +#> 3 1.37181050 1 0.9 3 crps #> 4 NA NA 0.9 4 crps -#> 5 0.03482775 1 0.9 5 crps -#> 6 1.55416700 1 0.9 6 crps -#> 7 1.51028900 1 0.9 7 crps -#> 8 0.62121225 1 0.9 8 crps -#> 9 0.62630125 1 0.9 9 crps -#> 10 0.59853100 1 0.9 10 crps -#> 11 1.30998625 1 0.9 11 crps -#> 12 2.04829775 1 0.9 12 crps -#> 13 0.61251800 1 0.9 13 crps -#> 14 0.14052300 1 0.9 14 crps -#> 15 0.65110800 1 0.9 15 crps -#> 16 0.07973125 1 0.9 16 crps -#> 17 0.07675600 1 0.9 17 crps -#> 18 0.09382375 1 0.9 18 crps -#> 19 0.12356725 1 0.9 19 crps +#> 5 0.03698600 1 0.9 5 crps +#> 6 1.53997900 1 0.9 6 crps +#> 7 1.50467675 1 0.9 7 crps +#> 8 0.63460725 1 0.9 8 crps +#> 9 0.61682725 1 0.9 9 crps +#> 10 0.62428875 1 0.9 10 crps +#> 11 1.33824700 1 0.9 11 crps +#> 12 2.06378300 1 0.9 12 crps +#> 13 0.59247200 1 0.9 13 crps +#> 14 0.13560025 1 0.9 14 crps +#> 15 0.66512975 1 0.9 15 crps +#> 16 0.08238525 1 0.9 16 crps +#> 17 0.08152900 1 0.9 17 crps +#> 18 0.09446425 1 0.9 18 crps +#> 19 0.12084700 1 0.9 19 crps #> 20 NA NA 0.9 20 crps -#> 21 0.20173600 1 0.9 21 crps -#> 22 0.84066825 1 0.9 22 crps +#> 21 0.21286925 1 0.9 21 crps +#> 22 0.85799700 1 0.9 22 crps #> 23 NA NA 0.9 23 crps -#> 24 1.06489225 1 0.9 24 crps -#> 25 0.75528825 1 0.9 25 crps
    +#> 24 1.14954750 1 0.9 24 crps +#> 25 0.85131425 1 0.9 25 crps

    The returned list contains a data.frame for each series in the data that shows the CRPS score for each evaluation in the testing data, along with some other useful information about the fit of the @@ -779,31 +777,31 @@

    Scoring forecast distributions

    crps_mod1 <- score(fc_mod1, score = 'crps', interval_width = 0.6)
 crps_mod1$series_1
 #>         score in_interval interval_width eval_horizon score_type
-#> 1  0.19375525           1            0.6            1       crps
-#> 2  0.13663925           1            0.6            2       crps
-#> 3  1.35502175           0            0.6            3       crps
+#> 1  0.18582425           1            0.6            1       crps
+#> 2  0.12933350           1            0.6            2       crps
+#> 3  1.37181050           0            0.6            3       crps
 #> 4          NA          NA            0.6            4       crps
-#> 5  0.03482775           1            0.6            5       crps
-#> 6  1.55416700           0            0.6            6       crps
-#> 7  1.51028900           0            0.6            7       crps
-#> 8  0.62121225           1            0.6            8       crps
-#> 9  0.62630125           1            0.6            9       crps
-#> 10 0.59853100           1            0.6           10       crps
-#> 11 1.30998625           0            0.6           11       crps
-#> 12 2.04829775           0            0.6           12       crps
-#> 13 0.61251800           1            0.6           13       crps
-#> 14 0.14052300           1            0.6           14       crps
-#> 15 0.65110800           1            0.6           15       crps
-#> 16 0.07973125           1            0.6           16       crps
-#> 17 0.07675600           1            0.6           17       crps
-#> 18 0.09382375           1            0.6           18       crps
-#> 19 0.12356725           1            0.6           19       crps
+#> 5  0.03698600           1            0.6            5       crps
+#> 6  1.53997900           0            0.6            6       crps
+#> 7  1.50467675           0            0.6            7       crps
+#> 8  0.63460725           1            0.6            8       crps
+#> 9  0.61682725           1            0.6            9       crps
+#> 10 0.62428875           1            0.6           10       crps
+#> 11 1.33824700           0            0.6           11       crps
+#> 12 2.06378300           0            0.6           12       crps
+#> 13 0.59247200           1            0.6           13       crps
+#> 14 0.13560025           1            0.6           14       crps
+#> 15 0.66512975           1            0.6           15       crps
+#> 16 0.08238525           1            0.6           16       crps
+#> 17 0.08152900           1            0.6           17       crps
+#> 18 0.09446425           1            0.6           18       crps
+#> 19 0.12084700           1            0.6           19       crps
 #> 20         NA          NA            0.6           20       crps
-#> 21 0.20173600           1            0.6           21       crps
-#> 22 0.84066825           1            0.6           22       crps
+#> 21 0.21286925           1            0.6           21       crps
+#> 22 0.85799700           1            0.6           22       crps
 #> 23         NA          NA            0.6           23       crps
-#> 24 1.06489225           1            0.6           24       crps
-#> 25 0.75528825           1            0.6           25       crps
    +#> 24 1.14954750 1 0.6 24 crps +#> 25 0.85131425 1 0.6 25 crps

    We can also compare forecasts against out of sample observations using the Expected Log Predictive Density (ELPD; also known as the log score). The ELPD is a strictly proper scoring rule that can be @@ -814,31 +812,31 @@

    Scoring forecast distributions

    link_mod1 <- forecast(mod1, newdata = simdat$data_test, type = 'link')
 score(link_mod1, score = 'elpd')$series_1
 #>         score eval_horizon score_type
-#> 1  -0.5304414            1       elpd
-#> 2  -0.4298955            2       elpd
-#> 3  -2.9617583            3       elpd
+#> 1  -0.5343784            1       elpd
+#> 2  -0.4326190            2       elpd
+#> 3  -2.9699450            3       elpd
 #> 4          NA            4       elpd
-#> 5  -0.2007644            5       elpd
-#> 6  -3.3781408            6       elpd
-#> 7  -3.2729088            7       elpd
-#> 8  -2.0363750            8       elpd
-#> 9  -2.0670612            9       elpd
-#> 10 -2.0844818           10       elpd
-#> 11 -3.0576463           11       elpd
-#> 12 -3.6291058           12       elpd
-#> 13 -2.1692669           13       elpd
-#> 14 -0.2960899           14       elpd
-#> 15 -2.3738851           15       elpd
-#> 16 -0.2160804           16       elpd
-#> 17 -0.2036782           17       elpd
-#> 18 -0.2115539           18       elpd
-#> 19 -0.2235072           19       elpd
+#> 5  -0.1998425            5       elpd
+#> 6  -3.3976729            6       elpd
+#> 7  -3.2989297            7       elpd
+#> 8  -2.0490633            8       elpd
+#> 9  -2.0690163            9       elpd
+#> 10 -2.0822051           10       elpd
+#> 11 -3.1101639           11       elpd
+#> 12 -3.7240924           12       elpd
+#> 13 -2.1578701           13       elpd
+#> 14 -0.2899481           14       elpd
+#> 15 -2.3811862           15       elpd
+#> 16 -0.2085375           16       elpd
+#> 17 -0.1960501           17       elpd
+#> 18 -0.2036978           18       elpd
+#> 19 -0.2154374           19       elpd
 #> 20         NA           20       elpd
-#> 21 -0.2413680           21       elpd
-#> 22 -2.6791984           22       elpd
+#> 21 -0.2341597           21       elpd
+#> 22 -2.6552948           22       elpd
 #> 23         NA           23       elpd
-#> 24 -2.6851981           24       elpd
-#> 25 -0.2836901           25       elpd
    +#> 24 -2.6652717 24 elpd +#> 25 -0.2759126 25 elpd

    Finally, when we have multiple time series it may also make sense to use a multivariate proper scoring rule. mvgam offers two such options: the Energy score and the Variogram score. The first @@ -862,7 +860,7 @@

    Scoring forecast distributions

    #> ..$ interval_width: num [1:25] 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 0.9 ... #> ..$ eval_horizon : int [1:25] 1 2 3 4 5 6 7 8 9 10 ... #> $ all_series:'data.frame': 25 obs. of 3 variables: -#> ..$ score : num [1:25] 0.773 1.147 1.226 NA 0.458 ... +#> ..$ score : num [1:25] 0.771 1.133 1.26 NA 0.443 ... #> ..$ eval_horizon: int [1:25] 1 2 3 4 5 6 7 8 9 10 ... #> ..$ score_type : chr [1:25] "energy" "energy" "energy" "energy" ...

    The returned object still provides information on interval coverage @@ -870,31 +868,31 @@

    Scoring forecast distributions

    now (which is provided in the all_series slot):

    energy_mod2$all_series
 #>        score eval_horizon score_type
-#> 1  0.7728517            1     energy
-#> 2  1.1469836            2     energy
-#> 3  1.2258781            3     energy
+#> 1  0.7705198            1     energy
+#> 2  1.1330328            2     energy
+#> 3  1.2600785            3     energy
 #> 4         NA            4     energy
-#> 5  0.4577536            5     energy
-#> 6  1.8094487            6     energy
-#> 7  1.4887317            7     energy
-#> 8  0.7651593            8     energy
-#> 9  1.1180634            9     energy
+#> 5  0.4427578            5     energy
+#> 6  1.8848308            6     energy
+#> 7  1.4186997            7     energy
+#> 8  0.7280518            8     energy
+#> 9  1.0467755            9     energy
 #> 10        NA           10     energy
-#> 11 1.5008324           11     energy
-#> 12 3.2142460           12     energy
-#> 13 1.6129732           13     energy
-#> 14 1.2704438           14     energy
-#> 15 1.1335958           15     energy
-#> 16 1.8717420           16     energy
+#> 11 1.4172423           11     energy
+#> 12 3.2326925           12     energy
+#> 13 1.5987732           13     energy
+#> 14 1.1798872           14     energy
+#> 15 1.0311968           15     energy
+#> 16 1.8261356           16     energy
 #> 17        NA           17     energy
-#> 18 0.7953392           18     energy
-#> 19 0.9919119           19     energy
+#> 18 0.7170961           18     energy
+#> 19 0.8927311           19     energy
 #> 20        NA           20     energy
-#> 21 1.2461964           21     energy
-#> 22 1.5170615           22     energy
+#> 21 1.0544501           21     energy
+#> 22 1.3280321           22     energy
 #> 23        NA           23     energy
-#> 24 2.3824552           24     energy
-#> 25 1.5314557           25     energy
    +#> 24 2.1843621 24 energy +#> 25 1.2352041 25 energy

    You can use your score(s) of choice to compare different models. For example, we can compute and plot the difference in CRPS scores for each series in data. Here, a negative value means the Gaussian Process model @@ -916,7 +914,7 @@

    Scoring forecast distributions

    title(main = paste0('GP better in ', gp_better, ' of 25 evaluations', '\nMean difference = ', round(mean(diff_scores, na.rm = TRUE), 2))) -

    +

    
 
 diff_scores <- crps_mod2$series_2$score -
@@ -932,7 +930,7 @@ 
    Scoring forecast distributions
    
 title(main = paste0('GP better in ', gp_better, ' of 25 evaluations',
                     '\nMean difference = ', 
                     round(mean(diff_scores, na.rm = TRUE), 2)))
    -

    +

    
 diff_scores <- crps_mod2$series_3$score -
   crps_mod1$series_3$score
@@ -947,7 +945,7 @@ 
    Scoring forecast distributions
    
 title(main = paste0('GP better in ', gp_better, ' of 25 evaluations',
                     '\nMean difference = ', 
                     round(mean(diff_scores, na.rm = TRUE), 2)))
    -

    +

    The GP model consistently gives better forecasts, and the difference between scores grows quickly as the forecast horizon increases. This is not unexpected given the way that splines linearly extrapolate outside diff --git a/inst/doc/mvgam_overview.R b/inst/doc/mvgam_overview.R index b298f867..c8b40d2d 100644 --- a/inst/doc/mvgam_overview.R +++ b/inst/doc/mvgam_overview.R @@ -1,4 +1,4 @@ -## ----echo = FALSE-------------------------------------------------------------- +## ----echo = FALSE------------------------------------------------------------- NOT_CRAN <- identical(tolower(Sys.getenv("NOT_CRAN")), "true") knitr::opts_chunk$set( collapse = TRUE, @@ -7,11 +7,10 @@ knitr::opts_chunk$set( eval = NOT_CRAN ) - -## ----setup, include=FALSE------------------------------------------------------ +## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, - dpi = 100, + dpi = 150, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -20,25 +19,20 @@ library(mvgam) library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) - -## ----Access time series data--------------------------------------------------- +## ----Access time series data-------------------------------------------------- data("portal_data") - -## ----Inspect data format and structure----------------------------------------- +## ----Inspect data format and structure---------------------------------------- head(portal_data) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- dplyr::glimpse(portal_data) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- data <- sim_mvgam(n_series = 4, T = 24) head(data$data_train, 12) - -## ----Wrangle data for modelling------------------------------------------------ +## ----Wrangle data for modelling----------------------------------------------- portal_data %>% # mvgam requires a 'time' variable be present in the data to index @@ -60,131 +54,122 @@ portal_data %>% # Select the variables of interest to keep in the model_data dplyr::select(series, year, time, count, mintemp, ndvi) -> model_data - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- head(model_data) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- dplyr::glimpse(model_data) - -## ----Summarise variables------------------------------------------------------- +## ----Summarise variables------------------------------------------------------ summary(model_data) +## ----------------------------------------------------------------------------- +image(is.na(t(model_data %>% + dplyr::arrange(dplyr::desc(time)))), axes = F, + col = c('grey80', 'darkred')) +axis(3, at = seq(0,1, len = NCOL(model_data)), labels = colnames(model_data)) -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- plot_mvgam_series(data = model_data, series = 1, y = 'count') - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- model_data %>% # Create a 'year_fac' factor version of 'year' dplyr::mutate(year_fac = factor(year)) -> model_data - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- dplyr::glimpse(model_data) levels(model_data$year_fac) - -## ----model1, include=FALSE, results='hide'------------------------------------- +## ----model1, include=FALSE, results='hide'------------------------------------ model1 <- mvgam(count ~ s(year_fac, bs = 're') - 1, family = poisson(), data = model_data, parallel = FALSE) +## ----eval=FALSE--------------------------------------------------------------- +# model1 <- mvgam(count ~ s(year_fac, bs = 're') - 1, +# family = poisson(), +# data = model_data) -## ----eval=FALSE---------------------------------------------------------------- -## model1 <- mvgam(count ~ s(year_fac, bs = 're') - 1, -## family = poisson(), -## data = model_data) - - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- get_mvgam_priors(count ~ s(year_fac, bs = 're') - 1, family = poisson(), data = model_data) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- summary(model1) - -## ----Extract coefficient posteriors-------------------------------------------- +## ----Extract coefficient posteriors------------------------------------------- beta_post <- as.data.frame(model1, variable = 'betas') dplyr::glimpse(beta_post) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- code(model1) - -## ----Plot random effect estimates---------------------------------------------- +## ----Plot random effect estimates--------------------------------------------- plot(model1, type = 're') - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- mcmc_plot(object = model1, variable = 'betas', type = 'areas') - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- pp_check(object = model1) +pp_check(model1, type = "rootogram") - -## ----Plot posterior hindcasts-------------------------------------------------- +## ----Plot posterior hindcasts------------------------------------------------- plot(model1, type = 'forecast') - -## ----Extract posterior hindcast------------------------------------------------ +## ----Extract posterior hindcast----------------------------------------------- hc <- hindcast(model1) str(hc) - -## ----Extract hindcasts on the linear predictor scale--------------------------- +## ----Extract hindcasts on the linear predictor scale-------------------------- hc <- hindcast(model1, type = 'link') range(hc$hindcasts$PP) +## ----Plot hindcasts on the linear predictor scale----------------------------- +plot(hc) -## ----Plot posterior residuals-------------------------------------------------- +## ----Plot posterior residuals------------------------------------------------- plot(model1, type = 'residuals') - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- model_data %>% dplyr::filter(time <= 160) -> data_train model_data %>% dplyr::filter(time > 160) -> data_test - -## ----include=FALSE, message=FALSE, warning=FALSE------------------------------- +## ----include=FALSE, message=FALSE, warning=FALSE------------------------------ model1b <- mvgam(count ~ s(year_fac, bs = 're') - 1, family = poisson(), data = data_train, newdata = data_test, parallel = FALSE) +## ----eval=FALSE--------------------------------------------------------------- +# model1b <- mvgam(count ~ s(year_fac, bs = 're') - 1, +# family = poisson(), +# data = data_train, +# newdata = data_test) -## ----eval=FALSE---------------------------------------------------------------- -## model1b <- mvgam(count ~ s(year_fac, bs = 're') - 1, -## family = poisson(), -## data = data_train, -## newdata = data_test) +## ----------------------------------------------------------------------------- +plot(model1b, type = 're') +## ----------------------------------------------------------------------------- +plot(model1b, type = 'forecast') -## ----Plotting predictions against test data------------------------------------ +## ----Plotting predictions against test data----------------------------------- plot(model1b, type = 'forecast', newdata = data_test) - -## ----Extract posterior forecasts----------------------------------------------- +## ----Extract posterior forecasts---------------------------------------------- fc <- forecast(model1b) str(fc) - -## ----model2, include=FALSE, message=FALSE, warning=FALSE----------------------- +## ----model2, include=FALSE, message=FALSE, warning=FALSE---------------------- model2 <- mvgam(count ~ s(year_fac, bs = 're') + ndvi - 1, family = poisson(), @@ -192,29 +177,27 @@ model2 <- mvgam(count ~ s(year_fac, bs = 're') + newdata = data_test, parallel = FALSE) +## ----eval=FALSE--------------------------------------------------------------- +# model2 <- mvgam(count ~ s(year_fac, bs = 're') + +# ndvi - 1, +# family = poisson(), +# data = data_train, +# newdata = data_test) -## ----eval=FALSE---------------------------------------------------------------- -## model2 <- mvgam(count ~ s(year_fac, bs = 're') + -## ndvi - 1, -## family = poisson(), -## data = data_train, -## newdata = data_test) - - -## ----class.output="scroll-300"------------------------------------------------- +## ----class.output="scroll-300"------------------------------------------------ summary(model2) - -## ----Posterior quantiles of model coefficients--------------------------------- +## ----Posterior quantiles of model coefficients-------------------------------- coef(model2) +## ----Plot NDVI effect--------------------------------------------------------- +plot(model2, type = 'pterms') -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- beta_post <- as.data.frame(model2, variable = 'betas') dplyr::glimpse(beta_post) - -## ----Histogram of NDVI effects------------------------------------------------- +## ----Histogram of NDVI effects------------------------------------------------ hist(beta_post$ndvi, xlim = c(-1 * max(abs(beta_post$ndvi)), max(abs(beta_post$ndvi))), @@ -227,12 +210,18 @@ hist(beta_post$ndvi, lwd = 2) abline(v = 0, lwd = 2.5) +## ----warning=FALSE------------------------------------------------------------ +plot_predictions(model2, + condition = "ndvi", + # include the observed count values + # as points, and show rugs for the observed + # ndvi and count values on the axes + points = 0.5, rug = TRUE) -## ----warning=FALSE------------------------------------------------------------- -conditional_effects(model2) - +## ----warning=FALSE------------------------------------------------------------ +plot(conditional_effects(model2), ask = FALSE) -## ----model3, include=FALSE, message=FALSE, warning=FALSE----------------------- +## ----model3, include=FALSE, message=FALSE, warning=FALSE---------------------- model3 <- mvgam(count ~ s(time, bs = 'bs', k = 15) + ndvi, family = poisson(), @@ -240,32 +229,39 @@ model3 <- mvgam(count ~ s(time, bs = 'bs', k = 15) + newdata = data_test, parallel = FALSE) +## ----eval=FALSE--------------------------------------------------------------- +# model3 <- mvgam(count ~ s(time, bs = 'bs', k = 15) + +# ndvi, +# family = poisson(), +# data = data_train, +# newdata = data_test) -## ----eval=FALSE---------------------------------------------------------------- -## model3 <- mvgam(count ~ s(time, bs = 'bs', k = 15) + -## ndvi, -## family = poisson(), -## data = data_train, -## newdata = data_test) +## ----------------------------------------------------------------------------- +summary(model3) +## ----------------------------------------------------------------------------- +plot(model3, type = 'smooths') -## ------------------------------------------------------------------------------ -summary(model3) +## ----------------------------------------------------------------------------- +plot(model3, type = 'smooths', realisations = TRUE, + n_realisations = 30) +## ----Plot smooth term derivatives, warning = FALSE, fig.asp = 1--------------- +plot(model3, type = 'smooths', derivatives = TRUE) -## ----warning=FALSE------------------------------------------------------------- -conditional_effects(model3, type = 'link') +## ----warning=FALSE------------------------------------------------------------ +plot(conditional_effects(model3), ask = FALSE) +## ----warning=FALSE------------------------------------------------------------ +plot(conditional_effects(model3, type = 'link'), ask = FALSE) -## ----class.output="scroll-300"------------------------------------------------- +## ----class.output="scroll-300"------------------------------------------------ code(model3) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- plot(model3, type = 'forecast', newdata = data_test) - -## ----Plot extrapolated temporal functions using newdata------------------------ +## ----Plot extrapolated temporal functions using newdata----------------------- plot_mvgam_smooth(model3, smooth = 's(time)', # feed newdata to the plot function to generate # predictions of the temporal smooth to the end of the @@ -274,8 +270,7 @@ plot_mvgam_smooth(model3, smooth = 's(time)', ndvi = 0)) abline(v = max(data_train$time), lty = 'dashed', lwd = 2) - -## ----model4, include=FALSE----------------------------------------------------- +## ----model4, include=FALSE---------------------------------------------------- model4 <- mvgam(count ~ s(ndvi, k = 6), family = poisson(), data = data_train, @@ -283,32 +278,31 @@ model4 <- mvgam(count ~ s(ndvi, k = 6), trend_model = 'AR1', parallel = FALSE) - -## ----eval=FALSE---------------------------------------------------------------- -## model4 <- mvgam(count ~ s(ndvi, k = 6), -## family = poisson(), -## data = data_train, -## newdata = data_test, -## trend_model = 'AR1') - +## ----eval=FALSE--------------------------------------------------------------- +# model4 <- mvgam(count ~ s(ndvi, k = 6), +# family = poisson(), +# data = data_train, +# newdata = data_test, +# trend_model = 'AR1') ## ----Summarise the mvgam autocorrelated error model, class.output="scroll-300"---- summary(model4) +## ----warning=FALSE, message=FALSE--------------------------------------------- +plot_predictions(model4, + condition = "ndvi", + points = 0.5, rug = TRUE) -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- plot(model4, type = 'forecast', newdata = data_test) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- plot(model4, type = 'trend', newdata = data_test) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- loo_compare(model3, model4) - -## ------------------------------------------------------------------------------ +## ----------------------------------------------------------------------------- fc_mod3 <- forecast(model3) fc_mod4 <- forecast(model4) score_mod3 <- score(fc_mod3, score = 'drps') diff --git a/inst/doc/mvgam_overview.html b/inst/doc/mvgam_overview.html index b390eccb..6ebc839b 100644 --- a/inst/doc/mvgam_overview.html +++ b/inst/doc/mvgam_overview.html @@ -12,7 +12,7 @@ - + Overview of the mvgam package @@ -340,7 +340,7 @@

    Overview of the mvgam package

    Nicholas J Clark

    -

    2024-05-08

    +

    2024-04-16

    @@ -382,8 +382,10 @@

    2024-05-08

  • marginaleffects support
    • -
  • Adding predictors as -smooths
    • +
  • Adding predictors as smooths +
  • Latent dynamics in mvgam
  • Interested in contributing?
    • @@ -692,7 +694,7 @@

    Continuous time AR(1) processes

    Regression formulae

    mvgam supports an observation model regression formula, -built off the mgcv package, as well as an optional process +built off the mvgcv package, as well as an optional process model regression formula. The formulae supplied to are exactly like those supplied to glm() except that smooth terms, s(), te(), ti() and @@ -765,19 +767,19 @@

    Manipulating data for modelling

    ?sim_mvgam for more details

    data <- sim_mvgam(n_series = 4, T = 24)
 head(data$data_train, 12)
-#>     y season year   series time
-#> 1   9      1    1 series_1    1
-#> 2  11      1    1 series_2    1
-#> 3   7      1    1 series_3    1
-#> 4   3      1    1 series_4    1
-#> 5   3      2    1 series_1    2
-#> 6   2      2    1 series_2    2
-#> 7   0      2    1 series_3    2
-#> 8   1      2    1 series_4    2
-#> 9   2      3    1 series_1    3
-#> 10  0      3    1 series_2    3
-#> 11  0      3    1 series_3    3
-#> 12  1      3    1 series_4    3
    +#> y season year series time +#> 1 1 1 1 series_1 1 +#> 2 0 1 1 series_2 1 +#> 3 1 1 1 series_3 1 +#> 4 1 1 1 series_4 1 +#> 5 1 2 1 series_1 2 +#> 6 1 2 1 series_2 2 +#> 7 0 2 1 series_3 2 +#> 8 1 2 1 series_4 2 +#> 9 2 3 1 series_1 3 +#> 10 0 3 1 series_2 3 +#> 11 0 3 1 series_3 3 +#> 12 1 3 1 series_4 3

    Notice how we have four different time series in these simulated data, but we do not spread the outcome values into different columns. Rather, there is only a single column for the outcome variable, labelled @@ -861,14 +863,22 @@

    Manipulating data for modelling

    #> Max. :3.9126 #>

    We have some NAs in our response variable -count. These observations will generally be thrown out by -most modelling packages in . But as you will see when we work through -the tutorials, mvgam keeps these in the data so that -predictions can be automatically returned for the full dataset. The time -series and some of its descriptive features can be plotted using +count. Let’s visualize the data as a heatmap to get a sense +of where these are distributed (NAs are shown as red bars +in the below plot)

    +
    image(is.na(t(model_data %>%
+                dplyr::arrange(dplyr::desc(time)))), axes = F,
+      col = c('grey80', 'darkred'))
+axis(3, at = seq(0,1, len = NCOL(model_data)), labels = colnames(model_data))
    +

    +

    These observations will generally be thrown out by most modelling +packages in . But as you will see when we work through the tutorials, +mvgam keeps these in the data so that predictions can be +automatically returned for the full dataset. The time series and some of +its descriptive features can be plotted using plot_mvgam_series():

    -
    plot_mvgam_series(data = model_data, series = 1, y = 'count')
    -

    +
    plot_mvgam_series(data = model_data, series = 1, y = 'count')
    +

    GLMs with temporal random effects

    @@ -893,25 +903,25 @@

    GLMs with temporal random effects

    ?smooth.construct.re.smooth.spec for details about the re basis construction that is used by both mvgam and mgcv

    -
    model_data %>%
-  
-  # Create a 'year_fac' factor version of 'year'
-  dplyr::mutate(year_fac = factor(year)) -> model_data
    +
    model_data %>%
+  
+  # Create a 'year_fac' factor version of 'year'
+  dplyr::mutate(year_fac = factor(year)) -> model_data

    Preview the dataset to ensure year is now a factor with a unique factor level for each year in the data

    -
    dplyr::glimpse(model_data)
-#> Rows: 199
-#> Columns: 7
-#> $ series   <fct> PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, P…
-#> $ year     <int> 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2…
-#> $ time     <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18…
-#> $ count    <int> 0, 1, 2, NA, 10, NA, NA, 16, 18, 12, NA, 3, 2, NA, NA, 13, NA…
-#> $ mintemp  <dbl> -9.710, -5.924, -0.220, 1.931, 6.568, 11.590, 14.370, 16.520,…
-#> $ ndvi     <dbl> 1.4658889, 1.5585069, 1.3378172, 1.6589129, 1.8536561, 1.7613…
-#> $ year_fac <fct> 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2…
-levels(model_data$year_fac)
-#>  [1] "2004" "2005" "2006" "2007" "2008" "2009" "2010" "2011" "2012" "2013"
-#> [11] "2014" "2015" "2016" "2017" "2018" "2019" "2020"
    +
    dplyr::glimpse(model_data)
+#> Rows: 199
+#> Columns: 7
+#> $ series   <fct> PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, PP, P…
+#> $ year     <int> 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2…
+#> $ time     <dbl> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18…
+#> $ count    <int> 0, 1, 2, NA, 10, NA, NA, 16, 18, 12, NA, 3, 2, NA, NA, 13, NA…
+#> $ mintemp  <dbl> -9.710, -5.924, -0.220, 1.931, 6.568, 11.590, 14.370, 16.520,…
+#> $ ndvi     <dbl> 1.4658889, 1.5585069, 1.3378172, 1.6589129, 1.8536561, 1.7613…
+#> $ year_fac <fct> 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2004, 2…
+levels(model_data$year_fac)
+#>  [1] "2004" "2005" "2006" "2007" "2008" "2009" "2010" "2011" "2012" "2013"
+#> [11] "2014" "2015" "2016" "2017" "2018" "2019" "2020"

    We are now ready for our first mvgam model. The syntax will be familiar to users who have previously built models with mgcv. But for a refresher, see ?formula.gam @@ -933,9 +943,9 @@

    GLMs with temporal random effects

    consult the Stan user’s guide for more information about the software and the enormous variety of models that can be tackled with HMC.

    -
    model1 <- mvgam(count ~ s(year_fac, bs = 're') - 1,
-                family = poisson(),
-                data = model_data)
    +
    model1 <- mvgam(count ~ s(year_fac, bs = 're') - 1,
+                family = poisson(),
+                data = model_data)

    The model can be described mathematically for each timepoint \(t\) as follows: \[\begin{align*} \boldsymbol{count}_t & \sim \text{Poisson}(\lambda_t) \\ log(\lambda_t) & = \beta_{year[year_t]} \\ @@ -949,91 +959,90 @@

    GLMs with temporal random effects

    similar functionality to the options available in brms. For example, the default priors on \((\mu_{year})\) and \((\sigma_{year})\) can be viewed using the following code:

    -
    get_mvgam_priors(count ~ s(year_fac, bs = 're') - 1,
-                 family = poisson(),
-                 data = model_data)
-#>                      param_name param_length           param_info
-#> 1             vector[1] mu_raw;            1 s(year_fac) pop mean
-#> 2 vector<lower=0>[1] sigma_raw;            1   s(year_fac) pop sd
-#>                               prior                 example_change
-#> 1            mu_raw ~ std_normal();   mu_raw ~ normal(0.13, 0.16);
-#> 2 sigma_raw ~ student_t(3, 0, 2.5); sigma_raw ~ exponential(0.72);
-#>   new_lowerbound new_upperbound
-#> 1             NA             NA
-#> 2             NA             NA
    +
    get_mvgam_priors(count ~ s(year_fac, bs = 're') - 1,
+                 family = poisson(),
+                 data = model_data)
+#>                      param_name param_length           param_info
+#> 1             vector[1] mu_raw;            1 s(year_fac) pop mean
+#> 2 vector<lower=0>[1] sigma_raw;            1   s(year_fac) pop sd
+#>                               prior                example_change
+#> 1            mu_raw ~ std_normal();  mu_raw ~ normal(0.17, 0.76);
+#> 2 sigma_raw ~ student_t(3, 0, 2.5); sigma_raw ~ exponential(0.7);
+#>   new_lowerbound new_upperbound
+#> 1             NA             NA
+#> 2             NA             NA

    See examples in ?get_mvgam_priors to find out different ways that priors can be altered. Once the model has finished, the first step is to inspect the summary to ensure no major diagnostic warnings have been produced and to quickly summarise posterior distributions for key parameters

    -
    summary(model1)
-#> GAM formula:
-#> count ~ s(year_fac, bs = "re") - 1
-#> <environment: 0x0000026502c9ba10>
-#> 
-#> Family:
-#> poisson
-#> 
-#> Link function:
-#> log
-#> 
-#> Trend model:
-#> None
-#> 
-#> N series:
-#> 1 
-#> 
-#> N timepoints:
-#> 199 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> GAM coefficient (beta) estimates:
-#>                 2.5% 50% 97.5% Rhat n_eff
-#> s(year_fac).1   1.80 2.1   2.3    1  2272
-#> s(year_fac).2   2.50 2.7   2.9    1  3300
-#> s(year_fac).3   3.00 3.1   3.2    1  3601
-#> s(year_fac).4   3.10 3.3   3.4    1  2910
-#> s(year_fac).5   1.90 2.1   2.3    1  2957
-#> s(year_fac).6   1.50 1.8   2.0    1  2772
-#> s(year_fac).7   1.80 2.0   2.3    1  2956
-#> s(year_fac).8   2.80 3.0   3.1    1  2895
-#> s(year_fac).9   3.10 3.2   3.4    1  3207
-#> s(year_fac).10  2.60 2.8   2.9    1  2399
-#> s(year_fac).11  3.00 3.1   3.2    1  3477
-#> s(year_fac).12  3.10 3.2   3.3    1  3154
-#> s(year_fac).13  2.00 2.2   2.4    1  1854
-#> s(year_fac).14  2.50 2.6   2.8    1  2744
-#> s(year_fac).15  1.90 2.2   2.4    1  2927
-#> s(year_fac).16  1.90 2.1   2.3    1  3169
-#> s(year_fac).17 -0.35 1.1   1.9    1   387
-#> 
-#> GAM group-level estimates:
-#>                   2.5%  50% 97.5% Rhat n_eff
-#> mean(s(year_fac)) 2.00 2.40   2.8 1.01   175
-#> sd(s(year_fac))   0.45 0.67   1.1 1.01   171
-#> 
-#> Approximate significance of GAM smooths:
-#>              edf Ref.df Chi.sq p-value    
-#> s(year_fac) 12.6     17  24442  <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 8:46:12 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +
    summary(model1)
+#> GAM formula:
+#> count ~ s(year_fac, bs = "re") - 1
+#> 
+#> Family:
+#> poisson
+#> 
+#> Link function:
+#> log
+#> 
+#> Trend model:
+#> None
+#> 
+#> N series:
+#> 1 
+#> 
+#> N timepoints:
+#> 199 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> GAM coefficient (beta) estimates:
+#>                 2.5% 50% 97.5% Rhat n_eff
+#> s(year_fac).1   1.80 2.1   2.3 1.00  2663
+#> s(year_fac).2   2.50 2.7   2.8 1.00  2468
+#> s(year_fac).3   3.00 3.1   3.2 1.00  3105
+#> s(year_fac).4   3.10 3.3   3.4 1.00  2822
+#> s(year_fac).5   1.90 2.1   2.3 1.00  3348
+#> s(year_fac).6   1.50 1.8   2.0 1.00  2859
+#> s(year_fac).7   1.80 2.0   2.3 1.00  2995
+#> s(year_fac).8   2.80 3.0   3.1 1.00  3126
+#> s(year_fac).9   3.10 3.3   3.4 1.00  2816
+#> s(year_fac).10  2.60 2.8   2.9 1.00  2289
+#> s(year_fac).11  3.00 3.1   3.2 1.00  2725
+#> s(year_fac).12  3.10 3.2   3.3 1.00  2581
+#> s(year_fac).13  2.00 2.2   2.5 1.00  2885
+#> s(year_fac).14  2.50 2.6   2.8 1.00  2749
+#> s(year_fac).15  1.90 2.2   2.4 1.00  2943
+#> s(year_fac).16  1.90 2.1   2.3 1.00  2991
+#> s(year_fac).17 -0.33 1.1   1.9 1.01   356
+#> 
+#> GAM group-level estimates:
+#>                   2.5%  50% 97.5% Rhat n_eff
+#> mean(s(year_fac)) 2.00 2.40   2.7 1.01   193
+#> sd(s(year_fac))   0.44 0.67   1.1 1.02   172
+#> 
+#> Approximate significance of GAM smooths:
+#>              edf Ref.df Chi.sq p-value    
+#> s(year_fac) 13.8     17  23477  <2e-16 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Tue Apr 16 12:59:57 PM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

    The diagnostic messages at the bottom of the summary show that the HMC sampler did not encounter any problems or difficult posterior spaces. This is a good sign. Posterior distributions for model @@ -1042,85 +1051,85 @@

    GLMs with temporal random effects

    details). For example, we can extract the coefficients related to the GAM linear predictor (i.e. the \(\beta\)’s) into a data.frame using:

    -
    beta_post <- as.data.frame(model1, variable = 'betas')
-dplyr::glimpse(beta_post)
-#> Rows: 2,000
-#> Columns: 17
-#> $ `s(year_fac).1`  <dbl> 2.19572, 1.80459, 2.05882, 1.77283, 2.17899, 1.78306,…
-#> $ `s(year_fac).2`  <dbl> 2.73268, 2.63982, 2.67192, 2.60732, 2.70498, 2.59426,…
-#> $ `s(year_fac).3`  <dbl> 3.20954, 3.21016, 3.04541, 3.12612, 3.02844, 3.07486,…
-#> $ `s(year_fac).4`  <dbl> 3.21654, 3.22332, 3.27734, 3.26635, 3.22450, 3.18903,…
-#> $ `s(year_fac).5`  <dbl> 2.11947, 2.02341, 2.15199, 2.11768, 2.04859, 2.13145,…
-#> $ `s(year_fac).6`  <dbl> 1.77935, 1.75774, 1.87608, 1.74988, 1.68181, 1.57843,…
-#> $ `s(year_fac).7`  <dbl> 2.00416, 2.09224, 2.06421, 1.79570, 2.09012, 1.85510,…
-#> $ `s(year_fac).8`  <dbl> 2.90598, 2.98992, 2.95453, 2.90335, 3.00163, 2.83986,…
-#> $ `s(year_fac).9`  <dbl> 3.28482, 3.30058, 3.15660, 3.32875, 3.27280, 3.26740,…
-#> $ `s(year_fac).10` <dbl> 2.94900, 2.58117, 2.62932, 2.87103, 2.61496, 2.84087,…
-#> $ `s(year_fac).11` <dbl> 3.07873, 3.07060, 3.21571, 2.99998, 3.04865, 3.12531,…
-#> $ `s(year_fac).12` <dbl> 3.18193, 3.15362, 3.19562, 3.23034, 3.18776, 3.10583,…
-#> $ `s(year_fac).13` <dbl> 2.25802, 2.21252, 2.17579, 2.24304, 2.19309, 2.15013,…
-#> $ `s(year_fac).14` <dbl> 2.48221, 2.50201, 2.64717, 2.72028, 2.53187, 2.68245,…
-#> $ `s(year_fac).15` <dbl> 2.11611, 2.36704, 2.18749, 2.32255, 1.88132, 2.34579,…
-#> $ `s(year_fac).16` <dbl> 2.10163, 2.10267, 2.12983, 1.97498, 2.01470, 1.93883,…
-#> $ `s(year_fac).17` <dbl> 1.252770, 0.736639, 0.520716, -0.163687, 1.832560, 0.…
    +
    beta_post <- as.data.frame(model1, variable = 'betas')
+dplyr::glimpse(beta_post)
+#> Rows: 2,000
+#> Columns: 17
+#> $ `s(year_fac).1`  <dbl> 2.17023, 2.08413, 1.99815, 2.17572, 2.11308, 2.03050,…
+#> $ `s(year_fac).2`  <dbl> 2.70488, 2.69887, 2.65551, 2.79651, 2.76044, 2.75108,…
+#> $ `s(year_fac).3`  <dbl> 3.08617, 3.13429, 3.04575, 3.14824, 3.10917, 3.09809,…
+#> $ `s(year_fac).4`  <dbl> 3.29529, 3.21044, 3.22018, 3.26644, 3.29880, 3.25638,…
+#> $ `s(year_fac).5`  <dbl> 2.11053, 2.14516, 2.13959, 2.05244, 2.26847, 2.20820,…
+#> $ `s(year_fac).6`  <dbl> 1.80418, 1.83343, 1.75987, 1.76972, 1.64782, 1.70765,…
+#> $ `s(year_fac).7`  <dbl> 1.99033, 1.95772, 1.98093, 2.01777, 2.04849, 1.97815,…
+#> $ `s(year_fac).8`  <dbl> 3.01204, 2.91291, 3.14762, 2.83082, 2.90250, 3.04050,…
+#> $ `s(year_fac).9`  <dbl> 3.22248, 3.20205, 3.30373, 3.23181, 3.24927, 3.25232,…
+#> $ `s(year_fac).10` <dbl> 2.71922, 2.62225, 2.82574, 2.65027, 2.69077, 2.75249,…
+#> $ `s(year_fac).11` <dbl> 3.10525, 3.03951, 3.12914, 3.03849, 3.01198, 3.14391,…
+#> $ `s(year_fac).12` <dbl> 3.20887, 3.23337, 3.24350, 3.16821, 3.23516, 3.18216,…
+#> $ `s(year_fac).13` <dbl> 2.18530, 2.15358, 2.39908, 2.21862, 2.14648, 2.17067,…
+#> $ `s(year_fac).14` <dbl> 2.66153, 2.67202, 2.64594, 2.57457, 2.38109, 2.44175,…
+#> $ `s(year_fac).15` <dbl> 2.24898, 2.24912, 2.03587, 2.33842, 2.27868, 2.24643,…
+#> $ `s(year_fac).16` <dbl> 2.20947, 2.21717, 2.03610, 2.17374, 2.16442, 2.14900,…
+#> $ `s(year_fac).17` <dbl> 0.1428430, 0.8005170, -0.0136294, 0.6880930, 0.192034…

    With any model fitted in mvgam, the underlying Stan code can be viewed using the code function:

    -
    code(model1)
-#> // Stan model code generated by package mvgam
-#> data {
-#>   int<lower=0> total_obs; // total number of observations
-#>   int<lower=0> n; // number of timepoints per series
-#>   int<lower=0> n_series; // number of series
-#>   int<lower=0> num_basis; // total number of basis coefficients
-#>   matrix[total_obs, num_basis] X; // mgcv GAM design matrix
-#>   array[n, n_series] int<lower=0> ytimes; // time-ordered matrix (which col in X belongs to each [time, series] observation?)
-#>   int<lower=0> n_nonmissing; // number of nonmissing observations
-#>   array[n_nonmissing] int<lower=0> flat_ys; // flattened nonmissing observations
-#>   matrix[n_nonmissing, num_basis] flat_xs; // X values for nonmissing observations
-#>   array[n_nonmissing] int<lower=0> obs_ind; // indices of nonmissing observations
-#> }
-#> parameters {
-#>   // raw basis coefficients
-#>   vector[num_basis] b_raw;
-#>   
-#>   // random effect variances
-#>   vector<lower=0>[1] sigma_raw;
-#>   
-#>   // random effect means
-#>   vector[1] mu_raw;
-#> }
-#> transformed parameters {
-#>   // basis coefficients
-#>   vector[num_basis] b;
-#>   b[1 : 17] = mu_raw[1] + b_raw[1 : 17] * sigma_raw[1];
-#> }
-#> model {
-#>   // prior for random effect population variances
-#>   sigma_raw ~ student_t(3, 0, 2.5);
-#>   
-#>   // prior for random effect population means
-#>   mu_raw ~ std_normal();
-#>   
-#>   // prior (non-centred) for s(year_fac)...
-#>   b_raw[1 : 17] ~ std_normal();
-#>   {
-#>     // likelihood functions
-#>     flat_ys ~ poisson_log_glm(flat_xs, 0.0, b);
-#>   }
-#> }
-#> generated quantities {
-#>   vector[total_obs] eta;
-#>   matrix[n, n_series] mus;
-#>   array[n, n_series] int ypred;
-#>   
-#>   // posterior predictions
-#>   eta = X * b;
-#>   for (s in 1 : n_series) {
-#>     mus[1 : n, s] = eta[ytimes[1 : n, s]];
-#>     ypred[1 : n, s] = poisson_log_rng(mus[1 : n, s]);
-#>   }
-#> }
    +
    code(model1)
+#> // Stan model code generated by package mvgam
+#> data {
+#>   int<lower=0> total_obs; // total number of observations
+#>   int<lower=0> n; // number of timepoints per series
+#>   int<lower=0> n_series; // number of series
+#>   int<lower=0> num_basis; // total number of basis coefficients
+#>   matrix[total_obs, num_basis] X; // mgcv GAM design matrix
+#>   array[n, n_series] int<lower=0> ytimes; // time-ordered matrix (which col in X belongs to each [time, series] observation?)
+#>   int<lower=0> n_nonmissing; // number of nonmissing observations
+#>   array[n_nonmissing] int<lower=0> flat_ys; // flattened nonmissing observations
+#>   matrix[n_nonmissing, num_basis] flat_xs; // X values for nonmissing observations
+#>   array[n_nonmissing] int<lower=0> obs_ind; // indices of nonmissing observations
+#> }
+#> parameters {
+#>   // raw basis coefficients
+#>   vector[num_basis] b_raw;
+#>   
+#>   // random effect variances
+#>   vector<lower=0>[1] sigma_raw;
+#>   
+#>   // random effect means
+#>   vector[1] mu_raw;
+#> }
+#> transformed parameters {
+#>   // basis coefficients
+#>   vector[num_basis] b;
+#>   b[1 : 17] = mu_raw[1] + b_raw[1 : 17] * sigma_raw[1];
+#> }
+#> model {
+#>   // prior for random effect population variances
+#>   sigma_raw ~ student_t(3, 0, 2.5);
+#>   
+#>   // prior for random effect population means
+#>   mu_raw ~ std_normal();
+#>   
+#>   // prior (non-centred) for s(year_fac)...
+#>   b_raw[1 : 17] ~ std_normal();
+#>   {
+#>     // likelihood functions
+#>     flat_ys ~ poisson_log_glm(flat_xs, 0.0, b);
+#>   }
+#> }
+#> generated quantities {
+#>   vector[total_obs] eta;
+#>   matrix[n, n_series] mus;
+#>   array[n, n_series] int ypred;
+#>   
+#>   // posterior predictions
+#>   eta = X * b;
+#>   for (s in 1 : n_series) {
+#>     mus[1 : n, s] = eta[ytimes[1 : n, s]];
+#>     ypred[1 : n, s] = poisson_log_rng(mus[1 : n, s]);
+#>   }
+#> }

    Plotting effects and residuals

    Now for interrogating the model. We can get some sense of the @@ -1130,8 +1139,8 @@

    Plotting effects and residuals

    type = 're'. See ?plot.mvgam for more details about the types of plots that can be produced from fitted mvgam objects

    -
    plot(model1, type = 're')
    -

    +
    plot(model1, type = 're')
    +

    bayesplot support

    @@ -1139,71 +1148,84 @@

    bayesplot support

    from the bayesplot package to visualize posterior distributions and diagnostics (see ?mvgam::mcmc_plot.mvgam for details):

    -
    mcmc_plot(object = model1,
-          variable = 'betas',
-          type = 'areas')
    -

    +
    mcmc_plot(object = model1,
+          variable = 'betas',
+          type = 'areas')
    +

    We can also use the wide range of posterior checking functions available in bayesplot (see ?mvgam::ppc_check.mvgam for details):

    -
    pp_check(object = model1)
-#> Using 10 posterior draws for ppc type 'dens_overlay' by default.
-#> Warning in pp_check.mvgam(object = model1): NA responses are not shown in
-#> 'pp_check'.
    -

    +
    pp_check(object = model1)
+#> Using 10 posterior draws for ppc type 'dens_overlay' by default.
+#> Warning in pp_check.mvgam(object = model1): NA responses are not shown in
+#> 'pp_check'.
    +

    +
    pp_check(model1, type = "rootogram")
+#> Using all posterior draws for ppc type 'rootogram' by default.
+#> Warning in pp_check.mvgam(model1, type = "rootogram"): NA responses are not
+#> shown in 'pp_check'.
    +

    There is clearly some variation in these yearly intercept estimates. But how do these translate into time-varying predictions? To understand this, we can plot posterior hindcasts from this model for the training period using plot.mvgam with type = 'forecast'

    -
    plot(model1, type = 'forecast')
    -

    +
    plot(model1, type = 'forecast')
    +

    If you wish to extract these hindcasts for other downstream analyses, the hindcast function can be used. This will return a list object of class mvgam_forecast. In the hindcasts slot, a matrix of posterior retrodictions will be returned for each series in the data (only one series in our example):

    -
    hc <- hindcast(model1)
-str(hc)
-#> List of 15
-#>  $ call              :Class 'formula'  language count ~ s(year_fac, bs = "re") - 1
-#>   .. ..- attr(*, ".Environment")=<environment: 0x0000026502c9ba10> 
-#>  $ trend_call        : NULL
-#>  $ family            : chr "poisson"
-#>  $ trend_model       : chr "None"
-#>  $ drift             : logi FALSE
-#>  $ use_lv            : logi FALSE
-#>  $ fit_engine        : chr "stan"
-#>  $ type              : chr "response"
-#>  $ series_names      : chr "PP"
-#>  $ train_observations:List of 1
-#>   ..$ PP: int [1:199] 0 1 2 NA 10 NA NA 16 18 12 ...
-#>  $ train_times       : num [1:199] 1 2 3 4 5 6 7 8 9 10 ...
-#>  $ test_observations : NULL
-#>  $ test_times        : NULL
-#>  $ hindcasts         :List of 1
-#>   ..$ PP: num [1:2000, 1:199] 11 9 9 7 8 4 12 9 13 3 ...
-#>   .. ..- attr(*, "dimnames")=List of 2
-#>   .. .. ..$ : NULL
-#>   .. .. ..$ : chr [1:199] "ypred[1,1]" "ypred[2,1]" "ypred[3,1]" "ypred[4,1]" ...
-#>  $ forecasts         : NULL
-#>  - attr(*, "class")= chr "mvgam_forecast"
    +
    hc <- hindcast(model1)
+str(hc)
+#> List of 15
+#>  $ call              :Class 'formula'  language count ~ s(year_fac, bs = "re") - 1
+#>   .. ..- attr(*, ".Environment")=<environment: R_GlobalEnv> 
+#>  $ trend_call        : NULL
+#>  $ family            : chr "poisson"
+#>  $ trend_model       : chr "None"
+#>  $ drift             : logi FALSE
+#>  $ use_lv            : logi FALSE
+#>  $ fit_engine        : chr "stan"
+#>  $ type              : chr "response"
+#>  $ series_names      : chr "PP"
+#>  $ train_observations:List of 1
+#>   ..$ PP: int [1:199] 0 1 2 NA 10 NA NA 16 18 12 ...
+#>  $ train_times       : num [1:199] 1 2 3 4 5 6 7 8 9 10 ...
+#>  $ test_observations : NULL
+#>  $ test_times        : NULL
+#>  $ hindcasts         :List of 1
+#>   ..$ PP: num [1:2000, 1:199] 9 6 10 6 12 8 10 5 8 6 ...
+#>   .. ..- attr(*, "dimnames")=List of 2
+#>   .. .. ..$ : NULL
+#>   .. .. ..$ : chr [1:199] "ypred[1,1]" "ypred[2,1]" "ypred[3,1]" "ypred[4,1]" ...
+#>  $ forecasts         : NULL
+#>  - attr(*, "class")= chr "mvgam_forecast"

    You can also extract these hindcasts on the linear predictor scale, which in this case is the log scale (our Poisson GLM used a log link function). Sometimes this can be useful for asking more targeted questions about drivers of variation:

    -
    hc <- hindcast(model1, type = 'link')
-range(hc$hindcasts$PP)
-#> [1] -1.62312  3.47602
    +
    hc <- hindcast(model1, type = 'link')
+range(hc$hindcasts$PP)
+#> [1] -1.51216  3.46162
    +

    Objects of class mvgam_forecast have an associated plot +function as well:

    +
    plot(hc)
    +

    +

    This plot can look a bit confusing as it seems like there is linear +interpolation from the end of one year to the start of the next. But +this is just due to the way the lines are automatically connected in +base plots

    In any regression analysis, a key question is whether the residuals show any patterns that can be indicative of un-modelled sources of variation. For GLMs, we can use a modified residual called the Dunn-Smyth, or randomized quantile, residual. Inspect Dunn-Smyth residuals from the model using plot.mvgam with type = 'residuals'

    -
    plot(model1, type = 'residuals')
    -

    +
    plot(model1, type = 'residuals')
    +

    @@ -1216,56 +1238,65 @@

    Automatic forecasting for new data

    testing sets before re-running the model. We can then supply the test set as newdata. For splitting, we will make use of the filter function from dplyr

    -
    model_data %>% 
-  dplyr::filter(time <= 160) -> data_train 
-model_data %>% 
-  dplyr::filter(time > 160) -> data_test
    -
    model1b <- mvgam(count ~ s(year_fac, bs = 're') - 1,
-                 family = poisson(),
-                 data = data_train,
-                 newdata = data_test)
    -

    We can view the test data in the forecast plot to see that the +

    model_data %>% 
+  dplyr::filter(time <= 160) -> data_train 
+model_data %>% 
+  dplyr::filter(time > 160) -> data_test
    +
    model1b <- mvgam(count ~ s(year_fac, bs = 're') - 1,
+                family = poisson(),
+                data = data_train,
+                newdata = data_test)
    +

    Repeating the plots above gives insight into how the model’s +hierarchical prior formulation provides all the structure needed to +sample values for un-modelled years

    +
    plot(model1b, type = 're')
    +

    +
    plot(model1b, type = 'forecast')
    +

    +
    #> Out of sample DRPS:
+#> [1] 182.6177
    +

    We can also view the test data in the forecast plot to see that the predictions do not capture the temporal variation in the test set

    -
    plot(model1b, type = 'forecast', newdata = data_test)
-#> Out of sample DRPS:
-#> 179.97371575
    -

    +
    plot(model1b, type = 'forecast', newdata = data_test)
    +

    +
    #> Out of sample DRPS:
+#> [1] 182.6177

    As with the hindcast function, we can use the forecast function to automatically extract the posterior distributions for these predictions. This also returns an object of class mvgam_forecast, but now it will contain both the hindcasts and forecasts for each series in the data:

    -
    fc <- forecast(model1b)
-str(fc)
-#> List of 16
-#>  $ call              :Class 'formula'  language count ~ s(year_fac, bs = "re") - 1
-#>   .. ..- attr(*, ".Environment")=<environment: 0x0000026502c9ba10> 
-#>  $ trend_call        : NULL
-#>  $ family            : chr "poisson"
-#>  $ family_pars       : NULL
-#>  $ trend_model       : chr "None"
-#>  $ drift             : logi FALSE
-#>  $ use_lv            : logi FALSE
-#>  $ fit_engine        : chr "stan"
-#>  $ type              : chr "response"
-#>  $ series_names      : Factor w/ 1 level "PP": 1
-#>  $ train_observations:List of 1
-#>   ..$ PP: int [1:160] 0 1 2 NA 10 NA NA 16 18 12 ...
-#>  $ train_times       : num [1:160] 1 2 3 4 5 6 7 8 9 10 ...
-#>  $ test_observations :List of 1
-#>   ..$ PP: int [1:39] NA 0 0 10 3 14 18 NA 28 46 ...
-#>  $ test_times        : num [1:39] 161 162 163 164 165 166 167 168 169 170 ...
-#>  $ hindcasts         :List of 1
-#>   ..$ PP: num [1:2000, 1:160] 14 7 5 9 5 7 10 7 11 5 ...
-#>   .. ..- attr(*, "dimnames")=List of 2
-#>   .. .. ..$ : NULL
-#>   .. .. ..$ : chr [1:160] "ypred[1,1]" "ypred[2,1]" "ypred[3,1]" "ypred[4,1]" ...
-#>  $ forecasts         :List of 1
-#>   ..$ PP: num [1:2000, 1:39] 8 13 16 15 15 11 10 7 7 4 ...
-#>   .. ..- attr(*, "dimnames")=List of 2
-#>   .. .. ..$ : NULL
-#>   .. .. ..$ : chr [1:39] "ypred[161,1]" "ypred[162,1]" "ypred[163,1]" "ypred[164,1]" ...
-#>  - attr(*, "class")= chr "mvgam_forecast"
    +
    fc <- forecast(model1b)
+str(fc)
+#> List of 16
+#>  $ call              :Class 'formula'  language count ~ s(year_fac, bs = "re") - 1
+#>   .. ..- attr(*, ".Environment")=<environment: R_GlobalEnv> 
+#>  $ trend_call        : NULL
+#>  $ family            : chr "poisson"
+#>  $ family_pars       : NULL
+#>  $ trend_model       : chr "None"
+#>  $ drift             : logi FALSE
+#>  $ use_lv            : logi FALSE
+#>  $ fit_engine        : chr "stan"
+#>  $ type              : chr "response"
+#>  $ series_names      : Factor w/ 1 level "PP": 1
+#>  $ train_observations:List of 1
+#>   ..$ PP: int [1:160] 0 1 2 NA 10 NA NA 16 18 12 ...
+#>  $ train_times       : num [1:160] 1 2 3 4 5 6 7 8 9 10 ...
+#>  $ test_observations :List of 1
+#>   ..$ PP: int [1:39] NA 0 0 10 3 14 18 NA 28 46 ...
+#>  $ test_times        : num [1:39] 161 162 163 164 165 166 167 168 169 170 ...
+#>  $ hindcasts         :List of 1
+#>   ..$ PP: num [1:2000, 1:160] 10 7 8 11 6 11 9 11 5 2 ...
+#>   .. ..- attr(*, "dimnames")=List of 2
+#>   .. .. ..$ : NULL
+#>   .. .. ..$ : chr [1:160] "ypred[1,1]" "ypred[2,1]" "ypred[3,1]" "ypred[4,1]" ...
+#>  $ forecasts         :List of 1
+#>   ..$ PP: num [1:2000, 1:39] 5 12 10 7 7 8 11 14 8 12 ...
+#>   .. ..- attr(*, "dimnames")=List of 2
+#>   .. .. ..$ : NULL
+#>   .. .. ..$ : chr [1:39] "ypred[161,1]" "ypred[162,1]" "ypred[163,1]" "ypred[164,1]" ...
+#>  - attr(*, "class")= chr "mvgam_forecast"

    Adding predictors as “fixed” effects

    @@ -1274,11 +1305,11 @@

    Adding predictors as “fixed” effects

    our observations. Predictors are easily incorporated into GLMs / GAMs. Here, we will update the model from above by including a parametric (fixed) effect of ndvi as a linear predictor:

    -
    model2 <- mvgam(count ~ s(year_fac, bs = 're') + 
-                  ndvi - 1,
-                family = poisson(),
-                data = data_train,
-                newdata = data_test)
    +
    model2 <- mvgam(count ~ s(year_fac, bs = 're') + 
+                  ndvi - 1,
+                family = poisson(),
+                data = data_train,
+                newdata = data_test)

    The model can be described mathematically as follows: \[\begin{align*} \boldsymbol{count}_t & \sim \text{Poisson}(\lambda_t) \\ log(\lambda_t) & = \beta_{year[year_t]} + \beta_{ndvi} * @@ -1288,140 +1319,145 @@

    Adding predictors as “fixed” effects

    Where the \(\beta_{year}\) effects are the same as before but we now have another predictor \((\beta_{ndvi})\) that applies to the ndvi value at each timepoint \(t\). Inspect the summary of this model

    -
    summary(model2)
-#> GAM formula:
-#> count ~ ndvi + s(year_fac, bs = "re") - 1
-#> <environment: 0x0000026502c9ba10>
-#> 
-#> Family:
-#> poisson
-#> 
-#> Link function:
-#> log
-#> 
-#> Trend model:
-#> None
-#> 
-#> N series:
-#> 1 
-#> 
-#> N timepoints:
-#> 199 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> GAM coefficient (beta) estimates:
-#>                2.5%  50% 97.5% Rhat n_eff
-#> ndvi           0.32 0.39  0.46    1  1941
-#> s(year_fac).1  1.10 1.40  1.70    1  2605
-#> s(year_fac).2  1.80 2.00  2.20    1  2245
-#> s(year_fac).3  2.20 2.40  2.60    1  2285
-#> s(year_fac).4  2.30 2.50  2.70    1  2014
-#> s(year_fac).5  1.20 1.40  1.60    1  2363
-#> s(year_fac).6  1.00 1.30  1.50    1  2822
-#> s(year_fac).7  1.10 1.40  1.70    1  2801
-#> s(year_fac).8  2.10 2.30  2.50    1  1854
-#> s(year_fac).9  2.70 2.90  3.00    1  1900
-#> s(year_fac).10 2.00 2.20  2.40    1  2160
-#> s(year_fac).11 2.30 2.40  2.60    1  2236
-#> s(year_fac).12 2.50 2.70  2.80    1  2288
-#> s(year_fac).13 1.40 1.60  1.90    1  2756
-#> s(year_fac).14 0.67 2.00  3.30    1  1454
-#> s(year_fac).15 0.68 2.00  3.30    1  1552
-#> s(year_fac).16 0.61 2.00  3.20    1  1230
-#> s(year_fac).17 0.60 2.00  3.20    1  1755
-#> 
-#> GAM group-level estimates:
-#>                   2.5%  50% 97.5% Rhat n_eff
-#> mean(s(year_fac)) 1.60 2.00  2.30    1   375
-#> sd(s(year_fac))   0.42 0.59  0.99    1   419
-#> 
-#> Approximate significance of GAM smooths:
-#>             edf Ref.df Chi.sq p-value    
-#> s(year_fac)  10     17   2971  <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 8:47:27 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +
    summary(model2)
+#> GAM formula:
+#> count ~ ndvi + s(year_fac, bs = "re") - 1
+#> 
+#> Family:
+#> poisson
+#> 
+#> Link function:
+#> log
+#> 
+#> Trend model:
+#> None
+#> 
+#> N series:
+#> 1 
+#> 
+#> N timepoints:
+#> 160 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> GAM coefficient (beta) estimates:
+#>                2.5%  50% 97.5% Rhat n_eff
+#> ndvi           0.32 0.39  0.46    1  1696
+#> s(year_fac).1  1.10 1.40  1.70    1  2512
+#> s(year_fac).2  1.80 2.00  2.20    1  2210
+#> s(year_fac).3  2.20 2.40  2.60    1  2109
+#> s(year_fac).4  2.30 2.50  2.70    1  1780
+#> s(year_fac).5  1.20 1.40  1.60    1  2257
+#> s(year_fac).6  1.00 1.30  1.50    1  2827
+#> s(year_fac).7  1.10 1.40  1.70    1  2492
+#> s(year_fac).8  2.10 2.30  2.50    1  2188
+#> s(year_fac).9  2.70 2.90  3.00    1  2014
+#> s(year_fac).10 2.00 2.20  2.40    1  2090
+#> s(year_fac).11 2.30 2.40  2.60    1  1675
+#> s(year_fac).12 2.50 2.70  2.80    1  2108
+#> s(year_fac).13 1.40 1.60  1.80    1  2161
+#> s(year_fac).14 0.46 2.00  3.20    1  1849
+#> s(year_fac).15 0.53 2.00  3.30    1  1731
+#> s(year_fac).16 0.53 2.00  3.30    1  1859
+#> s(year_fac).17 0.59 1.90  3.20    1  1761
+#> 
+#> GAM group-level estimates:
+#>                   2.5%  50% 97.5% Rhat n_eff
+#> mean(s(year_fac))  1.6 2.00   2.3 1.01   397
+#> sd(s(year_fac))    0.4 0.59   1.0 1.01   395
+#> 
+#> Approximate significance of GAM smooths:
+#>              edf Ref.df Chi.sq p-value    
+#> s(year_fac) 11.2     17   3096  <2e-16 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Tue Apr 16 1:00:50 PM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

    Rather than printing the summary each time, we can also quickly look at the posterior empirical quantiles for the fixed effect of ndvi (and other linear predictor coefficients) using coef:

    -
    coef(model2)
-#>                     2.5%      50%     97.5% Rhat n_eff
-#> ndvi           0.3181071 0.388789 0.4593694    1  1941
-#> s(year_fac).1  1.1403257 1.401500 1.6865907    1  2605
-#> s(year_fac).2  1.7973795 2.001035 2.2164728    1  2245
-#> s(year_fac).3  2.1907445 2.380020 2.5654575    1  2285
-#> s(year_fac).4  2.3191002 2.508015 2.6922312    1  2014
-#> s(year_fac).5  1.1906135 1.421775 1.6474892    1  2363
-#> s(year_fac).6  1.0297390 1.273005 1.5119025    1  2822
-#> s(year_fac).7  1.1386545 1.416695 1.6901837    1  2801
-#> s(year_fac).8  2.0805780 2.275875 2.4541855    1  1854
-#> s(year_fac).9  2.7105088 2.854695 2.9904035    1  1900
-#> s(year_fac).10 1.9784170 2.185665 2.3829547    1  2160
-#> s(year_fac).11 2.2702520 2.439920 2.6018802    1  2236
-#> s(year_fac).12 2.5377335 2.694410 2.8427060    1  2288
-#> s(year_fac).13 1.3582277 1.614790 1.8549620    1  2756
-#> s(year_fac).14 0.6747114 1.981380 3.3241242    1  1454
-#> s(year_fac).15 0.6760184 1.965565 3.2735972    1  1552
-#> s(year_fac).16 0.6100672 1.984980 3.2413580    1  1230
-#> s(year_fac).17 0.5969866 1.971725 3.2093065    1  1755
    -

    Look at the estimated effect of ndvi using using a -histogram. This can be done by first extracting the posterior -coefficients:

    -
    beta_post <- as.data.frame(model2, variable = 'betas')
-dplyr::glimpse(beta_post)
-#> Rows: 2,000
-#> Columns: 18
-#> $ ndvi             <dbl> 0.439648, 0.384196, 0.413367, 0.366973, 0.404344, 0.4…
-#> $ `s(year_fac).1`  <dbl> 1.42732, 1.53312, 1.22096, 1.23654, 1.26042, 1.28158,…
-#> $ `s(year_fac).2`  <dbl> 1.96723, 2.09795, 1.93254, 2.02153, 2.08334, 1.88701,…
-#> $ `s(year_fac).3`  <dbl> 2.27870, 2.37000, 2.29162, 2.36628, 2.29201, 2.38041,…
-#> $ `s(year_fac).4`  <dbl> 2.37015, 2.60912, 2.43459, 2.50683, 2.52586, 2.54542,…
-#> $ `s(year_fac).5`  <dbl> 1.28135, 1.38028, 1.39677, 1.43385, 1.36603, 1.40265,…
-#> $ `s(year_fac).6`  <dbl> 1.08797, 1.08143, 1.41139, 1.32584, 1.22344, 1.39926,…
-#> $ `s(year_fac).7`  <dbl> 1.44054, 1.56645, 1.31643, 1.48867, 1.37964, 1.47620,…
-#> $ `s(year_fac).8`  <dbl> 2.15992, 2.33356, 2.20094, 2.28246, 2.21501, 2.25253,…
-#> $ `s(year_fac).9`  <dbl> 2.75921, 2.88033, 2.78019, 2.93305, 2.78423, 2.83695,…
-#> $ `s(year_fac).10` <dbl> 1.88597, 2.00190, 2.27773, 2.19950, 2.14239, 2.05914,…
-#> $ `s(year_fac).11` <dbl> 2.30656, 2.53149, 2.47414, 2.61563, 2.23886, 2.28949,…
-#> $ `s(year_fac).12` <dbl> 2.60053, 2.67232, 2.56650, 2.61523, 2.77591, 2.78755,…
-#> $ `s(year_fac).13` <dbl> 1.49833, 1.65298, 1.59788, 1.49292, 1.91593, 1.46407,…
-#> $ `s(year_fac).14` <dbl> 2.275730, 1.633320, 2.074560, 2.935380, 2.663920, 1.3…
-#> $ `s(year_fac).15` <dbl> 1.405470, 2.233280, 2.326930, 1.424470, 1.962880, 2.6…
-#> $ `s(year_fac).16` <dbl> 1.809570, 1.569380, 1.961950, 2.647790, 2.515950, 1.1…
-#> $ `s(year_fac).17` <dbl> 2.672570, 1.177650, 3.133890, 1.256500, 1.641950, 1.9…
    +
    coef(model2)
+#>                     2.5%       50%     97.5% Rhat n_eff
+#> ndvi           0.3198694 0.3899835 0.4571083    1  1696
+#> s(year_fac).1  1.1176373 1.4085900 1.6603838    1  2512
+#> s(year_fac).2  1.8008470 2.0005000 2.2003670    1  2210
+#> s(year_fac).3  2.1842727 2.3822950 2.5699363    1  2109
+#> s(year_fac).4  2.3267037 2.5022700 2.6847912    1  1780
+#> s(year_fac).5  1.1945853 1.4215950 1.6492038    1  2257
+#> s(year_fac).6  1.0332160 1.2743050 1.5091052    1  2827
+#> s(year_fac).7  1.1467567 1.4119100 1.6751850    1  2492
+#> s(year_fac).8  2.0710285 2.2713050 2.4596285    1  2188
+#> s(year_fac).9  2.7198967 2.8557300 2.9874662    1  2014
+#> s(year_fac).10 1.9798730 2.1799600 2.3932595    1  2090
+#> s(year_fac).11 2.2734940 2.4374700 2.6130482    1  1675
+#> s(year_fac).12 2.5421157 2.6935350 2.8431822    1  2108
+#> s(year_fac).13 1.3786087 1.6177850 1.8495872    1  2161
+#> s(year_fac).14 0.4621041 1.9744700 3.2480377    1  1849
+#> s(year_fac).15 0.5293684 2.0014200 3.2766722    1  1731
+#> s(year_fac).16 0.5285142 1.9786450 3.2859085    1  1859
+#> s(year_fac).17 0.5909969 1.9462850 3.2306940    1  1761
    +

    Look at the estimated effect of ndvi using +plot.mvgam with type = 'pterms'

    +
    plot(model2, type = 'pterms')
    +

    +

    This plot indicates a positive linear effect of ndvi on +log(counts). But it may be easier to visualise using a +histogram, especially for parametric (linear) effects. This can be done +by first extracting the posterior coefficients as we did in the first +example:

    +
    beta_post <- as.data.frame(model2, variable = 'betas')
+dplyr::glimpse(beta_post)
+#> Rows: 2,000
+#> Columns: 18
+#> $ ndvi             <dbl> 0.330568, 0.398734, 0.357498, 0.484288, 0.380087, 0.3…
+#> $ `s(year_fac).1`  <dbl> 1.55868, 1.27949, 1.24414, 1.02997, 1.64712, 1.07519,…
+#> $ `s(year_fac).2`  <dbl> 1.98967, 2.00846, 2.07493, 1.84431, 2.01590, 2.16466,…
+#> $ `s(year_fac).3`  <dbl> 2.41434, 2.16020, 2.67324, 2.33332, 2.32415, 2.45516,…
+#> $ `s(year_fac).4`  <dbl> 2.62215, 2.53992, 2.50659, 2.23671, 2.56663, 2.40054,…
+#> $ `s(year_fac).5`  <dbl> 1.37221, 1.44795, 1.53019, 1.27623, 1.50771, 1.49515,…
+#> $ `s(year_fac).6`  <dbl> 1.323980, 1.220200, 1.165610, 1.271620, 1.193820, 1.3…
+#> $ `s(year_fac).7`  <dbl> 1.52005, 1.30735, 1.42566, 1.13335, 1.61581, 1.31853,…
+#> $ `s(year_fac).8`  <dbl> 2.40223, 2.20021, 2.44366, 2.17192, 2.20837, 2.33066,…
+#> $ `s(year_fac).9`  <dbl> 2.91580, 2.90942, 2.87679, 2.64941, 2.85401, 2.78744,…
+#> $ `s(year_fac).10` <dbl> 2.46559, 2.01466, 2.08319, 2.01400, 2.22965, 2.26523,…
+#> $ `s(year_fac).11` <dbl> 2.52118, 2.45406, 2.46667, 2.20664, 2.42495, 2.46256,…
+#> $ `s(year_fac).12` <dbl> 2.72360, 2.63546, 2.86718, 2.59035, 2.76576, 2.56130,…
+#> $ `s(year_fac).13` <dbl> 1.67388, 1.50790, 1.52463, 1.39004, 1.72927, 1.61023,…
+#> $ `s(year_fac).14` <dbl> 2.583650, 2.034240, 1.819820, 1.579280, 2.426880, 1.8…
+#> $ `s(year_fac).15` <dbl> 2.57365, 2.28723, 1.67404, 1.46796, 2.49512, 2.71230,…
+#> $ `s(year_fac).16` <dbl> 1.801660, 2.185540, 1.756500, 2.098760, 2.270640, 1.8…
+#> $ `s(year_fac).17` <dbl> 0.886081, 3.409300, -0.371795, 2.494990, 1.822150, 2.…

    The posterior distribution for the effect of ndvi is stored in the ndvi column. A quick histogram confirms our inference that log(counts) respond positively to increases in ndvi:

    -
    hist(beta_post$ndvi,
-     xlim = c(-1 * max(abs(beta_post$ndvi)),
-              max(abs(beta_post$ndvi))),
-     col = 'darkred',
-     border = 'white',
-     xlab = expression(beta[NDVI]),
-     ylab = '',
-     yaxt = 'n',
-     main = '',
-     lwd = 2)
-abline(v = 0, lwd = 2.5)
    -

    +
    hist(beta_post$ndvi,
+     xlim = c(-1 * max(abs(beta_post$ndvi)),
+              max(abs(beta_post$ndvi))),
+     col = 'darkred',
+     border = 'white',
+     xlab = expression(beta[NDVI]),
+     ylab = '',
+     yaxt = 'n',
+     main = '',
+     lwd = 2)
+abline(v = 0, lwd = 2.5)
    +

    marginaleffects support

    Given our model used a nonlinear link function (log link in this @@ -1431,13 +1467,25 @@

    marginaleffects support

    this relatively straightforward. Objects of class mvgam can be used with marginaleffects to inspect contrasts, scenario-based predictions, conditional and marginal effects, all on the -outcome scale. Like brms, mvgam has the simple +outcome scale. Here we will use the plot_predictions +function from marginaleffects to inspect the conditional +effect of ndvi (use ?plot_predictions for +guidance on how to modify these plots):

    +
    plot_predictions(model2, 
+                 condition = "ndvi",
+                 # include the observed count values
+                 # as points, and show rugs for the observed
+                 # ndvi and count values on the axes
+                 points = 0.5, rug = TRUE)
    +

    +

    Now it is easier to get a sense of the nonlinear but positive +relationship estimated between ndvi and count. +Like brms, mvgam has the simple conditional_effects function to make quick and informative -plots for main effects, which rely on marginaleffects -support. This will likely be your go-to function for quickly -understanding patterns from fitted mvgam models

    -
    conditional_effects(model2)
    -

    +plots for main effects. This will likely be your go-to function for +quickly understanding patterns from fitted mvgam models

    +
    plot(conditional_effects(model2), ask = FALSE)
    +

    @@ -1472,11 +1520,11 @@

    Adding predictors as smooths

    b-spline basis for the temporal smooth. Because we no longer have intercepts for each year, we also retain the primary intercept term in this model (there is no -1 in the formula now):

    -
    model3 <- mvgam(count ~ s(time, bs = 'bs', k = 15) + 
-                  ndvi,
-                family = poisson(),
-                data = data_train,
-                newdata = data_test)
    +
    model3 <- mvgam(count ~ s(time, bs = 'bs', k = 15) + 
+                  ndvi,
+                family = poisson(),
+                data = data_train,
+                newdata = data_test)

    The model can be described mathematically as follows: \[\begin{align*} \boldsymbol{count}_t & \sim \text{Poisson}(\lambda_t) \\ log(\lambda_t) & = f(\boldsymbol{time})_t + \beta_{ndvi} * @@ -1495,151 +1543,178 @@

    Adding predictors as smooths

    wiggly spline. Note that sometimes there are multiple smoothing penalties that contribute to the covariance matrix, but I am only showing one here for simplicity. View the summary as before

    -
    summary(model3)
-#> GAM formula:
-#> count ~ s(time, bs = "bs", k = 15) + ndvi
-#> <environment: 0x0000026502c9ba10>
-#> 
-#> Family:
-#> poisson
-#> 
-#> Link function:
-#> log
-#> 
-#> Trend model:
-#> None
-#> 
-#> N series:
-#> 1 
-#> 
-#> N timepoints:
-#> 199 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> GAM coefficient (beta) estimates:
-#>              2.5%   50% 97.5% Rhat n_eff
-#> (Intercept)  2.00  2.10  2.20    1   852
-#> ndvi         0.26  0.33  0.40    1   860
-#> s(time).1   -2.10 -1.10 -0.10    1   618
-#> s(time).2    0.43  1.30  2.20    1   493
-#> s(time).3   -0.50  0.42  1.40    1   445
-#> s(time).4    1.60  2.40  3.40    1   445
-#> s(time).5   -1.20 -0.23  0.74    1   467
-#> s(time).6   -0.56  0.34  1.40    1   487
-#> s(time).7   -1.50 -0.54  0.46    1   492
-#> s(time).8    0.59  1.40  2.50    1   450
-#> s(time).9    1.10  2.00  3.00    1   427
-#> s(time).10  -0.35  0.51  1.50    1   459
-#> s(time).11   0.81  1.70  2.70    1   429
-#> s(time).12   0.68  1.50  2.30    1   450
-#> s(time).13  -1.20 -0.35  0.61    1   614
-#> s(time).14  -7.20 -4.10 -1.20    1   513
-#> 
-#> Approximate significance of GAM smooths:
-#>          edf Ref.df Chi.sq p-value    
-#> s(time) 8.72     14    771  <2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 8:48:31 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +
    summary(model3)
+#> GAM formula:
+#> count ~ s(time, bs = "bs", k = 15) + ndvi
+#> 
+#> Family:
+#> poisson
+#> 
+#> Link function:
+#> log
+#> 
+#> Trend model:
+#> None
+#> 
+#> N series:
+#> 1 
+#> 
+#> N timepoints:
+#> 160 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> GAM coefficient (beta) estimates:
+#>              2.5%   50%  97.5% Rhat n_eff
+#> (Intercept)  2.00  2.10  2.200 1.00   903
+#> ndvi         0.26  0.33  0.390 1.00   942
+#> s(time).1   -2.10 -1.10  0.029 1.01   484
+#> s(time).2    0.45  1.30  2.400 1.01   411
+#> s(time).3   -0.43  0.45  1.500 1.02   347
+#> s(time).4    1.60  2.50  3.600 1.02   342
+#> s(time).5   -1.10 -0.22  0.880 1.02   375
+#> s(time).6   -0.53  0.36  1.600 1.01   352
+#> s(time).7   -1.50 -0.51  0.560 1.01   406
+#> s(time).8    0.63  1.50  2.600 1.02   340
+#> s(time).9    1.20  2.10  3.200 1.02   346
+#> s(time).10  -0.34  0.54  1.600 1.01   364
+#> s(time).11   0.92  1.80  2.900 1.02   332
+#> s(time).12   0.67  1.50  2.500 1.01   398
+#> s(time).13  -1.20 -0.32  0.700 1.01   420
+#> s(time).14  -7.90 -4.20 -1.200 1.01   414
+#> 
+#> Approximate significance of GAM smooths:
+#>          edf Ref.df Chi.sq p-value    
+#> s(time) 9.41     14    790  <2e-16 ***
+#> ---
+#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Tue Apr 16 1:01:29 PM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)

    The summary above now contains posterior estimates for the smoothing parameters as well as the basis coefficients for the nonlinear effect of -time. We can visualize conditional_effects as -before:

    -
    conditional_effects(model3, type = 'link')
    -

    +time. We can visualize the conditional time +effect using the plot function with +type = 'smooths':

    +
    plot(model3, type = 'smooths')
    +

    +

    By default this plots shows posterior empirical quantiles, but it can +also be helpful to view some realizations of the underlying function +(here, each line is a different potential curve drawn from the posterior +of all possible curves):

    +
    plot(model3, type = 'smooths', realisations = TRUE,
+     n_realisations = 30)
    +

    +
    +

    Derivatives of smooths

    +

    A useful question when modelling using GAMs is to identify where the +function is changing most rapidly. To address this, we can plot +estimated 1st derivatives of the spline:

    +
    plot(model3, type = 'smooths', derivatives = TRUE)
    +

    +

    Here, values above >0 indicate the function was +increasing at that time point, while values <0 indicate +the function was declining. The most rapid declines appear to have been +happening around timepoints 50 and again toward the end of the training +period, for example.

    +

    Use conditional_effects again for useful plots on the +outcome scale:

    +
    plot(conditional_effects(model3), ask = FALSE)
    +

    +

    Or on the link scale:

    +
    plot(conditional_effects(model3, type = 'link'), ask = FALSE)
    +

    Inspect the underlying Stan code to gain some idea of how the spline is being penalized:

    -
    code(model3)
-#> // Stan model code generated by package mvgam
-#> data {
-#>   int<lower=0> total_obs; // total number of observations
-#>   int<lower=0> n; // number of timepoints per series
-#>   int<lower=0> n_sp; // number of smoothing parameters
-#>   int<lower=0> n_series; // number of series
-#>   int<lower=0> num_basis; // total number of basis coefficients
-#>   vector[num_basis] zero; // prior locations for basis coefficients
-#>   matrix[total_obs, num_basis] X; // mgcv GAM design matrix
-#>   array[n, n_series] int<lower=0> ytimes; // time-ordered matrix (which col in X belongs to each [time, series] observation?)
-#>   matrix[14, 28] S1; // mgcv smooth penalty matrix S1
-#>   int<lower=0> n_nonmissing; // number of nonmissing observations
-#>   array[n_nonmissing] int<lower=0> flat_ys; // flattened nonmissing observations
-#>   matrix[n_nonmissing, num_basis] flat_xs; // X values for nonmissing observations
-#>   array[n_nonmissing] int<lower=0> obs_ind; // indices of nonmissing observations
-#> }
-#> parameters {
-#>   // raw basis coefficients
-#>   vector[num_basis] b_raw;
-#>   
-#>   // smoothing parameters
-#>   vector<lower=0>[n_sp] lambda;
-#> }
-#> transformed parameters {
-#>   // basis coefficients
-#>   vector[num_basis] b;
-#>   b[1 : num_basis] = b_raw[1 : num_basis];
-#> }
-#> model {
-#>   // prior for (Intercept)...
-#>   b_raw[1] ~ student_t(3, 2.6, 2.5);
-#>   
-#>   // prior for ndvi...
-#>   b_raw[2] ~ student_t(3, 0, 2);
-#>   
-#>   // prior for s(time)...
-#>   b_raw[3 : 16] ~ multi_normal_prec(zero[3 : 16],
-#>                                     S1[1 : 14, 1 : 14] * lambda[1]
-#>                                     + S1[1 : 14, 15 : 28] * lambda[2]);
-#>   
-#>   // priors for smoothing parameters
-#>   lambda ~ normal(5, 30);
-#>   {
-#>     // likelihood functions
-#>     flat_ys ~ poisson_log_glm(flat_xs, 0.0, b);
-#>   }
-#> }
-#> generated quantities {
-#>   vector[total_obs] eta;
-#>   matrix[n, n_series] mus;
-#>   vector[n_sp] rho;
-#>   array[n, n_series] int ypred;
-#>   rho = log(lambda);
-#>   
-#>   // posterior predictions
-#>   eta = X * b;
-#>   for (s in 1 : n_series) {
-#>     mus[1 : n, s] = eta[ytimes[1 : n, s]];
-#>     ypred[1 : n, s] = poisson_log_rng(mus[1 : n, s]);
-#>   }
-#> }
    +
    code(model3)
+#> // Stan model code generated by package mvgam
+#> data {
+#>   int<lower=0> total_obs; // total number of observations
+#>   int<lower=0> n; // number of timepoints per series
+#>   int<lower=0> n_sp; // number of smoothing parameters
+#>   int<lower=0> n_series; // number of series
+#>   int<lower=0> num_basis; // total number of basis coefficients
+#>   vector[num_basis] zero; // prior locations for basis coefficients
+#>   matrix[total_obs, num_basis] X; // mgcv GAM design matrix
+#>   array[n, n_series] int<lower=0> ytimes; // time-ordered matrix (which col in X belongs to each [time, series] observation?)
+#>   matrix[14, 28] S1; // mgcv smooth penalty matrix S1
+#>   int<lower=0> n_nonmissing; // number of nonmissing observations
+#>   array[n_nonmissing] int<lower=0> flat_ys; // flattened nonmissing observations
+#>   matrix[n_nonmissing, num_basis] flat_xs; // X values for nonmissing observations
+#>   array[n_nonmissing] int<lower=0> obs_ind; // indices of nonmissing observations
+#> }
+#> parameters {
+#>   // raw basis coefficients
+#>   vector[num_basis] b_raw;
+#>   
+#>   // smoothing parameters
+#>   vector<lower=0>[n_sp] lambda;
+#> }
+#> transformed parameters {
+#>   // basis coefficients
+#>   vector[num_basis] b;
+#>   b[1 : num_basis] = b_raw[1 : num_basis];
+#> }
+#> model {
+#>   // prior for (Intercept)...
+#>   b_raw[1] ~ student_t(3, 2.6, 2.5);
+#>   
+#>   // prior for ndvi...
+#>   b_raw[2] ~ student_t(3, 0, 2);
+#>   
+#>   // prior for s(time)...
+#>   b_raw[3 : 16] ~ multi_normal_prec(zero[3 : 16],
+#>                                     S1[1 : 14, 1 : 14] * lambda[1]
+#>                                     + S1[1 : 14, 15 : 28] * lambda[2]);
+#>   
+#>   // priors for smoothing parameters
+#>   lambda ~ normal(5, 30);
+#>   {
+#>     // likelihood functions
+#>     flat_ys ~ poisson_log_glm(flat_xs, 0.0, b);
+#>   }
+#> }
+#> generated quantities {
+#>   vector[total_obs] eta;
+#>   matrix[n, n_series] mus;
+#>   vector[n_sp] rho;
+#>   array[n, n_series] int ypred;
+#>   rho = log(lambda);
+#>   
+#>   // posterior predictions
+#>   eta = X * b;
+#>   for (s in 1 : n_series) {
+#>     mus[1 : n, s] = eta[ytimes[1 : n, s]];
+#>     ypred[1 : n, s] = poisson_log_rng(mus[1 : n, s]);
+#>   }
+#> }

    The line below // prior for s(time)... shows how the spline basis coefficients are drawn from a zero-centred multivariate normal distribution. The precision matrix \(S\) is penalized by two different smoothing parameters (the \(\lambda\)’s) to enforce smoothness and reduce overfitting

    +

    Latent dynamics in mvgam

    Forecasts from the above model are not ideal:

    -
    plot(model3, type = 'forecast', newdata = data_test)
-#> Out of sample DRPS:
-#> 287.6505975
    -

    +
    plot(model3, type = 'forecast', newdata = data_test)
    +

    +
    #> Out of sample DRPS:
+#> [1] 288.3844

    Why is this happening? The forecasts are driven almost entirely by variation in the temporal spline, which is extrapolating linearly forever beyond the edge of the training data. Any slight @@ -1648,14 +1723,14 @@

    Latent dynamics in mvgam

    functions into the out-of-sample test set for the two models. Here are the extrapolated functions for the first model, with 15 basis functions:

    -
    plot_mvgam_smooth(model3, smooth = 's(time)',
-                  # feed newdata to the plot function to generate
-                  # predictions of the temporal smooth to the end of the 
-                  # testing period
-                  newdata = data.frame(time = 1:max(data_test$time),
-                                       ndvi = 0))
-abline(v = max(data_train$time), lty = 'dashed', lwd = 2)
    -

    +
    plot_mvgam_smooth(model3, smooth = 's(time)',
+                  # feed newdata to the plot function to generate
+                  # predictions of the temporal smooth to the end of the 
+                  # testing period
+                  newdata = data.frame(time = 1:max(data_test$time),
+                                       ndvi = 0))
+abline(v = max(data_train$time), lty = 'dashed', lwd = 2)
    +

    This model is not doing well. Clearly we need to somehow account for the strong temporal autocorrelation when modelling these data without using a smooth function of time. Now onto another prominent @@ -1670,11 +1745,11 @@

    Latent dynamics in mvgam

    rather than the parametric term that was used above, to showcase that mvgam can include combinations of smooths and dynamic components:

    -
    model4 <- mvgam(count ~ s(ndvi, k = 6),
-                family = poisson(),
-                data = data_train,
-                newdata = data_test,
-                trend_model = 'AR1')
    +
    model4 <- mvgam(count ~ s(ndvi, k = 6),
+                family = poisson(),
+                data = data_train,
+                newdata = data_test,
+                trend_model = 'AR1')

    The model can be described mathematically as follows: \[\begin{align*} \boldsymbol{count}_t & \sim \text{Poisson}(\lambda_t) \\ log(\lambda_t) & = f(\boldsymbol{ndvi})_t + z_t \\ @@ -1692,81 +1767,84 @@

    Latent dynamics in mvgam

    more realistic estimates of the residual autocorrelation parameters. Summarise the model to see how it now returns posterior summaries for the latent AR1 process:

    -
    summary(model4)
-#> GAM formula:
-#> count ~ s(ndvi, k = 6)
-#> <environment: 0x0000026502c9ba10>
-#> 
-#> Family:
-#> poisson
-#> 
-#> Link function:
-#> log
-#> 
-#> Trend model:
-#> AR1
-#> 
-#> N series:
-#> 1 
-#> 
-#> N timepoints:
-#> 199 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
-#> Total post-warmup draws = 2000
-#> 
-#> 
-#> GAM coefficient (beta) estimates:
-#>               2.5%     50% 97.5% Rhat n_eff
-#> (Intercept)  1.100  1.9000 2.500 1.08    73
-#> s(ndvi).1   -0.078  0.0096 0.180 1.01   369
-#> s(ndvi).2   -0.160  0.0150 0.270 1.03   200
-#> s(ndvi).3   -0.051 -0.0015 0.046 1.02   292
-#> s(ndvi).4   -0.270  0.1100 1.300 1.03   187
-#> s(ndvi).5   -0.072  0.1400 0.340 1.01   661
-#> 
-#> Approximate significance of GAM smooths:
-#>          edf Ref.df Chi.sq p-value
-#> s(ndvi) 1.35      5   74.7    0.15
-#> 
-#> Latent trend parameter AR estimates:
-#>          2.5%  50% 97.5% Rhat n_eff
-#> ar1[1]   0.70 0.81  0.92 1.01   308
-#> sigma[1] 0.67 0.80  0.96 1.01   501
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhats above 1.05 found for 49 parameters
-#>  *Diagnose further to investigate why the chains have not mixed
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 8:49:55 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +
    summary(model4)
+#> GAM formula:
+#> count ~ s(ndvi, k = 6)
+#> 
+#> Family:
+#> poisson
+#> 
+#> Link function:
+#> log
+#> 
+#> Trend model:
+#> AR1
+#> 
+#> N series:
+#> 1 
+#> 
+#> N timepoints:
+#> 160 
+#> 
+#> Status:
+#> Fitted using Stan 
+#> 4 chains, each with iter = 1000; warmup = 500; thin = 1 
+#> Total post-warmup draws = 2000
+#> 
+#> 
+#> GAM coefficient (beta) estimates:
+#>               2.5%     50% 97.5% Rhat n_eff
+#> (Intercept)  1.200  1.9000 2.500 1.03    63
+#> s(ndvi).1   -0.066  0.0100 0.160 1.01   318
+#> s(ndvi).2   -0.110  0.0190 0.340 1.00   286
+#> s(ndvi).3   -0.048 -0.0019 0.051 1.00   560
+#> s(ndvi).4   -0.210  0.1200 1.500 1.01   198
+#> s(ndvi).5   -0.079  0.1500 0.360 1.01   350
+#> 
+#> Approximate significance of GAM smooths:
+#>          edf Ref.df Chi.sq p-value
+#> s(ndvi) 2.26      5   87.8     0.1
+#> 
+#> Latent trend parameter AR estimates:
+#>          2.5%  50% 97.5% Rhat n_eff
+#> ar1[1]   0.70 0.81  0.92 1.01   234
+#> sigma[1] 0.68 0.80  0.96 1.00   488
+#> 
+#> Stan MCMC diagnostics:
+#> n_eff / iter looks reasonable for all parameters
+#> Rhat looks reasonable for all parameters
+#> 0 of 2000 iterations ended with a divergence (0%)
+#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
+#> E-FMI indicated no pathological behavior
+#> 
+#> Samples were drawn using NUTS(diag_e) at Tue Apr 16 1:02:26 PM 2024.
+#> For each parameter, n_eff is a crude measure of effective sample size,
+#> and Rhat is the potential scale reduction factor on split MCMC chains
+#> (at convergence, Rhat = 1)
    +

    View conditional smooths for the ndvi effect:

    +
    plot_predictions(model4, 
+                 condition = "ndvi",
+                 points = 0.5, rug = TRUE)
    +

    View posterior hindcasts / forecasts and compare against the out of sample test data

    -
    plot(model4, type = 'forecast', newdata = data_test)
-#> Out of sample DRPS:
-#> 150.62898975
    -

    +
    plot(model4, type = 'forecast', newdata = data_test)
    +

    +
    #> Out of sample DRPS:
+#> [1] 150.5241

    The trend is evolving as an AR1 process, which we can also view:

    -
    plot(model4, type = 'trend', newdata = data_test)
    -

    +
    plot(model4, type = 'trend', newdata = data_test)
    +

    In-sample model performance can be interrogated using leave-one-out cross-validation utilities from the loo package (a higher value is preferred for this metric):

    -
    loo_compare(model3, model4)
-#> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
-
-#> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
-#>        elpd_diff se_diff
-#> model4    0.0       0.0 
-#> model3 -561.4      66.3
    +
    loo_compare(model3, model4)
+#> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
+
+#> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details.
+#>        elpd_diff se_diff
+#> model4    0.0       0.0 
+#> model3 -558.9      66.4

    The higher estimated log predictive density (ELPD) value for the dynamic model suggests it provides a better fit to the in-sample data.

    @@ -1775,12 +1853,12 @@

    Latent dynamics in mvgam

    the forecast and score functions. Here we will compare models based on their Discrete Ranked Probability Scores (a lower value is preferred for this metric)

    -
    fc_mod3 <- forecast(model3)
-fc_mod4 <- forecast(model4)
-score_mod3 <- score(fc_mod3, score = 'drps')
-score_mod4 <- score(fc_mod4, score = 'drps')
-sum(score_mod4$PP$score, na.rm = TRUE) - sum(score_mod3$PP$score, na.rm = TRUE)
-#> [1] -137.0216
    +
    fc_mod3 <- forecast(model3)
+fc_mod4 <- forecast(model4)
+score_mod3 <- score(fc_mod3, score = 'drps')
+score_mod4 <- score(fc_mod4, score = 'drps')
+sum(score_mod4$PP$score, na.rm = TRUE) - sum(score_mod3$PP$score, na.rm = TRUE)
+#> [1] -137.8603

    A strongly negative value here suggests the score for the dynamic model (model 4) is much smaller than the score for the model with a smooth function of time (model 3)

    diff --git a/inst/doc/nmixtures.R b/inst/doc/nmixtures.R index 81faebc2..a4e7a766 100644 --- a/inst/doc/nmixtures.R +++ b/inst/doc/nmixtures.R @@ -1,4 +1,4 @@ -## ----echo = FALSE------------------------------------------------------ +## ----echo = FALSE------------------------------------------------------------- NOT_CRAN <- identical(tolower(Sys.getenv("NOT_CRAN")), "true") knitr::opts_chunk$set( collapse = TRUE, @@ -7,11 +7,10 @@ knitr::opts_chunk$set( eval = NOT_CRAN ) - -## ----setup, include=FALSE---------------------------------------------- +## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, - dpi = 100, + dpi = 150, fig.asp = 0.8, fig.width = 6, out.width = "60%", @@ -34,8 +33,7 @@ options(ggplot2.discrete.colour = c("#A25050", 'darkred', "#010048")) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- set.seed(999) # Simulate observations for species 1, which shows a declining trend and 0.7 detection probability data.frame(site = 1, @@ -94,20 +92,17 @@ testdat = testdat %>% cap = 50) %>% dplyr::select(-replicate)) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- testdat$species <- factor(testdat$species, levels = unique(testdat$species)) testdat$series <- factor(testdat$series, levels = unique(testdat$series)) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- dplyr::glimpse(testdat) head(testdat, 12) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- testdat %>% # each unique combination of site*species is a separate process dplyr::mutate(trend = as.numeric(factor(paste0(site, species)))) %>% @@ -115,8 +110,7 @@ testdat %>% dplyr::distinct() -> trend_map trend_map - -## ----include = FALSE, results='hide'----------------------------------- +## ----include = FALSE, results='hide'------------------------------------------ mod <- mvgam( # the observation formula sets up linear predictors for # detection probability on the logit scale @@ -138,47 +132,41 @@ mod <- mvgam( prior(normal(1, 1.5), class = Intercept_trend)), samples = 1000) - -## ----eval = FALSE------------------------------------------------------ -## 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)), -## samples = 1000) - - -## ---------------------------------------------------------------------- +## ----eval = FALSE------------------------------------------------------------- +# 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)), +# samples = 1000) + +## ----------------------------------------------------------------------------- code(mod) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(mod) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- loo(mod) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(mod, type = 'smooths', trend_effects = TRUE) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_predictions(mod, condition = 'species', type = 'detection') + ylab('Pr(detection)') + @@ -186,8 +174,7 @@ plot_predictions(mod, condition = 'species', theme_classic() + theme(legend.position = 'none') - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- hc <- hindcast(mod, type = 'latent_N') # Function to plot latent abundance estimates vs truth @@ -240,13 +227,11 @@ plot_latentN = function(hindcasts, data, species = 'sp_1'){ title = species) } - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_latentN(hc, testdat, species = 'sp_1') plot_latentN(hc, testdat, species = 'sp_2') - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- # Date link load(url('https://github.com/doserjef/spAbundance/raw/main/data/dataNMixSim.rda')) data.one.sp <- dataNMixSim @@ -266,8 +251,7 @@ det.cov[is.na(det.cov)] <- rnorm(length(which(is.na(det.cov)))) det.cov2 <- dataNMixSim$det.covs$det.cov.2 det.cov2[is.na(det.cov2)] <- rnorm(length(which(is.na(det.cov2)))) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- mod_data <- do.call(rbind, lapply(1:NROW(data.one.sp$y), function(x){ data.frame(y = data.one.sp$y[x,], @@ -285,14 +269,12 @@ mod_data <- do.call(rbind, time = 1, cap = max(data.one.sp$y, na.rm = TRUE) + 20) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- NROW(mod_data) dplyr::glimpse(mod_data) head(mod_data) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- mod_data %>% # each unique combination of site*species is a separate process dplyr::mutate(trend = as.numeric(factor(paste0(site, species)))) %>% @@ -303,8 +285,7 @@ trend_map %>% dplyr::arrange(trend) %>% head(12) - -## ----include = FALSE, results='hide'----------------------------------- +## ----include = FALSE, results='hide'------------------------------------------ mod <- mvgam( # effects of covariates on detection probability; # here we use penalized splines for both continuous covariates @@ -336,82 +317,73 @@ mod <- mvgam( residuals = FALSE, samples = 1000) - -## ----eval=FALSE-------------------------------------------------------- -## mod <- mvgam( -## # effects of covariates on detection probability; -## # here we use penalized splines for both continuous covariates -## formula = y ~ s(det_cov, k = 4) + s(det_cov2, k = 4), -## -## # effects of the covariates on latent abundance; -## # here we use a penalized spline for the continuous covariate and -## # hierarchical intercepts for the factor covariate -## trend_formula = ~ s(abund_cov, k = 4) + -## s(abund_fac, bs = 're'), -## -## # link multiple observations to each site -## trend_map = trend_map, -## -## # nmix() family and supplied data -## family = nmix(), -## data = mod_data, -## -## # standard normal priors on key regression parameters -## priors = c(prior(std_normal(), class = 'b'), -## prior(std_normal(), class = 'Intercept'), -## prior(std_normal(), class = 'Intercept_trend'), -## prior(std_normal(), class = 'sigma_raw_trend')), -## -## # use Stan's variational inference for quicker results -## algorithm = 'meanfield', -## -## # no need to compute "series-level" residuals -## residuals = FALSE, -## samples = 1000) - - -## ---------------------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- +# mod <- mvgam( +# # effects of covariates on detection probability; +# # here we use penalized splines for both continuous covariates +# formula = y ~ s(det_cov, k = 4) + s(det_cov2, k = 4), +# +# # effects of the covariates on latent abundance; +# # here we use a penalized spline for the continuous covariate and +# # hierarchical intercepts for the factor covariate +# trend_formula = ~ s(abund_cov, k = 4) + +# s(abund_fac, bs = 're'), +# +# # link multiple observations to each site +# trend_map = trend_map, +# +# # nmix() family and supplied data +# family = nmix(), +# data = mod_data, +# +# # standard normal priors on key regression parameters +# priors = c(prior(std_normal(), class = 'b'), +# prior(std_normal(), class = 'Intercept'), +# prior(std_normal(), class = 'Intercept_trend'), +# prior(std_normal(), class = 'sigma_raw_trend')), +# +# # use Stan's variational inference for quicker results +# algorithm = 'meanfield', +# +# # no need to compute "series-level" residuals +# residuals = FALSE, +# samples = 1000) + +## ----------------------------------------------------------------------------- summary(mod, include_betas = FALSE) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- avg_predictions(mod, type = 'detection') - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- abund_plots <- plot(conditional_effects(mod, type = 'link', effects = c('abund_cov', 'abund_fac')), plot = FALSE) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- abund_plots[[1]] + ylab('Expected latent abundance') - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- abund_plots[[2]] + ylab('Expected latent abundance') - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- det_plots <- plot(conditional_effects(mod, type = 'detection', effects = c('det_cov', 'det_cov2')), plot = FALSE) - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- det_plots[[1]] + ylab('Pr(detection)') det_plots[[2]] + ylab('Pr(detection)') - -## ---------------------------------------------------------------------- +## ----------------------------------------------------------------------------- fivenum_round = function(x)round(fivenum(x, na.rm = TRUE), 2) plot_predictions(mod, diff --git a/inst/doc/nmixtures.html b/inst/doc/nmixtures.html index 0acb06b2..f92147dd 100644 --- a/inst/doc/nmixtures.html +++ b/inst/doc/nmixtures.html @@ -12,7 +12,7 @@ - + N-mixtures in mvgam @@ -340,7 +340,7 @@

    N-mixtures in mvgam

    Nicholas J Clark

    -

    2024-05-09

    +

    2024-04-16

    @@ -711,68 +711,66 @@

    Modelling with the nmix() family

    summary(mod)
 #> GAM observation formula:
 #> obs ~ species - 1
-#> <environment: 0x00000237248751d0>
-#> 
-#> GAM process formula:
-#> ~s(time, by = trend, k = 4) + species
-#> <environment: 0x00000237248751d0>
-#> 
-#> Family:
-#> nmix
-#> 
-#> Link function:
-#> log
-#> 
-#> Trend model:
-#> None
-#> 
-#> N process models:
-#> 2 
-#> 
-#> N series:
-#> 10 
-#> 
-#> N timepoints:
-#> 6 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 4 chains, each with iter = 1500; warmup = 500; thin = 1 
-#> Total post-warmup draws = 4000
-#> 
-#> 
-#> GAM observation model coefficient (beta) estimates:
-#>              2.5%   50% 97.5% Rhat n_eff
-#> speciessp_1 -0.28 0.720  1.40    1  1630
-#> speciessp_2 -1.20 0.035  0.88    1  1913
-#> 
-#> GAM process model coefficient (beta) estimates:
-#>                               2.5%     50%  97.5% Rhat n_eff
-#> (Intercept)_trend            2.700  3.0000  3.500 1.00  1453
-#> speciessp_2_trend           -1.200 -0.6300  0.140 1.00  1587
-#> s(time):trendtrend1.1_trend -0.078  0.0160  0.210 1.01   931
-#> s(time):trendtrend1.2_trend -0.250  0.0058  0.270 1.00  2384
-#> s(time):trendtrend1.3_trend -0.450 -0.2500 -0.040 1.00  1747
-#> s(time):trendtrend2.1_trend -0.210 -0.0120  0.092 1.00   849
-#> s(time):trendtrend2.2_trend -0.190  0.0290  0.530 1.00   627
-#> s(time):trendtrend2.3_trend  0.052  0.3300  0.640 1.00  2547
-#> 
-#> Approximate significance of GAM process smooths:
-#>                       edf Ref.df    F p-value
-#> s(time):seriestrend1 1.16      3 1.04    0.64
-#> s(time):seriestrend2 1.12      3 1.58    0.62
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 4000 iterations ended with a divergence (0%)
-#> 0 of 4000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Thu May 09 9:46:13 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +#> +#> GAM process formula: +#> ~s(time, by = trend, k = 4) + species +#> +#> Family: +#> nmix +#> +#> Link function: +#> log +#> +#> Trend model: +#> None +#> +#> N process models: +#> 2 +#> +#> N series: +#> 10 +#> +#> N timepoints: +#> 6 +#> +#> Status: +#> Fitted using Stan +#> 4 chains, each with iter = 1500; warmup = 500; thin = 1 +#> Total post-warmup draws = 4000 +#> +#> +#> GAM observation model coefficient (beta) estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> speciessp_1 -0.28 0.7200 1.40 1 1361 +#> speciessp_2 -1.20 -0.0075 0.89 1 1675 +#> +#> GAM process model coefficient (beta) estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> (Intercept)_trend 2.700 3.0000 3.400 1.00 1148 +#> speciessp_2_trend -1.200 -0.6100 0.190 1.00 1487 +#> s(time):trendtrend1.1_trend -0.081 0.0130 0.200 1.00 800 +#> s(time):trendtrend1.2_trend -0.230 0.0077 0.310 1.00 1409 +#> s(time):trendtrend1.3_trend -0.460 -0.2500 -0.038 1.00 1699 +#> s(time):trendtrend2.1_trend -0.220 -0.0130 0.095 1.00 995 +#> s(time):trendtrend2.2_trend -0.190 0.0320 0.500 1.01 1071 +#> s(time):trendtrend2.3_trend 0.064 0.3300 0.640 1.00 2268 +#> +#> Approximate significance of GAM process smooths: +#> edf Ref.df F p-value +#> s(time):seriestrend1 1.25 3 0.19 0.83 +#> s(time):seriestrend2 1.07 3 0.39 0.92 +#> +#> Stan MCMC diagnostics: +#> n_eff / iter looks reasonable for all parameters +#> Rhat looks reasonable for all parameters +#> 0 of 4000 iterations ended with a divergence (0%) +#> 0 of 4000 iterations saturated the maximum tree depth of 12 (0%) +#> E-FMI indicated no pathological behavior +#> +#> Samples were drawn using NUTS(diag_e) at Tue Apr 16 1:04:54 PM 2024. +#> For each parameter, n_eff is a crude measure of effective sample size, +#> and Rhat is the potential scale reduction factor on split MCMC chains +#> (at convergence, Rhat = 1)

    loo() functionality works just as it does for all mvgam models to aid in model comparison / selection (though note that Pareto K values often give warnings for mixture models so @@ -782,24 +780,24 @@

    Modelling with the nmix() family

    #> #> Computed from 4000 by 60 log-likelihood matrix #> -#> Estimate SE -#> elpd_loo -452.5 77.5 -#> p_loo 254.0 64.5 -#> looic 905.0 155.0 +#> Estimate SE +#> elpd_loo -230.4 13.8 +#> p_loo 83.3 12.7 +#> looic 460.9 27.5 #> ------ #> Monte Carlo SE of elpd_loo is NA. #> #> Pareto k diagnostic values: #> Count Pct. Min. n_eff -#> (-Inf, 0.5] (good) 29 48.3% 823 -#> (0.5, 0.7] (ok) 1 1.7% 1302 -#> (0.7, 1] (bad) 9 15.0% 49 -#> (1, Inf) (very bad) 21 35.0% 1 +#> (-Inf, 0.5] (good) 25 41.7% 1141 +#> (0.5, 0.7] (ok) 5 8.3% 390 +#> (0.7, 1] (bad) 7 11.7% 13 +#> (1, Inf) (very bad) 23 38.3% 2 #> See help('pareto-k-diagnostic') for details.

    Plot the estimated smooths of time from each species’ latent abundance process (on the log scale)

    plot(mod, type = 'smooths', trend_effects = TRUE)
    -

    +

    marginaleffects support allows for more useful prediction-based interrogations on different scales (though note that at the time of writing this Vignette, you must have the development version @@ -818,7 +816,7 @@

    Modelling with the nmix() family

    ylim(c(0, 1)) + theme_classic() + theme(legend.position = 'none') -

    +

    A common goal in N-mixture modelling is to estimate the true latent abundance. The model has automatically generated predictions for the unknown latent abundance that are conditional on the observations. We @@ -879,9 +877,9 @@

    Modelling with the nmix() family

    black line shows the true latent abundance, and the ribbons show credible intervals of our estimates:

    plot_latentN(hc, testdat, species = 'sp_1')
    -

    +

    plot_latentN(hc, testdat, species = 'sp_2')
    -

    +

    We can see that estimates for both species have correctly captured the true temporal variation and magnitudes in abundance

    @@ -946,8 +944,8 @@

    Example 2: a larger survey with possible nonlinear effects

    #> $ y <int> 1, NA, NA, NA, 2, 2, NA, 1, NA, NA, 0, 1, 0, 0, 0, 0, NA, NA… #> $ abund_cov <dbl> -0.3734384, -0.3734384, -0.3734384, 0.7064305, 0.7064305, 0.… #> $ abund_fac <fct> 3, 3, 3, 4, 4, 4, 9, 9, 9, 2, 2, 2, 3, 3, 3, 2, 2, 2, 1, 1, … -#> $ det_cov <dbl> -1.28279990, 0.02694282, 0.06007252, 0.23234268, 0.19548086,… -#> $ det_cov2 <dbl> 2.0304731, 1.8551705, 1.0026802, -0.8328419, 1.0455536, 1.91… +#> $ det_cov <dbl> -1.28279990, -0.08474811, 0.44789392, 1.71731815, 0.19548086… +#> $ det_cov2 <dbl> 2.03047314, -1.42459158, 1.68497337, 0.75026787, 1.04555361,… #> $ replicate <int> 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, … #> $ site <fct> site1, site1, site1, site2, site2, site2, site3, site3, site… #> $ species <fct> sp_1, sp_1, sp_1, sp_1, sp_1, sp_1, sp_1, sp_1, sp_1, sp_1, … @@ -957,9 +955,9 @@

    Example 2: a larger survey with possible nonlinear effects

    head(mod_data) #> y abund_cov abund_fac det_cov det_cov2 replicate site species #> 1 1 -0.3734384 3 -1.28279990 2.0304731 1 site1 sp_1 -#> 2 NA -0.3734384 3 0.02694282 1.8551705 2 site1 sp_1 -#> 3 NA -0.3734384 3 0.06007252 1.0026802 3 site1 sp_1 -#> 4 NA 0.7064305 4 0.23234268 -0.8328419 1 site2 sp_1 +#> 2 NA -0.3734384 3 -0.08474811 -1.4245916 2 site1 sp_1 +#> 3 NA -0.3734384 3 0.44789392 1.6849734 3 site1 sp_1 +#> 4 NA 0.7064305 4 1.71731815 0.7502679 1 site2 sp_1 #> 5 2 0.7064305 4 0.19548086 1.0455536 2 site2 sp_1 #> 6 2 0.7064305 4 0.96730338 1.9197118 3 site2 sp_1 #> series time cap @@ -1039,71 +1037,69 @@

    Example 2: a larger survey with possible nonlinear effects

    summary(mod, include_betas = FALSE)
 #> GAM observation formula:
 #> y ~ s(det_cov, k = 3) + s(det_cov2, k = 3)
-#> <environment: 0x00000237248751d0>
-#> 
-#> GAM process formula:
-#> ~s(abund_cov, k = 3) + s(abund_fac, bs = "re")
-#> <environment: 0x00000237248751d0>
-#> 
-#> Family:
-#> nmix
-#> 
-#> Link function:
-#> log
-#> 
-#> Trend model:
-#> None
-#> 
-#> N process models:
-#> 225 
-#> 
-#> N series:
-#> 675 
-#> 
-#> N timepoints:
-#> 1 
-#> 
-#> Status:
-#> Fitted using Stan 
-#> 1 chains, each with iter = 1000; warmup = ; thin = 1 
-#> Total post-warmup draws = 1000
-#> 
-#> 
-#> GAM observation model coefficient (beta) estimates:
-#>              2.5%  50% 97.5% Rhat n.eff
-#> (Intercept) 0.099 0.44  0.82  NaN   NaN
-#> 
-#> Approximate significance of GAM observation smooths:
-#>              edf Ref.df Chi.sq p-value    
-#> s(det_cov)  1.07      2     89 0.00058 ***
-#> s(det_cov2) 1.05      2    318 < 2e-16 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> GAM process model coefficient (beta) estimates:
-#>                     2.5%  50% 97.5% Rhat n.eff
-#> (Intercept)_trend -0.028 0.11  0.28  NaN   NaN
-#> 
-#> GAM process model group-level estimates:
-#>                           2.5%   50% 97.5% Rhat n.eff
-#> mean(s(abund_fac))_trend -0.44 -0.32 -0.18  NaN   NaN
-#> sd(s(abund_fac))_trend    0.28  0.42  0.60  NaN   NaN
-#> 
-#> Approximate significance of GAM process smooths:
-#>               edf Ref.df    F p-value  
-#> s(abund_cov) 1.18      2 0.29   0.813  
-#> s(abund_fac) 8.85     10 3.33   0.038 *
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Posterior approximation used: no diagnostics to compute
    +#> +#> GAM process formula: +#> ~s(abund_cov, k = 3) + s(abund_fac, bs = "re") +#> +#> Family: +#> nmix +#> +#> Link function: +#> log +#> +#> Trend model: +#> None +#> +#> N process models: +#> 225 +#> +#> N series: +#> 675 +#> +#> N timepoints: +#> 1 +#> +#> Status: +#> Fitted using Stan +#> 1 chains, each with iter = 1000; warmup = ; thin = 1 +#> Total post-warmup draws = 1000 +#> +#> +#> GAM observation model coefficient (beta) estimates: +#> 2.5% 50% 97.5% Rhat n.eff +#> (Intercept) 0.052 0.4 0.71 NaN NaN +#> +#> Approximate significance of GAM observation smooths: +#> edf Ref.df Chi.sq p-value +#> s(det_cov) 1.22 2 52.3 0.0011 ** +#> s(det_cov2) 1.07 2 307.1 <2e-16 *** +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> +#> GAM process model coefficient (beta) estimates: +#> 2.5% 50% 97.5% Rhat n.eff +#> (Intercept)_trend -0.25 -0.081 0.079 NaN NaN +#> +#> GAM process model group-level estimates: +#> 2.5% 50% 97.5% Rhat n.eff +#> mean(s(abund_fac))_trend -0.18 0.0038 0.19 NaN NaN +#> sd(s(abund_fac))_trend 0.26 0.3900 0.56 NaN NaN +#> +#> Approximate significance of GAM process smooths: +#> edf Ref.df F p-value +#> s(abund_cov) 1.19 2 2.38 0.299 +#> s(abund_fac) 8.82 10 2.79 0.025 * +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> +#> Posterior approximation used: no diagnostics to compute

    Again we can make use of marginaleffects support for interrogating the model through targeted predictions. First, we can inspect the estimated average detection probability

    avg_predictions(mod, type = 'detection')
 #> 
 #>  Estimate 2.5 % 97.5 %
-#>     0.588  0.52  0.662
+#>     0.579  0.51  0.644
 #> 
 #> Columns: estimate, conf.low, conf.high 
 #> Type:  detection
    @@ -1120,12 +1116,12 @@

    Example 2: a larger survey with possible nonlinear effects

    abundance

    abund_plots[[1]] +
   ylab('Expected latent abundance')
    -

    +

    The effect of the factor covariate on expected latent abundance, estimated as a hierarchical random effect

    abund_plots[[2]] +
   ylab('Expected latent abundance')
    -

    +

    Now we can investigate estimated effects of covariates on detection probability using type = 'detection'

    det_plots <- plot(conditional_effects(mod,
@@ -1139,10 +1135,10 @@ 
    Example 2: a larger survey with possible nonlinear effects
    
 the probability scale is more intuitive and useful
    
 
    det_plots[[1]] +
   ylab('Pr(detection)')
    
-
    
+
    
 
    det_plots[[2]] +
   ylab('Pr(detection)')
    
-
    
+
    
 
    More targeted predictions are also easy with
 marginaleffects support. For example, we can ask: How does
 detection probability change as we change both detection
@@ -1156,7 +1152,7 @@ 
    Example 2: a larger survey with possible nonlinear effects
    
                  type = 'detection') +
   theme_classic() +
   ylab('Pr(detection)')
    -

    +

    The model has found support for some important covariate effects, but of course we’d want to interrogate how well the model predicts and think about possible spatial effects to capture unmodelled variation in latent diff --git a/inst/doc/shared_states.R b/inst/doc/shared_states.R index 971c0bec..3619bf06 100644 --- a/inst/doc/shared_states.R +++ b/inst/doc/shared_states.R @@ -1,4 +1,4 @@ -## ----echo = FALSE----------------------------------------------------- +## ----echo = FALSE------------------------------------------------------------- NOT_CRAN <- identical(tolower(Sys.getenv("NOT_CRAN")), "true") knitr::opts_chunk$set( collapse = TRUE, @@ -8,7 +8,7 @@ knitr::opts_chunk$set( ) -## ----setup, include=FALSE--------------------------------------------- +## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, dpi = 100, @@ -21,9 +21,9 @@ library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- set.seed(122) -simdat <- sim_mvgam(trend_model = 'AR1', +simdat <- sim_mvgam(trend_model = AR(), prop_trend = 0.6, mu = c(0, 1, 2), family = poisson()) @@ -32,11 +32,11 @@ trend_map <- data.frame(series = unique(simdat$data_train$series), trend_map -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- all.equal(levels(trend_map$series), levels(simdat$data_train$series)) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- fake_mod <- mvgam(y ~ # observation model formula, which has a # different intercept per series @@ -47,8 +47,10 @@ fake_mod <- mvgam(y ~ trend_formula = ~ s(season, bs = 'cc', k = 6), # AR1 dynamics (each latent process model has DIFFERENT) - # dynamics - trend_model = 'AR1', + # dynamics; processes are estimated using the noncentred + # parameterisation for improved efficiency + trend_model = AR(), + noncentred = TRUE, # supplied trend_map trend_map = trend_map, @@ -59,46 +61,50 @@ fake_mod <- mvgam(y ~ run_model = FALSE) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- code(fake_mod) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- fake_mod$model_data$Z -## ----full_mod, include = FALSE, results='hide'------------------------ +## ----full_mod, include = FALSE, results='hide'-------------------------------- full_mod <- mvgam(y ~ series - 1, trend_formula = ~ s(season, bs = 'cc', k = 6), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, trend_map = trend_map, family = poisson(), - data = simdat$data_train) + data = simdat$data_train, + silent = 2) -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## full_mod <- mvgam(y ~ series - 1, ## trend_formula = ~ s(season, bs = 'cc', k = 6), -## trend_model = 'AR1', +## trend_model = AR(), +## noncentred = TRUE, ## trend_map = trend_map, ## family = poisson(), -## data = simdat$data_train) +## data = simdat$data_train, +## silent = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(full_mod) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(full_mod, type = 'trend', series = 1) plot(full_mod, type = 'trend', series = 2) plot(full_mod, type = 'trend', series = 3) -## --------------------------------------------------------------------- -set.seed(543210) +## ----------------------------------------------------------------------------- +set.seed(0) # simulate a nonlinear relationship using the mgcv function gamSim -signal_dat <- gamSim(n = 100, eg = 1, scale = 1) +signal_dat <- mgcv::gamSim(n = 100, eg = 1, scale = 1) # productivity is one of the variables in the simulated data productivity <- signal_dat$x2 @@ -110,17 +116,16 @@ true_signal <- as.vector(scale(signal_dat$y) + arima.sim(100, model = list(ar = 0.8, sd = 0.1))) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(true_signal, type = 'l', bty = 'l', lwd = 2, ylab = 'True signal', xlab = 'Time') -## --------------------------------------------------------------------- -set.seed(543210) +## ----------------------------------------------------------------------------- sim_series = function(n_series = 3, true_signal){ - temp_effects <- gamSim(n = 100, eg = 7, scale = 0.1) + temp_effects <- mgcv::gamSim(n = 100, eg = 7, scale = 0.1) temperature <- temp_effects$y alphas <- rnorm(n_series, sd = 2) @@ -141,12 +146,12 @@ model_dat <- sim_series(true_signal = true_signal) %>% dplyr::mutate(series = factor(series)) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_mvgam_series(data = model_dat, y = 'observed', series = 'all') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(observed ~ temperature, data = model_dat %>% dplyr::filter(series == 'sensor_1'), pch = 16, bty = 'l', @@ -164,7 +169,7 @@ plot_mvgam_series(data = model_dat, y = 'observed', xlab = 'Temperature') -## ----sensor_mod, include = FALSE, results='hide'---------------------- +## ----sensor_mod, include = FALSE, results='hide'------------------------------ mod <- mvgam(formula = # formula for observations, allowing for different # intercepts and smooth effects of temperature @@ -180,7 +185,8 @@ mod <- mvgam(formula = trend_model = # in addition to productivity effects, the signal is # assumed to exhibit temporal autocorrelation - 'AR1', + AR(), + noncentred = TRUE, trend_map = # trend_map forces all sensors to track the same @@ -197,10 +203,11 @@ mod <- mvgam(formula = family = gaussian(), burnin = 600, adapt_delta = 0.95, - data = model_dat) + data = model_dat, + silent = 2) -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## mod <- mvgam(formula = ## # formula for observations, allowing for different ## # intercepts and hierarchical smooth effects of temperature @@ -216,7 +223,8 @@ mod <- mvgam(formula = ## trend_model = ## # in addition to productivity effects, the signal is ## # assumed to exhibit temporal autocorrelation -## 'AR1', +## AR(), +## noncentred = TRUE, ## ## trend_map = ## # trend_map forces all sensors to track the same @@ -231,25 +239,27 @@ mod <- mvgam(formula = ## ## # Gaussian observations ## family = gaussian(), -## data = model_dat) +## data = model_dat, +## silent = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(mod, include_betas = FALSE) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- conditional_effects(mod, type = 'link') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- +require(marginaleffects) plot_predictions(mod, condition = c('temperature', 'series', 'series'), points = 0.5) + theme(legend.position = 'none') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(mod, type = 'trend') # Overlay the true simulated signal diff --git a/inst/doc/shared_states.Rmd b/inst/doc/shared_states.Rmd index fb1b7282..bc79aa71 100644 --- a/inst/doc/shared_states.Rmd +++ b/inst/doc/shared_states.Rmd @@ -39,7 +39,7 @@ This vignette gives an example of how `mvgam` can be used to estimate models whe The `trend_map` argument in the `mvgam()` function is an optional `data.frame` that can be used to specify which series should depend on which latent process models (called "trends" in `mvgam`). This can be particularly useful if we wish to force multiple observed time series to depend on the same latent trend process, but with different observation processes. If this argument is supplied, a latent factor model is set up by setting `use_lv = TRUE` and using the supplied `trend_map` to set up the shared trends. Users familiar with the `MARSS` family of packages will recognize this as a way of specifying the $Z$ matrix. This `data.frame` needs to have column names `series` and `trend`, with integer values in the `trend` column to state which trend each series should depend on. The `series` column should have a single unique entry for each time series in the data, with names that perfectly match the factor levels of the `series` variable in `data`). For example, if we were to simulate a collection of three integer-valued time series (using `sim_mvgam`), the following `trend_map` would force the first two series to share the same latent trend process: ```{r} set.seed(122) -simdat <- sim_mvgam(trend_model = 'AR1', +simdat <- sim_mvgam(trend_model = AR(), prop_trend = 0.6, mu = c(0, 1, 2), family = poisson()) @@ -66,8 +66,10 @@ fake_mod <- mvgam(y ~ trend_formula = ~ s(season, bs = 'cc', k = 6), # AR1 dynamics (each latent process model has DIFFERENT) - # dynamics - trend_model = 'AR1', + # dynamics; processes are estimated using the noncentred + # parameterisation for improved efficiency + trend_model = AR(), + noncentred = TRUE, # supplied trend_map trend_map = trend_map, @@ -93,19 +95,23 @@ Though this model doesn't perfectly match the data-generating process (which all ```{r full_mod, include = FALSE, results='hide'} full_mod <- mvgam(y ~ series - 1, trend_formula = ~ s(season, bs = 'cc', k = 6), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, trend_map = trend_map, family = poisson(), - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` ```{r eval=FALSE} full_mod <- mvgam(y ~ series - 1, trend_formula = ~ s(season, bs = 'cc', k = 6), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, trend_map = trend_map, family = poisson(), - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The summary of this model is informative as it shows that only two latent process models have been estimated, even though we have three observed time series. The model converges well @@ -125,9 +131,9 @@ However, forecasts for series' 1 and 2 will differ because they have different i ## Example: signal detection Now we will explore a more complicated example. Here we simulate a true hidden signal that we are trying to track. This signal depends nonlinearly on some covariate (called `productivity`, which represents a measure of how productive the landscape is). The signal also demonstrates a fairly large amount of temporal autocorrelation: ```{r} -set.seed(543210) +set.seed(0) # simulate a nonlinear relationship using the mgcv function gamSim -signal_dat <- gamSim(n = 100, eg = 1, scale = 1) +signal_dat <- mgcv::gamSim(n = 100, eg = 1, scale = 1) # productivity is one of the variables in the simulated data productivity <- signal_dat$x2 @@ -149,9 +155,8 @@ plot(true_signal, type = 'l', Next we simulate three sensors that are trying to track the same hidden signal. All of these sensors have different observation errors that can depend nonlinearly on a second external covariate, called `temperature` in this example. Again this makes use of `gamSim` ```{r} -set.seed(543210) sim_series = function(n_series = 3, true_signal){ - temp_effects <- gamSim(n = 100, eg = 7, scale = 0.1) + temp_effects <- mgcv::gamSim(n = 100, eg = 7, scale = 0.1) temperature <- temp_effects$y alphas <- rnorm(n_series, sd = 2) @@ -215,7 +220,8 @@ mod <- mvgam(formula = trend_model = # in addition to productivity effects, the signal is # assumed to exhibit temporal autocorrelation - 'AR1', + AR(), + noncentred = TRUE, trend_map = # trend_map forces all sensors to track the same @@ -232,7 +238,8 @@ mod <- mvgam(formula = family = gaussian(), burnin = 600, adapt_delta = 0.95, - data = model_dat) + data = model_dat, + silent = 2) ``` ```{r eval=FALSE} @@ -251,7 +258,8 @@ mod <- mvgam(formula = trend_model = # in addition to productivity effects, the signal is # assumed to exhibit temporal autocorrelation - 'AR1', + AR(), + noncentred = TRUE, trend_map = # trend_map forces all sensors to track the same @@ -266,7 +274,8 @@ mod <- mvgam(formula = # Gaussian observations family = gaussian(), - data = model_dat) + data = model_dat, + silent = 2) ``` View a reduced version of the model summary because there will be many spline coefficients in this model @@ -282,6 +291,7 @@ conditional_effects(mod, type = 'link') `conditional_effects` is simply a wrapper to the more flexible `plot_predictions` function from the `marginaleffects` package. We can get more useful plots of these effects using this function for further customisation: ```{r} +require(marginaleffects) plot_predictions(mod, condition = c('temperature', 'series', 'series'), points = 0.5) + diff --git a/inst/doc/shared_states.html b/inst/doc/shared_states.html index 665beb75..db2dac3b 100644 --- a/inst/doc/shared_states.html +++ b/inst/doc/shared_states.html @@ -12,7 +12,7 @@ - + Shared latent states in mvgam @@ -340,7 +340,7 @@

    Shared latent states in mvgam

    Nicholas J Clark

    -

    2024-05-08

    +

    2024-07-01

    @@ -393,7 +393,7 @@

    The trend_map argument

    sim_mvgam), the following trend_map would force the first two series to share the same latent trend process:

    set.seed(122)
-simdat <- sim_mvgam(trend_model = 'AR1',
+simdat <- sim_mvgam(trend_model = AR(),
                     prop_trend = 0.6,
                     mu = c(0, 1, 2),
                     family = poisson())
@@ -432,16 +432,18 @@ 
    Checking trend_map with
                   trend_formula = ~ s(season, bs = 'cc', k = 6),
                   
                   # AR1 dynamics (each latent process model has DIFFERENT)
-                  # dynamics
-                  trend_model = 'AR1',
-                  
-                  # supplied trend_map
-                  trend_map = trend_map,
-                  
-                  # data and observation family
-                  family = poisson(),
-                  data = simdat$data_train,
-                  run_model = FALSE)
    + # dynamics; processes are estimated using the noncentred + # parameterisation for improved efficiency + trend_model = AR(), + noncentred = TRUE, + + # supplied trend_map + trend_map = trend_map, + + # data and observation family + family = poisson(), + data = simdat$data_train, + run_model = FALSE)

    Inspecting the Stan code shows how this model is a dynamic factor model in which the loadings are constructed to reflect the supplied trend_map:

    @@ -479,96 +481,99 @@

    Checking trend_map with #> vector<lower=0>[n_lv] sigma; #> #> // latent state AR1 terms -#> vector<lower=-1.5, upper=1.5>[n_lv] ar1; +#> vector<lower=-1, upper=1>[n_lv] ar1; #> -#> // latent states -#> matrix[n, n_lv] LV; +#> // raw latent states +#> matrix[n, n_lv] LV_raw; #> #> // smoothing parameters #> vector<lower=0>[n_sp_trend] lambda_trend; #> } #> transformed parameters { -#> // latent states and loading matrix +#> // raw latent states #> vector[n * n_lv] trend_mus; #> matrix[n, n_series] trend; #> #> // basis coefficients #> vector[num_basis] b; -#> vector[num_basis_trend] b_trend; -#> -#> // observation model basis coefficients -#> b[1 : num_basis] = b_raw[1 : num_basis]; +#> +#> // latent states +#> matrix[n, n_lv] LV; +#> vector[num_basis_trend] b_trend; #> -#> // process model basis coefficients -#> b_trend[1 : num_basis_trend] = b_raw_trend[1 : num_basis_trend]; +#> // observation model basis coefficients +#> b[1 : num_basis] = b_raw[1 : num_basis]; #> -#> // latent process linear predictors -#> trend_mus = X_trend * b_trend; +#> // process model basis coefficients +#> b_trend[1 : num_basis_trend] = b_raw_trend[1 : num_basis_trend]; #> -#> // derived latent states -#> for (i in 1 : n) { -#> for (s in 1 : n_series) { -#> trend[i, s] = dot_product(Z[s, : ], LV[i, : ]); -#> } -#> } -#> } -#> model { -#> // prior for seriesseries_1... -#> b_raw[1] ~ student_t(3, 0, 2); +#> // latent process linear predictors +#> trend_mus = X_trend * b_trend; +#> LV = LV_raw .* rep_matrix(sigma', rows(LV_raw)); +#> for (j in 1 : n_lv) { +#> LV[1, j] += trend_mus[ytimes_trend[1, j]]; +#> for (i in 2 : n) { +#> LV[i, j] += trend_mus[ytimes_trend[i, j]] +#> + ar1[j] * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]); +#> } +#> } #> -#> // prior for seriesseries_2... -#> b_raw[2] ~ student_t(3, 0, 2); -#> -#> // prior for seriesseries_3... -#> b_raw[3] ~ student_t(3, 0, 2); -#> -#> // priors for AR parameters -#> ar1 ~ std_normal(); -#> -#> // priors for latent state SD parameters -#> sigma ~ student_t(3, 0, 2.5); -#> -#> // dynamic process models +#> // derived latent states +#> for (i in 1 : n) { +#> for (s in 1 : n_series) { +#> trend[i, s] = dot_product(Z[s, : ], LV[i, : ]); +#> } +#> } +#> } +#> model { +#> // prior for seriesseries_1... +#> b_raw[1] ~ student_t(3, 0, 2); +#> +#> // prior for seriesseries_2... +#> b_raw[2] ~ student_t(3, 0, 2); #> -#> // prior for s(season)_trend... -#> b_raw_trend[1 : 4] ~ multi_normal_prec(zero_trend[1 : 4], -#> S_trend1[1 : 4, 1 : 4] -#> * lambda_trend[1]); -#> lambda_trend ~ normal(5, 30); -#> for (j in 1 : n_lv) { -#> LV[1, j] ~ normal(trend_mus[ytimes_trend[1, j]], sigma[j]); -#> for (i in 2 : n) { -#> LV[i, j] ~ normal(trend_mus[ytimes_trend[i, j]] -#> + ar1[j] -#> * (LV[i - 1, j] - trend_mus[ytimes_trend[i - 1, j]]), -#> sigma[j]); -#> } -#> } -#> { -#> // likelihood functions -#> vector[n_nonmissing] flat_trends; -#> flat_trends = to_vector(trend)[obs_ind]; -#> flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends), 0.0, -#> append_row(b, 1.0)); -#> } -#> } -#> generated quantities { -#> vector[total_obs] eta; -#> matrix[n, n_series] mus; -#> vector[n_sp_trend] rho_trend; -#> vector[n_lv] penalty; -#> array[n, n_series] int ypred; -#> penalty = 1.0 / (sigma .* sigma); -#> rho_trend = log(lambda_trend); -#> -#> matrix[n_series, n_lv] lv_coefs = Z; -#> // posterior predictions -#> eta = X * b; -#> for (s in 1 : n_series) { -#> mus[1 : n, s] = eta[ytimes[1 : n, s]] + trend[1 : n, s]; -#> ypred[1 : n, s] = poisson_log_rng(mus[1 : n, s]); -#> } -#> } +#> // prior for seriesseries_3... +#> b_raw[3] ~ student_t(3, 0, 2); +#> +#> // priors for AR parameters +#> ar1 ~ std_normal(); +#> +#> // priors for latent state SD parameters +#> sigma ~ student_t(3, 0, 2.5); +#> to_vector(LV_raw) ~ std_normal(); +#> +#> // dynamic process models +#> +#> // prior for s(season)_trend... +#> b_raw_trend[1 : 4] ~ multi_normal_prec(zero_trend[1 : 4], +#> S_trend1[1 : 4, 1 : 4] +#> * lambda_trend[1]); +#> lambda_trend ~ normal(5, 30); +#> { +#> // likelihood functions +#> vector[n_nonmissing] flat_trends; +#> flat_trends = to_vector(trend)[obs_ind]; +#> flat_ys ~ poisson_log_glm(append_col(flat_xs, flat_trends), 0.0, +#> append_row(b, 1.0)); +#> } +#> } +#> generated quantities { +#> vector[total_obs] eta; +#> matrix[n, n_series] mus; +#> vector[n_sp_trend] rho_trend; +#> vector[n_lv] penalty; +#> array[n, n_series] int ypred; +#> penalty = 1.0 / (sigma .* sigma); +#> rho_trend = log(lambda_trend); +#> +#> matrix[n_series, n_lv] lv_coefs = Z; +#> // posterior predictions +#> eta = X * b; +#> for (s in 1 : n_series) { +#> mus[1 : n, s] = eta[ytimes[1 : n, s]] + trend[1 : n, s]; +#> ypred[1 : n, s] = poisson_log_rng(mus[1 : n, s]); +#> } +#> }

    Notice the line that states “lv_coefs = Z;”. This uses the supplied \(Z\) matrix to construct the loading coefficients. The supplied matrix now looks exactly like what you’d use @@ -587,21 +592,23 @@

    Fitting and inspecting the model

    can still fit it to show what the resulting inferences look like:

    full_mod <- mvgam(y ~ series - 1,
                   trend_formula = ~ s(season, bs = 'cc', k = 6),
-                  trend_model = 'AR1',
-                  trend_map = trend_map,
-                  family = poisson(),
-                  data = simdat$data_train)
    + trend_model = AR(), + noncentred = TRUE, + trend_map = trend_map, + family = poisson(), + data = simdat$data_train, + silent = 2)

    The summary of this model is informative as it shows that only two latent process models have been estimated, even though we have three observed time series. The model converges well

    summary(full_mod)
 #> GAM observation formula:
 #> y ~ series - 1
-#> <environment: 0x000001b6d1eaf110>
+#> <environment: 0x000001f52b9e3130>
 #> 
 #> GAM process formula:
 #> ~s(season, bs = "cc", k = 6)
-#> <environment: 0x000001b6d1eaf110>
+#> <environment: 0x000001f52b9e3130>
 #> 
 #> Family:
 #> poisson
@@ -610,7 +617,7 @@ 
    Fitting and inspecting the model
    
 #> log
 #> 
 #> Trend model:
-#> AR1
+#> AR()
 #> 
 #> N process models:
 #> 2 
@@ -629,30 +636,30 @@ 
    Fitting and inspecting the model
    
 #> 
 #> GAM observation model coefficient (beta) estimates:
 #>                 2.5%   50% 97.5% Rhat n_eff
-#> seriesseries_1 -0.15 0.079   0.3 1.00  1468
-#> seriesseries_2  0.90 1.100   1.2 1.00  1001
-#> seriesseries_3  1.90 2.100   2.3 1.01   318
+#> seriesseries_1 -0.14 0.084  0.29 1.00  1720
+#> seriesseries_2  0.91 1.100  1.20 1.00  1374
+#> seriesseries_3  1.90 2.100  2.30 1.01   447
 #> 
 #> Process model AR parameter estimates:
-#>         2.5%   50%  97.5% Rhat n_eff
-#> ar1[1] -0.71 -0.42 -0.054    1   952
-#> ar1[2] -0.29 -0.01  0.290    1  1786
+#>         2.5%    50%  97.5% Rhat n_eff
+#> ar1[1] -0.72 -0.430 -0.037 1.01   560
+#> ar1[2] -0.30 -0.017  0.270 1.01   286
 #> 
 #> Process error parameter estimates:
 #>          2.5%  50% 97.5% Rhat n_eff
-#> sigma[1] 0.34 0.50  0.69 1.01   435
-#> sigma[2] 0.60 0.73  0.92 1.00  1061
+#> sigma[1] 0.34 0.49  0.65    1   819
+#> sigma[2] 0.59 0.73  0.90    1   573
 #> 
 #> GAM process model coefficient (beta) estimates:
 #>                    2.5%    50% 97.5% Rhat n_eff
-#> s(season).1_trend -0.22 -0.010  0.21    1  1610
-#> s(season).2_trend -0.27 -0.048  0.16    1  1547
-#> s(season).3_trend -0.16  0.075  0.29    1  1834
-#> s(season).4_trend -0.15  0.065  0.26    1  1605
+#> s(season).1_trend -0.20 -0.003  0.21 1.01   857
+#> s(season).2_trend -0.27 -0.046  0.17 1.00   918
+#> s(season).3_trend -0.15  0.068  0.28 1.00   850
+#> s(season).4_trend -0.14  0.064  0.27 1.00   972
 #> 
 #> Approximate significance of GAM process smooths:
-#>            edf Ref.df    F p-value
-#> s(season) 1.81      4 0.17    0.92
+#>            edf Ref.df Chi.sq p-value
+#> s(season) 2.33      4   0.38    0.93
 #> 
 #> Stan MCMC diagnostics:
 #> n_eff / iter looks reasonable for all parameters
@@ -661,18 +668,18 @@ 
    Fitting and inspecting the model
    
 #> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
 #> E-FMI indicated no pathological behavior
 #> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 9:17:16 PM 2024.
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:31:17 AM 2024.
 #> For each parameter, n_eff is a crude measure of effective sample size,
 #> and Rhat is the potential scale reduction factor on split MCMC chains
 #> (at convergence, Rhat = 1)

    Both series 1 and 2 share the exact same latent process estimates, while the estimates for series 3 are different:

    plot(full_mod, type = 'trend', series = 1)
    -

    +

    plot(full_mod, type = 'trend', series = 2)
    -

    +

    plot(full_mod, type = 'trend', series = 3)
    -

    +

    However, forecasts for series’ 1 and 2 will differ because they have different intercepts in the observation model

    @@ -684,9 +691,9 @@

    Example: signal detection

    nonlinearly on some covariate (called productivity, which represents a measure of how productive the landscape is). The signal also demonstrates a fairly large amount of temporal autocorrelation:

    -
    set.seed(543210)
+
    set.seed(0)
 # simulate a nonlinear relationship using the mgcv function gamSim
-signal_dat <- gamSim(n = 100, eg = 1, scale = 1)
+signal_dat <- mgcv::gamSim(n = 100, eg = 1, scale = 1)
 #> Gu & Wahba 4 term additive model
 
 # productivity is one of the variables in the simulated data
@@ -702,38 +709,37 @@ 
    Example: signal detection
    
      bty = 'l', lwd = 2,
      ylab = 'True signal',
      xlab = 'Time')
    
-
    
+
    
 
    Next we simulate three sensors that are trying to track the same
 hidden signal. All of these sensors have different observation errors
 that can depend nonlinearly on a second external covariate, called
 temperature in this example. Again this makes use of
 gamSim
    
-
    set.seed(543210)
-sim_series = function(n_series = 3, true_signal){
-  temp_effects <- gamSim(n = 100, eg = 7, scale = 0.1)
-  temperature <- temp_effects$y
-  alphas <- rnorm(n_series, sd = 2)
-
-  do.call(rbind, lapply(seq_len(n_series), function(series){
-    data.frame(observed = rnorm(length(true_signal),
-                                mean = alphas[series] +
-                                       1.5*as.vector(scale(temp_effects[, series + 1])) +
-                                       true_signal,
-                                sd = runif(1, 1, 2)),
-               series = paste0('sensor_', series),
-               time = 1:length(true_signal),
-               temperature = temperature,
-               productivity = productivity,
-               true_signal = true_signal)
-   }))
-  }
-model_dat <- sim_series(true_signal = true_signal) %>%
-  dplyr::mutate(series = factor(series))
-#> Gu & Wahba 4 term additive model, correlated predictors
    
+
    sim_series = function(n_series = 3, true_signal){
+  temp_effects <- mgcv::gamSim(n = 100, eg = 7, scale = 0.1)
+  temperature <- temp_effects$y
+  alphas <- rnorm(n_series, sd = 2)
+
+  do.call(rbind, lapply(seq_len(n_series), function(series){
+    data.frame(observed = rnorm(length(true_signal),
+                                mean = alphas[series] +
+                                       1.5*as.vector(scale(temp_effects[, series + 1])) +
+                                       true_signal,
+                                sd = runif(1, 1, 2)),
+               series = paste0('sensor_', series),
+               time = 1:length(true_signal),
+               temperature = temperature,
+               productivity = productivity,
+               true_signal = true_signal)
+   }))
+  }
+model_dat <- sim_series(true_signal = true_signal) %>%
+  dplyr::mutate(series = factor(series))
+#> Gu & Wahba 4 term additive model, correlated predictors
    
 
    Plot the sensor observations
    
 
    plot_mvgam_series(data = model_dat, y = 'observed',
                   series = 'all')
    
-
    
+
    
 
    And now plot the observed relationships between the three sensors and
 the temperature covariate
    
 
     plot(observed ~ temperature, data = model_dat %>%
@@ -741,19 +747,19 @@ 
    Example: signal detection
    
    pch = 16, bty = 'l',
    ylab = 'Sensor 1',
    xlab = 'Temperature')
    
-
    
+
    
 
     plot(observed ~ temperature, data = model_dat %>%
    dplyr::filter(series == 'sensor_2'),
    pch = 16, bty = 'l',
    ylab = 'Sensor 2',
    xlab = 'Temperature')
    
-
    
+
    
 
     plot(observed ~ temperature, data = model_dat %>%
    dplyr::filter(series == 'sensor_3'),
    pch = 16, bty = 'l',
    ylab = 'Sensor 3',
    xlab = 'Temperature')
    
-
    
+
    
 
    
 
    The shared signal model
    
 
    Now we can formulate and fit a model that allows each sensor’s
@@ -781,33 +787,35 @@ 
    The shared signal model
    
              trend_model =
                # in addition to productivity effects, the signal is
                # assumed to exhibit temporal autocorrelation
-               'AR1',
-             
-             trend_map =
-               # trend_map forces all sensors to track the same
-               # latent signal
-               data.frame(series = unique(model_dat$series),
-                          trend = c(1, 1, 1)),
-             
-             # informative priors on process error
-             # and observation error will help with convergence
-             priors = c(prior(normal(2, 0.5), class = sigma),
-                        prior(normal(1, 0.5), class = sigma_obs)),
-             
-             # Gaussian observations
-             family = gaussian(),
-             data = model_dat)
    + AR(), + noncentred = TRUE, + + trend_map = + # trend_map forces all sensors to track the same + # latent signal + data.frame(series = unique(model_dat$series), + trend = c(1, 1, 1)), + + # informative priors on process error + # and observation error will help with convergence + priors = c(prior(normal(2, 0.5), class = sigma), + prior(normal(1, 0.5), class = sigma_obs)), + + # Gaussian observations + family = gaussian(), + data = model_dat, + silent = 2)

    View a reduced version of the model summary because there will be many spline coefficients in this model

    summary(mod, include_betas = FALSE)
 #> GAM observation formula:
 #> observed ~ series + s(temperature, k = 10) + s(series, temperature, 
 #>     bs = "sz", k = 8)
-#> <environment: 0x000001b6d1eaf110>
+#> <environment: 0x000001f52b9e3130>
 #> 
 #> GAM process formula:
 #> ~s(productivity, k = 8)
-#> <environment: 0x000001b6d1eaf110>
+#> <environment: 0x000001f52b9e3130>
 #> 
 #> Family:
 #> gaussian
@@ -816,7 +824,7 @@ 
    The shared signal model
    
 #> identity
 #> 
 #> Trend model:
-#> AR1
+#> AR()
 #> 
 #> N process models:
 #> 1 
@@ -835,49 +843,46 @@ 
    The shared signal model
    
 #> 
 #> Observation error parameter estimates:
 #>              2.5% 50% 97.5% Rhat n_eff
-#> sigma_obs[1]  1.6 1.9   2.2    1  1757
-#> sigma_obs[2]  1.4 1.7   2.0    1  1090
-#> sigma_obs[3]  1.3 1.5   1.8    1  1339
+#> sigma_obs[1]  1.4 1.7   2.1    1  1298
+#> sigma_obs[2]  1.7 2.0   2.3    1  1946
+#> sigma_obs[3]  2.0 2.3   2.7    1  2569
 #> 
 #> GAM observation model coefficient (beta) estimates:
-#>                 2.5%   50% 97.5% Rhat n_eff
-#> (Intercept)     0.72  1.70  2.50 1.01   360
-#> seriessensor_2 -2.10 -0.96  0.32 1.00  1068
-#> seriessensor_3 -3.40 -2.00 -0.39 1.00  1154
+#>                 2.5%  50% 97.5% Rhat n_eff
+#> (Intercept)    -3.40 -2.1 -0.69    1  1067
+#> seriessensor_2 -2.80 -1.4 -0.14    1  1169
+#> seriessensor_3  0.63  3.1  4.80    1  1055
 #> 
 #> Approximate significance of GAM observation smooths:
-#>                        edf Ref.df    F p-value    
-#> s(temperature)        1.22      9 12.6  <2e-16 ***
-#> s(series,temperature) 1.92     16  1.0   0.011 *  
+#>                        edf Ref.df Chi.sq p-value    
+#> s(temperature)        1.39      9   0.11       1    
+#> s(series,temperature) 2.78     16 107.40 5.4e-05 ***
 #> ---
 #> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
 #> 
 #> Process model AR parameter estimates:
-#>        2.5%  50% 97.5% Rhat n_eff
-#> ar1[1] 0.33 0.59  0.83    1   492
+#>        2.5% 50% 97.5% Rhat n_eff
+#> ar1[1] 0.37 0.6   0.8 1.01   616
 #> 
 #> Process error parameter estimates:
 #>          2.5% 50% 97.5% Rhat n_eff
-#> sigma[1] 0.72   1   1.3 1.01   392
+#> sigma[1]  1.5 1.8   2.2 1.01   649
 #> 
 #> Approximate significance of GAM process smooths:
-#>                 edf Ref.df    F p-value    
-#> s(productivity) 3.6      7 9.34 0.00036 ***
-#> ---
-#> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhats above 1.05 found for 28 parameters
-#>  *Diagnose further to investigate why the chains have not mixed
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 9:20:39 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +#> edf Ref.df Chi.sq p-value +#> s(productivity) 0.926 7 5.45 1 +#> +#> Stan MCMC diagnostics: +#> n_eff / iter looks reasonable for all parameters +#> Rhat looks reasonable for all parameters +#> 0 of 2000 iterations ended with a divergence (0%) +#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%) +#> E-FMI indicated no pathological behavior +#> +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:32:12 AM 2024. +#> For each parameter, n_eff is a crude measure of effective sample size, +#> and Rhat is the potential scale reduction factor on split MCMC chains +#> (at convergence, Rhat = 1)

    Inspecting effects on both process and observation models

    @@ -888,16 +893,18 @@

    Inspecting effects on both process and observation models

    prediction-based plots of the smooth functions. All main effects can be quickly plotted with conditional_effects:

    conditional_effects(mod, type = 'link')
    -

    +

    conditional_effects is simply a wrapper to the more flexible plot_predictions function from the marginaleffects package. We can get more useful plots of these effects using this function for further customisation:

    -
    plot_predictions(mod, 
-                 condition = c('temperature', 'series', 'series'),
-                 points = 0.5) +
-  theme(legend.position = 'none')
    -

    +
    require(marginaleffects)
+#> Loading required package: marginaleffects
+plot_predictions(mod, 
+                 condition = c('temperature', 'series', 'series'),
+                 points = 0.5) +
+  theme(legend.position = 'none')
    +

    We have successfully estimated effects, some of them nonlinear, that impact the hidden process AND the observations. All in a single joint model. But there can always be challenges with these models, @@ -917,7 +924,7 @@

    Recovering the hidden signal

    # Overlay the true simulated signal points(true_signal, pch = 16, cex = 1, col = 'white') points(true_signal, pch = 16, cex = 0.8)
    -

    +

    diff --git a/inst/doc/time_varying_effects.R b/inst/doc/time_varying_effects.R index 6d791ad6..18caf805 100644 --- a/inst/doc/time_varying_effects.R +++ b/inst/doc/time_varying_effects.R @@ -1,4 +1,4 @@ -## ----echo = FALSE----------------------------------------------------- +## ----echo = FALSE------------------------------------------------------------- NOT_CRAN <- identical(tolower(Sys.getenv("NOT_CRAN")), "true") knitr::opts_chunk$set( collapse = TRUE, @@ -8,7 +8,7 @@ knitr::opts_chunk$set( ) -## ----setup, include=FALSE--------------------------------------------- +## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, dpi = 100, @@ -21,7 +21,7 @@ library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- set.seed(1111) N <- 200 beta_temp <- mvgam:::sim_gp(rnorm(1), @@ -30,18 +30,18 @@ beta_temp <- mvgam:::sim_gp(rnorm(1), h = N) + 0.5 -## ----fig.alt = "Simulating time-varying effects in mvgam and R"------- +## ----fig.alt = "Simulating time-varying effects in mvgam and R"--------------- plot(beta_temp, type = 'l', lwd = 3, bty = 'l', xlab = 'Time', ylab = 'Coefficient', col = 'darkred') box(bty = 'l', lwd = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- temp <- rnorm(N, sd = 1) -## ----fig.alt = "Simulating time-varying effects in mvgam and R"------- +## ----fig.alt = "Simulating time-varying effects in mvgam and R"--------------- out <- rnorm(N, mean = 4 + beta_temp * temp, sd = 0.25) time <- seq_along(temp) @@ -51,36 +51,39 @@ plot(out, type = 'l', lwd = 3, box(bty = 'l', lwd = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- data <- data.frame(out, temp, time) data_train <- data[1:190,] data_test <- data[191:200,] -## ----include=FALSE---------------------------------------------------- +## ----include=FALSE------------------------------------------------------------ mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), ## family = gaussian(), -## data = data_train) +## data = data_train, +## silent = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(mod, include_betas = FALSE) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_mvgam_smooth(mod, smooth = 1, newdata = data) abline(v = 190, lty = 'dashed', lwd = 2) lines(beta_temp, lwd = 2.5, col = 'white') lines(beta_temp, lwd = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- +require(marginaleffects) range_round = function(x){ round(range(x, na.rm = TRUE), 2) } @@ -91,40 +94,42 @@ plot_predictions(mod, type = 'link') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- fc <- forecast(mod, newdata = data_test) plot(fc) -## ----include=FALSE---------------------------------------------------- +## ----include=FALSE------------------------------------------------------------ mod <- mvgam(out ~ dynamic(temp, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## mod <- mvgam(out ~ dynamic(temp, k = 40), ## family = gaussian(), -## data = data_train) +## data = data_train, +## silent = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(mod, include_betas = FALSE) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_mvgam_smooth(mod, smooth = 1, newdata = data) abline(v = 190, lty = 'dashed', lwd = 2) lines(beta_temp, lwd = 2.5, col = 'white') lines(beta_temp, lwd = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- load(url('https://github.com/atsa-es/MARSS/raw/master/data/SalmonSurvCUI.rda')) dplyr::glimpse(SalmonSurvCUI) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- SalmonSurvCUI %>% # create a time variable dplyr::mutate(time = dplyr::row_number()) %>% @@ -139,66 +144,74 @@ SalmonSurvCUI %>% dplyr::mutate(survival = plogis(logit.s)) -> model_data -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- dplyr::glimpse(model_data) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_mvgam_series(data = model_data, y = 'survival') -## ----include = FALSE-------------------------------------------------- +## ----include = FALSE---------------------------------------------------------- mod0 <- mvgam(formula = survival ~ 1, - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) -## ----eval = FALSE----------------------------------------------------- +## ----eval = FALSE------------------------------------------------------------- ## mod0 <- mvgam(formula = survival ~ 1, -## trend_model = RW(), -## family = betar(), -## data = model_data) +## trend_model = AR(), +## noncentred = TRUE, +## family = betar(), +## data = model_data, +## silent = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(mod0) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(mod0, type = 'trend') -## ----include=FALSE---------------------------------------------------- +## ----include=FALSE------------------------------------------------------------ mod1 <- mvgam(formula = survival ~ 1, trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), data = model_data, - adapt_delta = 0.99) + adapt_delta = 0.99, + silent = 2) -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## mod1 <- mvgam(formula = survival ~ 1, ## trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), -## trend_model = 'RW', +## trend_model = AR(), +## noncentred = TRUE, ## family = betar(), -## data = model_data) +## data = model_data, +## silent = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(mod1, include_betas = FALSE) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(mod1, type = 'trend') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(mod1, type = 'forecast') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- # Extract estimates of the process error 'sigma' for each model mod0_sigma <- as.data.frame(mod0, variable = 'sigma', regex = TRUE) %>% dplyr::mutate(model = 'Mod0') @@ -207,31 +220,31 @@ mod1_sigma <- as.data.frame(mod1, variable = 'sigma', regex = TRUE) %>% sigmas <- rbind(mod0_sigma, mod1_sigma) # Plot using ggplot2 -library(ggplot2) +require(ggplot2) ggplot(sigmas, aes(y = `sigma[1]`, fill = model)) + geom_density(alpha = 0.3, colour = NA) + coord_flip() -## --------------------------------------------------------------------- -plot(mod1, type = 'smooth', trend_effects = TRUE) +## ----------------------------------------------------------------------------- +plot(mod1, type = 'smooths', trend_effects = TRUE) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- loo_compare(mod0, mod1) -## ----include=FALSE---------------------------------------------------- +## ----include=FALSE------------------------------------------------------------ lfo_mod0 <- lfo_cv(mod0, min_t = 30) lfo_mod1 <- lfo_cv(mod1, min_t = 30) -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## lfo_mod0 <- lfo_cv(mod0, min_t = 30) ## lfo_mod1 <- lfo_cv(mod1, min_t = 30) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- sum(lfo_mod0$elpds) sum(lfo_mod1$elpds) diff --git a/inst/doc/time_varying_effects.Rmd b/inst/doc/time_varying_effects.Rmd index cf9573fd..ec19a933 100644 --- a/inst/doc/time_varying_effects.Rmd +++ b/inst/doc/time_varying_effects.Rmd @@ -85,13 +85,15 @@ Time-varying coefficients can be fairly easily set up using the `s()` or `gp()` ```{r, include=FALSE} mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` ```{r, eval=FALSE} mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` Inspect the model summary, which shows how the `dynamic()` wrapper was used to construct a low-rank Gaussian Process smooth function: @@ -109,6 +111,7 @@ lines(beta_temp, lwd = 2) We can also use `plot_predictions` from the `marginaleffects` package to visualise the time-varying coefficient for what the effect would be estimated to be at different values of $temperature$: ```{r} +require(marginaleffects) range_round = function(x){ round(range(x, na.rm = TRUE), 2) } @@ -129,13 +132,15 @@ The syntax is very similar if we wish to estimate the parameters of the underlyi ```{r include=FALSE} mod <- mvgam(out ~ dynamic(temp, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` ```{r eval=FALSE} mod <- mvgam(out ~ dynamic(temp, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` This model summary now contains estimates for the marginal deviation and length scale parameters of the underlying Gaussian Process function: @@ -186,19 +191,23 @@ plot_mvgam_series(data = model_data, y = 'survival') ### A State-Space Beta regression -`mvgam` can easily handle data that are bounded at 0 and 1 with a Beta observation model (using the `mgcv` function `betar()`, see `?mgcv::betar` for details). First we will fit a simple State-Space model that uses a Random Walk dynamic process model with no predictors and a Beta observation model: +`mvgam` can easily handle data that are bounded at 0 and 1 with a Beta observation model (using the `mgcv` function `betar()`, see `?mgcv::betar` for details). First we will fit a simple State-Space model that uses an AR1 dynamic process model with no predictors and a Beta observation model: ```{r include = FALSE} mod0 <- mvgam(formula = survival ~ 1, - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) ``` ```{r eval = FALSE} mod0 <- mvgam(formula = survival ~ 1, - trend_model = RW(), - family = betar(), - data = model_data) + trend_model = AR(), + noncentred = TRUE, + family = betar(), + data = model_data, + silent = 2) ``` The summary of this model shows good behaviour of the Hamiltonian Monte Carlo sampler and provides useful summaries on the Beta observation model parameters: @@ -216,18 +225,22 @@ Now we can increase the complexity of our model by constructing and fitting a St ```{r include=FALSE} mod1 <- mvgam(formula = survival ~ 1, trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), data = model_data, - adapt_delta = 0.99) + adapt_delta = 0.99, + silent = 2) ``` ```{r eval=FALSE} mod1 <- mvgam(formula = survival ~ 1, trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) ``` The summary for this model now includes estimates for the time-varying GP parameters: @@ -254,15 +267,15 @@ mod1_sigma <- as.data.frame(mod1, variable = 'sigma', regex = TRUE) %>% sigmas <- rbind(mod0_sigma, mod1_sigma) # Plot using ggplot2 -library(ggplot2) +require(ggplot2) ggplot(sigmas, aes(y = `sigma[1]`, fill = model)) + geom_density(alpha = 0.3, colour = NA) + coord_flip() ``` -Why does the process error not need to be as flexible in the second model? Because the estimates of this dynamic process are now informed partly by the time-varying effect of upwelling, which we can visualise on the link scale using `plot()` with `trend_effects = TRUE`: +Why does the process error not need to be as flexible in the second model? Because the estimates of this dynamic process are now informed partly by the time-varying effect of upwelling, which we can visualise on the link scale using `plot()`: ```{r} -plot(mod1, type = 'smooth', trend_effects = TRUE) +plot(mod1, type = 'smooths', trend_effects = TRUE) ``` ### Comparing model predictive performances diff --git a/inst/doc/time_varying_effects.html b/inst/doc/time_varying_effects.html index 6f53eb9e..341e817b 100644 --- a/inst/doc/time_varying_effects.html +++ b/inst/doc/time_varying_effects.html @@ -12,7 +12,7 @@ - + Time-varying effects in mvgam @@ -340,7 +340,7 @@

    Time-varying effects in mvgam

    Nicholas J Clark

    -

    2024-05-08

    +

    2024-07-01

    @@ -453,14 +453,15 @@

    The dynamic() function

    s(time, by = temp, bs = "gp", m = c(-2, 8, 2), k = 40)

    mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40),
              family = gaussian(),
-             data = data_train)
    + data = data_train, + silent = 2)

    Inspect the model summary, which shows how the dynamic() wrapper was used to construct a low-rank Gaussian Process smooth function:

    summary(mod, include_betas = FALSE)
 #> GAM formula:
 #> out ~ s(time, by = temp, bs = "gp", m = c(-2, 8, 2), k = 40)
-#> <environment: 0x000001820adad480>
+#> <environment: 0x0000014d37f0f110>
 #> 
 #> Family:
 #> gaussian
@@ -485,15 +486,15 @@ 
    The dynamic() function
    
 #> 
 #> Observation error parameter estimates:
 #>              2.5%  50% 97.5% Rhat n_eff
-#> sigma_obs[1] 0.23 0.25  0.28    1  2222
+#> sigma_obs[1] 0.23 0.25  0.28    1  2026
 #> 
 #> GAM coefficient (beta) estimates:
 #>             2.5% 50% 97.5% Rhat n_eff
-#> (Intercept)    4   4   4.1    1  2893
+#> (Intercept)    4   4   4.1    1  2640
 #> 
 #> Approximate significance of GAM smooths:
-#>              edf Ref.df    F p-value    
-#> s(time):temp  14     40 73.2  <2e-16 ***
+#>               edf Ref.df Chi.sq p-value    
+#> s(time):temp 15.4     40    173  <2e-16 ***
 #> ---
 #> Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
 #> 
@@ -504,7 +505,7 @@ 
    The dynamic() function
    
 #> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
 #> E-FMI indicated no pathological behavior
 #> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 9:26:35 PM 2024.
+#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:35:21 AM 2024.
 #> For each parameter, n_eff is a crude measure of effective sample size,
 #> and Rhat is the potential scale reduction factor on split MCMC chains
 #> (at convergence, Rhat = 1)
    @@ -521,26 +522,28 @@

    The dynamic() function

    abline(v = 190, lty = 'dashed', lwd = 2) lines(beta_temp, lwd = 2.5, col = 'white') lines(beta_temp, lwd = 2)
    -

    +

    We can also use plot_predictions from the marginaleffects package to visualise the time-varying coefficient for what the effect would be estimated to be at different values of \(temperature\):

    -
    range_round = function(x){
-  round(range(x, na.rm = TRUE), 2)
-}
-plot_predictions(mod, 
-                 newdata = datagrid(time = unique,
-                                    temp = range_round),
-                 by = c('time', 'temp', 'temp'),
-                 type = 'link')
    -

    +
    require(marginaleffects)
+#> Loading required package: marginaleffects
+range_round = function(x){
+  round(range(x, na.rm = TRUE), 2)
+}
+plot_predictions(mod, 
+                 newdata = datagrid(time = unique,
+                                    temp = range_round),
+                 by = c('time', 'temp', 'temp'),
+                 type = 'link')
    +

    This results in sensible forecasts of the observations as well

    fc <- forecast(mod, newdata = data_test)
 plot(fc)
 #> Out of sample CRPS:
-#> 1.28034661302171
    -

    +#> 1.30674285292277 +

    The syntax is very similar if we wish to estimate the parameters of the underlying Gaussian Process, this time using a Hilbert space approximation. We simply omit the rho argument in @@ -548,14 +551,15 @@

    The dynamic() function

    similar to gp(time, by = 'temp', c = 5/4, k = 40).

    mod <- mvgam(out ~ dynamic(temp, k = 40),
              family = gaussian(),
-             data = data_train)
    + data = data_train, + silent = 2)

    This model summary now contains estimates for the marginal deviation and length scale parameters of the underlying Gaussian Process function:

    summary(mod, include_betas = FALSE)
 #> GAM formula:
 #> out ~ gp(time, by = temp, c = 5/4, k = 40, scale = TRUE)
-#> <environment: 0x000001820adad480>
+#> <environment: 0x0000014d37f0f110>
 #> 
 #> Family:
 #> gaussian
@@ -580,36 +584,35 @@ 
    The dynamic() function
    
 #> 
 #> Observation error parameter estimates:
 #>              2.5%  50% 97.5% Rhat n_eff
-#> sigma_obs[1] 0.24 0.26  0.29    1  2151
+#> sigma_obs[1] 0.24 0.26   0.3    1  2183
 #> 
 #> GAM coefficient (beta) estimates:
 #>             2.5% 50% 97.5% Rhat n_eff
-#> (Intercept)    4   4   4.1    1  2989
+#> (Intercept)    4   4   4.1    1  2733
 #> 
 #> GAM gp term marginal deviation (alpha) and length scale (rho) estimates:
 #>                      2.5%   50% 97.5% Rhat n_eff
-#> alpha_gp(time):temp 0.640 0.890 1.400 1.01   745
-#> rho_gp(time):temp   0.028 0.053 0.069 1.00   888
+#> alpha_gp(time):temp 0.620 0.890 1.400 1.01   539
+#> rho_gp(time):temp   0.026 0.053 0.069 1.00   628
 #> 
 #> Stan MCMC diagnostics:
 #> n_eff / iter looks reasonable for all parameters
 #> Rhat looks reasonable for all parameters
-#> 1 of 2000 iterations ended with a divergence (0.05%)
-#>  *Try running with larger adapt_delta to remove the divergences
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 9:27:46 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +#> 0 of 2000 iterations ended with a divergence (0%) +#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%) +#> E-FMI indicated no pathological behavior +#> +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:36:09 AM 2024. +#> For each parameter, n_eff is a crude measure of effective sample size, +#> and Rhat is the potential scale reduction factor on split MCMC chains +#> (at convergence, Rhat = 1)

    Effects for gp() terms can also be plotted as smooths:

    plot_mvgam_smooth(mod, smooth = 1, newdata = data)
 abline(v = 190, lty = 'dashed', lwd = 2)
 lines(beta_temp, lwd = 2.5, col = 'white')
 lines(beta_temp, lwd = 2)
    -

    +

    @@ -667,25 +670,27 @@

    Salmon survival example

    proportional variable with particular restrictions that we want to model:

    plot_mvgam_series(data = model_data, y = 'survival')
    -

    +

    A State-Space Beta regression

    mvgam can easily handle data that are bounded at 0 and 1 with a Beta observation model (using the mgcv function betar(), see ?mgcv::betar for details). First -we will fit a simple State-Space model that uses a Random Walk dynamic -process model with no predictors and a Beta observation model:

    +we will fit a simple State-Space model that uses an AR1 dynamic process +model with no predictors and a Beta observation model:

    mod0 <- mvgam(formula = survival ~ 1,
-              trend_model = RW(),
-              family = betar(),
-              data = model_data)
    + trend_model = AR(), + noncentred = TRUE, + family = betar(), + data = model_data, + silent = 2)

    The summary of this model shows good behaviour of the Hamiltonian Monte Carlo sampler and provides useful summaries on the Beta observation model parameters:

    summary(mod0)
 #> GAM formula:
 #> survival ~ 1
-#> <environment: 0x000001820adad480>
+#> <environment: 0x0000014d37f0f110>
 #> 
 #> Family:
 #> beta
@@ -694,7 +699,7 @@ 
    A State-Space Beta regression
    
 #> logit
 #> 
 #> Trend model:
-#> RW
+#> AR()
 #> 
 #> N series:
 #> 1 
@@ -710,31 +715,32 @@ 
    A State-Space Beta regression
    
 #> 
 #> Observation precision parameter estimates:
 #>        2.5% 50% 97.5% Rhat n_eff
-#> phi[1]  160 310   570    1   633
+#> phi[1]   95 280   630 1.02   271
 #> 
 #> GAM coefficient (beta) estimates:
 #>             2.5%  50% 97.5% Rhat n_eff
-#> (Intercept) -4.2 -3.3  -2.4 1.01   147
+#> (Intercept) -4.7 -4.4    -4    1   625
 #> 
-#> Latent trend variance estimates:
-#>          2.5%  50% 97.5% Rhat n_eff
-#> sigma[1] 0.19 0.34  0.57 1.01   254
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 0 of 2000 iterations ended with a divergence (0%)
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 9:29:11 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +#> Latent trend parameter AR estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> ar1[1] -0.230 0.67 0.98 1.01 415 +#> sigma[1] 0.073 0.47 0.72 1.02 213 +#> +#> Stan MCMC diagnostics: +#> n_eff / iter looks reasonable for all parameters +#> Rhat looks reasonable for all parameters +#> 0 of 2000 iterations ended with a divergence (0%) +#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%) +#> E-FMI indicated no pathological behavior +#> +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:36:57 AM 2024. +#> For each parameter, n_eff is a crude measure of effective sample size, +#> and Rhat is the potential scale reduction factor on split MCMC chains +#> (at convergence, Rhat = 1)

    A plot of the underlying dynamic component shows how it has easily handled the temporal evolution of the time series:

    plot(mod0, type = 'trend')
    -

    +

    Including time-varying upwelling effects

    @@ -748,19 +754,21 @@

    Including time-varying upwelling effects

    to estimate it using a Hilbert space approximate GP:

    mod1 <- mvgam(formula = survival ~ 1,
               trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE),
-              trend_model = 'RW',
-              family = betar(),
-              data = model_data)
    + trend_model = AR(), + noncentred = TRUE, + family = betar(), + data = model_data, + silent = 2)

    The summary for this model now includes estimates for the time-varying GP parameters:

    summary(mod1, include_betas = FALSE)
 #> GAM observation formula:
 #> survival ~ 1
-#> <environment: 0x000001820adad480>
+#> <environment: 0x0000014d37f0f110>
 #> 
 #> GAM process formula:
 #> ~dynamic(CUI.apr, k = 25, scale = FALSE)
-#> <environment: 0x000001820adad480>
+#> <environment: 0x0000014d37f0f110>
 #> 
 #> Family:
 #> beta
@@ -769,7 +777,7 @@ 
    Including time-varying upwelling effects
    
 #> logit
 #> 
 #> Trend model:
-#> RW
+#> AR()
 #> 
 #> N process models:
 #> 1 
@@ -788,39 +796,43 @@ 
    Including time-varying upwelling effects
    
 #> 
 #> Observation precision parameter estimates:
 #>        2.5% 50% 97.5% Rhat n_eff
-#> phi[1]  180 350   620    1   931
+#> phi[1]  160 350   690    1   557
 #> 
 #> GAM observation model coefficient (beta) estimates:
-#>             2.5%  50% 97.5% Rhat n_eff
-#> (Intercept) -4.1 -3.3  -2.4 1.03    80
+#>             2.5% 50% 97.5% Rhat n_eff
+#> (Intercept) -4.7  -4  -2.6    1   331
 #> 
-#> Process error parameter estimates:
-#>          2.5% 50% 97.5% Rhat n_eff
-#> sigma[1] 0.15 0.3  0.49 1.02   215
+#> Process model AR parameter estimates:
+#>        2.5%  50% 97.5% Rhat n_eff
+#> ar1[1] 0.46 0.89  0.99 1.01   364
 #> 
-#> GAM process model gp term marginal deviation (alpha) and length scale (rho) estimates:
-#>                                2.5%  50% 97.5% Rhat n_eff
-#> alpha_gp_time_byCUI_apr_trend 0.027 0.31   1.3    1   680
-#> rho_gp_time_byCUI_apr_trend   1.300 6.50  34.0    1   668
-#> 
-#> Stan MCMC diagnostics:
-#> n_eff / iter looks reasonable for all parameters
-#> Rhat looks reasonable for all parameters
-#> 73 of 2000 iterations ended with a divergence (3.65%)
-#>  *Try running with larger adapt_delta to remove the divergences
-#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> E-FMI indicated no pathological behavior
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 9:31:10 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +#> Process error parameter estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> sigma[1] 0.18 0.35 0.58 1 596 +#> +#> GAM process model gp term marginal deviation (alpha) and length scale (rho) estimates: +#> 2.5% 50% 97.5% Rhat n_eff +#> alpha_gp_time_byCUI_apr_trend 0.02 0.3 1.2 1 760 +#> rho_gp_time_byCUI_apr_trend 1.30 5.5 28.0 1 674 +#> +#> Stan MCMC diagnostics: +#> n_eff / iter looks reasonable for all parameters +#> Rhat looks reasonable for all parameters +#> 79 of 2000 iterations ended with a divergence (3.95%) +#> *Try running with larger adapt_delta to remove the divergences +#> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%) +#> E-FMI indicated no pathological behavior +#> +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:37:32 AM 2024. +#> For each parameter, n_eff is a crude measure of effective sample size, +#> and Rhat is the potential scale reduction factor on split MCMC chains +#> (at convergence, Rhat = 1)

    The estimates for the underlying dynamic process, and for the hindcasts, haven’t changed much:

    plot(mod1, type = 'trend')
    -

    +

    plot(mod1, type = 'forecast')
    -

    +

    But the process error parameter \(\sigma\) is slightly smaller for this model than for the first model:

    # Extract estimates of the process error 'sigma' for each model
@@ -831,18 +843,17 @@ 
    Including time-varying upwelling effects
    
 sigmas <- rbind(mod0_sigma, mod1_sigma)
 
 # Plot using ggplot2
-library(ggplot2)
+require(ggplot2)
 ggplot(sigmas, aes(y = `sigma[1]`, fill = model)) +
   geom_density(alpha = 0.3, colour = NA) +
   coord_flip()
    -

    +

    Why does the process error not need to be as flexible in the second model? Because the estimates of this dynamic process are now informed partly by the time-varying effect of upwelling, which we can visualise -on the link scale using plot() with -trend_effects = TRUE:

    -
    plot(mod1, type = 'smooth', trend_effects = TRUE)
    -

    +on the link scale using plot():

    +
    plot(mod1, type = 'smooths', trend_effects = TRUE)
    +

    Comparing model predictive performances

    @@ -858,7 +869,7 @@

    Comparing model predictive performances

    #> Warning: Some Pareto k diagnostic values are too high. See help('pareto-k-diagnostic') for details. #> elpd_diff se_diff #> mod1 0.0 0.0 -#> mod0 -1.7 1.5
    +#> mod0 -6.5 2.7

    The second model has the larger Expected Log Predictive Density (ELPD), meaning that it is slightly favoured over the simpler model that did not include the time-varying upwelling effect. However, the two @@ -878,9 +889,9 @@

    Comparing model predictive performances

    The model with the time-varying upwelling effect tends to provides better 1-step ahead forecasts, with a higher total forecast ELPD

    sum(lfo_mod0$elpds)
-#> [1] 34.83384
+#> [1] 39.52656
 sum(lfo_mod1$elpds)
-#> [1] 35.99664
    +#> [1] 40.81327

    We can also plot the ELPDs for each model as a contrast. Here, values less than zero suggest the time-varying predictor model (Mod1) gives better 1-step ahead forecasts:

    @@ -892,7 +903,7 @@

    Comparing model predictive performances

    col = 'darkred', bty = 'l') abline(h = 0, lty = 'dashed') -

    Comparing forecast skill for dynamic beta regression models in mvgam and R

    +

    Comparing forecast skill for dynamic beta regression models in mvgam and R

    A useful exercise to further expand this model would be to think about what kinds of predictors might impact measurement error, which could easily be implemented into the observation formula in diff --git a/inst/doc/trend_formulas.R b/inst/doc/trend_formulas.R index 45ece59c..21ec225e 100644 --- a/inst/doc/trend_formulas.R +++ b/inst/doc/trend_formulas.R @@ -1,4 +1,4 @@ -## ----echo = FALSE----------------------------------------------------- +## ----echo = FALSE------------------------------------------------------------- NOT_CRAN <- identical(tolower(Sys.getenv("NOT_CRAN")), "true") knitr::opts_chunk$set( collapse = TRUE, @@ -8,7 +8,7 @@ knitr::opts_chunk$set( ) -## ----setup, include=FALSE--------------------------------------------- +## ----setup, include=FALSE----------------------------------------------------- knitr::opts_chunk$set( echo = TRUE, dpi = 100, @@ -21,15 +21,15 @@ library(ggplot2) theme_set(theme_bw(base_size = 12, base_family = 'serif')) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- load(url('https://github.com/atsa-es/MARSS/raw/master/data/lakeWAplankton.rda')) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- outcomes <- c('Greens', 'Bluegreens', 'Diatoms', 'Unicells', 'Other.algae') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- # loop across each plankton group to create the long datframe plankton_data <- do.call(rbind, lapply(outcomes, function(x){ @@ -57,19 +57,19 @@ plankton_data <- do.call(rbind, lapply(outcomes, function(x){ dplyr::ungroup() -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- head(plankton_data) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- dplyr::glimpse(plankton_data) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_mvgam_series(data = plankton_data, series = 'all') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plankton_data %>% dplyr::filter(series == 'Other.algae') %>% ggplot(aes(x = time, y = temp)) + @@ -83,7 +83,7 @@ plankton_data %>% ggtitle('Temperature (black) vs Other algae (red)') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plankton_data %>% dplyr::filter(series == 'Diatoms') %>% ggplot(aes(x = time, y = temp)) + @@ -97,14 +97,14 @@ plankton_data %>% ggtitle('Temperature (black) vs Diatoms (red)') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plankton_train <- plankton_data %>% dplyr::filter(time <= 112) plankton_test <- plankton_data %>% dplyr::filter(time > 112) -## ----notrend_mod, include = FALSE, results='hide'--------------------- +## ----notrend_mod, include = FALSE, results='hide'----------------------------- notrend_mod <- mvgam(y ~ te(temp, month, k = c(4, 4)) + te(temp, month, k = c(4, 4), by = series), @@ -114,7 +114,7 @@ notrend_mod <- mvgam(y ~ trend_model = 'None') -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## notrend_mod <- mvgam(y ~ ## # tensor of temp and month to capture ## # "global" seasonality @@ -129,43 +129,43 @@ notrend_mod <- mvgam(y ~ ## -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_mvgam_smooth(notrend_mod, smooth = 1) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_mvgam_smooth(notrend_mod, smooth = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot_mvgam_smooth(notrend_mod, smooth = 3) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'forecast', series = 1) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'forecast', series = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'forecast', series = 3) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'residuals', series = 1) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'residuals', series = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(notrend_mod, type = 'residuals', series = 3) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- priors <- get_mvgam_priors( # observation formula, which has no terms in it y ~ -1, @@ -175,25 +175,25 @@ priors <- get_mvgam_priors( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- priors[, 3] -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- priors[, 4] -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- priors <- c(prior(normal(0.5, 0.1), class = sigma_obs, lb = 0.2), prior(normal(0.5, 0.25), class = sigma)) -## ----var_mod, include = FALSE, results='hide'------------------------- +## ----var_mod, include = FALSE, results='hide'--------------------------------- var_mod <- mvgam(y ~ -1, trend_formula = ~ # tensor of temp and month should capture @@ -205,12 +205,13 @@ var_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1', + trend_model = VAR(), priors = priors, + adapt_delta = 0.99, burnin = 1000) -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## var_mod <- mvgam( ## # observation formula, which is empty ## y ~ -1, @@ -220,24 +221,25 @@ var_mod <- mvgam(y ~ -1, ## te(temp, month, k = c(4, 4), by = trend), ## ## # VAR1 model with uncorrelated process errors -## trend_model = 'VAR1', +## trend_model = VAR(), ## family = gaussian(), ## data = plankton_train, ## newdata = plankton_test, ## ## # include the updated priors -## priors = priors) +## priors = priors, +## silent = 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- summary(var_mod, include_betas = FALSE) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- plot(var_mod, 'smooths', trend_effects = TRUE) -## ----warning=FALSE, message=FALSE------------------------------------- +## ----warning=FALSE, message=FALSE--------------------------------------------- A_pars <- matrix(NA, nrow = 5, ncol = 5) for(i in 1:5){ for(j in 1:5){ @@ -249,7 +251,7 @@ mcmc_plot(var_mod, type = 'hist') -## ----warning=FALSE, message=FALSE------------------------------------- +## ----warning=FALSE, message=FALSE--------------------------------------------- Sigma_pars <- matrix(NA, nrow = 5, ncol = 5) for(i in 1:5){ for(j in 1:5){ @@ -261,16 +263,16 @@ mcmc_plot(var_mod, type = 'hist') -## ----warning=FALSE, message=FALSE------------------------------------- +## ----warning=FALSE, message=FALSE--------------------------------------------- mcmc_plot(var_mod, variable = 'sigma_obs', regex = TRUE, type = 'hist') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- priors <- c(prior(normal(0.5, 0.1), class = sigma_obs, lb = 0.2), prior(normal(0.5, 0.25), class = sigma)) -## ----varcor_mod, include = FALSE, results='hide'---------------------- +## ----varcor_mod, include = FALSE, results='hide'------------------------------ varcor_mod <- mvgam(y ~ -1, trend_formula = ~ # tensor of temp and month should capture @@ -282,12 +284,13 @@ varcor_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), burnin = 1000, + adapt_delta = 0.99, priors = priors) -## ----eval=FALSE------------------------------------------------------- +## ----eval=FALSE--------------------------------------------------------------- ## varcor_mod <- mvgam( ## # observation formula, which remains empty ## y ~ -1, @@ -297,16 +300,17 @@ varcor_mod <- mvgam(y ~ -1, ## te(temp, month, k = c(4, 4), by = trend), ## ## # VAR1 model with correlated process errors -## trend_model = 'VAR1cor', +## trend_model = VAR(cor = TRUE), ## family = gaussian(), ## data = plankton_train, ## newdata = plankton_test, ## ## # include the updated priors -## priors = priors) +## priors = priors, +## silent = 2) -## ----warning=FALSE, message=FALSE------------------------------------- +## ----warning=FALSE, message=FALSE--------------------------------------------- Sigma_pars <- matrix(NA, nrow = 5, ncol = 5) for(i in 1:5){ for(j in 1:5){ @@ -318,7 +322,7 @@ mcmc_plot(varcor_mod, type = 'hist') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- Sigma_post <- as.matrix(varcor_mod, variable = 'Sigma', regex = TRUE) median_correlations <- cov2cor(matrix(apply(Sigma_post, 2, median), nrow = 5, ncol = 5)) @@ -327,7 +331,7 @@ rownames(median_correlations) <- colnames(median_correlations) <- levels(plankto round(median_correlations, 2) -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- # create forecast objects for each model fcvar <- forecast(var_mod) fcvarcor <- forecast(varcor_mod) @@ -344,7 +348,7 @@ plot(diff_scores, pch = 16, cex = 1.25, col = 'darkred', abline(h = 0, lty = 'dashed') -## --------------------------------------------------------------------- +## ----------------------------------------------------------------------------- # plot the difference in energy scores; a negative value means the VAR1cor model is better, while a positive value means the VAR1 model is better diff_scores <- score(fcvarcor, score = 'energy')$all_series$score - score(fcvar, score = 'energy')$all_series$score diff --git a/inst/doc/trend_formulas.Rmd b/inst/doc/trend_formulas.Rmd index 46dbe8a5..387a8708 100644 --- a/inst/doc/trend_formulas.Rmd +++ b/inst/doc/trend_formulas.Rmd @@ -231,7 +231,7 @@ priors <- get_mvgam_priors( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train) ``` @@ -265,8 +265,9 @@ var_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1', + trend_model = VAR(), priors = priors, + adapt_delta = 0.99, burnin = 1000) ``` @@ -280,13 +281,14 @@ var_mod <- mvgam( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train, newdata = plankton_test, # include the updated priors - priors = priors) + priors = priors, + silent = 2) ``` ### Inspecting SS models @@ -313,7 +315,7 @@ mcmc_plot(var_mod, type = 'hist') ``` -There is a lot happening in this matrix. Each cell captures the lagged effect of the process in the column on the process in the row in the next timestep. So for example, the effect in cell [1,3], which is quite strongly negative, means that an *increase* in the process for series 3 (Greens) at time $t$ is expected to lead to a subsequent *decrease* in the process for series 1 (Bluegreens) at time $t+1$. The latent process model is now capturing these effects and the smooth seasonal effects. +There is a lot happening in this matrix. Each cell captures the lagged effect of the process in the column on the process in the row in the next timestep. So for example, the effect in cell [1,3] shows how an *increase* in the process for series 3 (Greens) at time $t$ is expected to impact the process for series 1 (Bluegreens) at time $t+1$. The latent process model is now capturing these effects and the smooth seasonal effects. The process error $(\Sigma)$ captures unmodelled variation in the process models. Again, we fixed the off-diagonals to 0, so the histograms for these will look like flat boxes: ```{r warning=FALSE, message=FALSE} @@ -356,8 +358,9 @@ varcor_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), burnin = 1000, + adapt_delta = 0.99, priors = priors) ``` @@ -371,13 +374,14 @@ varcor_mod <- mvgam( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with correlated process errors - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), family = gaussian(), data = plankton_train, newdata = plankton_test, # include the updated priors - priors = priors) + priors = priors, + silent = 2) ``` The $(\Sigma)$ matrix now captures any evidence of contemporaneously correlated process error: @@ -393,7 +397,7 @@ mcmc_plot(varcor_mod, type = 'hist') ``` -This symmetric matrix tells us there is support for correlated process errors. For example, series 1 and 3 (Bluegreens and Greens) show negatively correlated process errors, while series 1 and 4 (Bluegreens and Other.algae) show positively correlated errors. But it is easier to interpret these estimates if we convert the covariance matrix to a correlation matrix. Here we compute the posterior median process error correlations: +This symmetric matrix tells us there is support for correlated process errors, as several of the off-diagonal entries are strongly non-zero. But it is easier to interpret these estimates if we convert the covariance matrix to a correlation matrix. Here we compute the posterior median process error correlations: ```{r} Sigma_post <- as.matrix(varcor_mod, variable = 'Sigma', regex = TRUE) median_correlations <- cov2cor(matrix(apply(Sigma_post, 2, median), diff --git a/inst/doc/trend_formulas.html b/inst/doc/trend_formulas.html index 0cbb003a..5e2a8efc 100644 --- a/inst/doc/trend_formulas.html +++ b/inst/doc/trend_formulas.html @@ -12,7 +12,7 @@ - + State-Space models in mvgam @@ -340,7 +340,7 @@

    State-Space models in mvgam

    Nicholas J Clark

    -

    2024-05-08

    +

    2024-07-01

    @@ -536,38 +536,38 @@

    Capturing seasonality

    The “global” tensor product smooth function can be quickly visualized:

    plot_mvgam_smooth(notrend_mod, smooth = 1)
    -

    +

    On this plot, red indicates below-average linear predictors and white indicates above-average. We can then plot the deviation smooths for a few algal groups to see how they vary from the “global” pattern:

    plot_mvgam_smooth(notrend_mod, smooth = 2)
    -

    +

    plot_mvgam_smooth(notrend_mod, smooth = 3)
    -

    +

    These multidimensional smooths have done a good job of capturing the seasonal variation in our observations:

    plot(notrend_mod, type = 'forecast', series = 1)
 #> Out of sample CRPS:
-#> 6.76565115609046
    -

    +#> 6.77172874237756
    +

    plot(notrend_mod, type = 'forecast', series = 2)
 #> Out of sample CRPS:
-#> 6.8078256849951
    -

    +#> 6.75657325046048 +

    plot(notrend_mod, type = 'forecast', series = 3)
 #> Out of sample CRPS:
-#> 4.12245753246738
    -

    +#> 4.09992574037549 +

    This basic model gives us confidence that we can capture the seasonal variation in the observations. But the model has not captured the remaining temporal dynamics, which is obvious when we inspect Dunn-Smyth residuals for a few series:

    plot(notrend_mod, type = 'residuals', series = 1)
    -

    +

    plot(notrend_mod, type = 'residuals', series = 2)
    -

    +

    plot(notrend_mod, type = 'residuals', series = 3)
    -

    +

    Multiseries dynamics

    @@ -639,7 +639,7 @@

    Multiseries dynamics

    te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train)

    Get names of all parameters whose priors can be modified:

    @@ -694,13 +694,14 @@

    Multiseries dynamics

    te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train, newdata = plankton_test, # include the updated priors - priors = priors) + priors = priors, + silent = 2)

    Inspecting SS models

    @@ -718,12 +719,12 @@

    Inspecting SS models

    summary(var_mod, include_betas = FALSE)
 #> GAM observation formula:
 #> y ~ 1
-#> <environment: 0x000001ea39b95140>
+#> <environment: 0x00000241693f91f0>
 #> 
 #> GAM process formula:
 #> ~te(temp, month, k = c(4, 4)) + te(temp, month, k = c(4, 4), 
 #>     by = trend)
-#> <environment: 0x000001ea39b95140>
+#> <environment: 0x00000241693f91f0>
 #> 
 #> Family:
 #> gaussian
@@ -732,7 +733,7 @@ 
    Inspecting SS models
    
 #> identity
 #> 
 #> Trend model:
-#> VAR1
+#> VAR()
 #> 
 #> N process models:
 #> 5 
@@ -751,11 +752,11 @@ 
    Inspecting SS models
    
 #> 
 #> Observation error parameter estimates:
 #>              2.5%  50% 97.5% Rhat n_eff
-#> sigma_obs[1] 0.20 0.26  0.34 1.01   453
-#> sigma_obs[2] 0.27 0.40  0.54 1.00   284
-#> sigma_obs[3] 0.42 0.64  0.81 1.02    90
-#> sigma_obs[4] 0.25 0.37  0.50 1.01   340
-#> sigma_obs[5] 0.31 0.43  0.53 1.02   266
+#> sigma_obs[1] 0.20 0.25  0.34 1.01   508
+#> sigma_obs[2] 0.27 0.40  0.54 1.03   179
+#> sigma_obs[3] 0.43 0.64  0.82 1.13    20
+#> sigma_obs[4] 0.25 0.37  0.50 1.00   378
+#> sigma_obs[5] 0.30 0.43  0.54 1.03   229
 #> 
 #> GAM observation model coefficient (beta) estimates:
 #>             2.5% 50% 97.5% Rhat n_eff
@@ -763,88 +764,87 @@ 
    Inspecting SS models
    
 #> 
 #> Process model VAR parameter estimates:
 #>          2.5%    50% 97.5% Rhat n_eff
-#> A[1,1] -0.015  0.500 0.830 1.01   171
-#> A[1,2] -0.330 -0.030 0.210 1.01   485
-#> A[1,3] -0.490 -0.024 0.330 1.00   332
-#> A[1,4] -0.260  0.027 0.380 1.00   706
-#> A[1,5] -0.100  0.120 0.510 1.02   218
-#> A[2,1] -0.180  0.012 0.180 1.02   238
-#> A[2,2]  0.630  0.790 0.920 1.01   435
-#> A[2,3] -0.400 -0.120 0.048 1.01   370
-#> A[2,4] -0.044  0.100 0.340 1.02   307
-#> A[2,5] -0.050  0.056 0.210 1.01   480
-#> A[3,1] -0.600  0.013 0.310 1.09    47
-#> A[3,2] -0.500 -0.180 0.031 1.03   156
-#> A[3,3]  0.049  0.450 0.730 1.01   259
-#> A[3,4] -0.039  0.210 0.630 1.02   189
-#> A[3,5] -0.064  0.120 0.400 1.04   183
-#> A[4,1] -0.250  0.049 0.300 1.05    91
-#> A[4,2] -0.110  0.055 0.260 1.00   540
-#> A[4,3] -0.460 -0.110 0.110 1.01   274
-#> A[4,4]  0.470  0.740 0.950 1.01   348
-#> A[4,5] -0.190 -0.032 0.140 1.01   555
-#> A[5,1] -0.520  0.072 0.450 1.11    32
-#> A[5,2] -0.430 -0.110 0.090 1.02   209
-#> A[5,3] -0.650 -0.170 0.130 1.02   185
-#> A[5,4] -0.057  0.180 0.570 1.02   226
-#> A[5,5]  0.540  0.730 0.980 1.06    69
+#> A[1,1]  0.038  0.520 0.870 1.08    32
+#> A[1,2] -0.350 -0.030 0.200 1.00   497
+#> A[1,3] -0.530 -0.044 0.330 1.02   261
+#> A[1,4] -0.280  0.038 0.420 1.00   392
+#> A[1,5] -0.100  0.120 0.510 1.04   141
+#> A[2,1] -0.160  0.011 0.200 1.00  1043
+#> A[2,2]  0.620  0.790 0.910 1.01   418
+#> A[2,3] -0.400 -0.130 0.045 1.03   291
+#> A[2,4] -0.034  0.110 0.360 1.02   274
+#> A[2,5] -0.048  0.061 0.200 1.01   585
+#> A[3,1] -0.260  0.025 0.560 1.10    28
+#> A[3,2] -0.530 -0.200 0.027 1.02   167
+#> A[3,3]  0.069  0.430 0.740 1.01   256
+#> A[3,4] -0.022  0.230 0.660 1.02   162
+#> A[3,5] -0.094  0.120 0.390 1.02   208
+#> A[4,1] -0.150  0.058 0.360 1.03   137
+#> A[4,2] -0.110  0.063 0.270 1.01   360
+#> A[4,3] -0.430 -0.110 0.140 1.01   312
+#> A[4,4]  0.470  0.730 0.950 1.02   278
+#> A[4,5] -0.200 -0.036 0.130 1.01   548
+#> A[5,1] -0.190  0.083 0.650 1.08    41
+#> A[5,2] -0.460 -0.120 0.076 1.04   135
+#> A[5,3] -0.620 -0.180 0.130 1.04   153
+#> A[5,4] -0.062  0.190 0.660 1.04   140
+#> A[5,5]  0.510  0.740 0.930 1.00   437
 #> 
 #> Process error parameter estimates:
 #>             2.5%  50% 97.5% Rhat n_eff
-#> Sigma[1,1] 0.034 0.28  0.65 1.02    77
+#> Sigma[1,1] 0.033 0.27  0.64 1.20     9
 #> Sigma[1,2] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[1,3] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[1,4] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[1,5] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[2,1] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[2,2] 0.065 0.11  0.18 1.00   508
+#> Sigma[2,2] 0.066 0.12  0.18 1.01   541
 #> Sigma[2,3] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[2,4] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[2,5] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[3,1] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[3,2] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[3,3] 0.061 0.16  0.30 1.02   179
+#> Sigma[3,3] 0.051 0.16  0.29 1.04   163
 #> Sigma[3,4] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[3,5] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[4,1] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[4,2] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[4,3] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[4,4] 0.058 0.13  0.27 1.01   199
+#> Sigma[4,4] 0.054 0.14  0.28 1.03   182
 #> Sigma[4,5] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[5,1] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[5,2] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[5,3] 0.000 0.00  0.00  NaN   NaN
 #> Sigma[5,4] 0.000 0.00  0.00  NaN   NaN
-#> Sigma[5,5] 0.100 0.21  0.35 1.02   256
+#> Sigma[5,5] 0.100 0.21  0.35 1.01   343
 #> 
 #> Approximate significance of GAM process smooths:
-#>                               edf Ref.df    F p-value
-#> te(temp,month)              3.409     15 2.05    0.43
-#> te(temp,month):seriestrend1 2.137     15 0.07    1.00
-#> te(temp,month):seriestrend2 0.843     15 0.93    1.00
-#> te(temp,month):seriestrend3 4.421     15 3.01    0.41
-#> te(temp,month):seriestrend4 2.639     15 0.56    0.97
-#> te(temp,month):seriestrend5 1.563     15 0.35    1.00
+#>                               edf Ref.df Chi.sq p-value
+#> te(temp,month)              2.902     15  43.54    0.44
+#> te(temp,month):seriestrend1 2.001     15   1.66    1.00
+#> te(temp,month):seriestrend2 0.943     15   7.03    1.00
+#> te(temp,month):seriestrend3 5.867     15  45.04    0.21
+#> te(temp,month):seriestrend4 2.984     15   9.12    0.98
+#> te(temp,month):seriestrend5 1.986     15   4.66    1.00
 #> 
 #> Stan MCMC diagnostics:
 #> n_eff / iter looks reasonable for all parameters
-#> Rhats above 1.05 found for 5 parameters
+#> Rhats above 1.05 found for 33 parameters
 #>  *Diagnose further to investigate why the chains have not mixed
 #> 0 of 2000 iterations ended with a divergence (0%)
 #> 0 of 2000 iterations saturated the maximum tree depth of 12 (0%)
-#> Chain 3: E-FMI = 0.1497
-#>  *E-FMI below 0.2 indicates you may need to reparameterize your model
-#> 
-#> Samples were drawn using NUTS(diag_e) at Wed May 08 9:01:11 PM 2024.
-#> For each parameter, n_eff is a crude measure of effective sample size,
-#> and Rhat is the potential scale reduction factor on split MCMC chains
-#> (at convergence, Rhat = 1)
    +#> E-FMI indicated no pathological behavior +#> +#> Samples were drawn using NUTS(diag_e) at Mon Jul 01 7:43:45 AM 2024. +#> For each parameter, n_eff is a crude measure of effective sample size, +#> and Rhat is the potential scale reduction factor on split MCMC chains +#> (at convergence, Rhat = 1)

    The convergence of this model isn’t fabulous (more on this in a moment). But we can again plot the smooth functions, which this time operate on the process model. We can see the same plot using trend_effects = TRUE in the plotting functions:

    plot(var_mod, 'smooths', trend_effects = TRUE)
    -

    +

    The VAR matrix is of particular interest here, as it captures lagged dependencies and cross-dependencies in the latent process model. Unfortunately bayesplot doesn’t know this is a matrix of @@ -860,13 +860,11 @@

    Inspecting SS models

    mcmc_plot(var_mod, variable = as.vector(t(A_pars)), type = 'hist') -

    +

    There is a lot happening in this matrix. Each cell captures the lagged effect of the process in the column on the process in the row in -the next timestep. So for example, the effect in cell [1,3], which is -quite strongly negative, means that an increase in the process -for series 3 (Greens) at time \(t\) is -expected to lead to a subsequent decrease in the process for +the next timestep. So for example, the effect in cell [1,3] shows how an +increase in the process for series 3 (Greens) at time \(t\) is expected to impact the process for series 1 (Bluegreens) at time \(t+1\). The latent process model is now capturing these effects and the smooth seasonal effects.

    @@ -883,12 +881,12 @@

    Inspecting SS models

    mcmc_plot(var_mod, variable = as.vector(t(Sigma_pars)), type = 'hist') -

    +

    The observation error estimates \((\sigma_{obs})\) represent how much the model thinks we might miss the true count when we take our imperfect measurements:

    mcmc_plot(var_mod, variable = 'sigma_obs', regex = TRUE, type = 'hist')
    -

    +

    These are still a bit hard to identify overall, especially when trying to estimate both process and observation error. Often we need to make some strong assumptions about which of these is more important for @@ -911,13 +909,14 @@

    Correlated process errors

    te(temp, month, k = c(4, 4), by = trend), # VAR1 model with correlated process errors - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), family = gaussian(), data = plankton_train, newdata = plankton_test, # include the updated priors - priors = priors) + priors = priors, + silent = 2)

    The \((\Sigma)\) matrix now captures any evidence of contemporaneously correlated process error:

    Sigma_pars <- matrix(NA, nrow = 5, ncol = 5)
@@ -929,14 +928,12 @@ 
    Correlated process errors
    
 mcmc_plot(varcor_mod, 
           variable = as.vector(t(Sigma_pars)), 
           type = 'hist')
    -

    +

    This symmetric matrix tells us there is support for correlated -process errors. For example, series 1 and 3 (Bluegreens and Greens) show -negatively correlated process errors, while series 1 and 4 (Bluegreens -and Other.algae) show positively correlated errors. But it is easier to -interpret these estimates if we convert the covariance matrix to a -correlation matrix. Here we compute the posterior median process error -correlations:

    +process errors, as several of the off-diagonal entries are strongly +non-zero. But it is easier to interpret these estimates if we convert +the covariance matrix to a correlation matrix. Here we compute the +posterior median process error correlations:

    Sigma_post <- as.matrix(varcor_mod, variable = 'Sigma', regex = TRUE)
 median_correlations <- cov2cor(matrix(apply(Sigma_post, 2, median),
                                       nrow = 5, ncol = 5))
@@ -944,11 +941,11 @@ 
    Correlated process errors
    
 
 round(median_correlations, 2)
 #>             Bluegreens Diatoms Greens Other.algae Unicells
-#> Bluegreens        1.00   -0.04   0.16       -0.08     0.30
-#> Diatoms          -0.04    1.00  -0.21        0.47     0.17
-#> Greens            0.16   -0.21   1.00        0.18     0.46
-#> Other.algae      -0.08    0.47   0.18        1.00     0.26
-#> Unicells          0.30    0.17   0.46        0.26     1.00
    +#> Bluegreens 1.00 -0.04 0.16 -0.05 0.29 +#> Diatoms -0.04 1.00 -0.21 0.48 0.17 +#> Greens 0.16 -0.21 1.00 0.17 0.46 +#> Other.algae -0.05 0.48 0.17 1.00 0.28 +#> Unicells 0.29 0.17 0.46 0.28 1.00

    But which model is better? We can compute the variogram score for out of sample forecasts to get a sense of which model does a better job of capturing the dependence structure in the true evaluation set:

    @@ -966,7 +963,7 @@

    Correlated process errors

    xlab = 'Forecast horizon', ylab = expression(variogram[VAR1cor]~-~variogram[VAR1])) abline(h = 0, lty = 'dashed') -

    +

    And we can also compute the energy score for out of sample forecasts to get a sense of which model provides forecasts that are better calibrated:

    @@ -980,7 +977,7 @@

    Correlated process errors

    xlab = 'Forecast horizon', ylab = expression(energy[VAR1cor]~-~energy[VAR1])) abline(h = 0, lty = 'dashed') -

    +

    The models tend to provide similar forecasts, though the correlated error model does slightly better overall. We would probably need to use a more extensive rolling forecast evaluation exercise if we felt like we diff --git a/man/conditional_effects.mvgam.Rd b/man/conditional_effects.mvgam.Rd index 951a39f6..9d97505d 100644 --- a/man/conditional_effects.mvgam.Rd +++ b/man/conditional_effects.mvgam.Rd @@ -77,7 +77,7 @@ continuous variables and the reference category is used for factors. Use and create more bespoke conditional effects plots. } \examples{ -\dontrun{ +\donttest{ # Simulate some data simdat <- sim_mvgam(family = poisson(), seasonality = 'hierarchical') @@ -86,9 +86,7 @@ simdat <- sim_mvgam(family = poisson(), mod <- mvgam(y ~ s(season, by = series, k = 5) + year:series, family = poisson(), data = simdat$data_train, - chains = 2, - burnin = 300, - samples = 300) + chains = 2) # Plot all main effects on the response scale conditional_effects(mod) @@ -106,9 +104,7 @@ 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, - burnin = 300, - samples = 300) + chains = 2) conditional_effects(mod) conditional_effects(mod, conf_level = 0.5, type = 'link') } diff --git a/man/dynamic.Rd b/man/dynamic.Rd index cfca461d..4c7a9053 100644 --- a/man/dynamic.Rd +++ b/man/dynamic.Rd @@ -54,7 +54,7 @@ set automatically to ensure enough basis functions are used to approximate the e wiggliness of the underlying dynamic function (\code{k} will increase as \code{rho} decreases) } \examples{ -\dontrun{ +\donttest{ # Simulate a time-varying coefficient #(as a Gaussian Process with length scale = 10) set.seed(1111) diff --git a/man/figures/README-beta_fc-1.png b/man/figures/README-beta_fc-1.png index fd585092..ce3cd414 100644 Binary files a/man/figures/README-beta_fc-1.png and b/man/figures/README-beta_fc-1.png differ diff --git a/man/figures/README-unnamed-chunk-12-1.png b/man/figures/README-unnamed-chunk-12-1.png index 424187f6..c17c5edf 100644 Binary files a/man/figures/README-unnamed-chunk-12-1.png and b/man/figures/README-unnamed-chunk-12-1.png differ diff --git a/man/figures/README-unnamed-chunk-13-1.png b/man/figures/README-unnamed-chunk-13-1.png index 080205de..b2cfbc0a 100644 Binary files a/man/figures/README-unnamed-chunk-13-1.png and b/man/figures/README-unnamed-chunk-13-1.png differ diff --git a/man/figures/README-unnamed-chunk-14-1.png b/man/figures/README-unnamed-chunk-14-1.png index 21a95e17..33cc6049 100644 Binary files a/man/figures/README-unnamed-chunk-14-1.png and b/man/figures/README-unnamed-chunk-14-1.png differ diff --git a/man/figures/README-unnamed-chunk-15-1.png b/man/figures/README-unnamed-chunk-15-1.png index d5b8585b..76a07c65 100644 Binary files a/man/figures/README-unnamed-chunk-15-1.png and b/man/figures/README-unnamed-chunk-15-1.png differ diff --git a/man/figures/README-unnamed-chunk-16-1.png b/man/figures/README-unnamed-chunk-16-1.png index b2ea9696..0a34b924 100644 Binary files a/man/figures/README-unnamed-chunk-16-1.png and b/man/figures/README-unnamed-chunk-16-1.png differ diff --git a/man/figures/README-unnamed-chunk-17-1.png b/man/figures/README-unnamed-chunk-17-1.png index 82ea67db..19670803 100644 Binary files a/man/figures/README-unnamed-chunk-17-1.png and b/man/figures/README-unnamed-chunk-17-1.png differ diff --git a/man/figures/README-unnamed-chunk-18-1.png b/man/figures/README-unnamed-chunk-18-1.png index 20b690d5..5749f681 100644 Binary files a/man/figures/README-unnamed-chunk-18-1.png and b/man/figures/README-unnamed-chunk-18-1.png differ diff --git a/man/figures/README-unnamed-chunk-19-1.png b/man/figures/README-unnamed-chunk-19-1.png index 0aff9cf5..9366be92 100644 Binary files a/man/figures/README-unnamed-chunk-19-1.png and b/man/figures/README-unnamed-chunk-19-1.png differ diff --git a/man/figures/README-unnamed-chunk-20-1.png b/man/figures/README-unnamed-chunk-20-1.png index 77c1cb41..ea9c0caf 100644 Binary files a/man/figures/README-unnamed-chunk-20-1.png and b/man/figures/README-unnamed-chunk-20-1.png differ diff --git a/man/figures/README-unnamed-chunk-21-1.png b/man/figures/README-unnamed-chunk-21-1.png index afd00553..9871d757 100644 Binary files a/man/figures/README-unnamed-chunk-21-1.png and b/man/figures/README-unnamed-chunk-21-1.png differ diff --git a/man/figures/README-unnamed-chunk-22-1.png b/man/figures/README-unnamed-chunk-22-1.png index 57ca851b..c5658791 100644 Binary files a/man/figures/README-unnamed-chunk-22-1.png and b/man/figures/README-unnamed-chunk-22-1.png differ diff --git a/man/figures/README-unnamed-chunk-23-1.png b/man/figures/README-unnamed-chunk-23-1.png index c0e06652..f908b9ab 100644 Binary files a/man/figures/README-unnamed-chunk-23-1.png and b/man/figures/README-unnamed-chunk-23-1.png differ diff --git a/man/forecast.mvgam.Rd b/man/forecast.mvgam.Rd index 9341abcc..62299688 100644 --- a/man/forecast.mvgam.Rd +++ b/man/forecast.mvgam.Rd @@ -55,13 +55,12 @@ Extract or compute hindcasts and forecasts for a fitted \code{mvgam} object Posterior predictions are drawn from the fitted \code{mvgam} and used to simulate a forecast distribution } \examples{ -\dontrun{ -simdat <- sim_mvgam(n_series = 3, trend_model = 'AR1') +\donttest{ +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, - burnin = 300, - samples = 300, chains = 2) # Hindcasts on response scale diff --git a/man/hindcast.mvgam.Rd b/man/hindcast.mvgam.Rd index 7bab4bb8..fad8fa3b 100644 --- a/man/hindcast.mvgam.Rd +++ b/man/hindcast.mvgam.Rd @@ -33,7 +33,6 @@ detection probability from an N-mixture distribution} \value{ An object of class \code{mvgam_forecast} containing hindcast distributions. See \code{\link{mvgam_forecast-class}} for details. -#'@seealso \code{\link{forecast.mvgam}} } \description{ Extract hindcasts for a fitted \code{mvgam} object @@ -43,13 +42,12 @@ Posterior retrodictions are drawn from the fitted \code{mvgam} and organized into a convenient format } \examples{ -\dontrun{ -simdat <- sim_mvgam(n_series = 3, trend_model = 'AR1') +\donttest{ +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, - burnin = 300, - samples = 300, chains = 2) # Hindcasts on response scale @@ -74,3 +72,6 @@ plot(hc, series = 2) plot(hc, series = 3) } } +\seealso{ +\code{\link{forecast.mvgam}} +} diff --git a/man/loo.mvgam.Rd b/man/loo.mvgam.Rd index c044f6ee..34b184fc 100644 --- a/man/loo.mvgam.Rd +++ b/man/loo.mvgam.Rd @@ -59,7 +59,7 @@ forecast evaluations for further scrutiny of models (see for example \code{\link \code{\link{score.mvgam_forecast}} and \code{\link{lfo_cv}}) } \examples{ -\dontrun{ +\donttest{ # Simulate 4 time series with hierarchical seasonality # and independent AR1 dynamic processes set.seed(111) diff --git a/man/mcmc_plot.mvgam.Rd b/man/mcmc_plot.mvgam.Rd index 6c16e39b..311be9ee 100644 --- a/man/mcmc_plot.mvgam.Rd +++ b/man/mcmc_plot.mvgam.Rd @@ -53,12 +53,11 @@ implemented in the \pkg{bayesplot} package } \examples{ \dontrun{ -simdat <- sim_mvgam(n_series = 1, trend_model = 'AR1') +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, - burnin = 300, - samples = 300, chains = 2) mcmc_plot(mod) mcmc_plot(mod, type = 'neff_hist') diff --git a/man/monotonic.Rd b/man/monotonic.Rd index 761448ca..2a7f5074 100644 --- a/man/monotonic.Rd +++ b/man/monotonic.Rd @@ -61,7 +61,7 @@ functions will not be guaranteed to be monotonic because constraints on basis coefficients will not be enforced } \examples{ -\dontrun{ +\donttest{ # Simulate data from a monotonically increasing function set.seed(123123) x <- runif(80) * 4 - 1 @@ -71,6 +71,7 @@ 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, @@ -89,8 +90,6 @@ mod_data$time <- 1:NROW(mod_data) mod2 <- mvgam(y ~ s(x, bs = 'moi', k = 18), data = mod_data, family = gaussian(), - burnin = 300, - samples = 300, chains = 2) plot_predictions(mod2, @@ -125,8 +124,6 @@ mod_data$time <- 1:NROW(mod_data) mod <- mvgam(y ~ s(x, bs = 'moi', by = fac, k = 8), data = mod_data, family = gaussian(), - burnin = 300, - samples = 300, chains = 2) # Visualise the different monotonic functions diff --git a/man/mvgam.Rd b/man/mvgam.Rd index 9fbb37d5..cd67fb90 100644 --- a/man/mvgam.Rd +++ b/man/mvgam.Rd @@ -422,6 +422,7 @@ mod1 <- mvgam(formula = y ~ s(season, bs = 'cc', k = 6), data = dat$data_train, trend_model = AR(), family = poisson(), + noncentred = TRUE, use_stan = TRUE, run_model = FALSE) @@ -466,6 +467,7 @@ plot(mod1, type = 'smooths', residuals = TRUE) plot(mod1, type = 'smooths', realisations = TRUE) # Plot conditional response predictions using marginaleffects +library(marginaleffects) conditional_effects(mod1) plot_predictions(mod1, condition = 'season', points = 0.5) @@ -560,7 +562,8 @@ points(beta_temp, pch = 16) # 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') +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) diff --git a/man/mvgam_diagnostics.Rd b/man/mvgam_diagnostics.Rd index 2432a12d..e483b900 100644 --- a/man/mvgam_diagnostics.Rd +++ b/man/mvgam_diagnostics.Rd @@ -43,13 +43,12 @@ For more details see \code{\link[bayesplot:bayesplot-extractors]{bayesplot-extractors}}. } \examples{ -\dontrun{ +\donttest{ 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, - burnin = 300, - samples = 300, chains = 2) np <- nuts_params(mod) head(np) diff --git a/man/mvgam_families.Rd b/man/mvgam_families.Rd index e9936c73..6d993699 100644 --- a/man/mvgam_families.Rd +++ b/man/mvgam_families.Rd @@ -4,6 +4,8 @@ \alias{mvgam_families} \alias{tweedie} \alias{student_t} +\alias{betar} +\alias{nb} \alias{nmix} \title{Supported mvgam families} \usage{ @@ -11,11 +13,17 @@ tweedie(link = "log") student_t(link = "identity") +betar(...) + +nb(...) + nmix(link = "log") } \arguments{ \item{link}{a specification for the family link function. At present these cannot be changed} + +\item{...}{Arguments to be passed to the \pkg{mgcv} version of the associated functions} } \value{ Objects of class \code{family} @@ -62,7 +70,7 @@ Note that currently it is not possible to change the default link functions in \code{mvgam}, so any call to change these will be silently ignored } \examples{ -\dontrun{ +\donttest{ # Example showing how to set up N-mixture models set.seed(999) # Simulate observations for species 1, which shows a declining trend and 0.7 detection probability @@ -156,15 +164,13 @@ mod <- mvgam( # priors can be set in the usual way priors = c(prior(std_normal(), class = b), prior(normal(1, 1.5), class = Intercept_trend)), - burnin = 300, - samples = 300, chains = 2) # The usual diagnostics summary(mod) # Plotting conditional effects -library(ggplot2) +library(ggplot2); library(marginaleffects) plot_predictions(mod, condition = 'species', type = 'detection') + ylab('Pr(detection)') + diff --git a/man/mvgam_marginaleffects.Rd b/man/mvgam_marginaleffects.Rd index 16e6648e..5564cfdb 100644 --- a/man/mvgam_marginaleffects.Rd +++ b/man/mvgam_marginaleffects.Rd @@ -86,8 +86,6 @@ arguments.} \item \code{newdata = datagrid(cyl = c(4, 6))}: \code{cyl} variable equal to 4 and 6 and other regressors fixed at their means or modes. \item See the Examples section and the \code{\link[marginaleffects:datagrid]{datagrid()}} documentation. } -\item \code{\link[=subset]{subset()}} call with a single argument to select a subset of the dataset used to fit the model, ex: \code{newdata = subset(treatment == 1)} -\item \code{\link[dplyr:filter]{dplyr::filter()}} call with a single argument to select a subset of the dataset used to fit the model, ex: \code{newdata = filter(treatment == 1)} \item string: \itemize{ \item "mean": Marginal Effects at the Mean. Slopes when each predictor is held at its mean or mode. diff --git a/man/pairs.mvgam.Rd b/man/pairs.mvgam.Rd index d9caa3db..eb37b4e3 100644 --- a/man/pairs.mvgam.Rd +++ b/man/pairs.mvgam.Rd @@ -36,10 +36,11 @@ For a detailed description see \code{\link[bayesplot:MCMC-scatterplots]{mcmc_pairs}}. } \examples{ -\dontrun{ +\donttest{ 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) diff --git a/man/piecewise_trends.Rd b/man/piecewise_trends.Rd index bb3bbfd0..4c69f3cb 100644 --- a/man/piecewise_trends.Rd +++ b/man/piecewise_trends.Rd @@ -66,7 +66,7 @@ that you specify the \code{cap} values on the scale of your outcome. Note also t no missing values are allowed in \code{cap}. } \examples{ -\dontrun{ +\donttest{ # Example of logistic growth with possible changepoints # Simple logistic growth model dNt = function(r, N, k){ diff --git a/man/plot.mvgam.Rd b/man/plot.mvgam.Rd index 3177dc3c..4d21c783 100644 --- a/man/plot.mvgam.Rd +++ b/man/plot.mvgam.Rd @@ -70,7 +70,7 @@ but the individual plotting functions and the functions from the marginaleffects offer far more more customisation. } \examples{ -\dontrun{ +\donttest{ # Simulate some time series dat <- sim_mvgam(T = 80, n_series = 3) @@ -78,8 +78,6 @@ dat <- sim_mvgam(T = 80, n_series = 3) mod <- mvgam(y ~ s(season, bs = 'cc') + s(series, bs = 're'), data = dat$data_train, trend_model = RW(), - burnin = 300, - samples = 300, chains = 2) # Plot predictions and residuals for each series @@ -95,6 +93,7 @@ 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'), @@ -107,8 +106,6 @@ mod <- mvgam(y ~ -1, trend_formula = ~ s(season, bs = 'cc'), data = dat$data_train, trend_model = RW(), - burnin = 300, - samples = 300, chains = 2) plot(mod, type = 'smooths', trend_effects = TRUE) diff --git a/man/plot_mvgam_factors.Rd b/man/plot_mvgam_factors.Rd index aae8c588..10033529 100644 --- a/man/plot_mvgam_factors.Rd +++ b/man/plot_mvgam_factors.Rd @@ -29,7 +29,7 @@ sum due to the weaker penalty on the factor's precision. If \code{plot == TRUE}, the factors are also plotted. } \examples{ -\dontrun{ +\donttest{ simdat <- sim_mvgam() mod <- mvgam(y ~ s(season, bs = 'cc', k = 6), diff --git a/man/plot_mvgam_series.Rd b/man/plot_mvgam_series.Rd index 2165b62f..9439b959 100644 --- a/man/plot_mvgam_series.Rd +++ b/man/plot_mvgam_series.Rd @@ -65,12 +65,15 @@ and produces plots of observed time series, ACF, CDF and histograms for explorat } \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) +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) +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) +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') } \author{ diff --git a/man/plot_mvgam_trend.Rd b/man/plot_mvgam_trend.Rd index c60c7956..68b0cb80 100644 --- a/man/plot_mvgam_trend.Rd +++ b/man/plot_mvgam_trend.Rd @@ -62,9 +62,8 @@ Plot mvgam latent trend for a specified series simdat <- sim_mvgam(n_series = 3, trend_model = 'AR1') mod <- mvgam(y ~ s(season, bs = 'cc', k = 6), trend_model = AR(), + noncentred = TRUE, data = simdat$data_train, - burnin = 300, - samples = 300, chains = 2) # Plot estimated trends for some series diff --git a/man/posterior_epred.mvgam.Rd b/man/posterior_epred.mvgam.Rd index 01b3d749..cbf354ce 100644 --- a/man/posterior_epred.mvgam.Rd +++ b/man/posterior_epred.mvgam.Rd @@ -68,11 +68,12 @@ of a \code{mvgam} model, while the forecasting functions that respect the temporal dynamics of estimated latent trends. } \examples{ -\dontrun{ +\donttest{ # Simulate some data and fit a model 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) # Compute posterior expectations diff --git a/man/posterior_linpred.mvgam.Rd b/man/posterior_linpred.mvgam.Rd index 745e4e91..348dcdaf 100644 --- a/man/posterior_linpred.mvgam.Rd +++ b/man/posterior_linpred.mvgam.Rd @@ -66,14 +66,13 @@ of a \code{mvgam} model, while the forecasting functions that respect the temporal dynamics of estimated latent trends. } \examples{ -\dontrun{ +\donttest{ # Simulate some data and fit a model simdat <- sim_mvgam(n_series = 1, trend_model = 'AR1') mod <- mvgam(y ~ s(season, bs = 'cc'), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, data = simdat$data_train, - burnin = 300, - samples = 300, chains = 2) # Extract linear predictor values diff --git a/man/ppc.mvgam.Rd b/man/ppc.mvgam.Rd index 4c8cde4b..c29beeb6 100644 --- a/man/ppc.mvgam.Rd +++ b/man/ppc.mvgam.Rd @@ -80,15 +80,13 @@ a broader range of posterior checks that are created using "new data" prediction \code{\link{pp_check.mvgam}} } \examples{ -\dontrun{ +\donttest{ # 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(), - burnin = 300, - samples = 300, chains = 2) # Posterior checks diff --git a/man/predict.mvgam.Rd b/man/predict.mvgam.Rd index 0f5c6c11..1eb8a13f 100644 --- a/man/predict.mvgam.Rd +++ b/man/predict.mvgam.Rd @@ -102,7 +102,7 @@ of a \code{mvgam} model, while the forecasting functions that respect the temporal dynamics of estimated latent trends. } \examples{ -\dontrun{ +\donttest{ # Simulate 4 time series with hierarchical seasonality # and independent AR1 dynamic processes set.seed(111) @@ -115,8 +115,7 @@ mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 6), data = simdat$data_train, family = gaussian(), trend_model = AR(), - burnin = 300, - samples = 300, + noncentred = TRUE, chains = 2) # Generate predictions against observed data diff --git a/man/residuals.mvgam.Rd b/man/residuals.mvgam.Rd index 113162ba..3ffd00ae 100644 --- a/man/residuals.mvgam.Rd +++ b/man/residuals.mvgam.Rd @@ -49,14 +49,13 @@ observations that were missing (i.e. \code{NA}) in the original data will have m in the residuals } \examples{ -\dontrun{ +\donttest{ # Simulate some data and fit a model simdat <- sim_mvgam(n_series = 1, trend_model = 'AR1') mod <- mvgam(y ~ s(season, bs = 'cc'), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, data = simdat$data_train, - burnin = 300, - samples = 300, chains = 2) # Extract posterior residuals diff --git a/man/score.mvgam_forecast.Rd b/man/score.mvgam_forecast.Rd index 94475e76..67e96d10 100644 --- a/man/score.mvgam_forecast.Rd +++ b/man/score.mvgam_forecast.Rd @@ -58,7 +58,7 @@ will only contain the linear predictors Compute probabilistic forecast scores for mvgam objects } \examples{ -\dontrun{ +\donttest{ # Simulate observations for three count-valued time series data <- sim_mvgam() # Fit a dynamic model using 'newdata' to automatically produce forecasts @@ -66,8 +66,6 @@ mod <- mvgam(y ~ 1, trend_model = RW(), data = data$data_train, newdata = data$data_test, - burnin = 300, - samples = 300, chains = 2) # Extract forecasts into a 'mvgam_forecast' object diff --git a/man/ti.Rd b/man/ti.Rd new file mode 100644 index 00000000..6631b3e0 --- /dev/null +++ b/man/ti.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ti.R +\name{ti} +\alias{ti} +\alias{te} +\title{Defining smooths in \pkg{mvgam} formulae} +\usage{ +ti(...) + +te(...) +} +\arguments{ +\item{...}{Arguments passed to \code{\link[mgcv:ti]{mgcv::ti}} or +\code{\link[mgcv:ti]{mgcv::te}}} +} +\description{ +Functions used in definition of smooth terms within model formulae. +The functions do not evaluate a (spline) smooth - they exist purely +to help set up mvgam models using spline based smooths. +} +\details{ +The functions defined here are just simple wrappers of the respective +functions of the \pkg{mgcv} package. When using them, please cite the +appropriate references obtained via \code{citation("mgcv")}. +} +\examples{ +\donttest{ +# Simulate some data +dat <- mgcv::gamSim(1, n = 200, scale = 2) + +# Fit univariate smooths for all predictors +fit1 <- mvgam(y ~ s(x0) + s(x1) + s(x2) + s(x3), + data = dat, chains = 2, family = gaussian()) +summary(fit1) +conditional_effects(fit1) + +# Fit a more complicated smooth model +fit2 <- mvgam(y ~ te(x0, x1) + s(x2, by = x3), + data = dat, chains = 2, family = gaussian()) +summary(fit2) +conditional_effects(fit2) +} + +} +\seealso{ +\code{\link[mgcv:ti]{mgcv::ti}}, \code{\link[mgcv:ti]{mgcv::te}} +} diff --git a/man/update.mvgam.Rd b/man/update.mvgam.Rd index 63b07934..dce855a9 100644 --- a/man/update.mvgam.Rd +++ b/man/update.mvgam.Rd @@ -182,20 +182,20 @@ Use \code{methods(class = "mvgam")} for an overview on available methods. This function allows a previously fitted \code{mvgam} model to be updated } \examples{ -\dontrun{ +\donttest{ # Simulate some data and fit a Poisson AR1 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, - burnin = 300, - samples = 300, chains = 2) summary(mod) conditional_effects(mod, type = 'link') # Update to an AR2 model -updated_mod <- update(mod, trend_model = AR(p = 2)) +updated_mod <- update(mod, trend_model = AR(p = 2), + noncentred = TRUE) summary(updated_mod) conditional_effects(updated_mod, type = 'link') @@ -204,6 +204,7 @@ conditional_effects(updated_mod, type = 'link') simdat$data_train$trials <- max(simdat$data_train$y) + 15 updated_mod <- update(mod, formula = cbind(y, trials) ~ s(season, bs = 'cc'), + noncentred = TRUE, data = simdat$data_train, family = binomial()) summary(updated_mod) diff --git a/src/RcppExports.o b/src/RcppExports.o index 03b01119..e8dd19f0 100644 Binary files a/src/RcppExports.o and b/src/RcppExports.o differ diff --git a/src/mvgam.dll b/src/mvgam.dll index ea6c83ce..0e057d84 100644 Binary files a/src/mvgam.dll and b/src/mvgam.dll differ diff --git a/src/trend_funs.o b/src/trend_funs.o index 1c0d5a8f..917270cf 100644 Binary files a/src/trend_funs.o and b/src/trend_funs.o differ diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf index d7f88ec0..a0e2e14b 100644 Binary files a/tests/testthat/Rplots.pdf and b/tests/testthat/Rplots.pdf differ diff --git a/tests/testthat/test-example_processing.R b/tests/testthat/test-example_processing.R index 0f8013dd..27ae689d 100644 --- a/tests/testthat/test-example_processing.R +++ b/tests/testthat/test-example_processing.R @@ -46,25 +46,25 @@ test_that("variable extraction works correctly", { 'rho_gp', regex = TRUE), 'matrix')) expect_true(inherits(as_draws(mvgam:::mvgam_example5, - 'rho_gp', regex = TRUE), + 'rho_gp', regex = TRUE), 'draws')) expect_true(inherits(as_draws(mvgam:::mvgam_example1, 'obs_params', regex = TRUE), 'draws')) expect_true(inherits(as_draws_df(mvgam:::mvgam_example1, - 'obs_params', regex = TRUE), + 'obs_params', regex = TRUE), 'draws')) expect_true(inherits(as_draws_matrix(mvgam:::mvgam_example4, - 'obs_params'), + 'obs_params'), 'draws')) expect_true(inherits(as_draws_matrix(mvgam:::mvgam_example4, 'trend_params'), 'draws')) expect_true(inherits(as_draws_list(mvgam:::mvgam_example4, - 'betas'), + 'betas'), 'draws')) expect_true(inherits(as_draws_rvars(mvgam:::mvgam_example4, - 'trend_betas'), + 'trend_betas'), 'draws')) }) @@ -112,9 +112,9 @@ test_that("predict() works correctly", { process_error = TRUE))) expect_equal(dim(posterior_linpred(mvgam:::mvgam_example1, type = 'expected', - process_error = FALSE)), + process_error = FALSE)), dim(posterior_linpred(mvgam:::mvgam_example2, type = 'expected', - process_error = FALSE))) + process_error = FALSE))) expect_equal(dim(posterior_linpred(mvgam:::mvgam_example1, type = 'expected', process_error = FALSE, @@ -129,8 +129,8 @@ test_that("predict() works correctly", { process_error = FALSE))) expect_equal(NROW(predict(mvgam:::mvgam_example1, - newdata = mvgam:::mvgam_examp_dat$data_test, - process_error = FALSE)), + newdata = mvgam:::mvgam_examp_dat$data_test, + process_error = FALSE)), NROW(mvgam:::mvgam_examp_dat$data_test)) expect_equal(NROW(predict(mvgam:::mvgam_example5, newdata = mvgam:::mvgam_examp_dat$data_test, @@ -173,42 +173,42 @@ test_that("mcmc_plot() works correctly", { }) test_that("marginaleffects works correctly", { - expect_ggplot(plot_slopes(mvgam:::mvgam_example1, - variables = 'season', - condition = 'season', - type = 'link')) - expect_ggplot(plot_slopes(mvgam:::mvgam_example2, - variables = 'season', - condition = 'season', - type = 'link')) - expect_ggplot(plot_slopes(mvgam:::mvgam_example3, - variables = 'season', - condition = 'season', - type = 'link')) - expect_ggplot(plot_slopes(mvgam:::mvgam_example4, - variables = 'season', - condition = 'season', - type = 'link')) - expect_ggplot(plot_slopes(mvgam:::mvgam_example5, - variables = 'season', - condition = 'season', - type = 'link')) - - expect_ggplot(plot_predictions(mvgam:::mvgam_example1, - condition = 'season', - type = 'link')) - expect_ggplot(plot_predictions(mvgam:::mvgam_example2, - condition = 'season', - type = 'link')) - expect_ggplot(plot_predictions(mvgam:::mvgam_example3, - condition = 'season', - type = 'link')) - expect_ggplot(plot_predictions(mvgam:::mvgam_example4, - condition = 'season', - type = 'link')) - expect_ggplot(plot_predictions(mvgam:::mvgam_example5, - condition = 'season', - type = 'link')) + expect_ggplot(marginaleffects::plot_slopes(mvgam:::mvgam_example1, + variables = 'season', + condition = 'season', + type = 'link')) + expect_ggplot(marginaleffects::plot_slopes(mvgam:::mvgam_example2, + variables = 'season', + condition = 'season', + type = 'link')) + expect_ggplot(marginaleffects::plot_slopes(mvgam:::mvgam_example3, + variables = 'season', + condition = 'season', + type = 'link')) + expect_ggplot(marginaleffects::plot_slopes(mvgam:::mvgam_example4, + variables = 'season', + condition = 'season', + type = 'link')) + expect_ggplot(marginaleffects::plot_slopes(mvgam:::mvgam_example5, + variables = 'season', + condition = 'season', + type = 'link')) + + expect_ggplot(marginaleffects::plot_predictions(mvgam:::mvgam_example1, + condition = 'season', + type = 'link')) + expect_ggplot(marginaleffects::plot_predictions(mvgam:::mvgam_example2, + condition = 'season', + type = 'link')) + expect_ggplot(marginaleffects::plot_predictions(mvgam:::mvgam_example3, + condition = 'season', + type = 'link')) + expect_ggplot(marginaleffects::plot_predictions(mvgam:::mvgam_example4, + condition = 'season', + type = 'link')) + expect_ggplot(marginaleffects::plot_predictions(mvgam:::mvgam_example5, + condition = 'season', + type = 'link')) }) test_that("plot_mvgam... functions work properly", { @@ -217,7 +217,7 @@ test_that("plot_mvgam... functions work properly", { expect_no_error(plot(mvgam:::mvgam_example4, type = 'forecast')) expect_no_error(SW(plot(mvgam:::mvgam_example3, type = 'smooths'))) expect_no_error(SW(plot(mvgam:::mvgam_example3, type = 'smooths', - realisations = TRUE))) + realisations = TRUE))) expect_no_error(plot_mvgam_smooth(mvgam:::mvgam_example1, smooth = 1, derivatives = TRUE)) @@ -228,10 +228,10 @@ test_that("plot_mvgam... functions work properly", { smooth = 1, realisations = TRUE)) expect_error(plot_mvgam_smooth(mvgam:::mvgam_example4, - smooth = 1)) + smooth = 1)) expect_no_error(plot_mvgam_smooth(mvgam:::mvgam_example4, - smooth = 1, - trend_effects = TRUE)) + smooth = 1, + trend_effects = TRUE)) expect_no_error(plot_mvgam_smooth(mvgam:::mvgam_example4, smooth = 1, derivatives = TRUE, @@ -338,14 +338,14 @@ test_that("evaluate() functions working", { test_that("lfo_cv() working", { lfs <- SW(lfo_cv(mvgam:::mvgam_example1, - min_t = 27, - fc_horizon = 1)) + min_t = 27, + fc_horizon = 1)) expect_true(inherits(lfs, 'mvgam_lfo')) expect_no_error(plot(lfs)) lfs <- SW(lfo_cv(mvgam:::mvgam_example5, - min_t = 27, - fc_horizon = 1)) + min_t = 27, + fc_horizon = 1)) expect_true(inherits(lfs, 'mvgam_lfo')) expect_no_error(plot(lfs)) }) diff --git a/tests/testthat/test-marginaleffects.R b/tests/testthat/test-marginaleffects.R index bd67ccd2..e38e288a 100644 --- a/tests/testthat/test-marginaleffects.R +++ b/tests/testthat/test-marginaleffects.R @@ -9,8 +9,8 @@ test_that("data_grid gives expected output structure", { mu = 1.5) out <- SW(data_grid(season = unique, - year = mean, - newdata = simdat$data_test)) + year = mean, + newdata = simdat$data_test)) expect_true(all(out$year == mean(simdat$data_test$year))) myfunc = function(x){ @@ -30,7 +30,7 @@ test_that("data_grid gives expected output structure", { }) test_that("get_data gives expected output structure", { - plot_data <- get_data(mvgam:::mvgam_example2) + plot_data <- insight::get_data(mvgam:::mvgam_example2) obs_data <- mvgam:::mvgam_example2$obs_data # get_data should give the exact same data used for modelling, including @@ -44,31 +44,31 @@ test_that("get_data gives expected output structure", { }) test_that("get_predict gives expected output structure", { - preds <- get_predict(mvgam:::mvgam_example4) + preds <- marginaleffects::get_predict(mvgam:::mvgam_example4) expect_equal(NROW(preds), NROW(mvgam:::mvgam_example4$obs_data)) - preds <- get_predict(mvgam:::mvgam_example2) + preds <- marginaleffects::get_predict(mvgam:::mvgam_example2) expect_equal(NROW(preds), NROW(mvgam:::mvgam_example2$obs_data)) }) test_that("averages give expected output structures", { - ems <- avg_predictions(mvgam:::mvgam_example3) + ems <- marginaleffects::avg_predictions(mvgam:::mvgam_example3) expect_equal(NROW(ems), 1) expect_true(all(c("estimate", "conf.low", "conf.high") %in% colnames(ems))) - ems <- avg_predictions(mvgam:::mvgam_example4, - variables = list(season = c(1, 6, 12))) + ems <- marginaleffects::avg_predictions(mvgam:::mvgam_example4, + variables = list(season = c(1, 6, 12))) expect_equal(NROW(ems), 3) expect_true(all(c("season", "estimate", "conf.low", "conf.high") %in% colnames(ems))) - ems <- avg_predictions(mvgam:::mvgam_example5, - variables = list(season = c(1, 6, 12))) + ems <- marginaleffects::avg_predictions(mvgam:::mvgam_example5, + variables = list(season = c(1, 6, 12))) expect_equal(NROW(ems), 3) expect_true(all(c("season", "estimate", "conf.low", "conf.high") %in% colnames(ems))) - ems <- predictions(mvgam:::mvgam_example2, by = 'series') + ems <- marginaleffects::predictions(mvgam:::mvgam_example2, by = 'series') expect_equal(NROW(ems), nlevels(mvgam:::mvgam_example3$obs_data$series)) }) diff --git a/vignettes/forecast_evaluation.Rmd b/vignettes/forecast_evaluation.Rmd index 8b6a9ec5..8979593d 100644 --- a/vignettes/forecast_evaluation.Rmd +++ b/vignettes/forecast_evaluation.Rmd @@ -36,12 +36,12 @@ theme_set(theme_bw(base_size = 12, base_family = 'serif')) The purpose of this vignette is to show how the `mvgam` package can be used to produce probabilistic forecasts and to evaluate those forecasts using a variety of proper scoring rules. ## Simulating discrete time series -We begin by simulating some data to show how forecasts are computed and evaluated in `mvgam`. The `sim_mvgam()` function can be used to simulate series that come from a variety of response distributions as well as seasonal patterns and/or dynamic temporal patterns. Here we simulate a collection of three time count-valued series. These series all share the same seasonal pattern but have different temporal dynamics. By setting `trend_model = 'GP'` and `prop_trend = 0.75`, we are generating time series that have smooth underlying temporal trends (evolving as Gaussian Processes with squared exponential kernel) and moderate seasonal patterns. The observations are Poisson-distributed and we allow 10% of observations to be missing. +We begin by simulating some data to show how forecasts are computed and evaluated in `mvgam`. The `sim_mvgam()` function can be used to simulate series that come from a variety of response distributions as well as seasonal patterns and/or dynamic temporal patterns. Here we simulate a collection of three time count-valued series. These series all share the same seasonal pattern but have different temporal dynamics. By setting `trend_model = GP()` and `prop_trend = 0.75`, we are generating time series that have smooth underlying temporal trends (evolving as Gaussian Processes with squared exponential kernel) and moderate seasonal patterns. The observations are Poisson-distributed and we allow 10% of observations to be missing. ```{r} set.seed(2345) simdat <- sim_mvgam(T = 100, n_series = 3, - trend_model = 'GP', + trend_model = GP(), prop_trend = 0.75, family = poisson(), prop_missing = 0.10) @@ -80,7 +80,8 @@ mod1 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + s(time, by = series, bs = 'cr', k = 20), knots = list(season = c(0.5, 12.5)), trend_model = 'None', - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The model fits without issue: @@ -88,9 +89,9 @@ The model fits without issue: summary(mod1, include_betas = FALSE) ``` -And we can plot the partial effects of the splines to see that they are estimated to be highly nonlinear +And we can plot the conditional effects of the splines (on the link scale) to see that they are estimated to be highly nonlinear ```{r, fig.alt = "Plotting GAM smooth functions using mvgam"} -plot(mod1, type = 'smooths') +conditional_effects(mod1, type = 'link') ``` ### Modelling dynamics with GPs @@ -102,7 +103,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) ``` ```{r eval=FALSE} @@ -111,7 +113,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + scale = FALSE), knots = list(season = c(0.5, 12.5)), trend_model = 'None', - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The summary for this model now contains information on the GP parameters for each time series: @@ -129,13 +132,9 @@ And now the length scale ($\rho$) parameters: mcmc_plot(mod2, variable = c('rho_gp'), regex = TRUE, type = 'areas') ``` -We can also plot the nonlinear effects using `marginaleffects` utilities: -```{r, fig.alt = "Summarising latent Gaussian Process parameters in mvgam and marginaleffects"} -require('ggplot2') -plot_predictions(mod2, - condition = c('time', 'series', 'series'), - type = 'link') + - theme(legend.position = 'none') +We can again plot the nonlinear effects: +```{r, fig.alt = "Plotting latent Gaussian Process effects in mvgam and marginaleffects"} +conditional_effects(mod2, type = 'link') ``` The estimates for the temporal trends are fairly similar for the two models, but below we will see if they produce similar forecasts @@ -173,7 +172,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + trend_model = 'None', data = simdat$data_train, newdata = simdat$data_test, - adapt_delta = 0.98) + adapt_delta = 0.98, + silent = 2) ``` ```{r eval=FALSE} @@ -183,7 +183,8 @@ mod2 <- mvgam(y ~ s(season, bs = 'cc', k = 8) + knots = list(season = c(0.5, 12.5)), trend_model = 'None', data = simdat$data_train, - newdata = simdat$data_test) + newdata = simdat$data_test, + silent = 2) ``` Because the model already contains a forecast distribution, we do not need to feed `newdata` to the `forecast()` function: diff --git a/vignettes/shared_states.Rmd b/vignettes/shared_states.Rmd index fb1b7282..bc79aa71 100644 --- a/vignettes/shared_states.Rmd +++ b/vignettes/shared_states.Rmd @@ -39,7 +39,7 @@ This vignette gives an example of how `mvgam` can be used to estimate models whe The `trend_map` argument in the `mvgam()` function is an optional `data.frame` that can be used to specify which series should depend on which latent process models (called "trends" in `mvgam`). This can be particularly useful if we wish to force multiple observed time series to depend on the same latent trend process, but with different observation processes. If this argument is supplied, a latent factor model is set up by setting `use_lv = TRUE` and using the supplied `trend_map` to set up the shared trends. Users familiar with the `MARSS` family of packages will recognize this as a way of specifying the $Z$ matrix. This `data.frame` needs to have column names `series` and `trend`, with integer values in the `trend` column to state which trend each series should depend on. The `series` column should have a single unique entry for each time series in the data, with names that perfectly match the factor levels of the `series` variable in `data`). For example, if we were to simulate a collection of three integer-valued time series (using `sim_mvgam`), the following `trend_map` would force the first two series to share the same latent trend process: ```{r} set.seed(122) -simdat <- sim_mvgam(trend_model = 'AR1', +simdat <- sim_mvgam(trend_model = AR(), prop_trend = 0.6, mu = c(0, 1, 2), family = poisson()) @@ -66,8 +66,10 @@ fake_mod <- mvgam(y ~ trend_formula = ~ s(season, bs = 'cc', k = 6), # AR1 dynamics (each latent process model has DIFFERENT) - # dynamics - trend_model = 'AR1', + # dynamics; processes are estimated using the noncentred + # parameterisation for improved efficiency + trend_model = AR(), + noncentred = TRUE, # supplied trend_map trend_map = trend_map, @@ -93,19 +95,23 @@ Though this model doesn't perfectly match the data-generating process (which all ```{r full_mod, include = FALSE, results='hide'} full_mod <- mvgam(y ~ series - 1, trend_formula = ~ s(season, bs = 'cc', k = 6), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, trend_map = trend_map, family = poisson(), - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` ```{r eval=FALSE} full_mod <- mvgam(y ~ series - 1, trend_formula = ~ s(season, bs = 'cc', k = 6), - trend_model = 'AR1', + trend_model = AR(), + noncentred = TRUE, trend_map = trend_map, family = poisson(), - data = simdat$data_train) + data = simdat$data_train, + silent = 2) ``` The summary of this model is informative as it shows that only two latent process models have been estimated, even though we have three observed time series. The model converges well @@ -125,9 +131,9 @@ However, forecasts for series' 1 and 2 will differ because they have different i ## Example: signal detection Now we will explore a more complicated example. Here we simulate a true hidden signal that we are trying to track. This signal depends nonlinearly on some covariate (called `productivity`, which represents a measure of how productive the landscape is). The signal also demonstrates a fairly large amount of temporal autocorrelation: ```{r} -set.seed(543210) +set.seed(0) # simulate a nonlinear relationship using the mgcv function gamSim -signal_dat <- gamSim(n = 100, eg = 1, scale = 1) +signal_dat <- mgcv::gamSim(n = 100, eg = 1, scale = 1) # productivity is one of the variables in the simulated data productivity <- signal_dat$x2 @@ -149,9 +155,8 @@ plot(true_signal, type = 'l', Next we simulate three sensors that are trying to track the same hidden signal. All of these sensors have different observation errors that can depend nonlinearly on a second external covariate, called `temperature` in this example. Again this makes use of `gamSim` ```{r} -set.seed(543210) sim_series = function(n_series = 3, true_signal){ - temp_effects <- gamSim(n = 100, eg = 7, scale = 0.1) + temp_effects <- mgcv::gamSim(n = 100, eg = 7, scale = 0.1) temperature <- temp_effects$y alphas <- rnorm(n_series, sd = 2) @@ -215,7 +220,8 @@ mod <- mvgam(formula = trend_model = # in addition to productivity effects, the signal is # assumed to exhibit temporal autocorrelation - 'AR1', + AR(), + noncentred = TRUE, trend_map = # trend_map forces all sensors to track the same @@ -232,7 +238,8 @@ mod <- mvgam(formula = family = gaussian(), burnin = 600, adapt_delta = 0.95, - data = model_dat) + data = model_dat, + silent = 2) ``` ```{r eval=FALSE} @@ -251,7 +258,8 @@ mod <- mvgam(formula = trend_model = # in addition to productivity effects, the signal is # assumed to exhibit temporal autocorrelation - 'AR1', + AR(), + noncentred = TRUE, trend_map = # trend_map forces all sensors to track the same @@ -266,7 +274,8 @@ mod <- mvgam(formula = # Gaussian observations family = gaussian(), - data = model_dat) + data = model_dat, + silent = 2) ``` View a reduced version of the model summary because there will be many spline coefficients in this model @@ -282,6 +291,7 @@ conditional_effects(mod, type = 'link') `conditional_effects` is simply a wrapper to the more flexible `plot_predictions` function from the `marginaleffects` package. We can get more useful plots of these effects using this function for further customisation: ```{r} +require(marginaleffects) plot_predictions(mod, condition = c('temperature', 'series', 'series'), points = 0.5) + diff --git a/vignettes/time_varying_effects.Rmd b/vignettes/time_varying_effects.Rmd index cf9573fd..ec19a933 100644 --- a/vignettes/time_varying_effects.Rmd +++ b/vignettes/time_varying_effects.Rmd @@ -85,13 +85,15 @@ Time-varying coefficients can be fairly easily set up using the `s()` or `gp()` ```{r, include=FALSE} mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` ```{r, eval=FALSE} mod <- mvgam(out ~ dynamic(temp, rho = 8, stationary = TRUE, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` Inspect the model summary, which shows how the `dynamic()` wrapper was used to construct a low-rank Gaussian Process smooth function: @@ -109,6 +111,7 @@ lines(beta_temp, lwd = 2) We can also use `plot_predictions` from the `marginaleffects` package to visualise the time-varying coefficient for what the effect would be estimated to be at different values of $temperature$: ```{r} +require(marginaleffects) range_round = function(x){ round(range(x, na.rm = TRUE), 2) } @@ -129,13 +132,15 @@ The syntax is very similar if we wish to estimate the parameters of the underlyi ```{r include=FALSE} mod <- mvgam(out ~ dynamic(temp, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` ```{r eval=FALSE} mod <- mvgam(out ~ dynamic(temp, k = 40), family = gaussian(), - data = data_train) + data = data_train, + silent = 2) ``` This model summary now contains estimates for the marginal deviation and length scale parameters of the underlying Gaussian Process function: @@ -186,19 +191,23 @@ plot_mvgam_series(data = model_data, y = 'survival') ### A State-Space Beta regression -`mvgam` can easily handle data that are bounded at 0 and 1 with a Beta observation model (using the `mgcv` function `betar()`, see `?mgcv::betar` for details). First we will fit a simple State-Space model that uses a Random Walk dynamic process model with no predictors and a Beta observation model: +`mvgam` can easily handle data that are bounded at 0 and 1 with a Beta observation model (using the `mgcv` function `betar()`, see `?mgcv::betar` for details). First we will fit a simple State-Space model that uses an AR1 dynamic process model with no predictors and a Beta observation model: ```{r include = FALSE} mod0 <- mvgam(formula = survival ~ 1, - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) ``` ```{r eval = FALSE} mod0 <- mvgam(formula = survival ~ 1, - trend_model = RW(), - family = betar(), - data = model_data) + trend_model = AR(), + noncentred = TRUE, + family = betar(), + data = model_data, + silent = 2) ``` The summary of this model shows good behaviour of the Hamiltonian Monte Carlo sampler and provides useful summaries on the Beta observation model parameters: @@ -216,18 +225,22 @@ Now we can increase the complexity of our model by constructing and fitting a St ```{r include=FALSE} mod1 <- mvgam(formula = survival ~ 1, trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), data = model_data, - adapt_delta = 0.99) + adapt_delta = 0.99, + silent = 2) ``` ```{r eval=FALSE} mod1 <- mvgam(formula = survival ~ 1, trend_formula = ~ dynamic(CUI.apr, k = 25, scale = FALSE), - trend_model = 'RW', + trend_model = AR(), + noncentred = TRUE, family = betar(), - data = model_data) + data = model_data, + silent = 2) ``` The summary for this model now includes estimates for the time-varying GP parameters: @@ -254,15 +267,15 @@ mod1_sigma <- as.data.frame(mod1, variable = 'sigma', regex = TRUE) %>% sigmas <- rbind(mod0_sigma, mod1_sigma) # Plot using ggplot2 -library(ggplot2) +require(ggplot2) ggplot(sigmas, aes(y = `sigma[1]`, fill = model)) + geom_density(alpha = 0.3, colour = NA) + coord_flip() ``` -Why does the process error not need to be as flexible in the second model? Because the estimates of this dynamic process are now informed partly by the time-varying effect of upwelling, which we can visualise on the link scale using `plot()` with `trend_effects = TRUE`: +Why does the process error not need to be as flexible in the second model? Because the estimates of this dynamic process are now informed partly by the time-varying effect of upwelling, which we can visualise on the link scale using `plot()`: ```{r} -plot(mod1, type = 'smooth', trend_effects = TRUE) +plot(mod1, type = 'smooths', trend_effects = TRUE) ``` ### Comparing model predictive performances diff --git a/vignettes/trend_formulas.Rmd b/vignettes/trend_formulas.Rmd index 46dbe8a5..387a8708 100644 --- a/vignettes/trend_formulas.Rmd +++ b/vignettes/trend_formulas.Rmd @@ -231,7 +231,7 @@ priors <- get_mvgam_priors( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train) ``` @@ -265,8 +265,9 @@ var_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1', + trend_model = VAR(), priors = priors, + adapt_delta = 0.99, burnin = 1000) ``` @@ -280,13 +281,14 @@ var_mod <- mvgam( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with uncorrelated process errors - trend_model = 'VAR1', + trend_model = VAR(), family = gaussian(), data = plankton_train, newdata = plankton_test, # include the updated priors - priors = priors) + priors = priors, + silent = 2) ``` ### Inspecting SS models @@ -313,7 +315,7 @@ mcmc_plot(var_mod, type = 'hist') ``` -There is a lot happening in this matrix. Each cell captures the lagged effect of the process in the column on the process in the row in the next timestep. So for example, the effect in cell [1,3], which is quite strongly negative, means that an *increase* in the process for series 3 (Greens) at time $t$ is expected to lead to a subsequent *decrease* in the process for series 1 (Bluegreens) at time $t+1$. The latent process model is now capturing these effects and the smooth seasonal effects. +There is a lot happening in this matrix. Each cell captures the lagged effect of the process in the column on the process in the row in the next timestep. So for example, the effect in cell [1,3] shows how an *increase* in the process for series 3 (Greens) at time $t$ is expected to impact the process for series 1 (Bluegreens) at time $t+1$. The latent process model is now capturing these effects and the smooth seasonal effects. The process error $(\Sigma)$ captures unmodelled variation in the process models. Again, we fixed the off-diagonals to 0, so the histograms for these will look like flat boxes: ```{r warning=FALSE, message=FALSE} @@ -356,8 +358,9 @@ varcor_mod <- mvgam(y ~ -1, family = gaussian(), data = plankton_train, newdata = plankton_test, - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), burnin = 1000, + adapt_delta = 0.99, priors = priors) ``` @@ -371,13 +374,14 @@ varcor_mod <- mvgam( te(temp, month, k = c(4, 4), by = trend), # VAR1 model with correlated process errors - trend_model = 'VAR1cor', + trend_model = VAR(cor = TRUE), family = gaussian(), data = plankton_train, newdata = plankton_test, # include the updated priors - priors = priors) + priors = priors, + silent = 2) ``` The $(\Sigma)$ matrix now captures any evidence of contemporaneously correlated process error: @@ -393,7 +397,7 @@ mcmc_plot(varcor_mod, type = 'hist') ``` -This symmetric matrix tells us there is support for correlated process errors. For example, series 1 and 3 (Bluegreens and Greens) show negatively correlated process errors, while series 1 and 4 (Bluegreens and Other.algae) show positively correlated errors. But it is easier to interpret these estimates if we convert the covariance matrix to a correlation matrix. Here we compute the posterior median process error correlations: +This symmetric matrix tells us there is support for correlated process errors, as several of the off-diagonal entries are strongly non-zero. But it is easier to interpret these estimates if we convert the covariance matrix to a correlation matrix. Here we compute the posterior median process error correlations: ```{r} Sigma_post <- as.matrix(varcor_mod, variable = 'Sigma', regex = TRUE) median_correlations <- cov2cor(matrix(apply(Sigma_post, 2, median),