diff --git a/DESCRIPTION b/DESCRIPTION index 7e0fe86..6882935 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: mfbvar Type: Package Title: Mixed-Frequency Bayesian VAR Models -Version: 0.5.0.9000 +Version: 0.5.1.9000 Date: 2019-05-09 Authors@R: c( person("Sebastian", "Ankargren", email = "sebastian.ankargren@statistics.uu.se", role = c("cre", "aut"), comment = c(ORCID = "0000-0003-4415-8734")), @@ -12,10 +12,24 @@ LazyData: TRUE URL: https://github.com/ankargren/mfbvar BugReports: https://github.com/ankargren/mfbvar/issues Imports: - Rcpp (>= 0.12.7), ggplot2 (>= 2.2.1), methods, pbapply, utils, factorstochvol, progress, lubridate, GIGrvg + Rcpp (>= 0.12.7), + ggplot2 (>= 2.2.1), + methods, + pbapply, + utils, + progress, + lubridate, + GIGrvg, + stochvol (>= 2.0.3), + RcppParallel LinkingTo: - Rcpp, RcppArmadillo, RcppProgress + Rcpp, + RcppArmadillo, + RcppProgress, + stochvol (>= 2.0.3), + RcppParallel Depends: R (>= 2.10) Suggests: testthat, covr, tidyverse RoxygenNote: 6.1.1 Encoding: UTF-8 +SystemRequirements: GNU make diff --git a/NAMESPACE b/NAMESPACE index 9a601f5..2edbfa3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,26 +9,25 @@ importFrom(tibble,"tibble") importFrom(dplyr, "group_by", "summarize", "ungroup", "mutate", "transmute", "bind_rows") importFrom(lubridate, "%m-%", "%m+%", "days", "ymd", "quarter", "month", "year") import(ggplot2) +importFrom(stochvol,svsample) S3method(print, mfbvar_prior) S3method(summary, mfbvar_prior) -S3method(mdd, mfbvar_minn_iw) -S3method(mdd, mfbvar_ss_iw) -S3method(mcmc_sampler, mfbvar_minn_iw) -S3method(mcmc_sampler, mfbvar_ss_iw) S3method(print, mfbvar) S3method(summary, mfbvar) S3method(plot, mfbvar_minn) S3method(plot, mfbvar_ss) S3method(plot, mfbvar_ssng) S3method(plot, mfbvar_prior) +S3method(mcmc_sampler, mfbvar_minn_fsv) +S3method(mcmc_sampler, mfbvar_dl_fsv) S3method(predict, mfbvar) S3method(predict, sfbvar) importFrom("methods", "hasArg") export(set_prior) export(update_prior) export(estimate_mfbvar) -export(interval_to_moments) -export(mdd) export(mcmc_sampler) +export(interval_to_moments) export(varplot) importFrom(GIGrvg,rgig) +importFrom(RcppParallel, RcppParallelLibs) diff --git a/R/RcppExports.R b/R/RcppExports.R index d5d5252..806adcd 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -26,51 +26,8 @@ create_X_t_noint <- function(y) { .Call(`_mfbvar_create_X_t_noint`, y) } -#' @title Kalman filter and smoother -#' -#' @description Kalman filter and smoother (\code{kf_ragged}) and simulation smoother (\code{kf_sim_smooth}) for mixed-frequency data with ragged edges. This function is more computationally efficient than using a companion form representation. -#' @param y_ matrix with the data -#' @param Phi_ matrix with the autoregressive parameters, where the last column is the intercept -#' @param Sigma_ error covariance matrix -#' @param Lambda_ aggregation matrix (for quarterly variables only) -#' @param n_q_ number of quarterly variables -#' @param T_b_ final time period where all monthly variables are observed -#' @keywords internal -#' @return For \code{kf_ragged}, a list with elements: -#' \item{a}{The one-step predictions (for the compact form)} -#' \item{a_tt}{The filtered estimates (for the compact form)} -#' \item{a_tT}{The smoothed estimates (for the compact form)} -#' \item{Z_tT}{The smoothed estimated (for the original form)} -#' @details The returned matrices have the same number of rows as \code{y_}, but the first \code{n_lags} rows are zero. -kf_loglike <- function(y_, Phi_, Sigma_, Lambda_, a00, P00) { - .Call(`_mfbvar_kf_loglike`, y_, Phi_, Sigma_, Lambda_, a00, P00) -} - -#' @title Kalman filter and smoother -#' -#' @description Kalman filter and smoother (\code{kf_ragged}) and simulation smoother (\code{kf_sim_smooth}) for mixed-frequency data with ragged edges. This function is more computationally efficient than using a companion form representation. -#' @param y_ matrix with the data -#' @param Phi_ matrix with the autoregressive parameters, where the last column is the intercept -#' @param Sigma_ error covariance matrix -#' @param Lambda_ aggregation matrix (for quarterly variables only) -#' @param n_q_ number of quarterly variables -#' @param T_b_ final time period where all monthly variables are observed -#' @keywords internal -#' @return For \code{kf_ragged}, a list with elements: -#' \item{a}{The one-step predictions (for the compact form)} -#' \item{a_tt}{The filtered estimates (for the compact form)} -#' \item{a_tT}{The smoothed estimates (for the compact form)} -#' \item{Z_tT}{The smoothed estimated (for the original form)} -#' @details The returned matrices have the same number of rows as \code{y_}, but the first \code{n_lags} rows are zero. -kf_ragged <- function(y_, Phi_, Sigma_, Lambda_, Z1_, n_q_, T_b_) { - .Call(`_mfbvar_kf_ragged`, y_, Phi_, Sigma_, Lambda_, Z1_, n_q_, T_b_) -} - -#' @describeIn kf_ragged Simulation smoother -#' @param Z1 initial values, with \code{n_lags} rows and same number of columns as \code{y_} -#' @return For \code{kf_sim_smooth}, a matrix with the draw from the posterior distribution. -kf_sim_smooth <- function(y_, Phi_, Sigma_, Lambda_, Z1_, n_q_, T_b_) { - .Call(`_mfbvar_kf_sim_smooth`, y_, Phi_, Sigma_, Lambda_, Z1_, n_q_, T_b_) +dl_reg <- function(y, x, beta, aux, global, local, prior_Pi_Omega, n_reps, a, gig) { + invisible(.Call(`_mfbvar_dl_reg`, y, x, beta, aux, global, local, prior_Pi_Omega, n_reps, a, gig)) } #' @title Find maximum eigenvalue @@ -85,40 +42,12 @@ max_eig_cpp <- function(A) { .Call(`_mfbvar_max_eig_cpp`, A) } -mcmc_minn_csv <- function(y_in_p, Pi, Sigma, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose) { - invisible(.Call(`_mfbvar_mcmc_minn_csv`, y_in_p, Pi, Sigma, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose)) -} - -mcmc_ss_csv <- function(y_in_p, Pi, Sigma, psi, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose) { - invisible(.Call(`_mfbvar_mcmc_ss_csv`, y_in_p, Pi, Sigma, psi, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose)) -} - -mcmc_ssng_csv <- function(y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose) { - invisible(.Call(`_mfbvar_mcmc_ssng_csv`, y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose)) -} - -mcmc_minn_diffuse <- function(y_in_p, Pi, Sigma, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose) { - invisible(.Call(`_mfbvar_mcmc_minn_diffuse`, y_in_p, Pi, Sigma, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose)) -} - -mcmc_minn_iw <- function(y_in_p, Pi, Sigma, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose, prior_nu) { - invisible(.Call(`_mfbvar_mcmc_minn_iw`, y_in_p, Pi, Sigma, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose, prior_nu)) -} - -mcmc_ss_diffuse <- function(y_in_p, Pi, Sigma, psi, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose) { - invisible(.Call(`_mfbvar_mcmc_ss_diffuse`, y_in_p, Pi, Sigma, psi, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose)) +mcmc_minn_fsv <- function(y_in_p, Pi, Z, Z_fcst, mu, phi, sigma, f, facload, h, aux, global, local, slice, Lambda_comp, prior_Pi_Omega, prior_Pi_AR1, Z_1, bmu, Bmu, a0idi, b0idi, a0fac, b0fac, Bsigma, B011inv, B022inv, priorh0, armarestr, armatau2, n_fac, n_reps, n_burnin, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose, a, gig) { + invisible(.Call(`_mfbvar_mcmc_minn_fsv`, y_in_p, Pi, Z, Z_fcst, mu, phi, sigma, f, facload, h, aux, global, local, slice, Lambda_comp, prior_Pi_Omega, prior_Pi_AR1, Z_1, bmu, Bmu, a0idi, b0idi, a0fac, b0fac, Bsigma, B011inv, B022inv, priorh0, armarestr, armatau2, n_fac, n_reps, n_burnin, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose, a, gig)) } -mcmc_ss_iw <- function(y_in_p, Pi, Sigma, psi, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose) { - invisible(.Call(`_mfbvar_mcmc_ss_iw`, y_in_p, Pi, Sigma, psi, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose)) -} - -mcmc_ssng_diffuse <- function(y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose) { - invisible(.Call(`_mfbvar_mcmc_ssng_diffuse`, y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose)) -} - -mcmc_ssng_iw <- function(y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose) { - invisible(.Call(`_mfbvar_mcmc_ssng_iw`, y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose)) +mcmc_ss_fsv <- function(y_in_p, Pi, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, mu, phi, sigma, f, facload, h, Lambda_comp, prior_Pi_Omega, prior_Pi_AR1, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, bmu, Bmu, a0idi, b0idi, a0fac, b0fac, Bsigma, B011inv, B022inv, priorh0, armarestr, armatau2, n_fac, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose, ssng) { + invisible(.Call(`_mfbvar_mcmc_ss_fsv`, y_in_p, Pi, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, mu, phi, sigma, f, facload, h, Lambda_comp, prior_Pi_Omega, prior_Pi_AR1, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, bmu, Bmu, a0idi, b0idi, a0fac, b0fac, Bsigma, B011inv, B022inv, priorh0, armarestr, armatau2, n_fac, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose, ssng)) } variances_fsv <- function(variances, latent, facload, variables_num, n_fac, n_reps, n_T, n_vars, n_plotvars) { @@ -173,6 +102,10 @@ do_rgig1 <- function(lambda, chi, psi) { .Call(`_mfbvar_do_rgig1`, lambda, chi, psi) } +rig <- function(mu, lambda) { + .Call(`_mfbvar_rig`, mu, lambda) +} + rmvn <- function(Phi, d, alpha) { .Call(`_mfbvar_rmvn`, Phi, d, alpha) } @@ -199,41 +132,6 @@ rmultn <- function(m, Sigma) { .Call(`_mfbvar_rmultn`, m, Sigma) } -rsimsm_adaptive_cv <- function(y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b) { - .Call(`_mfbvar_rsimsm_adaptive_cv`, y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b) -} - -rsimsm_adaptive_sv <- function(y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b) { - .Call(`_mfbvar_rsimsm_adaptive_sv`, y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b) -} - -rsimsm_adaptive_univariate <- function(y_, Phi, Sigma, Lambda, Z1, n_q_, T_b, f) { - .Call(`_mfbvar_rsimsm_adaptive_univariate`, y_, Phi, Sigma, Lambda, Z1, n_q_, T_b, f) -} - -#' @title Smooth and sample from the smoothed distribution -#' -#' @description Functions for smoothing and sampling from the (smoothed) distribution \eqn{p(Z_{1:T}|Y_{1:T}, \Theta)}. -#' @details Implemented in C++. -#' @aliases smoother simulation_smoother generate_mhh loglike -#' @describeIn smoother Compute smoothed states -#' @templateVar Y TRUE -#' @templateVar Lambda TRUE -#' @templateVar Pi_comp TRUE -#' @templateVar Q_comp TRUE -#' @templateVar n_T TRUE -#' @templateVar n_vars TRUE -#' @templateVar n_comp TRUE -#' @templateVar z0 TRUE -#' @templateVar P0 TRUE -#' @template man_template -#' @keywords internal -#' @return For \code{loglike}: -#' \item{}{An \code{n_T}-long vector of the log-likelihoods. \code{exp(sum(loglike(...)))} is the likelihood.} -loglike <- function(Y, Lambda, Pi_comp, Q_comp, n_T, n_vars, n_comp, z0, P0) { - .Call(`_mfbvar_loglike`, Y, Lambda, Pi_comp, Q_comp, n_T, n_vars, n_comp, z0, P0) -} - update_demean <- function(my, mu_long, y_in_p, mu_mat, d1, Psi_i, Lambda_single, n_vars, n_q, n_Lambda, n_T) { invisible(.Call(`_mfbvar_update_demean`, my, mu_long, y_in_p, mu_mat, d1, Psi_i, Lambda_single, n_vars, n_q, n_Lambda, n_T)) } diff --git a/R/interface.R b/R/interface.R index 30cf115..13cd950 100644 --- a/R/interface.R +++ b/R/interface.R @@ -24,7 +24,8 @@ #' @param prior_phi (Only used with common stochastic volatility) Vector with two elements \code{c(mean, variance)} for the AR(1) parameter in the log-volatility regression #' @param prior_sigma2 (Only used with common stochastic volatility) Vector with two elements \code{c(mean, df)} for the innovation variance of the log-volatility regression #' @param n_fac (Only used with factor stochastic volatility) Number of factors to use for the factor stochastic volatility model -#' @param cl (Only used with factor stochastic volatility) Cluster object to use for drawing regression parameters in parallel +#' @param n_cores (Only used with factor stochastic volatility) Number of cores to use for drawing regression parameters in parallel +#' @param a (Only used with factor stochastic volatility and Dirichlet-Laplace) Shrinkage hyperparameter a (lower values impose more powerful shrinkage) #' @param ... (Only used with factor stochastic volatility) Arguments to pass along to \code{\link[factorstochvol]{fsvsample}}. See details. #' @templateVar verbose TRUE #' @templateVar check_roots TRUE @@ -47,11 +48,7 @@ #' \item{\code{priorsigmaidi}}{\code{ = 1}} #' \item{\code{priorsigmafac}}{\code{ = 1}} #' \item{\code{priorfacload}}{\code{ = 1}} -#' \item{\code{priorng}}{\code{ = c(1, 1)}} -#' \item{\code{columnwise}}{\code{ = FALSE}} #' \item{\code{restrict}}{\code{ = "none"}} -#' \item{\code{heteroskedastic}}{\code{ = TRUE}} -#' \item{\code{priorhomoskedastic}}{\code{ = NA}} #' } #' #' The steady-state prior involves inverting the lag polynomial. For this reason, draws in which the largest eigenvalue @@ -68,7 +65,7 @@ set_prior <- function(Y, freq, aggregation = "average", prior_Pi_AR1 = rep(0, nc n_fcst = 0, n_thin = 1, n_burnin, n_reps, d = NULL, d_fcst = NULL, prior_psi_mean = NULL, prior_psi_Omega = NULL, prior_phi = c(0.9, 0.1), prior_sigma2 = c(0.01, 4), n_fac = NULL, - cl = NULL, verbose = FALSE, check_roots = FALSE, ...) { + n_cores = 1, a = 1/(ncol(Y)^2*n_lags), verbose = FALSE, check_roots = FALSE, ...) { prior_call <- mget(names(formals())[names(formals()) != "..."], sys.frame(sys.nframe())) prior_call$supplied_args <- names(as.list(match.call()))[-1] ellipsis <- list(...) @@ -365,8 +362,8 @@ check_prior <- function(prior_obj) { stop("The number of factors is not a numeric scalar value.") } - if (!inherits(prior_obj$cl, "cluster") && !is.null(prior_obj$cl)) { - stop(sprintf("cl should be a cluster object, but is %s", class(prior_obj$cl))) + if (!is.atomic(prior_obj$n_cores) || length(prior_obj$n_cores) > 1) { + stop("n_cores must be a vector with a single element.") } if ("priormu" %in% prior_obj$supplied_args) { @@ -394,19 +391,29 @@ check_prior <- function(prior_obj) { } if ("priorsigmaidi" %in% prior_obj$supplied_args) { - if (!(is.numeric(prior_obj$priorsigmaidi) && is.atomic(prior_obj$priorsigmaidi) && length(prior_obj$priorsigmaidi) %in% c(1, ncol(prior_obj$Y)))) { - stop(sprintf("priorsigmaidi should be a numeric vector with 1 or n_vars elements, but is %s with %d elements", class(prior_obj$priorsigmaidi), length(prior_obj$priorsigmaidi))) + if (!(is.numeric(prior_obj$priorsigmaidi))) { + stop("priorsigmaidi should be numeric.") + } + if (length(prior_obj$priorsigmaidi) == 1) { + } else if (length(prior_obj$priorsigmaidi) == ncol(prior_obj$Y)) { + } else { + stop("priorsigmaidi should be a numeric vector of length 1 or n_vars.") } } else { - prior_obj$priorsigmaidi <- 1 + prior_obj$priorsigmaidi <- rep(1, ncol(prior_obj$Y)) } if ("priorsigmafac" %in% prior_obj$supplied_args) { - if (!(is.numeric(prior_obj$priorsigmafac) && is.atomic(prior_obj$priorsigmafac) && length(prior_obj$priorsigmafac) %in% c(1, ncol(prior_obj$n_fac)))) { - stop(sprintf("priorsigmafac should be a numeric vector with 1 or n_vars elements, but is %s with %d elements", class(prior_obj$priorsigmafac), length(prior_obj$priorsigmaidi))) + if (!(is.numeric(prior_obj$priorsigmafac))) { + stop("priorsigmafac should be numeric.") + } + if (length(prior_obj$priorsigmafac) == 1) { + } else if (length(prior_obj$priorsigmafac) == prior_obj$n_fac) { + } else { + stop("priorsigmafac should be a numeric vector of length 1 or n_fac") } } else { - prior_obj$priorsigmafac <- 1 + prior_obj$priorsigmafac <- rep(1, prior_obj$n_fac) } if ("priorfacload" %in% prior_obj$supplied_args) { @@ -417,54 +424,32 @@ check_prior <- function(prior_obj) { prior_obj$priorfacload <- 1 } - if ("priorng" %in% prior_obj$supplied_args) { - if (!(is.numeric(prior_obj$priorng) && length(prior_obj$priorng) == 2)) { - stop(sprintf("priorng should be a numeric vector of length 2, but is %s of length %d", class(prior_obj$priorng), length(prior_obj$priorng))) - } - } else { - prior_obj$priorng <- c(1, 1) - } - - if ("columnwise" %in% prior_obj$supplied_args) { - if (!(is.logical(prior_obj$columnwise) && length(prior_obj$priorng) == 1)) { - stop(sprintf("columnwise should be a single logical value, but is %s of length %d", class(prior_obj$columnwise), length(prior_obj$columnwise))) - } - } else { - prior_obj$columnwise <- FALSE - } - if ("restrict" %in% prior_obj$supplied_args) { if (!(is.character(prior_obj$restrict) && length(prior_obj$priorng) == 1)) { stop(sprintf("restrict should be a single string, but is %s of length %d", class(prior_obj$restrict), length(prior_obj$restrict))) + } else { + if (!(prior_obj$restrict %in% c("none", "upper"))) { + stop(sprintf("restrict should be 'none' or 'upper', but is %s", prior_obj$restrict)) + } } } else { prior_obj$restrict <- "none" } - if ("heteroskedastic" %in% prior_obj$supplied_args) { - if (!(is.logical(prior_obj$heteroskedastic) && length(prior_obj$priorng) %in% c(1, 2, ncol(prior_obj$Y)+prior_obj$n_fac))) { - stop(sprintf("heteroskedastic should be a vector of 1, 2, or n_vars + n_fac logical values, but is %s of length %d", class(prior_obj$heteroskedastic), length(prior_obj$heteroskedastic))) - } - } else { - prior_obj$heteroskedastic <- TRUE - } - if (any(!prior_obj$heteroskedastic)) { - if ("priorhomoskedastic" %in% prior_obj$supplied_args) { - if (!(is.numeric(prior_obj$priorhomoskedastic) && is.matrix(prior_obj$priorhomoskedastic) && dim(prior_obj$priorhomoskedastic) == c(ncol(prior_obj$Y)+prior_obj$n_fac, 2))) { - stop(sprintf("priorhomoskedastic should be a matrix of dimensions (n_vars + n_fac) x 2, but is %s of length %d", class(prior_obj$priorhomoskedastic), length(prior_obj$priorhomoskedastic))) - } - } else { - prior_obj$priorhomoskedastic <- c(1.1, 1.1) - } - } else { - prior_obj$priorhomoskedastic <- c(1.1, 1.1) - } + } else if (is.null(prior_obj$n_fac) && any(prior_obj$supplied_args %in% c("priormu", "priorphiidi", "priorphifac", "priorsigmaidi", "priorsigmafac", - "priorfacload", "priorng", "columnwise", "restrict", "heteroskedastic", "priorhomoskedastic"))) { + "priorfacload", "restrict"))) { stop("Please set the number of factors before attempting to pass additional arguments along to fsvsim.") } + if ("a" %in% prior_obj$supplied_args) { + if (!is.atomic(prior_obj$a) || length(prior_obj$a) > 1) { + stop("a must be a vector with a single element.") + } + } else { + prior_obj$supplied_args <- c(prior_obj$supplied_args, "a") + } return(prior_obj) } @@ -574,7 +559,8 @@ summary.mfbvar_prior <- function(object, ...) { cat("----------------------------\n") cat("Factor stochastic volatility-specific elements:\n") cat(" n_fac:", ifelse(is.null(object$n_fac), "", object$n_fac), "\n") - cat(" cl:", ifelse(is.null(object$cl), "", sprintf("%s with %d workers", class(object$cl)[1], length(object$cl))), "\n") + cat(" n_cores:", ifelse(is.null(object$n_cores), "", object$n_cores), "\n") + cat(" a:", ifelse(is.null(object[["a"]]), "", object[["a"]]), "\n") if ("priormu" %in% object$supplied_args) { cat(" priormu:", object$priormu, "\n") } @@ -696,8 +682,8 @@ estimate_mfbvar <- function(mfbvar_prior = NULL, prior, variance = "iw", ...) { prior <- args$prior_type } - if (!(prior %in% c("ss", "ssng", "minn"))) { - stop("prior must be 'ss', 'ssng' or 'minn'.") + if (!(prior %in% c("ss", "ssng", "minn", "dl"))) { + stop("prior must be 'ss', 'ssng', 'minn' or 'dl'.") } if (!(variance %in% c("iw", "fsv", "csv", "diffuse"))) { stop("volatility must be 'iw', 'diffuse', 'csv' or 'fsv'.") @@ -707,28 +693,11 @@ estimate_mfbvar <- function(mfbvar_prior = NULL, prior, variance = "iw", ...) { class(mfbvar_prior) <- c(class(mfbvar_prior), sprintf("mfbvar_%s_%s", prior, variance), sprintf("mfbvar_%s", prior), sprintf("mfbvar_%s", variance)) - if (mfbvar_prior$verbose) { - cat(paste0("##############################################\nRunning the burn-in sampler with ", mfbvar_prior$n_burnin, " draws\n\n")) - start_burnin <- Sys.time() - } - - time_out <- c(time_out, Sys.time()) - burn_in <- mcmc_sampler(update_prior(mfbvar_prior, n_fcst = 0), n_reps = mfbvar_prior$n_burnin, n_thin = mfbvar_prior$n_burnin) - - if (mfbvar_prior$verbose) { - end_burnin <- Sys.time() - time_diff <- end_burnin - start_burnin - cat(paste0("\n Time elapsed for drawing ", mfbvar_prior$n_burnin, " times for burn-in: ", signif(time_diff, digits = 1), " ", - attr(time_diff, "units"), "\n")) - cat(paste0("\nMoving on to the main chain with ", - mfbvar_prior$n_reps, " draws \n\n", ifelse(mfbvar_prior$n_fcst > 0, paste0(" Making forecasts ", mfbvar_prior$n_fcst, " steps ahead"), ""), "\n\n")) - } - time_out <- c(time_out, Sys.time()) - main_run <- mcmc_sampler(mfbvar_prior, n_reps = mfbvar_prior$n_reps, init = burn_in$init) + main_run <- mcmc_sampler(mfbvar_prior) time_out <- c(time_out, Sys.time()) if (mfbvar_prior$verbose) { - time_diff <- Sys.time() - start_burnin + time_diff <- Sys.time() - time_out[1] cat(paste0("\n Total time elapsed: ", signif(time_diff, digits = 1), " ", attr(time_diff, "units"), "\n")) } @@ -748,7 +717,7 @@ estimate_mfbvar <- function(mfbvar_prior = NULL, prior, variance = "iw", ...) { } if (mfbvar_prior$n_fcst > 0) { names_fcst <- paste0("fcst_", 1:mfbvar_prior$n_fcst) - rownames(main_run$Z_fcst)[1:main_run$n_lags] <- names_row[(main_run$n_T-main_run$n_lags+1):main_run$n_T] + rownames(main_run$Z_fcst)[1:main_run$n_lags] <- names_row[(length(names_row)-main_run$n_lags+1):length(names_row)] rownames(main_run$Z_fcst)[(main_run$n_lags+1):(main_run$n_fcst+main_run$n_lags)] <- names_fcst colnames(main_run$Z_fcst) <- names_col } else { @@ -763,12 +732,12 @@ estimate_mfbvar <- function(mfbvar_prior = NULL, prior, variance = "iw", ...) { dimnames(main_run$Z) <- list(time = names_row[(nrow(mfbvar_prior$Y)-nrow(main_run$Z)+1):nrow(mfbvar_prior$Y)], variable = names_col, - iteration = 1:mfbvar_prior$n_reps) + iteration = 1:(mfbvar_prior$n_reps/mfbvar_prior$n_thin)) if (variance %in% c("iw", "diffuse")) { dimnames(main_run$Sigma) <- list(names_col, names_col, - iteration = 1:mfbvar_prior$n_reps) + iteration = 1:(mfbvar_prior$n_reps/mfbvar_prior$n_thin)) } @@ -781,15 +750,15 @@ estimate_mfbvar <- function(mfbvar_prior = NULL, prior, variance = "iw", ...) { rownames(mfbvar_prior$d) <- rownames(mfbvar_prior$Y) main_run$names_determ <- names_determ n_determ <- dim(mfbvar_prior$d)[2] - dimnames(main_run$psi) <- list(iteration = 1:mfbvar_prior$n_reps, + dimnames(main_run$psi) <- list(iteration = 1:(mfbvar_prior$n_reps/mfbvar_prior$n_thin), param = paste0(rep(names_col, n_determ), ".", rep(names_determ, each = n_vars))) dimnames(main_run$Pi) <- list(dep = names_col, indep = paste0(rep(names_col, mfbvar_prior$n_lags), ".l", rep(1:mfbvar_prior$n_lags, each = n_vars)), - iteration = 1:mfbvar_prior$n_reps) + iteration = 1:(mfbvar_prior$n_reps/mfbvar_prior$n_thin)) } else { dimnames(main_run$Pi) <- list(dep = names_col, indep = c("const", paste0(rep(names_col, mfbvar_prior$n_lags), ".l", rep(1:mfbvar_prior$n_lags, each = n_vars))), - iteration = 1:mfbvar_prior$n_reps) + iteration = 1:(mfbvar_prior$n_reps/mfbvar_prior$n_thin)) } if (sum(mfbvar_prior$freq == "m") == 0 || sum(mfbvar_prior$freq == "m") == ncol(mfbvar_prior$Y)) { @@ -1280,12 +1249,12 @@ predict.mfbvar <- function(object, fcst_start = NULL, aggregate_fcst = TRUE, pre n_m <- sum(object$mfbvar_prior$freq == "m") n_q <- sum(object$mfbvar_prior$freq == "q") n_vars <- n_m + n_q - fcst_collapsed <- tibble(variable = rep(rep(object$names_col[1:n_m], each = length(incl_fcst)), object$n_reps), - iter = rep(1:object$n_reps, each = n_m*length(incl_fcst)), + fcst_collapsed <- tibble(variable = rep(rep(object$names_col[1:n_m], each = length(incl_fcst)), object$n_reps/object$n_thin), + iter = rep(1:(object$n_reps/object$n_thin), each = n_m*length(incl_fcst)), fcst = c(object$Z_fcst[incl_fcst,1:n_m,]), - fcst_date = rep(as.Date(as.character(ret_names)), n_m*object$n_reps), - freq = rep(rep(rep("m", n_m), each = length(incl_fcst)), object$n_reps), - time = rep(nrow(object$Y)+object$n_fcst-max(incl_fcst)+incl_fcst, n_m*object$n_reps) + fcst_date = rep(as.Date(as.character(ret_names)), n_m*object$n_reps/object$n_thin), + freq = rep(rep(rep("m", n_m), each = length(incl_fcst)), object$n_reps/object$n_thin), + time = rep(nrow(object$Y)+object$n_fcst-max(incl_fcst)+incl_fcst, n_m*object$n_reps/object$n_thin) ) %>% transmute(variable = variable, iter = iter, @@ -1300,7 +1269,7 @@ predict.mfbvar <- function(object, fcst_start = NULL, aggregate_fcst = TRUE, pre fcst_agg_required <- final_q+3-n_Lambda+1 fcst_included <- nrow(object$Y)-object$n_lags+1 fcst_agg_missing <- max(c(fcst_included - fcst_agg_required, 0)) - fcst_q <- array(0, dim = c(dim(object$Z_fcst)[1]+max(c(fcst_agg_missing, 0)), n_q, object$n_reps)) + fcst_q <- array(0, dim = c(dim(object$Z_fcst)[1]+max(c(fcst_agg_missing, 0)), n_q, object$n_reps/object$n_thin)) if (fcst_agg_required < fcst_included) { ret_names_q <- c(ret_names_q[1] %m+% months((-fcst_agg_missing):(-1)), ret_names_q) @@ -1318,7 +1287,7 @@ predict.mfbvar <- function(object, fcst_start = NULL, aggregate_fcst = TRUE, pre end_of_quarter <- end_of_quarter[end_of_quarter >= n_Lambda] agg_fun <- function(fcst_q, Lambda_, end_of_quarter) { fcst_q_agg <- array(0, dim = c(length(end_of_quarter), dim(fcst_q)[2:3])) - for (i in 1:object$n_reps) { + for (i in 1:(object$n_reps/object$n_thin)) { Z_i <- matrix(fcst_q[,,i], nrow = nrow(fcst_q), ncol = ncol(fcst_q)) for (j in 1:length(end_of_quarter)) { Z_ij <- matrix(t(Z_i[(((-n_Lambda+1):0)+end_of_quarter[j]), , drop = FALSE]), ncol = 1) @@ -1330,12 +1299,12 @@ predict.mfbvar <- function(object, fcst_start = NULL, aggregate_fcst = TRUE, pre fcst_q_agg <- agg_fun(fcst_q, object$Lambda_, end_of_quarter) - fcst_quarterly <- tibble(variable = rep(rep(object$names_col[(n_m+1):n_vars], each = nrow(fcst_q_agg)), object$n_reps), - iter = rep(1:object$n_reps, each = n_q*nrow(fcst_q_agg)), + fcst_quarterly <- tibble(variable = rep(rep(object$names_col[(n_m+1):n_vars], each = nrow(fcst_q_agg)), object$n_reps/object$n_thin), + iter = rep(1:(object$n_reps/object$n_thin), each = n_q*nrow(fcst_q_agg)), fcst = c(fcst_q_agg), - fcst_date = rep(ret_names_q[end_of_quarter], n_q*object$n_reps), - freq = rep(rep(rep("q", n_q), each = nrow(fcst_q_agg)), object$n_reps), - time = rep(seq(final_q+3, by = 3, length.out = nrow(fcst_q_agg)), n_q*object$n_reps) + fcst_date = rep(ret_names_q[end_of_quarter], n_q*object$n_reps/object$n_thin), + freq = rep(rep(rep("q", n_q), each = nrow(fcst_q_agg)), object$n_reps/object$n_thin), + time = rep(seq(final_q+3, by = 3, length.out = nrow(fcst_q_agg)), n_q*object$n_reps/object$n_thin) ) %>% transmute(variable = variable, iter = iter, @@ -1347,12 +1316,12 @@ predict.mfbvar <- function(object, fcst_start = NULL, aggregate_fcst = TRUE, pre time = time) } else { - fcst_quarterly <- tibble(variable = rep(rep(object$names_col[(n_m+1):n_vars], each = length(incl_fcst)), object$n_reps), - iter = rep(1:object$n_reps, each = n_q*length(incl_fcst)), + fcst_quarterly <- tibble(variable = rep(rep(object$names_col[(n_m+1):n_vars], each = length(incl_fcst)), object$n_reps/object$n_thin), + iter = rep(1:(object$n_reps/object$n_thin), each = n_q*length(incl_fcst)), fcst = c(object$Z_fcst[incl_fcst,(n_m+1):n_vars,]), - fcst_date = rep(as.Date(as.character(ret_names)), n_q*object$n_reps), - freq = rep(rep(rep("q", n_q), each = length(incl_fcst)), object$n_reps), - time = rep(nrow(object$Y)+object$n_fcst-max(incl_fcst)+incl_fcst, n_q*object$n_reps) + fcst_date = rep(as.Date(as.character(ret_names)), n_q*object$n_reps/object$n_thin), + freq = rep(rep(rep("q", n_q), each = length(incl_fcst)), object$n_reps/object$n_thin), + time = rep(nrow(object$Y)+object$n_fcst-max(incl_fcst)+incl_fcst, n_q*object$n_reps/object$n_thin) ) %>% transmute(variable = variable, iter = iter, @@ -1424,12 +1393,12 @@ predict.sfbvar <- function(object, fcst_start = NULL, pred_bands = 0.8, ...) { ret_names <- lubridate::ceiling_date(ret_names, unit = "months") - lubridate::days(1) } - fcst_collapsed <- tibble(variable = rep(rep(object$names_col, each = length(incl_fcst)), object$n_reps), - iter = rep(1:object$n_reps, each = object$n_vars*length(incl_fcst)), + fcst_collapsed <- tibble(variable = rep(rep(object$names_col, each = length(incl_fcst)), object$n_reps/object$n_thin), + iter = rep(1:(object$n_reps/object$n_thin), each = object$n_vars*length(incl_fcst)), fcst = c(object$Z_fcst[incl_fcst,,]), - fcst_date = rep(as.Date(as.character(ret_names)), object$n_vars*object$n_reps), - freq = rep(rep(object$mfbvar_prior$freq, each = length(incl_fcst)), object$n_reps), - time = rep(nrow(object$Y)+object$n_fcst-max(incl_fcst)+incl_fcst, object$n_vars*object$n_reps) + fcst_date = rep(as.Date(as.character(ret_names)), object$n_vars*object$n_reps/object$n_thin), + freq = rep(rep(object$mfbvar_prior$freq, each = length(incl_fcst)), object$n_reps/object$n_thin), + time = rep(nrow(object$Y)+object$n_fcst-max(incl_fcst)+incl_fcst, object$n_vars*object$n_reps/object$n_thin) ) %>% transmute(variable = variable, iter = iter, diff --git a/R/mcmc_minn_diffuse.R b/R/mcmc_minn_diffuse.R deleted file mode 100644 index 34f7fee..0000000 --- a/R/mcmc_minn_diffuse.R +++ /dev/null @@ -1,655 +0,0 @@ -#' @rdname mcmc_sampler -mcmc_sampler.mfbvar_minn_diffuse <- function(x, ...){ - - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - - # Diffuse - prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(lambda1 = x$lambda1, lambda2 = x$lambda2, lambda3 = x$lambda3, - prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, block_exo = x$block_exo) - prior_Pi_mean <- matrix(0, n_vars, n_vars*x$n_lags + 1) - prior_Pi_mean[, 2:(n_vars+1)] <- diag(x$prior_Pi_AR1) - - Y <- x$Y - freq <- x$freq - n_fcst <- x$n_fcst - verbose <- x$verbose - n_lags <- x$n_lags - lambda4 <- x$lambda4 - - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(!is.null(add_args$n_thin), add_args$n_thin, ifelse(!is.null(x$n_thin), x$n_thin, 1)) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_Z <- init$init_Z - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - - n_q <- sum(freq == "q") - if (n_q < n_vars) { - T_b <- max(which(!apply(apply(Y[, freq == "m", drop = FALSE], 2, is.na), 1, any))) - } else { - T_b <- nrow(Y) - } - if (n_q > 0) { - Lambda_ <- mfbvar:::build_Lambda(rep("q", n_q), 3) - } else { - Lambda_ <- matrix(0, 1, 3) - } - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - } - - n_pseudolags <- max(c(n_lags, 3)) - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - d <- matrix(1, nrow = nrow(Y), ncol = 1) - - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags + 1, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = 1) - - if (is.null(init_Pi)) { - Pi[,, 1] <- cbind(ols_results$const, ols_results$Pi) - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - Z_1 <- Z[1:n_pseudolags,, 1] - - # For the posterior of Pi - inv_prior_Pi_Omega <- diag(1/c(prior_Pi_Omega)) - Omega_Pi <- matrix(inv_prior_Pi_Omega %*% c(prior_Pi_mean), n_vars*n_lags + 1, n_vars) - - mfbvar:::mcmc_minn_diffuse(Y[-(1:n_lags),],Pi,Sigma,Z,Z_fcst,Lambda_,prior_Pi_Omega, - Omega_Pi,Z_1,n_reps,n_q,T_b-n_lags,n_lags,n_vars,n_T_,n_fcst, - n_thin,verbose) - - - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Sigma = Sigma, psi = NULL, Z = Z, roots = NULL, num_tries = NULL, - Z_fcst = NULL, smoothed_Z = NULL, n_determ = 1, - n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, prior_Pi_mean = prior_Pi_mean, - d = d, Y = Y, n_T = n_T, n_T_ = n_T_, - prior_psi_Omega = NULL, prior_psi_mean = NULL, n_reps = n_reps, Lambda_ = Lambda_, freq = freq, - init = list(init_Pi = Pi[,, n_reps/n_thin], init_Sigma = Sigma[,, n_reps/n_thin], init_Z = Z[,, n_reps/n_thin])) - - if (n_fcst>0) { - return_obj$Z_fcst <- Z_fcst - } - - return(return_obj) - -} - -#' @rdname mcmc_sampler -mcmc_sampler.mfbvar_ss_diffuse <- function(x, ...) { - - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$d) && !is.null(x$prior_psi_mean) && !is.null(x$prior_psi_Omega) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "d", "prior_psi_mean", "prior_psi_Omega", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - if (x$n_fcst > 0 && nrow(x$d_fcst) != x$n_fcst) { - stop("d_fcst has ", nrow(x$d_fcst), " rows, but n_fcst is ", x$n_fcst, ".") - } - - prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(lambda1 = x$lambda1, lambda2 = x$lambda2, lambda3 = x$lambda3, - prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, block_exo = x$block_exo) - prior_Pi_Omega <- prior_Pi_Omega[-1, ] - prior_Pi_mean <- matrix(0, n_vars, n_vars*x$n_lags) - prior_Pi_mean[, 1:n_vars] <- diag(x$prior_Pi_AR1) - - Y <- x$Y - d <- x$d - d_fcst <- x$d_fcst - freq <- x$freq - prior_psi_mean <- x$prior_psi_mean - prior_psi_Omega <- x$prior_psi_Omega - n_fcst <- x$n_fcst - check_roots <- x$check_roots - verbose <- x$verbose - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(is.null(add_args$n_thin),1,add_args$n_thin) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_psi <- init$init_psi - init_Z <- init$init_Z - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - n_vars <- dim(Y)[2] - n_lags <- prod(dim(as.matrix(prior_Pi_mean)))/n_vars^2 - n_q <- sum(freq == "q") - n_m <- sum(freq == "m") - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) - d <- d[complete_quarters, , drop = FALSE] - } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) - } else { - T_b <- nrow(y_in_p) - } - if (n_q > 0) { - Lambda_ <- mfbvar:::build_Lambda(rep("q", n_q), 3) - } else { - Lambda_ <- matrix(0, 1, 3) - } - - - n_pseudolags <- max(c(n_lags, 3)) - n_determ <- dim(d)[2] - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - - - - - - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - psi <- array(NA, dim = c(n_reps/n_thin, n_vars * n_determ)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) - d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] - roots <- vector("numeric", n_reps/n_thin) - num_tries <- roots - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- tryCatch(mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = n_determ), - error = function(cond) NULL) - if (is.null(ols_results)) { - ols_results <- list() - ols_results$Pi <- prior_Pi_mean - ols_results$psi <- prior_psi_mean - } - - if (is.null(init_Pi)) { - Pi[,, 1] <- ols_results$Pi - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - if (check_roots == TRUE) { - Pi_comp <- mfbvar:::build_companion(Pi = Pi[,, 1], n_vars = n_vars, n_lags = n_lags) - roots[1] <- mfbvar:::max_eig_cpp(Pi_comp) - } - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - if (is.null(init_psi)) { - if (roots[1] < 1) { - psi[1, ] <- ols_results$psi - } else { - psi[1, ] <- prior_psi_mean - } - } else { - if (length(psi[1, ]) == length(init_psi)) { - psi[1,] <- init_psi - } else { - stop(paste0("The length of init_psi is ", paste(length(init_psi), collapse = " x "), ", but should be ", paste(length(psi[1,]), collapse = " x "))) - } - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - # Create D (does not vary in the sampler), and find roots of Pi - # if requested - D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) - dt <- d[-(1:n_lags), , drop = FALSE] - d1 <- d[1:n_lags, , drop = FALSE] - psi_i <- psi[1, ] - Pi_i <- Pi[,, 1] - Sigma_i <- Sigma[,, 1] - Z_i <- Z[-(1:n_lags),, 1] - mu_mat <- dt %*% t(matrix(psi_i, nrow = n_vars)) - - - # For the posterior of Pi - inv_prior_Pi_Omega <- diag(1/c(prior_Pi_Omega)) - Omega_Pi <- matrix(inv_prior_Pi_Omega %*% c(prior_Pi_mean), n_vars*n_lags, n_vars) - - # For the posterior of psi - inv_prior_psi_Omega <- solve(prior_psi_Omega) - inv_prior_psi_Omega_mean <- inv_prior_psi_Omega %*% prior_psi_mean - Z_1 <- Z[1:n_pseudolags,, 1] - - mfbvar:::mcmc_ss_diffuse(Y[-(1:n_lags),],Pi,Sigma,psi,Z,Z_fcst,Lambda_,prior_Pi_Omega,Omega_Pi, - D_mat,dt,d1,d_fcst_lags,inv_prior_psi_Omega,inv_prior_psi_Omega_mean,check_roots,Z_1,n_reps, - n_q,T_b,n_lags,n_vars,n_T_,n_fcst,n_determ,n_thin,verbose) - - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Sigma = Sigma, psi = psi, Z = Z, roots = NULL, num_tries = NULL, - Z_fcst = NULL, smoothed_Z = NULL, n_determ = n_determ, - n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, prior_Pi_mean = prior_Pi_mean, - d = d, Y = Y, n_T = n_T, n_T_ = n_T_, - prior_psi_Omega = prior_psi_Omega, prior_psi_mean = prior_psi_mean, n_reps = n_reps, Lambda_ = Lambda_, - init = list(init_Pi = Pi[,, n_reps/n_thin], init_Sigma = Sigma[,, n_reps/n_thin], init_psi = psi[n_reps/n_thin, ], init_Z = Z[,, n_reps/n_thin])) - - if (check_roots == TRUE) { - return_obj$roots <- roots - return_obj$num_tries <- num_tries - } - if (n_fcst > 0) { - return_obj$Z_fcst <- Z_fcst - } - - return(return_obj) - -} - -#' @rdname mcmc_sampler -mcmc_sampler.mfbvar_ssng_diffuse <- function(x, ...) { - - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$d) && !is.null(x$prior_psi_mean) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "d", "prior_psi_mean", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - if (x$n_fcst > 0 && nrow(x$d_fcst) != x$n_fcst) { - stop("d_fcst has ", nrow(x$d_fcst), " rows, but n_fcst is ", x$n_fcst, ".") - } - - prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(lambda1 = x$lambda1, lambda2 = x$lambda2, lambda3 = x$lambda3, - prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, block_exo = x$block_exo) - prior_Pi_Omega <- prior_Pi_Omega[-1, ] - prior_Pi_mean <- matrix(0, n_vars, n_vars*x$n_lags) - prior_Pi_mean[, 1:n_vars] <- diag(x$prior_Pi_AR1) - - Y <- x$Y - d <- x$d - d_fcst <- x$d_fcst - freq <- x$freq - prior_psi_mean <- x$prior_psi_mean - prior_psi_Omega <- x$prior_psi_Omega - n_fcst <- x$n_fcst - check_roots <- x$check_roots - verbose <- x$verbose - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(is.null(add_args$n_thin),1,add_args$n_thin) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_psi <- init$init_psi - init_Z <- init$init_Z - init_omega <- init$init_omega - init_phi_mu <- init$init_phi_mu - init_lambda_mu <- init$init_lambda_mu - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - n_vars <- dim(Y)[2] - n_lags <- prod(dim(as.matrix(prior_Pi_mean)))/n_vars^2 - n_q <- sum(freq == "q") - n_m <- sum(freq == "m") - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) - d <- d[complete_quarters, , drop = FALSE] - } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) - } else { - T_b <- nrow(y_in_p) - } - if (n_q > 0) { - Lambda_ <- mfbvar:::build_Lambda(rep("q", n_q), 3) - } else { - Lambda_ <- matrix(0, 1, 3) - } - - - n_pseudolags <- max(c(n_lags, 3)) - n_determ <- dim(d)[2] - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - - c0 <- ifelse(is.null(x$c0), 0.01, x$c0) - c1 <- ifelse(is.null(x$c1), 0.01, x$c1) - s <- ifelse(is.null(x[["s"]]), 1, x$s) - - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - psi <- array(NA, dim = c(n_reps/n_thin, n_vars * n_determ)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - omega <- matrix(NA, nrow = n_reps/n_thin, ncol = n_vars * n_determ) - phi_mu <- rep(NA, n_reps/n_thin) - lambda_mu <- rep(NA, n_reps/n_thin) - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) - d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] - roots <- vector("numeric", n_reps/n_thin) - num_tries <- roots - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- tryCatch(mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = n_determ), - error = function(cond) NULL) - if (is.null(ols_results)) { - ols_results <- list() - ols_results$Pi <- prior_Pi_mean - ols_results$psi <- prior_psi_mean - } - - if (is.null(init_Pi)) { - Pi[,, 1] <- ols_results$Pi - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - if (check_roots == TRUE) { - Pi_comp <- mfbvar:::build_companion(Pi = Pi[,, 1], n_vars = n_vars, n_lags = n_lags) - roots[1] <- mfbvar:::max_eig_cpp(Pi_comp) - } - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - if (is.null(init_psi)) { - if (roots[1] < 1) { - psi[1, ] <- ols_results$psi - } else { - psi[1, ] <- prior_psi_mean - } - } else { - if (length(psi[1, ]) == length(init_psi)) { - psi[1,] <- init_psi - } else { - stop(paste0("The length of init_psi is ", paste(length(init_psi), collapse = " x "), ", but should be ", paste(length(psi[1,]), collapse = " x "))) - } - } - - if (is.null(init_omega)) { - if (is.null(prior_psi_Omega)) { - omega[1, ] <- diag(prior_psi_Omega) - } else { - omega[1, ] <- rep(0.1, n_determ*n_vars) - } - } else { - omega[1, ] <- init_omega - } - if (is.null(init_phi_mu)) { - phi_mu[1] <- 1 - } else { - phi_mu[1] <- init_phi_mu - } - if (is.null(init_lambda_mu)) { - lambda_mu[1] <- 1 - } else { - lambda_mu[1] <- init_lambda_mu - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - # Create D (does not vary in the sampler), and find roots of Pi - # if requested - D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) - dt <- d[-(1:n_lags), , drop = FALSE] - d1 <- d[1:n_lags, , drop = FALSE] - psi_i <- psi[1, ] - Pi_i <- Pi[,, 1] - Sigma_i <- Sigma[,, 1] - Z_i <- Z[-(1:n_lags),, 1] - mu_mat <- dt %*% t(matrix(psi_i, nrow = n_vars)) - omega_i <- omega[1, ] - phi_mu_i <- phi_mu[1] - lambda_mu_i <- lambda_mu[1] - - - # For the posterior of Pi - inv_prior_Pi_Omega <- diag(1/c(prior_Pi_Omega)) - Omega_Pi <- matrix(inv_prior_Pi_Omega %*% c(prior_Pi_mean), n_vars*n_lags, n_vars) - - Z_1 <- Z[1:n_pseudolags,, 1] - - mfbvar:::mcmc_ssng_diffuse(Y[-(1:n_lags),],Pi,Sigma,psi,phi_mu,lambda_mu,omega,Z,Z_fcst,Lambda_,prior_Pi_Omega,Omega_Pi, - D_mat,dt,d1,d_fcst_lags,prior_psi_mean,c0,c1,s,check_roots,Z_1,n_reps, - n_q,T_b,n_lags,n_vars,n_T_,n_fcst,n_determ,n_thin,verbose) - - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Sigma = Sigma, psi = psi, Z = Z, phi_mu = phi_mu, lambda_mu = lambda_mu, omega = omega, - roots = NULL, num_tries = NULL, - Z_fcst = NULL, smoothed_Z = NULL, n_determ = n_determ, - n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, prior_Pi_mean = prior_Pi_mean, - d = d, Y = Y, n_T = n_T, n_T_ = n_T_, - prior_psi_Omega = prior_psi_Omega, prior_psi_mean = prior_psi_mean, n_reps = n_reps, Lambda_ = Lambda_, - init = list(init_Pi = Pi[,, n_reps/n_thin], init_Sigma = Sigma[,, n_reps/n_thin], init_psi = psi[n_reps/n_thin, ], init_Z = Z[,, n_reps/n_thin], init_omega = omega[n_reps/n_thin, ], init_lambda_mu = lambda_mu[n_reps/n_thin], init_phi_mu = phi_mu[n_reps/n_thin])) - - if (check_roots == TRUE) { - return_obj$roots <- roots - return_obj$num_tries <- num_tries - } - if (n_fcst > 0) { - return_obj$Z_fcst <- Z_fcst - } - - return(return_obj) - -} diff --git a/R/mcmc_sampler.R b/R/mcmc_sampler.R deleted file mode 100644 index e0d028d..0000000 --- a/R/mcmc_sampler.R +++ /dev/null @@ -1,686 +0,0 @@ -#' MCMC sampler -#' -#' \code{mcmc_sampler} is a generic function for deciding which specific MCMC -#' algorithm to dispatch to. It is called internally. -#' -#' @param x argument to dispatch on (of class \code{prior_obj}) -#' @param ... additional named arguments passed on to the methods - -mcmc_sampler <- function(x, ...) { - UseMethod("mcmc_sampler") -} - -#' @rdname mcmc_sampler -mcmc_sampler.mfbvar_ss_iw <- function(x, ...) { - - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$d) && !is.null(x$prior_psi_mean) && !is.null(x$prior_psi_Omega) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "d", "prior_psi_mean", "prior_psi_Omega", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - if (x$n_fcst > 0 && nrow(x$d_fcst) != x$n_fcst) { - stop("d_fcst has ", nrow(x$d_fcst), " rows, but n_fcst is ", x$n_fcst, ".") - } - - priors <- mfbvar:::prior_Pi_Sigma(lambda1 = x$lambda1, lambda2 = x$lambda3, prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, prior_nu = n_vars + 2) - prior_Pi_mean <- priors$prior_Pi_mean - prior_Pi_Omega <- priors$prior_Pi_Omega - prior_S <- priors$prior_S - - Y <- x$Y - d <- x$d - d_fcst <- x$d_fcst - freq <- x$freq - prior_psi_mean <- x$prior_psi_mean - prior_psi_Omega <- x$prior_psi_Omega - n_fcst <- x$n_fcst - check_roots <- x$check_roots - verbose <- x$verbose - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(is.null(add_args$n_thin),1,add_args$n_thin) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_psi <- init$init_psi - init_Z <- init$init_Z - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - n_vars <- dim(Y)[2] - n_lags <- prod(dim(as.matrix(prior_Pi_mean)))/n_vars^2 - n_q <- sum(freq == "q") - n_m <- sum(freq == "m") - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) - d <- d[complete_quarters, , drop = FALSE] - } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) - } else { - T_b <- nrow(y_in_p) - } - if (n_q > 0) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} - } else { - Lambda_ <- matrix(0, 1, 3) - } - - - n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) - n_determ <- dim(d)[2] - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - - - - - - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - psi <- array(NA, dim = c(n_reps/n_thin, n_vars * n_determ)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) - d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] - roots <- vector("numeric", n_reps/n_thin) - num_tries <- roots - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- tryCatch(mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = n_determ), - error = function(cond) NULL) - if (is.null(ols_results)) { - ols_results <- list() - ols_results$Pi <- prior_Pi_mean - ols_results$S <- prior_S - ols_results$psi <- prior_psi_mean - } - - if (is.null(init_Pi)) { - Pi[,, 1] <- ols_results$Pi - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - if (check_roots == TRUE) { - Pi_comp <- mfbvar:::build_companion(Pi = Pi[,, 1], n_vars = n_vars, n_lags = n_lags) - roots[1] <- mfbvar:::max_eig_cpp(Pi_comp) - } - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - if (is.null(init_psi)) { - if (roots[1] < 1) { - psi[1, ] <- ols_results$psi - } else { - psi[1, ] <- prior_psi_mean - } - } else { - if (length(psi[1, ]) == length(init_psi)) { - psi[1,] <- init_psi - } else { - stop(paste0("The length of init_psi is ", paste(length(init_psi), collapse = " x "), ", but should be ", paste(length(psi[1,]), collapse = " x "))) - } - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - # Create D (does not vary in the sampler), and find roots of Pi - # if requested - D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) - dt <- d[-(1:n_lags), , drop = FALSE] - d1 <- d[1:n_lags, , drop = FALSE] - psi_i <- psi[1, ] - Pi_i <- Pi[,, 1] - Sigma_i <- Sigma[,, 1] - Z_i <- Z[-(1:n_lags),, 1] - mu_mat <- dt %*% t(matrix(psi_i, nrow = n_vars)) - - - # For the posterior of Pi - inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - - # For the posterior of psi - inv_prior_psi_Omega <- solve(prior_psi_Omega) - inv_prior_psi_Omega_mean <- inv_prior_psi_Omega %*% prior_psi_mean - Z_1 <- Z[1:n_pseudolags,, 1] - - mfbvar:::mcmc_ss_iw(Y[-(1:n_lags),],Pi,Sigma,psi,Z,Z_fcst,Lambda_,prior_Pi_Omega,inv_prior_Pi_Omega,Omega_Pi,prior_Pi_mean, - prior_S,D_mat,dt,d1,d_fcst_lags,inv_prior_psi_Omega,inv_prior_psi_Omega_mean,check_roots,Z_1,n_reps, - n_q,T_b,n_lags,n_vars,n_T_,n_fcst,n_determ,n_thin,verbose) - - # mfbvar:::mcmc_ssng_iw(Y[-(1:n_lags),],Pi,Sigma,psi,phi_mu,lambda_mu,omega,Z,Z_fcst,Lambda_comp,prior_Pi_Omega,inv_prior_Pi_Omega,Omega_Pi,prior_Pi_mean, - # prior_S,D_mat,dt,d1,d_fcst_lags,prior_psi_mean,0.01,0.01,1,check_roots,Z_1,n_reps, - # n_q,T_b,n_lags,n_vars,n_T_,n_fcst,n_determ,n_thin,verbose) - - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Sigma = Sigma, psi = psi, Z = Z, roots = NULL, num_tries = NULL, - Z_fcst = NULL, smoothed_Z = NULL, n_determ = n_determ, - n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, prior_Pi_mean = prior_Pi_mean, - prior_S = prior_S, prior_nu = n_vars+2, post_nu = n_T + n_vars+2, d = d, Y = Y, n_T = n_T, n_T_ = n_T_, - prior_psi_Omega = prior_psi_Omega, prior_psi_mean = prior_psi_mean, n_reps = n_reps, Lambda_ = Lambda_, - init = list(init_Pi = Pi[,, n_reps/n_thin], init_Sigma = Sigma[,, n_reps/n_thin], init_psi = psi[n_reps/n_thin, ], init_Z = Z[,, n_reps/n_thin])) - - if (check_roots == TRUE) { - return_obj$roots <- roots - return_obj$num_tries <- num_tries - } - if (n_fcst > 0) { - return_obj$Z_fcst <- Z_fcst - } - - return(return_obj) - -} - -#' @rdname mcmc_sampler -mcmc_sampler.mfbvar_ssng_iw <- function(x, ...) { - - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$d) && !is.null(x$prior_psi_mean) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "d", "prior_psi_mean", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - if (x$n_fcst > 0 && nrow(x$d_fcst) != x$n_fcst) { - stop("d_fcst has ", nrow(x$d_fcst), " rows, but n_fcst is ", x$n_fcst, ".") - } - - priors <- mfbvar:::prior_Pi_Sigma(lambda1 = x$lambda1, lambda2 = x$lambda3, prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, prior_nu = n_vars + 2) - prior_Pi_mean <- priors$prior_Pi_mean - prior_Pi_Omega <- priors$prior_Pi_Omega - prior_S <- priors$prior_S - - Y <- x$Y - d <- x$d - d_fcst <- x$d_fcst - freq <- x$freq - prior_psi_mean <- x$prior_psi_mean - prior_psi_Omega <- x$prior_psi_Omega - n_fcst <- x$n_fcst - check_roots <- x$check_roots - verbose <- x$verbose - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(is.null(add_args$n_thin),1,add_args$n_thin) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_psi <- init$init_psi - init_Z <- init$init_Z - init_omega <- init$init_omega - init_phi_mu <- init$init_phi_mu - init_lambda_mu <- init$init_lambda_mu - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - n_vars <- dim(Y)[2] - n_lags <- prod(dim(as.matrix(prior_Pi_mean)))/n_vars^2 - n_q <- sum(freq == "q") - n_m <- sum(freq == "m") - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) - d <- d[complete_quarters, , drop = FALSE] - } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) - } else { - T_b <- nrow(y_in_p) - } - if (n_q > 0) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} - } else { - Lambda_ <- matrix(0, 1, 3) - } - - - n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) - n_determ <- dim(d)[2] - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - - c0 <- ifelse(is.null(x$c0), 0.01, x$c0) - c1 <- ifelse(is.null(x$c1), 0.01, x$c1) - s <- ifelse(is.null(x[["s"]]), 1, x$s) - - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - psi <- array(NA, dim = c(n_reps/n_thin, n_vars * n_determ)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - omega <- matrix(NA, nrow = n_reps/n_thin, ncol = n_vars * n_determ) - phi_mu <- rep(NA, n_reps/n_thin) - lambda_mu <- rep(NA, n_reps/n_thin) - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) - d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] - roots <- vector("numeric", n_reps/n_thin) - num_tries <- roots - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- tryCatch(mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = n_determ), - error = function(cond) NULL) - if (is.null(ols_results)) { - ols_results <- list() - ols_results$Pi <- prior_Pi_mean - ols_results$S <- prior_S - ols_results$psi <- prior_psi_mean - } - - if (is.null(init_Pi)) { - Pi[,, 1] <- ols_results$Pi - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - if (check_roots == TRUE) { - Pi_comp <- mfbvar:::build_companion(Pi = Pi[,, 1], n_vars = n_vars, n_lags = n_lags) - roots[1] <- mfbvar:::max_eig_cpp(Pi_comp) - } - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - if (is.null(init_psi)) { - if (roots[1] < 1) { - psi[1, ] <- ols_results$psi - } else { - psi[1, ] <- prior_psi_mean - } - } else { - if (length(psi[1, ]) == length(init_psi)) { - psi[1,] <- init_psi - } else { - stop(paste0("The length of init_psi is ", paste(length(init_psi), collapse = " x "), ", but should be ", paste(length(psi[1,]), collapse = " x "))) - } - } - - if (is.null(init_omega)) { - if (is.null(prior_psi_Omega)) { - omega[1, ] <- diag(prior_psi_Omega) - } else { - omega[1, ] <- rep(0.1, n_determ*n_vars) - } - } else { - omega[1, ] <- init_omega - } - if (is.null(init_phi_mu)) { - phi_mu[1] <- 1 - } else { - phi_mu[1] <- init_phi_mu - } - if (is.null(init_lambda_mu)) { - lambda_mu[1] <- 1 - } else { - lambda_mu[1] <- init_lambda_mu - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - # Create D (does not vary in the sampler), and find roots of Pi - # if requested - D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) - dt <- d[-(1:n_lags), , drop = FALSE] - d1 <- d[1:n_lags, , drop = FALSE] - psi_i <- psi[1, ] - Pi_i <- Pi[,, 1] - Sigma_i <- Sigma[,, 1] - Z_i <- Z[-(1:n_lags),, 1] - mu_mat <- dt %*% t(matrix(psi_i, nrow = n_vars)) - omega_i <- omega[1, ] - phi_mu_i <- phi_mu[1] - lambda_mu_i <- lambda_mu[1] - - - # For the posterior of Pi - inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - - Z_1 <- Z[1:n_pseudolags,, 1] - - mfbvar:::mcmc_ssng_iw(Y[-(1:n_lags),],Pi,Sigma,psi,phi_mu,lambda_mu,omega,Z,Z_fcst,Lambda_,prior_Pi_Omega,inv_prior_Pi_Omega,Omega_Pi,prior_Pi_mean, - prior_S,D_mat,dt,d1,d_fcst_lags,prior_psi_mean,c0,c1,s,check_roots,Z_1,n_reps, - n_q,T_b,n_lags,n_vars,n_T_,n_fcst,n_determ,n_thin,verbose) - - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Sigma = Sigma, psi = psi, Z = Z, phi_mu = phi_mu, lambda_mu = lambda_mu, omega = omega, - roots = NULL, num_tries = NULL, - Z_fcst = NULL, smoothed_Z = NULL, n_determ = n_determ, - n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, prior_Pi_mean = prior_Pi_mean, - prior_S = prior_S, prior_nu = n_vars+2, post_nu = n_T + n_vars+2, d = d, Y = Y, n_T = n_T, n_T_ = n_T_, - prior_psi_Omega = prior_psi_Omega, prior_psi_mean = prior_psi_mean, n_reps = n_reps, Lambda_ = Lambda_, - init = list(init_Pi = Pi[,, n_reps/n_thin], init_Sigma = Sigma[,, n_reps/n_thin], init_psi = psi[n_reps/n_thin, ], init_Z = Z[,, n_reps/n_thin], init_omega = omega[n_reps/n_thin, ], init_lambda_mu = lambda_mu[n_reps/n_thin], init_phi_mu = phi_mu[n_reps/n_thin])) - - if (check_roots == TRUE) { - return_obj$roots <- roots - return_obj$num_tries <- num_tries - } - if (n_fcst > 0) { - return_obj$Z_fcst <- Z_fcst - } - - return(return_obj) - -} - -#' @rdname mcmc_sampler -mcmc_sampler.mfbvar_minn_iw <- function(x, ...){ - - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - - prior_nu <- n_vars + 2 - priors <- mfbvar:::prior_Pi_Sigma(lambda1 = x$lambda1, lambda2 = x$lambda3, prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, prior_nu = prior_nu) - prior_Pi_mean <- priors$prior_Pi_mean - prior_Pi_Omega <- priors$prior_Pi_Omega - prior_S <- priors$prior_S - - Y <- x$Y - freq <- x$freq - n_fcst <- x$n_fcst - verbose <- x$verbose - n_lags <- x$n_lags - lambda4 <- x$lambda4 - - # Add terms for constant - prior_Pi_Omega <- diag(c(x$lambda1^2*lambda4^2, diag(prior_Pi_Omega))) - prior_Pi_mean <- rbind(0, prior_Pi_mean) - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(!is.null(add_args$n_thin), add_args$n_thin, ifelse(!is.null(x$n_thin), x$n_thin, 1)) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_Z <- init$init_Z - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - - n_q <- sum(freq == "q") - if (n_q < n_vars) { - T_b <- max(which(!apply(apply(Y[, freq == "m", drop = FALSE], 2, is.na), 1, any))) - } else { - T_b <- nrow(Y) - } - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - } - if (n_q > 0) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} - } else { - Lambda_ <- matrix(0, 1, 3) - } - - n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - d <- matrix(1, nrow = nrow(Y), ncol = 1) - post_nu <- n_T_ + prior_nu - - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags + 1, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = 1) - - if (is.null(init_Pi)) { - Pi[,, 1] <- cbind(ols_results$const, ols_results$Pi) - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - Z_1 <- Z[1:n_pseudolags,, 1] - - # For the posterior of Pi - inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - - mfbvar:::mcmc_minn_iw(Y[-(1:n_lags),],Pi,Sigma,Z,Z_fcst,Lambda_,prior_Pi_Omega,inv_prior_Pi_Omega, - Omega_Pi,prior_Pi_mean,prior_S,Z_1,n_reps,n_q,T_b-n_lags,n_lags,n_vars,n_T_,n_fcst, - n_thin,verbose,2) - - - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Sigma = Sigma, psi = NULL, Z = Z, roots = NULL, num_tries = NULL, - Z_fcst = NULL, smoothed_Z = NULL, n_determ = 1, - n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, prior_Pi_mean = prior_Pi_mean, - prior_S = prior_S, prior_nu = prior_nu, post_nu = prior_nu + n_T_, d = d, Y = Y, n_T = n_T, n_T_ = n_T_, - prior_psi_Omega = NULL, prior_psi_mean = NULL, n_reps = n_reps, Lambda_ = Lambda_, freq = freq, - init = list(init_Pi = Pi[,, n_reps/n_thin], init_Sigma = Sigma[,, n_reps/n_thin], init_Z = Z[,, n_reps/n_thin])) - - if (n_fcst>0) { - return_obj$Z_fcst <- Z_fcst - } - - return(return_obj) - -} - - diff --git a/R/mcmc_sampler_csv.R b/R/mcmc_sampler_csv.R deleted file mode 100644 index 7c36654..0000000 --- a/R/mcmc_sampler_csv.R +++ /dev/null @@ -1,731 +0,0 @@ -mcmc_sampler.mfbvar_minn_csv <- function(x, ...){ - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - - prior_nu <- n_vars + 2 - priors <- mfbvar:::prior_Pi_Sigma(lambda1 = x$lambda1, lambda2 = x$lambda3, prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, prior_nu = prior_nu) - prior_Pi_mean <- priors$prior_Pi_mean - prior_Pi_Omega <- priors$prior_Pi_Omega - prior_S <- priors$prior_S - - Y <- x$Y - freq <- x$freq - n_fcst <- x$n_fcst - verbose <- x$verbose - n_lags <- x$n_lags - lambda4 <- x$lambda4 - - # Add terms for constant - prior_Pi_Omega <- diag(c(x$lambda1^2*lambda4^2, diag(prior_Pi_Omega))) - prior_Pi_mean <- rbind(0, prior_Pi_mean) - - phi_invvar <- 1/x$prior_phi[2] - phi_meaninvvar <- x$prior_phi[1] * phi_invvar - prior_sigma2 <- x$prior_sigma2[1] - prior_df <- x$prior_sigma2[2] - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(!is.null(add_args$n_thin), add_args$n_thin, ifelse(!is.null(x$n_thin), x$n_thin, 1)) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_Z <- init$init_Z - init_phi <- init$init_phi - init_sigma <- init$init_sigma - init_f <- init$init_f - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - - n_q <- sum(freq == "q") - if (n_q < n_vars) { - T_b <- max(which(!apply(apply(Y[, freq == "m", drop = FALSE], 2, is.na), 1, any))) - } else { - T_b <- nrow(Y) - } - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - } - if (n_q > 0) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} - } else { - Lambda_ <- matrix(0, 1, 3) - } - - - n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - d <- matrix(1, nrow = nrow(Y), ncol = 1) - post_nu <- n_T_ + prior_nu - - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags + 1, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - phi <- rep(NA, n_reps/n_thin) - sigma <- rep(NA, n_reps/n_thin) - f <- matrix(NA, n_reps, n_T_) - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = 1) - - if (is.null(init_Pi)) { - Pi[,, 1] <- cbind(ols_results$const, ols_results$Pi) - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - if (is.null(init_phi)) { - phi[1] <- x$prior_phi[1] - } else { - phi[1] <- init_phi - } - - if (is.null(init_sigma)) { - sigma[1] <- sqrt(x$prior_sigma2[1]) - } else { - sigma[1] <- init_sigma - } - - if (is.null(init_f)) { - f[1,] <- 0.0 - } else { - f[1,] <- init_f - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - Z_1 <- Z[1:n_pseudolags,, 1] - - # For the posterior of Pi - inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - - set.seed(1) - mfbvar:::mcmc_minn_csv(Y[-(1:n_lags),],Pi,Sigma,Z,Z_fcst,phi,sigma,f,Lambda_,prior_Pi_Omega,inv_prior_Pi_Omega, - Omega_Pi,prior_Pi_mean,prior_S,Z_1,10,phi_invvar,phi_meaninvvar,prior_sigma2,prior_df, - n_reps,n_q,T_b-n_lags,n_lags,n_vars,n_T_,n_fcst,n_thin,verbose) - - return_obj <- list(Pi = Pi, Sigma = Sigma, Z = Z, phi = phi, sigma = sigma, f = f, - Z_fcst = NULL, n_lags = n_lags, n_vars = n_vars, - n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, - prior_Pi_mean = prior_Pi_mean, prior_S = prior_S, - prior_nu = n_vars+2, post_nu = n_T + n_vars+2, d = d, Y = Y, - n_T = n_T, n_T_ = n_T_, n_reps = n_reps, Lambda_ = Lambda_, - init = list(init_Pi = Pi[,, n_reps/n_thin], - init_Sigma = Sigma[,, n_reps/n_thin], - init_Z = Z[,, n_reps/n_thin], - init_phi = phi[n_reps/n_thin], - init_sigma = sigma[n_reps/n_thin], - init_f = f[n_reps/n_thin,])) - - if (n_fcst > 0) { - return_obj$Z_fcst <- Z_fcst - } - return(return_obj) - -} - -mcmc_sampler.mfbvar_ss_csv <- function(x, ...) { - - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$d) && !is.null(x$prior_psi_mean) && !is.null(x$prior_psi_Omega) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "d", "prior_psi_mean", "prior_psi_Omega", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - if (x$n_fcst > 0 && nrow(x$d_fcst) != x$n_fcst) { - stop("d_fcst has ", nrow(x$d_fcst), " rows, but n_fcst is ", x$n_fcst, ".") - } - - priors <- mfbvar:::prior_Pi_Sigma(lambda1 = x$lambda1, lambda2 = x$lambda3, prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, prior_nu = n_vars + 2) - prior_Pi_mean <- priors$prior_Pi_mean - prior_Pi_Omega <- priors$prior_Pi_Omega - prior_S <- priors$prior_S - - Y <- x$Y - d <- x$d - d_fcst <- x$d_fcst - freq <- x$freq - prior_psi_mean <- x$prior_psi_mean - prior_psi_Omega <- x$prior_psi_Omega - n_fcst <- x$n_fcst - check_roots <- x$check_roots - verbose <- x$verbose - - phi_invvar <- 1/x$prior_phi[2] - phi_meaninvvar <- x$prior_phi[1] * phi_invvar - prior_sigma2 <- x$prior_sigma2[1] - prior_df <- x$prior_sigma2[2] - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(is.null(add_args$n_thin),1,add_args$n_thin) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_psi <- init$init_psi - init_Z <- init$init_Z - init_phi <- init$init_phi - init_sigma <- init$init_sigma - init_f <- init$init_f - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - n_vars <- dim(Y)[2] - n_lags <- prod(dim(as.matrix(prior_Pi_mean)))/n_vars^2 - n_q <- sum(freq == "q") - n_m <- sum(freq == "m") - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) - d <- d[complete_quarters, , drop = FALSE] - } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) - } else { - T_b <- nrow(y_in_p) - } - if (n_q > 0) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} - } else { - Lambda_ <- matrix(0, 1, 3) - } - - - n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) - n_determ <- dim(d)[2] - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - psi <- array(NA, dim = c(n_reps/n_thin, n_vars * n_determ)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - phi <- rep(NA, n_reps/n_thin) - sigma <- rep(NA, n_reps/n_thin) - f <- matrix(NA, n_reps/n_thin, n_T_) - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) - d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] - roots <- vector("numeric", n_reps/n_thin) - num_tries <- roots - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- tryCatch(mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = n_determ), - error = function(cond) NULL) - if (is.null(ols_results)) { - ols_results <- list() - ols_results$Pi <- prior_Pi_mean - ols_results$S <- prior_S - ols_results$psi <- prior_psi_mean - } - - if (is.null(init_Pi)) { - Pi[,, 1] <- ols_results$Pi - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - if (check_roots == TRUE) { - Pi_comp <- mfbvar:::build_companion(Pi = Pi[,, 1], n_vars = n_vars, n_lags = n_lags) - roots[1] <- mfbvar:::max_eig_cpp(Pi_comp) - } - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - if (is.null(init_psi)) { - if (roots[1] < 1) { - psi[1, ] <- ols_results$psi - } else { - psi[1, ] <- prior_psi_mean - } - } else { - if (length(psi[1, ]) == length(init_psi)) { - psi[1,] <- init_psi - } else { - stop(paste0("The length of init_psi is ", paste(length(init_psi), collapse = " x "), ", but should be ", paste(length(psi[1,]), collapse = " x "))) - } - } - - if (is.null(init_phi)) { - phi[1] <- x$prior_phi[1] - } else { - phi[1] <- init_phi - } - - if (is.null(init_sigma)) { - sigma[1] <- sqrt(x$prior_sigma2[1]) - } else { - sigma[1] <- init_sigma - } - - if (is.null(init_f)) { - f[1,] <- 0.0 - } else { - f[1,] <- init_f - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - # Create D (does not vary in the sampler), and find roots of Pi - # if requested - D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) - dt <- d[-(1:n_lags), , drop = FALSE] - d1 <- d[1:n_lags, , drop = FALSE] - - # For the posterior of Pi - inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - - # For the posterior of psi - inv_prior_psi_Omega <- solve(prior_psi_Omega) - inv_prior_psi_Omega_mean <- inv_prior_psi_Omega %*% prior_psi_mean - Z_1 <- Z[1:n_pseudolags,, 1] - - mfbvar:::mcmc_ss_csv(Y[-(1:n_lags),],Pi,Sigma,psi,Z,Z_fcst,phi,sigma,f,Lambda_,prior_Pi_Omega,inv_prior_Pi_Omega,Omega_Pi,prior_Pi_mean, - prior_S,D_mat,dt,d1,d_fcst_lags,inv_prior_psi_Omega,inv_prior_psi_Omega_mean,check_roots,Z_1, - 10,phi_invvar,phi_meaninvvar,prior_sigma2,prior_df,n_reps,n_q,T_b,n_lags,n_vars,n_T_,n_fcst,n_determ,n_thin,verbose) - - return_obj <- list(Pi = Pi, Sigma = Sigma, psi = psi, Z = Z, phi = phi, sigma = sigma, f = f, roots = NULL, num_tries = NULL, - Z_fcst = NULL, smoothed_Z = NULL, n_determ = n_determ, - n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, prior_Pi_mean = prior_Pi_mean, - prior_S = prior_S, prior_nu = n_vars+2, post_nu = n_T + n_vars+2, d = d, Y = Y, n_T = n_T, n_T_ = n_T_, - prior_psi_Omega = prior_psi_Omega, prior_psi_mean = prior_psi_mean, n_reps = n_reps, Lambda_ = Lambda_, - init = list(init_Pi = Pi[,, n_reps/n_thin], init_Sigma = Sigma[,, n_reps/n_thin], init_psi = psi[n_reps/n_thin, ], init_Z = Z[,, n_reps/n_thin], init_phi = phi[n_reps/n_thin], init_sigma = sigma[n_reps/n_thin], init_f = f[n_reps/n_thin,])) - - if (check_roots == TRUE) { - return_obj$roots <- roots - return_obj$num_tries <- num_tries - } - if (n_fcst > 0) { - return_obj$Z_fcst <- Z_fcst - } - - return(return_obj) -} - -mcmc_sampler.mfbvar_ssng_csv <- function(x, ...) { - - n_vars <- ncol(x$Y) - if (!(!is.null(x$Y) && !is.null(x$d) && !is.null(x$prior_psi_mean) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { - test_all <- sapply(x, is.null) - test_sub <- test_all[c("Y", "d", "prior_psi_mean", "n_lags", "n_burnin", "n_reps")] - stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) - } - if (x$n_fcst > 0 && nrow(x$d_fcst) != x$n_fcst) { - stop("d_fcst has ", nrow(x$d_fcst), " rows, but n_fcst is ", x$n_fcst, ".") - } - - priors <- mfbvar:::prior_Pi_Sigma(lambda1 = x$lambda1, lambda2 = x$lambda3, prior_Pi_AR1 = x$prior_Pi_AR1, Y = x$Y, - n_lags = x$n_lags, prior_nu = n_vars + 2) - prior_Pi_mean <- priors$prior_Pi_mean - prior_Pi_Omega <- priors$prior_Pi_Omega - prior_S <- priors$prior_S - - Y <- x$Y - d <- x$d - d_fcst <- x$d_fcst - freq <- x$freq - prior_psi_mean <- x$prior_psi_mean - prior_psi_Omega <- x$prior_psi_Omega - n_fcst <- x$n_fcst - check_roots <- x$check_roots - verbose <- x$verbose - - phi_invvar <- 1/x$prior_phi[2] - phi_meaninvvar <- x$prior_phi[1] * phi_invvar - prior_sigma2 <- x$prior_sigma2[1] - prior_df <- x$prior_sigma2[2] - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(is.null(add_args$n_thin),1,add_args$n_thin) - init <- add_args$init - init_Pi <- init$init_Pi - init_Sigma <- init$init_Sigma - init_psi <- init$init_psi - init_Z <- init$init_Z - init_phi <- init$init_phi - init_sigma <- init$init_sigma - init_f <- init$init_f - init_omega <- init$init_omega - init_phi_mu <- init$init_phi_mu - init_lambda_mu <- init$init_lambda_mu - - # n_vars: number of variables - # n_lags: number of lags - # n_determ: number of deterministic variables - # n_T: sample size (full sample) - # n_T_: sample size (reduced sample) - n_vars <- dim(Y)[2] - n_lags <- prod(dim(as.matrix(prior_Pi_mean)))/n_vars^2 - n_q <- sum(freq == "q") - n_m <- sum(freq == "m") - if (n_q == 0 || n_q == n_vars) { - complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) - Y <- Y[complete_quarters, ] - d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) - d <- d[complete_quarters, , drop = FALSE] - } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) - } else { - T_b <- nrow(y_in_p) - } - if (n_q > 0) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} - } else { - Lambda_ <- matrix(0, 1, 3) - } - - - n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) - n_determ <- dim(d)[2] - n_T <- dim(Y)[1]# - n_lags - n_T_ <- n_T - n_pseudolags - - - - c0 <- ifelse(is.null(x$c0), 0.01, x$c0) - c1 <- ifelse(is.null(x$c1), 0.01, x$c1) - s <- ifelse(is.null(x[["s"]]), -10, x$s) - ################################################################ - ### Preallocation - # Pi and Sigma store their i-th draws in the third dimension, psi - # is vectorized so it has its i-th draw stored in the i-th row - # Pi: p * pk * n_reps, each [,,i] stores Pi' - # Sigma: p * p * n_reps - # psi: n_reps * p - # Z: T * p * n_reps - ### If forecasting (h is horizon): - # Z_fcst: hk * p * n_reps - # d_fcst_lags: hk * m - ### If root checking: - # roots: n_reps vector - # num_tries: n_reps vector - ### If smoothing of the state vector: - # smoothed_Z: T * p * n_reps - - Pi <- array(NA, dim = c(n_vars, n_vars * n_lags, n_reps/n_thin)) - Sigma <- array(NA, dim = c(n_vars, n_vars, n_reps/n_thin)) - psi <- array(NA, dim = c(n_reps/n_thin, n_vars * n_determ)) - Z <- array(NA, dim = c(n_T, n_vars, n_reps/n_thin)) - phi <- rep(NA, n_reps/n_thin) - sigma <- rep(NA, n_reps/n_thin) - f <- matrix(NA, n_reps/n_thin, n_T_) - omega <- matrix(NA, nrow = n_reps/n_thin, ncol = n_vars * n_determ) - phi_mu <- rep(NA, n_reps/n_thin) - lambda_mu <- rep(NA, n_reps/n_thin) - Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) - if (n_fcst > 0) { - rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) - Z_fcst[,,1] <- 0 - } else { - rownames(Z_fcst) <- (n_T-n_lags+1):n_T - } - d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) - d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] - roots <- vector("numeric", n_reps/n_thin) - num_tries <- roots - - - - ################################################################ - ### MCMC sampling initialization - - # If the initial values are not provided, the missing values in - # Z are filled with the next observed value and Pi, Sigma and - # psi are then computed using maximum likelihood - - # This allows the user to run the MCMC sampler for a burn-in - # period, then use the final draw of that as initialization - # for multiple chains - - if (is.null(init_Z)) { - Z[,, 1] <- mfbvar:::fill_na(Y) - } else { - if (all(dim(Z[,, 1]) == dim(init_Z))) { - Z[,, 1] <- init_Z - } else { - stop(paste0("The dimension of init_Z is ", paste(dim(init_Z), collapse = " x "), ", but should be ", paste(dim(Z[,, 1]), collapse = " x "))) - } - - } - - ols_results <- tryCatch(mfbvar:::ols_initialization(z = Z[,, 1], d = d, n_lags = n_lags, n_T = n_T, n_vars = n_vars, n_determ = n_determ), - error = function(cond) NULL) - if (is.null(ols_results)) { - ols_results <- list() - ols_results$Pi <- prior_Pi_mean - ols_results$S <- prior_S - ols_results$psi <- prior_psi_mean - } - - if (is.null(init_Pi)) { - Pi[,, 1] <- ols_results$Pi - } else { - if (all(dim(Pi[,, 1]) == dim(init_Pi))) { - Pi[,, 1] <- init_Pi - } else { - stop(paste0("The dimension of init_Pi is ", paste(dim(init_Pi), collapse = " x "), ", but should be ", paste(dim(Pi[,, 1]), collapse = " x "))) - } - } - - # Compute the maximum eigenvalue of the initial Pi - if (check_roots == TRUE) { - Pi_comp <- mfbvar:::build_companion(Pi = Pi[,, 1], n_vars = n_vars, n_lags = n_lags) - roots[1] <- mfbvar:::max_eig_cpp(Pi_comp) - } - - if (is.null(init_Sigma)) { - Sigma[,, 1] <- ols_results$S - } else { - if (all(dim(Sigma[,,1]) == dim(init_Sigma))) { - Sigma[,, 1] <- init_Sigma - } else { - stop(paste0("The dimension of init_Sigma is ", paste(dim(init_Sigma), collapse = " x "), ", but should be ", paste(dim(Sigma[,,1]), collapse = " x "))) - } - } - - if (is.null(init_psi)) { - if (roots[1] < 1) { - psi[1, ] <- ols_results$psi - } else { - psi[1, ] <- prior_psi_mean - } - } else { - if (length(psi[1, ]) == length(init_psi)) { - psi[1,] <- init_psi - } else { - stop(paste0("The length of init_psi is ", paste(length(init_psi), collapse = " x "), ", but should be ", paste(length(psi[1,]), collapse = " x "))) - } - } - - if (is.null(init_phi)) { - phi[1] <- x$prior_phi[1] - } else { - phi[1] <- init_phi - } - - if (is.null(init_sigma)) { - sigma[1] <- sqrt(x$prior_sigma2[1]) - } else { - sigma[1] <- init_sigma - } - - if (is.null(init_f)) { - f[1,] <- 0.0 - } else { - f[1,] <- init_f - } - - if (is.null(init_omega)) { - if (is.null(prior_psi_Omega)) { - omega[1, ] <- diag(prior_psi_Omega) - } else { - omega[1, ] <- rep(0.1, n_determ*n_vars) - } - } else { - omega[1, ] <- init_omega - } - - if (is.null(init_phi_mu)) { - phi_mu[1] <- 1 - } else { - phi_mu[1] <- init_phi_mu - } - - if (is.null(init_lambda_mu)) { - lambda_mu[1] <- 1 - } else { - lambda_mu[1] <- init_lambda_mu - } - - ################################################################ - ### Compute terms which do not vary in the sampler - - # Create D (does not vary in the sampler), and find roots of Pi - # if requested - D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) - dt <- d[-(1:n_lags), , drop = FALSE] - d1 <- d[1:n_lags, , drop = FALSE] - - # For the posterior of Pi - inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - - Z_1 <- Z[1:n_pseudolags,, 1] - - mfbvar:::mcmc_ssng_csv(Y[-(1:n_lags),],Pi,Sigma,psi,phi_mu,lambda_mu,omega,Z,Z_fcst,phi,sigma,f,Lambda_,prior_Pi_Omega,inv_prior_Pi_Omega,Omega_Pi,prior_Pi_mean, - prior_S,D_mat,dt,d1,d_fcst_lags,prior_psi_mean,c0,c1,s,check_roots,Z_1, - 10,phi_invvar,phi_meaninvvar,prior_sigma2,prior_df,n_reps,n_q,T_b,n_lags,n_vars,n_T_,n_fcst,n_determ,n_thin,verbose) - - return_obj <- list(Pi = Pi, Sigma = Sigma, psi = psi, Z = Z, phi_mu = phi_mu, lambda_mu = lambda_mu, omega = omega, - phi = phi, sigma = sigma, f = f, roots = NULL, num_tries = NULL, - Z_fcst = NULL, smoothed_Z = NULL, n_determ = n_determ, - n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, prior_Pi_Omega = prior_Pi_Omega, prior_Pi_mean = prior_Pi_mean, - prior_S = prior_S, prior_nu = n_vars+2, post_nu = n_T + n_vars+2, d = d, Y = Y, n_T = n_T, n_T_ = n_T_, - prior_psi_Omega = prior_psi_Omega, prior_psi_mean = prior_psi_mean, n_reps = n_reps, Lambda_ = Lambda_, - init = list(init_Pi = Pi[,, n_reps/n_thin], init_Sigma = Sigma[,, n_reps/n_thin], init_psi = psi[n_reps/n_thin, ], init_Z = Z[,, n_reps/n_thin], init_phi = phi[n_reps/n_thin], init_sigma = sigma[n_reps/n_thin], init_f = f[n_reps/n_thin,], init_omega = omega[n_reps/n_thin, ], init_lambda_mu = lambda_mu[n_reps/n_thin], init_phi_mu = phi_mu[n_reps/n_thin])) - - if (check_roots == TRUE) { - return_obj$roots <- roots - return_obj$num_tries <- num_tries - } - if (n_fcst > 0) { - return_obj$Z_fcst <- Z_fcst - } - - return(return_obj) -} diff --git a/R/mcmc_sampler_fsv.R b/R/mcmc_sampler_fsv.R index 9ac11de..15dcf66 100644 --- a/R/mcmc_sampler_fsv.R +++ b/R/mcmc_sampler_fsv.R @@ -1,50 +1,110 @@ +mcmc_sampler <- function(x, ...) { + UseMethod("mcmc_sampler") +} + + #' @rdname mcmc_sampler mcmc_sampler.mfbvar_minn_fsv <- function(x, ...){ - - if (is.null(x$n_fac)) { - stop("The number of factors (n_fac) must be provided.") + n_vars <- ncol(x$Y) + if (!(!is.null(x$Y) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { + test_all <- sapply(x, is.null) + test_sub <- test_all[c("Y", "n_lags", "n_burnin", "n_reps")] + stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) } + + prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(x$lambda1, x$lambda2, x$lambda3, x$prior_Pi_AR1, x$Y, x$n_lags) + prior_Pi_AR1 <- x$prior_Pi_AR1 + prior_zero_mean <- all(x$prior_Pi_AR1 == 0) + Y <- x$Y + freq <- x$freq + verbose <- x$verbose + n_vars <- ncol(Y) n_lags <- x$n_lags - n_q <- sum(x$freq == "q") - n_m <- n_vars - n_q n_fac <- x$n_fac n_fcst <- x$n_fcst - mf <- TRUE + + ## Priors + + priormu <- x$priormu + priorphiidi <- x$priorphiidi + priorphifac <- x$priorphifac + priorsigmaidi <- x$priorsigmaidi + priorsigmafac <- x$priorsigmafac + priorfacload <- x$priorfacload + restrict <- x$restrict + + if (length(priorsigmaidi) == 1) { + priorsigmaidi <- rep(priorsigmaidi, n_vars) + } + if (length(priorsigmafac) == 1) { + priorsigmafac <- rep(priorsigmafac, n_fac) + } + + bmu <- priormu[1] + Bmu <- priormu[2]^2 + + Bsigma <- c(priorsigmaidi, priorsigmafac) + + B011inv <- 1/10^8 + B022inv <- 1/10^12 + + armatau2 <- matrix(priorfacload^2, n_vars, n_fac) # priorfacload is scalar, or matrix + + armarestr <- matrix(FALSE, nrow = n_vars, ncol = n_fac) + if (restrict == "upper") armarestr[upper.tri(armarestr)] <- TRUE + armarestr <- matrix(as.integer(!armarestr), nrow = nrow(armarestr), ncol = ncol(armarestr)) # restrinv + + a0idi <- priorphiidi[1] + b0idi <- priorphiidi[2] + a0fac <- priorphifac[1] + b0fac <- priorphifac[2] + + priorh0 <- rep(-1.0, n_vars + n_fac) + + ## Initials + + add_args <- list(...) + n_reps <- x$n_reps + n_burnin <- x$n_burnin + n_thin <- ifelse(is.null(x$n_thin), 1, x$n_thin) + + # n_vars: number of variables + # n_lags: number of lags + # n_determ: number of deterministic variables + # n_T: sample size (full sample) + # n_T_: sample size (reduced sample) + + n_q <- sum(freq == "q") + if (n_q < n_vars) { + T_b <- max(which(!apply(apply(Y[, freq == "m", drop = FALSE], 2, is.na), 1, any))) + } else { + T_b <- nrow(Y) + } if (n_q == 0 || n_q == n_vars) { complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) Y <- Y[complete_quarters, ] - mf <- FALSE } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) + if (n_q > 0) { + if (x$aggregation == "average") { + Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) + } else { + Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} } else { - T_b <- nrow(y_in_p) + Lambda_ <- matrix(0, 1, 3) } - n_T_ <- nrow(Y) - n_lags - n_T <- nrow(Y) - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(!is.null(add_args$n_thin), add_args$n_thin, ifelse(!is.null(x$n_thin), x$n_thin, 1)) + n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) + n_T <- dim(Y)[1]# - n_lags + n_T_ <- n_T - n_pseudolags + + ## Initials init <- add_args$init + y_in_p <- Y[-(1:n_lags), ] error_variance <- mfbvar:::compute_error_variances(Y) - priormu <- x$priormu - priorphiidi <- x$priorphiidi - priorphifac <- x$priorphifac - priorsigmaidi <- x$priorsigmaidi - priorsigmafac <- x$priorsigmafac - priorfacload <- x$priorfacload - priorng <- x$priorng - columnwise <- x$columnwise - restrict <- x$restrict - heteroskedastic <- x$heteroskedastic - priorhomoskedastic <- x$priorhomoskedastic - ### Regression parameters if (is.null(init$init_Pi)) { init_Pi <- matrix(0, nrow = n_vars, ncol = n_vars*(n_vars*n_lags + 1)) @@ -54,7 +114,7 @@ mcmc_sampler.mfbvar_minn_fsv <- function(x, ...){ ### Latent high-frequency if (is.null(init$init_Z)) { - init_Z <- y_in_p + init_Z <- mfbvar:::fill_na(Y) } else { init_Z <- init$init_Z } @@ -78,14 +138,14 @@ mcmc_sampler.mfbvar_minn_fsv <- function(x, ...){ ### Factors and loadings if (is.null(init$init_facload)) { - init_facload <- matrix(rnorm(n_vars*n_fac, sd = .5)^2, nrow=n_vars, ncol=n_fac) + init_facload <- matrix(rnorm(n_vars*n_fac, sd = 0.5)^2, nrow=n_vars, ncol=n_fac) } else { init_facload <- init$init_facload } - if (is.null(init$init_fac)) { - init_fac <- matrix(rnorm(n_fac*n_T_, sd = 0.005), n_fac, n_T_) + if (is.null(init$init_f)) { + init_f <- matrix(rnorm(n_fac*n_T_, sd = 0.5), n_fac, n_T_) } else { - init_fac <- init$init_fac + init_f <- init$init_f } ### Latent volatilities @@ -100,294 +160,212 @@ mcmc_sampler.mfbvar_minn_fsv <- function(x, ...){ init_latent0 <- init$init_latent0 } - cl <- x$cl - Z_1 <- mfbvar:::fill_na(Y)[(1:n_lags), ] - verbose <- x$verbose + ################################################################ + ### Preallocation + # Pi and Sigma store their i-th draws in the third dimension, psi + # is vectorized so it has its i-th draw stored in the i-th row + # Pi: p * pk * n_reps, each [,,i] stores Pi' + # Sigma: p * p * n_reps + # psi: n_reps * p + # Z: T * p * n_reps + ### If forecasting (h is horizon): + # Z_fcst: hk * p * n_reps + # d_fcst_lags: hk * m + ### If root checking: + # roots: n_reps vector + # num_tries: n_reps vector + ### If smoothing of the state vector: + # smoothed_Z: T * p * n_reps - ## Set up cluster (if used) - if (!is.null(cl)) { - parallelize <- TRUE - parallel::clusterCall(cl, fun = function() library(mfbvar)) - parallel::clusterExport(cl, varlist = c("par_fun")) + Pi <- array(init_Pi, dim = c(n_vars, n_vars*n_lags + 1, n_reps/n_thin)) + Z <- array(init_Z, dim = c(n_T, n_vars, n_reps/n_thin)) + Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) + if (n_fcst > 0) { + rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) + Z_fcst[,,1] <- 0 } else { - parallelize <- FALSE + rownames(Z_fcst) <- (n_T-n_lags+1):n_T } - prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(x$lambda1, x$lambda2, x$lambda3, x$prior_Pi_AR1, Y, n_lags) - prior_Pi_AR1 <- x$prior_Pi_AR1 - prior_zero_mean <- all(x$prior_Pi_AR1 == 0) + mu <- matrix(init_mu, n_vars, n_reps/n_thin) + sigma <- matrix(init_sigma, n_vars+n_fac, n_reps/n_thin) + phi <- matrix(init_phi, n_vars+n_fac, n_reps/n_thin) - if (prior_zero_mean) { - if (n_vars*n_lags > 1.05 * n_T_) { - par_fun <- mfbvar:::par_fun_top(mfbvar:::rmvn_bcm) - } else { - par_fun <- mfbvar:::par_fun_top(mfbvar:::rmvn_rue) - } - } + facload <- array(matrix(init_facload, nrow = n_vars, ncol = n_fac), + dim = c(n_vars, n_fac, n_reps/n_thin)) + f <- array(matrix(init_f, n_fac, n_T_), dim = c(n_fac, n_T_, n_reps/n_thin)) - ## Obtain the aggregation matrix for the quarterly only - if (mf) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5) - } - } + h <- array(t(init_latent), dim = c(n_T_, n_vars+n_fac, n_reps/n_thin), + dimnames = list(rownames(init_latent), colnames(init_latent), NULL)) + + ################################################################ + ### Compute terms which do not vary in the sampler + + Z_1 <- Z[1:n_pseudolags,, 1] + + aux <- matrix(0, 1, 1) + global <- c(0) + local <- matrix(0, 1, 1) + a <- -1 + slice <- c(0) + gig <- TRUE + + mfbvar:::mcmc_minn_fsv(Y[-(1:n_lags),],Pi,Z,Z_fcst,mu,phi,sigma,f,facload,h, + aux,global,local,slice,Lambda_,prior_Pi_Omega,prior_Pi_AR1, Z_1,bmu,Bmu, + a0idi,b0idi,a0fac,b0fac,Bsigma,B011inv,B022inv,priorh0, + armarestr,armatau2,n_fac,n_reps,n_burnin,n_q,T_b-n_lags,n_lags, + n_vars,n_T_,n_fcst,n_thin,verbose,a,gig) + + return_obj <- list(Pi = Pi, Z = Z, Z_fcst = NULL, mu = mu, phi = phi, + sigma = sigma, f = f, facload = facload, h = h, + Lambda_ = Lambda_, prior_Pi_Omega = prior_Pi_Omega, + prior_Pi_AR1 = prior_Pi_AR1, Y = Y, Z_1 = Z_1, bmu = bmu, + Bmu = Bmu, a0idi = a0idi, b0idi = b0idi, a0fac = a0fac, + b0fac = b0fac, Bsigma = Bsigma, B011inv = B011inv, + B022inv = B022inv, priorh0 = priorh0, armarestr = armarestr, + armatau2 = armatau2, n_fac = n_fac, n_reps = n_reps, + n_q = n_q, T_b_ = T_b-n_lags, n_lags = n_lags, + n_vars = n_vars, n_T_ = n_T_, n_fcst = n_fcst, + n_thin = n_thin, verbose = verbose, + init = list(init_Pi = Pi[,, n_reps/n_thin], + init_Z = Z[,, n_reps/n_thin], + init_mu = mu[, n_reps/n_thin], + init_phi = phi[, n_reps/n_thin], + init_sigma = sigma[, n_reps/n_thin], + init_facload = facload[,,n_reps/n_thin], + init_f = f[,,n_reps/n_thin], + init_h = h[,,n_reps/n_thin])) - Pi <- array(init_Pi, dim = c(n_vars, n_vars*n_lags + 1, n_reps/n_thin)) - Z <- array(init_Z, dim = c(n_T_, n_vars, n_reps/n_thin)) if (n_fcst > 0) { - Z_fcst <- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps), - dimnames = list(c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)), NULL, NULL)) + return_obj$Z_fcst <- Z_fcst } + return(return_obj) - mu_storage <- matrix(init_mu, n_vars, n_reps/n_thin) - sigma_storage <- matrix(init_sigma, n_vars+n_fac, n_reps/n_thin) - phi_storage <- matrix(init_phi, n_vars+n_fac, n_reps/n_thin) +} - facload_storage <- array(matrix(init_facload, nrow = n_vars, ncol = n_fac), dim = c(n_vars, n_fac, n_reps/n_thin)) - fac_storage <- array(matrix(init_fac, n_fac, n_T_), dim = c(n_fac, n_T_, n_reps/n_thin)) +#' @rdname mcmc_sampler +mcmc_sampler.mfbvar_dl_fsv <- function(x, ...){ + n_vars <- ncol(x$Y) + if (!(!is.null(x$Y) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { + test_all <- sapply(x, is.null) + test_sub <- test_all[c("Y", "n_lags", "n_burnin", "n_reps")] + stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) + } - latent <- array(init_latent, dim = c(n_T_, n_vars+n_fac, n_reps/n_thin), - dimnames = list(rownames(init_latent), colnames(init_latent), NULL)) + prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(x$lambda1, x$lambda2, x$lambda3, x$prior_Pi_AR1, x$Y, x$n_lags) + prior_Pi_AR1 <- x$prior_Pi_AR1 + prior_zero_mean <- all(x$prior_Pi_AR1 == 0) - Pi_i <- Pi[,,1] - Z_i <- init_Z - startpara <- list(mu = init_mu, - phi = init_phi, - sigma = init_sigma) - startlatent <- latent[,,1] - startlatent0 <- init_latent0 - startfacload <- matrix(init_facload, nrow = n_vars, ncol = n_fac) - startfac <- matrix(init_fac, n_fac, n_T_) - - if (verbose) { - pb <- progress_bar$new( - format = "[:bar] :percent eta: :eta", - clear = FALSE, total = n_reps, width = 60) - } - - if (!mf) { - X <- mfbvar:::create_X(rbind(Z_1, Z_i), n_lags) - } - - error <- NULL - for (i in 1:n_reps) { - ## Square root of idiosyncratic variances (in dense form) - Sig <- exp(0.5 * startlatent[, 1:n_vars]) - - ## Mixed-frequency block: sample latent monthly series - if (mf) { - Z_i <- tryCatch(mfbvar:::rsimsm_adaptive_univariate(y_in_p, Pi_i, Sig, Lambda_, Z_1, n_q, T_b, t(startfac) %*% t(startfacload)), error = function(cond) cond) - if (inherits(Z_i, "error")) { - warning("MCMC halted because of an error in the mixed-frequency step. See $error for more information.") - error <- list(error = Z_i, iter = i, block = "z") - break - } - Z_i <- rbind(Z_1, Z_i) - X <- mfbvar:::create_X(Z_i, n_lags) - Z_i <- Z_i[-(1:n_lags), ] - } + Y <- x$Y + freq <- x$freq + verbose <- x$verbose - ## Produce forecasts + n_vars <- ncol(Y) + n_lags <- x$n_lags + n_fac <- x$n_fac + n_fcst <- x$n_fcst + ## Priors - ## Storage - if (i %% n_thin == 0) { + priormu <- x$priormu + priorphiidi <- x$priorphiidi + priorphifac <- x$priorphifac + priorsigmaidi <- x$priorsigmaidi + priorsigmafac <- x$priorsigmafac + priorfacload <- x$priorfacload + restrict <- x$restrict - if (n_fcst > 0) { - mu <- c(startpara$mu, numeric(n_fac)) - phi <- startpara$phi - sigma <- startpara$sigma - volatility_pred <- startlatent[n_T_, ] + if (length(priorsigmaidi) == 1) { + priorsigmaidi <- rep(priorsigmaidi, n_vars) + } + if (length(priorsigmafac) == 1) { + priorsigmafac <- rep(priorsigmafac, n_fac) + } - Z_pred <- matrix(0, n_fcst+n_lags, n_vars) - Z_pred[1:n_lags, ] <- Z_i[(n_T_-n_lags+1):n_T_,] - for (j in 1:n_fcst) { - volatility_pred <- mu + phi * (volatility_pred - mu) + rnorm(n_vars+n_fac, sd = sigma) - error_pred <- rnorm(n_vars+n_fac, sd = exp(volatility_pred * 0.5)) - X_t <- mfbvar:::create_X_t(Z_pred[j:(n_lags+j-1), ]) - Z_pred[j+n_lags, ] <- Pi_i %*% X_t + startfacload %*% error_pred[(n_vars+1):(n_vars+n_fac)] + error_pred[1:n_vars] - } - Z_fcst[,,i/n_thin] <- Z_pred - } + bmu <- priormu[1] + Bmu <- priormu[2]^2 - Pi[,,i/n_thin] <- Pi_i - Z[,,i/n_thin] <- Z_i + Bsigma <- c(priorsigmaidi, priorsigmafac) - mu_storage[,i/n_thin] <- startpara$mu - sigma_storage[,i/n_thin] <- startpara$sigma - phi_storage[,i/n_thin] <- startpara$phi + B011inv <- 1/10^8 + B022inv <- 1/10^12 - fac_storage[,,i/n_thin] <- startfac - facload_storage[,,i/n_thin] <- startfacload + armatau2 <- matrix(priorfacload^2, n_vars, n_fac) # priorfacload is scalar, or matrix - latent[,,i/n_thin] <- startlatent - } + armarestr <- matrix(FALSE, nrow = n_vars, ncol = n_fac) + if (restrict == "upper") armarestr[upper.tri(armarestr)] <- TRUE + armarestr <- matrix(as.integer(!armarestr), nrow = nrow(armarestr), ncol = ncol(armarestr)) # restrinv - ## Stochastic volatility block: sample latent factors, latent volatilities and factor loadings - y_hat <- Z_i - X %*% t(Pi_i) - fsample <- tryCatch(factorstochvol::fsvsample(y_hat, factors = n_fac, draws = 1, burnin = 0, priorh0idi = "stationary", - priorh0fac = "stationary", thin = 1, keeptime = "all", - runningstore = 0, runningstorethin = 10, runningstoremoments = 1, - quiet = TRUE, interweaving = 4, signswitch = TRUE, - startpara = startpara, startlatent = startlatent, - startlatent0 = startlatent0, - startfacload = startfacload, startfac = startfac, priormu = priormu, - priorphiidi = priorphiidi, priorphifac = priorphifac, priorsigmaidi = priorsigmaidi, - priorsigmafac = priorsigmafac, priorfacload = priorfacload, priorng = priorng, - columnwise = columnwise, restrict = restrict, heteroskedastic = heteroskedastic, - priorhomoskedastic = priorhomoskedastic), error = function(cond) cond) - if (inherits(fsample, "error")) { - warning("MCMC halted because of an error in the factor stochastic volatility step. See $error for more information.") - error <- list(error = fsample, iter = i, block = "fsample") - break - } - startpara$mu <- fsample$para[1,1:n_vars,1] - startpara$phi <- fsample$para[2,,1] - startpara$sigma <- fsample$para[3,,1] - startlatent0 <- c(fsample$h0) - startlatent <- fsample$h[,,1] - startfacload <- matrix(fsample$facload[,,1], nrow = n_vars, ncol = n_fac) - startfac <- matrix(fsample$f[,,1], nrow = n_fac) - - ## Regression parameters block: sample Pi (possibly in parallel) - latent_nofac <- Z_i - t(startfac) %*% t(startfacload) - - if (!parallelize) { - if (prior_zero_mean) { - for (j in 1:n_vars) { - Pi_i[j,] <- tryCatch(mfbvar:::rmvn(X/exp(startlatent[,j]*0.5), prior_Pi_Omega[,j], latent_nofac[,j]/exp(startlatent[,j]*0.5)), error = function(cond) cond) - } - } else { - for (j in 1:n_vars) { - Pi_i[j,] <- tryCatch(mfbvar:::rmvn_ccm(X/exp(startlatent[,j]*0.5), prior_Pi_Omega[,j], latent_nofac[,j]/exp(startlatent[,j]*0.5), prior_Pi_AR1[j], j), error = function(cond) cond) - } - } - } else { - if (prior_zero_mean) { - Pi_i <- tryCatch(t(parallel::parSapply(cl, 1:n_vars, FUN = par_fun, XX = X, startlatent = startlatent, D = prior_Pi_Omega, latent_nofac = latent_nofac)), error = function(cond) cond) - } else { - Pi_i <- tryCatch(t(parallel::parSapply(cl, 1:n_vars, FUN = par_fun_AR1, XX = X, startlatent = startlatent, D = prior_Pi_Omega, latent_nofac = latent_nofac, prior_Pi_AR1 = prior_Pi_AR1)), error = function(cond) cond) - } - } - if (inherits(Pi_i, "error")) { - warning("MCMC halted because of an error in the regression parameters step. See $error for more information.") - error <- list(error = Pi_i, iter = i, block = "Pi_i") - break - } + a0idi <- priorphiidi[1] + b0idi <- priorphiidi[2] + a0fac <- priorphifac[1] + b0fac <- priorphifac[2] - if (verbose) { - pb$tick() - } - } + priorh0 <- rep(-1.0, n_vars + n_fac) - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Z = Z, Z_fcst = NULL, n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, - prior_Pi_Omega = prior_Pi_Omega, Y = Y, n_T = n_T, n_T_ = n_T_, n_reps = n_reps, - facload = facload_storage, latent = latent, mu = mu_storage, sigma = sigma_storage, phi = phi_storage, - init = list(init_Pi = Pi_i, init_Z = Z_i, init_mu = startpara$mu, - init_phi = startpara$phi, init_sigma = startpara$sigma, - init_facload = startfacload, - init_fac = startfac, - init_latent = startlatent, - init_latent0 = startlatent0), - error = error) - - if (n_fcst>0) { - return_obj$Z_fcst <- Z_fcst + ## DL + if (!("a" %in% names(x))) { + a <- 1 + } else { + a <- x$a } - return(return_obj) + gig <- ifelse(is.null(x$gig), TRUE, FALSE) -} + RcppParallel::setThreadOptions(numThreads = x$n_cores) + cat("Number of cores: %s\n", Sys.getenv("RCPP_PARALLEL_NUM_THREADS")) + ## Initials -#' @rdname mcmc_sampler -mcmc_sampler.mfbvar_ss_fsv <- function(x, ...){ + add_args <- list(...) + n_reps <- x$n_reps + n_burnin <- x$n_burnin + n_thin <- ifelse(is.null(x$n_thin), 1, x$n_thin) - if (is.null(x$n_fac)) { - stop("The number of factors (n_fac) must be provided.") - } + # n_vars: number of variables + # n_lags: number of lags + # n_determ: number of deterministic variables + # n_T: sample size (full sample) + # n_T_: sample size (reduced sample) - if (x$n_fcst > 0 && nrow(x$d_fcst) != x$n_fcst) { - stop("d_fcst has ", nrow(x$d_fcst), " rows, but n_fcst is ", x$n_fcst, ".") + n_q <- sum(freq == "q") + if (n_q < n_vars) { + T_b <- max(which(!apply(apply(Y[, freq == "m", drop = FALSE], 2, is.na), 1, any))) + } else { + T_b <- nrow(Y) } - - Y <- x$Y - d <- x$d - d_fcst <- x$d_fcst - n_vars <- ncol(Y) - n_lags <- x$n_lags - n_q <- sum(x$freq == "q") - n_m <- n_vars - n_q - n_fac <- x$n_fac - n_fcst <- x$n_fcst - n_determ <- dim(d)[2] - mf <- TRUE if (n_q == 0 || n_q == n_vars) { complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) Y <- Y[complete_quarters, ] - d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) - d <- d[complete_quarters, , drop = FALSE] - mf <- FALSE } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) + if (n_q > 0) { + if (x$aggregation == "average") { + Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) + } else { + Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} } else { - T_b <- nrow(y_in_p) + Lambda_ <- matrix(0, 1, 3) } - n_T_ <- nrow(Y) - n_lags - n_T <- nrow(Y) - - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(!is.null(add_args$n_thin), add_args$n_thin, ifelse(!is.null(x$n_thin), x$n_thin, 1)) - prior_psi_mean <- x$prior_psi_mean - prior_psi_Omega <- x$prior_psi_Omega - check_roots <- x$check_roots - if (check_roots == TRUE) { - roots <- vector("numeric", n_reps) - num_tries <- roots - } else { - num_tries <- NULL - } + n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) + n_T <- dim(Y)[1]# - n_lags + n_T_ <- n_T - n_pseudolags + ## Initials init <- add_args$init + y_in_p <- Y[-(1:n_lags), ] error_variance <- mfbvar:::compute_error_variances(Y) - priormu <- x$priormu - priorphiidi <- x$priorphiidi - priorphifac <- x$priorphifac - priorsigmaidi <- x$priorsigmaidi - priorsigmafac <- x$priorsigmafac - priorfacload <- x$priorfacload - priorng <- x$priorng - columnwise <- x$columnwise - restrict <- x$restrict - heteroskedastic <- x$heteroskedastic - priorhomoskedastic <- x$priorhomoskedastic - ### Regression parameters if (is.null(init$init_Pi)) { - init_Pi <- matrix(0, nrow = n_vars, ncol = n_vars*n_lags) + init_Pi <- matrix(0, nrow = n_vars, ncol = n_vars*(n_vars*n_lags + 1)) } else { init_Pi <- init$init_Pi } - - ### Regression parameters - if (is.null(init$init_psi)) { - init_psi <- colMeans(y_in_p, na.rm = TRUE) - } else { - init_psi <- init$init_psi - } ### Latent high-frequency if (is.null(init$init_Z)) { - init_Z <- y_in_p + init_Z <- mfbvar:::fill_na(Y) } else { init_Z <- init$init_Z } @@ -399,31 +377,31 @@ mcmc_sampler.mfbvar_ss_fsv <- function(x, ...){ init_mu <- init$init_mu } if (is.null(init$init_sigma)) { - init_sigma <- rep(0.2, n_vars + n_fac) + init_sigma <- rep(0.75, n_vars + n_fac) } else { init_sigma <- init$init_sigma } if (is.null(init$init_phi)) { - init_phi <- rep(0.75, n_vars + n_fac) + init_phi <- rep(0.2, n_vars + n_fac) } else { init_phi <- init$init_phi } ### Factors and loadings if (is.null(init$init_facload)) { - init_facload <- matrix(rnorm(n_vars*n_fac, sd = .5)^2, nrow=n_vars, ncol=n_fac) + init_facload <- matrix(rnorm(n_vars*n_fac, sd = 0.5)^2, nrow=n_vars, ncol=n_fac) } else { init_facload <- init$init_facload } - if (is.null(init$init_fac)) { - init_fac <- matrix(rnorm(n_fac*n_T_, sd = 0.005), n_fac, n_T_) + if (is.null(init$init_f)) { + init_f <- matrix(rnorm(n_fac*n_T_, sd = 0.5), n_fac, n_T_) } else { - init_fac <- init$init_fac + init_f <- init$init_f } ### Latent volatilities if (is.null(init$init_latent)) { - init_latent <- cbind(matrix(c(log(error_variance), rep(1, n_fac)), nrow = n_T_, ncol = n_vars+n_fac, byrow = TRUE)) + init_latent <- t(cbind(matrix(c(log(error_variance), rep(1, n_fac)), nrow = n_T_, ncol = n_vars+n_fac, byrow = TRUE))) } else { init_latent <- init$init_latent } @@ -433,375 +411,230 @@ mcmc_sampler.mfbvar_ss_fsv <- function(x, ...){ init_latent0 <- init$init_latent0 } - cl <- x$cl - Z_1 <- mfbvar:::fill_na(Y)[(1:n_lags), ] - verbose <- x$verbose - - ## Set up cluster (if used) - if (!is.null(cl)) { - parallelize <- TRUE - parallel::clusterCall(cl, fun = function() library(mfbvar)) - parallel::clusterExport(cl, varlist = c("par_fun")) + if (is.null(init$init_global)) { + init_global <- 0.1 } else { - parallelize <- FALSE + init_global <- init$init_global } - prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(x$lambda1, x$lambda2, x$lambda3, x$prior_Pi_AR1, Y, n_lags)[-1, ] - prior_Pi_AR1 <- x$prior_Pi_AR1 - prior_zero_mean <- all(x$prior_Pi_AR1 == 0) - - if (prior_zero_mean) { - if (n_vars*n_lags > 1.05 * n_T_) { - par_fun <- mfbvar:::par_fun_top(rmvn_bcm) - } else { - par_fun <- mfbvar:::par_fun_top(rmvn_rue) - } + if (is.null(init$init_aux)) { + init_aux <- c(sqrt(prior_Pi_Omega[-1,])/init_global) + } else { + init_aux <- init$init_aux } - ## Obtain the aggregation matrix for the quarterly only - if (mf) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5) - } + if (is.null(init$init_local)) { + init_local <- c(sqrt(prior_Pi_Omega[-1,])/init_global) + } else { + init_local <- init$init_local } - Pi <- array(init_Pi, dim = c(n_vars, n_vars*n_lags, n_reps/n_thin)) - Z <- array(init_Z, dim = c(n_T_, n_vars, n_reps/n_thin)) - psi <- matrix(init_psi, n_reps, n_vars * n_determ, byrow = TRUE) - if (n_fcst > 0) { - Z_fcst <- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps), - dimnames = list(c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)), NULL, NULL)) + if (is.null(init$init_slice)) { + init_slice <- rep(1, n_vars^2*n_lags) + } else { + init_slice <- init$init_slice } - d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) - d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] - mu_storage <- matrix(init_mu, n_vars, n_reps/n_thin) - sigma_storage <- matrix(init_sigma, n_vars+n_fac, n_reps/n_thin) - phi_storage <- matrix(init_phi, n_vars+n_fac, n_reps/n_thin) - - facload_storage <- array(matrix(init_facload, nrow = n_vars, ncol = n_fac), dim = c(n_vars, n_fac, n_reps/n_thin)) - fac_storage <- array(matrix(init_fac, n_fac, n_T_), dim = c(n_fac, n_T_, n_reps/n_thin)) - - latent <- array(init_latent, dim = c(n_T_, n_vars+n_fac, n_reps/n_thin), - dimnames = list(rownames(init_latent), colnames(init_latent), NULL)) - - Pi_i <- init_Pi - Pi_i0 <- cbind(0, Pi_i) - Z_i <- init_Z - psi_i <- init_psi - startpara <- list(mu = init_mu, - phi = init_phi, - sigma = init_sigma) - startlatent <- latent[,,1] - startlatent0 <- init_latent0 - startfacload <- matrix(init_facload, nrow = n_vars, ncol = n_fac) - startfac <- matrix(init_fac, n_fac, n_T_) - - D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) - dt <- d[-(1:n_lags), , drop = FALSE] - d1 <- d[1:n_lags, , drop = FALSE] - mu_mat <- dt %*% t(matrix(psi_i, nrow = n_vars)) - n_Lambda <- ncol(Lambda_)/nrow(Lambda_) - mu_long <- matrix(0, n_Lambda+n_T_, n_vars) - if (mf) { - Lambda_single <- matrix(0, 1, n_Lambda) - for (i in 1:n_Lambda) { - Lambda_single[i] <- Lambda_[1, (i-1)*n_q+1] - } - } - my <- matrix(0, nrow(y_in_p), ncol(y_in_p)) + ################################################################ + ### Preallocation + # Pi and Sigma store their i-th draws in the third dimension, psi + # is vectorized so it has its i-th draw stored in the i-th row + # Pi: p * pk * n_reps, each [,,i] stores Pi' + # Sigma: p * p * n_reps + # psi: n_reps * p + # Z: T * p * n_reps + ### If forecasting (h is horizon): + # Z_fcst: hk * p * n_reps + # d_fcst_lags: hk * m + ### If root checking: + # roots: n_reps vector + # num_tries: n_reps vector + ### If smoothing of the state vector: + # smoothed_Z: T * p * n_reps - if (verbose) { - pb <- progress_bar$new( - format = "[:bar] :percent eta: :eta", - clear = FALSE, total = n_reps, width = 60) + Pi <- array(init_Pi, dim = c(n_vars, n_vars*n_lags + 1, n_reps/n_thin)) + Z <- array(init_Z, dim = c(n_T, n_vars, n_reps/n_thin)) + Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) + if (n_fcst > 0) { + rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) + Z_fcst[,,1] <- 0 + } else { + rownames(Z_fcst) <- (n_T-n_lags+1):n_T } - error <- NULL + mu <- matrix(init_mu, n_vars, n_reps/n_thin) + sigma <- matrix(init_sigma, n_vars+n_fac, n_reps/n_thin) + phi <- matrix(init_phi, n_vars+n_fac, n_reps/n_thin) - inv_prior_psi_Omega <- solve(prior_psi_Omega) - inv_prior_psi_Omega_mean <- inv_prior_psi_Omega %*% prior_psi_mean - for (i in 1:n_reps) { - ## Square root of idiosyncratic variances (in dense form) - Sig <- exp(0.5 * startlatent[, 1:n_vars]) + facload <- array(matrix(init_facload, nrow = n_vars, ncol = n_fac), + dim = c(n_vars, n_fac, n_reps/n_thin)) + f <- array(matrix(init_f, n_fac, n_T_), dim = c(n_fac, n_T_, n_reps/n_thin)) + h <- array(t(init_latent), dim = c(n_T_, n_vars+n_fac, n_reps/n_thin), + dimnames = list(rownames(init_latent), colnames(init_latent), NULL)) + aux <- matrix(init_aux, nrow = n_reps/n_thin, ncol = n_vars*n_vars*n_lags, byrow = TRUE) + local <- matrix(init_local, nrow = n_reps/n_thin, ncol = n_vars*n_vars*n_lags, byrow = TRUE) + global <- matrix(init_global, n_reps/n_thin, ncol = 1) + slice <- matrix(init_slice, nrow = 1, ncol = n_vars*n_vars*n_lags) - ## Mixed-frequency block: sample latent monthly series - if (mf) { - mfbvar:::update_demean(my, mu_long, y_in_p, mu_mat, d1, matrix(psi_i, nrow = n_vars), Lambda_single, n_vars, - n_q, n_Lambda, n_T_) - } else { - mZ <- y_in_p - mu_mat - } - - mZ1 <- Z_1 - d1 %*% t(matrix(psi_i, nrow = n_vars)) - Pi_i0[, -1] <- Pi_i + ################################################################ + ### Compute terms which do not vary in the sampler + + Z_1 <- Z[1:n_pseudolags,, 1] + mfbvar:::mcmc_minn_fsv(Y[-(1:n_lags),],Pi,Z,Z_fcst,mu,phi,sigma,f,facload,h, + aux,global,local,slice,Lambda_,prior_Pi_Omega,prior_Pi_AR1, Z_1,bmu,Bmu, + a0idi,b0idi,a0fac,b0fac,Bsigma,B011inv,B022inv,priorh0, + armarestr,armatau2,n_fac,n_reps,n_burnin,n_q,T_b-n_lags,n_lags, + n_vars,n_T_,n_fcst,n_thin,verbose,a,gig) + + return_obj <- list(Pi = Pi, Z = Z, Z_fcst = NULL, mu = mu, phi = phi, + sigma = sigma, f = f, facload = facload, h = h, + aux = aux, local = local, global = global, + Lambda_ = Lambda_, prior_Pi_Omega = prior_Pi_Omega, + prior_Pi_AR1 = prior_Pi_AR1, Y = Y, Z_1 = Z_1, bmu = bmu, + Bmu = Bmu, a0idi = a0idi, b0idi = b0idi, a0fac = a0fac, + b0fac = b0fac, Bsigma = Bsigma, B011inv = B011inv, + B022inv = B022inv, priorh0 = priorh0, armarestr = armarestr, + armatau2 = armatau2, n_fac = n_fac, n_reps = n_reps, + n_q = n_q, T_b_ = T_b-n_lags, n_lags = n_lags, + n_vars = n_vars, n_T_ = n_T_, n_fcst = n_fcst, + n_thin = n_thin, verbose = verbose) - if (mf){ - mZ <- tryCatch(mfbvar:::rsimsm_adaptive_univariate(my, Pi_i0, Sig, Lambda_, mZ1, n_q, T_b, t(startfac) %*% t(startfacload)), error = function(cond) cond) - if (inherits(Z_i, "error")) { - warning("MCMC halted because of an error in the mixed-frequency step. See $error for more information.") - error <- list(error = Z_i_demean, iter = i, block = "z") - break - } - } - Z_i_demean <- mZ - Z_i <- Z_i_demean + mu_mat - X <- mfbvar:::create_X_noint(rbind(Z_1, Z_i), n_lags) - X_demean <- mfbvar:::create_X_noint(rbind(mZ1, Z_i_demean), n_lags) + if (n_fcst > 0) { + return_obj$Z_fcst <- Z_fcst + } + return(return_obj) +} - ## Produce forecasts +mcmc_sampler.mfbvar_ss_fsv <- function(x, ...){ + n_vars <- ncol(x$Y) + if (!(!is.null(x$Y) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { + test_all <- sapply(x, is.null) + test_sub <- test_all[c("Y", "n_lags", "n_burnin", "n_reps")] + stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) + } + prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(x$lambda1, x$lambda2, x$lambda3, x$prior_Pi_AR1, x$Y, x$n_lags) + prior_Pi_AR1 <- x$prior_Pi_AR1 + prior_zero_mean <- all(x$prior_Pi_AR1 == 0) - ## Storage - if (i %% n_thin == 0) { + Y <- x$Y + freq <- x$freq + verbose <- x$verbose - if (n_fcst > 0) { - mu <- c(startpara$mu, numeric(n_fac)) - phi <- startpara$phi - sigma <- startpara$sigma - volatility_pred <- startlatent[n_T_, ] + prior_psi_mean <- x$prior_psi_mean + prior_psi_Omega <- x$prior_psi_Omega + d <- x$d + d_fcst <- x$d_fcst + check_roots <- x$check_roots + n_determ <- dim(d)[2] - Z_pred <- matrix(0, n_fcst+n_lags, n_vars) - Z_pred[1:n_lags, ] <- Z_i_demean[(n_T_-n_lags+1):n_T_,] - for (j in 1:n_fcst) { - volatility_pred <- mu + phi * (volatility_pred - mu) + rnorm(n_vars+n_fac, sd = sigma) - error_pred <- rnorm(n_vars+n_fac, sd = exp(volatility_pred * 0.5)) - X_t <- mfbvar:::create_X_t_noint(Z_pred[j:(n_lags+j-1), ]) - Z_pred[j+n_lags, ] <- Pi_i %*% X_t + startfacload %*% error_pred[(n_vars+1):(n_vars+n_fac)] + error_pred[1:n_vars] - } - Z_fcst[,,i/n_thin] <- Z_pred + d_fcst_lags %*% t(matrix(psi_i, nrow = n_vars)) - } + n_vars <- ncol(Y) + n_lags <- x$n_lags + n_fac <- x$n_fac + n_fcst <- x$n_fcst - Pi[,,i/n_thin] <- Pi_i - Z[,,i/n_thin] <- Z_i - psi[i/n_thin, ] <- psi_i + ## Priors - mu_storage[,i/n_thin] <- startpara$mu - sigma_storage[,i/n_thin] <- startpara$sigma - phi_storage[,i/n_thin] <- startpara$phi + priormu <- x$priormu + priorphiidi <- x$priorphiidi + priorphifac <- x$priorphifac + priorsigmaidi <- x$priorsigmaidi + priorsigmafac <- x$priorsigmafac + priorfacload <- x$priorfacload + restrict <- x$restrict - fac_storage[,,i/n_thin] <- startfac - facload_storage[,,i/n_thin] <- startfacload + if (length(priorsigmaidi) == 1) { + priorsigmaidi <- rep(priorsigmaidi, n_vars) + } + if (length(priorsigmafac) == 1) { + priorsigmafac <- rep(priorsigmafac, n_fac) + } - latent[,,i/n_thin] <- startlatent - } + bmu <- priormu[1] + Bmu <- priormu[2]^2 - ## Stochastic volatility block: sample latent factors, latent volatilities and factor loadings - y_hat <- Z_i_demean - X_demean %*% t(Pi_i) - fsample <- tryCatch(factorstochvol::fsvsample(y_hat, factors = n_fac, draws = 1, burnin = 0, priorh0idi = "stationary", - priorh0fac = "stationary", thin = 1, keeptime = "all", - runningstore = 0, runningstorethin = 10, runningstoremoments = 1, - quiet = TRUE, interweaving = 4, signswitch = TRUE, - startpara = startpara, startlatent = startlatent, - startlatent0 = startlatent0, - startfacload = startfacload, startfac = startfac, priormu = priormu, - priorphiidi = priorphiidi, priorphifac = priorphifac, priorsigmaidi = priorsigmaidi, - priorsigmafac = priorsigmafac, priorfacload = priorfacload, priorng = priorng, - columnwise = columnwise, restrict = restrict, heteroskedastic = heteroskedastic, - priorhomoskedastic = priorhomoskedastic), error = function(cond) cond) - if (inherits(fsample, "error")) { - warning("MCMC halted because of an error in the factor stochastic volatility step. See $error for more information.") - error <- list(error = fsample, iter = i, block = "fsample") - break - } - startpara$mu <- fsample$para[1,1:n_vars,1] - startpara$phi <- fsample$para[2,,1] - startpara$sigma <- fsample$para[3,,1] - startlatent0 <- c(fsample$h0) - startlatent <- fsample$h[,,1] - startfacload <- matrix(fsample$facload[,,1], nrow = n_vars, ncol = n_fac) - startfac <- matrix(fsample$f[,,1], nrow = n_fac) - - ## Regression parameters block: sample Pi (possibly in parallel) - latent_nofac <- Z_i_demean - t(startfac) %*% t(startfacload) - - stationarity_check <- FALSE - iter <- 0 - while(stationarity_check == FALSE) { - iter <- iter + 1 - - if (!parallelize) { - if (prior_zero_mean) { - for (j in 1:n_vars) { - Pi_i[j,] <- tryCatch(mfbvar:::rmvn(X_demean/exp(startlatent[,j]*0.5), prior_Pi_Omega[,j], latent_nofac[,j]/exp(startlatent[,j]*0.5)), error = function(cond) cond) - } - } else { - for (j in 1:n_vars) { - Pi_i[j,] <- tryCatch(mfbvar:::rmvn_ccm(X_demean/exp(startlatent[,j]*0.5), prior_Pi_Omega[,j], latent_nofac[,j]/exp(startlatent[,j]*0.5), prior_Pi_AR1[j], j), error = function(cond) cond) - } - } - } else { - if (prior_zero_mean) { - Pi_i <- tryCatch(t(parallel::parSapply(cl, 1:n_vars, FUN = par_fun, XX = X_demean, startlatent = startlatent, D = prior_Pi_Omega, latent_nofac = latent_nofac)), error = function(cond) cond) - } else { - Pi_i <- tryCatch(t(parallel::parSapply(cl, 1:n_vars, FUN = par_fun_AR1, XX = X_demean, startlatent = startlatent, D = prior_Pi_Omega, latent_nofac = latent_nofac, prior_Pi_AR1 = prior_Pi_AR1)), error = function(cond) cond) - } - } - - if (inherits(Pi_i, "error")) { - warning("MCMC halted because of an error in the regression parameters step. See $error for more information.") - error <- list(error = Pi_i, iter = i, block = "Pi_i") - break - } - - Pi_comp <- mfbvar:::build_companion(Pi_i, n_vars = n_vars, n_lags = n_lags) - if (check_roots == TRUE) { - root <- mfbvar:::max_eig_cpp(Pi_comp) - } else { - root <- 0 - } - if (root < 1) { - stationarity_check <- TRUE - if (check_roots == TRUE) { - num_tries[i] <- iter - } - } - if (iter == 1000) { - warning("Attempted to draw stationary Pi 1,000 times.") - error <- list(error = Pi_i, iter = i, block = "Pi_i") - if (check_roots == TRUE) { - num_tries[i] <- iter - } - break - } + Bsigma <- c(priorsigmaidi, priorsigmafac) - } + B011inv <- 1/10^8 + B022inv <- 1/10^12 - Pi_i0[, -1] <- Pi_i - idivar <- exp(startlatent[, 1:n_vars]) - mfbvar:::posterior_psi_fsv(psi_i, mu_mat, Pi_i, D_mat, idivar, inv_prior_psi_Omega, - Z_i, X, startfacload, startfac, inv_prior_psi_Omega_mean, dt, - n_determ, n_vars, n_lags) + armatau2 <- matrix(priorfacload^2, n_vars, n_fac) # priorfacload is scalar, or matrix - if (verbose) { - pb$tick() - } - } + armarestr <- matrix(FALSE, nrow = n_vars, ncol = n_fac) + if (restrict == "upper") armarestr[upper.tri(armarestr)] <- TRUE + armarestr <- matrix(as.integer(!armarestr), nrow = nrow(armarestr), ncol = ncol(armarestr)) # restrinv - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Z = Z, psi = psi, Z_fcst = NULL, n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, - prior_Pi_Omega = prior_Pi_Omega, d = d, Y = Y, n_T = n_T, n_T_ = n_T_, n_reps = n_reps, - n_determ = n_determ, facload = facload_storage, latent = latent, mu = mu_storage, sigma = sigma_storage, phi = phi_storage, - init = list(init_Pi = Pi_i, init_Z = Z_i, init_psi = psi_i, init_mu = startpara$mu, - init_phi = startpara$phi, init_sigma = startpara$sigma, - init_facload = startfacload, - init_fac = startfac, - init_latent = startlatent, - init_latent0 = startlatent0), - num_tries = num_tries, - error = error) - - if (n_fcst>0) { - return_obj$Z_fcst <- Z_fcst - } + a0idi <- priorphiidi[1] + b0idi <- priorphiidi[2] + a0fac <- priorphifac[1] + b0fac <- priorphifac[2] - return(return_obj) + priorh0 <- rep(-1.0, n_vars + n_fac) -} + ## Initials -mcmc_sampler.mfbvar_ssng_fsv <- function(x, ...){ + add_args <- list(...) + n_reps <- add_args$n_reps + n_thin <- ifelse(!is.null(add_args$n_thin), add_args$n_thin, ifelse(!is.null(x$n_thin), x$n_thin, 1)) - if (is.null(x$n_fac)) { - stop("The number of factors (n_fac) must be provided.") - } + # n_vars: number of variables + # n_lags: number of lags + # n_determ: number of deterministic variables + # n_T: sample size (full sample) + # n_T_: sample size (reduced sample) - if (x$n_fcst > 0 && nrow(x$d_fcst) != x$n_fcst) { - stop("d_fcst has ", nrow(x$d_fcst), " rows, but n_fcst is ", x$n_fcst, ".") + n_q <- sum(freq == "q") + if (n_q < n_vars) { + T_b <- max(which(!apply(apply(Y[, freq == "m", drop = FALSE], 2, is.na), 1, any))) + } else { + T_b <- nrow(Y) } - - Y <- x$Y - d <- x$d - d_fcst <- x$d_fcst - n_vars <- ncol(Y) - n_lags <- x$n_lags - n_q <- sum(x$freq == "q") - n_m <- n_vars - n_q - n_fac <- x$n_fac - n_fcst <- x$n_fcst - n_determ <- dim(d)[2] - mf <- TRUE if (n_q == 0 || n_q == n_vars) { complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) Y <- Y[complete_quarters, ] d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) d <- d[complete_quarters, , drop = FALSE] - mf <- FALSE } - y_in_p <- Y[-(1:n_lags), ] - if (n_q < n_vars) { - T_b <- min(apply(y_in_p[,1:n_m], 2, function(x) ifelse(any(is.na(x)), min(which(is.na(x))), Inf))-1, nrow(y_in_p)) + if (n_q > 0) { + if (x$aggregation == "average") { + Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) + } else { + Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} } else { - T_b <- nrow(y_in_p) + Lambda_ <- matrix(0, 1, 3) } - n_T_ <- nrow(Y) - n_lags - n_T <- nrow(Y) - add_args <- list(...) - n_reps <- add_args$n_reps - n_thin <- ifelse(!is.null(add_args$n_thin), add_args$n_thin, ifelse(!is.null(x$n_thin), x$n_thin, 1)) - prior_psi_mean <- x$prior_psi_mean - prior_psi_Omega <- x$prior_psi_Omega - check_roots <- x$check_roots - if (check_roots == TRUE) { - roots <- vector("numeric", n_reps) - num_tries <- roots - } else { - num_tries <- NULL - } - c0 <- ifelse(is.null(x$c0), 0.01, x$c0) - c1 <- ifelse(is.null(x$c1), 0.01, x$c1) - s <- ifelse(is.null(x[["s"]]), -10, x$s) - batch <- 0 - accept_vec <- numeric(n_reps) - accept <- 0 - adaptive_mh <- FALSE - if (s < 0) { - M <- abs(s) - s <- 1.0 - adaptive_mh <- TRUE - } - min_vec <- c(0.01, 0) + n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) + n_T <- dim(Y)[1]# - n_lags + n_T_ <- n_T - n_pseudolags + ## Initials init <- add_args$init + y_in_p <- Y[-(1:n_lags), ] error_variance <- mfbvar:::compute_error_variances(Y) - priormu <- x$priormu - priorphiidi <- x$priorphiidi - priorphifac <- x$priorphifac - priorsigmaidi <- x$priorsigmaidi - priorsigmafac <- x$priorsigmafac - priorfacload <- x$priorfacload - priorng <- x$priorng - columnwise <- x$columnwise - restrict <- x$restrict - heteroskedastic <- x$heteroskedastic - priorhomoskedastic <- x$priorhomoskedastic - ### Regression parameters if (is.null(init$init_Pi)) { - init_Pi <- matrix(0, nrow = n_vars, ncol = n_vars*n_lags) + init_Pi <- matrix(0, nrow = n_vars, ncol = n_vars*(n_vars*n_lags + 1)) } else { init_Pi <- init$init_Pi } - - ### Regression parameters - if (is.null(init$init_psi)) { - init_psi <- colMeans(y_in_p, na.rm = TRUE) + ### Steady-states + if (is.null(init$init_Z)) { + init_Z <- mfbvar:::fill_na(Y) } else { - init_psi <- init$init_psi + init_Z <- init$init_Z } + ### Latent high-frequency - if (is.null(init$init_Z)) { - init_Z <- y_in_p + if (is.null(init$init_psi)) { + init_psi <- prior_psi_mean } else { - init_Z <- init$init_Z + init_psi <- init$init_psi } ### SV regressions @@ -811,31 +644,31 @@ mcmc_sampler.mfbvar_ssng_fsv <- function(x, ...){ init_mu <- init$init_mu } if (is.null(init$init_sigma)) { - init_sigma <- rep(0.2, n_vars + n_fac) + init_sigma <- rep(0.75, n_vars + n_fac) } else { init_sigma <- init$init_sigma } if (is.null(init$init_phi)) { - init_phi <- rep(0.75, n_vars + n_fac) + init_phi <- rep(0.2, n_vars + n_fac) } else { init_phi <- init$init_phi } ### Factors and loadings if (is.null(init$init_facload)) { - init_facload <- matrix(rnorm(n_vars*n_fac, sd = .5)^2, nrow=n_vars, ncol=n_fac) + init_facload <- matrix(rnorm(n_vars*n_fac, sd = 0.5)^2, nrow=n_vars, ncol=n_fac) } else { init_facload <- init$init_facload } - if (is.null(init$init_fac)) { - init_fac <- matrix(rnorm(n_fac*n_T_, sd = 0.005), n_fac, n_T_) + if (is.null(init$init_f)) { + init_f <- matrix(rnorm(n_fac*n_T_, sd = 0.5), n_fac, n_T_) } else { - init_fac <- init$init_fac + init_f <- init$init_f } ### Latent volatilities if (is.null(init$init_latent)) { - init_latent <- cbind(matrix(c(log(error_variance), rep(1, n_fac)), nrow = n_T_, ncol = n_vars+n_fac, byrow = TRUE)) + init_latent <- t(cbind(matrix(c(log(error_variance), rep(1, n_fac)), nrow = n_T_, ncol = n_vars+n_fac, byrow = TRUE))) } else { init_latent <- init$init_latent } @@ -845,9 +678,237 @@ mcmc_sampler.mfbvar_ssng_fsv <- function(x, ...){ init_latent0 <- init$init_latent0 } + ################################################################ + ### Preallocation + # Pi and Sigma store their i-th draws in the third dimension, psi + # is vectorized so it has its i-th draw stored in the i-th row + # Pi: p * pk * n_reps, each [,,i] stores Pi' + # Sigma: p * p * n_reps + # psi: n_reps * p + # Z: T * p * n_reps + ### If forecasting (h is horizon): + # Z_fcst: hk * p * n_reps + # d_fcst_lags: hk * m + ### If root checking: + # roots: n_reps vector + # num_tries: n_reps vector + ### If smoothing of the state vector: + # smoothed_Z: T * p * n_reps + + Pi <- array(init_Pi, dim = c(n_vars, n_vars*n_lags + 1, n_reps/n_thin)) + psi <- array(init_psi, dim = c(n_reps/n_thin, n_vars * n_determ)) + Z <- array(init_Z, dim = c(n_T, n_vars, n_reps/n_thin)) + Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) + if (n_fcst > 0) { + rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) + Z_fcst[,,1] <- 0 + } else { + rownames(Z_fcst) <- (n_T-n_lags+1):n_T + } + d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) + d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] + roots <- vector("numeric", n_reps/n_thin) + num_tries <- roots + + mu <- matrix(init_mu, n_vars, n_reps/n_thin) + sigma <- matrix(init_sigma, n_vars+n_fac, n_reps/n_thin) + phi <- matrix(init_phi, n_vars+n_fac, n_reps/n_thin) + + facload <- array(matrix(init_facload, nrow = n_vars, ncol = n_fac), + dim = c(n_vars, n_fac, n_reps/n_thin)) + f <- array(matrix(init_f, n_fac, n_T_), dim = c(n_fac, n_T_, n_reps/n_thin)) + + h <- array(t(init_latent), dim = c(n_T_, n_vars+n_fac, n_reps/n_thin), + dimnames = list(rownames(init_latent), colnames(init_latent), NULL)) + + ################################################################ + ### Compute terms which do not vary in the sampler + + Z_1 <- Z[1:n_pseudolags,, 1] + D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) + dt <- d[-(1:n_lags), , drop = FALSE] + d1 <- d[1:n_lags, , drop = FALSE] + + phi_mu <- matrix(0, 1, 1) + lambda_mu <- matrix(0, 1, 1) + omega <- matrix(diag(prior_psi_Omega), nrow = 1) + c0 <- 0 + c1 <- 0 + s <- 0 + + mfbvar:::mcmc_ss_fsv(Y[-(1:n_lags),],Pi,psi,phi_mu,lambda_mu,omega,Z,Z_fcst, + mu,phi,sigma,f,facload,h, + Lambda_,prior_Pi_Omega,prior_Pi_AR1,D_mat,dt,d1, + d_fcst_lags,prior_psi_mean,c0,c1,s,check_roots,Z_1,bmu,Bmu, + a0idi,b0idi,a0fac,b0fac,Bsigma,B011inv,B022inv,priorh0, + armarestr,armatau2,n_fac,n_reps,n_q,T_b-n_lags,n_lags, + n_vars,n_T_,n_fcst,n_determ,n_thin,verbose,FALSE) + + return_obj <- list(Pi = Pi, psi = psi, Z = Z, Z_fcst = NULL, mu = mu, phi = phi, + sigma = sigma, f = f, facload = facload, h = h, + Lambda_ = Lambda_, prior_Pi_Omega = prior_Pi_Omega, + prior_Pi_AR1 = prior_Pi_AR1, prior_psi_mean = prior_psi_mean, + prior_psi_Omega = diag(omega[1, ]), Y = Y, Z_1 = Z_1, bmu = bmu, + Bmu = Bmu, a0idi = a0idi, b0idi = b0idi, a0fac = a0fac, + b0fac = b0fac, Bsigma = Bsigma, B011inv = B011inv, + B022inv = B022inv, priorh0 = priorh0, armarestr = armarestr, + armatau2 = armatau2, n_fac = n_fac, n_reps = n_reps, + n_q = n_q, T_b_ = T_b-n_lags, n_lags = n_lags, + n_vars = n_vars, n_T_ = n_T_, n_fcst = n_fcst, n_determ = n_determ, + n_thin = n_thin, verbose = verbose, + init = list(init_Pi = Pi[,, n_reps/n_thin], + init_psi = psi[n_reps/n_thin, ], + init_Z = Z[,, n_reps/n_thin], + init_mu = mu[, n_reps/n_thin], + init_phi = phi[, n_reps/n_thin], + init_sigma = sigma[, n_reps/n_thin], + init_facload = facload[,,n_reps/n_thin], + init_f = f[,,n_reps/n_thin], + init_h = h[,,n_reps/n_thin])) + + if (n_fcst > 0) { + return_obj$Z_fcst <- Z_fcst + } + return(return_obj) + +} + +mcmc_sampler.mfbvar_ssng_fsv <- function(x, ...){ + n_vars <- ncol(x$Y) + if (!(!is.null(x$Y) && !is.null(x$n_lags) && !is.null(x$n_burnin) && !is.null(x$n_reps))) { + test_all <- sapply(x, is.null) + test_sub <- test_all[c("Y", "n_lags", "n_burnin", "n_reps")] + stop("Missing elements: ", paste(names(test_sub)[which(test_sub)], collapse = " ")) + } + + prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(x$lambda1, x$lambda2, x$lambda3, x$prior_Pi_AR1, x$Y, x$n_lags) + prior_Pi_AR1 <- x$prior_Pi_AR1 + prior_zero_mean <- all(x$prior_Pi_AR1 == 0) + + Y <- x$Y + freq <- x$freq + verbose <- x$verbose + + prior_psi_mean <- x$prior_psi_mean + d <- x$d + d_fcst <- x$d_fcst + check_roots <- x$check_roots + n_determ <- dim(d)[2] + + n_vars <- ncol(Y) + n_lags <- x$n_lags + n_fac <- x$n_fac + n_fcst <- x$n_fcst + + ## Priors + + priormu <- x$priormu + priorphiidi <- x$priorphiidi + priorphifac <- x$priorphifac + priorsigmaidi <- x$priorsigmaidi + priorsigmafac <- x$priorsigmafac + priorfacload <- x$priorfacload + restrict <- x$restrict + + if (length(priorsigmaidi) == 1) { + priorsigmaidi <- rep(priorsigmaidi, n_vars) + } + if (length(priorsigmafac) == 1) { + priorsigmafac <- rep(priorsigmafac, n_fac) + } + + bmu <- priormu[1] + Bmu <- priormu[2]^2 + + Bsigma <- c(priorsigmaidi, priorsigmafac) + + B011inv <- 1/10^8 + B022inv <- 1/10^12 + + armatau2 <- matrix(priorfacload^2, n_vars, n_fac) # priorfacload is scalar, or matrix + + armarestr <- matrix(FALSE, nrow = n_vars, ncol = n_fac) + if (restrict == "upper") armarestr[upper.tri(armarestr)] <- TRUE + armarestr <- matrix(as.integer(!armarestr), nrow = nrow(armarestr), ncol = ncol(armarestr)) # restrinv + + a0idi <- priorphiidi[1] + b0idi <- priorphiidi[2] + a0fac <- priorphifac[1] + b0fac <- priorphifac[2] + + priorh0 <- rep(-1.0, n_vars + n_fac) + + c0 <- ifelse(is.null(x$c0), 0.01, x$c0) + c1 <- ifelse(is.null(x$c1), 0.01, x$c1) + s <- ifelse(is.null(x[["s"]]), 1, x$s) + + ## Initials + + add_args <- list(...) + n_reps <- add_args$n_reps + n_thin <- ifelse(!is.null(add_args$n_thin), add_args$n_thin, ifelse(!is.null(x$n_thin), x$n_thin, 1)) + + # n_vars: number of variables + # n_lags: number of lags + # n_determ: number of deterministic variables + # n_T: sample size (full sample) + # n_T_: sample size (reduced sample) + + n_q <- sum(freq == "q") + if (n_q < n_vars) { + T_b <- max(which(!apply(apply(Y[, freq == "m", drop = FALSE], 2, is.na), 1, any))) + } else { + T_b <- nrow(Y) + } + if (n_q == 0 || n_q == n_vars) { + complete_quarters <- apply(Y, 1, function(x) !any(is.na(x))) + Y <- Y[complete_quarters, ] + d_fcst <- rbind(d[!complete_quarters, , drop = FALSE], d_fcst) + d <- d[complete_quarters, , drop = FALSE] + } + if (n_q > 0) { + if (x$aggregation == "average") { + Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) + } else { + Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5)} + } else { + Lambda_ <- matrix(0, 1, 3) + } + + + n_pseudolags <- max(c(n_lags, ncol(Lambda_)/nrow(Lambda_))) + n_T <- dim(Y)[1]# - n_lags + n_T_ <- n_T - n_pseudolags + + ## Initials + init <- add_args$init + y_in_p <- Y[-(1:n_lags), ] + error_variance <- mfbvar:::compute_error_variances(Y) + + ### Regression parameters + if (is.null(init$init_Pi)) { + init_Pi <- matrix(0, nrow = n_vars, ncol = n_vars*(n_vars*n_lags + 1)) + } else { + init_Pi <- init$init_Pi + } + + ### Latent high-frequency + if (is.null(init$init_Z)) { + init_Z <- mfbvar:::fill_na(Y) + } else { + init_Z <- init$init_Z + } + + ### Steady-states + if (is.null(init$init_psi)) { + init_psi <- prior_psi_mean + } else { + init_psi <- init$init_psi + } + if (is.null(init$init_omega)) { - if (is.null(prior_psi_Omega)) { - init_omega <- diag(prior_psi_Omega) + if (!is.null(x$prior_psi_Omega)) { + init_omega <- diag(x$prior_psi_Omega) } else { init_omega <- rep(0.1, n_determ*n_vars) } @@ -867,314 +928,141 @@ mcmc_sampler.mfbvar_ssng_fsv <- function(x, ...){ init_lambda_mu <- init$init_lambda_mu } - cl <- x$cl - Z_1 <- mfbvar:::fill_na(Y)[(1:n_lags), ] - verbose <- x$verbose - - ## Set up cluster (if used) - if (!is.null(cl)) { - parallelize <- TRUE - parallel::clusterCall(cl, fun = function() library(mfbvar)) - parallel::clusterExport(cl, varlist = c("par_fun")) + ### SV regressions + if (is.null(init$init_mu)) { + init_mu <- log(error_variance) } else { - parallelize <- FALSE + init_mu <- init$init_mu + } + if (is.null(init$init_sigma)) { + init_sigma <- rep(0.75, n_vars + n_fac) + } else { + init_sigma <- init$init_sigma + } + if (is.null(init$init_phi)) { + init_phi <- rep(0.2, n_vars + n_fac) + } else { + init_phi <- init$init_phi } - prior_Pi_Omega <- mfbvar:::create_prior_Pi_Omega(x$lambda1, x$lambda2, x$lambda3, x$prior_Pi_AR1, Y, n_lags)[-1, ] - prior_Pi_AR1 <- x$prior_Pi_AR1 - prior_zero_mean <- all(x$prior_Pi_AR1 == 0) - - if (prior_zero_mean) { - if (n_vars*n_lags > 1.05 * n_T_) { - par_fun <- mfbvar:::par_fun_top(rmvn_bcm) - } else { - par_fun <- mfbvar:::par_fun_top(rmvn_rue) - } + ### Factors and loadings + if (is.null(init$init_facload)) { + init_facload <- matrix(rnorm(n_vars*n_fac, sd = 0.5)^2, nrow=n_vars, ncol=n_fac) + } else { + init_facload <- init$init_facload + } + if (is.null(init$init_f)) { + init_f <- matrix(rnorm(n_fac*n_T_, sd = 0.5), n_fac, n_T_) + } else { + init_f <- init$init_f } - ## Obtain the aggregation matrix for the quarterly only - if (mf) { - if (x$aggregation == "average") { - Lambda_ <- mfbvar:::build_Lambda(rep("average", n_q), 3) - } else { - Lambda_ <- mfbvar:::build_Lambda(rep("triangular", n_q), 5) - } + ### Latent volatilities + if (is.null(init$init_latent)) { + init_latent <- t(cbind(matrix(c(log(error_variance), rep(1, n_fac)), nrow = n_T_, ncol = n_vars+n_fac, byrow = TRUE))) + } else { + init_latent <- init$init_latent + } + if (is.null(init$init_latent0)) { + init_latent0 <- numeric(n_vars + n_fac) + } else { + init_latent0 <- init$init_latent0 } - Pi <- array(init_Pi, dim = c(n_vars, n_vars*n_lags, n_reps/n_thin)) - Z <- array(init_Z, dim = c(n_T_, n_vars, n_reps/n_thin)) - psi <- matrix(init_psi, n_reps, n_vars * n_determ, byrow = TRUE) + ################################################################ + ### Preallocation + # Pi and Sigma store their i-th draws in the third dimension, psi + # is vectorized so it has its i-th draw stored in the i-th row + # Pi: p * pk * n_reps, each [,,i] stores Pi' + # Sigma: p * p * n_reps + # psi: n_reps * p + # Z: T * p * n_reps + ### If forecasting (h is horizon): + # Z_fcst: hk * p * n_reps + # d_fcst_lags: hk * m + ### If root checking: + # roots: n_reps vector + # num_tries: n_reps vector + ### If smoothing of the state vector: + # smoothed_Z: T * p * n_reps + + Pi <- array(init_Pi, dim = c(n_vars, n_vars*n_lags + 1, n_reps/n_thin)) + psi <- array(init_psi, dim = c(n_reps/n_thin, n_vars * n_determ)) + Z <- array(init_Z, dim = c(n_T, n_vars, n_reps/n_thin)) + Z_fcst<- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps/n_thin)) if (n_fcst > 0) { - Z_fcst <- array(NA, dim = c(n_fcst+n_lags, n_vars, n_reps), - dimnames = list(c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)), NULL, NULL)) + rownames(Z_fcst) <- c((n_T-n_lags+1):n_T, paste0("fcst_", 1:n_fcst)) + Z_fcst[,,1] <- 0 + } else { + rownames(Z_fcst) <- (n_T-n_lags+1):n_T } d_fcst_lags <- as.matrix(rbind(d[(n_T-n_lags+1):n_T, , drop = FALSE], d_fcst)) d_fcst_lags <- d_fcst_lags[1:(n_lags+n_fcst), , drop = FALSE] + roots <- vector("numeric", n_reps/n_thin) + num_tries <- roots - omega <- matrix(init_omega, nrow = n_reps/n_thin, ncol = n_vars * n_determ) - phi_mu <- rep(init_phi_mu, n_reps/n_thin) - lambda_mu <- rep(init_lambda_mu, n_reps/n_thin) + mu <- matrix(init_mu, n_vars, n_reps/n_thin) + sigma <- matrix(init_sigma, n_vars+n_fac, n_reps/n_thin) + phi <- matrix(init_phi, n_vars+n_fac, n_reps/n_thin) - mu_storage <- matrix(init_mu, n_vars, n_reps/n_thin) - sigma_storage <- matrix(init_sigma, n_vars+n_fac, n_reps/n_thin) - phi_storage <- matrix(init_phi, n_vars+n_fac, n_reps/n_thin) + facload <- array(matrix(init_facload, nrow = n_vars, ncol = n_fac), + dim = c(n_vars, n_fac, n_reps/n_thin)) + f <- array(matrix(init_f, n_fac, n_T_), dim = c(n_fac, n_T_, n_reps/n_thin)) - facload_storage <- array(matrix(init_facload, nrow = n_vars, ncol = n_fac), dim = c(n_vars, n_fac, n_reps/n_thin)) - fac_storage <- array(matrix(init_fac, n_fac, n_T_), dim = c(n_fac, n_T_, n_reps/n_thin)) + h <- array(t(init_latent), dim = c(n_T_, n_vars+n_fac, n_reps/n_thin), + dimnames = list(rownames(init_latent), colnames(init_latent), NULL)) - latent <- array(init_latent, dim = c(n_T_, n_vars+n_fac, n_reps/n_thin), - dimnames = list(rownames(init_latent), colnames(init_latent), NULL)) + omega <- matrix(init_omega, nrow = n_reps/n_thin, ncol = n_vars * n_determ, byrow = TRUE) + phi_mu <- rep(init_phi_mu, n_reps/n_thin) + lambda_mu <- rep(init_lambda_mu, n_reps/n_thin) - Pi_i <- init_Pi - Pi_i0 <- cbind(0, Pi_i) - Z_i <- init_Z - psi_i <- init_psi - omega_i <- init_omega - phi_mu_i <- init_phi_mu - lambda_mu_i <- init_lambda_mu - startpara <- list(mu = init_mu, - phi = init_phi, - sigma = init_sigma) - startlatent <- latent[,,1] - startlatent0 <- init_latent0 - startfacload <- matrix(init_facload, nrow = n_vars, ncol = n_fac) - startfac <- matrix(init_fac, n_fac, n_T_) + ################################################################ + ### Compute terms which do not vary in the sampler + Z_1 <- Z[1:n_pseudolags,, 1] D_mat <- mfbvar:::build_DD(d = d, n_lags = n_lags) dt <- d[-(1:n_lags), , drop = FALSE] d1 <- d[1:n_lags, , drop = FALSE] - mu_mat <- dt %*% t(matrix(psi_i, nrow = n_vars)) - n_Lambda <- ncol(Lambda_)/nrow(Lambda_) - mu_long <- matrix(0, n_Lambda+n_T_, n_vars) - if (mf) { - Lambda_single <- matrix(0, 1, n_Lambda) - for (i in 1:n_Lambda) { - Lambda_single[i] <- Lambda_[1, (i-1)*n_q+1] - } - } - my <- matrix(0, nrow(y_in_p), ncol(y_in_p)) - if (verbose) { - pb <- progress_bar$new( - format = "[:bar] :percent eta: :eta", - clear = FALSE, total = n_reps, width = 60) - } - - error <- NULL - inv_prior_psi_Omega <- solve(prior_psi_Omega) - inv_prior_psi_Omega_mean <- inv_prior_psi_Omega %*% prior_psi_mean - for (i in 1:n_reps) { - ## Square root of idiosyncratic variances (in dense form) - Sig <- exp(0.5 * startlatent[, 1:n_vars]) - ## Mixed-frequency block: sample latent monthly series - if (mf) { - mfbvar:::update_demean(my, mu_long, y_in_p, mu_mat, d1, matrix(psi_i, nrow = n_vars), Lambda_single, n_vars, - n_q, n_Lambda, n_T_) - } else { - mZ <- y_in_p - mu_mat - } - mZ1 <- Z_1 - d1 %*% t(matrix(psi_i, nrow = n_vars)) - Pi_i0[, -1] <- Pi_i - - if (mf){ - mZ <- tryCatch(mfbvar:::rsimsm_adaptive_univariate(my, Pi_i0, Sig, Lambda_, mZ1, n_q, T_b, t(startfac) %*% t(startfacload)), error = function(cond) cond) - if (inherits(Z_i, "error")) { - warning("MCMC halted because of an error in the mixed-frequency step. See $error for more information.") - error <- list(error = Z_i_demean, iter = i, block = "z") - break - } - } - Z_i_demean <- mZ - Z_i <- Z_i_demean + mu_mat - X <- mfbvar:::create_X_noint(rbind(Z_1, Z_i), n_lags) - X_demean <- mfbvar:::create_X_noint(rbind(mZ1, Z_i_demean), n_lags) - - ## Produce forecasts - - - ## Storage - if (i %% n_thin == 0) { - - if (n_fcst > 0) { - mu <- c(startpara$mu, numeric(n_fac)) - phi <- startpara$phi - sigma <- startpara$sigma - volatility_pred <- startlatent[n_T_, ] - - Z_pred <- matrix(0, n_fcst+n_lags, n_vars) - Z_pred[1:n_lags, ] <- Z_i_demean[(n_T_-n_lags+1):n_T_,] - for (j in 1:n_fcst) { - volatility_pred <- mu + phi * (volatility_pred - mu) + rnorm(n_vars+n_fac, sd = sigma) - error_pred <- rnorm(n_vars+n_fac, sd = exp(volatility_pred * 0.5)) - X_t <- mfbvar:::create_X_t_noint(Z_pred[j:(n_lags+j-1), ]) - Z_pred[j+n_lags, ] <- Pi_i %*% X_t + startfacload %*% error_pred[(n_vars+1):(n_vars+n_fac)] + error_pred[1:n_vars] - } - Z_fcst[,,i/n_thin] <- Z_pred + d_fcst_lags %*% t(matrix(psi_i, nrow = n_vars)) - } - - Pi[,,i/n_thin] <- Pi_i - Z[,,i/n_thin] <- Z_i - psi[i/n_thin, ] <- psi_i - - mu_storage[,i/n_thin] <- startpara$mu - sigma_storage[,i/n_thin] <- startpara$sigma - phi_storage[,i/n_thin] <- startpara$phi - - fac_storage[,,i/n_thin] <- startfac - facload_storage[,,i/n_thin] <- startfacload - - latent[,,i/n_thin] <- startlatent - } - - ## Stochastic volatility block: sample latent factors, latent volatilities and factor loadings - y_hat <- Z_i_demean - X_demean %*% t(Pi_i) - fsample <- tryCatch(factorstochvol::fsvsample(y_hat, factors = n_fac, draws = 1, burnin = 0, priorh0idi = "stationary", - priorh0fac = "stationary", thin = 1, keeptime = "all", - runningstore = 0, runningstorethin = 10, runningstoremoments = 1, - quiet = TRUE, interweaving = 4, signswitch = TRUE, - startpara = startpara, startlatent = startlatent, - startlatent0 = startlatent0, - startfacload = startfacload, startfac = startfac, priormu = priormu, - priorphiidi = priorphiidi, priorphifac = priorphifac, priorsigmaidi = priorsigmaidi, - priorsigmafac = priorsigmafac, priorfacload = priorfacload, priorng = priorng, - columnwise = columnwise, restrict = restrict, heteroskedastic = heteroskedastic, - priorhomoskedastic = priorhomoskedastic), error = function(cond) cond) - if (inherits(fsample, "error")) { - warning("MCMC halted because of an error in the factor stochastic volatility step. See $error for more information.") - error <- list(error = fsample, iter = i, block = "fsample") - break - } - startpara$mu <- fsample$para[1,1:n_vars,1] - startpara$phi <- fsample$para[2,,1] - startpara$sigma <- fsample$para[3,,1] - startlatent0 <- c(fsample$h0) - startlatent <- fsample$h[,,1] - startfacload <- matrix(fsample$facload[,,1], nrow = n_vars, ncol = n_fac) - startfac <- matrix(fsample$f[,,1], nrow = n_fac) - - ## Regression parameters block: sample Pi (possibly in parallel) - latent_nofac <- Z_i_demean - t(startfac) %*% t(startfacload) - - stationarity_check <- FALSE - iter <- 0 - while(stationarity_check == FALSE) { - iter <- iter + 1 - - if (!parallelize) { - if (prior_zero_mean) { - for (j in 1:n_vars) { - Pi_i[j,] <- tryCatch(mfbvar:::rmvn(X_demean/exp(startlatent[,j]*0.5), prior_Pi_Omega[,j], latent_nofac[,j]/exp(startlatent[,j]*0.5)), error = function(cond) cond) - } - } else { - for (j in 1:n_vars) { - Pi_i[j,] <- tryCatch(mfbvar:::rmvn_ccm(X_demean/exp(startlatent[,j]*0.5), prior_Pi_Omega[,j], latent_nofac[,j]/exp(startlatent[,j]*0.5), prior_Pi_AR1[j], j), error = function(cond) cond) - } - } - } else { - if (prior_zero_mean) { - Pi_i <- tryCatch(t(parallel::parSapply(cl, 1:n_vars, FUN = par_fun, XX = X_demean, startlatent = startlatent, D = prior_Pi_Omega, latent_nofac = latent_nofac)), error = function(cond) cond) - } else { - Pi_i <- tryCatch(t(parallel::parSapply(cl, 1:n_vars, FUN = par_fun_AR1, XX = X_demean, startlatent = startlatent, D = prior_Pi_Omega, latent_nofac = latent_nofac, prior_Pi_AR1 = prior_Pi_AR1)), error = function(cond) cond) - } - } - - if (inherits(Pi_i, "error")) { - warning("MCMC halted because of an error in the regression parameters step. See $error for more information.") - error <- list(error = Pi_i, iter = i, block = "Pi_i") - break - } - - Pi_comp <- mfbvar:::build_companion(Pi_i, n_vars = n_vars, n_lags = n_lags) - if (check_roots == TRUE) { - root <- mfbvar:::max_eig_cpp(Pi_comp) - } else { - root <- 0 - } - if (root < 1) { - stationarity_check <- TRUE - if (check_roots == TRUE) { - num_tries[i] <- iter - } - } - if (iter == 1000) { - warning("Attempted to draw stationary Pi 1,000 times.") - error <- list(error = Pi_i, iter = i, block = "Pi_i") - if (check_roots == TRUE) { - num_tries[i] <- iter - } - break - } - - } + mfbvar:::mcmc_ss_fsv(Y[-(1:n_lags),],Pi,psi,phi_mu,lambda_mu,omega,Z,Z_fcst, + mu,phi,sigma,f,facload,h, + Lambda_,prior_Pi_Omega,prior_Pi_AR1,D_mat,dt,d1, + d_fcst_lags,prior_psi_mean,c0,c1,s,check_roots,Z_1,bmu,Bmu, + a0idi,b0idi,a0fac,b0fac,Bsigma,B011inv,B022inv,priorh0, + armarestr,armatau2,n_fac,n_reps,n_q,T_b-n_lags,n_lags, + n_vars,n_T_,n_fcst,n_determ,n_thin,verbose,TRUE) + + return_obj <- list(Pi = Pi, psi = psi, omega = omega, lambda_mu = lambda_mu, + phi_mu = phi_mu, Z = Z, Z_fcst = NULL, mu = mu, phi = phi, + sigma = sigma, f = f, facload = facload, h = h, + Lambda_ = Lambda_, prior_Pi_Omega = prior_Pi_Omega, + prior_Pi_AR1 = prior_Pi_AR1, prior_psi_mean = prior_psi_mean, + prior_psi_Omega = diag(omega[1, ]), Y = Y, Z_1 = Z_1, bmu = bmu, + Bmu = Bmu, a0idi = a0idi, b0idi = b0idi, a0fac = a0fac, + b0fac = b0fac, Bsigma = Bsigma, B011inv = B011inv, + B022inv = B022inv, priorh0 = priorh0, armarestr = armarestr, + armatau2 = armatau2, n_fac = n_fac, n_reps = n_reps, + n_q = n_q, T_b_ = T_b-n_lags, n_lags = n_lags, + n_vars = n_vars, n_T_ = n_T_, n_fcst = n_fcst, n_determ = n_determ, + n_thin = n_thin, verbose = verbose, + init = list(init_Pi = Pi[,, n_reps/n_thin], + init_psi = psi[n_reps/n_thin, ], + init_omega = omega[n_reps/n_thin, ], + init_lambda_mu = lambda_mu[n_reps/n_thin], + init_phi_mu = phi_mu[n_reps/n_thin], + init_Z = Z[,, n_reps/n_thin], + init_mu = mu[, n_reps/n_thin], + init_phi = phi[, n_reps/n_thin], + init_sigma = sigma[, n_reps/n_thin], + init_facload = facload[,,n_reps/n_thin], + init_f = f[,,n_reps/n_thin], + init_h = h[,,n_reps/n_thin])) - Pi_i0[, -1] <- Pi_i - idivar <- exp(startlatent[, 1:n_vars]) - - gig_lambda <- phi_mu_i-0.5 - gig_chi <- lambda_mu_i * phi_mu_i - gig_psi <- (psi_i-prior_psi_mean)^2 - for (j in 1:(n_vars*n_determ)) { - omega_i[j] = mfbvar:::do_rgig1(gig_lambda, gig_chi, gig_psi[j]) - } - lambda_mu_i <- rgamma(1, n_vars*n_determ * phi_mu_i + c0, (0.5 * phi_mu_i * sum(omega_i) + c1)) - phi_mu_proposal <- phi_mu_i * exp(rnorm(1, sd = s)) - prob <- exp(mfbvar:::posterior_phi_mu(lambda_mu_i, phi_mu_proposal, omega_i, n_vars*n_determ)-mfbvar:::posterior_phi_mu(lambda_mu_i, phi_mu_i, omega_i, n_vars*n_determ)) * phi_mu_proposal/phi_mu_i - u <- runif(1) - if (u < prob) { - phi_mu <- phi_mu_proposal - accept <- 1 - } else { - accept <- 0 - } - if (adaptive_mh) { - accept_vec[i] <- accept - if (i %% 100 == 0) { - batch <- batch + 1 - min_vec[2] <- batch^(-0.5) - if (mean(accept_vec[(i-99):i]) > 0.44) { - s_prop <- log(s) + min(min_vec) - if (s_prop < M) { - s <- exp(s_prop) - } - } else { - s_prop <- log(s) - min(min_vec) - if (s_prop > -M) { - s <- exp(s_prop) - } - } - } - } - - - mfbvar:::posterior_psi_fsv(psi_i, mu_mat, Pi_i, D_mat, idivar, inv_prior_psi_Omega, - Z_i, X, startfacload, startfac, inv_prior_psi_Omega_mean, dt, - n_determ, n_vars, n_lags) - - if (verbose) { - pb$tick() - } - } - - ################################################################ - ### Prepare the return object - return_obj <- list(Pi = Pi, Z = Z, psi = psi, Z_fcst = NULL, n_lags = n_lags, n_vars = n_vars, n_fcst = n_fcst, - prior_Pi_Omega = prior_Pi_Omega, d = d, Y = Y, n_T = n_T, n_T_ = n_T_, n_reps = n_reps, - n_determ = n_determ, facload = facload_storage, latent = latent, mu = mu_storage, sigma = sigma_storage, phi = phi_storage, - init = list(init_Pi = Pi_i, init_Z = Z_i, init_psi = psi_i, init_mu = startpara$mu, - init_phi = startpara$phi, init_sigma = startpara$sigma, - init_facload = startfacload, - init_fac = startfac, - init_latent = startlatent, - init_latent0 = startlatent0), - num_tries = num_tries, - error = error) - - if (n_fcst>0) { + if (n_fcst > 0) { return_obj$Z_fcst <- Z_fcst } - return(return_obj) } diff --git a/R/mdd.R b/R/mdd.R deleted file mode 100644 index b3b8617..0000000 --- a/R/mdd.R +++ /dev/null @@ -1,378 +0,0 @@ -#' Marginal data density estimation -#' -#' \code{mdd} estimates the (log) marginal data density. -#' -#' This is a generic function. See the methods for more information. -#' @seealso \code{\link{mdd.mfbvar_ss_iw}}, \code{\link{mdd.mfbvar_minn_iw}} -#' @param x argument to dispatch on (of class \code{mfbvar_ss} or \code{mfbvar_minn}) -#' @param ... additional named arguments passed on to the methods - -mdd <- function(x, ...) { - UseMethod("mdd") -} - -mdd.default <- function(x, ...) { - stop("The marginal data density can currently only be estimated when inverse Wishart is used for the error covariance matrix.") -} - -#' Marginal data density method for class \code{mfbvar_ss} -#' -#' Estimate the marginal data density for the model with a steady-state prior. -#' @param x object of class \code{mfbvar_ss} -#' @param method option for which method to choose for computing the mdd (\code{1} or \code{2}) -#' @param ... additional arguments (currently only \code{p_trunc} for the degree of truncation for method 2 is available) -#' @details Two methods for estimating the marginal data density are implemented. Method 1 and 2 correspond to the two methods proposed by -#' Fuentes-Albero and Melosi (2013) and Ankargren, Unosson and Yang (2018). -#' @return The logarithm of the marginal data density. -#' @references Fuentes-Albero, C. and Melosi, L. (2013) Methods for Computing Marginal Data Densities from the Gibbs Output. -#' \emph{Journal of Econometrics}, 175(2), 132-141, \url{https://doi.org/10.1016/j.jeconom.2013.03.002}\cr -#' Ankargren, S., Unosson, M., & Yang, Y. (2018) A Mixed-Frequency Bayesian Vector Autoregression with a Steady-State Prior. Working Paper, Department of Statistics, Uppsala University No. 2018:3. -#' @seealso \code{\link{mdd}}, \code{\link{mdd.mfbvar_minn_iw}} -mdd.mfbvar_ss_iw <- function(x, method = 1, ...) { - if (method == 1) { - mdd_est <- estimate_mdd_ss_1(x) - } else if (method == 2) { - mdd_est <- estimate_mdd_ss_2(x, ...) - } else { - stop("method: Must be 1 or 2.") - } - return(c(mdd_est$log_mdd)) -} - -#' Marginal data density method for class \code{mfbvar_minn} -#' -#' Estimate the marginal data density for the model with a Minnesota prior. -#' @param x object of class \code{mfbvar_minn} -#' @param ... additional arguments (currently only \code{p_trunc} for the degree of truncation is available) -#' @return The logarithm of the marginal data density. -#' @details The method used for estimating the marginal data density is the proposal made by -#' Schorfheide and Song (2015). -#' @references -#' Schorfheide, F., & Song, D. (2015) Real-Time Forecasting With a Mixed-Frequency VAR. \emph{Journal of Business & Economic Statistics}, 33(3), 366--380. \url{http://dx.doi.org/10.1080/07350015.2014.954707} -#' @seealso \code{\link{mdd}}, \code{\link{mdd.mfbvar_ss_iw}} -mdd.mfbvar_minn_iw <- function(x, ...) { - quarterly_cols <- which(x$mfbvar_prior$freq == "q") - estimate_mdd_minn(x, ...) -} - -#' Estimate marginal data density in steady-state MF-BVAR -#' -#' This function provides the possibility to estimate the log marginal density using the steady-state MF-BVAR. -#' @keywords internal -#' @return -#' \code{estimate_mdd_ss_1} returns a list with components (all are currently in logarithms): -#' \item{lklhd}{The likelihood.} -#' \item{eval_prior_Pi_Sigma}{The evaluated prior.} -#' \item{eval_prior_psi}{The evaluated prior of psi.} -#' \item{eval_RB_Pi_Sigma}{The Rao-Blackwellized estimate of the conditional posterior of Pi and Sigma.} -#' \item{eval_marg_psi}{The evaluated marginal posterior of psi.} -#' \item{log_mdd}{The mdd estimate (in log).} -estimate_mdd_ss_1 <- function(mfbvar_obj) { - ################################################################ - ### Get things from the MFBVAR object - n_determ <- mfbvar_obj$n_determ - n_vars <- mfbvar_obj$n_vars - n_lags <- mfbvar_obj$n_lags - n_T <- mfbvar_obj$n_T - n_T_ <- mfbvar_obj$n_T_ - n_reps <- mfbvar_obj$n_reps - - psi <- mfbvar_obj$psi - prior_Pi_Omega <- mfbvar_obj$prior_Pi_Omega - prior_Pi_mean <- mfbvar_obj$prior_Pi_mean - prior_S <- mfbvar_obj$prior_S - post_nu <- mfbvar_obj$post_nu - - Y <- mfbvar_obj$Y - Z <- mfbvar_obj$Z - d <- mfbvar_obj$d - Pi <- mfbvar_obj$Pi - Sigma <- mfbvar_obj$Sigma - - Lambda <- mfbvar_obj$Lambda - - post_Pi_mean <- apply(Pi, c(1, 2), mean) - post_Sigma <- apply(Sigma, c(1, 2), mean) - post_psi <- colMeans(psi) - - prior_S <- mfbvar_obj$prior_S - prior_Pi_Omega <- mfbvar_obj$prior_Pi_Omega - prior_Pi_mean <- mfbvar_obj$prior_Pi_mean - prior_psi_Omega <- mfbvar_obj$prior_psi_Omega - prior_psi_mean <- mfbvar_obj$prior_psi_mean - - freq <- mfbvar_obj$mfbvar_prior$freq - Lambda <- build_Lambda(freq, n_lags) - n_q <- sum(freq == "q") - T_b <- max(which(!apply(apply(Y[, freq == "m"], 2, is.na), 1, any))) - Lambda_ <- build_Lambda(rep("q", n_q), 3) - - ################################################################ - ### Initialize - Pi_red <- array(NA, dim = c(n_vars, n_vars * n_lags, n_reps)) - Sigma_red <- array(NA, dim = c(n_vars, n_vars, n_reps)) - Z_red <- array(NA, dim = c(n_T, n_vars, n_reps)) - - Pi_red[,, 1] <- post_Pi_mean - Sigma_red[,, 1] <- post_Sigma - Z_red[,, 1] <- apply(mfbvar_obj$Z, c(1, 2), mean) - - roots <- vector("numeric", n_reps) - num_tries <- roots - - ################################################################ - ### Compute terms which do not vary in the sampler - - # Create D (does not vary in the sampler), and find roots of Pi - D <- build_DD(d = d, n_lags = n_lags) - - # For the posterior of Pi - inv_prior_Pi_Omega <- solve(prior_Pi_Omega) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - - Z_1 <- Z_red[1:n_lags,, 1] - - mZ <- Y - d %*% t(matrix(post_psi, nrow = n_vars)) - mZ <- as.matrix(mZ) - demeaned_z0 <- Z_1 - d[1:n_lags, ] %*% t(matrix(post_psi, nrow = n_vars)) - d_post_psi <- d %*% t(matrix(post_psi, nrow = n_vars)) - ################################################################ - ### Reduced Gibbs step - for (r in 2:n_reps) { - ################################################################ - ### Pi and Sigma step - # (Z_r1, d, psi_r1, prior_Pi_mean, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_S, prior_nu, check_roots, n_vars, n_lags, n_T) - Pi_Sigma <- posterior_Pi_Sigma(Z_r1 = Z_red[,, r-1], d = d, psi_r1 = post_psi, prior_Pi_mean, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_S, n_vars+2, check_roots = TRUE, n_vars, n_lags, n_T) - Pi_red[,,r] <- Pi_Sigma$Pi_r - Sigma_red[,,r] <- Pi_Sigma$Sigma_r - num_tries[r] <- Pi_Sigma$num_try - roots[r] <- Pi_Sigma$root - - ################################################################ - ### Smoothing step - #(Y, d, Pi_r, Sigma_r, psi_r, Z_1, Lambda, n_vars, n_lags, n_T_, smooth_state) - - Pi_r <- cbind(Pi_red[,,r], 0) - Z_res <- kf_sim_smooth(mZ, Pi_r, Sigma_red[,,r], Lambda_, demeaned_z0, n_q, T_b) - Z_res <- rbind(demeaned_z0, Z_res) + d_post_psi - Z_red[,, r] <- Z_res - } - - ################################################################ - ### For the likelihood calculation - mZ <- Y - d %*% t(matrix(post_psi, nrow = n_vars)) - mZ <- mZ[-(1:n_lags), ] - demeaned_z0 <- Z[1:n_lags,, 1] - d[1:n_lags, ] %*% t(matrix(post_psi, nrow = n_vars)) - h0 <- matrix(t(demeaned_z0), ncol = 1) - h0 <- h0[(n_vars*n_lags):1,, drop = FALSE] # have to reverse the order - Pi_comp <- build_companion(post_Pi_mean, n_vars = n_vars, n_lags = n_lags) - Q_comp <- matrix(0, ncol = n_vars*n_lags, nrow = n_vars*n_lags) - Q_comp[1:n_vars, 1:n_vars] <- t(chol(post_Sigma)) - P0 <- matrix(0, n_lags*n_vars, n_lags*n_vars) - - ################################################################ - ### Final calculations - lklhd <- sum(c(loglike(Y = as.matrix(mZ), Lambda = Lambda, Pi_comp = Pi_comp, Q_comp = Q_comp, n_T = n_T_, n_vars = n_vars, n_comp = n_lags * n_vars, z0 = h0, P0 = P0)[-1])) - eval_prior_Pi_Sigma <- dnorminvwish(X = t(post_Pi_mean), Sigma = post_Sigma, M = prior_Pi_mean, P = prior_Pi_Omega, S = prior_S, v = n_vars+2) - eval_prior_psi <- dmultn(x = post_psi, m = prior_psi_mean, Sigma = prior_psi_Omega) - eval_RB_Pi_Sigma <- log(mean(eval_Pi_Sigma_RaoBlack(Z_array = Z_red, d = d, post_psi_center = post_psi, post_Pi_center = post_Pi_mean, post_Sigma_center = post_Sigma, - post_nu = post_nu, prior_Pi_mean = prior_Pi_mean, prior_Pi_Omega = prior_Pi_Omega, prior_S = prior_S, - n_vars = n_vars, n_lags = n_lags, n_reps = n_reps))) - eval_marg_psi <- log(mean(eval_psi_MargPost(Pi_array = Pi, Sigma_array = Sigma, Z_array = Z, post_psi_center = post_psi, prior_psi_mean = prior_psi_mean, - prior_psi_Omega = prior_psi_Omega, D_mat = D, n_determ = n_determ, n_vars = n_vars, n_lags = n_lags, n_reps = n_reps))) - - mdd_estimate <- c(lklhd + eval_prior_Pi_Sigma + eval_prior_psi - (eval_RB_Pi_Sigma + eval_marg_psi)) - - return(list(lklhd = lklhd, eval_prior_Pi_Sigma = eval_prior_Pi_Sigma, eval_prior_psi = eval_prior_psi, eval_RB_Pi_Sigma = eval_RB_Pi_Sigma, eval_marg_psi = eval_marg_psi, log_mdd = mdd_estimate)) -} - - -#' @rdname estimate_mdd_ss_1 -#' @details \code{estimate_mdd_ss_1} uses method 1, \code{estimate_mdd_ss_2} uses method 2. -#' @templateVar mfbvar_obj TRUE -#' @templateVar p_trunc TRUE -#' @template man_template -#' @keywords internal -#' @return -#' \code{estimate_mdd_ss_1} returns a list with components being \code{n_reps}-long vectors and a scalar (the final estimate). -#' \item{eval_posterior_Pi_Sigma}{Posterior of Pi and Sigma.} -#' \item{data_likelihood}{The likelihood.} -#' \item{eval_prior_Pi_Sigma}{Prior of Pi and Sigma.} -#' \item{eval_prior_psi}{Prior of psi.} -#' \item{psi_truncated}{The truncated psi pdf.} -#' \item{log_mdd}{The mdd estimate (in log).} - -estimate_mdd_ss_2 <- function(mfbvar_obj, p_trunc) { - # Get things from the MFBVAR object - n_determ <- mfbvar_obj$n_determ - n_vars <- mfbvar_obj$n_vars - n_lags <- mfbvar_obj$n_lags - n_T <- mfbvar_obj$n_T - n_T_ <- mfbvar_obj$n_T_ - n_reps <- mfbvar_obj$n_reps - - psi <- mfbvar_obj$psi - prior_Pi_Omega <- mfbvar_obj$prior_Pi_Omega - prior_Pi_mean <- mfbvar_obj$prior_Pi_mean - prior_S <- mfbvar_obj$prior_S - post_nu <- mfbvar_obj$post_nu - - Y <- mfbvar_obj$Y - Z <- mfbvar_obj$Z - d <- mfbvar_obj$d - - Lambda <- mfbvar_obj$Lambda - - post_Pi_mean <- apply(mfbvar_obj$Pi, c(1, 2), mean) - post_Sigma <- apply(mfbvar_obj$Sigma, c(1, 2), mean) - post_psi <- colMeans(psi) - post_psi_Omega <- cov(psi) - - prior_S <- mfbvar_obj$prior_S - prior_Pi_Omega <- mfbvar_obj$prior_Pi_Omega - prior_Pi_mean <- mfbvar_obj$prior_Pi_mean - prior_psi_Omega <- mfbvar_obj$prior_psi_Omega - prior_psi_mean <- mfbvar_obj$prior_psi_mean - - # For the truncated normal - chisq_val <- qchisq(p_trunc, n_determ*n_vars) - - #(mZ,lH,mF,mQ,iT,ip,iq,h0,P0) - Pi_comp <- build_companion(post_Pi_mean, n_vars = n_vars, n_lags = n_lags) - Q_comp <- matrix(0, ncol = n_vars*n_lags, nrow = n_vars*n_lags) - Q_comp[1:n_vars, 1:n_vars] <- t(chol(post_Sigma)) - P0 <- matrix(0, n_lags*n_vars, n_lags*n_vars) - - eval_posterior_Pi_Sigma <- vector("numeric", n_reps) - data_likelihood <- vector("numeric", n_reps) - eval_prior_Pi_Sigma <- vector("numeric", 1) - eval_prior_psi <- vector("numeric", n_reps) - psi_truncated <- vector("numeric", n_reps) - - inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - for (r in 1:n_reps) { - # Demean z, create Z (companion form version) - demeaned_z <- Z[,, r] - d %*% t(matrix(psi[r, ], nrow = n_vars)) - demeaned_Z <- build_Z(z = demeaned_z, n_lags = n_lags) - XX <- demeaned_Z[-nrow(demeaned_Z), ] - YY <- demeaned_Z[-1, 1:n_vars] - XXt.XX <- crossprod(XX) - XXt.XX.inv <- chol2inv(chol(XXt.XX)) - Pi_sample <- XXt.XX.inv %*% crossprod(XX, YY) - - ################################################################ - ### Pi and Sigma step - - # Posterior moments of Pi - post_Pi_Omega_i <- chol2inv(chol(inv_prior_Pi_Omega + XXt.XX)) - post_Pi_i <- post_Pi_Omega_i %*% (Omega_Pi + crossprod(XX, YY)) - - # Then Sigma - s_sample <- crossprod(YY - XX %*% Pi_sample) - Pi_diff <- prior_Pi_mean - Pi_sample - post_s_i <- prior_S + s_sample + t(Pi_diff) %*% chol2inv(chol(prior_Pi_Omega + XXt.XX.inv)) %*% Pi_diff - - # Set the variables which vary in the Kalman filtering - mZ <- Y - d %*% t(matrix(psi[r, ], nrow = n_vars)) - mZ <- mZ[-(1:n_lags), ] - demeaned_z0 <- Z[1:n_lags,, 1] - d[1:n_lags, ] %*% t(matrix(psi[r, ], nrow = n_vars)) - h0 <- matrix(t(demeaned_z0), ncol = 1) - h0 <- h0[(n_vars*n_lags):1,,drop = FALSE] # have to reverse the order - - - eval_posterior_Pi_Sigma[r] <- dnorminvwish(X = t(post_Pi_mean), Sigma = post_Sigma, M = post_Pi_i, P = post_Pi_Omega_i, S = post_s_i, v = post_nu) - data_likelihood[r] <- sum(c(loglike(Y = as.matrix(mZ), Lambda = Lambda, Pi_comp = Pi_comp, Q_comp = Q_comp, n_T = n_T_, n_vars = n_vars, n_comp = n_lags * n_vars, z0 = h0, P0 = P0)[-1])) - - eval_prior_psi[r] <- dmultn(x = psi[r, ], m = prior_psi_mean, Sigma = prior_psi_Omega) - psi_truncated[r] <- dnorm_trunc(psi[r, ], post_psi, solve(post_psi_Omega), n_determ*n_vars, p_trunc, chisq_val) - - } - - eval_prior_Pi_Sigma <- dnorminvwish(X = t(post_Pi_mean), Sigma = post_Sigma, M = prior_Pi_mean, P = prior_Pi_Omega, S = prior_S, v = n_vars+2) - exp_term <- eval_posterior_Pi_Sigma - (data_likelihood + eval_prior_Pi_Sigma + eval_prior_psi) - log_mdd <- -mean(exp_term)-log(mean(exp(exp_term-mean(exp_term)) * psi_truncated)) - - return(list(eval_posterior_Pi_Sigma = eval_posterior_Pi_Sigma, data_likelihood = data_likelihood, eval_prior_Pi_Sigma = eval_prior_Pi_Sigma, - eval_prior_psi = eval_prior_psi, psi_truncated = psi_truncated, log_mdd = log_mdd)) -} - - -#' Estimate marginal data density in Minnesota MF-BVAR -#' -#' This function provides the possibility to estimate the log marginal density (up to a constant) using the Minnesota MF-BVAR. -#' @rdname mdd.minn -#' @templateVar mfbvar_obj TRUE -#' @template man_template -#' @param quarterly_cols numeric vector with positions of quarterly variables -#' @templateVar p_trunc TRUE -#' @keywords internal -#' @return The log marginal data density estimate (bar a constant) -#' -estimate_mdd_minn <- function(mfbvar_obj, p_trunc, ...) { - Z <- mfbvar_obj$Z - Y <- mfbvar_obj$Y - n_T <- dim(Z)[1] - n_reps <- dim(Z)[3] - n_vars <- ncol(Y) - n_lags <- mfbvar_obj$mfbvar_prior$n_lags - prior_Pi_mean <- mfbvar_obj$prior_Pi_mean - prior_Pi_Omega <- mfbvar_obj$prior_Pi_Omega - inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) - Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean - prior_S <- mfbvar_obj$prior_S - prior_nu <- mfbvar_obj$prior_nu - - postsim <- sapply(1:n_reps, function(x) { - Z_comp <- build_Z(z = Z[,, x], n_lags = n_lags) - XX <- Z_comp[-nrow(Z_comp), ] - XX <- cbind(XX, 1) - YY <- Z_comp[-1, 1:n_vars] - - XXt.XX <- crossprod(XX) - XXt.XX.inv <- chol2inv(chol(XXt.XX)) - Pi_sample <- XXt.XX.inv %*% crossprod(XX, YY) - - # Posterior moments of Pi - post_Pi_Omega <- chol2inv(chol(inv_prior_Pi_Omega + XXt.XX)) - post_Pi <- post_Pi_Omega %*% (Omega_Pi + crossprod(XX, YY)) - S <- crossprod(YY - XX %*% Pi_sample) - Pi_diff <- prior_Pi_mean - Pi_sample - post_S <- prior_S + S + t(Pi_diff) %*% chol2inv(chol(prior_Pi_Omega + XXt.XX.inv)) %*% Pi_diff - return(dmatt(YY, XX %*% prior_Pi_mean, chol2inv(chol(diag(nrow(YY)) + XX %*% prior_Pi_Omega %*% t(XX))), prior_S, prior_nu)) - }) - - temp <- apply(Z[-(1:n_lags), , ], 3, function(x) x[is.na(c(mfbvar_obj$Y[-(1:n_lags),]))]) - - if (length(temp) == 0) { - return(log_mdd = mean(postsim)) - } else { - n_para <- nrow(temp) - drawmean <- matrix(rowMeans(temp), ncol = 1) - drawsig <- cov(t(temp)) - drawsiginv <- chol2inv(chol(drawsig)) - drawsiglndet <- as.numeric(determinant(drawsiginv, logarithm = TRUE)$modulus) - paradev <- temp - kronecker(matrix(1, 1, n_reps), drawmean) - quadpara <- rowSums((t(paradev) %*% drawsiginv) * t(paradev)) - pcrit <- qchisq(p_trunc, df = nrow(drawmean)) - invlike <- matrix(NA, n_reps, length(p_trunc)) - indpara <- invlike - lnfpara <- indpara - densfac <- -0.5 * n_para * log(2 * pi) + 0.5 * drawsiglndet - - 0.5 * quadpara[1] - log(p_trunc) - postsim[1] - densfac <- -mean(densfac) - for (i in seq_along(p_trunc)) { - for (j in 1:n_reps) { - lnfpara[j, i] <- -0.5 * n_para * log(2 * pi) + - 0.5 * drawsiglndet - 0.5 * quadpara[j] - log(p_trunc[i]) - indpara[j, i] <- quadpara[j] < pcrit[i] - invlike[j, i] <- exp(lnfpara[j, i] - postsim[j] + - densfac) * indpara[j, i] - } - meaninvlike <- colMeans(invlike) - mdd <- densfac - log(meaninvlike) - } - return(log_mdd = mean(mdd) + sum(!is.na(Y[-(1:n_lags), mfbvar_obj$freq == "q"]))*log(3)) - } -} - diff --git a/inst/include/mfbvar.h b/inst/include/mfbvar.h index 7c2c3cc..b80b74c 100644 --- a/inst/include/mfbvar.h +++ b/inst/include/mfbvar.h @@ -15,23 +15,8 @@ arma::vec rmultn(const arma::vec & m, const arma::mat & Sigma); arma::mat rinvwish(int v, const arma::mat & S); arma::mat rmatn(const arma::mat & M, const arma::mat & Q, const arma::mat & P); -void posterior_psi_iw(arma::vec & psi_i, arma::mat & mu_mat, - const arma::mat & Pi_i, const arma::mat & D_mat, - const arma::mat & Sigma_i, const arma::mat & inv_prior_psi_Omega, - const arma::mat & Z_i, const arma::mat & X, - const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, - int n_determ, int n_vars, int n_lags); -void posterior_psi_csv(arma::vec & psi_i, arma::mat & mu_mat, - const arma::mat & Pi_i, const arma::mat & D_mat, - const arma::mat & Sigma_chol_inv, const arma::mat & exp_sqrt_f, - const arma::mat & inv_prior_psi_Omega, - const arma::mat & Z_i, const arma::mat & X, - const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, - int n_determ, int n_vars, int n_lags); - -double max_eig_cpp(const arma::mat & A); - // Import the rgig double do_rgig1(double lambda, double chi, double psi); +double rig(double mu, double lambda); #endif diff --git a/src/minn_utils.h b/inst/include/minn_utils.h similarity index 100% rename from src/minn_utils.h rename to inst/include/minn_utils.h diff --git a/inst/include/mvn.h b/inst/include/mvn.h index 7222c60..1080d7d 100644 --- a/inst/include/mvn.h +++ b/inst/include/mvn.h @@ -1,10 +1,10 @@ -#ifndef MFBVAR_MVN_H -#define MFBVAR_MVN_H -inline arma::vec mvn_bcm(const arma::mat & Phi, const arma::vec & d, +#ifndef MFBVAR_MVN_BCM_H +#define MFBVAR_MVN_BCM_H +inline arma::vec mvn_bcm(const arma::mat & Phi, const arma::vec & d, const arma::vec & alpha) { arma::uword n = Phi.n_rows; arma::uword p = Phi.n_cols; - + arma::mat U = Phi.t(); U.each_col() %= d; arma::vec d_sqrt = sqrt(d); @@ -17,7 +17,31 @@ inline arma::vec mvn_bcm(const arma::mat & Phi, const arma::vec & d, arma::vec v = Phi * u + delta; arma::vec w = arma::solve(Phi * U + I, (alpha - v)); arma::vec theta = u + U * w; - + + return theta; +} + +#endif + +#ifndef MFBVAR_MVN_BCM_EPS_H +#define MFBVAR_MVN_BCM_EPS_H +inline arma::vec mvn_bcm_eps(const arma::mat & Phi, const arma::vec & d, + const arma::vec & alpha, const arma::vec & eps) { + arma::uword n = Phi.n_rows; + arma::uword p = Phi.n_cols; + + arma::vec u = arma::vec(eps.begin(), p); + arma::vec delta = arma::vec(eps.begin()+p, n); + + arma::mat U = Phi.t(); + U.each_col() %= d; + arma::vec d_sqrt = sqrt(d); + arma::mat I(n, n, arma::fill::eye); + u %= d_sqrt; + arma::vec v = Phi * u + delta; + arma::vec w = arma::solve(Phi * U + I, (alpha - v)); + arma::vec theta = u + U * w; + return theta; } @@ -25,9 +49,9 @@ inline arma::vec mvn_bcm(const arma::mat & Phi, const arma::vec & d, #ifndef MFBVAR_MVN_RUE_H #define MFBVAR_MVN_RUE_H -inline arma::vec mvn_rue(const arma::mat & Phi, const arma::vec & d, +inline arma::vec mvn_rue(const arma::mat & Phi, const arma::vec & d, const arma::vec & alpha) { - + arma::mat Q = Phi.t() * Phi; Q.diag() += pow(d, -1.0); arma::mat L = arma::chol(Q, "lower"); @@ -38,17 +62,17 @@ inline arma::vec mvn_rue(const arma::mat & Phi, const arma::vec & d, z.imbue(norm_rand); arma::vec y = arma::solve(arma::trimatu(L.t()), z); arma::mat theta = mu + y; - + return theta; } - #endif + #ifndef MFBVAR_MVN_CCM_H #define MFBVAR_MVN_CCM_H -inline arma::vec mvn_ccm(const arma::mat & Phi, const arma::vec & d, +inline arma::vec mvn_ccm(const arma::mat & Phi, const arma::vec & d, const arma::vec & alpha, double c, double j) { - + arma::mat Q = Phi.t() * Phi; Q.diag() += pow(d, -1.0); arma::mat L = arma::chol(Q, "lower"); @@ -58,8 +82,27 @@ inline arma::vec mvn_ccm(const arma::mat & Phi, const arma::vec & d, arma::vec z(Phi.n_cols); z.imbue(norm_rand); arma::vec theta = arma::solve(arma::trimatu(L.t()), v+z); - + + return theta; +} + +#endif + +#ifndef MFBVAR_MVN_RUE_EPS_H +#define MFBVAR_MVN_RUE_EPS_H +inline arma::vec mvn_rue_eps(const arma::mat & Phi, const arma::vec & d, + const arma::vec & alpha, const arma::vec & eps, + double c, double j) { + + arma::mat Q = Phi.t() * Phi; + Q.diag() += pow(d, -1.0); + arma::mat L = arma::chol(Q, "lower"); + arma::mat b = Phi.t() * alpha; + b(j) += c; + arma::vec v = arma::solve(arma::trimatl(L), b); + arma::vec theta = arma::solve(arma::trimatu(L.t()), v+eps); + return theta; } -#endif \ No newline at end of file +#endif diff --git a/inst/include/mvn_par.h b/inst/include/mvn_par.h new file mode 100644 index 0000000..89785f0 --- /dev/null +++ b/inst/include/mvn_par.h @@ -0,0 +1,51 @@ +#include +#include "mvn.h" +struct Pi_parallel_rue : public RcppParallel::Worker { + arma::mat & output; + const arma::mat & y; + const arma::mat & X; + const arma::mat & d; + const arma::mat & eps; + const arma::mat & volatility; + const arma::mat & prior_AR1; + arma::uword T; + arma::uword n; + arma::uword p; + + Pi_parallel_rue(arma::mat & output, + const arma::mat & y, + const arma::mat & X, + const arma::mat & d, + const arma::mat & eps, + const arma::mat & volatility, + const arma::mat & prior_AR1, + const arma::uword T, + const arma::uword n, + const arma::uword p); + + void operator()(std::size_t begin, std::size_t end); +}; + +struct Pi_parallel_bcm : public RcppParallel::Worker { + arma::mat & output; + const arma::mat & y; + const arma::mat & X; + const arma::mat & d; + const arma::mat & eps; + const arma::mat & volatility; + arma::uword T; + arma::uword n; + arma::uword p; + + Pi_parallel_bcm(arma::mat & output, + const arma::mat & y, + const arma::mat & X, + const arma::mat & d, + const arma::mat & eps, + const arma::mat & volatility, + const arma::uword T, + const arma::uword n, + const arma::uword p); + + void operator()(std::size_t begin, std::size_t end); +}; diff --git a/inst/include/simsm_adaptive_univariate.h b/inst/include/simsm_adaptive_univariate.h index f9e14b6..32caae8 100644 --- a/inst/include/simsm_adaptive_univariate.h +++ b/inst/include/simsm_adaptive_univariate.h @@ -26,6 +26,7 @@ inline arma::mat simsm_adaptive_univariate(arma::mat y_, arma::mat Phi, arma::ma arma::mat y_sim = arma::mat(n_T, n_vars).fill(NA_REAL); arma::mat Zt; + /////////////////////////////////////////////// // SIMULATING // /////////////////////////////////////////////// @@ -138,6 +139,7 @@ inline arma::mat simsm_adaptive_univariate(arma::mat y_, arma::mat Phi, arma::ma n_obs = obs_vars.n_elem; for (arma::uword i = 0; i < n_obs; i++) { + v_t = y(t, obs_vars(i)) - a_t * Z.row(obs_vars(i)).t() - c.col(obs_vars(i)) - intercept.col(obs_vars(i)); F_t = (Z.row(obs_vars(i)) * P_t) * Z.row(obs_vars(i)).t(); if (i < n_m) { @@ -182,7 +184,6 @@ inline arma::mat simsm_adaptive_univariate(arma::mat y_, arma::mat Phi, arma::ma P_t_out.slice(t) = P_t; P_tt_out.slice(t) = P_tt; } - /////////////////////////////////////////////// // ADAPTIVE // /////////////////////////////////////////////// @@ -322,7 +323,6 @@ inline arma::mat simsm_adaptive_univariate(arma::mat y_, arma::mat Phi, arma::ma /////////////////////////////////////////////// // SMOOTHING // /////////////////////////////////////////////// - arma::field r_out(T_b, 1); arma::mat r = adaptive_to_compact_smoothing(a_tT_y, a_tt_y, a_tt, a_tt_compact, a_tt_out, diff --git a/src/Makevars.in b/src/Makevars.in index b2bc732..b251637 100644 --- a/src/Makevars.in +++ b/src/Makevars.in @@ -1,3 +1,4 @@ CXX_STD = CXX11 PKG_CXXFLAGS = @OPENMP_FLAG@ -I../inst/include PKG_LIBS= @OPENMP_FLAG@ $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) +PKG_LIBS += $(shell ${R_HOME}/bin/Rscript -e "RcppParallel::RcppParallelLibs()") diff --git a/src/Makevars.win b/src/Makevars.win index 1d44c19..f2862fe 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -1,3 +1,6 @@ CXX_STD = CXX11 PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) -I../inst/include PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) +PKG_CXXFLAGS += -DRCPP_PARALLEL_USE_TBB=1 +PKG_LIBS += $(shell "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" \ + -e "RcppParallel::RcppParallelLibs()") diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index c4f3f61..6ad150b 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -67,54 +67,23 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// kf_loglike -arma::vec kf_loglike(arma::mat y_, arma::mat Phi_, arma::mat Sigma_, arma::mat Lambda_, arma::mat a00, arma::mat P00); -RcppExport SEXP _mfbvar_kf_loglike(SEXP y_SEXP, SEXP Phi_SEXP, SEXP Sigma_SEXP, SEXP Lambda_SEXP, SEXP a00SEXP, SEXP P00SEXP) { +// dl_reg +void dl_reg(const arma::mat& y, arma::mat& x, arma::mat& beta, arma::mat& aux, arma::vec& global, arma::mat& local, arma::mat& prior_Pi_Omega, arma::uword n_reps, const double a, bool gig); +RcppExport SEXP _mfbvar_dl_reg(SEXP ySEXP, SEXP xSEXP, SEXP betaSEXP, SEXP auxSEXP, SEXP globalSEXP, SEXP localSEXP, SEXP prior_Pi_OmegaSEXP, SEXP n_repsSEXP, SEXP aSEXP, SEXP gigSEXP) { BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat >::type y_(y_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Phi_(Phi_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Sigma_(Sigma_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Lambda_(Lambda_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type a00(a00SEXP); - Rcpp::traits::input_parameter< arma::mat >::type P00(P00SEXP); - rcpp_result_gen = Rcpp::wrap(kf_loglike(y_, Phi_, Sigma_, Lambda_, a00, P00)); - return rcpp_result_gen; -END_RCPP -} -// kf_ragged -Rcpp::List kf_ragged(arma::mat y_, arma::mat Phi_, arma::mat Sigma_, arma::mat Lambda_, arma::mat Z1_, int n_q_, unsigned int T_b_); -RcppExport SEXP _mfbvar_kf_ragged(SEXP y_SEXP, SEXP Phi_SEXP, SEXP Sigma_SEXP, SEXP Lambda_SEXP, SEXP Z1_SEXP, SEXP n_q_SEXP, SEXP T_b_SEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat >::type y_(y_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Phi_(Phi_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Sigma_(Sigma_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Lambda_(Lambda_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Z1_(Z1_SEXP); - Rcpp::traits::input_parameter< int >::type n_q_(n_q_SEXP); - Rcpp::traits::input_parameter< unsigned int >::type T_b_(T_b_SEXP); - rcpp_result_gen = Rcpp::wrap(kf_ragged(y_, Phi_, Sigma_, Lambda_, Z1_, n_q_, T_b_)); - return rcpp_result_gen; -END_RCPP -} -// kf_sim_smooth -arma::mat kf_sim_smooth(arma::mat y_, arma::mat Phi_, arma::mat Sigma_, arma::mat Lambda_, arma::mat Z1_, int n_q_, unsigned int T_b_); -RcppExport SEXP _mfbvar_kf_sim_smooth(SEXP y_SEXP, SEXP Phi_SEXP, SEXP Sigma_SEXP, SEXP Lambda_SEXP, SEXP Z1_SEXP, SEXP n_q_SEXP, SEXP T_b_SEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat >::type y_(y_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Phi_(Phi_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Sigma_(Sigma_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Lambda_(Lambda_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Z1_(Z1_SEXP); - Rcpp::traits::input_parameter< int >::type n_q_(n_q_SEXP); - Rcpp::traits::input_parameter< unsigned int >::type T_b_(T_b_SEXP); - rcpp_result_gen = Rcpp::wrap(kf_sim_smooth(y_, Phi_, Sigma_, Lambda_, Z1_, n_q_, T_b_)); - return rcpp_result_gen; + Rcpp::traits::input_parameter< const arma::mat& >::type y(ySEXP); + Rcpp::traits::input_parameter< arma::mat& >::type x(xSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type beta(betaSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type aux(auxSEXP); + Rcpp::traits::input_parameter< arma::vec& >::type global(globalSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type local(localSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); + Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); + Rcpp::traits::input_parameter< const double >::type a(aSEXP); + Rcpp::traits::input_parameter< bool >::type gig(gigSEXP); + dl_reg(y, x, beta, aux, global, local, prior_Pi_Omega, n_reps, a, gig); + return R_NilValue; END_RCPP } // max_eig_cpp @@ -128,337 +97,80 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// mcmc_minn_csv -void mcmc_minn_csv(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::cube& Z, arma::cube& Z_fcst, arma::vec& phi, arma::vec& sigma, arma::mat& f, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& inv_prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, const arma::mat& prior_S, const arma::mat& Z_1, const double priorlatent0, const double phi_invvar, const double phi_meaninvvar, const double prior_sigma2, const double prior_df, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_thin, bool verbose); -RcppExport SEXP _mfbvar_mcmc_minn_csv(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP phiSEXP, SEXP sigmaSEXP, SEXP fSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP inv_prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP prior_Pi_meanSEXP, SEXP prior_SSEXP, SEXP Z_1SEXP, SEXP priorlatent0SEXP, SEXP phi_invvarSEXP, SEXP phi_meaninvvarSEXP, SEXP prior_sigma2SEXP, SEXP prior_dfSEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_thinSEXP, SEXP verboseSEXP) { +// mcmc_minn_fsv +void mcmc_minn_fsv(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Z, arma::cube& Z_fcst, arma::mat& mu, arma::mat& phi, arma::mat& sigma, arma::cube& f, arma::cube& facload, arma::cube& h, arma::mat& aux, arma::vec& global, arma::mat& local, arma::vec& slice, const arma::mat& Lambda_comp, arma::mat prior_Pi_Omega, const arma::vec& prior_Pi_AR1, const arma::mat& Z_1, double bmu, double Bmu, double a0idi, double b0idi, double a0fac, double b0fac, const Rcpp::NumericVector& Bsigma, double B011inv, double B022inv, const Rcpp::NumericVector& priorh0, const arma::imat& armarestr, const arma::mat& armatau2, arma::uword n_fac, arma::uword n_reps, arma::uword n_burnin, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_thin, bool verbose, const double a, bool gig); +RcppExport SEXP _mfbvar_mcmc_minn_fsv(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP muSEXP, SEXP phiSEXP, SEXP sigmaSEXP, SEXP fSEXP, SEXP facloadSEXP, SEXP hSEXP, SEXP auxSEXP, SEXP globalSEXP, SEXP localSEXP, SEXP sliceSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP prior_Pi_AR1SEXP, SEXP Z_1SEXP, SEXP bmuSEXP, SEXP BmuSEXP, SEXP a0idiSEXP, SEXP b0idiSEXP, SEXP a0facSEXP, SEXP b0facSEXP, SEXP BsigmaSEXP, SEXP B011invSEXP, SEXP B022invSEXP, SEXP priorh0SEXP, SEXP armarestrSEXP, SEXP armatau2SEXP, SEXP n_facSEXP, SEXP n_repsSEXP, SEXP n_burninSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_thinSEXP, SEXP verboseSEXP, SEXP aSEXP, SEXP gigSEXP) { BEGIN_RCPP Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type phi(phiSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type sigma(sigmaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type f(fSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type mu(muSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type phi(phiSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type sigma(sigmaSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type f(fSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type facload(facloadSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type h(hSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type aux(auxSEXP); + Rcpp::traits::input_parameter< arma::vec& >::type global(globalSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type local(localSEXP); + Rcpp::traits::input_parameter< arma::vec& >::type slice(sliceSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_Pi_Omega(inv_prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_mean(prior_Pi_meanSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_S(prior_SSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); - Rcpp::traits::input_parameter< const double >::type priorlatent0(priorlatent0SEXP); - Rcpp::traits::input_parameter< const double >::type phi_invvar(phi_invvarSEXP); - Rcpp::traits::input_parameter< const double >::type phi_meaninvvar(phi_meaninvvarSEXP); - Rcpp::traits::input_parameter< const double >::type prior_sigma2(prior_sigma2SEXP); - Rcpp::traits::input_parameter< const double >::type prior_df(prior_dfSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_lags(n_lagsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_vars(n_varsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_T(n_TSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_fcst(n_fcstSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); - Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - mcmc_minn_csv(y_in_p, Pi, Sigma, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose); - return R_NilValue; -END_RCPP -} -// mcmc_ss_csv -void mcmc_ss_csv(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::cube& Z, arma::cube& Z_fcst, arma::vec& phi, arma::vec& sigma, arma::mat& f, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& inv_prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, const arma::mat& prior_S, const arma::mat& D_mat, const arma::mat& dt, const arma::mat& d1, const arma::mat& d_fcst_lags, const arma::mat& inv_prior_psi_Omega, const arma::mat& inv_prior_psi_Omega_mean, bool check_roots, const arma::mat& Z_1, const double priorlatent0, const double phi_invvar, const double phi_meaninvvar, const double prior_sigma2, const double prior_df, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, bool verbose); -RcppExport SEXP _mfbvar_mcmc_ss_csv(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP psiSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP phiSEXP, SEXP sigmaSEXP, SEXP fSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP inv_prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP prior_Pi_meanSEXP, SEXP prior_SSEXP, SEXP D_matSEXP, SEXP dtSEXP, SEXP d1SEXP, SEXP d_fcst_lagsSEXP, SEXP inv_prior_psi_OmegaSEXP, SEXP inv_prior_psi_Omega_meanSEXP, SEXP check_rootsSEXP, SEXP Z_1SEXP, SEXP priorlatent0SEXP, SEXP phi_invvarSEXP, SEXP phi_meaninvvarSEXP, SEXP prior_sigma2SEXP, SEXP prior_dfSEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_determSEXP, SEXP n_thinSEXP, SEXP verboseSEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type psi(psiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type phi(phiSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type sigma(sigmaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type f(fSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_Pi_Omega(inv_prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_mean(prior_Pi_meanSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_S(prior_SSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type D_mat(D_matSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type dt(dtSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d1(d1SEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d_fcst_lags(d_fcst_lagsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_psi_Omega(inv_prior_psi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_psi_Omega_mean(inv_prior_psi_Omega_meanSEXP); - Rcpp::traits::input_parameter< bool >::type check_roots(check_rootsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); - Rcpp::traits::input_parameter< const double >::type priorlatent0(priorlatent0SEXP); - Rcpp::traits::input_parameter< const double >::type phi_invvar(phi_invvarSEXP); - Rcpp::traits::input_parameter< const double >::type phi_meaninvvar(phi_meaninvvarSEXP); - Rcpp::traits::input_parameter< const double >::type prior_sigma2(prior_sigma2SEXP); - Rcpp::traits::input_parameter< const double >::type prior_df(prior_dfSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_lags(n_lagsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_vars(n_varsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_T(n_TSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_fcst(n_fcstSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_determ(n_determSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); - Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - mcmc_ss_csv(y_in_p, Pi, Sigma, psi, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose); - return R_NilValue; -END_RCPP -} -// mcmc_ssng_csv -void mcmc_ssng_csv(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::vec& phi_mu, arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, arma::cube& Z_fcst, arma::vec& phi, arma::vec& sigma, arma::mat& f, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& inv_prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, const arma::mat& prior_S, const arma::mat& D_mat, const arma::mat& dt, const arma::mat& d1, const arma::mat& d_fcst_lags, const arma::vec& prior_psi_mean, double c0, double c1, double s, bool check_roots, const arma::mat& Z_1, const double priorlatent0, const double phi_invvar, const double phi_meaninvvar, const double prior_sigma2, const double prior_df, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, bool verbose); -RcppExport SEXP _mfbvar_mcmc_ssng_csv(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP psiSEXP, SEXP phi_muSEXP, SEXP lambda_muSEXP, SEXP omegaSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP phiSEXP, SEXP sigmaSEXP, SEXP fSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP inv_prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP prior_Pi_meanSEXP, SEXP prior_SSEXP, SEXP D_matSEXP, SEXP dtSEXP, SEXP d1SEXP, SEXP d_fcst_lagsSEXP, SEXP prior_psi_meanSEXP, SEXP c0SEXP, SEXP c1SEXP, SEXP sSEXP, SEXP check_rootsSEXP, SEXP Z_1SEXP, SEXP priorlatent0SEXP, SEXP phi_invvarSEXP, SEXP phi_meaninvvarSEXP, SEXP prior_sigma2SEXP, SEXP prior_dfSEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_determSEXP, SEXP n_thinSEXP, SEXP verboseSEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type psi(psiSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type phi_mu(phi_muSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type lambda_mu(lambda_muSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type omega(omegaSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type phi(phiSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type sigma(sigmaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type f(fSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_Pi_Omega(inv_prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_mean(prior_Pi_meanSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_S(prior_SSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type D_mat(D_matSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type dt(dtSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d1(d1SEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d_fcst_lags(d_fcst_lagsSEXP); - Rcpp::traits::input_parameter< const arma::vec& >::type prior_psi_mean(prior_psi_meanSEXP); - Rcpp::traits::input_parameter< double >::type c0(c0SEXP); - Rcpp::traits::input_parameter< double >::type c1(c1SEXP); - Rcpp::traits::input_parameter< double >::type s(sSEXP); - Rcpp::traits::input_parameter< bool >::type check_roots(check_rootsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); - Rcpp::traits::input_parameter< const double >::type priorlatent0(priorlatent0SEXP); - Rcpp::traits::input_parameter< const double >::type phi_invvar(phi_invvarSEXP); - Rcpp::traits::input_parameter< const double >::type phi_meaninvvar(phi_meaninvvarSEXP); - Rcpp::traits::input_parameter< const double >::type prior_sigma2(prior_sigma2SEXP); - Rcpp::traits::input_parameter< const double >::type prior_df(prior_dfSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_lags(n_lagsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_vars(n_varsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_T(n_TSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_fcst(n_fcstSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_determ(n_determSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); - Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - mcmc_ssng_csv(y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, phi, sigma, f, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, priorlatent0, phi_invvar, phi_meaninvvar, prior_sigma2, prior_df, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose); - return R_NilValue; -END_RCPP -} -// mcmc_minn_diffuse -void mcmc_minn_diffuse(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::cube& Z, arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& Z_1, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_thin, bool verbose); -RcppExport SEXP _mfbvar_mcmc_minn_diffuse(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP Z_1SEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_thinSEXP, SEXP verboseSEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_lags(n_lagsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_vars(n_varsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_T(n_TSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_fcst(n_fcstSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); - Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - mcmc_minn_diffuse(y_in_p, Pi, Sigma, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose); - return R_NilValue; -END_RCPP -} -// mcmc_minn_iw -void mcmc_minn_iw(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::cube& Z, arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& inv_prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, const arma::mat& prior_S, const arma::mat& Z_1, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_thin, bool verbose, int prior_nu); -RcppExport SEXP _mfbvar_mcmc_minn_iw(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP inv_prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP prior_Pi_meanSEXP, SEXP prior_SSEXP, SEXP Z_1SEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_thinSEXP, SEXP verboseSEXP, SEXP prior_nuSEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_Pi_Omega(inv_prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_mean(prior_Pi_meanSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_S(prior_SSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_lags(n_lagsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_vars(n_varsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_T(n_TSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_fcst(n_fcstSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); - Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - Rcpp::traits::input_parameter< int >::type prior_nu(prior_nuSEXP); - mcmc_minn_iw(y_in_p, Pi, Sigma, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose, prior_nu); - return R_NilValue; -END_RCPP -} -// mcmc_ss_diffuse -void mcmc_ss_diffuse(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::cube& Z, arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& D_mat, const arma::mat& dt, const arma::mat& d1, const arma::mat& d_fcst_lags, const arma::mat& inv_prior_psi_Omega, const arma::mat& inv_prior_psi_Omega_mean, bool check_roots, const arma::mat& Z_1, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, bool verbose); -RcppExport SEXP _mfbvar_mcmc_ss_diffuse(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP psiSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP D_matSEXP, SEXP dtSEXP, SEXP d1SEXP, SEXP d_fcst_lagsSEXP, SEXP inv_prior_psi_OmegaSEXP, SEXP inv_prior_psi_Omega_meanSEXP, SEXP check_rootsSEXP, SEXP Z_1SEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_determSEXP, SEXP n_thinSEXP, SEXP verboseSEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type psi(psiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type D_mat(D_matSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type dt(dtSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d1(d1SEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d_fcst_lags(d_fcst_lagsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_psi_Omega(inv_prior_psi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_psi_Omega_mean(inv_prior_psi_Omega_meanSEXP); - Rcpp::traits::input_parameter< bool >::type check_roots(check_rootsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_lags(n_lagsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_vars(n_varsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_T(n_TSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_fcst(n_fcstSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_determ(n_determSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); - Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - mcmc_ss_diffuse(y_in_p, Pi, Sigma, psi, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose); - return R_NilValue; -END_RCPP -} -// mcmc_ss_iw -void mcmc_ss_iw(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::cube& Z, arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& inv_prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, const arma::mat& prior_S, const arma::mat& D_mat, const arma::mat& dt, const arma::mat& d1, const arma::mat& d_fcst_lags, const arma::mat& inv_prior_psi_Omega, const arma::mat& inv_prior_psi_Omega_mean, bool check_roots, const arma::mat& Z_1, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, bool verbose); -RcppExport SEXP _mfbvar_mcmc_ss_iw(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP psiSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP inv_prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP prior_Pi_meanSEXP, SEXP prior_SSEXP, SEXP D_matSEXP, SEXP dtSEXP, SEXP d1SEXP, SEXP d_fcst_lagsSEXP, SEXP inv_prior_psi_OmegaSEXP, SEXP inv_prior_psi_Omega_meanSEXP, SEXP check_rootsSEXP, SEXP Z_1SEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_determSEXP, SEXP n_thinSEXP, SEXP verboseSEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type psi(psiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_Pi_Omega(inv_prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_mean(prior_Pi_meanSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_S(prior_SSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type D_mat(D_matSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type dt(dtSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d1(d1SEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d_fcst_lags(d_fcst_lagsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_psi_Omega(inv_prior_psi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_psi_Omega_mean(inv_prior_psi_Omega_meanSEXP); - Rcpp::traits::input_parameter< bool >::type check_roots(check_rootsSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_lags(n_lagsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_vars(n_varsSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_T(n_TSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_fcst(n_fcstSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_determ(n_determSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); - Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - mcmc_ss_iw(y_in_p, Pi, Sigma, psi, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, inv_prior_psi_Omega, inv_prior_psi_Omega_mean, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose); - return R_NilValue; -END_RCPP -} -// mcmc_ssng_diffuse -void mcmc_ssng_diffuse(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::vec& phi_mu, arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& D_mat, const arma::mat& dt, const arma::mat& d1, const arma::mat& d_fcst_lags, const arma::vec& prior_psi_mean, double c0, double c1, double s, bool check_roots, const arma::mat& Z_1, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, bool verbose); -RcppExport SEXP _mfbvar_mcmc_ssng_diffuse(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP psiSEXP, SEXP phi_muSEXP, SEXP lambda_muSEXP, SEXP omegaSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP D_matSEXP, SEXP dtSEXP, SEXP d1SEXP, SEXP d_fcst_lagsSEXP, SEXP prior_psi_meanSEXP, SEXP c0SEXP, SEXP c1SEXP, SEXP sSEXP, SEXP check_rootsSEXP, SEXP Z_1SEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_determSEXP, SEXP n_thinSEXP, SEXP verboseSEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type psi(psiSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type phi_mu(phi_muSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type lambda_mu(lambda_muSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type omega(omegaSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type D_mat(D_matSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type dt(dtSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d1(d1SEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type d_fcst_lags(d_fcst_lagsSEXP); - Rcpp::traits::input_parameter< const arma::vec& >::type prior_psi_mean(prior_psi_meanSEXP); - Rcpp::traits::input_parameter< double >::type c0(c0SEXP); - Rcpp::traits::input_parameter< double >::type c1(c1SEXP); - Rcpp::traits::input_parameter< double >::type s(sSEXP); - Rcpp::traits::input_parameter< bool >::type check_roots(check_rootsSEXP); + Rcpp::traits::input_parameter< arma::mat >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type prior_Pi_AR1(prior_Pi_AR1SEXP); Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); + Rcpp::traits::input_parameter< double >::type bmu(bmuSEXP); + Rcpp::traits::input_parameter< double >::type Bmu(BmuSEXP); + Rcpp::traits::input_parameter< double >::type a0idi(a0idiSEXP); + Rcpp::traits::input_parameter< double >::type b0idi(b0idiSEXP); + Rcpp::traits::input_parameter< double >::type a0fac(a0facSEXP); + Rcpp::traits::input_parameter< double >::type b0fac(b0facSEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type Bsigma(BsigmaSEXP); + Rcpp::traits::input_parameter< double >::type B011inv(B011invSEXP); + Rcpp::traits::input_parameter< double >::type B022inv(B022invSEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type priorh0(priorh0SEXP); + Rcpp::traits::input_parameter< const arma::imat& >::type armarestr(armarestrSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type armatau2(armatau2SEXP); + Rcpp::traits::input_parameter< arma::uword >::type n_fac(n_facSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); + Rcpp::traits::input_parameter< arma::uword >::type n_burnin(n_burninSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_lags(n_lagsSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_vars(n_varsSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_T(n_TSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_fcst(n_fcstSEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_determ(n_determSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - mcmc_ssng_diffuse(y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, Omega_Pi, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose); + Rcpp::traits::input_parameter< const double >::type a(aSEXP); + Rcpp::traits::input_parameter< bool >::type gig(gigSEXP); + mcmc_minn_fsv(y_in_p, Pi, Z, Z_fcst, mu, phi, sigma, f, facload, h, aux, global, local, slice, Lambda_comp, prior_Pi_Omega, prior_Pi_AR1, Z_1, bmu, Bmu, a0idi, b0idi, a0fac, b0fac, Bsigma, B011inv, B022inv, priorh0, armarestr, armatau2, n_fac, n_reps, n_burnin, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_thin, verbose, a, gig); return R_NilValue; END_RCPP } -// mcmc_ssng_iw -void mcmc_ssng_iw(const arma::mat& y_in_p, arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::vec& phi_mu, arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, const arma::mat& inv_prior_Pi_Omega, const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, const arma::mat& prior_S, const arma::mat& D_mat, const arma::mat& dt, const arma::mat& d1, const arma::mat& d_fcst_lags, const arma::vec& prior_psi_mean, double c0, double c1, double s, bool check_roots, const arma::mat& Z_1, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, bool verbose); -RcppExport SEXP _mfbvar_mcmc_ssng_iw(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP SigmaSEXP, SEXP psiSEXP, SEXP phi_muSEXP, SEXP lambda_muSEXP, SEXP omegaSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP inv_prior_Pi_OmegaSEXP, SEXP Omega_PiSEXP, SEXP prior_Pi_meanSEXP, SEXP prior_SSEXP, SEXP D_matSEXP, SEXP dtSEXP, SEXP d1SEXP, SEXP d_fcst_lagsSEXP, SEXP prior_psi_meanSEXP, SEXP c0SEXP, SEXP c1SEXP, SEXP sSEXP, SEXP check_rootsSEXP, SEXP Z_1SEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_determSEXP, SEXP n_thinSEXP, SEXP verboseSEXP) { +// mcmc_ss_fsv +void mcmc_ss_fsv(const arma::mat& y_in_p, arma::cube& Pi, arma::mat& psi, arma::vec& phi_mu, arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, arma::cube& Z_fcst, arma::mat& mu, arma::mat& phi, arma::mat& sigma, arma::cube& f, arma::cube& facload, arma::cube& h, const arma::mat& Lambda_comp, arma::mat prior_Pi_Omega, const arma::vec& prior_Pi_AR1, const arma::mat& D_mat, const arma::mat& dt, const arma::mat& d1, const arma::mat& d_fcst_lags, const arma::vec& prior_psi_mean, double c0, double c1, double s, bool check_roots, const arma::mat& Z_1, double bmu, double Bmu, double a0idi, double b0idi, double a0fac, double b0fac, const Rcpp::NumericVector& Bsigma, double B011inv, double B022inv, const Rcpp::NumericVector& priorh0, const arma::imat& armarestr, const arma::mat& armatau2, arma::uword n_fac, arma::uword n_reps, arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, bool verbose, bool ssng); +RcppExport SEXP _mfbvar_mcmc_ss_fsv(SEXP y_in_pSEXP, SEXP PiSEXP, SEXP psiSEXP, SEXP phi_muSEXP, SEXP lambda_muSEXP, SEXP omegaSEXP, SEXP ZSEXP, SEXP Z_fcstSEXP, SEXP muSEXP, SEXP phiSEXP, SEXP sigmaSEXP, SEXP fSEXP, SEXP facloadSEXP, SEXP hSEXP, SEXP Lambda_compSEXP, SEXP prior_Pi_OmegaSEXP, SEXP prior_Pi_AR1SEXP, SEXP D_matSEXP, SEXP dtSEXP, SEXP d1SEXP, SEXP d_fcst_lagsSEXP, SEXP prior_psi_meanSEXP, SEXP c0SEXP, SEXP c1SEXP, SEXP sSEXP, SEXP check_rootsSEXP, SEXP Z_1SEXP, SEXP bmuSEXP, SEXP BmuSEXP, SEXP a0idiSEXP, SEXP b0idiSEXP, SEXP a0facSEXP, SEXP b0facSEXP, SEXP BsigmaSEXP, SEXP B011invSEXP, SEXP B022invSEXP, SEXP priorh0SEXP, SEXP armarestrSEXP, SEXP armatau2SEXP, SEXP n_facSEXP, SEXP n_repsSEXP, SEXP n_qSEXP, SEXP T_bSEXP, SEXP n_lagsSEXP, SEXP n_varsSEXP, SEXP n_TSEXP, SEXP n_fcstSEXP, SEXP n_determSEXP, SEXP n_thinSEXP, SEXP verboseSEXP, SEXP ssngSEXP) { BEGIN_RCPP Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::mat& >::type y_in_p(y_in_pSEXP); Rcpp::traits::input_parameter< arma::cube& >::type Pi(PiSEXP); - Rcpp::traits::input_parameter< arma::cube& >::type Sigma(SigmaSEXP); Rcpp::traits::input_parameter< arma::mat& >::type psi(psiSEXP); Rcpp::traits::input_parameter< arma::vec& >::type phi_mu(phi_muSEXP); Rcpp::traits::input_parameter< arma::vec& >::type lambda_mu(lambda_muSEXP); Rcpp::traits::input_parameter< arma::mat& >::type omega(omegaSEXP); Rcpp::traits::input_parameter< arma::cube& >::type Z(ZSEXP); Rcpp::traits::input_parameter< arma::cube& >::type Z_fcst(Z_fcstSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type mu(muSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type phi(phiSEXP); + Rcpp::traits::input_parameter< arma::mat& >::type sigma(sigmaSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type f(fSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type facload(facloadSEXP); + Rcpp::traits::input_parameter< arma::cube& >::type h(hSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type Lambda_comp(Lambda_compSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type inv_prior_Pi_Omega(inv_prior_Pi_OmegaSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type Omega_Pi(Omega_PiSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_Pi_mean(prior_Pi_meanSEXP); - Rcpp::traits::input_parameter< const arma::mat& >::type prior_S(prior_SSEXP); + Rcpp::traits::input_parameter< arma::mat >::type prior_Pi_Omega(prior_Pi_OmegaSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type prior_Pi_AR1(prior_Pi_AR1SEXP); Rcpp::traits::input_parameter< const arma::mat& >::type D_mat(D_matSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type dt(dtSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type d1(d1SEXP); @@ -469,6 +181,19 @@ BEGIN_RCPP Rcpp::traits::input_parameter< double >::type s(sSEXP); Rcpp::traits::input_parameter< bool >::type check_roots(check_rootsSEXP); Rcpp::traits::input_parameter< const arma::mat& >::type Z_1(Z_1SEXP); + Rcpp::traits::input_parameter< double >::type bmu(bmuSEXP); + Rcpp::traits::input_parameter< double >::type Bmu(BmuSEXP); + Rcpp::traits::input_parameter< double >::type a0idi(a0idiSEXP); + Rcpp::traits::input_parameter< double >::type b0idi(b0idiSEXP); + Rcpp::traits::input_parameter< double >::type a0fac(a0facSEXP); + Rcpp::traits::input_parameter< double >::type b0fac(b0facSEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type Bsigma(BsigmaSEXP); + Rcpp::traits::input_parameter< double >::type B011inv(B011invSEXP); + Rcpp::traits::input_parameter< double >::type B022inv(B022invSEXP); + Rcpp::traits::input_parameter< const Rcpp::NumericVector& >::type priorh0(priorh0SEXP); + Rcpp::traits::input_parameter< const arma::imat& >::type armarestr(armarestrSEXP); + Rcpp::traits::input_parameter< const arma::mat& >::type armatau2(armatau2SEXP); + Rcpp::traits::input_parameter< arma::uword >::type n_fac(n_facSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_reps(n_repsSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_q(n_qSEXP); Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); @@ -479,7 +204,8 @@ BEGIN_RCPP Rcpp::traits::input_parameter< arma::uword >::type n_determ(n_determSEXP); Rcpp::traits::input_parameter< arma::uword >::type n_thin(n_thinSEXP); Rcpp::traits::input_parameter< bool >::type verbose(verboseSEXP); - mcmc_ssng_iw(y_in_p, Pi, Sigma, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, Lambda_comp, prior_Pi_Omega, inv_prior_Pi_Omega, Omega_Pi, prior_Pi_mean, prior_S, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose); + Rcpp::traits::input_parameter< bool >::type ssng(ssngSEXP); + mcmc_ss_fsv(y_in_p, Pi, psi, phi_mu, lambda_mu, omega, Z, Z_fcst, mu, phi, sigma, f, facload, h, Lambda_comp, prior_Pi_Omega, prior_Pi_AR1, D_mat, dt, d1, d_fcst_lags, prior_psi_mean, c0, c1, s, check_roots, Z_1, bmu, Bmu, a0idi, b0idi, a0fac, b0fac, Bsigma, B011inv, B022inv, priorh0, armarestr, armatau2, n_fac, n_reps, n_q, T_b, n_lags, n_vars, n_T, n_fcst, n_determ, n_thin, verbose, ssng); return R_NilValue; END_RCPP } @@ -706,6 +432,18 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// rig +double rig(double mu, double lambda); +RcppExport SEXP _mfbvar_rig(SEXP muSEXP, SEXP lambdaSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< double >::type mu(muSEXP); + Rcpp::traits::input_parameter< double >::type lambda(lambdaSEXP); + rcpp_result_gen = Rcpp::wrap(rig(mu, lambda)); + return rcpp_result_gen; +END_RCPP +} // rmvn arma::vec rmvn(const arma::mat& Phi, const arma::vec& d, const arma::vec& alpha); RcppExport SEXP _mfbvar_rmvn(SEXP PhiSEXP, SEXP dSEXP, SEXP alphaSEXP) { @@ -771,77 +509,6 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// rsimsm_adaptive_cv -arma::mat rsimsm_adaptive_cv(arma::mat y_, arma::mat Phi, arma::mat Sigma_chol, arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b); -RcppExport SEXP _mfbvar_rsimsm_adaptive_cv(SEXP y_SEXP, SEXP PhiSEXP, SEXP Sigma_cholSEXP, SEXP LambdaSEXP, SEXP Z1SEXP, SEXP n_q_SEXP, SEXP T_bSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat >::type y_(y_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Phi(PhiSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Sigma_chol(Sigma_cholSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Lambda(LambdaSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Z1(Z1SEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q_(n_q_SEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - rcpp_result_gen = Rcpp::wrap(rsimsm_adaptive_cv(y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b)); - return rcpp_result_gen; -END_RCPP -} -// rsimsm_adaptive_sv -arma::mat rsimsm_adaptive_sv(arma::mat y_, arma::mat Phi, arma::cube Sigma_chol, arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b); -RcppExport SEXP _mfbvar_rsimsm_adaptive_sv(SEXP y_SEXP, SEXP PhiSEXP, SEXP Sigma_cholSEXP, SEXP LambdaSEXP, SEXP Z1SEXP, SEXP n_q_SEXP, SEXP T_bSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat >::type y_(y_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Phi(PhiSEXP); - Rcpp::traits::input_parameter< arma::cube >::type Sigma_chol(Sigma_cholSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Lambda(LambdaSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Z1(Z1SEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q_(n_q_SEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - rcpp_result_gen = Rcpp::wrap(rsimsm_adaptive_sv(y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b)); - return rcpp_result_gen; -END_RCPP -} -// rsimsm_adaptive_univariate -arma::mat rsimsm_adaptive_univariate(arma::mat y_, arma::mat Phi, arma::mat Sigma, arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b, arma::mat f); -RcppExport SEXP _mfbvar_rsimsm_adaptive_univariate(SEXP y_SEXP, SEXP PhiSEXP, SEXP SigmaSEXP, SEXP LambdaSEXP, SEXP Z1SEXP, SEXP n_q_SEXP, SEXP T_bSEXP, SEXP fSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat >::type y_(y_SEXP); - Rcpp::traits::input_parameter< arma::mat >::type Phi(PhiSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Sigma(SigmaSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Lambda(LambdaSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Z1(Z1SEXP); - Rcpp::traits::input_parameter< arma::uword >::type n_q_(n_q_SEXP); - Rcpp::traits::input_parameter< arma::uword >::type T_b(T_bSEXP); - Rcpp::traits::input_parameter< arma::mat >::type f(fSEXP); - rcpp_result_gen = Rcpp::wrap(rsimsm_adaptive_univariate(y_, Phi, Sigma, Lambda, Z1, n_q_, T_b, f)); - return rcpp_result_gen; -END_RCPP -} -// loglike -arma::mat loglike(arma::mat Y, arma::mat Lambda, arma::mat Pi_comp, arma::mat Q_comp, int n_T, int n_vars, int n_comp, arma::mat z0, arma::mat P0); -RcppExport SEXP _mfbvar_loglike(SEXP YSEXP, SEXP LambdaSEXP, SEXP Pi_compSEXP, SEXP Q_compSEXP, SEXP n_TSEXP, SEXP n_varsSEXP, SEXP n_compSEXP, SEXP z0SEXP, SEXP P0SEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat >::type Y(YSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Lambda(LambdaSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Pi_comp(Pi_compSEXP); - Rcpp::traits::input_parameter< arma::mat >::type Q_comp(Q_compSEXP); - Rcpp::traits::input_parameter< int >::type n_T(n_TSEXP); - Rcpp::traits::input_parameter< int >::type n_vars(n_varsSEXP); - Rcpp::traits::input_parameter< int >::type n_comp(n_compSEXP); - Rcpp::traits::input_parameter< arma::mat >::type z0(z0SEXP); - Rcpp::traits::input_parameter< arma::mat >::type P0(P0SEXP); - rcpp_result_gen = Rcpp::wrap(loglike(Y, Lambda, Pi_comp, Q_comp, n_T, n_vars, n_comp, z0, P0)); - return rcpp_result_gen; -END_RCPP -} // update_demean void update_demean(arma::mat& my, arma::mat& mu_long, const arma::mat& y_in_p, const arma::mat& mu_mat, const arma::mat& d1, const arma::mat& Psi_i, const arma::mat& Lambda_single, arma::uword n_vars, arma::uword n_q, arma::uword n_Lambda, arma::uword n_T); RcppExport SEXP _mfbvar_update_demean(SEXP mySEXP, SEXP mu_longSEXP, SEXP y_in_pSEXP, SEXP mu_matSEXP, SEXP d1SEXP, SEXP Psi_iSEXP, SEXP Lambda_singleSEXP, SEXP n_varsSEXP, SEXP n_qSEXP, SEXP n_LambdaSEXP, SEXP n_TSEXP) { @@ -883,19 +550,10 @@ static const R_CallMethodDef CallEntries[] = { {"_mfbvar_create_X_noint", (DL_FUNC) &_mfbvar_create_X_noint, 2}, {"_mfbvar_create_X_t", (DL_FUNC) &_mfbvar_create_X_t, 1}, {"_mfbvar_create_X_t_noint", (DL_FUNC) &_mfbvar_create_X_t_noint, 1}, - {"_mfbvar_kf_loglike", (DL_FUNC) &_mfbvar_kf_loglike, 6}, - {"_mfbvar_kf_ragged", (DL_FUNC) &_mfbvar_kf_ragged, 7}, - {"_mfbvar_kf_sim_smooth", (DL_FUNC) &_mfbvar_kf_sim_smooth, 7}, + {"_mfbvar_dl_reg", (DL_FUNC) &_mfbvar_dl_reg, 10}, {"_mfbvar_max_eig_cpp", (DL_FUNC) &_mfbvar_max_eig_cpp, 1}, - {"_mfbvar_mcmc_minn_csv", (DL_FUNC) &_mfbvar_mcmc_minn_csv, 29}, - {"_mfbvar_mcmc_ss_csv", (DL_FUNC) &_mfbvar_mcmc_ss_csv, 38}, - {"_mfbvar_mcmc_ssng_csv", (DL_FUNC) &_mfbvar_mcmc_ssng_csv, 43}, - {"_mfbvar_mcmc_minn_diffuse", (DL_FUNC) &_mfbvar_mcmc_minn_diffuse, 18}, - {"_mfbvar_mcmc_minn_iw", (DL_FUNC) &_mfbvar_mcmc_minn_iw, 22}, - {"_mfbvar_mcmc_ss_diffuse", (DL_FUNC) &_mfbvar_mcmc_ss_diffuse, 27}, - {"_mfbvar_mcmc_ss_iw", (DL_FUNC) &_mfbvar_mcmc_ss_iw, 30}, - {"_mfbvar_mcmc_ssng_diffuse", (DL_FUNC) &_mfbvar_mcmc_ssng_diffuse, 32}, - {"_mfbvar_mcmc_ssng_iw", (DL_FUNC) &_mfbvar_mcmc_ssng_iw, 35}, + {"_mfbvar_mcmc_minn_fsv", (DL_FUNC) &_mfbvar_mcmc_minn_fsv, 43}, + {"_mfbvar_mcmc_ss_fsv", (DL_FUNC) &_mfbvar_mcmc_ss_fsv, 51}, {"_mfbvar_variances_fsv", (DL_FUNC) &_mfbvar_variances_fsv, 9}, {"_mfbvar_variances_csv", (DL_FUNC) &_mfbvar_variances_csv, 6}, {"_mfbvar_posterior_psi_Omega_fsv", (DL_FUNC) &_mfbvar_posterior_psi_Omega_fsv, 4}, @@ -909,15 +567,12 @@ static const R_CallMethodDef CallEntries[] = { {"_mfbvar_posterior_psi_iw", (DL_FUNC) &_mfbvar_posterior_psi_iw, 13}, {"_mfbvar_forwardAlg", (DL_FUNC) &_mfbvar_forwardAlg, 4}, {"_mfbvar_do_rgig1", (DL_FUNC) &_mfbvar_do_rgig1, 3}, + {"_mfbvar_rig", (DL_FUNC) &_mfbvar_rig, 2}, {"_mfbvar_rmvn", (DL_FUNC) &_mfbvar_rmvn, 3}, {"_mfbvar_rmvn_ccm", (DL_FUNC) &_mfbvar_rmvn_ccm, 5}, {"_mfbvar_rmatn", (DL_FUNC) &_mfbvar_rmatn, 3}, {"_mfbvar_rinvwish", (DL_FUNC) &_mfbvar_rinvwish, 2}, {"_mfbvar_rmultn", (DL_FUNC) &_mfbvar_rmultn, 2}, - {"_mfbvar_rsimsm_adaptive_cv", (DL_FUNC) &_mfbvar_rsimsm_adaptive_cv, 7}, - {"_mfbvar_rsimsm_adaptive_sv", (DL_FUNC) &_mfbvar_rsimsm_adaptive_sv, 7}, - {"_mfbvar_rsimsm_adaptive_univariate", (DL_FUNC) &_mfbvar_rsimsm_adaptive_univariate, 8}, - {"_mfbvar_loglike", (DL_FUNC) &_mfbvar_loglike, 9}, {"_mfbvar_update_demean", (DL_FUNC) &_mfbvar_update_demean, 11}, {"_mfbvar_posterior_phi_mu", (DL_FUNC) &_mfbvar_posterior_phi_mu, 4}, {NULL, NULL, 0} diff --git a/src/dl_reg.cpp b/src/dl_reg.cpp new file mode 100644 index 0000000..d1317c4 --- /dev/null +++ b/src/dl_reg.cpp @@ -0,0 +1,39 @@ +#include "mfbvar.h" +#include "update_dl.h" +// [[Rcpp::export]] +void dl_reg(const arma::mat & y, arma::mat & x, arma::mat & beta, + arma::mat & aux, arma::vec & global, arma::mat & local, + arma::mat & prior_Pi_Omega, arma::uword n_reps, + const double a, bool gig) { + + arma::mat eps = arma::mat(x.n_cols, 1); + arma::mat beta_i = beta.row(0).t(); + + double global_i = global(0); + arma::vec aux_i = aux.row(0).t(); + arma::vec local_i = local.row(0).t(); + arma::vec slice = arma::vec(local_i.n_elem).fill(1.0); + + arma::mat Sigma, Sigma_inv, L; + arma::vec mu; + arma::uword n_lags = x.n_cols; + + for (arma::uword i = 0; i < n_reps; ++i) { + + eps.imbue(norm_rand); + Sigma = x.t() * x; + Sigma.diag() += 1/prior_Pi_Omega; + Sigma_inv = arma::inv_sympd(Sigma); + L = arma::chol(Sigma_inv, "lower"); + mu = Sigma_inv * x.t() * y; + beta_i.col(0) = mu + L * eps; + + //beta_i.col(0) = mvn_rue(x, prior_Pi_Omega, y); + beta.row(i) = beta_i.col(0).t(); + update_dl(prior_Pi_Omega, aux_i, local_i, global_i, beta_i, 1, n_lags, a, slice, gig, false); + global(i) = global_i; + aux.row(i) = aux_i.t(); + local.row(i) = local_i.t(); + } + +} diff --git a/src/dmvnorm.cpp b/src/dmvnorm.cpp new file mode 100644 index 0000000..d2ff5a6 --- /dev/null +++ b/src/dmvnorm.cpp @@ -0,0 +1,47 @@ +#include + +using namespace Rcpp; + +RcppExport SEXP dmvnorm(const SEXP x_in, const SEXP means_in, const SEXP vars_in, const SEXP log_in) { + + // note: SEXP to Rcpp conversion REUSES memory unless "clone"d + // Rcpp to Armadillo conversion allocates NEW memory unless deact'd + + const bool loga = as(log_in); + + NumericMatrix x_(x_in); + arma::mat x(x_.begin(), x_.nrow(), x_.ncol(), false); + + NumericMatrix means_(means_in); + arma::mat means(means_.begin(), means_.nrow(), means_.ncol(), false); + + NumericVector vars_(vars_in); + IntegerVector vars_dims = vars_.attr("dim"); + int dim = vars_dims(0); + int reps = vars_dims(2); + arma::cube vars(vars_.begin(), dim, dim, reps, false); + + NumericVector out_(reps); + arma::vec out(out_.begin(), reps, false); + + arma::mat root(dim, dim); + arma::vec tmp(dim); + double tracelog; + + const double normalizer = -(dim/2.) * log(2. * M_PI); + const arma::mat I = arma::eye(dim, dim); + + for (int i = 0; i < reps; i++) { + try { + root = arma::trans(arma::solve(arma::trimatu(arma::chol(vars.slice(i))), I)); + tracelog = arma::sum(arma::log(root.diag())); + tmp = root * (x.col(i) - means.col(i)); + out(i) = normalizer - .5 * arma::sum(tmp%tmp) + tracelog; + } catch (...) { + out(i) = R_NegInf; + } + } + + if (!loga) out_ = exp(out_); + return wrap(out_); +} diff --git a/src/dmvnorm.h b/src/dmvnorm.h new file mode 100644 index 0000000..d1ad583 --- /dev/null +++ b/src/dmvnorm.h @@ -0,0 +1,10 @@ +#ifndef _DMVNORM_H +#define _DMVNORM_H + +//#define ARMA_NO_DEBUG // disables bounds checks +#include + +// Main predict function (as called from R): +RcppExport SEXP dmvnorm(const SEXP, const SEXP, const SEXP, const SEXP); + +#endif diff --git a/src/kf_cpp.cpp b/src/kf_cpp.cpp deleted file mode 100644 index 3f291c2..0000000 --- a/src/kf_cpp.cpp +++ /dev/null @@ -1,538 +0,0 @@ -#include "mfbvar.h" - -#define _USE_MATH_DEFINES // for C++ -#include - - -class KF { -protected: - arma::mat r, P_TT; -public: - arma::mat y, G, H, a, a_tt, a_tT, Tt, c, intercept, d, a1, P1, Z, a_t1, P_t1, v; - arma::cube P, FF_inv, L, N; - unsigned int n_T, n_vars, n_state; - void set_pars(arma::mat y_, arma::mat Z_, arma::mat c_, arma::mat G_, arma::mat Tt_, arma::mat d_, arma::mat H_, arma::mat a1_, arma::mat P1_, arma::mat intercept_); - void filter(); - void smoother(arma::mat r_T); - void simulator(); - arma::vec loglike(); -}; - -void KF::set_pars(arma::mat y_, arma::mat Z_, arma::mat c_, arma::mat G_, arma::mat Tt_, arma::mat d_, arma::mat H_, arma::mat a1_, arma::mat P1_, arma::mat intercept_) { - y = y_; - Z = Z_; - c = c_; - G = G_; - Tt = Tt_; - d = d_; - H = H_; - a1 = a1_; - P1 = P1_; - n_T = y_.n_rows; - n_vars = y_.n_cols; - n_state = Tt_.n_rows; - intercept = intercept_; - - v = arma::mat(n_T, n_vars).fill(NA_REAL); - a = arma::mat(n_T, n_state).fill(NA_REAL); - a_tt = arma::mat(n_T, n_state).fill(NA_REAL); - r = arma::mat(n_T, n_state).fill(0); - a_tT = arma::mat(n_T, n_state).fill(NA_REAL); - - P = arma::cube(n_state, n_state, n_T).fill(NA_REAL); - FF_inv = arma::cube(n_vars, n_vars, n_T).fill(NA_REAL); - L = arma::cube(n_state, n_state, n_T).fill(NA_REAL); - N = arma::cube(n_state, n_state, n_T).fill(NA_REAL); -} - -void KF::filter() { - - arma::uvec obs_vars(n_vars); - arma::mat Zt; - arma::mat Gt; - arma::uvec t_vec(1); - arma::mat M_t; - arma::mat FF_inv_t; - arma::mat K_t; - arma::mat v_t; - arma::mat a_t = a1.t(); - arma::mat P_t = P1; - - a.row(0) = a_t; - P.slice(0) = P_t; - - - for (arma::uword t = 0; t < n_T; t++) { - obs_vars = find_finite(y.row(t)); - t_vec(0) = t; - - Zt = Z.rows(obs_vars); - Gt = G.rows(obs_vars); - - v_t = y.submat(t_vec, obs_vars) - a_t * Zt.t() - c.submat(t_vec, obs_vars) - intercept.cols(obs_vars); - v.submat(t_vec, obs_vars) = v_t; - - M_t = P_t * Zt.t() + H * Gt.t(); - - FF_inv_t = inv_sympd(symmatu(Zt * M_t + Gt * trans(Gt + Zt * H))); - FF_inv.slice(t).submat(obs_vars, obs_vars) = FF_inv_t; - - K_t = Tt * M_t * FF_inv_t; - - L.slice(t) = Tt - K_t * Zt; - N.slice(t) = P_t * L.slice(t).t() - H * Gt.t() * K_t.t(); - a_tt.row(t) = a_t + v_t * FF_inv_t * M_t.t(); - - if (t < n_T - 1) { - a_t = a_tt.row(t) * Tt.t() + d.row(t); - a.row(t+1) = a_t; - P_t = Tt * N.slice(t) + H * H.t(); - P_t = arma::symmatu(P_t); - P.slice(t+1) = P_t; - } else { - a_t1 = a_t * Tt.t() + d.row(t) + v_t * K_t.t(); - P_t1 = Tt * N.slice(t) + H * H.t(); - P_t1 = arma::symmatu(P_t1); - P_TT = P_t - M_t * FF_inv_t * M_t.t(); - } - } - -} - -void KF::smoother(arma::mat r_T) { - arma::uvec obs_vars(n_vars); - arma::mat Zt; - arma::uvec t_vec(1); - arma::mat FF_inv_t; - arma::mat r_t = r_T; - r.row(y.n_rows-1) = r_t; - for (arma::uword t = y.n_rows - 1; t >= 1; t--) { - obs_vars = find_finite(y.row(t)); - t_vec(0) = t; - Zt = Z.rows(obs_vars); - a_tT.row(t) = a_tt.row(t) + r_t * trans(N.slice(t)); - r_t = v.submat(t_vec, obs_vars) * trans(FF_inv.slice(t).submat(obs_vars, obs_vars)) * Zt + r_t * L.slice(t); - r.row(t-1) = r_t; - } - - obs_vars = find_finite(y.row(0)); - Zt = Z.rows(obs_vars); - a_tT.row(0) = a_tt.row(0) + r_t * trans(N.slice(0)); -} - -arma::vec KF::loglike() { - arma::uvec obs_vars(n_vars); - arma::mat Zt; - arma::mat Gt; - arma::uvec t_vec(1); - arma::mat M_t; - arma::mat FF_t; - arma::mat FF_inv_t; - arma::mat K_t; - arma::mat v_t; - arma::mat L_t; - arma::mat N_t; - arma::mat a_t = a1.t(); - arma::mat P_t = P1; - arma::vec logl(n_T); - - a.row(0) = a_t; - P.slice(0) = P_t; - - double val; - double sign; - - for (arma::uword t = 0; t < n_T; t++) { - obs_vars = find_finite(y.row(t)); - t_vec(0) = t; - Zt = Z.rows(obs_vars); - Gt = G.rows(obs_vars); - - v_t = y.submat(t_vec, obs_vars) - a_t * Zt.t() - c.submat(t_vec, obs_vars) - intercept.cols(obs_vars); - M_t = P_t * Zt.t() + H * Gt.t(); - FF_t = arma::symmatu(Zt * M_t + Gt * trans(Gt + Zt * H)); - FF_inv_t = arma::inv_sympd(FF_t); - - K_t = Tt * M_t * FF_inv_t; - - L_t = Tt - K_t * Zt; - N_t = P_t * L_t.t() - H * Gt.t() * K_t.t(); - a_tt.row(t) = a_t + v_t * FF_inv_t * M_t.t(); - - arma::log_det(val, sign, FF_t); - logl(t) = -0.5 * obs_vars.n_elem * log(2 * M_PI) - 0.5 * (val + as_scalar(v_t * FF_inv_t * v_t.t())); - - if (t < n_T - 1) { - a_t = a_tt.row(t) * Tt.t() + d.row(t); - a.row(t+1) = a_t; - P_t = Tt * N_t + H * H.t(); - P_t = arma::symmatu(P_t); - P.slice(t+1) = P_t; - } - } - return logl; -} - -//' @title Kalman filter and smoother -//' -//' @description Kalman filter and smoother (\code{kf_ragged}) and simulation smoother (\code{kf_sim_smooth}) for mixed-frequency data with ragged edges. This function is more computationally efficient than using a companion form representation. -//' @param y_ matrix with the data -//' @param Phi_ matrix with the autoregressive parameters, where the last column is the intercept -//' @param Sigma_ error covariance matrix -//' @param Lambda_ aggregation matrix (for quarterly variables only) -//' @param n_q_ number of quarterly variables -//' @param T_b_ final time period where all monthly variables are observed -//' @keywords internal -//' @return For \code{kf_ragged}, a list with elements: -//' \item{a}{The one-step predictions (for the compact form)} -//' \item{a_tt}{The filtered estimates (for the compact form)} -//' \item{a_tT}{The smoothed estimates (for the compact form)} -//' \item{Z_tT}{The smoothed estimated (for the original form)} -//' @details The returned matrices have the same number of rows as \code{y_}, but the first \code{n_lags} rows are zero. -// [[Rcpp::export]] -arma::vec kf_loglike(arma::mat y_, arma::mat Phi_, arma::mat Sigma_, arma::mat Lambda_, arma::mat a00, arma::mat P00) { - // y = Z * alpha + c + intercept + G * epsilon - // alpha = F_Phi * alpha + d + H * epsilon - int n_vars = Phi_.n_rows; - int n_lags = (Phi_.n_cols-1)/n_vars; - arma::vec logl; - arma::mat c = arma::mat(size(y_), arma::fill::zeros); - arma::mat G = arma::mat(size(Sigma_), arma::fill::zeros); - arma::mat F_Phi = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); - - F_Phi.rows(0, n_vars-1) = Phi_.cols(0, n_vars*n_lags-1); - F_Phi(arma::span(n_vars, n_vars*n_lags-1), arma::span(0, (n_lags-1)*n_vars - 1)) = arma::mat(n_vars*(n_lags-1), n_vars*(n_lags-1), arma::fill::eye); - - arma::mat d = arma::mat(y_.n_rows, n_vars*n_lags, arma::fill::zeros); - d.cols(0, n_vars-1) = arma::repmat(Phi_.col(n_vars*n_lags).t(), y_.n_rows, 1); - arma::mat H = arma::mat(n_vars*n_lags, n_vars, arma::fill::zeros); - H.rows(0, n_vars-1) = arma::trans(arma::chol(Sigma_)); - arma::mat a1 = F_Phi * a00 + d.row(0).t(); - arma::mat P1 = F_Phi * P00 * F_Phi.t() + H * H.t(); - arma::mat intercept = arma::mat(1, n_vars, arma::fill::zeros); - - KF kf_end; - kf_end.set_pars(y_, // y - Lambda_, // Z - c, // c - G, // G - F_Phi, // T - d, // d - H, // H - a1, // a1 - P1, // P1 - intercept); // intercept - - logl = kf_end.loglike(); - - return logl; -} - -class KF_ragged: public KF { - -public: - arma::mat a_TbTb, P_TbTb, Phi, F_Phi, Sigma, Lambda, y_Tb, Omega, W, F_Phi_c, a_Tb1, P_Tb1, Lambda_companion, Sigma_chol, Z1; - unsigned int n_q, T_b, n_lags, n_m; - void set_ragged_pars(arma::mat Phi_, arma::mat Sigma_, arma::mat Lambda_, int n_q_, int T_b_, arma::mat Z1_); - void compact_to_companion(arma::mat Lambda_); - void original_to_compact(arma::mat y_Tb_); - arma::mat create_d(int T_end_); -}; - -void KF_ragged::set_ragged_pars(arma::mat Phi_, arma::mat Sigma_, arma::mat Lambda_, int n_q_, int T_b_, arma::mat Z1_) { - Phi = Phi_; - Sigma = Sigma_; - Sigma_chol = trans(chol(Sigma)); - Lambda = Lambda_; - n_q = n_q_; - T_b = T_b_; - Z1 = Z1_; - n_vars = Phi.n_rows; - n_m = n_vars - n_q; - n_lags = (Phi.n_cols - 1)/n_vars; - n_state = n_q*(n_lags + 1); - a_TbTb = arma::mat(1, (n_lags+1)*n_vars); - P_TbTb = arma::mat((n_lags+1)*n_vars, n_vars*(n_lags+1)); - F_Phi = arma::mat((n_lags+1)*n_vars, n_vars*(n_lags+1)); - a_TbTb.fill(0); - P_TbTb.fill(0); - F_Phi.fill(0); - F_Phi_c.fill(0); - - v = arma::mat(T_b, n_vars).fill(NA_REAL); - a = arma::mat(T_b, n_state).fill(NA_REAL); - a_tt = arma::mat(T_b, n_state).fill(NA_REAL); - r = arma::mat(T_b, n_state).fill(0); - a_tT = arma::mat(T_b, n_state).fill(NA_REAL); - - P = arma::cube(n_state, n_state, T_b).fill(NA_REAL); - FF_inv = arma::cube(n_vars, n_vars, T_b).fill(NA_REAL); - L = arma::cube(n_state, n_state, T_b).fill(NA_REAL); - N = arma::cube(n_state, n_state, T_b).fill(NA_REAL); -} - -void KF_ragged::compact_to_companion(arma::mat Lambda_) { - F_Phi = arma::mat(n_vars*(n_lags+1), n_vars*(n_lags+1), arma::fill::zeros); - F_Phi.submat(0, 0, n_vars - 1, n_vars*n_lags-1) = Phi.cols(0, n_vars*n_lags-1); - F_Phi.submat(n_vars, 0, n_vars*(n_lags+1)-1, n_vars*n_lags - 1) = arma::eye(n_vars*n_lags, n_vars*n_lags); - F_Phi_c = arma::mat(n_vars*(n_lags+1), 1, arma::fill::zeros); - F_Phi_c.rows(0, n_vars - 1) = Phi.col(n_vars*n_lags); - Omega = arma::mat(n_vars*(n_lags+1), n_vars*(n_lags+1), arma::fill::zeros); - Omega.submat(0, 0, n_vars-1, n_vars-1) = Sigma_chol; - arma::mat X_mat = y.submat(T_b - n_lags - 1, 0, T_b - 1, n_vars - n_q - 1); - X_mat = arma::trans(arma::flipud(X_mat)); - arma::mat a_mat = arma::reshape(a_tt.row(T_b-1), n_q, n_lags + 1); - arma::mat Xa_mat = arma::join_cols(X_mat, a_mat); - a_TbTb = arma::reshape(Xa_mat, n_vars*(n_lags+1), 1); - P_TbTb = arma::mat(n_vars*(n_lags+1), n_vars*(n_lags+1)); - P_TbTb.fill(0); - int n_m = n_vars - n_q; - for (unsigned int i = 0; i < n_lags + 1; i++) { - for (unsigned int j = i; j < n_lags + 1; j++) { - P_TbTb.submat(n_m+j*n_vars, n_m+i*n_vars, n_vars-1+j*n_vars, n_vars-1+i*n_vars) = P_TT.submat(j*n_q, i*n_q, n_q-1+j*n_q, n_q-1+i*n_q); - } - } - P_TbTb = symmatl(P_TbTb); - - a_Tb1 = F_Phi * a_TbTb + F_Phi_c; - P_Tb1 = F_Phi * P_TbTb * F_Phi.t() + Omega*Omega.t(); - - Lambda_companion = arma::mat(n_vars, (n_vars*(n_lags+1)), arma::fill::zeros); - Lambda_companion.submat(0, 0, n_m-1, n_m-1) = arma::eye(n_m, n_m); - - for (arma::uword i = 0; i < Lambda_.n_cols/n_q; i++) { - Lambda_companion(arma::span(n_m, n_vars - 1), arma::span(n_m + i*n_vars, (i+1)*n_vars-1)) = Lambda_.cols(i*n_q, (i+1)*(n_q)-1); - } -} - -void KF_ragged::original_to_compact(arma::mat y_Tb_) { - y_Tb = y_Tb_; - y = y_Tb_; - n_T = T_b; - arma::mat Phi_mm(n_m, n_m*n_lags); - arma::mat Phi_mq(n_m, n_q*n_lags); - arma::mat Phi_qm(n_q, n_m*n_lags); - arma::mat Phi_qq(n_q, n_q*n_lags); - - for (unsigned int i = 0; i < n_lags; i++) { - Phi_mm.cols(i*n_m, (i+1)*n_m - 1) = Phi.submat(0, i*n_vars, n_m - 1, i*n_vars + n_m - 1); - Phi_mq.cols(i*n_q, (i+1)*n_q - 1) = Phi.submat(0, i*n_vars+n_m, n_m - 1, (i+1)*n_vars - 1); - Phi_qm.cols(i*n_m, (i+1)*n_m - 1) = Phi.submat(n_m, i*n_vars, n_vars - 1, i*n_vars + n_m - 1); - Phi_qq.cols(i*n_q, (i+1)*n_q - 1) = Phi.submat(n_m, i*n_vars+n_m, n_vars - 1, (i+1)*n_vars - 1); - } - - Z = arma::mat(n_vars, n_q*(n_lags + 1)); - Z.fill(0); - Z.submat(0, n_q, n_m - 1, n_q*(n_lags + 1) - 1) = Phi_mq; - Z.submat(n_m, 0 ,n_vars - 1, Lambda.n_cols - 1) = Lambda; - - Tt = arma::mat(n_q*(n_lags + 1), n_q*(n_lags + 1)); - Tt.fill(0); - Tt.submat(0, 0, n_q - 1, n_q*n_lags - 1) = Phi_qq; - Tt.submat(n_q, 0, n_q*(n_lags+1)-1, n_q*n_lags - 1) = arma::eye(n_lags*n_q, n_lags*n_q); - - G = arma::mat(n_vars, n_vars); - G.fill(0); - G.rows(0, n_m - 1) = Sigma_chol.rows(0, n_m - 1); - - H = arma::mat(n_q*(n_lags + 1), n_vars); - H.fill(0); - H.rows(0, n_q - 1) = Sigma_chol.rows(n_m, n_vars - 1); - - arma::mat X(T_b, n_m*n_lags); - X.fill(0); - X.row(0) = reshape(trans(flipud(Z1.cols(0, n_m-1))), 1, n_lags*n_m); - for (unsigned int i = 1; i < n_lags; i++) { - X.row(i).cols(0, i*n_m - 1) = reshape(trans(flipud(y_Tb(arma::span(0, i-1), arma::span(0, n_m - 1)))), 1, i*n_m); - X.row(i).cols(i*n_m, n_lags*n_m - 1) = reshape(trans(flipud(Z1(arma::span(i, n_lags - 1), arma::span(0, n_m - 1)))), 1, (n_lags-i)*n_m); - } - for (unsigned int i = n_lags; i < T_b; i++) { - X.row(i) = reshape(trans(flipud(y_Tb(arma::span(i-n_lags, i-1), arma::span(0, n_m - 1)))), 1, n_lags*n_m); - } - - c = arma::mat(T_b, n_vars, arma::fill::zeros); - c.cols(0, n_m - 1) = X * trans(Phi_mm); - intercept = arma::mat(1, n_vars, arma::fill::zeros); - intercept.cols(0, n_m - 1) = trans(Phi.submat(0, n_vars*n_lags, n_m - 1, n_vars*n_lags)); - - W = arma::mat(T_b, n_m*n_lags + 1, arma::fill::ones); - W(arma::span(0, T_b - 2), arma::span(0, n_m*n_lags - 1)) = X.rows(1, T_b - 1); - W.row(T_b-1).cols(0, n_m*n_lags - 1) = reshape(trans(flipud(y_Tb.submat(T_b-n_lags, 0, T_b-1, n_m - 1))), 1, n_lags*n_m); - d = arma::mat(T_b, n_q*(n_lags + 1), arma::fill::zeros); - arma::mat Beta_W = join_rows(Phi_qm, Phi.submat(n_m, n_vars*n_lags, n_vars-1, n_vars*n_lags)); - d.cols(0, n_q - 1) = W * trans(Beta_W); - - arma::mat means = solve(arma::eye(n_vars, n_vars) - Phi.cols(0, n_vars*n_lags - 1) * arma::repmat(arma::eye(n_vars, n_vars), n_lags, 1), Phi.col(n_vars*n_lags)); - a1 = arma::mat(n_q*(n_lags+1), 1, arma::fill::zeros); - a1.rows(0, n_q*n_lags - 1) = reshape(trans(flipud(Z1.cols(n_m, n_vars - 1))), 1, n_lags*n_q).t(); - arma::mat W0 = arma::mat(1, n_m*n_lags + 1, arma::fill::ones); - W0.cols(0, n_m*n_lags - 1) = X.row(0); - arma::mat d0 = arma::mat(1, n_q*(n_lags + 1), arma::fill::zeros); - d0.cols(0, n_q - 1) = W0 * trans(Beta_W); - a1 = Tt * a1 + d0.t(); - P1 = H * H.t(); -} - -arma::mat KF_ragged::create_d(int T_end_) { - arma::mat d = arma::join_rows(trans(Phi.submat(0, n_vars*n_lags, n_vars - 1, n_vars*n_lags)), arma::mat(1, n_vars*n_lags, arma::fill::zeros)); - d = arma::repmat(d, T_end_, 1); - return d; -} - -//' @title Kalman filter and smoother -//' -//' @description Kalman filter and smoother (\code{kf_ragged}) and simulation smoother (\code{kf_sim_smooth}) for mixed-frequency data with ragged edges. This function is more computationally efficient than using a companion form representation. -//' @param y_ matrix with the data -//' @param Phi_ matrix with the autoregressive parameters, where the last column is the intercept -//' @param Sigma_ error covariance matrix -//' @param Lambda_ aggregation matrix (for quarterly variables only) -//' @param n_q_ number of quarterly variables -//' @param T_b_ final time period where all monthly variables are observed -//' @keywords internal -//' @return For \code{kf_ragged}, a list with elements: -//' \item{a}{The one-step predictions (for the compact form)} -//' \item{a_tt}{The filtered estimates (for the compact form)} -//' \item{a_tT}{The smoothed estimates (for the compact form)} -//' \item{Z_tT}{The smoothed estimated (for the original form)} -//' @details The returned matrices have the same number of rows as \code{y_}, but the first \code{n_lags} rows are zero. -// [[Rcpp::export]] -Rcpp::List kf_ragged(arma::mat y_, arma::mat Phi_, arma::mat Sigma_, arma::mat Lambda_, arma::mat Z1_, int n_q_, unsigned int T_b_) { - - // Initialization of variables - KF_ragged kf_obj; - KF kf_end; - - // Initialization of filter - arma::mat y_Tb = y_.rows(0, T_b_ - 1); - kf_obj.set_ragged_pars(Phi_, Sigma_, Lambda_, n_q_, T_b_, Z1_); - kf_obj.original_to_compact(y_Tb); - - unsigned int n_vars, n_lags, n_m, n_q, T_b, T_end, T_full; - n_vars = kf_obj.n_vars; - n_lags = kf_obj.n_lags; - n_m = kf_obj.n_m; - n_q = kf_obj.n_q; - T_b = kf_obj.T_b; - T_full = y_.n_rows; - T_end = T_full - T_b; - - arma::mat alpha_t1, r_T; - arma::mat a = arma::mat(T_full, n_q*(n_lags+1)).fill(NA_REAL); - arma::mat a_tt = arma::mat(T_full, n_q*(n_lags+1)).fill(NA_REAL); - arma::mat a_tT = arma::mat(T_full, n_q*(n_lags+1)).fill(NA_REAL); - arma::mat Z_tT = arma::mat(T_full, n_vars).fill(NA_REAL); - - kf_obj.filter(); - a.rows(0, T_b-1) = kf_obj.a; - a_tt.rows(0, T_b-1) = kf_obj.a_tt; - - if (T_b_ < T_full) { - - kf_obj.compact_to_companion(Lambda_); - arma::mat y = y_.rows(T_b_, T_full-1); - - kf_end.set_pars(y, // y - kf_obj.Lambda_companion, // Z - arma::mat(size(y), arma::fill::zeros), // c - arma::mat(n_vars, n_vars*(n_lags+1), arma::fill::zeros), // G - kf_obj.F_Phi, // T - kf_obj.create_d(T_end), // d - kf_obj.Omega, // H - kf_obj.a_Tb1, // a1 - kf_obj.P_Tb1, // P1 - arma::mat(1, n_vars, arma::fill::zeros)); // intercept - - kf_end.filter(); - - // Fill in one-step predictions and filtered estimates - a.rows(T_b, T_full - 1) = companion_reshaper(kf_end.a, n_m, n_q, T_end, n_lags); - a_tt.rows(T_b, T_full - 1) = companion_reshaper(kf_end.a_tt, n_m, n_q, T_end, n_lags); - - kf_end.smoother(arma::mat(1, n_vars*(n_lags + 1), arma::fill::zeros)); - alpha_t1 = companion_reshaper(kf_end.a_tT.row(0), n_m, n_q, 1, n_lags); - r_T = (alpha_t1 - kf_obj.a_t1) * arma::pinv(kf_obj.P_t1); - - kf_obj.smoother(r_T); - a_tT.rows(T_b, T_full - 1) = companion_reshaper(kf_end.a_tT, n_m, n_q, T_end, n_lags); - Z_tT.rows(T_b, T_full - 1) = kf_end.a_tT.cols(0, n_vars - 1); - - - } else { - kf_obj.smoother(arma::mat(1, n_q*(n_lags + 1), arma::fill::zeros)); - } - - a_tT.rows(0, T_b - 1) = kf_obj.a_tT; - Z_tT(arma::span(0, T_b - 1), arma::span(0, n_m-1)) = y_Tb.cols(0, n_m - 1); - Z_tT(arma::span(0, T_b - 1), arma::span(n_m, n_vars - 1)) = kf_obj.a_tT.cols(0, n_q - 1); - - return Rcpp::List::create(Rcpp::Named("a") = a, - Rcpp::Named("a_tt") = a_tt, - Rcpp::Named("a_tT") = a_tT, - Rcpp::Named("Z_tT") = Z_tT); -} - -//' @describeIn kf_ragged Simulation smoother -//' @param Z1 initial values, with \code{n_lags} rows and same number of columns as \code{y_} -//' @return For \code{kf_sim_smooth}, a matrix with the draw from the posterior distribution. -// [[Rcpp::export]] -arma::mat kf_sim_smooth(arma::mat y_, arma::mat Phi_, arma::mat Sigma_, arma::mat Lambda_, arma::mat Z1_, int n_q_, unsigned int T_b_) { - - unsigned int n_vars, n_lags, n_m, n_q, T_full; - n_vars = y_.n_cols; - n_lags = (Phi_.n_cols-1)/n_vars; - n_q = n_q_; - n_m = n_vars - n_q; - T_full = y_.n_rows; - - arma::mat Sigma_chol = chol(Sigma_).t(); - - // Initialize Z - // Instead of usin n_vars*n_lags columns, use n_vars and then extract multiple rows - arma::mat Z = arma::mat(T_full, n_vars).fill(NA_REAL); - Z.rows(0, n_lags - 1) = Z1_; - - // Create y_sim - arma::mat y_sim = arma::mat(T_full, n_vars).fill(NA_REAL); - - // Draw errors - arma::mat epsilon = arma::mat(T_full - n_lags, n_vars); - for (arma::uword i = 0; i < n_vars; i++) { - epsilon.col(i) = Rcpp::as(Rcpp::rnorm(T_full - n_lags)); - } - - epsilon = epsilon * Sigma_chol.t(); - - arma::rowvec Z_t1(n_vars*n_lags); - arma::mat Phi_no_c = Phi_.cols(0, n_vars*n_lags-1).t(); - arma::rowvec Phi_c = arma::vectorise(Phi_.col(n_vars*n_lags), 1); - arma::rowvec Z_t(n_vars); - arma::rowvec y_all(n_vars); - arma::uvec obs_vars; - arma::uvec t_vec(1); - arma::mat Lambda_t = Lambda_.t(); - arma::uword agg_length = Lambda_t.n_rows/Lambda_t.n_cols; - arma::mat Z_mean = arma::mat(T_full, n_vars, arma::fill::zeros); - y_sim.rows(0, n_lags - 1) = y_.rows(0, n_lags - 1); - - for (arma::uword t = n_lags; t < T_full; t++) { - obs_vars = find_finite(y_.row(t)); - t_vec(0) = t; - Z_t1 = arma::vectorise(arma::fliplr(Z.rows(t-n_lags, t-1).t())).t(); - Z_t = Z_t1 * Phi_no_c + Phi_c + epsilon.row(t - n_lags); - Z.row(t) = Z_t; - y_all.cols(0, n_m - 1) = Z_t.cols(0, n_m - 1); - y_all.cols(n_m, n_vars - 1) = arma::join_rows(Z_t.cols(n_m, n_vars - 1), arma::vectorise(arma::fliplr(Z.submat(t-agg_length+1, n_m, t-1, n_vars - 1).t())).t()) * Lambda_t; - y_sim(t_vec, obs_vars) = y_all.cols(obs_vars); - } - - arma::mat Phi_diff = Phi_; - Phi_diff.col(n_vars*n_lags) = arma::mat(n_vars, 1, arma::fill::zeros); - arma::mat y_diff = y_.rows(n_lags, T_full - 1) - y_sim.rows(n_lags, T_full - 1); - arma::mat Z1_diff = arma::mat(arma::size(Z1_), arma::fill::zeros); - Rcpp::List smooth_diff = kf_ragged(y_diff, Phi_diff, Sigma_, Lambda_, Z1_diff, n_q_, T_b_ - n_lags); - - Rcpp::NumericMatrix Z_tT = smooth_diff["Z_tT"]; - arma::mat Z_draw = Z.rows(n_lags, T_full - 1) + Rcpp::as(Z_tT); - - return Z_draw; -} diff --git a/src/mcmc_minn_csv.cpp b/src/mcmc_minn_csv.cpp deleted file mode 100644 index f8aea3a..0000000 --- a/src/mcmc_minn_csv.cpp +++ /dev/null @@ -1,528 +0,0 @@ -#include "mfbvar.h" -#include "ss_utils.h" -#include "minn_utils.h" -#include "update_csv.h" -#include "update_ng.h" -// [[Rcpp::export]] -void mcmc_minn_csv(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::cube& Z, arma::cube& Z_fcst, - arma::vec& phi, arma::vec& sigma, arma::mat& f, - const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& inv_prior_Pi_Omega, - const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, - const arma::mat & prior_S, const arma::mat& Z_1, - const double priorlatent0, const double phi_invvar, const double phi_meaninvvar, - const double prior_sigma2, const double prior_df, - arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, arma::uword n_thin, bool verbose) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - Progress p(n_reps, verbose); - - arma::mat Pi_i = Pi.slice(0); - arma::mat Sigma_i = Sigma.slice(0); - arma::mat X, XX, XX_inv, Pi_sample, post_Pi_Omega, post_Pi, Sigma_chol_inv; - arma::mat y_i = y_in_p; - arma::mat S, Pi_diff, post_S, Sigma_chol, x, y_scaled, X_scaled, eps, u, u_tilde; - - arma::vec f_i = f.row(0).t(); - arma::vec exp_sqrt_f = arma::exp(0.5 * f_i); - arma::vec errors = arma::vec(n_vars); - double phi_i = phi(0), sigma_i = sigma(0), vol_pred; - arma::imat r = arma::imat(n_T, n_vars); - double f0 = 0.0; - arma::mat mixprob = arma::mat(10*n_T, n_vars); - - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - Z_i.rows(0, n_lags - 1) = Z_1; - - arma::cube Sigma_chol_cube = arma::cube(n_vars, n_vars, n_T, arma::fill::zeros); - Sigma_chol = arma::chol(Sigma_i, "lower"); - int post_nu = n_T + n_vars + 2; - - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; - X = create_X(Z_i, n_lags); - } - - for (arma::uword i = 0; i < n_reps; ++i) { - Sigma_chol_cube.each_slice() = Sigma_chol; - for (arma::uword j = 0; j < n_T; ++j) { - Sigma_chol_cube.slice(j) = Sigma_chol_cube.slice(j) * exp_sqrt_f(j); - } - if (!single_freq) { - y_i = simsm_adaptive_sv(y_in_p, Pi_i, Sigma_chol_cube, Lambda_comp, Z_1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; - X = create_X(Z_i, n_lags); - } - - exp_sqrt_f = arma::exp(0.5 * f_i); - y_scaled = y_i; - y_scaled.each_col() /= exp_sqrt_f; - X_scaled = X; - X_scaled.each_col() /= exp_sqrt_f; - XX = X_scaled.t() * X_scaled; - - XX_inv = arma::inv_sympd(XX); - Pi_sample = XX_inv * (X_scaled.t() * y_scaled); - post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); - post_Pi = post_Pi_Omega * (Omega_Pi + X_scaled.t() * y_scaled); - S = arma::trans((y_scaled - X_scaled * Pi_sample)) * (y_scaled - X_scaled * Pi_sample); - Pi_diff = prior_Pi_mean - Pi_sample; - post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; - Sigma_i = rinvwish(post_nu, post_S); - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_chol_inv = arma::inv(arma::trimatl(Sigma_chol)); - Pi_i = rmatn(post_Pi.t(), post_Pi_Omega, Sigma_i); - - // Sample factor and related parameters here - eps = y_i - X * Pi_i.t(); - u = eps * Sigma_chol_inv.t(); - u_tilde = arma::log(arma::pow(u+0.0001, 2.0)); - update_csv(u_tilde, phi_i, sigma_i, f_i, f0, mixprob, r, priorlatent0, phi_invvar, - phi_meaninvvar, prior_sigma2, prior_df); - vol_pred = f_i(n_T-1); - if (i % n_thin == 0) { - if (n_fcst > 0) { - Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - vol_pred = phi_i * vol_pred + R::rnorm(0.0, sigma_i); - errors.imbue(norm_rand); - errors = errors * std::exp(0.5 * vol_pred); - x = create_X_t(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t(); - } - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - f.row(i/n_thin) = f_i.t(); - phi(i/n_thin) = phi_i; - sigma(i/n_thin) = sigma_i; - } - if (verbose) { - p.increment(); - } - } - -} - - -// [[Rcpp::export]] -void mcmc_ss_csv(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::cube& Z, - arma::cube& Z_fcst, - arma::vec& phi, arma::vec& sigma, arma::mat& f, - const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& inv_prior_Pi_Omega, - const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, - const arma::mat & prior_S, - const arma::mat & D_mat, const arma::mat & dt, const arma::mat & d1, - const arma::mat & d_fcst_lags, const arma::mat& inv_prior_psi_Omega, const arma::mat& inv_prior_psi_Omega_mean, - bool check_roots, const arma::mat& Z_1, - const double priorlatent0, const double phi_invvar, const double phi_meaninvvar, - const double prior_sigma2, const double prior_df, - arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, - bool verbose) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - Progress p(n_reps, verbose); - - arma::mat Pi_i = Pi.slice(0); - arma::mat Sigma_i = Sigma.slice(0); - arma::vec psi_i = psi.row(0).t(); - arma::mat X, XX, XX_inv, Pi_sample, post_Pi_Omega, post_Pi, Sigma_chol, Sigma_chol_inv; - arma::mat y_i = y_in_p; - arma::mat S, Pi_diff, post_S, x, mu_mat, mZ, mZ1, mX, y_scaled, X_scaled, eps, u, u_tilde; - - arma::vec f_i = f.row(0).t(); - arma::vec exp_sqrt_f = arma::exp(0.5 * f_i); - arma::vec errors = arma::vec(n_vars); - double phi_i = phi(0), sigma_i = sigma(0), vol_pred; - arma::imat r = arma::imat(n_T, n_vars); - double f0 = 0.0; - arma::mat mixprob = arma::mat(10*n_T, n_vars); - - arma::mat my = arma::mat(arma::size(y_in_p), arma::fill::zeros); - - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - arma::mat Z_i_demean = Z_i; - Z_i.rows(0, n_lags - 1) = Z_1; - - arma::mat Pi_i0 = arma::mat(n_vars, n_vars*n_lags+1, arma::fill::zeros); - arma::mat Pi_comp = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); - Pi_comp.submat(n_vars, 0, n_vars*n_lags - 1, n_vars*(n_lags-1) - 1) = arma::eye(n_vars*(n_lags-1), n_vars*(n_lags-1)); - - arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ, false, true); - mu_mat = dt * Psi_i.t(); - arma::uword n_Lambda = Lambda_comp.n_cols/Lambda_comp.n_rows; - arma::mat mu_long = arma::mat(n_Lambda+n_T, n_vars, arma::fill::zeros); - arma::rowvec Lambda_single = arma::rowvec(n_Lambda, arma::fill::zeros); - for (arma::uword i = 0; i < n_Lambda; ++i) { - Lambda_single(i) = Lambda_comp.at(0, i*n_q); - } - - arma::cube Sigma_chol_cube = arma::cube(n_vars, n_vars, n_T, arma::fill::zeros); - Sigma_chol = arma::chol(Sigma_i, "lower"); - int post_nu = n_T + n_vars + 2; - - // if single freq, we don't need to update - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_in_p; - } - - for (arma::uword i = 0; i < n_reps; ++i) { - Sigma_chol_cube.each_slice() = Sigma_chol; - for (arma::uword j = 0; j < n_T; ++j) { - Sigma_chol_cube.slice(j) = Sigma_chol_cube.slice(j) * exp_sqrt_f(j); - } - - if (!single_freq) { - my.cols(0, n_vars - n_q - 1) = y_in_p.cols(0, n_vars - n_q - 1) - mu_mat.cols(0, n_vars - n_q - 1); - mu_long.rows(0, n_Lambda-1) = d1.tail_rows(n_Lambda) * Psi_i.t(); - mu_long.rows(n_Lambda, n_T+n_Lambda-1) = mu_mat; - for (arma::uword j = 0; j < n_T; ++j) { - my.row(j).cols(n_vars - n_q - 1, n_vars - 1) = y_in_p.row(j).cols(n_vars - n_q - 1, n_vars - 1) - Lambda_single * mu_long.rows(j, j+n_Lambda-1).cols(n_vars - n_q - 1, n_vars - 1);// Needs fixing - } - } else { - // Even if single freq, mZ needs to be updated - mZ = y_in_p - mu_mat; - } - - mZ1 = Z_1 - d1 * Psi_i.t(); - Pi_i0.cols(1, n_vars*n_lags) = Pi_i; - - if (!single_freq) { - mZ = simsm_adaptive_sv(my, Pi_i0, Sigma_chol_cube, Lambda_comp, mZ1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; - } - - Z_i_demean.rows(0, n_lags - 1) = mZ1; - Z_i_demean.rows(n_lags, n_T + n_lags - 1) = mZ; - - mX = create_X_noint(Z_i_demean, n_lags); - exp_sqrt_f = arma::exp(0.5 * f_i); - y_scaled = mZ; - y_scaled.each_col() /= exp_sqrt_f; - X_scaled = mX; - X_scaled.each_col() /= exp_sqrt_f; - XX = X_scaled.t() * X_scaled; - - XX_inv = arma::inv_sympd(XX); - Pi_sample = XX_inv * (X_scaled.t() * y_scaled); - post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); - post_Pi = post_Pi_Omega * (Omega_Pi + X_scaled.t() * y_scaled); - S = arma::trans((y_scaled - X_scaled * Pi_sample)) * (y_scaled - X_scaled * Pi_sample); - Pi_diff = prior_Pi_mean - Pi_sample; - post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; - Sigma_i = rinvwish(post_nu, post_S); - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_chol_inv = arma::inv(arma::trimatl(Sigma_chol)); - - bool stationarity_check = false; - int num_try = 0, iter = 0; - double root = 1000; - while (stationarity_check == false) { - iter += 1; - Pi_i = rmatn(post_Pi.t(), post_Pi_Omega, Sigma_i); - if (check_roots) { - Pi_comp.rows(0, n_vars-1) = Pi_i; - root = max_eig_cpp(Pi_comp); - } else { - root = 0.0; - } - if (root < 1.0) { - stationarity_check = true; - num_try = iter; - } - if (iter == 1000) { - Rcpp::stop("Attemped to draw stationary Pi 1,000 times."); - } - } - - X = create_X_noint(Z_i, n_lags); - posterior_psi_csv(psi_i, mu_mat, Pi_i, D_mat, Sigma_chol_inv, exp_sqrt_f, inv_prior_psi_Omega, mZ + mu_mat, X, - inv_prior_psi_Omega_mean, dt, n_determ, n_vars, n_lags); - - mZ1 = Z_1 - d1 * Psi_i.t(); - Z_i_demean.rows(0, n_lags - 1) = mZ1; - Z_i_demean.rows(n_lags, n_T + n_lags - 1) = Z_i.rows(n_lags, n_T + n_lags - 1) - mu_mat; // Not the same as mu_mat b/c different mu_mat - X = create_X_noint(Z_i_demean, n_lags); - eps = Z_i_demean.rows(n_lags, n_T + n_lags - 1) - X * Pi_i.t(); - u = eps * Sigma_chol_inv.t(); - u_tilde = arma::log(arma::pow(u, 2.0)); - update_csv(u_tilde, phi_i, sigma_i, f_i, f0, mixprob, r, priorlatent0, phi_invvar, - phi_meaninvvar, prior_sigma2, prior_df); - - vol_pred = f_i(n_T-1); - if (verbose) { - p.increment(); - } - if (i % n_thin == 0) { - if (n_fcst > 0) { - Z_fcst_i.head_cols(n_lags) = Z_i_demean.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - vol_pred = phi_i * vol_pred + R::rnorm(0.0, sigma_i); - errors.imbue(norm_rand); - errors = errors * std::exp(0.5 * vol_pred); - x = create_X_t_noint(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t() + d_fcst_lags * Psi_i.t(); - } - - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - psi.row(i/n_thin) = psi_i.t(); - f.row(i/n_thin) = f_i.t(); - phi(i/n_thin) = phi_i; - sigma(i/n_thin) = sigma_i; - } - } -} - -// [[Rcpp::export]] -void mcmc_ssng_csv(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::vec& phi_mu, - arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, - arma::cube& Z_fcst, - arma::vec& phi, arma::vec& sigma, arma::mat& f, - const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& inv_prior_Pi_Omega, - const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, - const arma::mat & prior_S, - const arma::mat & D_mat, const arma::mat & dt, const arma::mat & d1, - const arma::mat & d_fcst_lags, const arma::vec& prior_psi_mean, - double c0, double c1, double s, - bool check_roots, const arma::mat& Z_1, - const double priorlatent0, const double phi_invvar, const double phi_meaninvvar, - const double prior_sigma2, const double prior_df, - arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, - bool verbose) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - Progress p(n_reps, verbose); - - arma::mat Pi_i = Pi.slice(0); - arma::mat Sigma_i = Sigma.slice(0); - arma::vec psi_i = psi.row(0).t(); - arma::mat y_i, X, XX, XX_inv, Pi_sample, post_Pi_Omega, post_Pi, Sigma_chol, Sigma_chol_inv; - arma::mat S, Pi_diff, post_S, x, mu_mat, mZ, mZ1, mX, y_scaled, X_scaled, eps, u, u_tilde; - arma::mat my = arma::mat(arma::size(y_in_p), arma::fill::zeros); - - // Stochastic volatility - arma::vec f_i = f.row(0).t(); - arma::vec exp_sqrt_f = arma::exp(0.5 * f_i); - arma::vec errors = arma::vec(n_vars); - double phi_i = phi(0), sigma_i = sigma(0), vol_pred; - arma::imat r = arma::imat(n_T, n_vars); - double f0 = 0.0; - arma::mat mixprob = arma::mat(10*n_T, n_vars); - - // Steady state - arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ, false, true); - mu_mat = dt * Psi_i.t(); - arma::uword n_Lambda = Lambda_comp.n_cols/Lambda_comp.n_rows; - arma::mat mu_long = arma::mat(n_Lambda+n_T, n_vars, arma::fill::zeros); - arma::rowvec Lambda_single = arma::rowvec(n_Lambda, arma::fill::zeros); - for (arma::uword i = 0; i < n_Lambda; ++i) { - Lambda_single(i) = Lambda_comp.at(0, i*n_q); - } - - arma::uword nm = n_vars*n_determ; - double lambda_mu_i = lambda_mu(0); - double phi_mu_i = phi_mu(0); - arma::vec omega_i = omega.row(0).t(); - arma::mat inv_prior_psi_Omega = arma::diagmat(omega_i); - arma::vec inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; - double M, batch = 1.0; - arma::running_stat stats; - double accept = 0.0; - bool adaptive_mh = false; - double s_prop; - if (s < 0) { - M = std::abs(s); - s = 1.0; - adaptive_mh = true; - } - arma::vec min_vec(2); - min_vec(0) = 0.01; - - // Mixed frequencies - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - arma::mat Z_i_demean = Z_i; - Z_i.rows(0, n_lags - 1) = Z_1; - - // Regression parameters - arma::mat Pi_i0 = arma::mat(n_vars, n_vars*n_lags+1, arma::fill::zeros); - arma::mat Pi_comp = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); - Pi_comp.submat(n_vars, 0, n_vars*n_lags - 1, n_vars*(n_lags-1) - 1) = arma::eye(n_vars*(n_lags-1), n_vars*(n_lags-1)); - - // Covariance matrix - arma::cube Sigma_chol_cube = arma::cube(n_vars, n_vars, n_T, arma::fill::zeros); - Sigma_chol = arma::chol(Sigma_i, "lower"); - int post_nu = n_T + n_vars + 2; - - // if single freq, we don't need to update - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_in_p; - } - - for (arma::uword i = 0; i < n_reps; ++i) { - Sigma_chol_cube.each_slice() = Sigma_chol; - for (arma::uword j = 0; j < n_T; ++j) { - Sigma_chol_cube.slice(j) = Sigma_chol_cube.slice(j) * exp_sqrt_f(j); - } - - if (!single_freq) { - update_demean(my, mu_long, y_in_p, mu_mat, d1, Psi_i, Lambda_single, n_vars, - n_q, n_Lambda, n_T); - } else { - // Even if single freq, mZ needs to be updated - mZ = y_in_p - mu_mat; - } - - mZ1 = Z_1 - d1 * Psi_i.t(); - Pi_i0.cols(1, n_vars*n_lags) = Pi_i; - - if (!single_freq) { - mZ = simsm_adaptive_cv(my, Pi_i0, Sigma_chol, Lambda_comp, mZ1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; - } - - Z_i_demean.rows(0, n_lags - 1) = mZ1; - Z_i_demean.rows(n_lags, n_T + n_lags - 1) = mZ; - - mX = create_X_noint(Z_i_demean, n_lags); - exp_sqrt_f = arma::exp(0.5 * f_i); - y_scaled = mZ; - y_scaled.each_col() /= exp_sqrt_f; - X_scaled = mX; - X_scaled.each_col() /= exp_sqrt_f; - XX = X_scaled.t() * X_scaled; - - XX_inv = arma::inv_sympd(XX); - Pi_sample = XX_inv * (X_scaled.t() * y_scaled); - post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); - post_Pi = post_Pi_Omega * (Omega_Pi + X_scaled.t() * y_scaled); - S = arma::trans((y_scaled - X_scaled * Pi_sample)) * (y_scaled - X_scaled * Pi_sample); - Pi_diff = prior_Pi_mean - Pi_sample; - post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; - Sigma_i = rinvwish(post_nu, post_S); - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_chol_inv = arma::inv(arma::trimatl(Sigma_chol)); - - bool stationarity_check = false; - int num_try = 0, iter = 0; - double root = 1000; - while (stationarity_check == false) { - iter += 1; - Pi_i = rmatn(post_Pi.t(), post_Pi_Omega, Sigma_i); - if (check_roots) { - Pi_comp.rows(0, n_vars-1) = Pi_i; - root = max_eig_cpp(Pi_comp); - } else { - root = 0.0; - } - if (root < 1.0) { - stationarity_check = true; - num_try = iter; - } - if (iter == 1000) { - Rcpp::stop("Attemped to draw stationary Pi 1,000 times."); - } - } - - update_ng(phi_mu_i, lambda_mu_i, omega_i, nm, c0, c1, s, psi_i, prior_psi_mean, accept); - if (adaptive_mh) { - stats(accept); - if (i % 100 == 0) { - batch += 1.0; - min_vec(1) = std::pow(batch, -0.5); - if (stats.mean() > 0.44) { - s_prop = log(s) + arma::min(min_vec); - if (s_prop < M){ - s = std::exp(s_prop); - } - } else { - s_prop = log(s) - arma::min(min_vec); - if (s_prop > -M){ - s = std::exp(s_prop); - } - } - stats.reset(); - } - } - inv_prior_psi_Omega = arma::diagmat(1/omega_i); - inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; - X = create_X_noint(Z_i, n_lags); - posterior_psi_csv(psi_i, mu_mat, Pi_i, D_mat, Sigma_chol_inv, exp_sqrt_f, inv_prior_psi_Omega, mZ + mu_mat, X, - inv_prior_psi_Omega_mean, dt, n_determ, n_vars, n_lags); - - mZ1 = Z_1 - d1 * Psi_i.t(); - Z_i_demean.rows(0, n_lags - 1) = mZ1; - Z_i_demean.rows(n_lags, n_T + n_lags - 1) = Z_i.rows(n_lags, n_T + n_lags - 1) - mu_mat; // Not the same as mu_mat b/c different mu_mat - X = create_X_noint(Z_i_demean, n_lags); - eps = Z_i_demean.rows(n_lags, n_T + n_lags - 1) - X * Pi_i.t(); - u = eps * Sigma_chol_inv.t(); - u_tilde = arma::log(arma::pow(u, 2.0)); - update_csv(u_tilde, phi_i, sigma_i, f_i, f0, mixprob, r, priorlatent0, phi_invvar, - phi_meaninvvar, prior_sigma2, prior_df); - - vol_pred = f_i(n_T-1); - if (verbose) { - p.increment(); - } - if (i % n_thin == 0) { - if (n_fcst > 0) { - Z_fcst_i.head_cols(n_lags) = Z_i_demean.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - vol_pred = phi_i * vol_pred + R::rnorm(0.0, sigma_i); - errors.imbue(norm_rand); - errors = errors * std::exp(0.5 * vol_pred); - x = create_X_t_noint(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t() + d_fcst_lags * Psi_i.t(); - } - - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - psi.row(i/n_thin) = psi_i.t(); - f.row(i/n_thin) = f_i.t(); - phi(i/n_thin) = phi_i; - sigma(i/n_thin) = sigma_i; - phi_mu(i/n_thin) = phi_mu_i; - lambda_mu(i/n_thin) = lambda_mu_i; - omega.row(i/n_thin) = omega_i.t(); - } - } -} - - diff --git a/src/mcmc_minn_diffuse.cpp b/src/mcmc_minn_diffuse.cpp deleted file mode 100644 index 741736a..0000000 --- a/src/mcmc_minn_diffuse.cpp +++ /dev/null @@ -1,91 +0,0 @@ -#include "mfbvar.h" -#include "minn_utils.h" -// [[Rcpp::export]] -void mcmc_minn_diffuse(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::cube& Z, arma::cube& Z_fcst, - const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& Omega_Pi, - const arma::mat& Z_1, - arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, - arma::uword n_thin, bool verbose) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - - Progress p(n_reps, verbose); - arma::vec Pi_vec = arma::vec(Pi.begin(), n_vars*(n_vars*n_lags+1)); - arma::mat Pi_i = Pi.slice(0); //arma::mat(Pi_vec.begin(), n_vars, n_vars*n_lags + 1, false, true); - arma::mat Sigma_i = Sigma.slice(0); - arma::mat y_i = y_in_p; - arma::vec errors = arma::vec(n_vars); - arma::mat X, post_Pi_Omega_inv, L, b, u1, u2, u4, resid, x; - arma::mat u3 = arma::vec(n_vars*(n_vars*n_lags + 1)); - arma::mat post_S, Sigma_chol, Sigma_inv; - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - Z_i.rows(0, n_lags - 1) = Z_1; - - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; - X = create_X(Z_i, n_lags); - } - - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_inv = arma::inv_sympd(Sigma_i); - arma::vec prior_Pi_Omega_vec_inv = 1.0 / arma::vectorise(prior_Pi_Omega); - - for (arma::uword i = 0; i < n_reps; ++i) { - if (!single_freq) { - y_i = simsm_adaptive_cv(y_in_p, Pi_i, Sigma_chol, Lambda_comp, Z_1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; - X = create_X(Z_i, n_lags); - } - - // Pi - post_Pi_Omega_inv = arma::kron(Sigma_inv, X.t() * X); - post_Pi_Omega_inv.diag() += prior_Pi_Omega_vec_inv; - L = arma::chol(post_Pi_Omega_inv, "lower"); - b = arma::vectorise(X.t() * y_i * Sigma_inv + Omega_Pi); - u1 = arma::solve(arma::trimatl(L), b); - u2 = arma::solve(arma::trimatu(L.t()), u1); - u3.imbue(norm_rand); - u4 = arma::solve(arma::trimatu(L.t()), u3); - Pi_vec = u2 + u4; - Pi_i = arma::trans(arma::reshape(Pi_vec, n_vars*n_lags+1, n_vars)); - resid = y_i - X * Pi_i.t(); // Pi_vec and Pi_i use the same memory - // Sigma - post_S = resid.t() * resid; - Sigma_i = rinvwish(n_T, post_S); - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_inv = arma::inv_sympd(Sigma_i); - - if (i % n_thin == 0) { - if (n_fcst > 0) { - - Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - errors.imbue(norm_rand); - x = create_X_t(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t(); - } - - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - } - if (verbose) { - p.increment(); - } - } - -} - - diff --git a/src/mcmc_minn_fsv.cpp b/src/mcmc_minn_fsv.cpp new file mode 100644 index 0000000..fd2d301 --- /dev/null +++ b/src/mcmc_minn_fsv.cpp @@ -0,0 +1,448 @@ +#include "mfbvar.h" +#include "minn_utils.h" +#include "ss_utils.h" +#include "update_fsv.h" +#include "mvn.h" +#include "mvn_par.h" +#include "update_ng.h" +#include "update_dl.h" +#include +// [[Rcpp::export]] +void mcmc_minn_fsv(const arma::mat & y_in_p, + arma::cube& Pi, arma::cube& Z, arma::cube& Z_fcst, + arma::mat& mu, arma::mat& phi, arma::mat& sigma, + arma::cube& f, arma::cube& facload, arma::cube& h, + arma::mat & aux, arma::vec & global, arma::mat & local, + arma::vec & slice, + const arma::mat& Lambda_comp, arma::mat prior_Pi_Omega, + const arma::vec& prior_Pi_AR1, const arma::mat& Z_1, + double bmu, double Bmu, double a0idi, double b0idi, double a0fac, double b0fac, + const Rcpp::NumericVector & Bsigma, double B011inv, double B022inv, + const Rcpp::NumericVector & priorh0, const arma::imat & armarestr, + const arma::mat & armatau2, // armatau2 is the matrix with prior variance of factor loadings + arma::uword n_fac, arma::uword n_reps, arma::uword n_burnin, + arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, + arma::uword n_T, arma::uword n_fcst, arma::uword n_thin, bool verbose, + const double a, bool gig) { + bool single_freq; + if (n_q == 0 || n_q == n_vars) { + single_freq = true; + } else { + single_freq = false; + } + + Progress p(n_reps, verbose); + arma::mat Pi_i = Pi.slice(0); + arma::mat X; + arma::mat y_i = y_in_p; + arma::mat x; + arma::vec vol_pred; + + + // fsv + Rcpp::NumericMatrix curpara = Rcpp::NumericMatrix(3, n_vars + n_fac); + arma::mat curpara_arma(curpara.begin(), curpara.nrow(), curpara.ncol(), false); + curpara_arma.fill(0.0); + curpara_arma.row(0).cols(0, n_vars - 1) = mu.col(0).t(); + curpara_arma.row(1) = phi.col(0).t(); + curpara_arma.row(2) = sigma.col(0).t(); + + arma::vec mu_i = mu.col(0); + arma::vec phi_i = phi.col(0); + arma::vec sigma_i = sigma.col(0); + + arma::mat armaf = f.slice(0); + arma::mat armafacload = facload.slice(0); + arma::mat armah = h.slice(0); + arma::mat cc_i = armaf.t() * armafacload.t(); + + arma::vec armah0 = arma::vec(n_vars + n_fac); + + arma::mat Sig_i, y_hat, latent_nofac, h_j, X_j, y_j; + arma::vec error_pred; + arma::vec errors_sv = arma::vec(n_vars + n_fac); + arma::vec errors_var = arma::vec(n_vars + n_fac); + + arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); + arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); + Z_i.rows(0, n_lags - 1) = Z_1; + + arma::mat eps; + bool rue = true; + if ((n_vars*n_lags) > 1.1 * n_T & arma::range(prior_Pi_AR1) < 1e-12) { + rue = false; + eps = arma::mat(n_T+n_vars*n_lags+1, n_vars); + } else { + eps = arma::mat(n_vars*n_lags+1, n_vars); + } + + if (single_freq) { + Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; + X = create_X(Z_i, n_lags); + } + + // DL + bool dl = false; + double global_i; + if (a > 0) { + dl = true; + global_i = global(0); + } + arma::vec aux_i = aux.row(0).t(); + arma::vec local_i = local.row(0).t(); + + if (dl) { + prior_Pi_Omega.rows(1, n_vars*n_lags) = arma::reshape(aux_i % arma::pow(global_i * local_i, 2.0), n_vars*n_lags, n_vars); + } + + arma::mat curpara_old, armafacload_old, armaf_old; + + for (arma::uword i = 0; i < n_reps + n_burnin; ++i) { + if (!single_freq) { + Sig_i = arma::exp(0.5 * armah.head_cols(n_vars)); + y_i = simsm_adaptive_univariate(y_in_p, Pi_i, Sig_i, Lambda_comp, Z_1, n_q, T_b, cc_i); + Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; + X = create_X(Z_i, n_lags); + } + + y_hat = y_i - X * Pi_i.t(); + + curpara_old = curpara_arma; + armafacload_old = armafacload; + armaf_old = armaf; + + update_fsv(armafacload, armaf, armah, armah0, curpara, armatau2, y_hat.t(), + bmu, Bmu, a0idi, b0idi, a0fac, b0fac, Bsigma, B011inv, B022inv, + priorh0, armarestr); + + if ((i+1) % n_thin == 0 && i >= n_burnin) { + mu_i = curpara_old.row(0).t(); + phi_i = curpara_old.row(1).t(); + sigma_i = curpara_old.row(2).t(); + if (n_fcst > 0) { + vol_pred = armah.tail_rows(1).t(); + Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t(); + for (arma::uword h = 0; h < n_fcst; ++h) { + errors_sv.imbue(norm_rand); + errors_var.imbue(norm_rand); + vol_pred = mu_i + phi_i % (vol_pred - mu_i) + sigma_i % errors_sv; // Twice because we first need it for the volatility, then for the VAR + error_pred = arma::exp(0.5 * vol_pred) % errors_var; + x = create_X_t(Z_fcst_i.cols(0+h, n_lags-1+h).t()); + Z_fcst_i.col(n_lags + h) = Pi_i * x + armafacload_old * error_pred.tail_rows(n_fac) + error_pred.head_rows(n_vars); + } + Z_fcst.slice((i-n_burnin)/n_thin) = Z_fcst_i.t(); + } + + Z.slice((i-n_burnin)/n_thin) = Z_i; + Pi.slice((i-n_burnin)/n_thin) = Pi_i; + f.slice((i-n_burnin)/n_thin) = armaf_old; + facload.slice((i-n_burnin)/n_thin) = armafacload_old; + h.slice((i-n_burnin)/n_thin) = armah; + mu.col((i-n_burnin)/n_thin) = mu_i.head(n_vars); + phi.col((i-n_burnin)/n_thin) = phi_i; + sigma.col((i-n_burnin)/n_thin) = sigma_i; + if (dl) { + global((i-n_burnin)/n_thin) = global_i; + aux.row((i-n_burnin)/n_thin) = aux_i.t(); + local.row((i-n_burnin)/n_thin) = local_i.t(); + } + } + + + cc_i = armaf.t() * armafacload.t(); // Common component + latent_nofac = y_i - cc_i; + + eps.imbue(norm_rand); + arma::mat output(n_vars*n_lags+1, n_vars); + if (rue) { + Pi_parallel_rue Pi_parallel_i(output, latent_nofac, X, prior_Pi_Omega, eps, + armah, prior_Pi_AR1, n_T, n_vars, n_lags); + RcppParallel::parallelFor(0, n_vars, Pi_parallel_i); + } else { + Pi_parallel_bcm Pi_parallel_i(output, latent_nofac, X, prior_Pi_Omega, eps, + armah, n_T, n_vars, n_lags); + RcppParallel::parallelFor(0, n_vars, Pi_parallel_i); + } + + Pi_i = output.t(); + + if (dl) { + update_dl(prior_Pi_Omega, aux_i, local_i, global_i, Pi_i.t(), n_vars, n_lags, a, slice, gig, true); + } + + if (verbose) { + p.increment(); + } + + if ((i+1) % 100 == 0) { + std::time_t t = std::time(0); // get time now + std::tm* now = std::localtime(&t); + Rcpp::Rcout << "Iteration " << i+1 << " at " << std::setw(2) << std::setfill('0') << now->tm_hour << ':' << std::setw(2) << std::setfill('0') << now->tm_min <<':'<< std::setw(2) << std::setfill('0') << now->tm_sec << std::endl; + } + + + + } + +} + +// [[Rcpp::export]] +void mcmc_ss_fsv(const arma::mat & y_in_p, + arma::cube& Pi, arma::mat& psi, arma::vec& phi_mu, + arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, arma::cube& Z_fcst, + arma::mat& mu, arma::mat& phi, arma::mat& sigma, + arma::cube& f, arma::cube& facload, arma::cube& h, + const arma::mat& Lambda_comp, arma::mat prior_Pi_Omega, + const arma::vec& prior_Pi_AR1, + const arma::mat & D_mat, const arma::mat & dt, const arma::mat & d1, + const arma::mat & d_fcst_lags, const arma::vec& prior_psi_mean, + double c0, double c1, double s, bool check_roots, + const arma::mat& Z_1, + double bmu, double Bmu, double a0idi, double b0idi, double a0fac, double b0fac, + const Rcpp::NumericVector & Bsigma, double B011inv, double B022inv, + const Rcpp::NumericVector & priorh0, const arma::imat & armarestr, + const arma::mat & armatau2, // armatau2 is the matrix with prior variance of factor loadings + arma::uword n_fac, arma::uword n_reps, + arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, + arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, arma::uword n_thin, + bool verbose, bool ssng) { + bool single_freq; + if (n_q == 0 || n_q == n_vars) { + single_freq = true; + } else { + single_freq = false; + } + + Progress p(n_reps, verbose); + + arma::mat Pi_i = Pi.slice(0); + arma::vec psi_i = psi.row(0).t(); + arma::mat X; + arma::mat y_i = y_in_p; + arma::mat x; + arma::vec vol_pred; + + + // fsv + Rcpp::NumericMatrix curpara = Rcpp::NumericMatrix(3, n_vars + n_fac); + arma::mat curpara_arma(curpara.begin(), curpara.nrow(), curpara.ncol(), false); + curpara_arma.fill(0.0); + curpara_arma.row(0).cols(0, n_vars - 1) = mu.col(0).t(); + curpara_arma.row(1) = phi.col(0).t(); + curpara_arma.row(2) = sigma.col(0).t(); + + arma::vec mu_i = mu.col(0); + arma::vec phi_i = phi.col(0); + arma::vec sigma_i = sigma.col(0); + + arma::mat armaf = f.slice(0); + arma::mat armafacload = facload.slice(0); + arma::mat armah = h.slice(0); + arma::mat cc_i = armaf.t() * armafacload.t(); + + arma::vec armah0 = arma::vec(n_vars + n_fac); + + arma::mat Sig_i, y_hat, latent_nofac, h_j, X_j, y_j; + arma::vec error_pred; + arma::vec errors_sv = arma::vec(n_vars + n_fac); + arma::vec errors_var = arma::vec(n_vars + n_fac); + + arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); + arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); + Z_i.rows(0, n_lags - 1) = Z_1; + + arma::mat eps; + bool rue = true; + if ((n_vars*n_lags) > 1.1 * n_T & arma::range(prior_Pi_AR1) < 1e-12) { + rue = false; + eps = arma::mat(n_T+n_vars*n_lags, n_vars); + } else { + eps = arma::mat(n_vars*n_lags, n_vars); + } + + arma::mat output(n_vars*n_lags, n_vars); + + + // ss + + arma::mat mu_mat, mZ, mZ1, mX; + arma::mat my = arma::mat(arma::size(y_in_p), arma::fill::zeros); + arma::mat Z_i_demean = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); + arma::mat Pi_i0 = arma::mat(n_vars, n_vars*n_lags+1, arma::fill::zeros); + arma::mat Pi_comp = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); + Pi_comp.submat(n_vars, 0, n_vars*n_lags - 1, n_vars*(n_lags-1) - 1) = arma::eye(n_vars*(n_lags-1), n_vars*(n_lags-1)); + + arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ, false, true); + mu_mat = dt * Psi_i.t(); + arma::uword n_Lambda = Lambda_comp.n_cols/Lambda_comp.n_rows; + arma::mat mu_long = arma::mat(n_Lambda+n_T, n_vars, arma::fill::zeros); + arma::rowvec Lambda_single = arma::rowvec(n_Lambda, arma::fill::zeros); + for (arma::uword i = 0; i < n_Lambda; ++i) { + Lambda_single(i) = Lambda_comp.at(0, i*n_q); + } + arma::mat idivar = arma::mat(armah.begin_col(0), armah.n_rows, n_vars, false); + + // ssng + arma::uword nm = n_vars*n_determ; + double lambda_mu_i, phi_mu_i, accept, s_prop, M, batch; + bool adaptive_mh; + if (ssng) { + lambda_mu_i = lambda_mu(0); + phi_mu_i = phi_mu(0); + accept = 0.0; + batch = 1.0; + + adaptive_mh = false; + + if (s < 0) { + M = std::abs(s); + s = 1.0; + adaptive_mh = true; + } + } + + arma::vec omega_i = omega.row(0).t(); + arma::mat inv_prior_psi_Omega = arma::diagmat(omega_i); + arma::vec inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; + arma::running_stat stats; + + arma::vec min_vec(2); + min_vec(0) = 0.01; + + if (single_freq) { + Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; + } + + for (arma::uword i = 0; i < n_reps; ++i) { + if (!single_freq) { + update_demean(my, mu_long, y_in_p, mu_mat, d1, Psi_i, Lambda_single, n_vars, + n_q, n_Lambda, n_T); + } else { + // Even if single freq, mZ needs to be updated + mZ = y_in_p - mu_mat; + } + + mZ1 = Z_1 - d1 * Psi_i.t(); + Pi_i0.cols(1, n_vars*n_lags) = Pi_i; + + if (!single_freq) { + Sig_i = arma::exp(0.5 * armah.head_cols(n_vars)); + mZ = simsm_adaptive_univariate(my, Pi_i0, Sig_i, Lambda_comp, mZ1, n_q, T_b, cc_i); + Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; + } + Z_i_demean.rows(0, n_lags - 1) = mZ1; + Z_i_demean.rows(n_lags, n_T + n_lags - 1) = mZ; + + mX = create_X_noint(Z_i_demean, n_lags); + + y_hat = mZ - mX * Pi_i.t(); + + if ((i+1) % n_thin == 0) { + mu_i = curpara_arma.row(0).t(); + phi_i = curpara_arma.row(1).t(); + sigma_i = curpara_arma.row(2).t(); // sigma, not sigma2 + if (n_fcst > 0) { + vol_pred = armah.tail_rows(1).t(); + Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t() - mu_mat.tail_rows(n_lags).t(); + for (arma::uword h = 0; h < n_fcst; ++h) { + errors_sv.imbue(norm_rand); + errors_var.imbue(norm_rand); + vol_pred = mu_i + phi_i % (vol_pred - mu_i) + sigma_i % errors_sv; // Twice because we first need it for the volatility, then for the VAR + error_pred = arma::exp(0.5 * vol_pred) % errors_var; + x = create_X_t_noint(Z_fcst_i.cols(0+h, n_lags-1+h).t()); + Z_fcst_i.col(n_lags + h) = Pi_i * x + armafacload * error_pred.tail_rows(n_fac) + error_pred.head_rows(n_vars); + } + Z_fcst.slice(i/n_thin) = Z_fcst_i.t() + d_fcst_lags * Psi_i.t(); + } + + + Z.slice(i/n_thin) = Z_i; + Pi.slice(i/n_thin) = Pi_i; + psi.row(i/n_thin) = psi_i.t(); + + f.slice(i/n_thin) = armaf; + facload.slice(i/n_thin) = armafacload; + h.slice(i/n_thin) = armah; + + + mu.col(i/n_thin) = mu_i.head(n_vars); + phi.col(i/n_thin) = phi_i; + sigma.col(i/n_thin) = sigma_i; + } + update_fsv(armafacload, armaf, armah, armah0, curpara, armatau2, y_hat.t(), + bmu, Bmu, a0idi, b0idi, a0fac, b0fac, Bsigma, B011inv, B022inv, + priorh0, armarestr); + + cc_i = armaf.t() * armafacload.t(); // Common component + latent_nofac = mZ - cc_i; + + bool stationarity_check = false; + int num_try = 0, iter = 0; + double root = 1000; + while (stationarity_check == false) { + iter += 1; + eps.imbue(norm_rand); + if (rue) { + Pi_parallel_rue Pi_parallel_i(output, latent_nofac, mX, prior_Pi_Omega, eps, + armah, prior_Pi_AR1, n_T, n_vars, n_lags); + RcppParallel::parallelFor(0, n_vars, Pi_parallel_i); + } else { + Pi_parallel_bcm Pi_parallel_i(output, latent_nofac, mX, prior_Pi_Omega, eps, + armah, n_T, n_vars, n_lags); + RcppParallel::parallelFor(0, n_vars, Pi_parallel_i); + } + Pi_i = output.t(); + if (check_roots) { + Pi_comp.rows(0, n_vars-1) = Pi_i; + root = max_eig_cpp(Pi_comp); + } else { + root = 0.0; + } + if (root < 1.0) { + stationarity_check = true; + num_try = iter; + } + if (iter == 1000) { + Rcpp::stop("Attemped to draw stationary Pi 1,000 times."); + } + } + if (ssng) { + update_ng(phi_mu_i, lambda_mu_i, omega_i, nm, c0, c1, s, psi_i, prior_psi_mean, accept); + if (adaptive_mh) { + stats(accept); + if (i % 100 == 0) { + batch += 1.0; + min_vec(1) = std::pow(batch, -0.5); + if (stats.mean() > 0.44) { + s_prop = log(s) + arma::min(min_vec); + if (s_prop < M){ + s = std::exp(s_prop); + } + } else { + s_prop = log(s) - arma::min(min_vec); + if (s_prop > -M){ + s = std::exp(s_prop); + } + } + stats.reset(); + } + } + + inv_prior_psi_Omega = arma::diagmat(1/omega_i); + inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; + } + X = create_X_noint(Z_i, n_lags); + posterior_psi_fsv(psi_i, mu_mat, Pi_i, D_mat, idivar, + inv_prior_psi_Omega, Z_i.rows(n_lags, n_T + n_lags - 1), X, + armafacload, armaf, inv_prior_psi_Omega_mean, + dt, n_determ, n_vars, n_lags); + + + if (verbose) { + p.increment(); + } + } + +} + + diff --git a/src/mcmc_minn_iw.cpp b/src/mcmc_minn_iw.cpp deleted file mode 100644 index dd5c324..0000000 --- a/src/mcmc_minn_iw.cpp +++ /dev/null @@ -1,90 +0,0 @@ -#include "mfbvar.h" -#include "minn_utils.h" -// [[Rcpp::export]] -void mcmc_minn_iw(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::cube& Z, arma::cube& Z_fcst, - const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& inv_prior_Pi_Omega, - const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, - const arma::mat & prior_S, const arma::mat& Z_1, - arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, - arma::uword n_thin, bool verbose, int prior_nu) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - - Progress p(n_reps, verbose); - arma::mat Pi_i = Pi.slice(0); - arma::mat Sigma_i = Sigma.slice(0); - arma::mat y_i = y_in_p; - arma::vec errors = arma::vec(n_vars); - arma::mat X, XX, XX_inv, Pi_sample, post_Pi_Omega, post_Pi; - arma::mat S, Pi_diff, post_S, Sigma_chol, x; - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - Z_i.rows(0, n_lags - 1) = Z_1; - int post_nu = n_T + n_vars + prior_nu; - - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; - X = create_X(Z_i, n_lags); - XX = X.t() * X; - XX_inv = arma::inv_sympd(XX); - Pi_sample = XX_inv * (X.t() * y_i); - post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); - post_Pi = post_Pi_Omega * (Omega_Pi + X.t() * y_i); - S = arma::trans((y_i - X * Pi_sample)) * (y_i - X * Pi_sample); - Pi_diff = prior_Pi_mean - Pi_sample; - post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; - } - - Sigma_chol = arma::chol(Sigma_i, "lower"); - - for (arma::uword i = 0; i < n_reps; ++i) { - if (!single_freq) { - y_i = simsm_adaptive_cv(y_in_p, Pi_i, Sigma_chol, Lambda_comp, Z_1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; - X = create_X(Z_i, n_lags); - XX = X.t() * X; - XX_inv = arma::inv_sympd(XX); - Pi_sample = XX_inv * (X.t() * y_i); - post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); - post_Pi = post_Pi_Omega * (Omega_Pi + X.t() * y_i); - S = arma::trans((y_i - X * Pi_sample)) * (y_i - X * Pi_sample); - Pi_diff = prior_Pi_mean - Pi_sample; - post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; - } - Sigma_i = rinvwish(post_nu, post_S); - Sigma_chol = arma::chol(Sigma_i, "lower"); - Pi_i = rmatn(post_Pi.t(), post_Pi_Omega, Sigma_i); - - if (i % n_thin == 0) { - if (n_fcst > 0) { - - Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - errors.imbue(norm_rand); - x = create_X_t(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t(); - } - - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - } - if (verbose) { - p.increment(); - } - } - -} - - diff --git a/src/mcmc_ss_diffuse.cpp b/src/mcmc_ss_diffuse.cpp deleted file mode 100644 index 96c8ebf..0000000 --- a/src/mcmc_ss_diffuse.cpp +++ /dev/null @@ -1,145 +0,0 @@ -#include "mfbvar.h" -#include "ss_utils.h" -// [[Rcpp::export]] -void mcmc_ss_diffuse(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::cube& Z, - arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& Omega_Pi, - const arma::mat & D_mat, const arma::mat & dt, const arma::mat & d1, - const arma::mat & d_fcst_lags, const arma::mat& inv_prior_psi_Omega, const arma::mat& inv_prior_psi_Omega_mean, - bool check_roots, const arma::mat& Z_1, arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, - arma::uword n_thin, bool verbose) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - Progress p(n_reps, verbose); - - arma::vec Pi_vec = arma::vec(Pi.begin(), n_vars*(n_vars*n_lags)); - arma::mat Pi_i = Pi.slice(0); - arma::mat Sigma_i = Sigma.slice(0); - arma::vec psi_i = psi.row(0).t(); - arma::mat y_i = y_in_p; - arma::mat X, post_Pi_Omega_inv, L, b, u1, u2, u4, resid, x; - arma::mat post_S, mu_mat, mZ, mZ1, mX, Sigma_chol, Sigma_inv; - arma::mat u3 = arma::vec(n_vars*(n_vars*n_lags)); - arma::mat my = arma::mat(arma::size(y_in_p), arma::fill::zeros); - - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - arma::mat Z_i_demean = Z_i; - Z_i.rows(0, n_lags - 1) = Z_1; - - arma::mat Pi_i0 = arma::mat(n_vars, n_vars*n_lags+1, arma::fill::zeros); - arma::mat Pi_comp = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); - Pi_comp.submat(n_vars, 0, n_vars*n_lags - 1, n_vars*(n_lags-1) - 1) = arma::eye(n_vars*(n_lags-1), n_vars*(n_lags-1)); - - arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ, false, true); - mu_mat = dt * Psi_i.t(); - arma::uword n_Lambda = Lambda_comp.n_cols/Lambda_comp.n_rows; - arma::mat mu_long = arma::mat(n_Lambda+n_T, n_vars, arma::fill::zeros); - arma::rowvec Lambda_single = arma::rowvec(n_Lambda, arma::fill::zeros); - for (arma::uword i = 0; i < n_Lambda; ++i) { - Lambda_single(i) = Lambda_comp.at(0, i*n_q); - } - - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_inv = arma::inv_sympd(Sigma_i); - arma::vec prior_Pi_Omega_vec_inv = 1.0 / arma::vectorise(prior_Pi_Omega); - - // if single freq, we don't need to update - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_in_p; - } - - for (arma::uword i = 0; i < n_reps; ++i) { - - if (!single_freq) { - update_demean(my, mu_long, y_in_p, mu_mat, d1, Psi_i, Lambda_single, n_vars, - n_q, n_Lambda, n_T); - } else { - // Even if single freq, mZ needs to be updated - mZ = y_in_p - mu_mat; - } - - mZ1 = Z_1 - d1 * Psi_i.t(); - Pi_i0.cols(1, n_vars*n_lags) = Pi_i; - - if (!single_freq) { - mZ = simsm_adaptive_cv(my, Pi_i0, Sigma_chol, Lambda_comp, mZ1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; - } - - Z_i_demean.rows(0, n_lags - 1) = mZ1; - Z_i_demean.rows(n_lags, n_T + n_lags - 1) = mZ; - - mX = create_X_noint(Z_i_demean, n_lags); - // Pi - post_Pi_Omega_inv = arma::kron(Sigma_inv, mX.t() * mX); - post_Pi_Omega_inv.diag() += prior_Pi_Omega_vec_inv; - L = arma::chol(post_Pi_Omega_inv, "lower"); - b = arma::vectorise(mX.t() * mZ * Sigma_inv + Omega_Pi); - u1 = arma::solve(arma::trimatl(L), b); - u2 = arma::solve(arma::trimatu(L.t()), u1); - - bool stationarity_check = false; - int num_try = 0, iter = 0; - double root = 1000; - while (stationarity_check == false) { - iter += 1; - u3.imbue(norm_rand); - u4 = arma::solve(arma::trimatu(L.t()), u3); - Pi_vec = u2 + u4; - Pi_i = arma::trans(arma::reshape(Pi_vec, n_vars*n_lags, n_vars)); - if (check_roots) { - Pi_comp.rows(0, n_vars-1) = Pi_i; - root = max_eig_cpp(Pi_comp); - } else { - root = 0.0; - } - if (root < 1.0) { - stationarity_check = true; - num_try = iter; - } - if (iter == 1000) { - Rcpp::stop("Attemped to draw stationary Pi 1,000 times."); - } - } - - resid = mZ - mX * Pi_i.t(); - // Sigma - post_S = resid.t() * resid; - Sigma_i = rinvwish(n_T, post_S); - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_inv = arma::inv_sympd(Sigma_i); - - X = create_X_noint(Z_i, n_lags); - posterior_psi_iw(psi_i, mu_mat, Pi_i, D_mat, Sigma_i, inv_prior_psi_Omega, mZ + mu_mat, X, inv_prior_psi_Omega_mean, dt, n_determ, n_vars, n_lags); - - arma::vec errors = arma::vec(n_vars); - if (i % n_thin == 0) { - if (n_fcst > 0) { - Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t() - mu_mat.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - errors.imbue(norm_rand); - x = create_X_t_noint(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t() + d_fcst_lags * Psi_i.t(); - } - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - psi.row(i/n_thin) = psi_i.t(); - } - if (verbose) { - p.increment(); - } - } - -} diff --git a/src/mcmc_ss_iw.cpp b/src/mcmc_ss_iw.cpp deleted file mode 100644 index 3122ba5..0000000 --- a/src/mcmc_ss_iw.cpp +++ /dev/null @@ -1,137 +0,0 @@ -#include "mfbvar.h" -#include "ss_utils.h" -// [[Rcpp::export]] -void mcmc_ss_iw(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::cube& Z, - arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& inv_prior_Pi_Omega, - const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, - const arma::mat & prior_S, - const arma::mat & D_mat, const arma::mat & dt, const arma::mat & d1, - const arma::mat & d_fcst_lags, const arma::mat& inv_prior_psi_Omega, const arma::mat& inv_prior_psi_Omega_mean, - bool check_roots, const arma::mat& Z_1, arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, - arma::uword n_thin, bool verbose) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - Progress p(n_reps, verbose); - - arma::mat Pi_i = Pi.slice(0); - arma::mat Sigma_i = Sigma.slice(0); - arma::vec psi_i = psi.row(0).t(); - arma::mat y_i = y_in_p; - arma::mat X, XX, XX_inv, Pi_sample, post_Pi_Omega, post_Pi; - arma::mat S, Pi_diff, post_S, x, mu_mat, mZ, mZ1, mX; - arma::mat my = arma::mat(arma::size(y_in_p), arma::fill::zeros); - - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - arma::mat Z_i_demean = Z_i; - Z_i.rows(0, n_lags - 1) = Z_1; - - arma::mat Pi_i0 = arma::mat(n_vars, n_vars*n_lags+1, arma::fill::zeros); - arma::mat Pi_comp = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); - Pi_comp.submat(n_vars, 0, n_vars*n_lags - 1, n_vars*(n_lags-1) - 1) = arma::eye(n_vars*(n_lags-1), n_vars*(n_lags-1)); - - arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ, false, true); - mu_mat = dt * Psi_i.t(); - arma::uword n_Lambda = Lambda_comp.n_cols/Lambda_comp.n_rows; - arma::mat mu_long = arma::mat(n_Lambda+n_T, n_vars, arma::fill::zeros); - arma::rowvec Lambda_single = arma::rowvec(n_Lambda, arma::fill::zeros); - for (arma::uword i = 0; i < n_Lambda; ++i) { - Lambda_single(i) = Lambda_comp.at(0, i*n_q); - } - - int post_nu = n_T + n_vars + 2; - arma::mat Sigma_chol = arma::chol(Sigma_i, "lower"); - - // if single freq, we don't need to update - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_in_p; - } - - for (arma::uword i = 0; i < n_reps; ++i) { - if (!single_freq) { - update_demean(my, mu_long, y_in_p, mu_mat, d1, Psi_i, Lambda_single, n_vars, - n_q, n_Lambda, n_T); - } else { - // Even if single freq, mZ needs to be updated - mZ = y_in_p - mu_mat; - } - - mZ1 = Z_1 - d1 * Psi_i.t(); - Pi_i0.cols(1, n_vars*n_lags) = Pi_i; - - if (!single_freq) { - mZ = simsm_adaptive_cv(my, Pi_i0, Sigma_chol, Lambda_comp, mZ1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; - } - - Z_i_demean.rows(0, n_lags - 1) = mZ1; - Z_i_demean.rows(n_lags, n_T + n_lags - 1) = mZ; - - mX = create_X_noint(Z_i_demean, n_lags); - XX = mX.t() * mX; - XX_inv = arma::inv_sympd(XX); - Pi_sample = XX_inv * (mX.t() * mZ); - post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); - post_Pi = post_Pi_Omega * (Omega_Pi + mX.t() * mZ); - S = arma::trans((mZ - mX * Pi_sample)) * (mZ - mX * Pi_sample); - Pi_diff = prior_Pi_mean - Pi_sample; - post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; - - Sigma_i = rinvwish(post_nu, post_S); - - Sigma_chol = arma::chol(Sigma_i, "lower"); - bool stationarity_check = false; - int num_try = 0, iter = 0; - double root = 1000; - while (stationarity_check == false) { - iter += 1; - Pi_i = rmatn(post_Pi.t(), post_Pi_Omega, Sigma_i); - if (check_roots) { - Pi_comp.rows(0, n_vars-1) = Pi_i; - root = max_eig_cpp(Pi_comp); - } else { - root = 0.0; - } - if (root < 1.0) { - stationarity_check = true; - num_try = iter; - } - if (iter == 1000) { - Rcpp::stop("Attemped to draw stationary Pi 1,000 times."); - } - } - - X = create_X_noint(Z_i, n_lags); - posterior_psi_iw(psi_i, mu_mat, Pi_i, D_mat, Sigma_i, inv_prior_psi_Omega, mZ + mu_mat, X, inv_prior_psi_Omega_mean, dt, n_determ, n_vars, n_lags); - - arma::vec errors = arma::vec(n_vars); - if (i % n_thin == 0) { - if (n_fcst > 0) { - Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t() - mu_mat.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - errors.imbue(norm_rand); - x = create_X_t_noint(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t() + d_fcst_lags * Psi_i.t(); - } - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - psi.row(i/n_thin) = psi_i.t(); - } - if (verbose) { - p.increment(); - } - } - -} diff --git a/src/mcmc_ssng_diffuse.cpp b/src/mcmc_ssng_diffuse.cpp deleted file mode 100644 index f951db6..0000000 --- a/src/mcmc_ssng_diffuse.cpp +++ /dev/null @@ -1,195 +0,0 @@ -#include "mfbvar.h" -#include "ss_utils.h" -#include "update_ng.h" -// [[Rcpp::export]] -void mcmc_ssng_diffuse(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::vec& phi_mu, - arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, - arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& Omega_Pi, - const arma::mat & D_mat, const arma::mat & dt, const arma::mat & d1, - const arma::mat & d_fcst_lags, const arma::vec& prior_psi_mean, - double c0, double c1, double s, - bool check_roots, const arma::mat& Z_1, arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, - arma::uword n_thin, bool verbose) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - Progress p(n_reps, verbose); - - arma::vec Pi_vec = arma::vec(Pi.begin(), n_vars*(n_vars*n_lags)); - arma::mat Pi_i = Pi.slice(0); - arma::mat Sigma_i = Sigma.slice(0); - arma::vec psi_i = psi.row(0).t(); - arma::mat y_i = y_in_p; - arma::mat X, post_Pi_Omega_inv, L, b, u1, u2, u4, resid, x; - arma::mat post_S, mu_mat, mZ, mZ1, mX, Sigma_chol, Sigma_inv; - arma::mat u3 = arma::vec(n_vars*(n_vars*n_lags)); - arma::mat my = arma::mat(arma::size(y_in_p), arma::fill::zeros); - - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - arma::mat Z_i_demean = Z_i; - Z_i.rows(0, n_lags - 1) = Z_1; - - arma::mat Pi_i0 = arma::mat(n_vars, n_vars*n_lags+1, arma::fill::zeros); - arma::mat Pi_comp = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); - Pi_comp.submat(n_vars, 0, n_vars*n_lags - 1, n_vars*(n_lags-1) - 1) = arma::eye(n_vars*(n_lags-1), n_vars*(n_lags-1)); - - arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ, false, true); - mu_mat = dt * Psi_i.t(); - arma::uword n_Lambda = Lambda_comp.n_cols/Lambda_comp.n_rows; - arma::mat mu_long = arma::mat(n_Lambda+n_T, n_vars, arma::fill::zeros); - arma::rowvec Lambda_single = arma::rowvec(n_Lambda, arma::fill::zeros); - for (arma::uword i = 0; i < n_Lambda; ++i) { - Lambda_single(i) = Lambda_comp.at(0, i*n_q); - } - - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_inv = arma::inv_sympd(Sigma_i); - arma::vec prior_Pi_Omega_vec_inv = 1.0 / arma::vectorise(prior_Pi_Omega); - - // if single freq, we don't need to update - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_in_p; - } - - // NG stuff - arma::uword nm = n_vars*n_determ; - double lambda_mu_i = lambda_mu(0); - double phi_mu_i = phi_mu(0); - arma::vec omega_i = omega.row(0).t(); - arma::mat inv_prior_psi_Omega = arma::diagmat(omega_i); - arma::vec inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; - double M, batch = 1.0; - arma::running_stat stats; - double accept = 0.0; - bool adaptive_mh = false; - double s_prop; - if (s < 0) { - M = std::abs(s); - s = 1.0; - adaptive_mh = true; - } - arma::vec min_vec(2); - min_vec(0) = 0.01; - - for (arma::uword i = 0; i < n_reps; ++i) { - - if (!single_freq) { - update_demean(my, mu_long, y_in_p, mu_mat, d1, Psi_i, Lambda_single, n_vars, - n_q, n_Lambda, n_T); - } else { - // Even if single freq, mZ needs to be updated - mZ = y_in_p - mu_mat; - } - - mZ1 = Z_1 - d1 * Psi_i.t(); - Pi_i0.cols(1, n_vars*n_lags) = Pi_i; - - if (!single_freq) { - mZ = simsm_adaptive_cv(my, Pi_i0, Sigma_chol, Lambda_comp, mZ1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; - } - - Z_i_demean.rows(0, n_lags - 1) = mZ1; - Z_i_demean.rows(n_lags, n_T + n_lags - 1) = mZ; - - mX = create_X_noint(Z_i_demean, n_lags); - // Pi - post_Pi_Omega_inv = arma::kron(Sigma_inv, mX.t() * mX); - post_Pi_Omega_inv.diag() += prior_Pi_Omega_vec_inv; - L = arma::chol(post_Pi_Omega_inv, "lower"); - b = arma::vectorise(mX.t() * mZ * Sigma_inv + Omega_Pi); - u1 = arma::solve(arma::trimatl(L), b); - u2 = arma::solve(arma::trimatu(L.t()), u1); - - bool stationarity_check = false; - int num_try = 0, iter = 0; - double root = 1000; - while (stationarity_check == false) { - iter += 1; - u3.imbue(norm_rand); - u4 = arma::solve(arma::trimatu(L.t()), u3); - Pi_vec = u2 + u4; - Pi_i = arma::trans(arma::reshape(Pi_vec, n_vars*n_lags, n_vars)); - if (check_roots) { - Pi_comp.rows(0, n_vars-1) = Pi_i; - root = max_eig_cpp(Pi_comp); - } else { - root = 0.0; - } - if (root < 1.0) { - stationarity_check = true; - num_try = iter; - } - if (iter == 1000) { - Rcpp::stop("Attemped to draw stationary Pi 1,000 times."); - } - } - - resid = mZ - mX * Pi_i.t(); - // Sigma - post_S = resid.t() * resid; - Sigma_i = rinvwish(n_T, post_S); - Sigma_chol = arma::chol(Sigma_i, "lower"); - Sigma_inv = arma::inv_sympd(Sigma_i); - - update_ng(phi_mu_i, lambda_mu_i, omega_i, nm, c0, c1, s, psi_i, prior_psi_mean, accept); - if (adaptive_mh) { - stats(accept); - if (i % 100 == 0) { - batch += 1.0; - min_vec(1) = std::pow(batch, -0.5); - if (stats.mean() > 0.44) { - s_prop = log(s) + arma::min(min_vec); - if (s_prop < M){ - s = std::exp(s_prop); - } - } else { - s_prop = log(s) - arma::min(min_vec); - if (s_prop > -M){ - s = std::exp(s_prop); - } - } - stats.reset(); - } - } - - inv_prior_psi_Omega = arma::diagmat(1/omega_i); - inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; - - X = create_X_noint(Z_i, n_lags); - posterior_psi_iw(psi_i, mu_mat, Pi_i, D_mat, Sigma_i, inv_prior_psi_Omega, mZ + mu_mat, X, inv_prior_psi_Omega_mean, dt, n_determ, n_vars, n_lags); - - arma::vec errors = arma::vec(n_vars); - if (i % n_thin == 0) { - if (n_fcst > 0) { - Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t() - mu_mat.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - errors.imbue(norm_rand); - x = create_X_t_noint(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t() + d_fcst_lags * Psi_i.t(); - } - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - psi.row(i/n_thin) = psi_i.t(); - phi_mu(i/n_thin) = phi_mu_i; - lambda_mu(i/n_thin) = lambda_mu_i; - omega.row(i/n_thin) = omega_i.t(); - } - if (verbose) { - p.increment(); - } - } - -} diff --git a/src/mcmc_ssng_iw.cpp b/src/mcmc_ssng_iw.cpp deleted file mode 100644 index 1aadc75..0000000 --- a/src/mcmc_ssng_iw.cpp +++ /dev/null @@ -1,189 +0,0 @@ -#include "mfbvar.h" -#include "ss_utils.h" -#include "update_ng.h" -// [[Rcpp::export]] -void mcmc_ssng_iw(const arma::mat & y_in_p, - arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::vec& phi_mu, - arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, - arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, - const arma::mat& inv_prior_Pi_Omega, - const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, - const arma::mat & prior_S, - const arma::mat & D_mat, const arma::mat & dt, const arma::mat & d1, - const arma::mat & d_fcst_lags, const arma::vec& prior_psi_mean, - double c0, double c1, double s, - bool check_roots, const arma::mat& Z_1, arma::uword n_reps, - arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, - arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, - arma::uword n_thin, bool verbose) { - bool single_freq; - if (n_q == 0 || n_q == n_vars) { - single_freq = true; - } else { - single_freq = false; - } - - Progress p(n_reps, verbose); - - arma::mat Pi_i = Pi.slice(0); - arma::mat Sigma_i = Sigma.slice(0); - arma::vec psi_i = psi.row(0).t(); - arma::mat y_i, X, XX, XX_inv, Pi_sample, post_Pi_Omega, post_Pi; - arma::mat S, Pi_diff, post_S, x, mu_mat, mZ, mZ1, mX; - arma::mat my = arma::mat(arma::size(y_in_p), arma::fill::zeros); - - arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); - arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); - arma::mat Z_i_demean = Z_i; - Z_i.rows(0, n_lags - 1) = Z_1; - - arma::mat Pi_i0 = arma::mat(n_vars, n_vars*n_lags+1, arma::fill::zeros); - arma::mat Pi_comp = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); - Pi_comp.submat(n_vars, 0, n_vars*n_lags - 1, n_vars*(n_lags-1) - 1) = arma::eye(n_vars*(n_lags-1), n_vars*(n_lags-1)); - - arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ, false, true); - mu_mat = dt * Psi_i.t(); - arma::uword n_Lambda = Lambda_comp.n_cols/Lambda_comp.n_rows; - arma::mat mu_long = arma::mat(n_Lambda+n_T, n_vars, arma::fill::zeros); - arma::rowvec Lambda_single = arma::rowvec(n_Lambda, arma::fill::zeros); - for (arma::uword i = 0; i < n_Lambda; ++i) { - Lambda_single(i) = Lambda_comp.at(0, i*n_q); - } - - int post_nu = n_T + n_vars + 2; - arma::mat Sigma_chol = arma::chol(Sigma_i, "lower"); - - arma::uword nm = n_vars*n_determ; - double lambda_mu_i = lambda_mu(0); - double phi_mu_i = phi_mu(0); - arma::vec omega_i = omega.row(0).t(); - arma::mat inv_prior_psi_Omega = arma::diagmat(omega_i); - arma::vec inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; - double M, batch = 1.0; - arma::running_stat stats; - double accept = 0.0; - bool adaptive_mh = false; - double s_prop; - if (s < 0) { - M = std::abs(s); - s = 1.0; - adaptive_mh = true; - } - arma::vec min_vec(2); - min_vec(0) = 0.01; - - // if single freq, we don't need to update - if (single_freq) { - Z_i.rows(n_lags, n_T + n_lags - 1) = y_in_p; - } - for (arma::uword i = 0; i < n_reps; ++i) { - - if (!single_freq) { - my.cols(0, n_vars - n_q - 1) = y_in_p.cols(0, n_vars - n_q - 1) - mu_mat.cols(0, n_vars - n_q - 1); - mu_long.rows(0, n_Lambda-1) = d1.tail_rows(n_Lambda) * Psi_i.t(); - mu_long.rows(n_Lambda, n_T+n_Lambda-1) = mu_mat; - for (arma::uword j = 0; j < n_T; ++j) { - my.row(j).cols(n_vars - n_q - 1, n_vars - 1) = y_in_p.row(j).cols(n_vars - n_q - 1, n_vars - 1) - Lambda_single * mu_long.rows(j, j+n_Lambda-1).cols(n_vars - n_q - 1, n_vars - 1);// Needs fixing - } - } else { - // Even if single freq, mZ needs to be updated - mZ = y_in_p - mu_mat; - } - - mZ1 = Z_1 - d1 * Psi_i.t(); - Pi_i0.cols(1, n_vars*n_lags) = Pi_i; - - if (!single_freq) { - mZ = simsm_adaptive_cv(my, Pi_i0, Sigma_chol, Lambda_comp, mZ1, n_q, T_b); - Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; - } - - Z_i_demean.rows(n_lags, n_T + n_lags - 1) = mZ; - Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; - - mX = create_X_noint(Z_i_demean, n_lags); - XX = mX.t() * mX; - XX_inv = arma::inv_sympd(XX); - Pi_sample = XX_inv * (mX.t() * mZ); - - post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); - post_Pi = post_Pi_Omega * (Omega_Pi + mX.t() * mZ); - S = arma::trans((mZ - mX * Pi_sample)) * (mZ - mX * Pi_sample); - Pi_diff = prior_Pi_mean - Pi_sample; - post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; - Sigma_i = rinvwish(post_nu, arma::symmatu(post_S)); //Fixed in 9.400.3 - Sigma_chol = arma::chol(Sigma_i, "lower"); - bool stationarity_check = false; - int num_try = 0, iter = 0; - double root = 1000; - while (stationarity_check == false) { - iter += 1; - Pi_i = rmatn(post_Pi.t(), post_Pi_Omega, Sigma_i); - if (check_roots) { - Pi_comp.rows(0, n_vars-1) = Pi_i; - root = max_eig_cpp(Pi_comp); - } else { - root = 0.0; - } - if (root < 1.0) { - stationarity_check = true; - num_try = iter; - } - if (iter == 1000) { - Rcpp::stop("Attemped to draw stationary Pi 1,000 times."); - } - } - - update_ng(phi_mu_i, lambda_mu_i, omega_i, nm, c0, c1, s, psi_i, prior_psi_mean, accept); - if (adaptive_mh) { - stats(accept); - if (i % 100 == 0) { - batch += 1.0; - min_vec(1) = std::pow(batch, -0.5); - if (stats.mean() > 0.44) { - s_prop = log(s) + arma::min(min_vec); - if (s_prop < M){ - s = std::exp(s_prop); - } - } else { - s_prop = log(s) - arma::min(min_vec); - if (s_prop > -M){ - s = std::exp(s_prop); - } - } - stats.reset(); - } - } - - inv_prior_psi_Omega = arma::diagmat(1/omega_i); - inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; - - X = create_X_noint(Z_i, n_lags); - - posterior_psi_iw(psi_i, mu_mat, Pi_i, D_mat, Sigma_i, inv_prior_psi_Omega, mZ + mu_mat, X, inv_prior_psi_Omega_mean, dt, n_determ, n_vars, n_lags); - arma::vec errors = arma::vec(n_vars); - if (i % n_thin == 0) { - if (n_fcst > 0) { - Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t() - mu_mat.tail_rows(n_lags).t(); - for (arma::uword h = 0; h < n_fcst; ++h) { - - errors.imbue(norm_rand); - x = create_X_t_noint(Z_fcst_i.cols(0+h, n_lags-1+h).t()); - Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; - } - Z_fcst.slice(i/n_thin) = Z_fcst_i.t() + d_fcst_lags * Psi_i.t(); - } - Z.slice(i/n_thin) = Z_i; - Sigma.slice(i/n_thin) = Sigma_i; - Pi.slice(i/n_thin) = Pi_i; - psi.row(i/n_thin) = psi_i.t(); - phi_mu(i/n_thin) = phi_mu_i; - lambda_mu(i/n_thin) = lambda_mu_i; - omega.row(i/n_thin) = omega_i.t(); - } - if (verbose) { - p.increment(); - } - } - -} diff --git a/src/mvn_par.cpp b/src/mvn_par.cpp new file mode 100644 index 0000000..eaa127d --- /dev/null +++ b/src/mvn_par.cpp @@ -0,0 +1,51 @@ +#include +#include +#include "mvn.h" +#include "mvn_par.h" + +Pi_parallel_rue::Pi_parallel_rue(arma::mat & output, + const arma::mat & y, + const arma::mat & X, + const arma::mat & d, + const arma::mat & eps, + const arma::mat & volatility, + const arma::mat & prior_AR1, + const arma::uword T, + const arma::uword n, + const arma::uword p) : output(output), y(y), X(X), d(d), eps(eps), volatility(volatility), prior_AR1(prior_AR1), T(T), n(n), p(p) {}; + +void Pi_parallel_rue::operator()(std::size_t begin, std::size_t end) { + for (std::size_t i = begin; i < end; i++) + { + arma::vec h_j = arma::exp(-0.5 * volatility.col(i)); + arma::mat X_j = X.each_col() % h_j; + arma::vec y_j = y.col(i) % h_j; + arma::vec eps_i = eps.unsafe_col(i); + arma::vec d_i = d.unsafe_col(i); + output.col(i) = mvn_rue_eps(X_j, d_i, y_j, eps_i, prior_AR1(i), i); + } +} + +Pi_parallel_bcm::Pi_parallel_bcm(arma::mat & output, + const arma::mat & y, + const arma::mat & X, + const arma::mat & d, + const arma::mat & eps, + const arma::mat & volatility, + const arma::uword T, + const arma::uword n, + const arma::uword p) : output(output), y(y), X(X), d(d), eps(eps), volatility(volatility), T(T), n(n), p(p) {}; + +void Pi_parallel_bcm::operator()(std::size_t begin, std::size_t end) { + for (std::size_t i = begin; i < end; i++) + { + arma::vec h_j = arma::exp(-0.5 * volatility.col(i)); + arma::mat X_j = X.each_col() % h_j; + arma::vec y_j = y.col(i) % h_j; + arma::vec eps_i = eps.unsafe_col(i); + arma::vec d_i = d.unsafe_col(i); + output.col(i) = mvn_bcm_eps(X_j, d_i, y_j, eps_i); + } +} + + diff --git a/src/progutils_fsv.cpp b/src/progutils_fsv.cpp new file mode 100644 index 0000000..a02f191 --- /dev/null +++ b/src/progutils_fsv.cpp @@ -0,0 +1,74 @@ +#include "progutils_fsv.h" + +double logdnormquot(double x, double y, double mu, double sigma) { + return ((y-mu)*(y-mu) - (x-mu)*(x-mu)) / (2*sigma*sigma); +} + +double logspecialquot(double x, double y, double alpha, double beta, double c) { + return (alpha/c) * (x - y) - beta * (exp(x/c) - exp(y/c)); +} + + +void store(const Rcpp::NumericMatrix &curfacload, Rcpp::NumericVector &facload, + const Rcpp::NumericMatrix &curf, Rcpp::NumericVector &f, + const Rcpp::NumericMatrix &curh, Rcpp::NumericVector &h, + const Rcpp::NumericVector &curh0, Rcpp::NumericMatrix &h0, + const Rcpp::NumericMatrix &curpara, Rcpp::NumericVector ¶, + const Rcpp::NumericVector &curlambda2, Rcpp::NumericMatrix &lambda2, + const Rcpp::NumericMatrix &curtau2, Rcpp::NumericVector &tau2, + const Rcpp::NumericVector &curmixprob, Rcpp::NumericVector &mixprob, + const Rcpp::IntegerMatrix &curmixind, Rcpp::IntegerVector &mixind, + const bool auxstore, const int thintime, const int where) { + + std::copy(curfacload.begin(), curfacload.end(), facload.begin() + where * curfacload.length()); + std::copy(curpara.begin(), curpara.end(), para.begin() + where * curpara.length()); + + if (thintime == 1) { // store everything + + std::copy(curf.begin(), curf.end(), f.begin() + where * curf.length()); + std::copy(curh.begin(), curh.end(), h.begin() + where * curh.length()); + + } else if (thintime == -1) { // store only t = T + + for (int i = 0; i < curf.nrow(); i++) { + f(where*curf.nrow() + i) = curf(i, curf.ncol()-1); + } + + for (int i = 0; i < curh.ncol(); i++) { + h(where*curh.ncol() + i) = curh(curh.nrow()-1, i); + } + + } else if (thintime > 1) { // store every thintimeth point in time + + int tmp = curf.ncol()/thintime; + int tmpp = where * curf.nrow() * tmp; + + for (int j = 0; j < tmp; ++j) { + int tmppp = j*thintime; + int tmpppp = tmpp + j*curf.nrow(); + + for (int i = 0; i < curf.nrow(); ++i) { + f(tmpppp + i) = curf(i, tmppp); + } + } + + tmpp = where * curh.ncol() * tmp; + + for (int i = 0; i < curh.ncol(); ++i) { + int tmpppp = tmpp + i*tmp; + + for (int j = 0; j < tmp; ++j) { + h(tmpppp + j) = curh(j*thintime, i); + } + } + } + + std::copy(curh0.begin(), curh0.end(), h0.begin() + where * curh0.length()); + + if (auxstore) { // store mixture probabilities, mixture indicators, shrinkage hyperparas, h0 + std::copy(curmixprob.begin(), curmixprob.end(), mixprob.begin() + where * curmixprob.length()); + std::copy(curmixind.begin(), curmixind.end(), mixind.begin() + where * curmixind.length()); + std::copy(curlambda2.begin(), curlambda2.end(), lambda2.begin() + where * curlambda2.length()); + std::copy(curtau2.begin(), curtau2.end(), tau2.begin() + where * curtau2.length()); + } +} diff --git a/src/progutils_fsv.h b/src/progutils_fsv.h new file mode 100644 index 0000000..9776cbc --- /dev/null +++ b/src/progutils_fsv.h @@ -0,0 +1,20 @@ +#ifndef _PROGUTILS_H +#define _PROGUTILS_H + +#include + +double logdnormquot(double x, double y, double mu, double sigma); +double logspecialquot(double x, double y, double alpha, double beta, double c); + +void store(const Rcpp::NumericMatrix &curfacload, Rcpp::NumericVector &facload, + const Rcpp::NumericMatrix &curf, Rcpp::NumericVector &f, + const Rcpp::NumericMatrix &curh, Rcpp::NumericVector &h, + const Rcpp::NumericVector &curh0, Rcpp::NumericMatrix &h0, + const Rcpp::NumericMatrix &curpara, Rcpp::NumericVector ¶, + const Rcpp::NumericVector &curlambda2, Rcpp::NumericMatrix &lambda2, + const Rcpp::NumericMatrix &curtau2, Rcpp::NumericVector &tau2, + const Rcpp::NumericVector &curmixprob, Rcpp::NumericVector &mixprob, + const Rcpp::IntegerMatrix &curmixind, Rcpp::IntegerVector &mixind, + const bool auxstore, const int thintime, const int where); + +#endif diff --git a/src/rgig.cpp b/src/rgig.cpp index 4e35a59..37af332 100644 --- a/src/rgig.cpp +++ b/src/rgig.cpp @@ -14,3 +14,18 @@ double do_rgig1(double lambda, double chi, double psi) { if (!fun) fun = (SEXP(*)(int, double, double, double)) R_GetCCallable("GIGrvg", "do_rgig"); return Rcpp::as(fun(1, lambda, chi, psi)); } + +// [[Rcpp::export]] +double rig(double mu, double lambda){ + double z = R::rnorm(0,1); + double y = z*z; + double x = mu+0.5*mu*mu*y/lambda - 0.5*(mu/lambda)*sqrt(4*mu*lambda*y+mu*mu*y*y); + double u=R::runif(0,1); + double out; + if(u <= mu/(mu+x)){ + out = x; + } else { + out = mu*mu/x; + } + return out; +} diff --git a/src/rsimsm_adaptive_cv.cpp b/src/rsimsm_adaptive_cv.cpp deleted file mode 100644 index 72b6a91..0000000 --- a/src/rsimsm_adaptive_cv.cpp +++ /dev/null @@ -1,14 +0,0 @@ -#include "mfbvar.h" - -// [[Rcpp::export]] -arma::mat rsimsm_adaptive_cv(arma::mat y_, arma::mat Phi, arma::mat Sigma_chol, - arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b) { - return simsm_adaptive_cv(y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b); -} - -// [[Rcpp::export]] -arma::mat rsimsm_adaptive_sv(arma::mat y_, arma::mat Phi, arma::cube Sigma_chol, - arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b) { - return simsm_adaptive_sv(y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b); -} - diff --git a/src/rsimsm_adaptive_univariate.cpp b/src/rsimsm_adaptive_univariate.cpp deleted file mode 100644 index 0d05144..0000000 --- a/src/rsimsm_adaptive_univariate.cpp +++ /dev/null @@ -1,7 +0,0 @@ -#include "mfbvar.h" - -// [[Rcpp::export]] -arma::mat rsimsm_adaptive_univariate(arma::mat y_, arma::mat Phi, arma::mat Sigma, - arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b, arma::mat f) { - return simsm_adaptive_univariate(y_, Phi, Sigma, Lambda, Z1, n_q_, T_b, f); -} diff --git a/src/sampler.h b/src/sampler.h new file mode 100644 index 0000000..7d3d414 --- /dev/null +++ b/src/sampler.h @@ -0,0 +1,28 @@ +#ifndef _SAMPLER_H +#define _SAMPLER_H + +//#define ARMA_NO_DEBUG // disables bounds checks +#include +#include // decl'd and def'd in "stochvol" (univariate SV-update) +#include "progutils.h" + +double rgig1(double, double, double); + +// Main sampler (as called from R): +RcppExport SEXP sampler(const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP); + +RcppExport SEXP sampler2(const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP, const SEXP, + const SEXP, const SEXP, const SEXP, const SEXP); + +#endif diff --git a/src/smoothing.cpp b/src/smoothing.cpp deleted file mode 100644 index 6abd904..0000000 --- a/src/smoothing.cpp +++ /dev/null @@ -1,109 +0,0 @@ -#include "mfbvar.h" - -#define _USE_MATH_DEFINES // for C++ -#include - -//' @title Smooth and sample from the smoothed distribution -//' -//' @description Functions for smoothing and sampling from the (smoothed) distribution \eqn{p(Z_{1:T}|Y_{1:T}, \Theta)}. -//' @details Implemented in C++. -//' @aliases smoother simulation_smoother generate_mhh loglike -//' @describeIn smoother Compute smoothed states -//' @templateVar Y TRUE -//' @templateVar Lambda TRUE -//' @templateVar Pi_comp TRUE -//' @templateVar Q_comp TRUE -//' @templateVar n_T TRUE -//' @templateVar n_vars TRUE -//' @templateVar n_comp TRUE -//' @templateVar z0 TRUE -//' @templateVar P0 TRUE -//' @template man_template -//' @keywords internal -//' @return For \code{loglike}: -//' \item{}{An \code{n_T}-long vector of the log-likelihoods. \code{exp(sum(loglike(...)))} is the likelihood.} -// [[Rcpp::export]] -arma::mat loglike( arma::mat Y, arma::mat Lambda, arma::mat Pi_comp, arma::mat Q_comp, int n_T, int n_vars, int n_comp, arma::mat z0, arma::mat P0) { - /* This function computes the smoothed state vector */ - /****************************************************/ - /* Initialize matrices and cubes */ - arma::mat QQ = Q_comp * Q_comp.t(); - arma::mat mv(n_T, n_vars); - mv.fill(NA_REAL); - arma::mat me(n_T, n_vars); - me.fill(NA_REAL); - arma::mat mr(n_T, n_comp); - mr.fill(0); - arma::mat mu(n_T, n_comp); - mu.fill(0); - arma::cube IS(n_vars, n_vars, n_T); - IS.fill(NA_REAL); - arma::cube aK(n_comp, n_vars, n_T); - aK.fill(NA_REAL); - arma::mat identity_mat(n_comp, n_comp, arma::fill::eye); - arma::mat YY(n_T, n_vars); - YY.fill(NA_REAL); - arma::mat mhh(n_T, n_comp); - mhh.fill(NA_REAL); - arma::mat mz = Y.row(0); - arma::uvec obs_vars = find_finite(mz); - arma::mat logl(n_T, 1); - logl.fill(NA_REAL); - - /* Fill some temporary variables */ - arma::mat h1 = Pi_comp * z0; - arma::mat P1 = Pi_comp * P0 * Pi_comp.t() + QQ; - arma::mat mH = Lambda.rows(obs_vars); - arma::mat vz = mz.cols(obs_vars); - - arma::mat vv = mv.row(0); - vv.cols(obs_vars) = vz - trans(mH * h1); - mv.row(0) = vv; - - arma::mat aS = mH * P1 * mH.t(); - arma::mat mIS = IS.slice(0); - mIS(obs_vars, obs_vars) = inv_sympd(aS); - IS.slice(0) = mIS; - - arma::mat mK = aK.slice(0); - mK.cols(obs_vars) = P1 * mH.t() * mIS(obs_vars, obs_vars); - aK.slice(0) = mK; - - arma::mat h2 = h1 + mK.cols(obs_vars) * trans(vv.cols(obs_vars)); - arma::mat P2 = (identity_mat - mK.cols(obs_vars) * mH) * P1; - - double log_det_val; - double log_det_sign; - /* Filtering */ - for (int i = 1; i < n_T; i++) { - mz = Y.row(i); - obs_vars = find_finite(mz); - - h1 = Pi_comp * h2; - P1 = Pi_comp * P2 * Pi_comp.t() + QQ; - - mH = Lambda.rows(obs_vars); - vz = mz.cols(obs_vars); - - vv = mv.row(i); - vv.cols(obs_vars) = vz - trans(mH * h1); - mv.row(i) = vv; - - aS = mH * P1 * mH.t(); - mIS = IS.slice(i); - mIS(obs_vars, obs_vars) = inv_sympd(aS); - IS.slice(i) = mIS; - - mK = aK.slice(i); - mK.cols(obs_vars) = P1 * mH.t() * mIS(obs_vars, obs_vars); - aK.slice(i) = mK; - - h2 = h1 + mK.cols(obs_vars) * trans(vv.cols(obs_vars)); - P2 = (identity_mat - mK.cols(obs_vars) * mH) * P1; - log_det(log_det_val, log_det_sign, aS); - logl.row(i) = -0.5* obs_vars.n_elem * log(2*M_PI) - (log_det_val + vv.cols(obs_vars) * mIS(obs_vars, obs_vars) * trans(vv.cols(obs_vars)))*0.5; - } - - /* The return is the smoothed state vector */ - return(logl); -} diff --git a/src/ss_utils.h b/src/ss_utils.h index 33ed8eb..7c6d6ee 100644 --- a/src/ss_utils.h +++ b/src/ss_utils.h @@ -7,4 +7,27 @@ void update_demean(arma::mat & my, arma::mat & mu_long, const arma::mat & y_in_p, const arma::mat & mu_mat, const arma::mat & d1, const arma::mat & Psi_i, const arma::mat & Lambda_single, arma::uword n_vars, arma::uword n_q, arma::uword n_Lambda, arma::uword n_T); + +void posterior_psi_iw(arma::vec & psi_i, arma::mat & mu_mat, + const arma::mat & Pi_i, const arma::mat & D_mat, + const arma::mat & Sigma_i, const arma::mat & inv_prior_psi_Omega, + const arma::mat & Z_i, const arma::mat & X, + const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, + int n_determ, int n_vars, int n_lags); +void posterior_psi_csv(arma::vec & psi_i, arma::mat & mu_mat, + const arma::mat & Pi_i, const arma::mat & D_mat, + const arma::mat & Sigma_chol_inv, const arma::mat & exp_sqrt_f, + const arma::mat & inv_prior_psi_Omega, + const arma::mat & Z_i, const arma::mat & X, + const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, + int n_determ, int n_vars, int n_lags); +void posterior_psi_fsv(arma::vec & psi_i, arma::mat & mu_mat, + const arma::mat & Pi_i, const arma::mat & D_mat, + const arma::mat & idivar, const arma::mat & inv_prior_psi_Omega, + const arma::mat & Z_i, const arma::mat & X, + const arma::mat & startfacload, const arma::mat & startfac, + const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, + int n_determ, int n_vars, int n_lags); + +double max_eig_cpp(const arma::mat & A); #endif diff --git a/src/update_csv.cpp b/src/update_csv.cpp deleted file mode 100644 index a955122..0000000 --- a/src/update_csv.cpp +++ /dev/null @@ -1,109 +0,0 @@ -// Copyright of original code: Gregor Kastner (stochvol package) -// Copyright of modified code: Sebastian Ankargren (mfbvar package) -// The following code is a derivative work of the code -// developed by Gregor Kastner for the stochvol package, which -// is licensed GPL>=2. This code is therefore licensed under -// the terms of the GNU Public License, version 3. - -#include "mfbvar.h" -#include "progutils.h" -#include "auxmix.h" -void update_csv( - const arma::mat& data, - double& phi, - double& sigma, - arma::vec& h, - double& h0, - arma::mat& mixprob, - arma::imat& r, - const double priorlatent0, - const double phi_invvar, - const double phi_meaninvvar, - const double prior_sigma2, - const double prior_df) { - int T = data.n_rows; - int n = data.n_cols; - - arma::vec omega_diag(T+1); // contains diagonal elements of precision matrix - double omega_offdiag; // contains off-diag element of precision matrix (const) - arma::vec chol_offdiag(T), chol_diag(T+1); // Cholesky-factor of Omega - arma::vec covector(T+1); // holds covector (see McCausland et al. 2011) - arma::vec htmp(T+1); // intermediate vector for sampling h - arma::vec hnew(T+1); // intermediate vector for sampling h - - double sigma2inv = std::pow(sigma, -2.0); - - double Bh0inv = 1.0/priorlatent0; - - arma::vec hT = h.rows(1, T - 1); - arma::vec hT1 = h.rows(0, T - 2); - - - /* - * Sample phi - */ - double phi_postvar = std::pow(phi_invvar + sigma2inv * arma::accu(arma::pow(hT1, 2.0)), -1.0); - double phi_postmean = phi_postvar * (sigma2inv * arma::accu(hT1 % hT) + phi_meaninvvar); - phi = rtruncnorm(phi_postmean, phi_postvar); - const double phi2 = std::pow(phi, 2.0); - - /* - * Sample sigma2 - */ - arma::vec u = hT - phi * hT1; - - sigma = std::pow(R::rgamma(prior_df + T - 1, 1/(prior_df * prior_sigma2 + arma::accu(arma::pow(u, 2.0)))), -0.5); - sigma2inv = std::pow(sigma, -2.0); - - /* - * Step (c): sample indicators - */ - // calculate non-normalized CDF of posterior indicator probs - for (int i = 0; i < n; ++i) { - arma::vec mixprob_vec = arma::vec(10*T); - arma::ivec r_vec = arma::ivec(T); - findMixCDF(mixprob_vec, data.col(i)-h); - invTransformSampling(mixprob_vec, r_vec, T); - mixprob.col(i) = mixprob_vec; - r.col(i) = r_vec; - } - - - // find correct indicators (currently by inversion method) - - /* - * Step (a): sample the latent volatilities h: - */ - omega_diag[0] = (Bh0inv + 1) * sigma2inv; - covector[0] = 0.0; - - for (int j = 1; j < T; j++) { - omega_diag[j] = sigma2inv*(1+phi2); - covector[j] = 0.0; - for (int i = 0; i < n; i++) { - omega_diag[j] += mix_varinv[r.at(j-1, i)]; - covector[j] += (data.at(j-1, i) - mix_mean[r.at(j-1, i)])*mix_varinv[r.at(j-1, i)]; - } - } - omega_diag[T] = sigma2inv; - covector[T] = 0.0; - for (int i = 0; i < n; i++) { - omega_diag[T] += mix_varinv[r.at(T-1, i)]; - covector[T] += (data.at(T-1, i) - mix_mean[r.at(T-1, i)])*mix_varinv[r.at(T-1, i)]; - } - omega_offdiag = -phi * sigma2inv; // omega_offdiag is constant - - // Cholesky decomposition - cholTridiag(omega_diag, omega_offdiag, chol_diag, chol_offdiag); - - // Solution of Chol*x = covector ("forward algorithm") - forwardAlg(chol_diag, chol_offdiag, covector, htmp); - - htmp += Rcpp::as(Rcpp::rnorm(T+1)); - - // Solution of (Chol')*x = htmp ("backward algorithm") - backwardAlg(chol_diag, chol_offdiag, htmp, hnew); - - h = hnew.tail(T); - h0 = hnew[0]; -} diff --git a/src/update_dl.cpp b/src/update_dl.cpp new file mode 100644 index 0000000..fad966d --- /dev/null +++ b/src/update_dl.cpp @@ -0,0 +1,62 @@ +#include "mfbvar.h" +void update_dl(arma::mat & prior_Pi_Omega, arma::vec & aux, + arma::vec & local, double & global, const arma::mat & Pi_i, + arma::uword n_vars, arma::uword n_lags, const double a, + arma::vec & slice, bool gig = true, bool intercept = true) { + + arma::vec Pi_vec; + if (intercept) { + Pi_vec = arma::vectorise(Pi_i.rows(1, n_vars*n_lags)); + } else { + Pi_vec = arma::vectorise(Pi_i); + } + + + arma::uword K = Pi_vec.n_elem; + + for (arma::uword i = 0; i < K; ++i) { + aux[i] = 1.0/rig(global * local[i] / fabs(Pi_vec[i]), 1.0); + } + arma::vec Pi_local = arma::abs(Pi_vec) / local; + + global = do_rgig1(K*(a-1.0), 2.0 * arma::accu(Pi_local), 1.0); + + + if (gig) { + for (arma::uword i = 0; i < K; ++i) { + local[i] = do_rgig1((a-1.0), 2.0 * fabs(Pi_vec[i]), 1.0); + } + } else { + arma::vec u1 = arma::vec(K); + std::generate(u1.begin(), u1.end(), ::unif_rand); + u1 %= arma::exp(-0.5 / slice); + arma::vec lb = 0.5/(arma::log(1/u1)); + double Flb; + arma::vec u2 = arma::vec(K); + for (arma::uword i = 0; i < K; ++i) { + Flb = R::pgamma(lb[i], 1-a, 1/fabs(Pi_vec[i]), true, false); + u2[i] = R::runif(Flb, 1.0); + } + arma::uvec u3 = arma::find(u2 > 1-(1e-16)); + if (u3.n_elem > 0) { + u2.elem(u3).fill(1-(1e-16)); + } + for (arma::uword i = 0; i < K; ++i) { + slice[i] = R::qgamma(u2[i], 1-a, 1/fabs(Pi_vec[i]), true, false); + } + local = 1/slice; + } + + local = local / arma::accu(local); + + arma::uvec local_idx = arma::find(local < 1e-20); + local.elem(local_idx).fill(1e-20); + + if (intercept) { + prior_Pi_Omega.rows(1, n_vars*n_lags) = arma::reshape(aux % arma::pow(global * local, 2.0), n_vars*n_lags, n_vars); + } else { + prior_Pi_Omega = arma::reshape(aux % arma::pow(global * local, 2.0), n_vars*n_lags, n_vars); + } + + +} diff --git a/src/update_dl.h b/src/update_dl.h new file mode 100644 index 0000000..406af47 --- /dev/null +++ b/src/update_dl.h @@ -0,0 +1,8 @@ +#ifndef MFBVAR_UPDATE_DL_H +#define MFBVAR_UPDATE_DL_H +void update_dl(arma::mat & prior_Pi_Omega, arma::vec & aux, + arma::vec & local, double & global, const arma::mat & Pi_i, + arma::uword n_vars, arma::uword n_lags, const double a, + arma::vec & slice, bool gig = true, + bool intercept = true); +#endif diff --git a/src/update_fsv.h b/src/update_fsv.h new file mode 100644 index 0000000..3314b6d --- /dev/null +++ b/src/update_fsv.h @@ -0,0 +1,452 @@ +#include +#include // decl'd and def'd in "stochvol" (univariate SV-update) +#include "progutils_fsv.h" +#include "auxmix.h" + + +// curfacload changed to armafacload +void update_fsv(arma::mat & armafacload, arma::mat & armaf, arma::mat & armah, + arma::vec & armah0, + Rcpp::NumericMatrix & curpara, + const arma::mat & armatau2, + const arma::mat & armay, + const double bmu, const double Bmu, const double a0idi, const double b0idi, + const double a0fac, const double b0fac, const Rcpp::NumericVector & Bsigma, + const double B011inv, const double B022inv, + const Rcpp::NumericVector & priorh0, const arma::imat & armarestr) { + + + + bool Gammaprior = true; + bool truncnormal = false; + double MHcontrol = -1.0; + int MHsteps = 2; + int parameterization = 3; + + const int interweaving = 4; + const bool signswitch = false; + const bool samplefac = true; + int nlambda = 0; + const double c0 = 2.5; + const Rcpp::NumericVector C0 = 1.5*Bsigma; + + using namespace Rcpp; + + const int m = armay.n_rows; // number of time series + const int T = armay.n_cols; // length of time series + const int r = armafacload.n_cols; // number of latent factors + const int mpr = m + r; + + arma::irowvec nonzerospercol = arma::sum(armarestr, 0); + arma::icolvec nonzerosperrow = arma::sum(armarestr, 1); + + // restriction on factor loadings matrix: + for (int i = 0; i < m; i++) { + for (int j = 0; j < r; j++) { + if (armarestr(i, j) == 0) armafacload(i,j) = 0.; + } + } + /* + * Needs to be done in R first + // restriction on factor loadings matrix: + for (int i = 0; i < m; i++) { + for (int j = 0; j < r; j++) { + if (armarestr(i,j) == 0) armatau2(i,j) = 0.; + } + } + */ + // pre-calculation of a posterior parameter + double cT = 0; + if (Gammaprior) { + if (MHsteps == 2 || MHsteps == 3) cT = T/2.0; // we want IG(-.5,0) as proposal + else if (MHsteps == 1) cT = (T-1)/2.0; // we want IG(-.5,0) as proposal + } else { + if (MHsteps == 2) cT = c0 + (T+1)/2.0; // pre-calculation outside the loop + } + + int tmpcounter = 0; + arma::uvec diagindices(m); + for (int k = 0; k < m; k++) { + for (int l = k; l < m; l++) { + if (k == l) diagindices(k) = tmpcounter; + tmpcounter++; + } + } + + //convention: "arma"-prefixed variables denote Armadillo proxy objects + arma::mat armafacloadt = arma::trans(armafacload); + arma::uvec armafacloadtunrestrictedelements = arma::find(armarestr.t() != 0); + arma::vec armafacloadtmp = arma::zeros(armafacloadtunrestrictedelements.size()); + arma::vec armafacload2inter(r, arma::fill::zeros); + arma::mat armahtilde(armah.n_rows, m); + + + + + + //current shrinkage latents lambda^2 + arma::vec armalambda2(nlambda); + + // temporary stroage for hopen in interweaving + arma::vec hopen(T); + + // NOTE: (Almost) all storage of MCMC draws is done in NumericVectors + // because no 'array' structure is available at this point in time. + + // facload holds the factor loadings: + NumericVector facload(m * r); + facload.attr("dim") = Dimension(m, r, 1); + + //current mixture indicator draws + IntegerMatrix curmixind(T, mpr); + NumericVector curmixprob(10 * T * mpr); + + // h holds the latent log-volatilities, but not h0! + NumericVector h(T); + h.attr("dim") = Dimension(1, T, 1); + + // f holds the latent factor draws + NumericVector f(T); + f.attr("dim") = Dimension(T, 1, 1); + + + // mixind holds the mixture indicators for the auxiliary mixture sampling + IntegerVector mixind(T * mpr); + + // mixprob holds the mixture probabilities for the auxmix + NumericVector mixprob(10 * T * mpr); + //mixprob.attr("dim") = Dimension(10, T, mpr, 1); no 4-dim possible? + + // para holds the parameter draws (mu, phi, sigma) + NumericVector para(3 * mpr * (1)); + para.attr("dim") = Dimension(3, mpr, 1) ; + + // curynorm will hold log((y - facload %*% f)^2) in STEP 1 + arma::mat armaynorm(m, T); + + // curynorm2 will hold log(f^2) in STEP 1 + arma::mat armafnorm(r, T, arma::fill::zeros); + arma::mat armaXt(r, T); + arma::mat armaXt2(r, m); + arma::colvec armaytilde(T); + arma::colvec armaytilde2(m); + arma::mat armaSigma(r, r); + arma::mat armaR(r, r); + arma::mat armaRinv(r, r); + arma::mat armaSigma2(r, r); + arma::mat armaR2(r, r); + arma::mat armaR2inv(r, r); + arma::colvec armamean(r); + arma::colvec armamean2(r); + arma::colvec armadraw(r); + arma::colvec armadraw2(r*T); + + // we always use the centered parameterization as baseline + // (for compatibility reasons with stochvol) + const bool centered_baseline = true; + + // RNGScope scope; + // variables are declared afterwards + + + + + // temporary variables for the updated stochvol code + arma::mat curpara_arma(curpara.begin(), curpara.nrow(), curpara.ncol(), false); + arma::mat curmixprob_arma(curmixprob.begin(), 10*T, mpr, false); + arma::imat curmixind_arma(curmixind.begin(), curmixind.nrow(), curmixind.ncol(), false); + + // "linearized residuals" + // NOTE: "log", "square" are component-wise functions, '*' denotes matrix multiplication + double offset = 0.00001; + if (r > 0) { + armaynorm = log(square(armay - armafacload * armaf)); + } else { + armaynorm = log(square(armay) + offset); + } + armafnorm = log(square(armaf)); + + + + armahtilde = exp(-armah(arma::span::all, arma::span(0,m-1))/2.); + + for (arma::uword ii = 0; ii < armay.n_cols; ii++) { + Rcpp::NumericVector tmp(5); + tmp[0] = armay(0, ii); + tmp[1] = armafacload[0]; + tmp[2] = armaf[ii]; + tmp[3] = arma::as_scalar(armafacload.row(0) * armaf.col(ii)); + tmp[4] = armaynorm(0, ii); + + } + // STEP 1: + // update indicators, latent volatilities, and SV-parameters + + + + // STEP 1 for "linearized residuals" + + + for (int j = 0; j < m; j++) { + + double curh0j = armah0(j); + arma::vec curpara_j = curpara_arma.unsafe_col(j); + arma::vec curh_j = armah.unsafe_col(j); + arma::vec armaynorm_j = armaynorm.row(j).t(); + arma::vec curmixprob_j = curmixprob_arma.unsafe_col(j); + arma::ivec curmixind_j = curmixind_arma.unsafe_col(j); + double priorh0_j = priorh0(j); + double C0_j = C0(j); + double Bsigma_j = Bsigma(j); + + if (j < 1) { + + } + stochvol::update_sv(armaynorm_j, curpara_j, curh_j, curh0j, curmixprob_j, curmixind_j, + centered_baseline, C0_j, cT, Bsigma_j, a0idi, b0idi, bmu, Bmu, B011inv, B022inv, Gammaprior, + truncnormal, MHcontrol, MHsteps, parameterization, false, priorh0_j); + + armah0(j) = curh0j; + } + + + + // STEP 1 for factors + for (int j = m; j < mpr; j++) { + double curh0j = armah0(j); + arma::vec curpara_j = curpara_arma.unsafe_col(j); + arma::vec curh_j = armah.unsafe_col(j); + arma::vec curmixprob_j = curmixprob_arma.unsafe_col(j); + arma::ivec curmixind_j = curmixind_arma.unsafe_col(j); + stochvol::update_sv(armafnorm.row(j-m).t(), curpara_j, curh_j, curh0j, curmixprob_j, curmixind_j, + centered_baseline, C0(j), cT, Bsigma(j), a0fac, b0fac, bmu, Bmu, B011inv, B022inv, Gammaprior, + truncnormal, MHcontrol, MHsteps, parameterization, true, priorh0(j)); + armah0(j) = curh0j; + } + + // intermediate step: calculate transformation of curh + + + armahtilde = exp(-armah(arma::span::all, arma::span(0,m-1))/2.); + + + // STEP 2: + // update factor loadings: m independent r-variate regressions + // with T observations (for unrestricted case) + + + if (r > 0) { + + int oldpos = 0; + for (int j = 0; j < m; j++) { + + // TODO: some things outside + + + // transposed design matrix Xt is filled "manually" + int activecols = 0; + for (int l = 0; l < r; l++) { + for (int k = 0; k < T; k++) { + armaXt(activecols, k) = armaf(l, k) * armahtilde(k, j); + } + activecols++; + } + + armaytilde = armay.row(j).t() % armahtilde.col(j); + + + // Now draw from the multivariate normal distribution + // armaSigma is first used as temporary variable: + armaSigma.submat(0,0,activecols-1,activecols-1) = armaXt.rows(0,activecols-1) * armaXt.rows(0,activecols-1).t(); + + // add precisions to diagonal: + armaSigma.submat(0,0,activecols-1,activecols-1).diag() += 1/arma::nonzeros(armatau2.row(j)); + // Find Cholesky factor of posterior precision matrix + try { + armaR.submat(0, 0, activecols-1, activecols-1) = arma::chol(armaSigma.submat(0,0,activecols-1,activecols-1)); + } catch (...) { + ::Rf_error("Error: Couldn't Cholesky-decompose posterior loadings precision in row %i", j+1); + } + + + // TODO: Check whether Armadillo automatically exploits the fact that R2 is upper triangular for inversion + // (Partial) Answer: Seems to be OK for native R but solve(trimatu(R), I) is faster with OpenBLAS + try { + // armaRinv.submat(0,0,activecols-1,activecols-1) = arma::inv(arma::trimatu(armaR.submat(0,0,activecols-1,activecols-1))); + armaRinv.submat(0,0,activecols-1,activecols-1) = + arma::solve(arma::trimatu(armaR.submat(0,0,activecols-1,activecols-1)), + arma::eye(activecols, activecols)); + } catch (...) { + ::Rf_error("Error: Couldn't invert Cholesky factor of posterior loadings precision in row %i", j+1); + } + + // calculate posterior covariance armaSigma: + armaSigma.submat(0, 0, activecols-1, activecols-1) = + armaRinv.submat(0, 0, activecols-1, activecols-1) * + armaRinv.submat(0, 0, activecols-1, activecols-1).t(); + + // calculate posterior mean: + armamean.head(activecols) = armaSigma.submat(0, 0, activecols-1, activecols-1) * + armaXt.submat(0, 0, activecols-1, T-1) * + armaytilde; + + // draw from the r-variate normal distribution + armadraw = rnorm(r); + + try { + armafacloadtmp(arma::span(oldpos, oldpos + activecols - 1)) = armamean.head(activecols) + armaRinv.submat(0,0,activecols-1,activecols-1) * armadraw.head(activecols); + } catch(...) { + ::Rf_error("Error: Couldn't sample row %i of factor loadings", j+1); + } + + // Rprintf("\n%i to %i: ", oldpos, oldpos+activecols-1); + //for (int is = oldpos; is < oldpos+activecols; is++) Rprintf("%f ", armafacloadtmp(is)); + //Rprintf("\n\n"); + oldpos = oldpos + activecols; + + } + armafacloadt(armafacloadtunrestrictedelements) = armafacloadtmp; + armafacload = arma::trans(armafacloadt); + + //Rprintf("\n\n"); + //for (int is = 0; is < m; is++) Rprintf("%f %f\n", curfacload(is, 0), curfacload(is, 1)); + // STEP 2+: "Deep" Interweaving + + + for (int j = 0; j < r; j++) { + + int userow = j; + if (interweaving == 4) { // find largest absolute element in column to interweave + userow = 0; + for (int k = 1; k < m; k++) if (std::fabs(armafacload(k, j)) > std::fabs(armafacload(userow, j))) userow = k; + } + + + //Rprintf("%i and %i\n", j, userow); + + double phi = curpara(1,m+j); + double sigma = curpara(2,m+j); + double mu_old = log(armafacload(userow,j) * armafacload(userow,j)); + hopen = armah.col(m+j) + mu_old; + double h0open = armah0(m+j) + mu_old; + double logacceptrate; + double mu_prop; + + if (priorh0(m+j) < 0.) { // old prior for h0 (stationary distribution, depends on phi), as in JCGS submission Feb 2016 + double tmph = hopen(0) - phi*h0open; + for (int k = 1; k < T; k++) tmph += hopen(k) - phi*hopen(k-1); + + double gamma_old = (1 - phi) * mu_old; + double gamma_prop = as(rnorm(1, tmph/(T+B011inv), sigma/std::sqrt(T+B011inv))); + mu_prop = gamma_prop/(1-phi); + + logacceptrate = logdnormquot(mu_prop, mu_old, h0open, sigma/std::sqrt(1-phi*phi)); + logacceptrate += logspecialquot(gamma_prop, gamma_old, .5, 1/(2.*armatau2(userow,j)), 1-phi); + logacceptrate += logdnormquot(gamma_old, gamma_prop, 0., sigma*std::sqrt(1/B011inv)); + + } else { // new prior does not depend on phi + double tmph = hopen(0); + for (int k = 1; k < (T-1); k++) tmph += hopen(k); + + double tmp4prop = T*priorh0(m+j)*(1-phi)*(1-phi) + 1; + double prop_mean = (priorh0(m+j) * (1-phi) * (hopen(T-1) + (1-phi)*tmph - phi*h0open) + h0open) / tmp4prop; + double prop_sd = (sqrt(priorh0(m+j)) * sigma) / std::sqrt(tmp4prop); + + mu_prop = as(rnorm(1, prop_mean, prop_sd)); + logacceptrate = .5 * ((mu_prop - mu_old) - (std::exp(mu_prop) - std::exp(mu_old)) / armatau2(userow,j)); + } + + // NEW, same for both priors: + arma::vec relevantload = armafacload.col(j); + arma::vec relevanttau2 = armatau2.col(j); + + // use all except interwoven element (restricted loadings are assumed to be zero!) + double mysum = accu(square(nonzeros(relevantload))/nonzeros(relevanttau2)) - + (relevantload(userow)*relevantload(userow))/relevanttau2(userow); + + logacceptrate += .5 * ((nonzerospercol(j)-1)*(mu_prop - mu_old) - + mysum / (armafacload(userow,j)*armafacload(userow,j)) * (exp(mu_prop) - exp(mu_old))); + + + // Rprintf("ACCEPT? "); + + //ACCEPT/REJECT + if (log(as(runif(1))) < logacceptrate) { + // Rprintf("ACC col %i el %02i - ", j+1, userow+1); + armah.col(m+j) = hopen - mu_prop; + armah0(m+j) = h0open - mu_prop; + + double tmp = std::exp(mu_prop/2)/armafacload(userow,j); + armafacload.col(j) *= tmp; + armaf.row(j) *= 1/tmp; + // } else { + // Rprintf("REJ col %i el %02i - ", j+1, userow+1); + } + } + // STEP 3: + // update the factors (T independent r-variate regressions with m observations) + + + if (samplefac) { + armadraw2 = rnorm(r*T); + for (int j = 0; j < T; j++) { + + // transposed design matrix Xt2 (r x m) is filled "manually" + for (int k = 0; k < m; k++) { + for (int l = 0; l < r; l++) { + armaXt2(l, k) = armafacload(k, l) * armahtilde(j,k); + } + } + + armaytilde2 = armay.col(j) % armahtilde.row(j).t(); + + // Now draw form the multivariate normal distribution + + // armaSigma2 is first used as temporary variable (to hold the precision): + armaSigma2 = armaXt2 * armaXt2.t(); + + // add precisions to diagonal: + armaSigma2.diag() += exp(-armah(j, arma::span(m, mpr-1))); + + // find Cholesky factor of posterior precision + try { + armaR2 = arma::chol(armaSigma2); + } catch (...) { + ::Rf_error("Error: Couldn't Cholesky-decompose posterior factor precision at time %i of %i", j+1, T); + } + + try { + // armaR2inv = arma::inv(R2); # This is a little bit faster for very small matrices but a lot slower for large ones... + // armaR2inv = arma::inv(arma::trimatu(armaR2)); # This is OK on Native R but not so nice in OpenBLAS + armaR2inv = arma::solve(arma::trimatu(armaR2), arma::eye(r, r)); + } catch (...) { + ::Rf_error("Error: Couldn't invert Cholesky factor of posterior factor precision at time %i of %i",j+1, T); + } + + // calculate posterior covariance matrix armaSigma2: + armaSigma2 = armaR2inv * armaR2inv.t(); + + // calculate posterior mean armamean2: + armamean2 = armaSigma2 * armaXt2 * armaytilde2; + + // draw from the r-variate normal distribution + try { + armaf.col(j) = armamean2 + (armaR2inv * armadraw2.subvec(j*r, (j+1)*r - 1)); + } catch(...) { + ::Rf_error("Error: Couldn't sample factors at time %i of %i", j+1, T); + } + } + } + } + + + // SIGN SWITCH: + if (signswitch) { + for (int j = 0; j < r; j++) { + if (as(runif(1)) > .5) { + armafacload.col(j) *= -1; + armaf.row(j) *= -1; + } + } + } +} diff --git a/src/update_ng.cpp b/src/update_ng.cpp index 4c4e9c0..286e7f0 100644 --- a/src/update_ng.cpp +++ b/src/update_ng.cpp @@ -17,12 +17,16 @@ void update_ng(double & phi_mu, double & lambda_mu, arma::vec & omega, arma::uwo // Update omega double gig_lambda = phi_mu-0.5; - double gig_chi = lambda_mu * phi_mu; - arma::vec gig_psi = arma::pow(psi_i-prior_psi_mean, 2.0); + //double gig_chi = lambda_mu * phi_mu; + //arma::vec gig_psi = arma::pow(psi_i-prior_psi_mean, 2.0); + + arma::vec gig_chi = arma::pow(psi_i-prior_psi_mean, 2.0); + double gig_psi = lambda_mu * phi_mu; + for (arma::uword i = 0; i < nm; ++i) { - omega(i) = do_rgig1(gig_lambda, gig_chi, gig_psi(i)); + //omega(i) = do_rgig1(gig_lambda, gig_chi, gig_psi(i)); + omega(i) = do_rgig1(gig_lambda, gig_chi(i), gig_psi); } - // Update lambda lambda_mu = R::rgamma((double)nm * phi_mu + c0, 1.0/(0.5 * phi_mu * arma::accu(omega) + c1)); // Check parametrization