├── .DS_Store ├── .Rbuildignore ├── .gitattributes ├── .gitignore ├── .travis.yml ├── DESCRIPTION ├── MFBVAR.Rproj ├── NAMESPACE ├── NEWS.md ├── R ├── RcppExports.R ├── builders.R ├── data.R ├── densities.R ├── eval.R ├── fill_na.R ├── interface.R ├── interval_to_moments.R ├── list_to_matrix.R ├── mcmc_sampler.R ├── mcmc_sampler_csv.R ├── mcmc_sampler_diffuse.R ├── mcmc_sampler_fsv.R ├── mcmc_sampler_iw.R ├── mdd.R ├── mfbvar-package.R ├── mfsv.R ├── ols.R ├── posteriors.R ├── prior_pi_sigma.R ├── utils.R └── zzz.R ├── README.md ├── _config.yml ├── cleanup ├── codecov.yml ├── configure ├── configure.ac ├── cran-comments.md ├── data ├── mf_sweden.RData └── mf_usa.RData ├── inst ├── CITATION ├── data_prep.R └── include │ ├── auxmix.h │ ├── eta_progress_bar.hpp │ ├── mfbvar.h │ ├── mvn.h │ ├── mvn_par.h │ ├── progutils.h │ ├── simsm_adaptive_cv.h │ ├── simsm_adaptive_sv.h │ ├── simsm_adaptive_univariate.h │ ├── simsm_utils.h │ ├── update_csv.h │ ├── update_dl.h │ ├── update_fsv.h │ └── update_ng.h ├── man-roxygen └── man_template.R ├── man ├── estimate_mfbvar.Rd ├── interval_to_moments.Rd ├── mdd.Rd ├── mdd.mfbvar_minn_iw.Rd ├── mdd.mfbvar_ss_iw.Rd ├── mf_sweden.Rd ├── mf_usa.Rd ├── mfbvar.Rd ├── plot-mfbvar.Rd ├── plot.mfbvar_prior.Rd ├── predict.mfbvar.Rd ├── print.mfbvar.Rd ├── print.mfbvar_prior.Rd ├── set_prior.Rd ├── summary.mfbvar.Rd └── summary.mfbvar_prior.Rd ├── src ├── Makevars.in ├── Makevars.win ├── RcppExports.cpp ├── auxmix.cpp ├── builders.cpp ├── dl_reg.cpp ├── kf_cpp.cpp ├── max_eig_cpp.cpp ├── mcmc_csv.cpp ├── mcmc_diffuse.cpp ├── mcmc_fsv.cpp ├── mcmc_iw.cpp ├── minn_utils.h ├── mvn_par.cpp ├── plot_funs.cpp ├── posteriors.cpp ├── progutils.cpp ├── progutils_fsv.cpp ├── progutils_fsv.h ├── rgig.cpp ├── rmvn.cpp ├── rnd_numbers.cpp ├── rsimsm_adaptive_cv.cpp ├── rsimsm_adaptive_univariate.cpp ├── smoothing.cpp ├── ss_utils.h ├── update_csv.cpp ├── update_demean.cpp ├── update_dl.cpp ├── update_fsv.cpp ├── update_ng.cpp └── utils.cpp ├── tests ├── testthat.R └── testthat │ ├── Pi_minn.rds │ ├── Pi_ss.rds │ ├── Sigma_minn.rds │ ├── Sigma_ss.rds │ ├── Z_minn.rds │ ├── Z_ss.rds │ ├── mdd_minn.rds │ ├── mdd_ss1.rds │ ├── mdd_ss2.rds │ ├── psi_ss.rds │ ├── test_mcmc.R │ ├── test_mfbvar.R │ ├── test_plot.R │ └── test_predict.R └── vignettes ├── .DS_Store ├── alfred_data.RData ├── figures ├── ridges-1.pdf ├── ss_plots-1.pdf ├── ss_plots-2.pdf ├── varplot-1.pdf └── varplot-2.pdf ├── mfbvar_jss.Rnw ├── refs.bib └── vignette_data.RData /.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/.DS_Store -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | man-roxygen 4 | ^README\.Rmd$ 5 | ^README-.*\.png$ 6 | README_cache 7 | ^\.travis\.yml$ 8 | ^_config\.yml$ 9 | ^codecov\.yml$ 10 | ^cran-comments\.md$ 11 | ^/\.gitattributes$ 12 | ^doc$ 13 | ^Meta$ 14 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Declare files that will always have LF line endings on checkout. 2 | ^configure\.ac$ text eol=lf 3 | ^cleanup$ text eol=lf -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | src/*.o 5 | src/*.so 6 | src/*.dll 7 | README_cache/ 8 | src/.DS_Store 9 | Meta 10 | .DS_Store 11 | doc 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # R for travis: see documentation at https://docs.travis-ci.com/user/languages/r 2 | 3 | language: R 4 | sudo: true 5 | cache: packages 6 | warnings_are_errors: true 7 | os: 8 | - linux 9 | - osx 10 | r: 11 | - release 12 | 13 | branches: 14 | only: 15 | - master 16 | 17 | r_github_packages: 18 | - r-lib/covr 19 | r_binary_packages: 20 | - Rcpp 21 | - RcppArmadillo 22 | - ggplot2 23 | - pbapply 24 | - testthat 25 | - roxygen2 26 | - devtools 27 | - factorstochvol 28 | - tinytex 29 | 30 | before_install: 31 | - chmod +x configure 32 | - chmod +x cleanup 33 | 34 | r_build_args: --no-build-vignettes --no-manual --no-resave-data 35 | r_check_args: --ignore-vignettes --no-manual 36 | 37 | 38 | after_success: 39 | - tar -C .. -xf $PKG_TARBALL 40 | - Rscript -e 'covr::codecov()' 41 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: mfbvar 2 | Type: Package 3 | Title: Mixed-Frequency Bayesian VAR Models 4 | Version: 0.5.6 5 | Date: 2021-02-09 6 | Authors@R: c( 7 | person("Sebastian", "Ankargren", email = "sebastian.ankargren@statistics.uu.se", role = c("cre", "aut"), comment = c(ORCID = "0000-0003-4415-8734")), 8 | person("Yukai", "Yang", email = "yukai.yang@statistics.uu.se", role = c("aut"), comment=c(ORCID="0000-0002-2623-8549")), 9 | person("Gregor", "Kastner", role = "ctb", comment = c(ORCID="0000-0002-8237-8271"))) 10 | Description: Functions and tools for estimation of mixed-frequency Bayesian vector autoregressive (VAR) models. The package implements a state space-based VAR model that handles mixed frequencies of the data as proposed by Schorfheide and Song (2015) , and extensions thereof developed by Ankargren, Unosson and Yang (2020) , Ankargren and Joneus (2019) , and Ankargren and Joneus (2020) . The models are estimated using Markov Chain Monte Carlo to numerically approximate the posterior distribution. Prior distributions that can be used include normal-inverse Wishart and normal-diffuse priors as well as steady-state priors. Stochastic volatility can be handled by common or factor stochastic volatility models. 11 | License: GPL-3 12 | LazyData: TRUE 13 | URL: https://github.com/ankargren/mfbvar 14 | BugReports: https://github.com/ankargren/mfbvar/issues 15 | Imports: 16 | Rcpp (>= 0.12.7), 17 | ggplot2 (>= 3.3.0), 18 | methods, 19 | lubridate, 20 | GIGrvg, 21 | stochvol (>= 2.0.3), 22 | RcppParallel, 23 | dplyr, 24 | magrittr, 25 | tibble, 26 | zoo 27 | LinkingTo: 28 | Rcpp, 29 | RcppArmadillo, 30 | RcppProgress, 31 | stochvol (>= 2.0.3), 32 | RcppParallel 33 | Depends: R (>= 3.5.0) 34 | Suggests: testthat, covr, knitr, ggridges, alfred, factorstochvol 35 | RoxygenNote: 7.1.1 36 | Encoding: UTF-8 37 | SystemRequirements: GNU make 38 | VignetteBuilder: knitr 39 | -------------------------------------------------------------------------------- /MFBVAR.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source --clean --compact-vignettes=both 21 | PackageBuildArgs: --compact-vignettes=both 22 | PackageBuildBinaryArgs: --compact-vignettes=both 23 | PackageCheckArgs: --as-cran --clean --compact-vignettes=both 24 | PackageRoxygenize: rd,collate 25 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | importFrom(Rcpp, evalCpp) 2 | useDynLib(mfbvar, .registration = TRUE) 3 | import(stats) 4 | importFrom(magrittr,"%>%") 5 | importFrom(tibble,"tibble") 6 | importFrom(dplyr, "group_by", "summarize", "ungroup", "mutate", "transmute", "bind_rows", "pull") 7 | importFrom(lubridate, "%m-%", "%m+%", "days", "ymd", "quarter", "month", "year", 8 | "as_date", "day", "days_in_month", "ceiling_date", "floor_date") 9 | import(ggplot2) 10 | importFrom(zoo, "as.Date", "zoo", "as.Date.ts", "index", "merge.zoo") 11 | importFrom(stochvol,svsample) 12 | S3method(print, mfbvar_prior) 13 | S3method(summary, mfbvar_prior) 14 | S3method(print, mfbvar) 15 | S3method(summary, mfbvar) 16 | S3method(plot, mfbvar_minn) 17 | S3method(plot, mfbvar_ss) 18 | S3method(plot, mfbvar_ssng) 19 | S3method(plot, mfbvar_dl) 20 | S3method(plot, mfbvar_prior) 21 | S3method(mcmc_sampler, mfbvar_minn_fsv) 22 | S3method(mcmc_sampler, mfbvar_dl_fsv) 23 | S3method(mcmc_sampler, mfbvar_ss_fsv) 24 | S3method(mcmc_sampler, mfbvar_ssng_fsv) 25 | S3method(mcmc_sampler, mfbvar_minn_diffuse) 26 | S3method(mcmc_sampler, mfbvar_dl_diffuse) 27 | S3method(mcmc_sampler, mfbvar_ss_diffuse) 28 | S3method(mcmc_sampler, mfbvar_ssng_diffuse) 29 | S3method(mcmc_sampler, mfbvar_minn_csv) 30 | S3method(mcmc_sampler, mfbvar_ss_csv) 31 | S3method(mcmc_sampler, mfbvar_ssng_csv) 32 | S3method(mcmc_sampler, mfbvar_minn_iw) 33 | S3method(mcmc_sampler, mfbvar_ss_iw) 34 | S3method(mcmc_sampler, mfbvar_ssng_iw) 35 | S3method(mdd, mfbvar_ss_iw) 36 | S3method(mdd, mfbvar_minn_iw) 37 | S3method(predict, mfbvar) 38 | S3method(predict, sfbvar) 39 | importFrom("methods", "hasArg") 40 | export(mdd) 41 | export(set_prior) 42 | export(update_prior) 43 | export(estimate_mfbvar) 44 | export(interval_to_moments) 45 | export(varplot) 46 | importFrom(GIGrvg,rgig) 47 | importFrom(RcppParallel, RcppParallelLibs) 48 | 49 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # mfbvar 0.5.6 (2021-02-03) 2 | * Removed use of internet connection in vignette 3 | * Enabled use of weekly-monthly frequency mix 4 | 5 | # mfbvar 0.5.4 (2020-05-14) 6 | * Changes to the main interface. Data can (and should) now be given as a list of `zooreg` or `ts` objects. 7 | 8 | # mfbvar 0.5.3 (2020-03-18) 9 | * Fixed a bug caused by the plotting functions 10 | 11 | # mfbvar 0.5.1 (2019-08-16) 12 | * Support for more priors 13 | * Stochastic volatility models 14 | * Better `predict` functions 15 | * Faster implementations 16 | * Some support for quarterly/monthly (i.e. single-frequency) models 17 | * Vignette added 18 | 19 | # TODO 20 | * Impulse responses 21 | * Marginal data densities for more specifications (currently `minn`-`iw` with `average` only), and in C++ 22 | * Enable use of less lags than what the aggregations need 23 | 24 | -------------------------------------------------------------------------------- /R/builders.R: -------------------------------------------------------------------------------- 1 | #' Build the \eqn{D} matrix 2 | #' 3 | #' \code{build_DD} builds the \eqn{D} matrix. 4 | #' 5 | #' @templateVar d TRUE 6 | #' @templateVar n_lags TRUE 7 | #' @keywords internal 8 | #' @noRd 9 | #' @template man_template 10 | #' 11 | #' @return \item{DD}{A matrix of size \code{n_T * ((n_lags + 1)*n_determ)} where 12 | #' row \code{t} is \eqn{(d_t', -d_{t-1}', \dots, -d_{t-k}')}.} 13 | 14 | build_DD <- function(d, n_lags) { 15 | # Inputs: 16 | 17 | 18 | n_T <- nrow(d) 19 | DD <- d[-(1:(n_lags)), ] 20 | for (i in 1:n_lags) { 21 | DD <- cbind(DD, -d[-c(0:(n_lags-i), ((n_T-i+1):n_T)), ]) 22 | } 23 | return(DD) 24 | # The output is a (t_1-t_0+1)*pk matrix 25 | } 26 | 27 | #' Build the companion matrix for the dynamic parameters 28 | #' 29 | #' Builds the parameter matrix of dynamic coefficients for the companion form representation. 30 | #' 31 | #' @templateVar Pi TRUE 32 | #' @templateVar n_vars TRUE 33 | #' @templateVar n_lags TRUE 34 | #' @keywords internal 35 | #' @noRd 36 | #' @template man_template 37 | #' 38 | #' @return 39 | #' \item{Pi_comp}{The companion form matrix of size \code{(n_vars*n_lags) * (n_vars*n_lags)}}. 40 | 41 | build_companion <- function(Pi, n_vars, n_lags) { 42 | rbind(Pi, cbind(diag(n_vars*(n_lags-1)), matrix(0, ncol = n_vars, nrow = n_vars*(n_lags-1)))) 43 | } 44 | 45 | #' Build the \eqn{Z} matrix 46 | #' 47 | #' Builds the \eqn{Z} matrix, which consists of lags of \eqn{z}. 48 | #' 49 | #' @templateVar z TRUE 50 | #' @templateVar n_lags TRUE 51 | #' @keywords internal 52 | #' @noRd 53 | #' @template man_template 54 | #' 55 | #' @return 56 | #' \item{Z}{A matrix of size \code{n_T * (n_vars*n_lags)}.} 57 | 58 | build_Z <- function(z, n_lags) { 59 | # Inputs: 60 | 61 | 62 | n_T <- nrow(z) 63 | Z <- z[-(1:(n_lags-1)), ] 64 | for (i in 2:n_lags) { 65 | Z <- cbind(Z, z[-c(0:(n_lags-i), ((n_T-i+2):n_T)), ]) 66 | } 67 | return(Z) 68 | # The output is a (t_1-t_0+1)*pk matrix 69 | } 70 | 71 | #' Build the \code{U} matrix 72 | #' 73 | #' Builds the parameter matrix of dynamic coefficients for the companion form representation. 74 | #' 75 | #' @templateVar Pi TRUE 76 | #' @templateVar n_determ TRUE 77 | #' @template man_template 78 | #' @keywords internal 79 | #' @noRd 80 | #' @describeIn build_U Build the U matrix (R implementation) 81 | #' 82 | #' @return 83 | #' \item{U}{The \code{U} matrix, of size \code{((n_lags+1)n_vars*n_determ) * n_vars*n_determ}.} 84 | 85 | build_U <- function(Pi, n_determ) { 86 | # Pi is (Pi_1, ..., Pi_k)' 87 | n_vars <- dim(Pi)[1] 88 | n_lags <- dim(Pi)[2]/n_vars 89 | U <- diag(n_vars*n_determ) 90 | for(i in 1:n_lags) { 91 | U <- rbind(U, kronecker(diag(n_determ), Pi[, (1 + (i-1)*n_vars):(i*n_vars)])) 92 | } 93 | return(U) 94 | } 95 | 96 | #' Build the lag-corrected data matrix 97 | #' 98 | #' Builds the \eqn{\tilde{Y}=\Pi(L)Y} matrix. 99 | #' 100 | #' @templateVar Pi TRUE 101 | #' @templateVar z TRUE 102 | #' @template man_template 103 | #' @keywords internal 104 | #' @noRd 105 | #' 106 | #' @return 107 | #' \item{Y_tilde}{A matrix of size \code{n_T * n_vars}.} 108 | #' @details Note that \code{z} does not contain missing values; at this point, the missing values have been replaced by values drawn using the simulation smoother. 109 | 110 | build_Y_tilde <- function(Pi, z) { 111 | n_vars <- nrow(Pi) 112 | n_lags <- ncol(Pi)/n_vars 113 | Z <- build_Z(z, n_lags) # This gives Z_{0:T}, we need Z_{0:T-1} 114 | Z <- Z[-nrow(Z), ] 115 | 116 | Y_tilde <- z[-(1:(n_lags)), ] - Z %*% t(Pi) 117 | return(Y_tilde) 118 | } 119 | 120 | #' Build the \eqn{M_t\Lambda} matrices 121 | #' 122 | #' Builds the selection matrices \eqn{M_t\Lambda}. 123 | #' @templateVar Y TRUE 124 | #' @templateVar Lambda TRUE 125 | #' @templateVar n_vars TRUE 126 | #' @templateVar n_lags TRUE 127 | #' @templateVar n_T TRUE 128 | #' @keywords internal 129 | #' @noRd 130 | #' @template man_template 131 | #' 132 | #' @return 133 | #' \item{M_Lambda}{A list of length \code{n_T}.} 134 | #' @details The element \code{M_Lambda[[t]]} corresponds to \eqn{M_t\Lambda}. Currently, if element \code{i} of \code{Y[t, ]} is \code{NA}, then row \code{i} of \code{M_Lambda[[t]]} is all \code{NA}. 135 | 136 | build_M_Lambda <- function(Y, Lambda, n_vars, n_lags, n_T) { 137 | M_Lambda <- list() 138 | for (i in 1:n_T) { 139 | M_Lambda[[i]] <- matrix(diag(n_vars), ncol = n_vars) %*% Lambda 140 | if (any(is.na(Y[i, ]))) { 141 | M_Lambda[[i]][is.na(Y[i, ]), ] <- NA 142 | } 143 | } 144 | return(M_Lambda) 145 | } 146 | 147 | #' Build the \eqn{\Lambda} matrix 148 | #' 149 | #' Builds the aggregation matrix \eqn{\Lambda}. 150 | #' @templateVar aggregation TRUE 151 | #' @templateVar n_lags TRUE 152 | #' @template man_template 153 | #' @keywords internal 154 | #' @noRd 155 | #' @return 156 | #' \item{Lambda}{An \code{n_vars * (n_vars*n_pseudolags)} matrix, where \code{n_pseudolags} is \code{max(5, n_lags)} if any variable uses the triangular aggregation scheme, \code{max(3, n_lags)} if any uses the quarterly average.} 157 | #' @details The choice \code{aggregation = "identity"} means that what is observed is assumed to be exactly the underlying variable, whereas \code{aggregation = "average"} uses the quarterly average of the monthly underlying observations. Lastly, \code{aggregation = "triangular"} uses the triangular specification used by Mariano and Murasawa (2010). 158 | build_Lambda <- function(aggregation, n_lags) { 159 | n_vars <- length(aggregation) 160 | if (any(aggregation %in% "triangular") && n_lags < 5) { 161 | Lambda <- matrix(0, n_vars, n_vars * 5) 162 | } else if (n_lags > 2) { 163 | Lambda <- matrix(0, n_vars, n_vars * n_lags) 164 | } else { 165 | stop("Too few lags!") 166 | } 167 | 168 | n_pseudolags <- dim(Lambda)[2]/n_vars 169 | for (i in 1:n_vars) { 170 | if (aggregation[i] == "m") { 171 | fill_vec <- c(1, rep(0, n_pseudolags - 1)) 172 | } 173 | if (aggregation[i] == "average") { 174 | fill_vec <- c(rep(1/3, 3), rep(0, n_pseudolags - 3)) 175 | } 176 | if (aggregation[i] == "triangular") { 177 | fill_vec <- c(1/3, 2/3, 1, 2/3, 1/3, rep(0, n_pseudolags - 5))/3 # Divide by three to make commensurate in scale 178 | } 179 | 180 | Lambda[i, seq(i, n_pseudolags * n_vars, by = n_vars)] <- fill_vec 181 | } 182 | return(Lambda) 183 | } 184 | -------------------------------------------------------------------------------- /R/data.R: -------------------------------------------------------------------------------- 1 | #' Real-time data set for Sweden. 2 | #' 3 | #' A dataset containing real-time data for mixed and quarterly frequencies. 4 | #' 5 | #' @format A mixed-frequency data set of five Swedish macroeconomic variables. 6 | #' \describe{ 7 | #' \item{unemp}{harmonized unemployment rate (source: OECD)} 8 | #' \item{infl}{inflation rate (source: OECD)} 9 | #' \item{ip}{industrial production (source: OECD)} 10 | #' \item{eti}{economic tendency indicator (source: National Institute of Economic Research)} 11 | #' \item{gdp}{GDP growth (source: Statistics Sweden)} 12 | #' } 13 | #' @references 14 | #' OECD (2016) MEI Archive: Revisions Analysis Dataset.\cr 15 | #' Billstam, M., Fr\''{a}nd\'{e}n, J., Samuelsson, J., \"{O}sterholm, P. (2016) Quasi-Real-Time Data of the Economic Tendency Survey. Working Paper No. 143, National Institute of Economic Research. 16 | #' Statistics Sweden (2016) Revisions, expenditure approach and hours worked at each release. 17 | #' 18 | "mf_sweden" 19 | 20 | #' US Macroeconomic Data Set 21 | #' 22 | #' A dataset containing mixed-frequency data from FRED for three US macroeconomic variables. 23 | #' 24 | #' @format A list with components: 25 | #' \describe{ 26 | #' \item{CPIAUCSL}{inflation rate} 27 | #' \item{UNRATE}{unemployment rate} 28 | #' \item{GDPC1}{GDP growth rate} 29 | #' } 30 | "mf_usa" 31 | -------------------------------------------------------------------------------- /R/densities.R: -------------------------------------------------------------------------------- 1 | #' Normal inverse Wishart density function 2 | #' 3 | #' Density function for the (matrix) normal inverse Wishart distribution 4 | #' @templateVar X TRUE 5 | #' @templateVar Sigma TRUE 6 | #' @templateVar M TRUE 7 | #' @templateVar Q TRUE 8 | #' @templateVar P TRUE 9 | #' @templateVar S TRUE 10 | #' @templateVar v TRUE 11 | #' @keywords internal 12 | #' @noRd 13 | #' @template man_template 14 | #' @return 15 | #' For \code{dnorminvwish}: the evaluated density.\\n 16 | #' For \code{rmatn} or \code{rinvwish}: the random numbers. 17 | dnorminvwish <- function(X, Sigma, M, P, S, v) { 18 | q <- dim(Sigma)[1] 19 | p <- dim(P)[1] 20 | det_Sigma <- det(Sigma) 21 | inv_Sigma <- chol2inv(chol(Sigma)) 22 | dmultnorm <- (-p*q/2) * log(2 * pi) + (-p/2) * log(det_Sigma) + (-q/2)*log(det(P)) + (-1/2 * sum(diag(inv_Sigma %*% t(X - M) %*% chol2inv(chol(P)) %*% (X - M)))) 23 | cc <- (v * q/2)*log(2) + (q*(q-1)/4)*log(pi) + sum(lgamma((v+1-1:q)/2)) 24 | dinvwish <- -cc + (v/2) * log(det(S)) -(v+q+1)/2*log(det_Sigma) -1/2 * sum(diag(inv_Sigma %*% S)) 25 | return(dmultnorm + dinvwish) 26 | } 27 | 28 | #' Multivariate normal density function 29 | #' 30 | #' Density function for the multivariate normal distribution 31 | #' @templateVar x TRUE 32 | #' @templateVar m TRUE 33 | #' @template man_template 34 | #' @inherit dnorminvwish 35 | #' @keywords internal 36 | #' @noRd 37 | #' @return 38 | #' For \code{dmultn}: the evaluated density.\\n 39 | #' For \code{rmultn}: \eqn{p} random numbers. 40 | dmultn <- function(x, m, Sigma) { 41 | log_d <- (-1/2)* log(det(2*pi*Sigma)) -1/2 * t(x-m) %*% chol2inv(chol(Sigma)) %*% (x-m) 42 | return(log_d) 43 | } 44 | 45 | #' Truncated multivariate normal density function 46 | #' 47 | #' Density function for the truncated multivariate normal distribution 48 | #' @templateVar V_inv TRUE 49 | #' @param d The number of components. 50 | #' @templateVar p_trunc TRUE 51 | #' @templateVar chisq_val TRUE 52 | #' @template man_template 53 | #' @keywords internal 54 | #' @noRd 55 | #' @inherit dmultn 56 | dnorm_trunc <- function(x, m, V_inv, d, p_trunc, chisq_val) { 57 | qf <- t(x - m) %*% V_inv %*% (x - m) 58 | return((1/p_trunc) * (1/sqrt((2*pi)^d/det(V_inv))) * exp(-0.5 * qf) * (qf < chisq_val)) 59 | } 60 | 61 | #' Matrix t distribution 62 | #' 63 | #' Density function for the truncated multivariate normal distribution 64 | #' @param X \code{p * q} matrix at which the density is to be evaluated 65 | #' @param M \code{p * q} matrix of means 66 | #' @param P \code{p * p} scale matrix 67 | #' @param Q \code{q * q} scale matrix 68 | #' @param v degrees of freedom 69 | #' @keywords internal 70 | #' @inherit dmultn 71 | #' @noRd 72 | #' @references Karlsson, S. (2013) Forecasting with Bayesian Vector Autoregression. 73 | #' In Elliott, G. and Timmermann, A., editors, \emph{Handbook of Economic Forecasting}, 74 | #' volume 2, chapter 15, pp. 791-897. Elsevier B.V. 75 | dmatt <- function(X, M, P, Q, v) { 76 | q <- ncol(X) 77 | p <- nrow(X) 78 | k <- p*q/2*log(pi)-q/2*log(det(P))-v/2*log(det(Q))+sum(lgamma((v+1-(1:q))/2)-lgamma((v+p+1-(1:q))/2)) 79 | return(-k -(v+p)/2*log(det(Q+t(X-M) %*% P %*% (X-M)))) 80 | } 81 | -------------------------------------------------------------------------------- /R/eval.R: -------------------------------------------------------------------------------- 1 | #' Evaluate the conditional posterior of Pi and Sigma using Rao-Blackwellization 2 | #' 3 | #' Evaluates the conditional posterior of Pi and Sigma using Rao-Blackwellization of the draws from the Gibbs sampler. 4 | #' @templateVar Z_array TRUE 5 | #' @templateVar d TRUE 6 | #' @templateVar post_psi_center TRUE 7 | #' @templateVar post_Pi_center TRUE 8 | #' @templateVar post_Sigma_center TRUE 9 | #' @templateVar post_nu TRUE 10 | #' @templateVar prior_Pi TRUE 11 | #' @templateVar prior_Pi_Omega TRUE 12 | #' @templateVar prior_S TRUE 13 | #' @templateVar n_vars TRUE 14 | #' @templateVar n_lags TRUEF 15 | #' @templateVar n_reps TRUE 16 | #' @template man_template 17 | #' @keywords internal 18 | #' @noRd 19 | #' @return The return is: 20 | #' \item{evals}{A vector with the evaulations.} 21 | #' 22 | eval_Pi_Sigma_RaoBlack <- function(Z_array, d, post_psi_center, post_Pi_center, post_Sigma_center, post_nu, prior_Pi_mean, prior_Pi_Omega, prior_S, n_vars, n_lags, n_reps) { 23 | ################################################################ 24 | ### Compute the Rao-Blackwellized estimate of posterior 25 | 26 | evals <- vector("numeric", n_reps - 1) 27 | inv_prior_Pi_Omega <- chol2inv(chol(prior_Pi_Omega)) 28 | Omega_Pi <- inv_prior_Pi_Omega %*% prior_Pi_mean 29 | for (i in 1:length(evals)) { 30 | # Demean z, create Z_array (companion form version) 31 | demeaned_z <- Z_array[,,i+1] - d %*% post_psi_center 32 | demeaned_Z <- mfbvar:::build_Z(z = demeaned_z, n_lags = n_lags) 33 | XX <- demeaned_Z[-nrow(demeaned_Z), ] 34 | YY <- demeaned_Z[-1, 1:n_vars] 35 | XXt.XX <- crossprod(XX) 36 | XXt.XX.inv <- chol2inv(chol(XXt.XX)) 37 | Pi_sample <- XXt.XX.inv %*% crossprod(XX, YY) 38 | ################################################################ 39 | ### Pi and Sigma step 40 | 41 | # Posterior moments of Pi 42 | post_Pi_Omega_i <- chol2inv(chol(inv_prior_Pi_Omega + XXt.XX)) 43 | post_Pi_i <- post_Pi_Omega_i %*% (Omega_Pi + crossprod(XX, YY)) 44 | 45 | # Then Sigma 46 | s_sample <- crossprod(YY - XX %*% Pi_sample) 47 | Pi_diff <- prior_Pi_mean - Pi_sample 48 | post_s_i <- prior_S + s_sample + t(Pi_diff) %*% chol2inv(chol(prior_Pi_Omega + XXt.XX.inv)) %*% Pi_diff 49 | 50 | # Evaluate 51 | evals[i] <- dnorminvwish(X = t(post_Pi_center), Sigma = post_Sigma_center, M = post_Pi_i, P = post_Pi_Omega_i, S = post_s_i, v = post_nu) 52 | } 53 | 54 | return(evals) 55 | 56 | } 57 | 58 | #' Evaluate the marginal posterior of psi 59 | #' 60 | #' Evaluates the marginal posterior of psi using the draws from the Gibbs sampler. 61 | #' @templateVar Pi_array TRUE 62 | #' @templateVar Sigma_array TRUE 63 | #' @templateVar Z_array TRUE 64 | #' @templateVar post_psi_center TRUE 65 | #' @templateVar prior_psi_mean TRUE 66 | #' @templateVar prior_psi_Omega TRUE 67 | #' @templateVar D_mat TRUE 68 | #' @templateVar n_determ TRUE 69 | #' @templateVar n_vars TRUE 70 | #' @templateVar n_lags TRUE 71 | #' @templateVar n_reps TRUE 72 | #' @template man_template 73 | #' @keywords internal 74 | #' @noRd 75 | #' @return The return is: 76 | #' \item{evals}{A vector with the evaulations.} 77 | #' 78 | #' 79 | eval_psi_MargPost <- function(Pi_array, Sigma_array, Z_array, post_psi_center, prior_psi_mean, prior_psi_Omega, D_mat, n_determ, n_vars, n_lags, n_reps) { 80 | post_psi_center <- matrix(post_psi_center, ncol = 1) 81 | 82 | evals <- vector("numeric", n_reps - 1) 83 | 84 | ################################################################ 85 | ### Steady-state step 86 | for (r in 1:(n_reps - 1)) { 87 | U <- build_U_cpp(Pi = Pi_array[,,r], n_determ = n_determ, 88 | n_vars = n_vars, n_lags = n_lags) 89 | post_psi_Omega <- posterior_psi_Omega(U = U, D_mat = D_mat, Sigma = Sigma_array[,, r], 90 | prior_psi_Omega = prior_psi_Omega) 91 | Y_tilde <- build_Y_tilde(Pi = Pi_array[,, r], z = Z_array[,, r]) 92 | 93 | post_psi_center <- posterior_psi_mean(U = U, D_mat = D_mat, Sigma = Sigma_array[,, r], prior_psi_Omega = prior_psi_Omega, 94 | post_psi_Omega = post_psi_Omega, Y_tilde = Y_tilde, prior_psi_mean = prior_psi_mean) 95 | 96 | evals[r] <- exp(dmultn(x = post_psi_center, m = post_psi_center, Sigma = post_psi_Omega)) 97 | } 98 | 99 | return(evals) 100 | } 101 | -------------------------------------------------------------------------------- /R/fill_na.R: -------------------------------------------------------------------------------- 1 | #' Fills NAs with the next non-NA value 2 | #' 3 | #' The function fills elements with \code{NA} with the next non-\code{NA} value (so that quarterly averages observed at the end of the quarter are assumed as observations for the remaining months of the quarter). 4 | #' @templateVar Y TRUE 5 | #' @template man_template 6 | #' @keywords internal 7 | #' @noRd 8 | #' @return A matrix with no \code{NA}s. 9 | fill_na <- function(Y) { 10 | apply(Y, 2, function(x) { 11 | n_x <- length(x) # save lentgh 12 | if (any(is.na(x))) { 13 | x <- x[1:max(which(is.na(x) == FALSE))] # get rid of NAs in the end 14 | for (i in which(is.na(x))) { 15 | x1 <- NA 16 | counter <- 1 17 | while (is.na(x1) == TRUE) { 18 | x1 <- x[i + counter] 19 | counter <- counter + 1 20 | } 21 | x[i] <- x1 22 | } 23 | 24 | trimmed_length <- length(x) 25 | if (trimmed_length < n_x) { 26 | x <- c(x, rep(NA, n_x - trimmed_length)) 27 | for (i in trimmed_length:n_x) { 28 | x[i] <- x[trimmed_length] 29 | } 30 | } 31 | } 32 | x}) 33 | } 34 | 35 | -------------------------------------------------------------------------------- /R/interval_to_moments.R: -------------------------------------------------------------------------------- 1 | #' Interval to moments 2 | #' 3 | #' Convert a matrix of \code{100*(1-alpha)} \% prior probability intervals for the steady states to prior moments. 4 | #' @templateVar prior_psi_int TRUE 5 | #' @param alpha \code{100*(1-alpha)} is the prior probability of the interval 6 | #' @template man_template 7 | #' @return A list with two components: 8 | #' \item{prior_psi_mean}{The prior mean of psi} 9 | #' \item{prior_psi_Omega}{The prior covariance matrix of psi} 10 | #' @examples 11 | #' prior_intervals <- matrix(c(0.1, 0.2, 12 | #' 0.4, 0.6), ncol = 2, byrow = TRUE) 13 | #' psi_moments <- interval_to_moments(prior_intervals) 14 | 15 | interval_to_moments <- function(prior_psi_int, alpha = 0.05) { 16 | stopifnot(is.matrix(prior_psi_int), ncol(prior_psi_int) == 2) 17 | prior_psi_mean <- rowMeans(prior_psi_int) 18 | prior_psi_Omega <- diag(((prior_psi_int[, 2] - prior_psi_int[, 1]) / (qnorm(1-alpha/2, mean = 0, sd = 1)*2))^2) 19 | return(list(prior_psi_mean = prior_psi_mean, prior_psi_Omega = prior_psi_Omega)) 20 | } 21 | -------------------------------------------------------------------------------- /R/list_to_matrix.R: -------------------------------------------------------------------------------- 1 | 2 | list_to_matrix <- function(Y_in) { 3 | 4 | if (all(sapply(Y_in, function(x) inherits(x, "ts"))) || all(sapply(Y_in, function(x) inherits(x, "zoo")))) { 5 | if (all(sapply(Y_in, function(x) inherits(x, "ts")))) { 6 | zoofun <- function(x) { 7 | if (frequency(x) == 4) { 8 | if (is.null(dim(x))) { 9 | zoo::zoo(as.numeric(x), as.Date(zoo::as.Date.ts(x) %m+% months(2))) 10 | } else { 11 | zoo::zoo(as.matrix(x), as.Date(zoo::as.Date.ts(x) %m+% months(2))) 12 | } 13 | } else if (frequency(x) == 12) { 14 | if (is.null(dim(x))) { 15 | zoo::zoo(as.numeric(x), as.Date(zoo::as.Date.ts(x))) 16 | } else { 17 | zoo::zoo(as.matrix(x), as.Date(zoo::as.Date.ts(x))) 18 | 19 | } 20 | } else { 21 | stop("Time series objects can only include monthly and/or quarterly time series.") 22 | } 23 | } 24 | 25 | } else if (all(sapply(Y_in, function(x) inherits(x, "zooreg")))) { 26 | zoofun <- function(x) { 27 | if (frequency(x) == 4) { 28 | if (is.null(dim(x))) { 29 | zoo::zoo(as.numeric(x), as.Date(zoo::as.Date(zoo::index(x)) %m+% months(2))) 30 | } else { 31 | zoo::zoo(as.matrix(x), as.Date(zoo::as.Date(zoo::index(x)) %m+% months(2))) 32 | } 33 | } else if (frequency(x) == 12) { 34 | if (is.null(dim(x))) { 35 | zoo::zoo(as.numeric(x), as.Date(zoo::as.Date(zoo::index(x)))) 36 | } else { 37 | zoo::zoo(as.matrix(x), as.Date(zoo::as.Date(zoo::index(x)))) 38 | } 39 | } else { 40 | stop("Time series objects can only include monthly and/or quarterly time series.") 41 | } 42 | } 43 | } 44 | zoolist <- lapply(Y_in, zoofun) 45 | reducedlist <- Reduce(zoo::merge.zoo, zoolist) 46 | Y <- as.matrix(reducedlist) 47 | rownames(Y) <- as.character(time(reducedlist)) 48 | dim_null <- sapply(zoolist, function(x) is.null(dim(x))) 49 | if (all(dim_null)) { 50 | colnames(Y) <- names(zoolist) 51 | } else if (all(!dim_null)) { 52 | colnames(Y) <- Reduce(c, lapply(zoolist, colnames)) 53 | } else { 54 | name_vec <- c() 55 | for (iter in 1:length(dim_null)) { 56 | if (dim_null[iter]) { 57 | name_vec <- c(name_vec, names(zoolist)[iter]) 58 | } else { 59 | name_vec <- c(name_vec, colnames(zoolist[[iter]])) 60 | } 61 | } 62 | colnames(Y) <- name_vec 63 | } 64 | 65 | if (all(dim_null)) { 66 | zoolistfreq <- sapply(Y_in, frequency) 67 | } else if (all(!dim_null)) { 68 | zoolistfreq <- sapply(Y_in, frequency) 69 | zoolistn <- sapply(Y_in, NCOL) 70 | zoolistfreq <- Reduce(c, mapply(function(x, y) rep(x, each = y), zoolistfreq, zoolistn, SIMPLIFY = FALSE)) 71 | 72 | } else { 73 | zoolistfreq <- c() 74 | for (iter in 1:length(dim_null)) { 75 | if (dim_null[iter]) { 76 | zoolistfreq <- c(zoolistfreq, frequency(Y_in[[iter]])) 77 | } else { 78 | zoolistfreq <- c(zoolistfreq, rep(frequency(Y_in[[iter]]), each = ncol(Y_in[[iter]]))) 79 | } 80 | } 81 | } 82 | names(zoolistfreq) <- NULL 83 | if (all(zoolistfreq %in% c(4, 12))) { 84 | freq <- ifelse(zoolistfreq == 4, "q", "m") 85 | } else { 86 | stop("Only monthly and quarterly frequencies are allowed as time series objects.") 87 | } 88 | } else { 89 | 90 | } 91 | return(list(Y, freq)) 92 | } 93 | -------------------------------------------------------------------------------- /R/mcmc_sampler.R: -------------------------------------------------------------------------------- 1 | #' MCMC sampler 2 | #' 3 | #' \code{mcmc_sampler} is a generic function for deciding which specific MCMC 4 | #' algorithm to dispatch to. It is called internally. 5 | #' 6 | #' @param x argument to dispatch on (of class \code{prior_obj}) 7 | #' @param ... additional named arguments passed on to the methods 8 | #' @noRd 9 | mcmc_sampler <- function(x, ...) { 10 | UseMethod("mcmc_sampler") 11 | } 12 | -------------------------------------------------------------------------------- /R/mfbvar-package.R: -------------------------------------------------------------------------------- 1 | #' mfbvar: A package for mixed-frequency Bayesian vector autoregressive (VAR) models. 2 | #' 3 | #' The mfbvar package makes estimation of Bayesian VARs with a mix of monthly and quarterly data 4 | #' simple. The prior for the regression parameters is normal with Minnesota-style prior moments. 5 | #' The package supports either an inverse Wishart prior for the error covariance matrix, yielding a 6 | #' standard normal-inverse Wishart prior, or a time-varying error covariance matrix by means of a factor 7 | #' stochastic volatility model through the \code{\link[factorstochvol]{factorstochvol-package}} package. 8 | #' 9 | #' @section Specifying the prior: 10 | #' The prior of the VAR model is specified using the function \code{\link{set_prior}}. The function 11 | #' creates a prior object, which can be further updated using \code{\link{update_prior}}. The model can be 12 | #' estimated using the steady-state prior, which requires the prior moments of the steady-state parameters. 13 | #' The function \code{\link{interval_to_moments}} is a helper function for obtaining these from prior intervals. 14 | #' 15 | #' @section Estimating the model: 16 | #' The model is estimated using the function \code{\link{estimate_mfbvar}}. The error covariance matrix 17 | #' is given an inverse Wishart prior or modeled using factor stochastic volatility. If the former is used, 18 | #' \code{\link{mdd}} can be used to estimate to the marginal data density (marginal likelihood). 19 | #' 20 | #' @section Processing the output: 21 | #' Plots of the output can be obtained from calling the generic function \code{plot} (see 22 | #' \code{\link{plot-mfbvar}}). If factor stochastic volatility is used, the time-varying 23 | #' standard deviations can be plotted using \code{\link{varplot}}. Predictions can be obtained 24 | #' from \code{\link{predict.mfbvar}}. 25 | #' 26 | #' 27 | #' @docType package 28 | #' @name mfbvar 29 | ## quiets concerns of R CMD check re: the .'s that appear in pipelines 30 | if(getRversion() >= "2.15.1") utils::globalVariables(c(".", "obj", "prior_type", "lower", "upper", "value", 31 | "variable", "iter", "fcst_date", "fcst", "freq", "prior_Pi_AR1")) 32 | -------------------------------------------------------------------------------- /R/mfsv.R: -------------------------------------------------------------------------------- 1 | par_fun_top <- function(mvn_fun) { 2 | function(j, XX, startlatent, D, latent_nofac) { 3 | mvn_fun(XX/exp(startlatent[,j]*0.5), D[,j], latent_nofac[,j,drop=FALSE]/exp(startlatent[,j]*0.5)) 4 | } 5 | } 6 | 7 | par_fun_AR1 <- function(j, XX, startlatent, D, latent_nofac, prior_Pi_AR1) { 8 | rmvn_ccm(XX/exp(startlatent[,j]*0.5), D[,j], latent_nofac[,j,drop=FALSE]/exp(startlatent[,j]*0.5), prior_Pi_AR1[j], j) 9 | } 10 | -------------------------------------------------------------------------------- /R/ols.R: -------------------------------------------------------------------------------- 1 | #' @title OLS functions 2 | #' @description Helper functions for multivariate regression and sum of squared error computations 3 | #' @param X The regressor matrix. 4 | #' @param Y The dependnet variable matrix. 5 | #' @keywords internal 6 | #' @noRd 7 | #' @return 8 | #' \item{pi_sample}{Estimated coefficients.} 9 | ols_pi <- function(X, Y) { 10 | ridge <- 1e-6 11 | error_count <- 0 12 | fail <- TRUE 13 | while (fail) { 14 | pi_sample <- tryCatch({solve(crossprod(X)+diag(ridge, ncol(X))) %*% crossprod(X, Y)}, 15 | error = function(cond) {cond}) 16 | if (!inherits(pi_sample, "error")) { 17 | fail <- FALSE 18 | } else { 19 | ridge <- ridge*10 20 | } 21 | } 22 | return(pi_sample) 23 | } 24 | 25 | #' @rdname ols_pi 26 | #' @param Pi The estimated coefficients. 27 | #' @keywords internal 28 | #' @noRd 29 | #' @return 30 | #' \item{s_sample}{The sum of squared residuals matrix.} 31 | ols_s <- function(X, Y, Pi) { 32 | s_sample <- crossprod(Y - X %*% Pi) 33 | return(s_sample) 34 | } 35 | 36 | #' Initialize Gibbs sampler using OLS 37 | #' 38 | #' Initializes the Gibbs sampler using OLS. 39 | #' @templateVar z TRUE 40 | #' @templateVar d TRUE 41 | #' @templateVar n_lags TRUE 42 | #' @templateVar n_T TRUE 43 | #' @templateVar n_vars TRUE 44 | #' @templateVar n_determ TRUE 45 | #' @template man_template 46 | #' @return A list with components: 47 | #' \item{Gam}{A matrix of size \code{n_vars * (n_vars*n_lags +n_determ)} of estimated parameters.} 48 | #' \item{S}{Estimated error covariance matrix.} 49 | #' \item{psi}{The estimated steady-state parameters.} 50 | #' @keywords internal 51 | #' @noRd 52 | 53 | ols_initialization <- function(z, d, n_lags, n_T, n_vars, n_determ) { 54 | n_T <- nrow(z) 55 | # Create regressor matrix (this is z in Karlsson, 2013) 56 | XX <- c() 57 | for (i in 1:n_lags) { 58 | XX <- cbind(XX, z[(n_lags+1-i):(n_T - i), ]) 59 | } 60 | XX <- cbind(XX, d[(n_lags+1):n_T, ]) 61 | YY <- z[(n_lags+1):n_T, ] 62 | 63 | # Gamma in Karlsson (2013, p. 797) 64 | Gam <- t(ols_pi(XX, YY)) 65 | Pi <- Gam[, 1:(n_vars * n_lags)] 66 | const <- Gam[, (n_vars * n_lags + 1):(n_vars * n_lags + n_determ)] 67 | psi <- c(solve(diag(n_vars) - Pi %*% 68 | kronecker(matrix(1, n_lags, 1), diag(n_vars))) %*% const) 69 | 70 | return(list(Pi = Pi, S = crossprod(YY - XX %*% t(Gam)) / n_T, 71 | psi = psi, const = const)) 72 | } 73 | -------------------------------------------------------------------------------- /R/posteriors.R: -------------------------------------------------------------------------------- 1 | #' Draw from posterior of Pi and Sigma 2 | #' 3 | #' Function for drawing from the posterior of Pi and Sigma, which can be used as a block in a Gibbs sampler. 4 | #' @templateVar Z_r1 TRUE 5 | #' @templateVar d TRUE 6 | #' @templateVar psi_r1 TRUE 7 | #' @templateVar prior_Pi_mean TRUE 8 | #' @templateVar prior_Pi_Omega TRUE 9 | #' @templateVar inv_prior_Pi_Omega TRUE 10 | #' @templateVar Omega_Pi TRUE 11 | #' @templateVar prior_S TRUE 12 | #' @templateVar prior_nu TRUE 13 | #' @templateVar check_roots TRUE 14 | #' @templateVar n_vars TRUE 15 | #' @templateVar n_lags TRUE 16 | #' @templateVar n_T TRUE 17 | #' @template man_template 18 | #' @keywords internal 19 | #' @noRd 20 | #' @return \code{posterior_Pi_Sigma} returns a list with: 21 | #' \item{Pi_r}{The draw of \code{Pi}.} 22 | #' \item{Sigma_r}{The draw of \code{Sigma}.} 23 | #' \item{num_try}{The try at which a stable draw was obtained.} 24 | #' \item{root}{The maximum eigenvalue (in modulus) of the system.} 25 | posterior_Pi_Sigma <- function(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) { 26 | ################################################################ 27 | ### Preliminary calculations 28 | 29 | # Demean z, create Z (companion form version) 30 | demeaned_z <- Z_r1 - d %*% t(matrix(psi_r1, nrow = n_vars)) 31 | demeaned_Z <- build_Z(z = demeaned_z, n_lags = n_lags) 32 | XX <- demeaned_Z[-nrow(demeaned_Z), ] 33 | YY <- demeaned_Z[-1, 1:n_vars] 34 | XXt.XX <- crossprod(XX) 35 | XXt.XX.inv <- chol2inv(chol(XXt.XX)) 36 | Pi_sample <- XXt.XX.inv %*% crossprod(XX, YY) 37 | 38 | ################################################################ 39 | ### Pi and Sigma step 40 | 41 | # Posterior moments of Pi 42 | post_Pi_Omega <- chol2inv(chol(inv_prior_Pi_Omega + XXt.XX)) 43 | post_Pi <- post_Pi_Omega %*% (Omega_Pi + crossprod(XX, YY)) 44 | 45 | # Then Sigma 46 | s_sample <- crossprod(YY - XX %*% Pi_sample) 47 | Pi_diff <- prior_Pi_mean - Pi_sample 48 | post_s <- prior_S + s_sample + t(Pi_diff) %*% chol2inv(chol(prior_Pi_Omega + XXt.XX.inv)) %*% Pi_diff 49 | post_nu <- n_T + prior_nu 50 | Sigma_r <- rinvwish(v = post_nu, S = post_s) 51 | 52 | 53 | # Draw Pi conditional on Sigma 54 | # This ensures that the draw is stationary 55 | stationarity_check <- FALSE 56 | iter <- 0 57 | Pi_temp <- array(NA, dim = c(n_vars, n_vars * n_lags, ifelse(check_roots, 1000, 1))) 58 | while(stationarity_check == FALSE) { 59 | iter <- iter + 1 60 | Pi_temp[,,iter] <- rmatn(M = t(post_Pi), Q = post_Pi_Omega, P = Sigma_r) 61 | Pi_comp <- build_companion(Pi_temp[,, iter], n_vars = n_vars, n_lags = n_lags) 62 | if (check_roots == TRUE) { 63 | root <- max_eig_cpp(Pi_comp) 64 | } else { 65 | root <- 0 66 | } 67 | if (root < 1) { 68 | stationarity_check <- TRUE 69 | num_try <- iter 70 | Pi_r <- Pi_temp[,,iter] 71 | } 72 | if (iter == 1000) { 73 | stop("Attempted to draw stationary Pi 1,000 times.") 74 | } 75 | } 76 | 77 | return(list(Pi_r = Pi_r, Sigma_r = Sigma_r, num_try = num_try, root = root)) 78 | } 79 | 80 | #' Draw from posterior of psi 81 | #' 82 | #' Function for drawing from the posterior of psi, which can be used as a block in a Gibbs sampler. 83 | #' @inherit posterior_Pi_Sigma 84 | #' @templateVar Pi_r TRUE 85 | #' @templateVar Sigma_r TRUE 86 | #' @templateVar prior_psi_mean TRUE 87 | #' @templateVar prior_psi_Omega TRUE 88 | #' @templateVar D_mat TRUE 89 | #' @templateVar n_determ TRUE 90 | #' @template man_template 91 | #' @keywords internal 92 | #' @noRd 93 | #' @return \code{posterior_psi} returns: 94 | #' \item{psi_r}{The draw of \code{psi}.} 95 | posterior_psi <- function(Pi_r, Sigma_r, Z_r1, prior_psi_mean, prior_psi_Omega, D_mat, n_vars, n_lags, n_determ) { 96 | U <- build_U_cpp(Pi = Pi_r, n_determ = n_determ, 97 | n_vars = n_vars, n_lags = n_lags) 98 | post_psi_Omega <- posterior_psi_Omega(U = U, D_mat = D_mat, Sigma = Sigma_r, 99 | prior_psi_Omega = prior_psi_Omega) 100 | Y_tilde <- build_Y_tilde(Pi = Pi_r, z = Z_r1) 101 | 102 | post_psi <- posterior_psi_mean(U = U, D_mat = D_mat, Sigma = Sigma_r, prior_psi_Omega = prior_psi_Omega, 103 | post_psi_Omega = post_psi_Omega, Y_tilde = Y_tilde, prior_psi_mean = prior_psi_mean) 104 | psi_r <- t(rmultn(m = post_psi, Sigma = post_psi_Omega)) 105 | return(psi_r) 106 | } 107 | 108 | #' Compute posterior moments of the steady-state parameters 109 | #' 110 | #' Computes the mean and variance of the conditional posterior distribution of the steady-state parameters. 111 | #' @templateVar U TRUE 112 | #' @templateVar D_mat TRUE 113 | #' @templateVar Sigma TRUE 114 | #' @templateVar prior_psi_Omega TRUE 115 | #' @templateVar post_psi_Omega TRUE 116 | #' @templateVar Y_tilde TRUE 117 | #' @templateVar prior_psi_mean TRUE 118 | #' @template man_template 119 | #' @keywords internal 120 | #' @noRd 121 | #' @return The return is: 122 | #' \item{psi}{The posterior mean (from \code{\link{posterior_psi_mean}})} 123 | posterior_psi_mean <- function(U, D_mat, Sigma, prior_psi_Omega, post_psi_Omega, Y_tilde, prior_psi_mean) { 124 | SigmaYD <- matrix(c(chol2inv(chol(Sigma)) %*% t(Y_tilde) %*% D_mat), ncol = 1) 125 | psi <- post_psi_Omega %*% (t(U) %*% SigmaYD + chol2inv(chol(prior_psi_Omega)) %*% prior_psi_mean) 126 | return(psi) 127 | } 128 | 129 | #' @rdname posterior_psi_mean 130 | #' @keywords internal 131 | #' @noRd 132 | #' @return \item{psi_Omega}{The posterior variance (from \code{\link{posterior_psi_Omega}})} 133 | posterior_psi_Omega <- function(U, D_mat, Sigma, prior_psi_Omega) { 134 | psi_Omega <- chol2inv(chol(t(U) %*% (kronecker(crossprod(D_mat), chol2inv(chol(Sigma)))) %*% U + chol2inv(chol(prior_psi_Omega)))) 135 | return(psi_Omega) 136 | } 137 | 138 | -------------------------------------------------------------------------------- /R/prior_pi_sigma.R: -------------------------------------------------------------------------------- 1 | #' Create the priors for Pi and Sigma 2 | #' 3 | #' Creates the prior mean and covariance for Pi given the hyperparameters, and the prior parameters for Sigma. 4 | #' @templateVar lambda1 TRUE 5 | #' @templateVar lambda2 TRUE 6 | #' @templateVar prior_Pi_AR1 TRUE 7 | #' @templateVar Y TRUE 8 | #' @templateVar n_lags TRUE 9 | #' @templateVar prior_nu TRUE 10 | #' @template man_template 11 | #' @return \item{prior_Pi}{The prior mean matrix for Pi.} 12 | #' \item{prior_Pi_Omega}{The prior covariance matrix for Pi.} 13 | #' \item{prior_s}{The prior for Sigma.} 14 | #' @keywords internal 15 | #' @noRd 16 | prior_Pi_Sigma <- function(lambda1, lambda2, prior_Pi_AR1, Y, n_lags, prior_nu) { 17 | # lambda1: 1-long vector (overall tightness) 18 | # lambda2: 1-long vector (lag decay) 19 | # prior_Pi_AR1: p-long vector with prior means for the AR(1) coefficients 20 | # Y: Txp matrix with data 21 | 22 | n_vars <- length(prior_Pi_AR1) 23 | prior_Pi_mean <- rbind(diag(prior_Pi_AR1), matrix(0, nrow = n_vars*(n_lags-1), ncol = n_vars)) 24 | 25 | prior_Pi_Omega <- rep(0, n_lags * n_vars) 26 | error_variance <- rep(NA, n_vars) 27 | for (i in 1:n_vars) { 28 | success <- NULL 29 | init_order <- 4 30 | while(is.null(success)) { 31 | error_variance[i] <- tryCatch(arima(na.omit(Y[,i]), order = c(init_order, 0, 0), method = "ML")$sigma2, 32 | error = function(cond) NA) 33 | if (!is.na(error_variance[i])) { 34 | success <- 1 35 | } else { 36 | init_order <- init_order - 1 37 | if (init_order < 1) { 38 | stop("Too low order.") 39 | } 40 | } 41 | } 42 | } 43 | 44 | for (l in 1:n_lags) { 45 | for (r in 1:n_vars) { 46 | i <- (l - 1) * n_vars + r 47 | prior_Pi_Omega[i] <- lambda1^2 / (l^(lambda2) * sqrt(error_variance[r]))^2 48 | } 49 | } 50 | 51 | prior_S <- (prior_nu - n_vars - 1) * diag(error_variance) 52 | 53 | 54 | return(list(prior_Pi_mean = prior_Pi_mean, prior_Pi_Omega = diag(prior_Pi_Omega), prior_S = prior_S)) 55 | } 56 | 57 | #' Create the priors for Pi and Sigma 58 | #' 59 | #' Creates the prior mean and covariance for Pi given the hyperparameters, and the prior parameters for Sigma. 60 | #' @param lambda1 overall tightness 61 | #' @param lambda2 cross-equation tightness 62 | #' @param lambda3 lag decay 63 | #' @param prior_Pi_AR1 prior means for AR(1) coefficients 64 | #' @param Y data 65 | #' @param n_lags number of lags 66 | #' @return 67 | #' \item{prior_Pi_Omega}{The prior covariance matrix for Pi.} 68 | #' @keywords internal 69 | #' @noRd 70 | create_prior_Pi_Omega <- function(lambda1, lambda2, lambda3, prior_Pi_AR1, Y, n_lags, 71 | block_exo = NULL) { 72 | # lambda1: 1-long vector (overall tightness) 73 | # lambda2: 1-long vector (lag decay) 74 | # prior_Pi_AR1: p-long vector with prior means for the AR(1) coefficients 75 | # Y: Txp matrix with data 76 | 77 | n_vars <- length(prior_Pi_AR1) 78 | 79 | prior_Pi_Omega <- matrix(0, n_vars * n_lags + 1, n_vars) 80 | error_variance <- compute_error_variances(Y) 81 | 82 | prior_Pi_Omega[1, ] <- lambda1 * 100 * sqrt(error_variance) 83 | for (i in 1:n_vars) { 84 | prior_Pi_Omega[-1, i] <- lambda1 * lambda2^((1:n_vars) != i) * sqrt(error_variance[i])/ 85 | ((rep(1:n_lags, each = n_vars))^(lambda3) * rep(sqrt(error_variance), times = n_lags)) 86 | if (i %in% block_exo) { 87 | prior_Pi_Omega[-1, i] <- prior_Pi_Omega[-1, i] * (1e-06)^(!(1:ncol(Y) %in% block_exo)) 88 | } 89 | } 90 | 91 | return(prior_Pi_Omega = prior_Pi_Omega^2) 92 | } 93 | 94 | 95 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | # The below loop just gets the error variances from AR(4) regressions 2 | 3 | compute_error_variances <- function(Y) { 4 | n_vars <- ncol(Y) 5 | error_variance <- rep(NA, n_vars) 6 | for (i in 1:n_vars) { 7 | success <- NULL 8 | init_order <- 4 9 | for (ar_order in init_order:1) { 10 | error_variance[i] <- tryCatch(arima(na.omit(Y[,i]), order = c(ar_order, 0, 0), method = "ML")$sigma2, 11 | error = function(cond) NA) 12 | if (!is.na(error_variance[i])) { 13 | break 14 | } else { 15 | if (init_order < 1) { 16 | error_variance[i] <- var(na.omit(Y[,i])) 17 | } 18 | } 19 | } 20 | } 21 | return(error_variance) 22 | } 23 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onUnload <- function (libpath) { 2 | library.dynam.unload("mfbvar", libpath) 3 | } 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | mfbvar 3 | ====== 4 | 5 | [![Build Status](https://travis-ci.org/ankargren/mfbvar.svg?branch=master)](https://travis-ci.org/ankargren/mfbvar) [![](http://www.r-pkg.org/badges/version/mfbvar)](https://www.r-pkg.org:443/pkg/mfbvar) [![Coverage status](https://codecov.io/gh/ankargren/mfbvar/branch/master/graph/badge.svg)](https://codecov.io/github/ankargren/mfbvar?branch=master) 6 | 7 | Overview 8 | -------- 9 | 10 | The `mfbvar` package implements Bayesian mixed-frequency VAR models. 11 | 12 | Installation 13 | ------------ 14 | 15 | The current development version of the package can be installed with the help of `devtools`: 16 | 17 | ``` r 18 | devtools::install_github("ankargren/mfbvar") 19 | ``` 20 | 21 | Usage 22 | ----- 23 | 24 | See the vignette for details and examples. 25 | -------------------------------------------------------------------------------- /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-minimal -------------------------------------------------------------------------------- /cleanup: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rm -f config.* src/Makevars src/config.h inst/include/mfbvarConfigGenerated.h \ 4 | src/*.o src/*.so src/*.dll 5 | rm -rf autom4te.cache/ 6 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | patch: 10 | default: 11 | target: auto 12 | threshold: 1% 13 | 14 | language: R 15 | sudo: false 16 | cache: packages 17 | after_success: 18 | - Rscript -e 'covr::codecov()' 19 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | ## -*- mode: autoconf; autoconf-indentation: 4; -*- 2 | ## 3 | ## Copyright (C) 2016 - 2017 Dirk Eddelbuettel for 4 | ## the RcppArmadillo package. Licensed under GPL-2 or later 5 | ## This file is a subset of the configure.ac used by 6 | ## RcppArmadillo, adapted to the mfbvar package by 7 | ## Sebastian Ankargren 8 | 9 | ## require at least autoconf 2.61 10 | AC_PREREQ(2.61) 11 | 12 | ## Process this file with autoconf to produce a configure script. 13 | AC_INIT([mfbvar], 0.4.0) 14 | 15 | ## Set R_HOME, respecting an environment variable if one is set 16 | : ${R_HOME=$(R RHOME)} 17 | if test -z "${R_HOME}"; then 18 | AC_MSG_ERROR([Could not determine R_HOME.]) 19 | fi 20 | ## Use R to set CXX and CXXFLAGS 21 | CXX=$(${R_HOME}/bin/R CMD config CXX) 22 | CXXFLAGS=$("${R_HOME}/bin/R" CMD config CXXFLAGS) 23 | 24 | ## We are using C++ 25 | AC_LANG(C++) 26 | AC_REQUIRE_CPP 27 | 28 | ## Default the OpenMP flag to the empty string. 29 | ## If and only if OpenMP is found, expand to $(SHLIB_OPENMP_CXXFLAGS) 30 | openmp_flag="" 31 | openmp_cflag="" 32 | 33 | ## Check for broken systems produced by a corporation based in Cupertino 34 | AC_MSG_CHECKING([for macOS]) 35 | RSysinfoName=$("${R_HOME}/bin/Rscript" --vanilla -e 'cat(Sys.info()[["sysname"]])') 36 | if test x"${RSysinfoName}" == x"Darwin"; then 37 | AC_MSG_RESULT([found]) 38 | AC_MSG_WARN([OpenMP unavailable and turned off.]) 39 | openmp_flag="-DARMA_DONT_USE_OPENMP" 40 | else 41 | AC_MSG_RESULT([not found as on ${RSysinfoName}]) 42 | ## Check for OpenMP 43 | AC_MSG_CHECKING([for OpenMP]) 44 | ## if R has -fopenmp we should be good 45 | allldflags=$(${R_HOME}/bin/R CMD config --ldflags) 46 | hasOpenMP=$(echo ${allldflags} | grep -- -fopenmp) 47 | if test x"${hasOpenMP}" == x""; then 48 | AC_MSG_RESULT([missing]) 49 | openmp_flag="-DARMA_DONT_USE_OPENMP" 50 | else 51 | AC_MSG_RESULT([found]) 52 | openmp_flag='$(SHLIB_OPENMP_CXXFLAGS)' 53 | openmp_cflag='$(SHLIB_OPENMP_CFLAGS)' 54 | fi 55 | fi 56 | 57 | AC_SUBST([OPENMP_CFLAG], ["${openmp_cflag}"]) 58 | AC_SUBST([OPENMP_FLAG], ["${openmp_flag}"]) 59 | AC_CONFIG_FILES([src/Makevars]) 60 | AC_OUTPUT 61 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Re-submission of archived package 2 | This is a resubmission of the mfbvar package that was archived on 2021-02-05 because check problems were not corrected in time. This version thus: 3 | * Fixes the check problems. The observed warnings came from the vignette, which attempted to download data. This has now been removed; vignette does no longer use an active internet connection (as per the CRAN policy). 4 | * I have also extended the ability of the package to handle mixed-frequency data to now also include weekly-monthly data. 5 | * .Rd files now include \value, as per Gregor Seyer's request on 2021-02-09. 6 | * DESCRIPTION has been extended to include references. 7 | 8 | 9 | ## Test environments 10 | * win-builder (R devel, R 4.0.2, R 3.6.3) 11 | * Local Mac OS X 10.14.3 (R 4.0.3) 12 | 13 | ## R CMD check results 14 | There were no ERRORs or WARNINGs. 15 | 16 | On some test environments, one of two NOTEs may appear: 17 | 18 | * checking for GNU extensions in Makefiles ... NOTE 19 | GNU make is a SystemRequirements. 20 | * checking CRAN incoming feasibility ... NOTE 21 | Maintainer: ‘Sebastian Ankargren ’ 22 | 23 | New submission 24 | 25 | Package was archived on CRAN 26 | 27 | Possibly mis-spelled words in DESCRIPTION: 28 | Ankargren (10:324, 10:389, 10:441) 29 | Joneus (10:403, 10:455) 30 | Schorfheide (10:224) 31 | Unosson (10:335) 32 | 33 | CRAN repository db overrides: 34 | X-CRAN-Comment: Archived on 2021-02-05 as check problems were not 35 | corrected in time. 36 | 37 | -------------------------------------------------------------------------------- /data/mf_sweden.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/data/mf_sweden.RData -------------------------------------------------------------------------------- /data/mf_usa.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/data/mf_usa.RData -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | ## citHeader("To cite package mfbvar in publications use:") 2 | 3 | ## R >= 2.8.0 passes package metadata to citation(). 4 | if(!exists("meta") || is.null(meta)) meta <- packageDescription("mfbvar") 5 | year <- sub("-.*", "", meta$Packaged) 6 | note <- sprintf("R package version %s", meta$Version) 7 | 8 | bibentry(bibtype = "article", 9 | header = "To cite mfbvar in publications use:", 10 | title = "Mixed-Frequency {B}ayesian {VAR} Models in {R}: the {mfbvar} package", 11 | author = personList( 12 | person(given = "Sebastian", 13 | family = "Ankargren", 14 | email = "sebastian.ankargren@konj.se"), 15 | person(given = "Yukai", 16 | family = "Yang", 17 | email = "yukai.yang@statistics.uu.se")), 18 | journal = "R package vignette", 19 | year = "2021", 20 | textVersion = 21 | paste("Ankargren, Sebastian and Yang, Yukai (2021).", 22 | "Mixed-Frequency Bayesian VAR Models in R: the mfbvar package.", 23 | "R package vignette.", 24 | "URL: https://CRAN.R-project.org/package=mfbvar/vignettes/mfbvar_jss.pdf") 25 | ) 26 | 27 | citEntry(header = "For the adaptive simulation smoother, please cite:", 28 | entry = "article", 29 | title = "Simulation Smoothing for Nowcasting with Large Mixed-Frequency {VAR}s", 30 | author = personList(as.person("Sebastian Ankargren"), 31 | as.person("Paulina Jon\\\'{e}us")), 32 | journal = "Econometrics and Statistics", 33 | year = "2020", 34 | doi = "10.1016/j.ecosta.2020.05.007", 35 | textVersion = "Ankargren, Sebastian and Jonéus, Paulina (2020). Simulation Smoothing for Nowcasting with Large Mixed-Frequency VARs. Econometrics and Statistics. https://doi.org/10.1016/j.ecosta.2020.05.007" 36 | ) 37 | 38 | citEntry(header = "For the steady-state mixed-frequency BVAR, please cite:", 39 | entry = "article", 40 | title = "A Flexible Mixed-Frequency Vector Autoregression with a Steady-State Prior", 41 | author = personList(as.person("Sebastian Ankargren"), 42 | as.person("Måns Unosson"), 43 | as.person("Yukai Yang")), 44 | journal = "Journal of Time Series Econometrics", 45 | volume = "12", 46 | number = "2", 47 | year = "2020", 48 | doi = "10.1515/jtse-2018-0034", 49 | textVersion = "Ankargren, Sebastian, Måns Unosson and Yukai Yang (2020). A Flexible Mixed-Frequency Vector Autoregression with a Steady-State Prior. Journal of Time Series Econometrics, 12(2). https://doi.org/10.1515/jtse-2018-0034" 50 | ) 51 | 52 | citEntry(header = "For the mixed-frequency BVAR with factor stochastic volatility, please cite:", 53 | entry = "article", 54 | title = "Estimating Large Mixed-Frequency Bayesian VAR Models", 55 | author = personList(as.person("Sebastian Ankargren"), 56 | as.person("Paulina Jon\\\'{e}us")), 57 | journal = "arXiv", 58 | year = "2019", 59 | url = "https://arxiv.org/abs/1912.02231", 60 | textVersion = "Ankargren, Sebastian and Paulina Jonéus (2019). Estimating Large Mixed-Frequency Bayesian VAR Models. arXiv, https://arxiv.org/abs/1912.02231" 61 | ) 62 | -------------------------------------------------------------------------------- /inst/data_prep.R: -------------------------------------------------------------------------------- 1 | library(tidyverse) 2 | library(lubridate) 3 | last_day <- function(date) { 4 | ceiling_date(date, "month", change_on_boundary = TRUE) - days(1) 5 | } 6 | 7 | log_diff <- function(x) { 8 | 100*(log(x) - lag(log(x), 1)) 9 | } 10 | scale_diff <- function(x) { 11 | x <- (x-10)/10 12 | x <- x - dplyr::lag(x) 13 | } 14 | 15 | data(full_tbl) 16 | 17 | full_tbl2 <- unnest(full_tbl) %>% 18 | filter(fcst_date > "2000-01-01" & date > "1996-07-01" & fcst_date < "2016-01-01") 19 | 20 | monthly_tbl <- full_tbl2 %>% 21 | group_by(fcst_date) %>% 22 | mutate(infl = log_diff(infl), ip = log_diff(ip), eti = scale_diff(eti)) %>% 23 | nest() 24 | 25 | quarterly_tbl <- unnest(monthly_tbl) %>% 26 | mutate(quarter = quarter(.$date, with_year = TRUE)) %>% 27 | group_by(quarter, fcst_date) %>% 28 | summarise(unemp = mean(unemp), infl = mean(infl), ip = mean(ip), eti = mean(eti), gdp = mean(gdp, na.rm = TRUE), 29 | interest = mean(interest), n_months = n()) %>% 30 | filter(n_months == 3) %>% 31 | ungroup() %>% 32 | select(-n_months) %>% 33 | mutate(date = paste0(floor(quarter), "-", round((quarter-floor(quarter))*30), "-01") %>% ymd %>% last_day) %>% 34 | select(date, everything()) %>% 35 | replace_na(replace = list(gdp = NA)) %>% 36 | select(-quarter) %>% 37 | group_by(fcst_date) %>% 38 | nest() 39 | 40 | data_list <- as.list(inner_join(monthly_tbl, quarterly_tbl, by = "fcst_date") %>% 41 | rename(mf = data.x, qf = data.y)) 42 | 43 | data_list$mf <- lapply(data_list$mf, function(x) { 44 | x <- as.data.frame(x) 45 | rownames(x) <- x$date 46 | x <- x[, -1] 47 | }) 48 | data_list$qf <- lapply(data_list$qf, function(x) { 49 | x <- as.data.frame(x) 50 | rownames(x) <- x$date 51 | x <- x[, -1] 52 | }) 53 | -------------------------------------------------------------------------------- /inst/include/auxmix.h: -------------------------------------------------------------------------------- 1 | #ifndef _AUXMIX_H_ 2 | #define _AUXMIX_H_ 3 | 4 | #include 5 | 6 | // Copyright of original code: Gregor Kastner (stochvol package) 7 | // Copyright of modified code: Sebastian Ankargren (mfbvar package) 8 | // The following code is a derivative work of the code 9 | // developed by Gregor Kastner for the stochvol package, which 10 | // is licensed GPL>=2. This code is therefore licensed under 11 | // the terms of the GNU Public License, version 3. 12 | 13 | const double mix_prob[10] = {.00609, .04775, .13057, .20674, .22715, .18842, .12047, .05591, .01575, .00115}; 14 | 15 | const double mix_mean[10] = {1.92677, 1.34744, .73504, .02266, -.85173, -1.97278, -3.46788, -5.55246, -8.68384, -14.65000}; 16 | 17 | const double mix_var[10] = {.11265, .17788, .26768, .40611, .62699, .98583, 1.57469, 2.54498, 4.16591, 7.33342}; 18 | 19 | const double mix_a[10] = {1.01418, 1.02248, 1.03403, 1.05207, 1.08153, 1.13114, 1.21754, 1.37454, 1.68327, 2.50097}; 20 | 21 | const double mix_b[10] = {0.50710, 0.51124, 0.51701, 0.52604, 0.54076, 0.56557, 0.60877, 0.68728, 0.84163, 1.25049}; 22 | 23 | const double mix_varinv[10] = { 24 | 8.8770528184642696345463264151476323604583740234375000000, 25 | 5.6217674836968738460996064532082527875900268554687500000, 26 | 3.7358039450089663979781562375137582421302795410156250000, 27 | 2.4623870379946319886244054941926151514053344726562500000, 28 | 1.5949217690872261599110970564652234315872192382812500000, 29 | 1.0143736749743870184659044753061607480049133300781250000, 30 | 0.6350456280283738319525355109362863004207611083984375000, 31 | 0.3929303963095977514363710270117735490202903747558593750, 32 | 0.2400435919162919873315331642515957355499267578125000000, 33 | 0.1363620248124340350592831327958265319466590881347656250}; 34 | 35 | const double mix_2varinv[10] = { 36 | 4.4385264092321348172731632075738161802291870117187500000, 37 | 2.8108837418484369230498032266041263937950134277343750000, 38 | 1.8679019725044831989890781187568791210651397705078125000, 39 | 1.2311935189973159943122027470963075757026672363281250000, 40 | 0.7974608845436130799555485282326117157936096191406250000, 41 | 0.5071868374871935092329522376530803740024566650390625000, 42 | 0.3175228140141869159762677554681431502103805541992187500, 43 | 0.1964651981547988757181855135058867745101451873779296875, 44 | 0.1200217959581459936657665821257978677749633789062500000, 45 | 0.0681810124062170175296415663979132659733295440673828125}; 46 | 47 | const double mix_pre[10] = { 48 | -4.0093723912083900628999799664597958326339721679687500000, 49 | -2.1784531553855770447114537091692909598350524902343750000, 50 | -1.3768642766903782526100030736415646970272064208984375000, 51 | -1.1257277037836319610875079888501204550266265869140625000, 52 | -1.2487323430568648685579091761610470712184906005859375000, 53 | -1.6619460888428292388852014482836239039897918701171875000, 54 | -2.3433837334574310062862423365004360675811767578125000000, 55 | -3.3510734196563021214387845247983932495117187500000000000, 56 | -4.8643822832849297199686589010525494813919067382812500000, 57 | -7.7642143280080739842219372803810983896255493164062500000}; 58 | 59 | void findMixprobs( 60 | arma::vec& mixprob, 61 | const arma::vec& datanorm); 62 | 63 | void colCumsums( 64 | arma::vec& x, 65 | int const nrow, 66 | int const ncol); 67 | 68 | void findMixCDF( 69 | arma::vec& mixprob, 70 | const arma::vec& datanorm); 71 | 72 | void invTransformSampling( 73 | const arma::vec& mixprob, 74 | arma::ivec& r, 75 | int T); 76 | 77 | #endif 78 | -------------------------------------------------------------------------------- /inst/include/eta_progress_bar.hpp: -------------------------------------------------------------------------------- 1 | /* 2 | * eta_progress_bar.hpp 3 | * 4 | * A custom ProgressBar class to display a progress bar with time estimation 5 | * 6 | * Author: clemens@nevrome.de 7 | * 8 | */ 9 | #ifndef _RcppProgress_ETA_PROGRESS_BAR_HPP 10 | #define _RcppProgress_ETA_PROGRESS_BAR_HPP 11 | 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | 18 | #include "progress_bar.hpp" 19 | 20 | // for unices only 21 | #if !defined(WIN32) && !defined(__WIN32) && !defined(__WIN32__) 22 | #include 23 | #endif 24 | 25 | class ETAProgressBar: public ProgressBar{ 26 | public: // ====== LIFECYCLE ===== 27 | 28 | /** 29 | * Main constructor 30 | */ 31 | ETAProgressBar() { 32 | _max_ticks = 50; 33 | _finalized = false; 34 | _timer_flag = true; 35 | } 36 | 37 | ~ETAProgressBar() { 38 | } 39 | 40 | public: // ===== main methods ===== 41 | 42 | void display() { 43 | } 44 | 45 | // update display 46 | void update(float progress) { 47 | 48 | // stop if already finalized 49 | if (_finalized) return; 50 | 51 | // create progress bar string 52 | std::string progress_bar_string = _current_ticks_display(progress); 53 | 54 | // ensure overwriting of old time info 55 | int empty_length = time_string.length(); 56 | std::string empty_space = std::string(empty_length, ' '); 57 | 58 | // merge progress bar and time string 59 | std::stringstream strs; 60 | strs << "0% [" << progress_bar_string << "] " << pct <<"%"; 61 | std::string temp_str = strs.str(); 62 | char const* char_type = temp_str.c_str(); 63 | 64 | // print: remove old and replace with new 65 | REprintf("\r"); 66 | REprintf("%s", char_type); 67 | 68 | // finalize display when ready 69 | if(progress == 1) { 70 | _finalize_display(); 71 | } 72 | } 73 | 74 | void end_display() { 75 | update(1); 76 | } 77 | 78 | protected: // ==== other instance methods ===== 79 | 80 | // update the ticks display corresponding to progress 81 | std::string _current_ticks_display(float progress) { 82 | 83 | int nb_ticks = _compute_nb_ticks(progress); 84 | 85 | std::string cur_display = _construct_ticks_display_string(nb_ticks); 86 | 87 | return cur_display; 88 | } 89 | 90 | // construct progress bar display 91 | std::string _construct_ticks_display_string(int nb) { 92 | 93 | std::stringstream ticks_strs; 94 | for (int i = 0; i < (_max_ticks - 1); ++i) { 95 | if (i < nb) { 96 | ticks_strs << "+"; 97 | } else { 98 | ticks_strs << "-"; 99 | } 100 | } 101 | std::string tick_space_string = ticks_strs.str(); 102 | 103 | return tick_space_string; 104 | } 105 | 106 | // finalize 107 | void _finalize_display() { 108 | if (_finalized) return; 109 | 110 | REprintf("\n"); 111 | flush_console(); 112 | _finalized = true; 113 | } 114 | 115 | // compute number of ticks according to progress 116 | int _compute_nb_ticks(float progress) { 117 | return int(progress * _max_ticks); 118 | } 119 | 120 | // N.B: does nothing on windows 121 | void flush_console() { 122 | #if !defined(WIN32) && !defined(__WIN32) && !defined(__WIN32__) 123 | R_FlushConsole(); 124 | #endif 125 | } 126 | 127 | private: // ===== INSTANCE VARIABLES ==== 128 | int _max_ticks; // the total number of ticks to print 129 | bool _finalized; 130 | bool _timer_flag; 131 | time_t start,end; 132 | 133 | }; 134 | 135 | #endif 136 | -------------------------------------------------------------------------------- /inst/include/mfbvar.h: -------------------------------------------------------------------------------- 1 | #ifndef MFBVAR_MFBVAR_H 2 | #define MFBVAR_MFBVAR_H 3 | 4 | #include 5 | #include "mvn.h" 6 | #include "simsm_adaptive_univariate.h" 7 | #include "simsm_adaptive_cv.h" 8 | #include "simsm_adaptive_sv.h" 9 | #include 10 | #include "progress_bar.hpp" 11 | 12 | 13 | 14 | arma::vec rmultn(const arma::vec & m, const arma::mat & Sigma); 15 | arma::mat rinvwish(int v, const arma::mat & S); 16 | arma::mat rmatn(const arma::mat & M, const arma::mat & Q, const arma::mat & P); 17 | 18 | // Import the rgig 19 | double do_rgig1(double lambda, double chi, double psi); 20 | double rig(double mu, double lambda); 21 | 22 | #endif 23 | -------------------------------------------------------------------------------- /inst/include/mvn.h: -------------------------------------------------------------------------------- 1 | #ifndef MFBVAR_MVN_BCM_H 2 | #define MFBVAR_MVN_BCM_H 3 | inline arma::vec mvn_bcm(const arma::mat & Phi, const arma::vec & d, 4 | const arma::vec & alpha) { 5 | // Function to sample from a normal posterior in accordance with Bhattacharya, 6 | // Chakraborty and Mallick (2016) 7 | // Notation following Bhattacharya, Chakraborty and Mallick (2016), doi:10.1093/biomet/asw042 8 | // Phi: scaled regressor matrix (n x p) 9 | // d: scaled diagonal of the (diagonal) prior covariance matrix 10 | // alpha: scaled response variable 11 | arma::uword n = Phi.n_rows; 12 | arma::uword p = Phi.n_cols; 13 | 14 | arma::mat U = Phi.t(); 15 | U.each_col() %= d; 16 | arma::vec d_sqrt = sqrt(d); 17 | arma::mat I(n, n, arma::fill::eye); 18 | arma::vec u(p); 19 | u.imbue(norm_rand); 20 | arma::vec delta(n); 21 | delta.imbue(norm_rand); 22 | u %= d_sqrt; 23 | arma::vec v = Phi * u + delta; 24 | arma::vec w = arma::solve(Phi * U + I, (alpha - v)); 25 | arma::vec theta = u + U * w; 26 | 27 | return theta; 28 | } 29 | 30 | #endif 31 | 32 | #ifndef MFBVAR_MVN_BCM_EPS_H 33 | #define MFBVAR_MVN_BCM_EPS_H 34 | inline arma::vec mvn_bcm_eps(const arma::mat & Phi, const arma::vec & d, 35 | const arma::vec & alpha, const arma::vec & eps) { 36 | // Function to sample from a normal posterior in accordance with Bhattacharya, 37 | // Chakraborty and Mallick (2016) with pregenerated random numbers 38 | // Notation following Bhattacharya, Chakraborty and Mallick (2016), doi:10.1093/biomet/asw042 39 | // Phi: scaled regressor matrix (n x p) 40 | // d: scaled diagonal of the (diagonal) prior covariance matrix 41 | // alpha: scaled response variable 42 | // eps: vector of iid N(0,1) (n+p) 43 | arma::uword n = Phi.n_rows; 44 | arma::uword p = Phi.n_cols; 45 | 46 | arma::vec u = arma::vec(eps.begin(), p); 47 | arma::vec delta = arma::vec(eps.begin()+p, n); 48 | 49 | arma::mat U = Phi.t(); 50 | U.each_col() %= d; 51 | arma::vec d_sqrt = sqrt(d); 52 | arma::mat I(n, n, arma::fill::eye); 53 | u %= d_sqrt; 54 | arma::vec v = Phi * u + delta; 55 | arma::vec w = arma::solve(Phi * U + I, (alpha - v)); 56 | arma::vec theta = u + U * w; 57 | 58 | return theta; 59 | } 60 | 61 | #endif 62 | 63 | #ifndef MFBVAR_MVN_RUE_H 64 | #define MFBVAR_MVN_RUE_H 65 | inline arma::vec mvn_rue(const arma::mat & Phi, const arma::vec & d, 66 | const arma::vec & alpha) { 67 | // Function to sample from a normal posterior in accordance with Rue (2001) 68 | // Notation following Bhattacharya, Chakraborty and Mallick (2016), doi:10.1093/biomet/asw042 69 | // Phi: scaled regressor matrix (n x p) 70 | // d: scaled diagonal of the (diagonal) prior covariance matrix 71 | // alpha: scaled response variable 72 | 73 | arma::mat Q = Phi.t() * Phi; 74 | Q.diag() += pow(d, -1.0); 75 | arma::mat L = arma::chol(Q, "lower"); 76 | arma::mat b = Phi.t() * alpha; 77 | arma::vec v = arma::solve(arma::trimatl(L), b); 78 | arma::vec mu = arma::solve(arma::trimatu(L.t()), v); 79 | arma::vec z(Phi.n_cols); 80 | z.imbue(norm_rand); 81 | arma::vec y = arma::solve(arma::trimatu(L.t()), z); 82 | arma::mat theta = mu + y; 83 | 84 | return theta; 85 | } 86 | #endif 87 | 88 | 89 | #ifndef MFBVAR_MVN_CCM_H 90 | #define MFBVAR_MVN_CCM_H 91 | inline arma::vec mvn_ccm(const arma::mat & Phi, const arma::vec & d, 92 | const arma::vec & alpha, double c, double j) { 93 | // Function to sample from a normal posterior when one parameter has non-zero prior mean 94 | // Notation following Bhattacharya, Chakraborty and Mallick (2016), doi:10.1093/biomet/asw042 95 | // Phi: scaled regressor matrix (n x p) 96 | // d: scaled diagonal of the (diagonal) prior covariance matrix 97 | // alpha: scaled response variable 98 | // c: prior mean of the parameter that has non-zero prior mean 99 | // j: index of the parameter 100 | arma::mat Q = Phi.t() * Phi; 101 | Q.diag() += pow(d, -1.0); 102 | arma::mat L = arma::chol(Q, "lower"); 103 | arma::mat b = Phi.t() * alpha; 104 | b(j) += c; 105 | arma::vec v = arma::solve(arma::trimatl(L), b); 106 | arma::vec z(Phi.n_cols); 107 | z.imbue(norm_rand); 108 | arma::vec theta = arma::solve(arma::trimatu(L.t()), v+z); 109 | 110 | return theta; 111 | } 112 | 113 | #endif 114 | 115 | #ifndef MFBVAR_MVN_RUE_EPS_H 116 | #define MFBVAR_MVN_RUE_EPS_H 117 | inline arma::vec mvn_rue_eps(const arma::mat & Phi, const arma::vec & d, 118 | const arma::vec & alpha, const arma::vec & eps, 119 | double c, double j) { 120 | // Function to sample from a normal posterior when one parameter has non-zero prior mean 121 | // using the Rue (2001) algorithm 122 | // Notation following Bhattacharya, Chakraborty and Mallick (2016), doi:10.1093/biomet/asw042 123 | // Phi: scaled regressor matrix (n x p) 124 | // d: scaled diagonal of the (diagonal) prior covariance matrix 125 | // alpha: scaled response variable 126 | // c: prior mean of the parameter that has non-zero prior mean 127 | // j: index of the parameter 128 | 129 | arma::mat Q = Phi.t() * Phi; 130 | Q.diag() += pow(d, -1.0); 131 | arma::mat L = arma::chol(Q, "lower"); 132 | arma::mat b = Phi.t() * alpha; 133 | b(j) += c; 134 | arma::vec v = arma::solve(arma::trimatl(L), b); 135 | arma::vec theta = arma::solve(arma::trimatu(L.t()), v+eps); 136 | 137 | return theta; 138 | } 139 | 140 | #endif 141 | -------------------------------------------------------------------------------- /inst/include/mvn_par.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include "mvn.h" 3 | struct Pi_parallel_rue : public RcppParallel::Worker { 4 | arma::mat & output; 5 | const arma::mat & y; 6 | const arma::mat & X; 7 | const arma::mat & d; 8 | const arma::mat & eps; 9 | const arma::mat & volatility; 10 | const arma::mat & prior_AR1; 11 | arma::uword T; 12 | arma::uword n; 13 | arma::uword p; 14 | 15 | Pi_parallel_rue(arma::mat & output, 16 | const arma::mat & y, 17 | const arma::mat & X, 18 | const arma::mat & d, 19 | const arma::mat & eps, 20 | const arma::mat & volatility, 21 | const arma::mat & prior_AR1, 22 | const arma::uword T, 23 | const arma::uword n, 24 | const arma::uword p); 25 | 26 | void operator()(std::size_t begin, std::size_t end); 27 | }; 28 | 29 | struct Pi_parallel_bcm : public RcppParallel::Worker { 30 | arma::mat & output; 31 | const arma::mat & y; 32 | const arma::mat & X; 33 | const arma::mat & d; 34 | const arma::mat & eps; 35 | const arma::mat & volatility; 36 | arma::uword T; 37 | arma::uword n; 38 | arma::uword p; 39 | 40 | Pi_parallel_bcm(arma::mat & output, 41 | const arma::mat & y, 42 | const arma::mat & X, 43 | const arma::mat & d, 44 | const arma::mat & eps, 45 | const arma::mat & volatility, 46 | const arma::uword T, 47 | const arma::uword n, 48 | const arma::uword p); 49 | 50 | void operator()(std::size_t begin, std::size_t end); 51 | }; 52 | -------------------------------------------------------------------------------- /inst/include/progutils.h: -------------------------------------------------------------------------------- 1 | #ifndef _PROGUTILS_H_ 2 | #define _PROGUTILS_H_ 3 | 4 | /* Contains the following code modules: 5 | 6 | a) some helper functions such as progress bar tools and return value 7 | prettifier 8 | 9 | b) some functions related to the Cholesky decomposition used for 10 | sampling AWOL and efficiently solving the systems of linear 11 | equations 12 | 13 | c) function for inverse transform sampling 14 | 15 | d) a very basic Newton-Raphson algorithm for finding the root 16 | of dlogdnu (defined in densities.h) 17 | */ 18 | 19 | #include 20 | 21 | // b) 22 | // Cholesky factor for a tridiagonal matrix with constant off-diagonal 23 | void cholTridiag( 24 | const arma::vec& omega_diag, 25 | double omega_offdiag, 26 | arma::vec& chol_diag, 27 | arma::vec& chol_offdiag); 28 | 29 | // Solves Chol*x = covector ("forward algorithm") 30 | void forwardAlg( 31 | const arma::vec& chol_diag, 32 | const arma::vec& chol_offdiag, 33 | const arma::vec& covector, 34 | arma::vec& htmp); 35 | 36 | // Solves (Chol')*x = htmp ("backward algorithm") 37 | void backwardAlg( 38 | const arma::vec& chol_diag, 39 | const arma::vec& chol_offdiag, 40 | const arma::vec& htmp, 41 | arma::vec& h); 42 | 43 | // c) 44 | // draws length(r) RVs, expects the non-normalized CDF mixprob 45 | void invTransformSampling( 46 | const arma::vec& mixprob, 47 | arma::ivec& r, 48 | int T); 49 | 50 | // d) 51 | // truncated normal (stationary) 52 | double rtruncnorm(double m, double v); 53 | #endif 54 | -------------------------------------------------------------------------------- /inst/include/simsm_adaptive_cv.h: -------------------------------------------------------------------------------- 1 | #include "simsm_utils.h" 2 | 3 | #ifndef MFBVAR_SIMSM_ADAPTIVE_CV_H 4 | #define MFBVAR_SIMSM_ADAPTIVE_CV_H 5 | 6 | inline arma::mat simsm_adaptive_cv(arma::mat y_, arma::mat Phi, arma::mat Sigma_chol, 7 | arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b) { 8 | // y_: The data matrix (n_T x n_vars) 9 | // Phi: Matrix with regression parameters, first column is the intercept (n_vars x (1 + n_vars * n_lags)) 10 | // Sigma_chol: lower triangular Cholesky factor of error covariance matrix (n_vars x n_vars) 11 | // Lambda: aggregation matrix (obtained from mfbvar:::build_Lambda), (usually n_vars x n_lags) 12 | // Z1: matrix with initial values (n_lags x n_vars) 13 | // n_q_: number of quarterly variables 14 | // T_b: time index of first NA among monthly variables ( = n_T if none) 15 | 16 | // intercept is first column 17 | arma::uword n_vars = y_.n_cols; 18 | arma::uword n_lags = Z1.n_rows; 19 | arma::uword n_T = y_.n_rows; 20 | arma::uword n_q = n_q_; 21 | arma::uword n_m = n_vars - n_q; 22 | 23 | /////////////////////////////////////////////// 24 | // SIMULATING // 25 | /////////////////////////////////////////////// 26 | arma::mat Phi_no_c = Phi.cols(1, n_vars * n_lags); 27 | arma::mat Phi_c = Phi.col(0); 28 | arma::uvec quarterly_indexes = create_quarterly_indexes(Lambda, n_m, n_q, n_vars); 29 | 30 | // Generating errors 31 | arma::mat epsilon = arma::mat(n_T, n_vars, arma::fill::zeros); 32 | std::generate(epsilon.begin(), epsilon.end(), ::norm_rand); 33 | arma::mat Z_gen = arma::mat(n_T+1, n_vars*n_lags, arma::fill::zeros); 34 | arma::mat y_sim = arma::mat(n_T, n_vars).fill(NA_REAL); 35 | 36 | arma::uvec obs_vars; 37 | arma::uvec t_vec(1); 38 | arma::mat Zt; 39 | 40 | for (arma::uword i = 1; i <= n_T; i++) { 41 | epsilon.row(i-1) = epsilon.row(i-1) * Sigma_chol.t(); 42 | } 43 | 44 | create_sim(Z_gen, y_sim, Phi_no_c, Phi_c, epsilon, y_, Z1, Lambda, 45 | quarterly_indexes, n_vars, n_m, n_q, n_T, n_lags); 46 | 47 | /////////////////////////////////////////////// 48 | // COMPACT // 49 | /////////////////////////////////////////////// 50 | arma::mat y_orig = y_; 51 | y_ = y_ - y_sim; 52 | arma::mat Z1_orig = Z1; 53 | Z1 = arma::mat(arma::size(Z1), arma::fill::zeros); 54 | Phi.col(0) = arma::mat(n_vars, 1, arma::fill::zeros); 55 | Phi_c = Phi_c.fill(0.0); 56 | 57 | 58 | /////////////////////////////////////////////// 59 | // COMPACT // 60 | /////////////////////////////////////////////// 61 | arma::mat y_Tb = y_.rows(0, T_b - 1); 62 | arma::mat y = y_Tb; 63 | 64 | arma::mat Phi_mm(n_m, n_m*n_lags); 65 | arma::mat Phi_mq(n_m, n_q*n_lags); 66 | arma::mat Phi_qm(n_q, n_m*n_lags); 67 | arma::mat Phi_qq(n_q, n_q*n_lags); 68 | 69 | arma::mat Z = arma::mat(n_vars, n_q*(n_lags + 1), arma::fill::zeros); 70 | arma::mat Tt = arma::mat(n_q*(n_lags + 1), n_q*(n_lags + 1), arma::fill::zeros); 71 | 72 | arma::mat G = arma::mat(n_vars, n_vars, arma::fill::zeros); 73 | arma::mat H = arma::mat(n_q*(n_lags + 1), n_vars, arma::fill::zeros); 74 | 75 | arma::mat X = arma::mat(1, n_m*n_lags, arma::fill::zeros); 76 | arma::mat c = arma::mat(1, n_vars, arma::fill::zeros); 77 | arma::mat intercept = arma::mat(1, n_vars, arma::fill::zeros); 78 | 79 | arma::mat W = arma::mat(1, n_m*n_lags + 1, arma::fill::ones); 80 | arma::mat d = arma::mat(1, n_q*(n_lags + 1), arma::fill::zeros); 81 | arma::mat Beta_W = arma::mat(n_q, n_m*n_lags+1, arma::fill::zeros); 82 | 83 | arma::mat a1 = arma::mat(n_q*(n_lags+1), 1, arma::fill::zeros); 84 | create_matrices(Phi_mm, Phi_mq, Phi_qm, Phi_qq, Z, Tt, intercept, a1, W, d, 85 | Beta_W, n_vars, n_m, n_q, n_lags, Lambda, Z1, Phi); 86 | 87 | G(arma::span(0, n_m - 1), arma::span::all) = Sigma_chol(arma::span(0, n_m - 1), arma::span::all); 88 | H(arma::span(0, n_q - 1), arma::span::all) = Sigma_chol(arma::span(n_m, n_vars - 1), arma::span::all); 89 | arma::mat HH = H * H.t(); 90 | a1 += d.t(); 91 | arma::mat P1 = HH; 92 | /////////////////////////////////////////////// 93 | // COMPACT FILTERING // 94 | /////////////////////////////////////////////// 95 | arma::mat r_T; 96 | arma::mat a_tt_compact = arma::mat(n_T, n_q*(n_lags+1)).fill(NA_REAL); 97 | arma::mat a = arma::mat(n_T, n_q*(n_lags+1)).fill(NA_REAL); 98 | arma::mat a_tT = arma::mat(n_T, n_q*(n_lags+1)).fill(NA_REAL); 99 | arma::mat Z_tT = arma::mat(n_T, n_vars).fill(NA_REAL); 100 | 101 | arma::mat a_tt_y = y_; 102 | arma::mat a_tT_y = y_; 103 | arma::mat a_y = arma::mat(arma::size(y_)).fill(NA_REAL); 104 | 105 | arma::mat Gt, Ht, M_t, FF_inv_t, K_t, v_t, a_t1, P_t1, P_TT; 106 | arma::mat a_t = a1.t(); 107 | arma::mat P_t = P1; 108 | 109 | arma::mat v_FF_inv = arma::mat(n_T, n_vars, arma::fill::zeros); 110 | arma::mat v = arma::mat(n_T, n_vars, arma::fill::zeros); 111 | arma::mat L, N; 112 | arma::mat v_FF_inv_t, F_t, GZH; 113 | 114 | arma::cube L_compact = arma::cube(n_q*(n_lags+1), n_q*(n_lags+1), T_b).fill(NA_REAL); 115 | arma::cube N_compact = arma::cube(n_q*(n_lags+1), n_q*(n_lags+1), T_b+1).fill(NA_REAL); 116 | 117 | for (arma::uword t = 0; t < T_b; t++) { 118 | prepare_filtering_t(obs_vars, t_vec, X, W, c, d, t, y, Z1, Phi_mm, Beta_W, 119 | n_m, n_q, n_lags); 120 | 121 | Zt = Z.rows(obs_vars); 122 | Gt = G.rows(obs_vars); 123 | 124 | v_t = y.submat(t_vec, obs_vars) - a_t * Zt.t() - c.cols(obs_vars) - intercept.cols(obs_vars); 125 | M_t = P_t * Zt.t() + H * Gt.t(); 126 | GZH = Gt + (Zt * H); 127 | F_t = Zt * M_t + Gt * GZH.t(); 128 | FF_inv_t = arma::inv_sympd(arma::symmatu(F_t)); 129 | v_FF_inv_t = v_t * FF_inv_t; 130 | v_FF_inv.submat(t_vec, obs_vars) = v_FF_inv_t; 131 | v.submat(t_vec, obs_vars) = v_t; 132 | 133 | K_t = Tt * M_t * FF_inv_t; 134 | L = Tt - K_t * Zt; 135 | N = P_t * L.t() - H * Gt.t() * K_t.t(); 136 | a.row(t) = a_t; 137 | a_tt_compact.row(t) = a_t + v_FF_inv_t * M_t.t(); 138 | a_y.row(t).cols(n_m, n_vars - 1) = a.row(t).cols(0, n_q - 1); 139 | a_tt_y.row(t).cols(n_m, n_vars - 1) = a_tt_compact.row(t).cols(0, n_q - 1); 140 | 141 | L_compact.slice(t) = L; 142 | N_compact.slice(t) = N; 143 | 144 | if (t < T_b - 1) { 145 | a_t = a_tt_compact.row(t) * Tt.t() + d; 146 | P_t = Tt * N; 147 | P_t += HH; 148 | P_t = arma::symmatu(P_t); 149 | } else { 150 | a_t1 = a_t * Tt.t() + d + v_t * K_t.t(); 151 | if (T_b < n_T) { 152 | P_t1 = Tt * N + HH; 153 | P_t1 = arma::symmatu(P_t1); 154 | P_TT = P_t - M_t * FF_inv_t * M_t.t(); 155 | } 156 | } 157 | 158 | } 159 | 160 | /////////////////////////////////////////////// 161 | // ADAPTIVE // 162 | /////////////////////////////////////////////// 163 | arma::field a_tt_out(n_T-T_b, 1); 164 | arma::field L_store(n_T-T_b, 1); 165 | arma::field N_store(n_T-T_b, 1); 166 | arma::field ZFv(n_T-T_b, 1); 167 | 168 | arma::mat Phi_umum, Phi_omom, Phi_omu, W_intercept, Phi_uom, y_t, y_tpt, Phi_uu, y_tpt2, a_tt; 169 | arma::uvec obs_m, obs_q, non_obs_m, obs_m2, non_obs_m2; 170 | arma::uword n_ovars, n_oq, n_om2; 171 | arma::uword n_om = 0; 172 | 173 | if (T_b < n_T) { 174 | update_missing(y_t, obs_vars, obs_q, n_ovars, n_oq, obs_m, n_om, non_obs_m, obs_m2, 175 | n_om2, non_obs_m2, y_tpt, y_tpt2, T_b, y_, n_vars, n_m, n_lags); 176 | 177 | Ht = arma::mat((n_m-n_om+n_q)*(n_lags+1), n_vars, arma::fill::zeros); 178 | if (n_m > n_om) { 179 | Ht.rows(0, n_m - n_om - 1) = Sigma_chol.rows(non_obs_m); 180 | } 181 | Ht.rows(n_m - n_om, n_m - n_om + n_q - 1) = Sigma_chol.rows(n_m, n_m+n_q-1); 182 | 183 | a_tt = a_tt_compact.row(T_b-1); 184 | 185 | Phi_uom = create_Phi_uom(Phi, n_vars, n_q, n_m, n_om, n_om2, n_lags, non_obs_m, obs_m2); 186 | Phi_uu = create_Phi_uu(Phi, n_vars, n_q, n_m, n_om, n_om2, n_lags, non_obs_m, non_obs_m2); 187 | 188 | // Update Tt 189 | Tt = arma::mat((n_q+n_m-n_om)*(n_lags + 1), (n_q+n_m-n_om2)*(n_lags + 1)); 190 | d = arma::mat(1, (n_m-n_om+n_q)*(n_lags + 1), arma::fill::zeros); 191 | create_Tt_d(Tt, d, Phi_uu, T_b-1, y_, n_m, n_q, n_om, 192 | n_om2, n_lags, obs_m2, non_obs_m, y_tpt2, Phi_uom); 193 | 194 | a_t = a_tt * Tt.t() + d; 195 | P_t = (Tt * P_TT) * Tt.t() + Ht * Ht.t(); 196 | store_a(a_y, a_t, T_b, non_obs_m, n_m, n_om, n_q); 197 | 198 | for (arma::uword t = T_b; t < n_T; t++) { 199 | t_vec(0) = t; 200 | 201 | X = arma::mat(1, n_om*n_lags, arma::fill::ones); 202 | X.cols(0, n_om*n_lags - 1) = reshape(trans(flipud(y_tpt.rows(0, n_lags-1))), 1, n_lags*n_om); 203 | 204 | W_intercept = arma::mat(n_m-n_om+n_q, 1); 205 | W_intercept.rows(0, n_m-n_om-1) = intercept.cols(non_obs_m).t(); 206 | W_intercept.rows(n_m-n_om, n_m-n_om+n_q-1) = Phi.col(0).rows(n_m, n_vars - 1); 207 | 208 | Phi_omom = create_Phi_omom(Phi, n_vars, n_om, n_om2, n_lags, obs_m, obs_m2); 209 | Phi_omu = create_Phi_omu(Phi, n_vars, n_q, n_m, n_om, n_om2, n_lags, non_obs_m, obs_m, obs_vars); 210 | 211 | c = arma::mat(1, n_ovars, arma::fill::zeros); 212 | c.cols(0, n_om - 1) = X * trans(Phi_omom); 213 | 214 | Zt = arma::mat(obs_vars.n_elem, (n_q+n_m-n_om)*(n_lags+1), arma::fill::zeros); 215 | create_Zt(Zt, Phi_omu, Lambda, n_ovars, n_m, n_om, n_om2, n_q, n_oq, n_lags, obs_q); 216 | 217 | Gt = G.rows(obs_vars); 218 | v_t = y_.submat(t_vec, obs_vars) - a_t * Zt.t() - c - intercept.cols(obs_vars); 219 | M_t = P_t * Zt.t() + Ht * Gt.t(); 220 | FF_inv_t = inv_sympd(symmatu(Zt * M_t + Gt * trans(Gt + Zt * Ht))); 221 | v_FF_inv_t = v_t * FF_inv_t; 222 | v_FF_inv.submat(t_vec, obs_vars) = v_FF_inv_t; 223 | v.submat(t_vec, obs_vars) = v_t; 224 | ZFv(t-T_b, 0) = v_FF_inv_t * Zt; 225 | 226 | if (t < n_T - 1) { 227 | update_missing(y_t, obs_vars, obs_q, n_ovars, n_oq, obs_m, n_om, non_obs_m, obs_m2, 228 | n_om2, non_obs_m2, y_tpt, y_tpt2, t+1, y_, n_vars, n_m, n_lags); 229 | } else { 230 | obs_m2 = obs_m; 231 | n_om2 = n_om; 232 | non_obs_m2 = non_obs_m; 233 | } 234 | 235 | Phi_uom = create_Phi_uom(Phi, n_vars, n_q, n_m, n_om, n_om2, n_lags, non_obs_m, obs_m2); 236 | Phi_uu = create_Phi_uu(Phi, n_vars, n_q, n_m, n_om, n_om2, n_lags, non_obs_m, non_obs_m2); 237 | 238 | if (t < n_T - 1) { 239 | Tt = arma::mat((n_q+n_m-n_om)*(n_lags + 1), (n_q+n_m-n_om2)*(n_lags + 1)); 240 | d = arma::mat(1, (n_m-n_om+n_q)*(n_lags + 1), arma::fill::zeros); 241 | create_Tt_d(Tt, d, Phi_uu, t, y_, n_m, n_q, n_om, 242 | n_om2, n_lags, obs_m2, non_obs_m, y_tpt2, Phi_uom); 243 | K_t = Tt * M_t * FF_inv_t; 244 | L = Tt - K_t * Zt; 245 | N = P_t * L.t() - Ht * Gt.t() * K_t.t(); 246 | 247 | L_store(t-T_b, 0) = L; 248 | N_store(t-T_b, 0) = N; 249 | } 250 | 251 | a_tt = a_t + v_FF_inv_t * M_t.t(); 252 | a_tt_out(t-T_b, 0) = a_tt; 253 | store_a(a_tt_y, a_tt, t, non_obs_m2, n_m, n_om2, n_q); 254 | if (t < n_T - 1) { 255 | Ht = arma::mat((n_m-n_om+n_q)*(n_lags+1), n_vars, arma::fill::zeros); 256 | Ht.rows(0, n_m - n_om - 1) = Sigma_chol.rows(non_obs_m); 257 | Ht.rows(n_m - n_om, n_m - n_om + n_q - 1) = Sigma_chol.rows(n_m, n_m+n_q-1); 258 | 259 | a_t = a_tt * Tt.t() + d; 260 | P_t = Tt * N + Ht * Ht.t(); 261 | P_t = arma::symmatu(P_t); 262 | 263 | store_a(a_y, a_t, t+1, non_obs_m, n_m, n_om, n_q); 264 | } 265 | } 266 | } 267 | 268 | /////////////////////////////////////////////// 269 | // SMOOTHING // 270 | /////////////////////////////////////////////// 271 | arma::mat r = adaptive_to_compact_smoothing(a_tT_y, a_tt_y, a_tt, a_tt_compact, a_tt_out, 272 | N_store, L_store, ZFv, y_, a_t1, P_t1, n_vars, 273 | n_m, n_q, n_T, T_b, n_lags, n_om); 274 | compact_smoothing(a_tT_y, r, a_tt_compact, Z, y, N_compact, L_compact, v_FF_inv, 275 | T_b, n_vars, n_m, n_q); 276 | arma::mat Z_rand = Z_gen.rows(1, n_T).cols(0, n_vars - 1); 277 | arma::mat Z_draw = a_tT_y + Z_rand; 278 | return Z_draw; 279 | } 280 | 281 | 282 | #endif 283 | -------------------------------------------------------------------------------- /inst/include/simsm_utils.h: -------------------------------------------------------------------------------- 1 | #ifndef MFBVAR_SIMSM_UTILS_H 2 | #define MFBVAR_SIMSM_UTILS_H 3 | 4 | arma::mat create_Phi_uu(const arma::mat &Phi, arma::uword n_vars, arma::uword n_q, arma::uword n_m, arma::uword n_om, 5 | arma::uword n_om2, arma::uword n_lags, arma::uvec non_obs_m, arma::uvec non_obs_m2); 6 | arma::mat create_Phi_uom(const arma::mat &Phi, arma::uword n_vars, arma::uword n_q, arma::uword n_m, arma::uword n_om, 7 | arma::uword n_om2, arma::uword n_lags, arma::uvec non_obs_m, arma::uvec obs_m2); 8 | arma::mat create_Phi_omu(const arma::mat &Phi, arma::uword n_vars, arma::uword n_q, arma::uword n_m, arma::uword n_om, 9 | arma::uword n_om2, arma::uword n_lags, arma::uvec non_obs_m, arma::uvec obs_m, arma::uvec obs_vars); 10 | arma::mat create_Phi_omom(const arma::mat &Phi, arma::uword n_vars, arma::uword n_om, arma::uword n_om2, 11 | arma::uword n_lags, arma::uvec obs_m, arma::uvec obs_m2); 12 | void create_Tt_d(arma::mat & Tt, arma::mat & d, const arma::mat & Phi_uu, arma::uword t, 13 | const arma::mat & y_, arma::uword n_m, arma::uword n_q, 14 | arma::uword n_om, arma::uword n_om2, arma::uword n_lags, 15 | arma::uvec obs_m2, arma::uvec non_obs_m, const arma::mat & y_tpt2, 16 | const arma::mat & Phi_uom); 17 | void create_Zt(arma::mat & Zt, const arma::mat & Phi_omu, const arma::mat & Lambda, 18 | arma::uword n_ovars, arma::uword n_m, arma::uword n_om, arma::uword n_om2, 19 | arma::uword n_q, arma::uword n_oq, arma::uword n_lags, const arma::uvec & obs_q); 20 | void update_missing(arma::mat & y_t, arma::uvec & obs_vars, arma::uvec & obs_q, 21 | arma::uword & n_ovars, arma::uword & n_oq, 22 | arma::uvec & obs_m, arma::uword & n_om, arma::uvec & non_obs_m, 23 | arma::uvec & obs_m2, arma::uword & n_om2, arma::uvec & non_obs_m2, 24 | arma::mat & y_tpt, arma::mat & y_tpt2, 25 | arma::uword t, const arma::mat & y_, arma::uword n_vars, arma::uword n_m, arma::uword n_lags); 26 | void store_a(arma::mat & a, arma::mat a_t, arma::uword t, arma::uvec non_obs_m, 27 | arma::uword n_m, arma::uword n_om, arma::uword n_q); 28 | arma::mat companion_reshaper(arma::mat obj_, unsigned int n_m_, unsigned int n_q_, unsigned int n_T_, unsigned int n_lags_); 29 | void compact_smoothing(arma::mat & a_tT_y, arma::mat & r, const arma::mat & a_tt_compact, const arma::mat & Z, 30 | const arma::mat & y, const arma::cube & N_compact, 31 | const arma::cube & L_compact, const arma::mat & v_FF_inv, 32 | arma::uword T_b, arma::uword n_vars, arma::uword n_m, 33 | arma::uword n_q); 34 | arma::mat adaptive_to_compact_smoothing(arma::mat & a_tT_y, 35 | const arma::mat &a_tt_y, 36 | const arma::mat & a_tt, 37 | const arma::mat & a_tt_compact, 38 | const arma::field & a_tt_out, 39 | const arma::field & N_store, 40 | const arma::field & L_store, 41 | const arma::field & ZFv, 42 | const arma::mat y_, const arma::mat & a_t1, 43 | const arma::mat & P_t1, arma::uword n_vars, 44 | arma::uword n_m, arma::uword n_q, 45 | arma::uword n_T, arma::uword T_b, arma::uword n_lags, 46 | arma::uword n_om); 47 | arma::uvec create_quarterly_indexes(const arma::mat & Lambda, arma::uword n_m, 48 | arma::uword n_q, arma::uword n_vars); 49 | void create_sim(arma::mat & Z_gen, arma::mat & y_sim, 50 | const arma::mat & Phi_no_c, const arma::mat & Phi_c, 51 | const arma::mat & epsilon, const arma::mat & y_, 52 | const arma::mat & Z1, const arma::mat & Lambda, 53 | const arma::uvec quarterly_indexes, 54 | arma::uword n_vars, arma::uword n_m, arma::uword n_q, 55 | arma::uword n_T, arma::uword n_lags); 56 | void create_matrices(arma::mat & Phi_mm, arma::mat & Phi_mq, arma::mat & Phi_qm, 57 | arma::mat & Phi_qq, arma::mat & Z, arma::mat & Tt, arma::mat & intercept, 58 | arma::mat & a1, arma::mat & W, arma::mat & d, arma::mat & Beta_W, 59 | arma::uword n_vars, arma::uword n_m, arma::uword n_q, 60 | arma::uword n_lags, const arma::mat & Lambda, 61 | const arma::mat & Z1, const arma::mat & Phi); 62 | void prepare_filtering_t(arma::uvec & obs_vars, arma::uvec & t_vec, arma::mat & X, 63 | arma::mat & W, arma::mat & c, arma::mat & d, arma::uword t, 64 | const arma::mat & y, const arma::mat & Z1, 65 | const arma::mat & Phi_mm, const arma::mat & Beta_W, 66 | arma::uword n_m, arma::uword n_q, arma::uword n_lags); 67 | #endif 68 | -------------------------------------------------------------------------------- /inst/include/update_csv.h: -------------------------------------------------------------------------------- 1 | #ifndef _UPDATE_CSV_H_ 2 | #define _UPDATE_CSV_H_ 3 | void update_csv( 4 | const arma::mat& data, 5 | double& phi, 6 | double& sigma, 7 | arma::vec& h, 8 | double& h0, 9 | arma::mat& mixprob, 10 | arma::imat& r, 11 | const double priorlatent0, 12 | const double phi_invvar, 13 | const double phi_meaninvvar, 14 | const double prior_sigma2, 15 | const double prior_df); 16 | 17 | #endif 18 | 19 | -------------------------------------------------------------------------------- /inst/include/update_dl.h: -------------------------------------------------------------------------------- 1 | #ifndef MFBVAR_UPDATE_DL_H 2 | #define MFBVAR_UPDATE_DL_H 3 | void update_dl(arma::mat & prior_Pi_Omega, arma::vec & aux, 4 | arma::vec & local, double & global, const arma::mat & Pi_i, 5 | arma::uword n_vars, arma::uword n_lags, const double a, 6 | arma::vec & slice, bool gig = true, 7 | bool intercept = true); 8 | #endif 9 | -------------------------------------------------------------------------------- /inst/include/update_fsv.h: -------------------------------------------------------------------------------- 1 | #ifndef _UPDATE_FSV_H_ 2 | #define _UPDATE_FSV_H_ 3 | void update_fsv(arma::mat & armafacload, arma::mat & armaf, arma::mat & armah, 4 | arma::vec & armah0, 5 | Rcpp::NumericMatrix & curpara, 6 | const arma::mat & armatau2, 7 | const arma::mat & armay, 8 | const double bmu, const double Bmu, const double a0idi, const double b0idi, 9 | const double a0fac, const double b0fac, const Rcpp::NumericVector & Bsigma, 10 | const double B011inv, const double B022inv, 11 | const Rcpp::NumericVector & priorh0, const arma::imat & armarestr); 12 | #endif 13 | -------------------------------------------------------------------------------- /inst/include/update_ng.h: -------------------------------------------------------------------------------- 1 | #ifndef _UPDATE_NG_H_ 2 | #define _UPDATE_NG_H_ 3 | void update_ng(double & phi_mu, double & lambda_mu, arma::vec & omega, arma::uword nm, 4 | const double c0, const double c1, double s, 5 | const arma::vec & psi_i, const arma::vec & prior_psi_mean, double & accept); 6 | #endif 7 | -------------------------------------------------------------------------------- /man-roxygen/man_template.R: -------------------------------------------------------------------------------- 1 | #' @title Template titel 2 | #' <%=ifelse(exists("A"), "@param A Symmetrix matrix whose maximum eigenvalue is to be computed.", "") %> 3 | #' <%=ifelse(exists("aggregation"), "@param aggregation A character vector of length \\code{n_vars} with elements being \\code{'identity'}, \\code{'average'} or \\code{'triangular'} to indicate the type of aggregation scheme to assume.", "") %> 4 | #' <%=ifelse(exists("chisq_val"), "@param chisq_val The value in the corresponding chi-square distribution; if the normal quadratic form exceeds this, the pdf is 0.", "") %> 5 | #' <%=ifelse(exists("check_roots"), "@param check_roots Logical, if roots of the companion matrix are to be checked to ensure stationarity.", "") %> 6 | #' <%=ifelse(exists("d"), "@param d The matrix of size \\code{(n_T + n_lags) * n_determ} of deterministic terms.", "") %> 7 | #' <%=ifelse(exists("D_mat"), "@param D_mat The \\code{D} matrix (from \\code{\\link{build_DD}}).", "") %> 8 | #' <%=ifelse(exists("d_fcst"), "@param d_fcst The deterministic terms for the forecasting period.", "") %> 9 | #' <%=ifelse(exists("freq"), "@param freq (Only used if \\code{Y} is a matrix) Character vector with elements 'm' (monthly) or 'q' (quarterly) for sampling frequency. Monthly variables must precede all quarterly variables.", "") %> 10 | #' <%=ifelse(exists("h0"), "@param h0 The initial state (\\code{(n_vars*n_lags)*1}).", "") %> 11 | #' <%=ifelse(exists("Lambda"), "@param Lambda The Lambda matrix (size \\code{n_vars* (n_vars*n_lags)}).", "") %> 12 | #' <%=ifelse(exists("lambda1"), "@param lambda1 The overall tightness.", "") %> 13 | #' <%=ifelse(exists("lambda1_grid"), "@param lambda1_grid The grid of values to use for lambda1.", "") %> 14 | #' <%=ifelse(exists("lambda2_grid"), "@param lambda2_grid The grid of values to use for lambda2.", "") %> 15 | #' <%=ifelse(exists("lambda2"), "@param lambda2 The lag decay.", "") %> 16 | #' <%=ifelse(exists("lambda3"), "@param lambda3 The tightness of the intercept prior variance.", "") %> 17 | #' <%=ifelse(exists("lH"), "@param lH A list of length \\code{n_T}, where \\code{M_Lambda[[t]]} corresponds to \\eqn{M_t\\Lambda}. The column dimension of each element should be \\code{n_lags*n_vars}, but the row dimension may vary.", "") %> 18 | #' <%=ifelse(exists("init_Pi"), "@param init_Pi Matrix to initialize the dynamic coefficients.", "") %> 19 | #' <%=ifelse(exists("init_psi"), "@param init_psi Matrix to initialize the steady-state parameters.", "") %> 20 | #' <%=ifelse(exists("init_Sigma"), "@param init_Sigma Matrix to initialize the error covariance.", "") %> 21 | #' <%=ifelse(exists("init_Z"), "@param init_Z Matrix to initialize the latent state.", "") %> 22 | #' <%=ifelse(exists("inv_prior_Pi_Omega"), "@param inv_prior_Pi_Omega The inverse of the prior covariance matrix for Pi.", "") %> 23 | #' <%=ifelse(exists("ip"), "@param ip The number of variables (\\code{n_vars}).", "") %> 24 | #' <%=ifelse(exists("iq"), "@param iq The companion-form dimension (\\code{n_vars*n_lags}).", "") %> 25 | #' <%=ifelse(exists("iT"), "@param iT The sample size (sometimes called \\code{n_T}).", "") %> 26 | #' <%=ifelse(exists("m"), "@param m The mean vector of size \\code{p}.", "") %> 27 | #' <%=ifelse(exists("method"), "@param method The method to use for estimation of the log marginal data density. One of \\code{1} and \\code{2}.", "") %> 28 | #' <%=ifelse(exists("mfbvar_obj"), "@param mfbvar_obj An object of class \\code{mfbvar} containing the results.", "") %> 29 | #' <%=ifelse(exists("monthly_cols"), "@param monthly_cols Column indexes of monthly variables.", "") %> 30 | #' <%=ifelse(exists("M"), "@param M The mean matrix of size \\code{p * q}.", "") %> 31 | #' <%=ifelse(exists("mF"), "@param mF \\code{(n_vars*n_lags) * (n_vars*n_lags)} matrix containing parameters (companion form)", "") %> 32 | #' <%=ifelse(exists("mQ"), "@param mQ \\code{(n_vars*n_lags) * (n_vars*n_lags)} matrix whose \\code{n_vars*n_vars} top-left block is the Cholesky decomposition of the error covariance matrix", "") %> 33 | #' <%=ifelse(exists("mZ"), "@param mZ \\code{T * n_vars} matrix with the observations (\\code{NA} represents missingness)", "") %> 34 | #' <%=ifelse(exists("n_burnin"), "@param n_burnin The number of burn-in replications.", "") %> 35 | #' <%=ifelse(exists("n_comp"), "@param n_comp The length of the companion form vector of data (\\code{n_vars*n_lags}).", "") %> 36 | #' <%=ifelse(exists("n_cores"), "@param n_cores The number of cores to use (if set to 1, computation is done serially).", "") %> 37 | #' <%=ifelse(exists("n_determ"), "@param n_determ The number of deterministic terms.", "") %> 38 | #' <%=ifelse(exists("n_fcst"), "@param n_fcst The number of periods to forecast.", "") %> 39 | #' <%=ifelse(exists("n_lags"), "@param n_lags The number of lags.", "") %> 40 | #' <%=ifelse(exists("n_reps"), "@param n_reps The number of replications.", "") %> 41 | #' <%=ifelse(exists("n_T"), "@param n_T The number of time points.", "") %> 42 | #' <%=ifelse(exists("n_T_"), "@param n_T_ The number of time points (excluding pre-sample).", "") %> 43 | #' <%=ifelse(exists("n_vars"), "@param n_vars The number of variables.", "") %> 44 | #' <%=ifelse(exists("Omega_Pi"), "@param Omega_Pi The \\code{inv_prior_Pi_Omega} multiplied by \\code{prior_Pi} matrix.", "") %> 45 | #' <%=ifelse(exists("P"), "@param P \\code{p * p} covariance matrix.", "") %> 46 | #' <%=ifelse(exists("postsim"), "@param postsim The log marginal data density for \\code{Z}.", "") %> 47 | #' <%=ifelse(exists("Q"), "@param Q \\code{q * q} covariance matrix.", "") %> 48 | #' <%=ifelse(exists("Q_comp"), "@param Q_comp The lower-triangular Cholesky decomposition of the covariance matrix (in companion form).", "") %> 49 | #' <%=ifelse(exists("p_trunc"), "@param p_trunc \\code{1-p_trunc} is the degree of truncation (i.e. \\code{p_trunc=1} is no truncation).", "") %> 50 | #' <%=ifelse(exists("P0"), "@param P0 The covariance matrix of the initial state (\\code{(n_vars*n_lags)*(n_vars*n_lags)}).", "") %> 51 | #' <%=ifelse(exists("Pi"), "@param Pi Matrix of size \\code{n_vars * (n_vars*n_lags)} containing the dynamic coefficients.", "") %> 52 | #' <%=ifelse(exists("Pi_array"), "@param Pi_array Array of draws of Pi from the Gibbs sampler.", "") %> 53 | #' <%=ifelse(exists("Pi_r"), "@param Pi_r The current draw of \\code{Pi} (i.e. \\code{Pi[,, r]}).", "") %> 54 | #' <%=ifelse(exists("Pi_comp"), "@param Pi_comp Matrix with the dynamic coefficients in companion form.", "") %> 55 | #' <%=ifelse(exists("post_nu"), "@param post_nu The posterior of the parameter \\eqn{\\nu}.", "") %> 56 | #' <%=ifelse(exists("post_Pi_center"), "@param post_Pi_center The value at which to do the evaluation (e.g. the posterior mean/median).", "") %> 57 | #' <%=ifelse(exists("post_psi_Omega"), "@param post_psi_Omega The covariance matrix in the posterior, \\eqn{\\bar{\\Omega}_{\\Psi}}.", "") %> 58 | #' <%=ifelse(exists("post_psi_center"), "@param post_psi_center The value at which to do the evaluation (e.g. the posterior mean/median).", "") %> 59 | #' <%=ifelse(exists("post_Sigma_center"), "@param post_Sigma_center The value at which to do the evaluation (e.g. the posterior mean/median).", "") %> 60 | #' <%=ifelse(exists("prior_nu"), "@param prior_nu The prior degrees of freedom.", "") %> 61 | #' <%=ifelse(exists("prior_Pi"), "@param prior_Pi Matrix of size \\code{n_vars * (n_vars*n_lags)} containing the prior for the mean of the dynamic coefficients.", "") %> 62 | #' <%=ifelse(exists("prior_Pi_AR1"), "@param prior_Pi_AR1 The prior means for the AR(1) coefficients.", "") %> 63 | #' <%=ifelse(exists("prior_Pi_mean"), "@param prior_Pi_mean Matrix of size \\code{n_vars * (n_vars*n_lags)} containing the prior for the mean of the dynamic coefficients.", "") %> 64 | #' <%=ifelse(exists("prior_Pi_Omega"), "@param prior_Pi_Omega Matrix of size \\code{(n_vars*n_lags)* (n_vars*n_lags)} containing the prior for (part of) the prior covariance of the dynamic coefficients.", "") %> 65 | #' <%=ifelse(exists("prior_psi_mean"), "@param prior_psi_mean Vector of length \\code{n_determ*n_vars} with the prior means of the steady-state parameters.", "") %> 66 | #' <%=ifelse(exists("prior_psi_Omega"), "@param prior_psi_Omega Matrix of size \\code{(n_determ*n_vars) * (n_determ*n_vars)} with the prior covariance of the steady-state parameters.", "") %> 67 | #' <%=ifelse(exists("prior_psi_int"), "@param prior_psi_int Matrix of size \\code{(n_determ*n_vars) * 2} with the prior 95 \\% prior probability intervals.", "") %> 68 | #' <%=ifelse(exists("prior_S"), "@param prior_S The prior for \\eqn{\\Sigma}.", "") %> 69 | #' <%=ifelse(exists("psi_r"), "@param psi_r The current draw of \\code{psi} (i.e. \\code{psi[r-1,]}).", "") %> 70 | #' <%=ifelse(exists("psi_r1"), "@param psi_r1 The previous draw of \\code{psi} (i.e. \\code{psi[r-1,]}).", "") %> 71 | #' <%=ifelse(exists("S"), "@param S \\code{q * q} scale matrix.", "") %> 72 | #' <%=ifelse(exists("Sigma"), "@param Sigma The covariance matrix.", "") %> 73 | #' <%=ifelse(exists("Sigma_array"), "@param Sigma_array Array of draws of Sigma from the Gibbs sampler.", "") %> 74 | #' <%=ifelse(exists("Sigma_r"), "@param Sigma_r The current draw of \\code{Sigma} (i.e. \\code{Sigma[,, r]}).", "") %> 75 | #' <%=ifelse(exists("smooth_state"), "@param smooth_state Logical, if \\code{TRUE} then the smoothed estimates of the latent states are also returned.", "") %> 76 | #' <%=ifelse(exists("U"), "@param U \\eqn{U} matrix, of size \\code{(n_vars*n_determ*(n_lags+1)) * (n_vars*n_determ)}. This can be obtained using \\code{\\link{build_U}}.", "") %> 77 | #' <%=ifelse(exists("v"), "@param v The degrees of freedom.", "") %> 78 | #' <%=ifelse(exists("verbose"), "@param verbose Logical, if progress should be printed to the console.", "") %> 79 | #' <%=ifelse(exists("V_inv"), "@param V_inv The inverse of the covariance matrix of size \\code{d * d}.", "") %> 80 | #' <%=ifelse(exists("x"), "@param x A vector of size \\code{p}.", "") %> 81 | #' <%=ifelse(exists("X"), "@param X Matrix of size \\code{p * q}.", "") %> 82 | #' <%=ifelse(exists("Y"), "@param Y The data matrix of size \\code{(n_T + n_lags) * n_vars} with \\code{NA} representing missingness. All monthly variables must be placed before quarterly variables.", "") %> 83 | #' <%=ifelse(exists("Y_tilde"), "@param Y_tilde The lag-corrected data matrix (with no missing values) of size \\code{n_T * n_vars}.", "") %> 84 | #' <%=ifelse(exists("z"), "@param z A matrix of size \\code{(n_T + n_lags) * n_vars} of data.", "") %> 85 | #' <%=ifelse(exists("Z"), "@param Z The array of draws from the posterior of \\code{Z}.", "") %> 86 | #' <%=ifelse(exists("Z_array"), "@param Z_array The array of draws of Z from the Gibbs sampler.", "") %> 87 | #' <%=ifelse(exists("z0"), "@param z0 A matrix of size \\code{(n_lags*n_vars) * n_vars} of initial values of the latent variable.", "") %> 88 | #' <%=ifelse(exists("Z_1"), "@param Z_1 The matrix \\code{Z[1:n_lags,, 1]} (used as initial value).", "") %> 89 | #' <%=ifelse(exists("Z_r1"), "@param Z_r1 The previous draw of \\code{Z} (i.e. \\code{Z[,, r-1]}).", "") %> 90 | 91 | 92 | -------------------------------------------------------------------------------- /man/estimate_mfbvar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{estimate_mfbvar} 4 | \alias{estimate_mfbvar} 5 | \title{Mixed-frequency Bayesian VAR} 6 | \usage{ 7 | estimate_mfbvar(mfbvar_prior = NULL, prior, variance = "iw", ...) 8 | } 9 | \arguments{ 10 | \item{mfbvar_prior}{a \code{mfbvar_prior} object} 11 | 12 | \item{prior}{either \code{"ss"} (steady-state prior), \code{"ssng"} (hierarchical steady-state prior with normal-gamma shrinkage) or \code{"minn"} (Minnesota prior)} 13 | 14 | \item{variance}{form of the error variance-covariance matrix: \code{"iw"} for the inverse Wishart prior, \code{"diffuse"} for a diffuse prior, \code{"csv"} for common stochastic volatility or \code{"fsv"} for factor stochastic volatility} 15 | 16 | \item{...}{additional arguments to \code{update_prior} (if \code{mfbvar_prior} is \code{NULL}, the arguments are passed on to \code{set_prior})} 17 | } 18 | \value{ 19 | An object of class \code{mfbvar}, \code{mfbvar_} and \code{mfbvar__} containing posterior quantities as well as the prior object. For all choices of \code{prior} and \code{variance}, the returned object contains: 20 | \item{Pi}{Array of dynamic coefficient matrices; \code{Pi[,, r]} is the \code{r}th draw} 21 | \item{Z}{Array of monthly processes; \code{Z[,, r]} is the \code{r}th draw} 22 | \item{Z_fcst}{Array of monthly forecasts; \code{Z_fcst[,, r]} is the \code{r}th forecast. The first \code{n_lags} 23 | rows are taken from the data to offer a bridge between observations and forecasts and for computing nowcasts (i.e. with ragged edges).} 24 | \subsection{Steady-state priors}{ 25 | If \code{prior = "ss"}, it also includes: 26 | \describe{\item{\code{psi}}{Matrix of steady-state parameter vectors; \code{psi[r,]} is the \code{r}th draw} 27 | \item{\code{roots}}{The maximum eigenvalue of the lag polynomial (if \code{check_roots = TRUE})}} 28 | 29 | If \code{prior = "ssng"}, it also includes: 30 | \describe{ 31 | \item{\code{psi}}{Matrix of steady-state parameter vectors; \code{psi[r,]} is the \code{r}th draw} 32 | \item{\code{roots}}{The maximum eigenvalue of the lag polynomial (if \code{check_roots = TRUE})} 33 | \item{\code{lambda_psi}}{Vector of draws of the global hyperparameter in the normal-Gamma prior} 34 | \item{\code{phi_psi}}{Vector of draws of the auxiliary hyperparameter in the normal-Gamma prior} 35 | \item{\code{omega_psi}}{Matrix of draws of the prior variances of psi; \code{omega_psi[r, ]} is the \code{r}th draw, where \code{diag(omega_psi[r, ])} is used as the prior covariance matrix for psi}}} 36 | \subsection{Constant error covariances}{ 37 | If \code{variance = "iw"} or \code{variance = "diffuse"}, it also includes: 38 | \describe{\item{\code{Sigma}}{Array of error covariance matrices; \code{Sigma[,, r]} is the \code{r}th draw}}} 39 | \subsection{Time-varying error covariances}{ 40 | If \code{variance = "csv"}, it also includes: 41 | \describe{\item{\code{Sigma}}{Array of error covariance matrices; \code{Sigma[,, r]} is the \code{r}th draw} 42 | \item{\code{phi}}{Vector of AR(1) parameters for the log-volatility regression; \code{phi[r]} is the \code{r}th draw} 43 | \item{\code{sigma}}{Vector of error standard deviations for the log-volatility regression; \code{sigma[r]} is the \code{r}th draw} 44 | \item{\code{f}}{Matrix of log-volatilities; \code{f[r, ]} is the \code{r}th draw}} 45 | 46 | If \code{variance = "fsv"}, it also includes: 47 | \describe{\item{\code{facload}}{Array of factor loadings; \code{facload[,, r]} is the \code{r}th draw} 48 | \item{\code{latent}}{Array of latent log-volatilities; \code{latent[,, r]} is the \code{r}th draw} 49 | \item{\code{mu}}{Matrix of means of the log-volatilities; \code{mu[, r]} is the \code{r}th draw} 50 | \item{\code{phi}}{Matrix of AR(1) parameters for the log-volatilities; \code{phi[, r]} is the \code{r}th draw} 51 | \item{\code{sigma}}{Matrix of innovation variances for the log-volatilities; \code{sigma[, r]} is the \code{r}th draw}}} 52 | } 53 | \description{ 54 | The main function for estimating a mixed-frequency BVAR. 55 | } 56 | \examples{ 57 | prior_obj <- set_prior(Y = mf_usa, n_lags = 4, n_reps = 20) 58 | mod_minn <- estimate_mfbvar(prior_obj, prior = "minn") 59 | } 60 | \references{ 61 | Ankargren, S., Unosson, M., & Yang, Y. (2020) A Flexible Mixed-Frequency Bayesian Vector Autoregression with a Steady-State Prior. \emph{Journal of Time Series Econometrics}, 12(2), \doi{10.1515/jtse-2018-0034}.\cr 62 | Ankargren, S., & Jonéus, P. (2020) Simulation Smoothing for Nowcasting with Large Mixed-Frequency VARs. \emph{Econometrics and Statistics}, \doi{10.1016/j.ecosta.2020.05.007}.\cr 63 | Ankargren, S., & Jonéus, P. (2019) Estimating Large Mixed-Frequency Bayesian VAR Models. arXiv:1912.02231, \url{https://arxiv.org/abs/1912.02231}.\cr 64 | Kastner, G., & Huber, F. (2020) Sparse Bayesian Vector Autoregressions in Huge Dimensions. \emph{Journal of Forecasting}, 39, 1142--1165. \doi{10.1002/for.2680}.\cr 65 | Schorfheide, F., & Song, D. (2015) Real-Time Forecasting With a Mixed-Frequency VAR. \emph{Journal of Business & Economic Statistics}, 33(3), 366--380. \doi{10.1080/07350015.2014.954707}\cr 66 | } 67 | \seealso{ 68 | \code{\link{set_prior}}, \code{\link{update_prior}}, \code{\link{predict.mfbvar}}, \code{\link{plot.mfbvar_minn}}, 69 | \code{\link{plot.mfbvar_ss}}, \code{\link{varplot}}, \code{\link{summary.mfbvar}} 70 | } 71 | -------------------------------------------------------------------------------- /man/interval_to_moments.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interval_to_moments.R 3 | \name{interval_to_moments} 4 | \alias{interval_to_moments} 5 | \title{Interval to moments} 6 | \usage{ 7 | interval_to_moments(prior_psi_int, alpha = 0.05) 8 | } 9 | \arguments{ 10 | \item{prior_psi_int}{Matrix of size \code{(n_determ*n_vars) * 2} with the prior 95 \% prior probability intervals.} 11 | 12 | \item{alpha}{\code{100*(1-alpha)} is the prior probability of the interval} 13 | } 14 | \value{ 15 | A list with two components: 16 | \item{prior_psi_mean}{The prior mean of psi} 17 | \item{prior_psi_Omega}{The prior covariance matrix of psi} 18 | } 19 | \description{ 20 | Convert a matrix of \code{100*(1-alpha)} \% prior probability intervals for the steady states to prior moments. 21 | } 22 | \examples{ 23 | prior_intervals <- matrix(c(0.1, 0.2, 24 | 0.4, 0.6), ncol = 2, byrow = TRUE) 25 | psi_moments <- interval_to_moments(prior_intervals) 26 | } 27 | -------------------------------------------------------------------------------- /man/mdd.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mdd.R 3 | \name{mdd} 4 | \alias{mdd} 5 | \title{Marginal data density estimation} 6 | \usage{ 7 | mdd(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{argument to dispatch on (of class \code{mfbvar_ss} or \code{mfbvar_minn})} 11 | 12 | \item{...}{additional named arguments passed on to the methods} 13 | } 14 | \value{ 15 | The logarithm of the marginal data density. 16 | } 17 | \description{ 18 | \code{mdd} estimates the (log) marginal data density. 19 | } 20 | \details{ 21 | This is a generic function. See the methods for more information. 22 | 23 | The marginal data density is also known as the marginal likelihood. 24 | } 25 | \seealso{ 26 | \code{\link{mdd.mfbvar_ss_iw}}, \code{\link{mdd.mfbvar_minn_iw}} 27 | } 28 | -------------------------------------------------------------------------------- /man/mdd.mfbvar_minn_iw.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mdd.R 3 | \name{mdd.mfbvar_minn_iw} 4 | \alias{mdd.mfbvar_minn_iw} 5 | \title{Marginal data density method for class \code{mfbvar_minn}} 6 | \usage{ 7 | \method{mdd}{mfbvar_minn_iw}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object of class \code{mfbvar_minn}} 11 | 12 | \item{...}{additional arguments (currently only \code{p_trunc} for the degree of truncation is available)} 13 | } 14 | \value{ 15 | The logarithm of the marginal data density. 16 | } 17 | \description{ 18 | Estimate the marginal data density for the model with a Minnesota prior. 19 | } 20 | \details{ 21 | The method used for estimating the marginal data density is the proposal made by 22 | Schorfheide and Song (2015). 23 | } 24 | \references{ 25 | Schorfheide, F., & Song, D. (2015) Real-Time Forecasting With a Mixed-Frequency VAR. \emph{Journal of Business & Economic Statistics}, 33(3), 366--380. \doi{10.1080/07350015.2014.954707} 26 | } 27 | \seealso{ 28 | \code{\link{mdd}}, \code{\link{mdd.mfbvar_ss_iw}} 29 | } 30 | -------------------------------------------------------------------------------- /man/mdd.mfbvar_ss_iw.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mdd.R 3 | \name{mdd.mfbvar_ss_iw} 4 | \alias{mdd.mfbvar_ss_iw} 5 | \title{Marginal data density method for class \code{mfbvar_ss}} 6 | \usage{ 7 | \method{mdd}{mfbvar_ss_iw}(x, method = 1, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object of class \code{mfbvar_ss}} 11 | 12 | \item{method}{option for which method to choose for computing the mdd (\code{1} or \code{2})} 13 | 14 | \item{...}{additional arguments (currently only \code{p_trunc} for the degree of truncation for method 2 is available)} 15 | } 16 | \value{ 17 | The logarithm of the marginal data density. 18 | } 19 | \description{ 20 | Estimate the marginal data density for the model with a steady-state prior. 21 | } 22 | \details{ 23 | Two methods for estimating the marginal data density are implemented. Method 1 and 2 correspond to the two methods proposed by 24 | Fuentes-Albero and Melosi (2013) and Ankargren, Unosson and Yang (2018). 25 | } 26 | \references{ 27 | Fuentes-Albero, C. and Melosi, L. (2013) Methods for Computing Marginal Data Densities from the Gibbs Output. 28 | \emph{Journal of Econometrics}, 175(2), 132-141, \doi{10.1016/j.jeconom.2013.03.002}\cr 29 | 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. 30 | } 31 | \seealso{ 32 | \code{\link{mdd}}, \code{\link{mdd.mfbvar_minn_iw}} 33 | } 34 | -------------------------------------------------------------------------------- /man/mf_sweden.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{mf_sweden} 5 | \alias{mf_sweden} 6 | \title{Real-time data set for Sweden.} 7 | \format{ 8 | A mixed-frequency data set of five Swedish macroeconomic variables. 9 | \describe{ 10 | \item{unemp}{harmonized unemployment rate (source: OECD)} 11 | \item{infl}{inflation rate (source: OECD)} 12 | \item{ip}{industrial production (source: OECD)} 13 | \item{eti}{economic tendency indicator (source: National Institute of Economic Research)} 14 | \item{gdp}{GDP growth (source: Statistics Sweden)} 15 | } 16 | } 17 | \usage{ 18 | mf_sweden 19 | } 20 | \description{ 21 | A dataset containing real-time data for mixed and quarterly frequencies. 22 | } 23 | \references{ 24 | OECD (2016) MEI Archive: Revisions Analysis Dataset.\cr 25 | Billstam, M., Fr\''{a}nd\'{e}n, J., Samuelsson, J., \"{O}sterholm, P. (2016) Quasi-Real-Time Data of the Economic Tendency Survey. Working Paper No. 143, National Institute of Economic Research. 26 | Statistics Sweden (2016) Revisions, expenditure approach and hours worked at each release. 27 | } 28 | \keyword{datasets} 29 | -------------------------------------------------------------------------------- /man/mf_usa.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data.R 3 | \docType{data} 4 | \name{mf_usa} 5 | \alias{mf_usa} 6 | \title{US Macroeconomic Data Set} 7 | \format{ 8 | A list with components: 9 | \describe{ 10 | \item{CPIAUCSL}{inflation rate} 11 | \item{UNRATE}{unemployment rate} 12 | \item{GDPC1}{GDP growth rate} 13 | } 14 | } 15 | \usage{ 16 | mf_usa 17 | } 18 | \description{ 19 | A dataset containing mixed-frequency data from FRED for three US macroeconomic variables. 20 | } 21 | \keyword{datasets} 22 | -------------------------------------------------------------------------------- /man/mfbvar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mfbvar-package.R 3 | \docType{package} 4 | \name{mfbvar} 5 | \alias{mfbvar} 6 | \title{mfbvar: A package for mixed-frequency Bayesian vector autoregressive (VAR) models.} 7 | \description{ 8 | The mfbvar package makes estimation of Bayesian VARs with a mix of monthly and quarterly data 9 | simple. The prior for the regression parameters is normal with Minnesota-style prior moments. 10 | The package supports either an inverse Wishart prior for the error covariance matrix, yielding a 11 | standard normal-inverse Wishart prior, or a time-varying error covariance matrix by means of a factor 12 | stochastic volatility model through the \code{\link[factorstochvol]{factorstochvol-package}} package. 13 | } 14 | \section{Specifying the prior}{ 15 | 16 | The prior of the VAR model is specified using the function \code{\link{set_prior}}. The function 17 | creates a prior object, which can be further updated using \code{\link{update_prior}}. The model can be 18 | estimated using the steady-state prior, which requires the prior moments of the steady-state parameters. 19 | The function \code{\link{interval_to_moments}} is a helper function for obtaining these from prior intervals. 20 | } 21 | 22 | \section{Estimating the model}{ 23 | 24 | The model is estimated using the function \code{\link{estimate_mfbvar}}. The error covariance matrix 25 | is given an inverse Wishart prior or modeled using factor stochastic volatility. If the former is used, 26 | \code{\link{mdd}} can be used to estimate to the marginal data density (marginal likelihood). 27 | } 28 | 29 | \section{Processing the output}{ 30 | 31 | Plots of the output can be obtained from calling the generic function \code{plot} (see 32 | \code{\link{plot-mfbvar}}). If factor stochastic volatility is used, the time-varying 33 | standard deviations can be plotted using \code{\link{varplot}}. Predictions can be obtained 34 | from \code{\link{predict.mfbvar}}. 35 | } 36 | 37 | -------------------------------------------------------------------------------- /man/plot-mfbvar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{plot-mfbvar} 4 | \alias{plot-mfbvar} 5 | \alias{plot.mfbvar_ss} 6 | \alias{plot.mfbvar_ssng} 7 | \alias{plot.mfbvar_minn} 8 | \alias{varplot} 9 | \title{Plotting methods for posterior mfbvar objects} 10 | \usage{ 11 | \method{plot}{mfbvar_ss}( 12 | x, 13 | aggregate_fcst = TRUE, 14 | plot_start = NULL, 15 | pred_bands = 0.8, 16 | nrow_facet = NULL, 17 | ss_bands = 0.95, 18 | ... 19 | ) 20 | 21 | \method{plot}{mfbvar_ssng}( 22 | x, 23 | aggregate_fcst = TRUE, 24 | plot_start = NULL, 25 | pred_bands = 0.8, 26 | nrow_facet = NULL, 27 | ss_bands = 0.95, 28 | ... 29 | ) 30 | 31 | \method{plot}{mfbvar_minn}( 32 | x, 33 | aggregate_fcst = TRUE, 34 | plot_start = NULL, 35 | pred_bands = 0.8, 36 | nrow_facet = NULL, 37 | ... 38 | ) 39 | 40 | varplot(x, variables = colnames(x$Y), var_bands = 0.95, nrow_facet = NULL, ...) 41 | } 42 | \arguments{ 43 | \item{x}{object of class \code{mfbvar_minn} or \code{mfbvar_ss}} 44 | 45 | \item{aggregate_fcst}{Boolean indicating whether forecasts of the latent monthly series should be aggregated to the quarterly frequency.} 46 | 47 | \item{plot_start}{Time period (date or number) to start plotting from. Default is to to use \code{5*n_fcst} time periods if \code{n_fcst} exists, otherwise the entire sample.} 48 | 49 | \item{pred_bands}{Single number (between \code{0.0} and \code{1.0}) giving the coverage level of forecast intervals.} 50 | 51 | \item{nrow_facet}{an integer giving the number of rows to use in the facet} 52 | 53 | \item{ss_bands}{(Steady-state prior only) Single number (between \code{0.0} and \code{1.0}) giving the coverage level of posterior steady-state intervals.} 54 | 55 | \item{...}{Currently not in use.} 56 | 57 | \item{variables}{Vector of names or positions of variables to include in the plot of variances} 58 | 59 | \item{var_bands}{(\code{varplot} only) Single number (between \code{0.0} and \code{1.0}) giving the coverage level of posterior intervals for the error standard deviations.} 60 | } 61 | \value{ 62 | A \code{\link[ggplot2]{ggplot}}. 63 | } 64 | \description{ 65 | Methods for plotting posterior mfbvar objects. 66 | } 67 | \examples{ 68 | prior_obj <- set_prior(Y = mf_usa, d = "intercept", 69 | n_lags = 4, n_reps = 20, 70 | n_fcst = 4, n_fac = 1) 71 | 72 | prior_intervals <- matrix(c(1, 3, 73 | 4, 8, 74 | 1, 3), ncol = 2, byrow = TRUE) 75 | psi_moments <- interval_to_moments(prior_intervals) 76 | prior_psi_mean <- psi_moments$prior_psi_mean 77 | prior_psi_Omega <- psi_moments$prior_psi_Omega 78 | prior_obj <- update_prior(prior_obj, 79 | prior_psi_mean = prior_psi_mean, 80 | prior_psi_Omega = prior_psi_Omega) 81 | 82 | mod_ss <- estimate_mfbvar(prior_obj, prior = "ss", variance = "fsv") 83 | plot(mod_ss) 84 | varplot(mod_ss) 85 | } 86 | -------------------------------------------------------------------------------- /man/plot.mfbvar_prior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{plot.mfbvar_prior} 4 | \alias{plot.mfbvar_prior} 5 | \title{Plot method for class \code{mfbvar_prior}} 6 | \usage{ 7 | \method{plot}{mfbvar_prior}(x, nrow_facet = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object of class \code{mfbvar_prior}} 11 | 12 | \item{nrow_facet}{number of rows in facet} 13 | 14 | \item{...}{Currently not in use.} 15 | } 16 | \value{ 17 | A \code{\link[ggplot2]{ggplot}}. 18 | } 19 | \description{ 20 | Method for plotting \code{mfbvar_prior} objects. 21 | } 22 | \details{ 23 | The function plots the data. If the prior moments for the steady-state parameters are available in \code{x}, these are included. 24 | } 25 | \examples{ 26 | prior_obj <- set_prior(Y = mf_usa, n_lags = 4, n_reps = 20, n_fcst = 4) 27 | plot(prior_obj) 28 | } 29 | -------------------------------------------------------------------------------- /man/predict.mfbvar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{predict.mfbvar} 4 | \alias{predict.mfbvar} 5 | \title{Predict method for class \code{mfbvar}} 6 | \usage{ 7 | \method{predict}{mfbvar}(object, aggregate_fcst = TRUE, pred_bands = 0.8, ...) 8 | } 9 | \arguments{ 10 | \item{object}{object of class mfbvar} 11 | 12 | \item{aggregate_fcst}{If forecasts of quarterly variables should be aggregated back to the quarterly frequency.} 13 | 14 | \item{pred_bands}{The level of the probability bands for the forecasts.} 15 | 16 | \item{...}{Currently not in use.} 17 | } 18 | \value{ 19 | A \code{\link[tibble]{tibble}} with columns: 20 | \describe{\item{\code{variable}}{Name of variable} 21 | \item{\code{time}}{Time index} 22 | \item{\code{fcst_date}}{Date of forecast}} 23 | If the argument \code{pred_bands} is given as a numeric value between 0 and 1, the returned tibble also includes columns: 24 | \describe{\item{\code{lower}}{The \code{(1-pred_bands)/2} lower quantiles of the predictive distributions} 25 | \item{\code{median}}{The medians of the predictive distributions} 26 | \item{\code{upper}}{The \code{(1+pred_bands)/2} upper quantiles of the predictive distributions}} 27 | If \code{pred_bands} \code{NULL} or \code{NA}, the returned tibble also includes the columns: 28 | \describe{\item{\code{fcst}}{MCMC samples from the predictive distributions} 29 | \item{\code{iter}}{Iteration indexes for the MCMC samples}} 30 | } 31 | \description{ 32 | Method for predicting \code{mfbvar} objects. 33 | } 34 | \details{ 35 | Note that this requires that forecasts were made in the original \code{mfbvar} call. 36 | } 37 | \examples{ 38 | prior_obj <- set_prior(Y = mf_usa, n_lags = 4, n_reps = 20, n_fcst = 4) 39 | mod_minn <- estimate_mfbvar(prior_obj, prior = "minn") 40 | predict(mod_minn) 41 | } 42 | -------------------------------------------------------------------------------- /man/print.mfbvar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{print.mfbvar} 4 | \alias{print.mfbvar} 5 | \title{Printing method for class mfbvar} 6 | \usage{ 7 | \method{print}{mfbvar}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{object of class \code{mfbvar}} 11 | 12 | \item{...}{Currently not in use.} 13 | } 14 | \value{ 15 | No return value, called for side effects. 16 | } 17 | \description{ 18 | Method for printing \code{mfbvar} objects. 19 | } 20 | \examples{ 21 | prior_obj <- set_prior(Y = mf_usa, n_lags = 4, n_reps = 20) 22 | mod_minn <- estimate_mfbvar(prior_obj, prior = "minn") 23 | mod_minn 24 | } 25 | -------------------------------------------------------------------------------- /man/print.mfbvar_prior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{print.mfbvar_prior} 4 | \alias{print.mfbvar_prior} 5 | \title{Print method for mfbvar_prior} 6 | \usage{ 7 | \method{print}{mfbvar_prior}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{prior object (class \code{mfbvar_prior})} 11 | 12 | \item{...}{additional arguments (currently unused)} 13 | } 14 | \value{ 15 | No return value, called for side effects. 16 | } 17 | \description{ 18 | Printing method for object of class mfbvar_prior, checking if information 19 | in the prior is sufficient for estimating models. 20 | } 21 | \details{ 22 | The print method checks whether the steady-state and Minnesota 23 | priors can be used with the current specification. This check is minimal in 24 | the sense that it checks only prior elements with no defaults, and it only 25 | checks for estimation and not forecasting (for which the steady-state prior 26 | requires additional information). 27 | } 28 | \examples{ 29 | prior_obj <- set_prior(Y = mf_usa, n_lags = 4, n_reps = 100) 30 | print(prior_obj) 31 | } 32 | \seealso{ 33 | \code{\link{set_prior}}, \code{\link{update_prior}}, \code{\link{estimate_mfbvar}}, \code{\link{summary.mfbvar_prior}} 34 | } 35 | -------------------------------------------------------------------------------- /man/set_prior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{set_prior} 4 | \alias{set_prior} 5 | \alias{update_prior} 6 | \title{Set priors for mfbvar} 7 | \usage{ 8 | set_prior( 9 | Y, 10 | aggregation = "average", 11 | prior_Pi_AR1 = 0, 12 | lambda1 = 0.2, 13 | lambda2 = 0.5, 14 | lambda3 = 1, 15 | lambda4 = 10000, 16 | block_exo = NULL, 17 | n_lags, 18 | n_fcst = 0, 19 | n_thin = 1, 20 | n_reps, 21 | n_burnin = n_reps, 22 | freq = NULL, 23 | d = NULL, 24 | d_fcst = NULL, 25 | prior_psi_mean = NULL, 26 | prior_psi_Omega = NULL, 27 | check_roots = FALSE, 28 | s = -1000, 29 | prior_ng = c(0.01, 0.01), 30 | prior_phi = c(0.9, 0.1), 31 | prior_sigma2 = c(0.01, 4), 32 | n_fac = NULL, 33 | n_cores = 1, 34 | verbose = FALSE, 35 | ... 36 | ) 37 | 38 | update_prior(prior_obj, ...) 39 | } 40 | \arguments{ 41 | \item{Y}{data input. For monthly-quarterly data, should be a list with components containing regularly spaced time series (that inherit from \code{ts} or \code{zooreg}). If a component contains a single time series, the component itself must be named. If a component contains multiple time series, each time series must be named. Monthly variables can only contain missing values at the end of the sample, and should precede quarterly variables in the list. Matrices in which quarterly variables are padded with \code{NA} and observations stored at the end of each quarter are also accepted, but then the frequency of each variable must be given in the argument \code{freq}. Weekly-monthly mixes can be provided using the matrix way, see examples.} 42 | 43 | \item{aggregation}{the aggregation scheme used for relating latent high-frequency series to their low-frequency observations. The default is \code{"average"} for averaging within each low-frequency period (e.g., quarterly observations are averages of the constituent monthly observations). The alternative \code{"triangular"} can be used for monthly-quarterly mixes, and uses the Mariano-Murasawa triangular set of weights. See details for more information.} 44 | 45 | \item{prior_Pi_AR1}{The prior means for the AR(1) coefficients.} 46 | 47 | \item{lambda1}{The overall tightness.} 48 | 49 | \item{lambda2}{(Only if \code{variance} is one of \code{c("diffuse", "fsv")} The cross-variable tightness} 50 | 51 | \item{lambda3}{The tightness of the intercept prior variance.} 52 | 53 | \item{lambda4}{(Minnesota only) Prior variance of the intercept.} 54 | 55 | \item{block_exo}{(Only if \code{variance} is one of \code{c("diffuse", "fsv")}) Vector of indexes/names of variables to be treated as block exogenous} 56 | 57 | \item{n_lags}{The number of lags.} 58 | 59 | \item{n_fcst}{The number of periods to forecast.} 60 | 61 | \item{n_thin}{Store every \code{n_thin}th draw} 62 | 63 | \item{n_reps}{The number of replications.} 64 | 65 | \item{n_burnin}{The number of burn-in replications.} 66 | 67 | \item{freq}{(Only used if \code{Y} is a matrix) Character vector with elements 'm' (monthly) or 'q' (quarterly) for sampling frequency. Monthly variables must precede all quarterly variables.} 68 | 69 | \item{d}{(Steady state only) Either a matrix with same number of rows as \code{Y} and \code{n_determ} number of columns containing the deterministic terms or a string \code{"intercept"} for requesting an intercept as the only deterministic 70 | term.} 71 | 72 | \item{d_fcst}{(Steady state only) The deterministic terms for the forecasting period (not used if \code{d = "intercept"}).} 73 | 74 | \item{prior_psi_mean}{(Steady state only) Vector of length \code{n_determ*n_vars} with the prior means of the steady-state parameters.} 75 | 76 | \item{prior_psi_Omega}{(Steady state only) Matrix of size \code{(n_determ*n_vars) * (n_determ*n_vars)} with the prior covariance of the steady-state parameters.#'} 77 | 78 | \item{check_roots}{Logical, if roots of the companion matrix are to be checked to ensure stationarity.} 79 | 80 | \item{s}{(Hierarchical steady state only) scalar giving the tuning parameter for the Metropolis-Hastings proposal for the kurtosis parameter. If \code{s < 0}, then adaptive Metropolis-Hastings targeting an acceptance rate of 0.44 is used, where the scaling factor is restricted to the interval \code{[-abs(s), abs(s)]}} 81 | 82 | \item{prior_ng}{(Hierarchical steady state only) vector with two elements giving the parameters \code{c(c0, c1)} of the hyperprior for the global shrinkage parameter} 83 | 84 | \item{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} 85 | 86 | \item{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} 87 | 88 | \item{n_fac}{(Only used with factor stochastic volatility) Number of factors to use for the factor stochastic volatility model} 89 | 90 | \item{n_cores}{(Only used with factor stochastic volatility) Number of cores to use for drawing regression parameters in parallel} 91 | 92 | \item{verbose}{Logical, if progress should be printed to the console.} 93 | 94 | \item{...}{(Only used with factor stochastic volatility) Arguments to pass along to \code{\link[factorstochvol]{fsvsample}}. See details.} 95 | 96 | \item{prior_obj}{an object of class \code{mfbvar_prior}} 97 | } 98 | \value{ 99 | An object of class \code{mfbvar_prior} that is used as input to \code{estimate_mfbvar}. 100 | } 101 | \description{ 102 | The function creates an object storing all information needed for estimating a mixed-frequency BVAR. The object includes data as well as details for the model and its priors. 103 | } 104 | \details{ 105 | Some support is provided for single-frequency data sets, where \code{Y} contains variables sampled with the same frequency. 106 | 107 | The aggregation weights that can be used for \code{aggregation} are intra-quarterly averages (\code{aggregation = "average"}), where the quarterly observations \eqn{y_{q,t}} are assumed to relate to the underlying monthly series \eqn{z_{q,,t}} through: 108 | \deqn{y_{q,t} = \frac{1}{3}(z_{q,,t} + z_{q,,t-1} + z_{q,, t-2})} 109 | 110 | If \code{aggregation = "triangular"}, then instead 111 | \deqn{y_{q,t} = \frac{1}{9}(z_{q,,t} + 2z_{q,,t-1} + 3z_{q,, t-2}) + 2z_{q,, t-3}) + z_{q,, t-4})} 112 | 113 | The latter is typically used when modeling growth rates, and the former when working with log-levels. 114 | 115 | If the steady-state prior is to be used, the deterministic matrix needs to be supplied, or a string indicating that the intercept should be the only deterministic term (\code{d = "intercept"}). If the latter, \code{d_fcst} is automatically set to be intercept only. Otherwise, if forecasts are requested 116 | (\code{n_fcst > 0}) also \code{d_fcst} must be provided. Finally, the prior means of the steady-state parameters must (at the very minimum) also be 117 | provided in \code{prior_psi_mean}. The steady-state prior involves inverting the lag polynomial. For this reason, draws in which the largest eigenvalue 118 | (in absolute value) of the lag polynomial is greater than 1 are discarded and new draws are made if \code{check_roots = TRUE}. The maximum number of 119 | attempts is 1,000. 120 | 121 | For modeling stochastic volatility by the factor stochastic volatility model, the number of factors to use must be supplied. Further arguments can be passed along, but are not included as formal arguments. If the default settings are not overriden, the defaults used are as follows (see \code{\link[factorstochvol]{fsvsample}} for descriptions): 122 | \itemize{ 123 | \item{\code{priormu}}{\code{ = c(0, 10)}} 124 | \item{\code{priorphiidi}}{\code{ = c(10, 3)}} 125 | \item{\code{priorphifac}}{\code{ = c(10, 3)}} 126 | \item{\code{priorsigmaidi}}{\code{ = 1}} 127 | \item{\code{priorsigmafac}}{\code{ = 1}} 128 | \item{\code{priorfacload}}{\code{ = 1}} 129 | \item{\code{restrict}}{\code{ = "none"}} 130 | } 131 | 132 | The function \code{update_prior} can be used to update an existing prior object. See the examples. 133 | } 134 | \examples{ 135 | # Standard list-based way 136 | prior_obj <- set_prior(Y = mf_usa, n_lags = 4, n_reps = 100) 137 | prior_obj <- update_prior(prior_obj, n_fcst = 4) 138 | 139 | # Weekly-monthly mix of data, four weeks per month 140 | Y <- matrix(rnorm(400), 100, 4) 141 | Y[setdiff(1:100,seq(4, 100, by = 4)), 4] <- NA 142 | prior_obj <- set_prior(Y = Y, freq = c(rep("w", 3), "m"), 143 | n_lags = 4, n_reps = 10) 144 | } 145 | \seealso{ 146 | \code{\link{estimate_mfbvar}}, \code{\link{update_prior}}, \code{\link{interval_to_moments}}, \code{\link{print.mfbvar_prior}}, \code{\link{summary.mfbvar_prior}}, \code{\link[factorstochvol]{fsvsample}} 147 | } 148 | -------------------------------------------------------------------------------- /man/summary.mfbvar.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{summary.mfbvar} 4 | \alias{summary.mfbvar} 5 | \title{Summary method for class mfbvar} 6 | \usage{ 7 | \method{summary}{mfbvar}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{object of class \code{mfbvar}} 11 | 12 | \item{...}{Currently not in use.} 13 | } 14 | \description{ 15 | Method for summarizing \code{mfbvar} objects. 16 | } 17 | \examples{ 18 | prior_obj <- set_prior(Y = mf_usa, n_lags = 4, n_reps = 20) 19 | mod_minn <- estimate_mfbvar(prior_obj, prior = "minn") 20 | summary(mod_minn) 21 | } 22 | -------------------------------------------------------------------------------- /man/summary.mfbvar_prior.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/interface.R 3 | \name{summary.mfbvar_prior} 4 | \alias{summary.mfbvar_prior} 5 | \title{Summary method for mfbvar_prior} 6 | \usage{ 7 | \method{summary}{mfbvar_prior}(object, ...) 8 | } 9 | \arguments{ 10 | \item{object}{prior object (class \code{mfbvar_prior})} 11 | 12 | \item{...}{additional arguments (currently unused)} 13 | } 14 | \description{ 15 | summary method for object of class mfbvar_prior, showing some basic 16 | information regarding the contents of the prior. 17 | } 18 | \examples{ 19 | prior_obj <- set_prior(Y = mf_usa, n_lags = 4, n_reps = 100) 20 | summary(prior_obj) 21 | } 22 | \seealso{ 23 | \code{\link{set_prior}}, \code{\link{update_prior}}, \code{\link{estimate_mfbvar}}, \code{\link{print.mfbvar_prior}} 24 | } 25 | -------------------------------------------------------------------------------- /src/Makevars.in: -------------------------------------------------------------------------------- 1 | CXX_STD = CXX11 2 | PKG_CXXFLAGS = @OPENMP_FLAG@ -I../inst/include 3 | PKG_LIBS= @OPENMP_FLAG@ $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 4 | PKG_LIBS += $(shell ${R_HOME}/bin/Rscript -e "RcppParallel::RcppParallelLibs()") 5 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | CXX_STD = CXX11 2 | PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) -I../inst/include 3 | PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 4 | PKG_CXXFLAGS += -DRCPP_PARALLEL_USE_TBB=1 5 | PKG_LIBS += $(shell "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" \ 6 | -e "RcppParallel::RcppParallelLibs()") 7 | -------------------------------------------------------------------------------- /src/auxmix.cpp: -------------------------------------------------------------------------------- 1 | // Copyright of original code: Gregor Kastner (stochvol package) 2 | // Copyright of modified code: Sebastian Ankargren (mfbvar package) 3 | // The following code is a derivative work of the code 4 | // developed by Gregor Kastner for the stochvol package, which 5 | // is licensed GPL>=2. This code is therefore licensed under 6 | // the terms of the GNU Public License, version 3. 7 | 8 | 9 | #include 10 | #include "auxmix.h" 11 | 12 | using namespace Rcpp; 13 | 14 | // Non-normalized posterior probabilities 15 | void findMixprobs( 16 | arma::vec& mixprob, 17 | const arma::vec& datanorm) { 18 | int T = datanorm.size(); 19 | int tmp; 20 | for (int c = 0; c < T; c++) { // SLOW (10*T calls to exp)! 21 | tmp = 10*c; 22 | for (int r = 0; r < 10; r++) { 23 | mixprob[tmp+r] = exp(mix_pre[r]-(datanorm[c]-mix_mean[r])*(datanorm[c]-mix_mean[r])*mix_2varinv[r]); 24 | } 25 | } 26 | } 27 | 28 | // Cumulative sum over columns of a matrix 29 | void colCumsums( 30 | arma::vec& x, 31 | int const nrow, 32 | int const ncol) { 33 | int tmp; 34 | for (int c = 0; c < ncol; c++) { 35 | tmp = c*nrow; 36 | for (int r = 1; r < nrow; r++) { 37 | x[tmp+r] = x[tmp+r-1] + x[tmp+r]; 38 | } 39 | } 40 | } 41 | 42 | // Combines findMixprobs() and colCumsums() (see above) into one function 43 | void findMixCDF( 44 | arma::vec& mixprob, 45 | const arma::vec& datanorm) { 46 | int T = datanorm.size(); 47 | int tmp; 48 | for (int c = 0; c < T; c++) { // SLOW (10*T calls to exp)! 49 | tmp = 10*c; 50 | mixprob[tmp] = exp(mix_pre[0]-(datanorm[c]-mix_mean[0])*(datanorm[c]-mix_mean[0])*mix_2varinv[0]); 51 | for (int r = 1; r < 10; r++) { 52 | mixprob[tmp+r] = mixprob[tmp+r-1] + exp(mix_pre[r]-(datanorm[c]-mix_mean[r])*(datanorm[c]-mix_mean[r])*mix_2varinv[r]); 53 | } 54 | } 55 | } 56 | 57 | void invTransformSampling( 58 | const arma::vec& mixprob, 59 | arma::ivec& r, 60 | int T) { 61 | int index; 62 | arma::vec innov = runif(T); 63 | double temp; 64 | bool larger, smaller; 65 | for (int j = 0; j < T; j++) { 66 | index = (10-1)/2; // start searching in the middle 67 | temp = innov[j]*mixprob[9 + 10*j]; // current (non-normalized) value 68 | larger = false; // indicates that we already went up 69 | smaller = false; // indicates that we already went down 70 | while(true) { 71 | if (temp > mixprob[index + 10*j]) { 72 | if (smaller == true) { 73 | index++; 74 | break; 75 | } 76 | else { 77 | index++; 78 | larger = true; 79 | } 80 | } 81 | else { 82 | if (larger == true) { 83 | break; 84 | } 85 | else { 86 | if (index == 0) { 87 | break; 88 | } 89 | else { 90 | index--; 91 | smaller = true; 92 | } 93 | } 94 | } 95 | } 96 | r[j] = index; 97 | } 98 | } 99 | -------------------------------------------------------------------------------- /src/builders.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | 3 | //' @describeIn build_U Build the U matrix (C++ implementation) 4 | //' @templateVar n_vars TRUE 5 | //' @templateVar n_lags TRUE 6 | //' @keywords internal 7 | //' @noRd 8 | //' @template man_template 9 | // [[Rcpp::export]] 10 | arma::mat build_U_cpp(const arma::mat & Pi, int n_determ, int n_vars, int n_lags){ 11 | arma::mat U(n_vars*n_determ*(n_lags+1), n_vars*n_determ, arma::fill::zeros); 12 | int pm = n_determ*n_vars; 13 | for(int i = 0; i < pm; i++){ 14 | U(i,i) = 1; 15 | } 16 | 17 | for(int i = 0; i < n_lags; i++){ 18 | for (int j = 0; j < n_determ; j++) { 19 | U(arma::span((i+1)*pm + j*n_vars,(i+1)*pm + (j+1)*n_vars-1), arma::span(j*n_vars, (j+1)*n_vars-1)) = Pi.cols(i * n_vars, (i+1)*n_vars - 1); 20 | } 21 | } 22 | 23 | return(U); 24 | 25 | } 26 | 27 | // [[Rcpp::export]] 28 | arma::mat create_X(const arma::mat & y, arma::uword k) { 29 | arma::uword TT = y.n_rows - k; 30 | arma::uword n = y.n_cols; 31 | arma::mat X = arma::mat(TT, n*k + 1, arma::fill::ones); 32 | 33 | for (arma::uword i = 0; i < k; i++) { 34 | X.cols(i*n+1,(i+1)*n) = y.rows(k-i-1, TT + k - 2 - i); 35 | } 36 | return X; 37 | } 38 | 39 | // [[Rcpp::export]] 40 | arma::mat create_X_noint(const arma::mat & y, arma::uword k) { 41 | arma::uword TT = y.n_rows - k; 42 | arma::uword n = y.n_cols; 43 | arma::mat X = arma::mat(TT, n*k, arma::fill::zeros); 44 | 45 | for (arma::uword i = 0; i < k; i++) { 46 | X.cols(i*n,(i+1)*n-1) = y.rows(k-i-1, TT + k - 2 - i); 47 | } 48 | return X; 49 | } 50 | 51 | // [[Rcpp::export]] 52 | arma::mat create_X_t(const arma::mat & y) { 53 | arma::uword np = y.n_elem; 54 | arma::mat X = arma::mat(np+1, 1, arma::fill::ones); 55 | X.rows(1, np) = arma::reshape(arma::trans(arma::flipud(y)), np, 1); 56 | return X; 57 | } 58 | 59 | // [[Rcpp::export]] 60 | arma::mat create_X_t_noint(const arma::mat & y) { 61 | arma::uword np = y.n_elem; 62 | arma::mat X = arma::reshape(arma::trans(arma::flipud(y)), np, 1); 63 | return X; 64 | } 65 | -------------------------------------------------------------------------------- /src/dl_reg.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | #include "update_dl.h" 3 | // [[Rcpp::export]] 4 | void dl_reg(const arma::mat & y, arma::mat & x, arma::mat & beta, 5 | arma::mat & aux, arma::vec & global, arma::mat & local, 6 | arma::mat & prior_Pi_Omega, arma::uword n_reps, 7 | const double a, bool gig) { 8 | 9 | arma::mat eps = arma::mat(x.n_cols, 1); 10 | arma::mat beta_i = beta.row(0).t(); 11 | 12 | double global_i = global(0); 13 | arma::vec aux_i = aux.row(0).t(); 14 | arma::vec local_i = local.row(0).t(); 15 | arma::vec slice = arma::vec(local_i.n_elem).fill(1.0); 16 | 17 | arma::mat Sigma, Sigma_inv, L; 18 | arma::vec mu; 19 | arma::uword n_lags = x.n_cols; 20 | 21 | for (arma::uword i = 0; i < n_reps; ++i) { 22 | 23 | eps.imbue(norm_rand); 24 | Sigma = x.t() * x; 25 | Sigma.diag() += 1/prior_Pi_Omega; 26 | Sigma_inv = arma::inv_sympd(Sigma); 27 | L = arma::chol(Sigma_inv, "lower"); 28 | mu = Sigma_inv * x.t() * y; 29 | beta_i.col(0) = mu + L * eps; 30 | 31 | //beta_i.col(0) = mvn_rue(x, prior_Pi_Omega, y); 32 | beta.row(i) = beta_i.col(0).t(); 33 | update_dl(prior_Pi_Omega, aux_i, local_i, global_i, beta_i, 1, n_lags, a, slice, gig, false); 34 | global(i) = global_i; 35 | aux.row(i) = aux_i.t(); 36 | local.row(i) = local_i.t(); 37 | } 38 | 39 | } 40 | -------------------------------------------------------------------------------- /src/max_eig_cpp.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | 3 | // [[Rcpp::depends(RcppArmadillo)]] 4 | 5 | //' @title Find maximum eigenvalue 6 | //' 7 | //' @description The function computes the maximum eigenvalue. 8 | //' @aliases max_eig max_eig_cpp 9 | //' @templateVar A TRUE 10 | //' @template man_template 11 | //' @keywords internal 12 | //' @noRd 13 | //' @return The maximum eigenvalue. 14 | // [[Rcpp::export]] 15 | double max_eig_cpp(const arma::mat & A) { 16 | arma::cx_vec eigval = arma::eig_gen(A); 17 | return max(abs(eigval)); 18 | } 19 | -------------------------------------------------------------------------------- /src/mcmc_iw.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | #include "minn_utils.h" 3 | #include "ss_utils.h" 4 | #include "update_ng.h" 5 | // [[Rcpp::export]] 6 | void mcmc_minn_iw(const arma::mat & y_in_p, 7 | arma::cube& Pi, arma::cube& Sigma, arma::cube& Z, arma::cube& Z_fcst, 8 | const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, 9 | const arma::mat& inv_prior_Pi_Omega, 10 | const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, 11 | const arma::mat & prior_S, const arma::mat& Z_1, 12 | arma::uword n_reps, arma::uword n_burnin, 13 | arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, 14 | arma::uword n_T, arma::uword n_fcst, 15 | arma::uword n_thin, bool verbose, int prior_nu) { 16 | bool single_freq; 17 | if (n_q == 0 || n_q == n_vars) { 18 | single_freq = true; 19 | } else { 20 | single_freq = false; 21 | } 22 | 23 | 24 | Progress p(n_reps+n_burnin, verbose); 25 | arma::mat Pi_i = Pi.slice(0); 26 | arma::mat Sigma_i = Sigma.slice(0); 27 | arma::mat y_i = y_in_p; 28 | arma::vec errors = arma::vec(n_vars); 29 | arma::mat X, XX, XX_inv, Pi_sample, post_Pi_Omega, post_Pi; 30 | arma::mat S, Pi_diff, post_S, Sigma_chol, x; 31 | arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); 32 | arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); 33 | Z_i.rows(0, n_lags - 1) = Z_1; 34 | int post_nu = n_T + n_vars + prior_nu; 35 | 36 | if (single_freq) { 37 | Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; 38 | X = create_X(Z_i, n_lags); 39 | XX = X.t() * X; 40 | XX_inv = arma::inv_sympd(XX); 41 | Pi_sample = XX_inv * (X.t() * y_i); 42 | post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); 43 | post_Pi = post_Pi_Omega * (Omega_Pi + X.t() * y_i); 44 | S = arma::trans((y_i - X * Pi_sample)) * (y_i - X * Pi_sample); 45 | Pi_diff = prior_Pi_mean - Pi_sample; 46 | post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; 47 | } 48 | 49 | Sigma_chol = arma::chol(Sigma_i, "lower"); 50 | 51 | for (arma::uword i = 0; i < n_reps + n_burnin; ++i) { 52 | if (!single_freq) { 53 | y_i = simsm_adaptive_cv(y_in_p, Pi_i, Sigma_chol, Lambda_comp, Z_1, n_q, T_b); 54 | Z_i.rows(n_lags, n_T + n_lags - 1) = y_i; 55 | X = create_X(Z_i, n_lags); 56 | XX = X.t() * X; 57 | XX_inv = arma::inv_sympd(XX); 58 | Pi_sample = XX_inv * (X.t() * y_i); 59 | post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); 60 | post_Pi = post_Pi_Omega * (Omega_Pi + X.t() * y_i); 61 | S = arma::trans((y_i - X * Pi_sample)) * (y_i - X * Pi_sample); 62 | Pi_diff = prior_Pi_mean - Pi_sample; 63 | post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; 64 | } 65 | Sigma_i = rinvwish(post_nu, post_S); 66 | Sigma_chol = arma::chol(Sigma_i, "lower"); 67 | Pi_i = rmatn(post_Pi.t(), post_Pi_Omega, Sigma_i); 68 | 69 | if ((i+1) % n_thin == 0 && i >= n_burnin) { 70 | if (n_fcst > 0) { 71 | 72 | Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t(); 73 | for (arma::uword h = 0; h < n_fcst; ++h) { 74 | errors.imbue(norm_rand); 75 | x = create_X_t(Z_fcst_i.cols(0+h, n_lags-1+h).t()); 76 | Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; 77 | } 78 | Z_fcst.slice((i-n_burnin)/n_thin) = Z_fcst_i.t(); 79 | } 80 | 81 | Z.slice((i-n_burnin)/n_thin) = Z_i; 82 | Sigma.slice((i-n_burnin)/n_thin) = Sigma_i; 83 | Pi.slice((i-n_burnin)/n_thin) = Pi_i; 84 | } 85 | if (verbose) { 86 | p.increment(); 87 | } 88 | } 89 | 90 | } 91 | 92 | // [[Rcpp::export]] 93 | void mcmc_ssng_iw(const arma::mat & y_in_p, 94 | arma::cube& Pi, arma::cube& Sigma, arma::mat& psi, arma::vec& phi_mu, 95 | arma::vec& lambda_mu, arma::mat& omega, arma::cube& Z, 96 | arma::cube& Z_fcst, const arma::mat& Lambda_comp, const arma::mat& prior_Pi_Omega, 97 | const arma::mat& inv_prior_Pi_Omega, 98 | const arma::mat& Omega_Pi, const arma::mat& prior_Pi_mean, 99 | const arma::mat & prior_S, 100 | const arma::mat & D_mat, const arma::mat & dt, const arma::mat & d1, 101 | const arma::mat & d_fcst_lags, const arma::vec& prior_psi_mean, 102 | double c0, double c1, double s, 103 | bool check_roots, const arma::mat& Z_1, arma::uword n_reps, arma::uword n_burnin, 104 | arma::uword n_q, arma::uword T_b, arma::uword n_lags, arma::uword n_vars, 105 | arma::uword n_T, arma::uword n_fcst, arma::uword n_determ, 106 | arma::uword n_thin, bool verbose, bool ssng) { 107 | bool single_freq; 108 | if (n_q == 0 || n_q == n_vars) { 109 | single_freq = true; 110 | } else { 111 | single_freq = false; 112 | } 113 | 114 | Progress p(n_reps+n_burnin, verbose); 115 | 116 | arma::mat Pi_i = Pi.slice(0); 117 | arma::mat Sigma_i = Sigma.slice(0); 118 | arma::vec psi_i = psi.row(0).t(); 119 | arma::mat y_i, X, XX, XX_inv, Pi_sample, post_Pi_Omega, post_Pi; 120 | arma::mat S, Pi_diff, post_S, x, mu_mat, mZ, mZ1, mX; 121 | arma::mat my = arma::mat(arma::size(y_in_p), arma::fill::zeros); 122 | 123 | arma::mat Z_i = arma::mat(n_lags + y_in_p.n_rows, n_vars, arma::fill::zeros); 124 | arma::mat Z_fcst_i = arma::mat(n_vars, n_lags + n_fcst); 125 | arma::mat Z_i_demean = Z_i; 126 | Z_i.rows(0, n_lags - 1) = Z_1; 127 | 128 | arma::mat Pi_i0 = arma::mat(n_vars, n_vars*n_lags+1, arma::fill::zeros); 129 | arma::mat Pi_comp = arma::mat(n_vars*n_lags, n_vars*n_lags, arma::fill::zeros); 130 | 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)); 131 | 132 | arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ, false, true); 133 | mu_mat = dt * Psi_i.t(); 134 | arma::uword n_Lambda = Lambda_comp.n_cols/Lambda_comp.n_rows; 135 | arma::mat mu_long = arma::mat(n_Lambda+n_T, n_vars, arma::fill::zeros); 136 | arma::rowvec Lambda_single = arma::rowvec(n_Lambda, arma::fill::zeros); 137 | for (arma::uword i = 0; i < n_Lambda; ++i) { 138 | Lambda_single(i) = Lambda_comp.at(0, i*n_q); 139 | } 140 | 141 | int post_nu = n_T + n_vars + 2; 142 | arma::mat Sigma_chol = arma::chol(Sigma_i, "lower"); 143 | 144 | arma::uword nm = n_vars*n_determ; 145 | double lambda_mu_i = lambda_mu(0); 146 | double phi_mu_i = phi_mu(0); 147 | arma::vec omega_i = omega.row(0).t(); 148 | arma::mat inv_prior_psi_Omega = arma::diagmat(1.0/omega_i); 149 | arma::vec inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; 150 | double M, batch = 1.0; 151 | arma::running_stat stats; 152 | double accept = 0.0; 153 | bool adaptive_mh = false; 154 | double s_prop; 155 | if (s < 0) { 156 | M = std::abs(s); 157 | s = 1.0; 158 | adaptive_mh = true; 159 | } 160 | arma::vec min_vec(2); 161 | min_vec(0) = 0.01; 162 | 163 | // if single freq, we don't need to update 164 | if (single_freq) { 165 | Z_i.rows(n_lags, n_T + n_lags - 1) = y_in_p; 166 | } 167 | for (arma::uword i = 0; i < n_reps + n_burnin; ++i) { 168 | 169 | if (!single_freq) { 170 | update_demean(my, mu_long, y_in_p, mu_mat, d1, Psi_i, Lambda_single, n_vars, 171 | n_q, n_Lambda, n_T); 172 | } else { 173 | // Even if single freq, mZ needs to be updated 174 | mZ = y_in_p - mu_mat; 175 | } 176 | 177 | mZ1 = Z_1 - d1 * Psi_i.t(); 178 | Pi_i0.cols(1, n_vars*n_lags) = Pi_i; 179 | 180 | if (!single_freq) { 181 | mZ = simsm_adaptive_cv(my, Pi_i0, Sigma_chol, Lambda_comp, mZ1, n_q, T_b); 182 | Z_i.rows(n_lags, n_T + n_lags - 1) = mZ + mu_mat; 183 | } 184 | 185 | Z_i_demean.rows(0, n_lags - 1) = mZ1; 186 | Z_i_demean.rows(n_lags, n_T + n_lags - 1) = mZ; 187 | 188 | mX = create_X_noint(Z_i_demean, n_lags); 189 | XX = mX.t() * mX; 190 | XX_inv = arma::inv_sympd(XX); 191 | Pi_sample = XX_inv * (mX.t() * mZ); 192 | 193 | post_Pi_Omega = arma::inv_sympd(inv_prior_Pi_Omega + XX); 194 | post_Pi = post_Pi_Omega * (Omega_Pi + mX.t() * mZ); 195 | S = arma::trans((mZ - mX * Pi_sample)) * (mZ - mX * Pi_sample); 196 | Pi_diff = prior_Pi_mean - Pi_sample; 197 | post_S = prior_S + S + Pi_diff.t() * arma::inv_sympd(prior_Pi_Omega + XX_inv) * Pi_diff; 198 | Sigma_i = rinvwish(post_nu, arma::symmatu(post_S)); //Fixed in 9.400.3 199 | Sigma_chol = arma::chol(Sigma_i, "lower"); 200 | bool stationarity_check = false; 201 | int num_try = 0, iter = 0; 202 | double root = 1000; 203 | while (stationarity_check == false) { 204 | iter += 1; 205 | Pi_i = rmatn(post_Pi.t(), post_Pi_Omega, Sigma_i); 206 | if (check_roots) { 207 | Pi_comp.rows(0, n_vars-1) = Pi_i; 208 | root = max_eig_cpp(Pi_comp); 209 | } else { 210 | root = 0.0; 211 | } 212 | if (root < 1.0) { 213 | stationarity_check = true; 214 | num_try = iter; 215 | } 216 | if (iter == 1000) { 217 | Rcpp::stop("Attemped to draw stationary Pi 1,000 times."); 218 | } 219 | } 220 | 221 | if (ssng) { 222 | update_ng(phi_mu_i, lambda_mu_i, omega_i, nm, c0, c1, s, psi_i, prior_psi_mean, accept); 223 | if (adaptive_mh) { 224 | stats(accept); 225 | if (i % 100 == 0) { 226 | batch += 1.0; 227 | min_vec(1) = std::pow(batch, -0.5); 228 | if (stats.mean() > 0.44) { 229 | s_prop = log(s) + arma::min(min_vec); 230 | if (s_prop < M){ 231 | s = std::exp(s_prop); 232 | } 233 | } else { 234 | s_prop = log(s) - arma::min(min_vec); 235 | if (s_prop > -M){ 236 | s = std::exp(s_prop); 237 | } 238 | } 239 | stats.reset(); 240 | } 241 | } 242 | 243 | inv_prior_psi_Omega = arma::diagmat(1.0/omega_i); 244 | inv_prior_psi_Omega_mean = prior_psi_mean / omega_i; 245 | } 246 | 247 | 248 | X = create_X_noint(Z_i, n_lags); 249 | 250 | 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); 251 | arma::vec errors = arma::vec(n_vars); 252 | if ((i+1) % n_thin == 0 && i>=n_burnin) { 253 | if (n_fcst > 0) { 254 | Z_fcst_i.head_cols(n_lags) = Z_i.tail_rows(n_lags).t() - mu_mat.tail_rows(n_lags).t(); 255 | for (arma::uword h = 0; h < n_fcst; ++h) { 256 | 257 | errors.imbue(norm_rand); 258 | x = create_X_t_noint(Z_fcst_i.cols(0+h, n_lags-1+h).t()); 259 | Z_fcst_i.col(n_lags + h) = Pi_i * x + Sigma_chol * errors; 260 | } 261 | Z_fcst.slice((i-n_burnin)/n_thin) = Z_fcst_i.t() + d_fcst_lags * Psi_i.t(); 262 | } 263 | Z.slice((i-n_burnin)/n_thin) = Z_i; 264 | Sigma.slice((i-n_burnin)/n_thin) = Sigma_i; 265 | Pi.slice((i-n_burnin)/n_thin) = Pi_i; 266 | psi.row((i-n_burnin)/n_thin) = psi_i.t(); 267 | if (ssng) { 268 | phi_mu((i-n_burnin)/n_thin) = phi_mu_i; 269 | lambda_mu((i-n_burnin)/n_thin) = lambda_mu_i; 270 | omega.row((i-n_burnin)/n_thin) = omega_i.t(); 271 | } 272 | 273 | } 274 | if (verbose) { 275 | p.increment(); 276 | } 277 | } 278 | 279 | } 280 | 281 | -------------------------------------------------------------------------------- /src/minn_utils.h: -------------------------------------------------------------------------------- 1 | #ifndef _MINN_UTILS_H_ 2 | #define _MINN_UTILS_H_ 3 | arma::mat create_X_t(const arma::mat & y); 4 | arma::mat create_X(const arma::mat & y, arma::uword k); 5 | #endif 6 | -------------------------------------------------------------------------------- /src/mvn_par.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "mvn.h" 4 | #include "mvn_par.h" 5 | 6 | Pi_parallel_rue::Pi_parallel_rue(arma::mat & output, 7 | const arma::mat & y, 8 | const arma::mat & X, 9 | const arma::mat & d, 10 | const arma::mat & eps, 11 | const arma::mat & volatility, 12 | const arma::mat & prior_AR1, 13 | const arma::uword T, 14 | const arma::uword n, 15 | 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) {}; 16 | 17 | void Pi_parallel_rue::operator()(std::size_t begin, std::size_t end) { 18 | for (std::size_t i = begin; i < end; i++) 19 | { 20 | arma::vec h_j = arma::exp(-0.5 * volatility.col(i)); 21 | arma::mat X_j = X.each_col() % h_j; 22 | arma::vec y_j = y.col(i) % h_j; 23 | arma::vec eps_i = eps.unsafe_col(i); 24 | arma::vec d_i = d.unsafe_col(i); 25 | output.col(i) = mvn_rue_eps(X_j, d_i, y_j, eps_i, prior_AR1(i), i); 26 | } 27 | } 28 | 29 | Pi_parallel_bcm::Pi_parallel_bcm(arma::mat & output, 30 | const arma::mat & y, 31 | const arma::mat & X, 32 | const arma::mat & d, 33 | const arma::mat & eps, 34 | const arma::mat & volatility, 35 | const arma::uword T, 36 | const arma::uword n, 37 | const arma::uword p) : output(output), y(y), X(X), d(d), eps(eps), volatility(volatility), T(T), n(n), p(p) {}; 38 | 39 | void Pi_parallel_bcm::operator()(std::size_t begin, std::size_t end) { 40 | for (std::size_t i = begin; i < end; i++) 41 | { 42 | arma::vec h_j = arma::exp(-0.5 * volatility.col(i)); 43 | arma::mat X_j = X.each_col() % h_j; 44 | arma::vec y_j = y.col(i) % h_j; 45 | arma::vec eps_i = eps.unsafe_col(i); 46 | arma::vec d_i = d.unsafe_col(i); 47 | output.col(i) = mvn_bcm_eps(X_j, d_i, y_j, eps_i); 48 | } 49 | } 50 | 51 | 52 | -------------------------------------------------------------------------------- /src/plot_funs.cpp: -------------------------------------------------------------------------------- 1 | //[[Rcpp::depends(RcppArmadillo)]] 2 | #include 3 | //[[Rcpp::export]] 4 | void variances_fsv(arma::cube & variances, const arma::cube & latent, const arma::cube & facload, arma::uvec variables_num, arma::uword n_fac, arma::uword n_reps, arma::uword n_T, arma::uword n_vars, arma::uword n_plotvars) { 5 | arma::mat facload_i, fac_i, idi_i, variance_i; 6 | 7 | for (arma::uword i = 0; i < n_reps; ++i) { 8 | for (arma::uword tt = 0; tt < n_T; ++tt) { 9 | facload_i = facload.slice(i).rows(variables_num-1); 10 | fac_i = latent.slice(i).row(tt).cols(n_vars, n_vars+n_fac-1); 11 | idi_i = latent.slice(i).row(tt); 12 | idi_i = idi_i.cols(variables_num-1); 13 | variance_i = facload_i * arma::diagmat(arma::exp(fac_i)) * facload_i.t(); 14 | variance_i.diag() += arma::exp(idi_i); 15 | variances.slice(i).row(tt) = arma::sqrt(variance_i.diag().t()); 16 | } 17 | } 18 | } 19 | 20 | //[[Rcpp::export]] 21 | void variances_csv(arma::cube & variances, const arma::cube & Sigma, const arma::mat & f, arma::uword n_T, arma::uword n_reps, arma::uvec variables_num) { 22 | arma::vec Sigma_i; 23 | for (arma::uword i = 0; i < n_T; ++i) { 24 | for (arma::uword j = 0; j < n_reps; ++j) { 25 | Sigma_i = Sigma.slice(j).diag(); 26 | variances.slice(j).row(i) = std::exp(0.5 * f(j, i)) * arma::sqrt(Sigma_i.rows(variables_num-1).t()); 27 | } 28 | } 29 | } 30 | -------------------------------------------------------------------------------- /src/posteriors.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | #include "ss_utils.h" 3 | 4 | // [[Rcpp::export]] 5 | arma::mat posterior_psi_Omega_fsv(const arma::mat & U, const arma::mat & D_mat, 6 | const arma::mat & idivar, const arma::mat & inv_prior_psi_Omega) { 7 | arma::mat mid_mat = arma::mat(D_mat.n_cols * idivar.n_cols, D_mat.n_cols * idivar.n_cols, arma::fill::zeros); 8 | arma::uword n_T = D_mat.n_rows; 9 | arma::mat D_temp; 10 | for (arma::uword i = 0; i < n_T; i++) { 11 | D_temp = D_mat.row(i); 12 | mid_mat += arma::kron(D_temp.t() * D_temp, arma::diagmat(arma::pow(idivar.row(i), -1.0))); 13 | } 14 | arma::mat psi_Omega = arma::inv_sympd((U.t() * mid_mat) * U + inv_prior_psi_Omega); 15 | return psi_Omega; 16 | } 17 | 18 | // [[Rcpp::export]] 19 | arma::mat posterior_psi_Omega_csv(const arma::mat & U, const arma::mat & D_mat, 20 | const arma::mat & Sigma_chol_inv, 21 | const arma::vec & exp_sqrt_f, const arma::mat & inv_prior_psi_Omega, 22 | int n_determ, int n_vars, int n_lags) { 23 | arma::uword pm1 = D_mat.n_cols; 24 | arma::mat mid_mat = arma::mat(pm1 * Sigma_chol_inv.n_cols, pm1 * Sigma_chol_inv.n_cols, arma::fill::zeros); 25 | arma::uword n_T = D_mat.n_rows; 26 | arma::mat D_temp; 27 | arma::mat Sigma_inv = arma::trimatu(Sigma_chol_inv.t()) * arma::trimatl(Sigma_chol_inv); 28 | for (arma::uword i = 0; i < n_T; i++) { 29 | D_temp = D_mat.row(i) / exp_sqrt_f(i); 30 | mid_mat += arma::kron(D_temp.t() * D_temp, Sigma_inv); 31 | } 32 | arma::mat psi_Omega = arma::inv_sympd((U.t() * mid_mat) * U + inv_prior_psi_Omega); 33 | return psi_Omega; 34 | } 35 | 36 | 37 | // [[Rcpp::export]] 38 | arma::vec posterior_psi_mean_csv(const arma::mat & U, const arma::mat & D_mat, const arma::mat & Sigma_chol_inv, 39 | const arma::mat & exp_sqrt_f, 40 | const arma::vec & inv_prior_psi_Omega_mean, const arma::mat & post_psi_Omega, 41 | const arma::mat & Y_tilde) { 42 | arma::mat SigmaYD = arma::mat(Y_tilde.n_cols, D_mat.n_cols, arma::fill::zeros); 43 | arma::uword n_T = D_mat.n_rows; 44 | for (arma::uword i = 0; i < n_T; i++) { 45 | SigmaYD += arma::trans(Y_tilde.row(i) / exp_sqrt_f(i)) * (D_mat.row(i) / exp_sqrt_f(i)); 46 | } 47 | SigmaYD = arma::trimatu(Sigma_chol_inv.t()) * arma::trimatl(Sigma_chol_inv) * SigmaYD; 48 | arma::vec sigmaYD = arma::vectorise(SigmaYD); 49 | arma::vec psi = post_psi_Omega * (U.t() * sigmaYD + inv_prior_psi_Omega_mean); 50 | return psi; 51 | } 52 | 53 | // [[Rcpp::export]] 54 | void posterior_psi_csv(arma::vec & psi_i, arma::mat & mu_mat, 55 | const arma::mat & Pi_i, const arma::mat & D_mat, 56 | const arma::mat & Sigma_chol_inv, const arma::mat & exp_sqrt_f, 57 | const arma::mat & inv_prior_psi_Omega, 58 | const arma::mat & Z_i, const arma::mat & X, 59 | const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, 60 | int n_determ, int n_vars, int n_lags) { 61 | arma::mat U = build_U_cpp(Pi_i, n_determ, n_vars, n_lags); 62 | arma::mat post_psi_Omega = posterior_psi_Omega_csv(U, D_mat, Sigma_chol_inv, exp_sqrt_f, inv_prior_psi_Omega, 63 | n_determ, n_vars, n_lags); 64 | arma::mat Y_tilde = Z_i - X * Pi_i.t(); 65 | 66 | arma::mat post_psi = posterior_psi_mean_csv(U, D_mat, Sigma_chol_inv, exp_sqrt_f, inv_prior_psi_Omega_mean, 67 | post_psi_Omega, Y_tilde); 68 | psi_i = rmultn(post_psi, post_psi_Omega); 69 | arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ); 70 | 71 | mu_mat = dt * Psi_i.t(); 72 | } 73 | 74 | // [[Rcpp::export]] 75 | arma::vec posterior_psi_mean_fsv(const arma::mat & U, const arma::mat & D_mat, const arma::mat & idivar, 76 | const arma::vec & inv_prior_psi_Omega_mean, const arma::mat & post_psi_Omega, 77 | const arma::mat & Y_tilde) { 78 | arma::mat SigmaYD = arma::mat(idivar.n_cols, D_mat.n_cols, arma::fill::zeros); 79 | arma::uword n_T = D_mat.n_rows; 80 | for (arma::uword i = 0; i < n_T; i++) { 81 | SigmaYD += arma::trans(Y_tilde.row(i) / idivar.row(i)) * D_mat.row(i); 82 | } 83 | arma::vec sigmaYD = arma::vectorise(SigmaYD); 84 | arma::vec psi = post_psi_Omega * (U.t() * sigmaYD + inv_prior_psi_Omega_mean); 85 | return psi; 86 | } 87 | 88 | // [[Rcpp::export]] 89 | void posterior_psi_fsv(arma::vec & psi_i, arma::mat & mu_mat, 90 | const arma::mat & Pi_i, const arma::mat & D_mat, 91 | const arma::mat & idivar, const arma::mat & inv_prior_psi_Omega, 92 | const arma::mat & Z_i, const arma::mat & X, 93 | const arma::mat & startfacload, const arma::mat & startfac, 94 | const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, 95 | int n_determ, int n_vars, int n_lags) { 96 | arma::mat U = build_U_cpp(Pi_i, n_determ, n_vars, n_lags); 97 | arma::mat post_psi_Omega = posterior_psi_Omega_fsv(U, D_mat, idivar, inv_prior_psi_Omega); 98 | arma::mat Y_tilde = Z_i - X * Pi_i.t() - arma::trans(startfacload * startfac); 99 | arma::mat post_psi = posterior_psi_mean_fsv(U, D_mat, idivar, inv_prior_psi_Omega_mean, 100 | post_psi_Omega, Y_tilde); 101 | psi_i = rmultn(post_psi, post_psi_Omega); 102 | arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ); 103 | 104 | mu_mat = dt * Psi_i.t(); 105 | } 106 | 107 | 108 | 109 | // [[Rcpp::export]] 110 | arma::vec posterior_psi_mean_iw(const arma::mat & U, const arma::mat & D_mat, const arma::mat & Sigma_i, 111 | const arma::vec & inv_prior_psi_Omega_mean, const arma::mat & post_psi_Omega, 112 | const arma::mat & Y_tilde) { 113 | 114 | arma::mat SigmaYD = arma::inv_sympd(Sigma_i) * (Y_tilde.t() * D_mat); 115 | arma::vec sigmaYD = arma::vectorise(SigmaYD); 116 | arma::vec psi = post_psi_Omega * (U.t() * sigmaYD + inv_prior_psi_Omega_mean); 117 | return psi; 118 | } 119 | 120 | // [[Rcpp::export]] 121 | arma::mat posterior_psi_Omega_iw(const arma::mat & U, const arma::mat & D_mat, 122 | const arma::mat & Sigma_i, const arma::mat & inv_prior_psi_Omega) { 123 | arma::mat mid_mat = arma::kron(D_mat.t() * D_mat, arma::inv_sympd(Sigma_i)); 124 | arma::mat psi_Omega = arma::inv_sympd((U.t() * mid_mat) * U + inv_prior_psi_Omega); 125 | return psi_Omega; 126 | } 127 | 128 | // [[Rcpp::export]] 129 | void posterior_psi_iw(arma::vec & psi_i, arma::mat & mu_mat, 130 | const arma::mat & Pi_i, const arma::mat & D_mat, 131 | const arma::mat & Sigma_i, const arma::mat & inv_prior_psi_Omega, 132 | const arma::mat & Z_i, const arma::mat & X, 133 | const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, 134 | int n_determ, int n_vars, int n_lags) { 135 | arma::mat U = build_U_cpp(Pi_i, n_determ, n_vars, n_lags); 136 | arma::mat post_psi_Omega = posterior_psi_Omega_iw(U, D_mat, Sigma_i, inv_prior_psi_Omega); 137 | arma::mat Y_tilde = Z_i - X * Pi_i.t(); 138 | arma::mat post_psi = posterior_psi_mean_iw(U, D_mat, Sigma_i, inv_prior_psi_Omega_mean, 139 | post_psi_Omega, Y_tilde); 140 | psi_i = rmultn(post_psi, post_psi_Omega); 141 | arma::mat Psi_i = arma::mat(psi_i.begin(), n_vars, n_determ); 142 | 143 | mu_mat = dt * Psi_i.t(); 144 | } 145 | 146 | -------------------------------------------------------------------------------- /src/progutils.cpp: -------------------------------------------------------------------------------- 1 | // Copyright of original code (excl. 'rtruncnorm'): Gregor Kastner (stochvol package) 2 | // Copyright of modified code: Sebastian Ankargren (mfbvar package) 3 | // The following code is a derivative work of the code 4 | // developed by Gregor Kastner for the stochvol package, which 5 | // is licensed GPL>=2. This code is therefore licensed under 6 | // the terms of the GNU Public License, version 3. 7 | #include 8 | #include "progutils.h" 9 | // b) 10 | // Cholesky factor for a tridiagonal matrix with constant off-diagonal 11 | void cholTridiag( 12 | const arma::vec& omega_diag, 13 | double omega_offdiag, 14 | arma::vec& chol_diag, 15 | arma::vec& chol_offdiag) { 16 | chol_diag[0] = std::pow(omega_diag[0], 0.5); // maybe speed up via iterators? 17 | for (int j = 1; j < int(omega_diag.size()); j++) { 18 | chol_offdiag[j-1] = omega_offdiag/chol_diag[j-1]; 19 | chol_diag[j] = std::pow(omega_diag[j]-chol_offdiag[j-1]*chol_offdiag[j-1], 0.5); 20 | } 21 | } 22 | 23 | // Solves Chol*x = covector ("forward algorithm") 24 | // [[Rcpp::export]] 25 | void forwardAlg( 26 | const arma::vec& chol_diag, 27 | const arma::vec& chol_offdiag, 28 | const arma::vec& covector, 29 | arma::vec& htmp) { 30 | htmp[0] = covector[0]/chol_diag[0]; 31 | for (int j = 1; j < int(chol_diag.size()); j++) { 32 | htmp[j] = (covector[j] - chol_offdiag[j-1]*htmp[j-1])/chol_diag[j]; 33 | } 34 | } 35 | 36 | // Solves (Chol')*x = htmp ("backward algorithm") 37 | void backwardAlg( 38 | const arma::vec& chol_diag, 39 | const arma::vec& chol_offdiag, 40 | const arma::vec& htmp, 41 | arma::vec& h) { 42 | int T = chol_diag.size(); 43 | h[T-1] = htmp[T-1]/chol_diag[T-1]; 44 | for (int j = T-2; j >= 0; j--) { 45 | h[j] = (htmp[j] - chol_offdiag[j]*h[j+1])/chol_diag[j]; 46 | } 47 | } 48 | 49 | double rtruncnorm(double m, double v) { 50 | double proposal = 1000; 51 | int iter = 0; 52 | while(std::abs(proposal)>1.0) { 53 | proposal = R::rnorm(m, std::pow(v, 0.5)); 54 | iter += 1; 55 | if (iter > 1000) { 56 | Rcpp::stop("Unable to draw stationary phi."); 57 | } 58 | } 59 | return proposal; 60 | } 61 | -------------------------------------------------------------------------------- /src/progutils_fsv.cpp: -------------------------------------------------------------------------------- 1 | #include "progutils_fsv.h" 2 | // Copyright of original code: Gregor Kastner (factorstochvol package) 3 | // Copyright of modified code: Sebastian Ankargren (mfbvar package) 4 | // The following code is a derivative work of the code 5 | // developed by Gregor Kastner for the factorstochvol package, which 6 | // is licensed GPL>=2. This code is therefore licensed under 7 | // the terms of the GNU Public License, version 3. 8 | 9 | double logdnormquot(double x, double y, double mu, double sigma) { 10 | return ((y-mu)*(y-mu) - (x-mu)*(x-mu)) / (2*sigma*sigma); 11 | } 12 | 13 | double logspecialquot(double x, double y, double alpha, double beta, double c) { 14 | return (alpha/c) * (x - y) - beta * (exp(x/c) - exp(y/c)); 15 | } 16 | 17 | 18 | void store(const Rcpp::NumericMatrix &curfacload, Rcpp::NumericVector &facload, 19 | const Rcpp::NumericMatrix &curf, Rcpp::NumericVector &f, 20 | const Rcpp::NumericMatrix &curh, Rcpp::NumericVector &h, 21 | const Rcpp::NumericVector &curh0, Rcpp::NumericMatrix &h0, 22 | const Rcpp::NumericMatrix &curpara, Rcpp::NumericVector ¶, 23 | const Rcpp::NumericVector &curlambda2, Rcpp::NumericMatrix &lambda2, 24 | const Rcpp::NumericMatrix &curtau2, Rcpp::NumericVector &tau2, 25 | const Rcpp::NumericVector &curmixprob, Rcpp::NumericVector &mixprob, 26 | const Rcpp::IntegerMatrix &curmixind, Rcpp::IntegerVector &mixind, 27 | const bool auxstore, const int thintime, const int where) { 28 | 29 | std::copy(curfacload.begin(), curfacload.end(), facload.begin() + where * curfacload.length()); 30 | std::copy(curpara.begin(), curpara.end(), para.begin() + where * curpara.length()); 31 | 32 | if (thintime == 1) { // store everything 33 | 34 | std::copy(curf.begin(), curf.end(), f.begin() + where * curf.length()); 35 | std::copy(curh.begin(), curh.end(), h.begin() + where * curh.length()); 36 | 37 | } else if (thintime == -1) { // store only t = T 38 | 39 | for (int i = 0; i < curf.nrow(); i++) { 40 | f(where*curf.nrow() + i) = curf(i, curf.ncol()-1); 41 | } 42 | 43 | for (int i = 0; i < curh.ncol(); i++) { 44 | h(where*curh.ncol() + i) = curh(curh.nrow()-1, i); 45 | } 46 | 47 | } else if (thintime > 1) { // store every thintimeth point in time 48 | 49 | int tmp = curf.ncol()/thintime; 50 | int tmpp = where * curf.nrow() * tmp; 51 | 52 | for (int j = 0; j < tmp; ++j) { 53 | int tmppp = j*thintime; 54 | int tmpppp = tmpp + j*curf.nrow(); 55 | 56 | for (int i = 0; i < curf.nrow(); ++i) { 57 | f(tmpppp + i) = curf(i, tmppp); 58 | } 59 | } 60 | 61 | tmpp = where * curh.ncol() * tmp; 62 | 63 | for (int i = 0; i < curh.ncol(); ++i) { 64 | int tmpppp = tmpp + i*tmp; 65 | 66 | for (int j = 0; j < tmp; ++j) { 67 | h(tmpppp + j) = curh(j*thintime, i); 68 | } 69 | } 70 | } 71 | 72 | std::copy(curh0.begin(), curh0.end(), h0.begin() + where * curh0.length()); 73 | 74 | if (auxstore) { // store mixture probabilities, mixture indicators, shrinkage hyperparas, h0 75 | std::copy(curmixprob.begin(), curmixprob.end(), mixprob.begin() + where * curmixprob.length()); 76 | std::copy(curmixind.begin(), curmixind.end(), mixind.begin() + where * curmixind.length()); 77 | std::copy(curlambda2.begin(), curlambda2.end(), lambda2.begin() + where * curlambda2.length()); 78 | std::copy(curtau2.begin(), curtau2.end(), tau2.begin() + where * curtau2.length()); 79 | } 80 | } 81 | -------------------------------------------------------------------------------- /src/progutils_fsv.h: -------------------------------------------------------------------------------- 1 | #ifndef _PROGUTILS_H 2 | #define _PROGUTILS_H 3 | 4 | #include 5 | 6 | double logdnormquot(double x, double y, double mu, double sigma); 7 | double logspecialquot(double x, double y, double alpha, double beta, double c); 8 | 9 | void store(const Rcpp::NumericMatrix &curfacload, Rcpp::NumericVector &facload, 10 | const Rcpp::NumericMatrix &curf, Rcpp::NumericVector &f, 11 | const Rcpp::NumericMatrix &curh, Rcpp::NumericVector &h, 12 | const Rcpp::NumericVector &curh0, Rcpp::NumericMatrix &h0, 13 | const Rcpp::NumericMatrix &curpara, Rcpp::NumericVector ¶, 14 | const Rcpp::NumericVector &curlambda2, Rcpp::NumericMatrix &lambda2, 15 | const Rcpp::NumericMatrix &curtau2, Rcpp::NumericVector &tau2, 16 | const Rcpp::NumericVector &curmixprob, Rcpp::NumericVector &mixprob, 17 | const Rcpp::IntegerMatrix &curmixind, Rcpp::IntegerVector &mixind, 18 | const bool auxstore, const int thintime, const int where); 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /src/rgig.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | 3 | /* 4 | double gigrvg(double lambda, double chi, double psi) { 5 | SEXP gig = do_rgig(1, lambda, chi, psi); 6 | double ret = 0.0;//Rcpp::as(gig); 7 | return ret; 8 | } 9 | */ 10 | 11 | // [[Rcpp::export]] 12 | double do_rgig1(double lambda, double chi, double psi) { 13 | SEXP (*fun)(int, double, double, double) = NULL; 14 | if (!fun) fun = (SEXP(*)(int, double, double, double)) R_GetCCallable("GIGrvg", "do_rgig"); 15 | return Rcpp::as(fun(1, lambda, chi, psi)); 16 | } 17 | 18 | // [[Rcpp::export]] 19 | double rig(double mu, double lambda){ 20 | double z = R::rnorm(0,1); 21 | double y = z*z; 22 | double x = mu+0.5*mu*mu*y/lambda - 0.5*(mu/lambda)*sqrt(4*mu*lambda*y+mu*mu*y*y); 23 | double u=R::runif(0,1); 24 | double out; 25 | if(u <= mu/(mu+x)){ 26 | out = x; 27 | } else { 28 | out = mu*mu/x; 29 | } 30 | return out; 31 | } 32 | -------------------------------------------------------------------------------- /src/rmvn.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | #include "mvn.h" 3 | 4 | // [[Rcpp::export]] 5 | arma::vec rmvn(const arma::mat & Phi, const arma::vec & d, const arma::vec & alpha) { 6 | arma::uword n = Phi.n_rows; 7 | arma::uword p = Phi.n_cols; 8 | arma::vec theta(p, arma::fill::zeros); 9 | 10 | if (p > 1.1*n) { 11 | theta = mvn_bcm(Phi, d, alpha); 12 | } else { 13 | theta = mvn_rue(Phi, d, alpha); 14 | } 15 | 16 | return theta; 17 | } 18 | 19 | // [[Rcpp::export]] 20 | arma::vec rmvn_ccm(const arma::mat & Phi, const arma::vec & d, const arma::vec & alpha, double c, double j) { 21 | return mvn_ccm(Phi, d, alpha, c, j); 22 | } 23 | -------------------------------------------------------------------------------- /src/rnd_numbers.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | 3 | //' @rdname dnorminvwish 4 | //' @keywords internal 5 | //' @noRd 6 | // [[Rcpp::export]] 7 | arma::mat rmatn(const arma::mat & M, const arma::mat & Q, const arma::mat & P){ 8 | /*------------------------------------------------------- 9 | # Generate draws from a matricvariate normal distribution 10 | #-------------------------------------------------------*/ 11 | int p = P.n_rows; 12 | int q = Q.n_rows; 13 | arma::mat L = arma::chol(Q, "upper"); 14 | arma::mat C = arma::chol(P, "lower"); 15 | arma::mat X = arma::reshape(arma::vec(Rcpp::rnorm(p * q)), p, q); 16 | X = M + C * X * L; 17 | return(X); 18 | } 19 | 20 | 21 | //' @rdname dnorminvwish 22 | //' @keywords internal 23 | //' @noRd 24 | // [[Rcpp::export]] 25 | arma::mat rinvwish(int v, const arma::mat & S){ 26 | int p = S.n_rows; 27 | arma::mat L = arma::chol(arma::inv_sympd(S), "lower"); 28 | arma::mat A(p,p, arma::fill::zeros); 29 | for(int i = 0; i < p; i++){ 30 | int df = v - (i + 1) + 1; //zero-indexing 31 | A(i,i) = sqrt(R::rchisq(df)); 32 | } 33 | for(int row = 1; row < p; row++){ 34 | for(int col = 0; col < row; col++){ 35 | A(row, col) = R::rnorm(0,1); 36 | } 37 | } 38 | arma::mat LA_inv = arma::inv(arma::trimatl(arma::trimatl(L) * arma::trimatl(A))); 39 | arma::mat X = LA_inv.t() * LA_inv; 40 | 41 | return(X); 42 | } 43 | 44 | 45 | //' @rdname dmultn 46 | //' @keywords internal 47 | //' @noRd 48 | // [[Rcpp::export]] 49 | arma::vec rmultn(const arma::vec & m, const arma::mat & Sigma){ 50 | /*------------------------------------------------------- 51 | # Generate draws from a matricvariate normal distribution 52 | #-------------------------------------------------------*/ 53 | int p = Sigma.n_rows; 54 | arma::vec X = Rcpp::rnorm(p); 55 | arma::mat L = arma::chol(Sigma, "lower"); 56 | X = m + L * X; 57 | return(X); 58 | } 59 | 60 | 61 | 62 | -------------------------------------------------------------------------------- /src/rsimsm_adaptive_cv.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | 3 | // [[Rcpp::export]] 4 | arma::mat rsimsm_adaptive_cv(arma::mat y_, arma::mat Phi, arma::mat Sigma_chol, 5 | arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b) { 6 | return simsm_adaptive_cv(y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b); 7 | } 8 | 9 | // [[Rcpp::export]] 10 | arma::mat rsimsm_adaptive_sv(arma::mat y_, arma::mat Phi, arma::cube Sigma_chol, 11 | arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b) { 12 | return simsm_adaptive_sv(y_, Phi, Sigma_chol, Lambda, Z1, n_q_, T_b); 13 | } 14 | 15 | -------------------------------------------------------------------------------- /src/rsimsm_adaptive_univariate.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | 3 | // [[Rcpp::export]] 4 | arma::mat rsimsm_adaptive_univariate(arma::mat y_, arma::mat Phi, arma::mat Sigma, 5 | arma::mat Lambda, arma::mat Z1, arma::uword n_q_, arma::uword T_b, arma::mat f) { 6 | return simsm_adaptive_univariate(y_, Phi, Sigma, Lambda, Z1, n_q_, T_b, f); 7 | } 8 | -------------------------------------------------------------------------------- /src/smoothing.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | 3 | #define _USE_MATH_DEFINES // for C++ 4 | #include 5 | 6 | //' @title Smooth and sample from the smoothed distribution 7 | //' 8 | //' @description Functions for smoothing and sampling from the (smoothed) distribution \eqn{p(Z_{1:T}|Y_{1:T}, \Theta)}. 9 | //' @details Implemented in C++. 10 | //' @aliases smoother simulation_smoother generate_mhh loglike 11 | //' @describeIn smoother Compute smoothed states 12 | //' @templateVar Y TRUE 13 | //' @templateVar Lambda TRUE 14 | //' @templateVar Pi_comp TRUE 15 | //' @templateVar Q_comp TRUE 16 | //' @templateVar n_T TRUE 17 | //' @templateVar n_vars TRUE 18 | //' @templateVar n_comp TRUE 19 | //' @templateVar z0 TRUE 20 | //' @templateVar P0 TRUE 21 | //' @template man_template 22 | //' @keywords internal 23 | //' @noRd 24 | //' @return For \code{loglike}: 25 | //' \item{}{An \code{n_T}-long vector of the log-likelihoods. \code{exp(sum(loglike(...)))} is the likelihood.} 26 | // [[Rcpp::export]] 27 | 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) { 28 | /* This function computes the smoothed state vector */ 29 | /****************************************************/ 30 | /* Initialize matrices and cubes */ 31 | arma::mat QQ = arma::symmatu(Q_comp * Q_comp.t()); 32 | arma::mat mv(n_T, n_vars); 33 | mv.fill(NA_REAL); 34 | arma::mat me(n_T, n_vars); 35 | me.fill(NA_REAL); 36 | arma::mat mr(n_T, n_comp); 37 | mr.fill(0); 38 | arma::mat mu(n_T, n_comp); 39 | mu.fill(0); 40 | arma::cube IS(n_vars, n_vars, n_T); 41 | IS.fill(NA_REAL); 42 | arma::cube aK(n_comp, n_vars, n_T); 43 | aK.fill(NA_REAL); 44 | arma::mat identity_mat(n_comp, n_comp, arma::fill::eye); 45 | arma::mat YY(n_T, n_vars); 46 | YY.fill(NA_REAL); 47 | arma::mat mhh(n_T, n_comp); 48 | mhh.fill(NA_REAL); 49 | arma::mat mz = Y.row(0); 50 | arma::uvec obs_vars = find_finite(mz); 51 | arma::mat logl(n_T, 1); 52 | logl.fill(NA_REAL); 53 | 54 | /* Fill some temporary variables */ 55 | arma::mat h1 = Pi_comp * z0; 56 | arma::mat P1 = arma::symmatu(Pi_comp * P0 * Pi_comp.t() + QQ); 57 | arma::mat mH = Lambda.rows(obs_vars); 58 | arma::mat vz = mz.cols(obs_vars); 59 | 60 | arma::mat vv = mv.row(0); 61 | vv.cols(obs_vars) = vz - trans(mH * h1); 62 | mv.row(0) = vv; 63 | 64 | arma::mat aS = arma::symmatu(mH * P1 * mH.t()); 65 | arma::mat mIS = IS.slice(0); 66 | mIS(obs_vars, obs_vars) = inv_sympd(aS); 67 | IS.slice(0) = mIS; 68 | 69 | arma::mat mK = aK.slice(0); 70 | mK.cols(obs_vars) = P1 * mH.t() * mIS(obs_vars, obs_vars); 71 | aK.slice(0) = mK; 72 | 73 | arma::mat h2 = h1 + mK.cols(obs_vars) * trans(vv.cols(obs_vars)); 74 | arma::mat P2 = arma::symmatu((identity_mat - mK.cols(obs_vars) * mH) * P1); 75 | 76 | double log_det_val; 77 | double log_det_sign; 78 | /* Filtering */ 79 | for (int i = 1; i < n_T; i++) { 80 | mz = Y.row(i); 81 | obs_vars = find_finite(mz); 82 | 83 | h1 = Pi_comp * h2; 84 | P1 = arma::symmatu(Pi_comp * P2 * Pi_comp.t() + QQ); 85 | 86 | mH = Lambda.rows(obs_vars); 87 | vz = mz.cols(obs_vars); 88 | 89 | vv = mv.row(i); 90 | vv.cols(obs_vars) = vz - trans(mH * h1); 91 | mv.row(i) = vv; 92 | 93 | aS = arma::symmatu(mH * P1 * mH.t()); 94 | mIS = IS.slice(i); 95 | mIS(obs_vars, obs_vars) = inv_sympd(aS); 96 | IS.slice(i) = mIS; 97 | 98 | mK = aK.slice(i); 99 | mK.cols(obs_vars) = P1 * mH.t() * mIS(obs_vars, obs_vars); 100 | aK.slice(i) = mK; 101 | 102 | h2 = h1 + mK.cols(obs_vars) * trans(vv.cols(obs_vars)); 103 | P2 = arma::symmatu((identity_mat - mK.cols(obs_vars) * mH) * P1); 104 | log_det(log_det_val, log_det_sign, aS); 105 | logl.row(i) = -0.5* obs_vars.n_elem * std::log(2*M_PI) - (log_det_val + vv.cols(obs_vars) * mIS(obs_vars, obs_vars) * trans(vv.cols(obs_vars)))*0.5; 106 | } 107 | 108 | /* The return is the smoothed state vector */ 109 | return(logl); 110 | } 111 | -------------------------------------------------------------------------------- /src/ss_utils.h: -------------------------------------------------------------------------------- 1 | #ifndef _SS_UTILS_H_ 2 | #define _SS_UTILS_H_ 3 | arma::mat build_U_cpp(const arma::mat & Pi, int n_determ, int n_vars, int n_lags); 4 | arma::mat create_X_t_noint(const arma::mat & y); 5 | arma::mat create_X_noint(const arma::mat & y, arma::uword k); 6 | void update_demean(arma::mat & my, arma::mat & mu_long, 7 | const arma::mat & y_in_p, const arma::mat & mu_mat, const arma::mat & d1, 8 | const arma::mat & Psi_i, const arma::mat & Lambda_single, 9 | arma::uword n_vars, arma::uword n_q, arma::uword n_Lambda, arma::uword n_T); 10 | 11 | void posterior_psi_iw(arma::vec & psi_i, arma::mat & mu_mat, 12 | const arma::mat & Pi_i, const arma::mat & D_mat, 13 | const arma::mat & Sigma_i, const arma::mat & inv_prior_psi_Omega, 14 | const arma::mat & Z_i, const arma::mat & X, 15 | const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, 16 | int n_determ, int n_vars, int n_lags); 17 | void posterior_psi_csv(arma::vec & psi_i, arma::mat & mu_mat, 18 | const arma::mat & Pi_i, const arma::mat & D_mat, 19 | const arma::mat & Sigma_chol_inv, const arma::mat & exp_sqrt_f, 20 | const arma::mat & inv_prior_psi_Omega, 21 | const arma::mat & Z_i, const arma::mat & X, 22 | const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, 23 | int n_determ, int n_vars, int n_lags); 24 | void posterior_psi_fsv(arma::vec & psi_i, arma::mat & mu_mat, 25 | const arma::mat & Pi_i, const arma::mat & D_mat, 26 | const arma::mat & idivar, const arma::mat & inv_prior_psi_Omega, 27 | const arma::mat & Z_i, const arma::mat & X, 28 | const arma::mat & startfacload, const arma::mat & startfac, 29 | const arma::mat & inv_prior_psi_Omega_mean, const arma::mat & dt, 30 | int n_determ, int n_vars, int n_lags); 31 | 32 | double max_eig_cpp(const arma::mat & A); 33 | #endif 34 | -------------------------------------------------------------------------------- /src/update_csv.cpp: -------------------------------------------------------------------------------- 1 | // Copyright of original code: Gregor Kastner (stochvol package) 2 | // Copyright of modified code: Sebastian Ankargren (mfbvar package) 3 | // The following code is a derivative work of the code 4 | // developed by Gregor Kastner for the stochvol package, which 5 | // is licensed GPL>=2. This code is therefore licensed under 6 | // the terms of the GNU Public License, version 3. 7 | 8 | #include "mfbvar.h" 9 | #include "progutils.h" 10 | #include "auxmix.h" 11 | void update_csv( 12 | const arma::mat& data, 13 | double& phi, 14 | double& sigma, 15 | arma::vec& h, 16 | double& h0, 17 | arma::mat& mixprob, 18 | arma::imat& r, 19 | const double priorlatent0, 20 | const double phi_invvar, 21 | const double phi_meaninvvar, 22 | const double prior_sigma2, 23 | const double prior_df) { 24 | // data: data matrix 25 | // phi: AR(1) parameter 26 | // sigma: standard deviation of log-volatility innovation 27 | // h: vector of log volatilities 28 | // h0: log volatility initial value 29 | // mixprob: mixture probabilities for Kim, Shephard, Chib (1998) algorithm 30 | // r: mixture indicators for KSC (1998) algorithm 31 | // priorlatent0: prior variance for initial value of log volatility 32 | // phi_invvar: inverse of prior variance for AR(1) parameter 33 | // phi_meaninvvar: prior mean of AR(1) parameter times phi_invvar 34 | // prior_sigma2: prior mean of variance of innovation 35 | // prior_df: prior degrees of freedom for variance of innovation 36 | int T = data.n_rows; 37 | int n = data.n_cols; 38 | 39 | arma::vec omega_diag(T+1); // contains diagonal elements of precision matrix 40 | double omega_offdiag; // contains off-diag element of precision matrix (const) 41 | arma::vec chol_offdiag(T), chol_diag(T+1); // Cholesky-factor of Omega 42 | arma::vec covector(T+1); // holds covector (see McCausland et al. 2011) 43 | arma::vec htmp(T+1); // intermediate vector for sampling h 44 | arma::vec hnew(T+1); // intermediate vector for sampling h 45 | 46 | double sigma2inv = std::pow(sigma, -2.0); 47 | 48 | double Bh0inv = 1.0/priorlatent0; 49 | 50 | arma::vec hT = h.rows(1, T - 1); 51 | arma::vec hT1 = h.rows(0, T - 2); 52 | 53 | 54 | /* 55 | * Sample phi 56 | */ 57 | double phi_postvar = std::pow(phi_invvar + sigma2inv * arma::accu(arma::pow(hT1, 2.0)), -1.0); 58 | double phi_postmean = phi_postvar * (sigma2inv * arma::accu(hT1 % hT) + phi_meaninvvar); 59 | phi = rtruncnorm(phi_postmean, phi_postvar); 60 | const double phi2 = std::pow(phi, 2.0); 61 | 62 | /* 63 | * Sample sigma2 64 | */ 65 | arma::vec u = hT - phi * hT1; 66 | 67 | sigma = std::pow(R::rgamma(prior_df + T - 1, 1/(prior_df * prior_sigma2 + arma::accu(arma::pow(u, 2.0)))), -0.5); 68 | sigma2inv = std::pow(sigma, -2.0); 69 | 70 | /* 71 | * Step (c): sample indicators 72 | */ 73 | // calculate non-normalized CDF of posterior indicator probs 74 | for (int i = 0; i < n; ++i) { 75 | arma::vec mixprob_vec = arma::vec(10*T); 76 | arma::ivec r_vec = arma::ivec(T); 77 | findMixCDF(mixprob_vec, data.col(i)-h); 78 | invTransformSampling(mixprob_vec, r_vec, T); 79 | mixprob.col(i) = mixprob_vec; 80 | r.col(i) = r_vec; 81 | } 82 | 83 | 84 | // find correct indicators (currently by inversion method) 85 | 86 | /* 87 | * Step (a): sample the latent volatilities h: 88 | */ 89 | omega_diag[0] = (Bh0inv + 1) * sigma2inv; 90 | covector[0] = 0.0; 91 | 92 | for (int j = 1; j < T; j++) { 93 | omega_diag[j] = sigma2inv*(1+phi2); 94 | covector[j] = 0.0; 95 | for (int i = 0; i < n; i++) { 96 | omega_diag[j] += mix_varinv[r.at(j-1, i)]; 97 | covector[j] += (data.at(j-1, i) - mix_mean[r.at(j-1, i)])*mix_varinv[r.at(j-1, i)]; 98 | } 99 | } 100 | omega_diag[T] = sigma2inv; 101 | covector[T] = 0.0; 102 | for (int i = 0; i < n; i++) { 103 | omega_diag[T] += mix_varinv[r.at(T-1, i)]; 104 | covector[T] += (data.at(T-1, i) - mix_mean[r.at(T-1, i)])*mix_varinv[r.at(T-1, i)]; 105 | } 106 | omega_offdiag = -phi * sigma2inv; // omega_offdiag is constant 107 | 108 | // Cholesky decomposition 109 | cholTridiag(omega_diag, omega_offdiag, chol_diag, chol_offdiag); 110 | 111 | // Solution of Chol*x = covector ("forward algorithm") 112 | forwardAlg(chol_diag, chol_offdiag, covector, htmp); 113 | 114 | htmp += Rcpp::as(Rcpp::rnorm(T+1)); 115 | 116 | // Solution of (Chol')*x = htmp ("backward algorithm") 117 | backwardAlg(chol_diag, chol_offdiag, htmp, hnew); 118 | 119 | h = hnew.tail(T); 120 | h0 = hnew[0]; 121 | } 122 | -------------------------------------------------------------------------------- /src/update_demean.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | // [[Rcpp::export]] 3 | void update_demean(arma::mat & my, arma::mat & mu_long, 4 | const arma::mat & y_in_p, const arma::mat & mu_mat, const arma::mat & d1, 5 | const arma::mat & Psi_i, const arma::mat & Lambda_single, 6 | arma::uword n_vars, arma::uword n_q, arma::uword n_Lambda, arma::uword n_T) { 7 | 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); 8 | mu_long.rows(0, n_Lambda-1) = d1.tail_rows(n_Lambda) * Psi_i.t(); 9 | mu_long.rows(n_Lambda, n_T+n_Lambda-1) = mu_mat; 10 | for (arma::uword j = 0; j < n_T; ++j) { 11 | 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 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /src/update_dl.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | void update_dl(arma::mat & prior_Pi_Omega, arma::vec & aux, 3 | arma::vec & local, double & global, const arma::mat & Pi_i, 4 | arma::uword n_vars, arma::uword n_lags, const double a, 5 | arma::vec & slice, bool gig = true, bool intercept = true) { 6 | 7 | arma::vec Pi_vec; 8 | if (intercept) { 9 | Pi_vec = arma::vectorise(Pi_i.rows(1, n_vars*n_lags)); 10 | } else { 11 | Pi_vec = arma::vectorise(Pi_i); 12 | } 13 | 14 | 15 | arma::uword K = Pi_vec.n_elem; 16 | 17 | for (arma::uword i = 0; i < K; ++i) { 18 | aux[i] = 1.0/rig(global * local[i] / fabs(Pi_vec[i]), 1.0); 19 | } 20 | arma::vec Pi_local = arma::abs(Pi_vec) / local; 21 | 22 | global = do_rgig1(K*(a-1.0), 2.0 * arma::accu(Pi_local), 1.0); 23 | 24 | 25 | if (gig) { 26 | for (arma::uword i = 0; i < K; ++i) { 27 | local[i] = do_rgig1((a-1.0), 2.0 * fabs(Pi_vec[i]), 1.0); 28 | } 29 | } else { 30 | arma::vec u1 = arma::vec(K); 31 | std::generate(u1.begin(), u1.end(), ::unif_rand); 32 | u1 %= arma::exp(-0.5 / slice); 33 | arma::vec lb = 0.5/(arma::log(1/u1)); 34 | double Flb; 35 | arma::vec u2 = arma::vec(K); 36 | for (arma::uword i = 0; i < K; ++i) { 37 | Flb = R::pgamma(lb[i], 1-a, 1/fabs(Pi_vec[i]), true, false); 38 | u2[i] = R::runif(Flb, 1.0); 39 | } 40 | arma::uvec u3 = arma::find(u2 > 1-(1e-16)); 41 | if (u3.n_elem > 0) { 42 | u2.elem(u3).fill(1-(1e-16)); 43 | } 44 | for (arma::uword i = 0; i < K; ++i) { 45 | slice[i] = R::qgamma(u2[i], 1-a, 1/fabs(Pi_vec[i]), true, false); 46 | } 47 | local = 1/slice; 48 | } 49 | 50 | local = local / arma::accu(local); 51 | 52 | arma::uvec local_idx = arma::find(local < 1e-20); 53 | local.elem(local_idx).fill(1e-20); 54 | 55 | if (intercept) { 56 | prior_Pi_Omega.rows(1, n_vars*n_lags) = arma::reshape(aux % arma::pow(global * local, 2.0), n_vars*n_lags, n_vars); 57 | } else { 58 | prior_Pi_Omega = arma::reshape(aux % arma::pow(global * local, 2.0), n_vars*n_lags, n_vars); 59 | } 60 | 61 | 62 | } 63 | -------------------------------------------------------------------------------- /src/update_ng.cpp: -------------------------------------------------------------------------------- 1 | #include "mfbvar.h" 2 | 3 | // [[Rcpp::export]] 4 | double posterior_phi_mu(const double lambda, const double phi_mu, const arma::vec omega, 5 | const arma::uword nm) { 6 | double log_prob = arma::accu((phi_mu-1)*arma::log(omega)-0.5*lambda*phi_mu*omega) + 7 | nm*(phi_mu*std::log(lambda*phi_mu*0.5) - 8 | std::lgamma(phi_mu)) - phi_mu; 9 | 10 | return log_prob; 11 | } 12 | 13 | void update_ng(double & phi_mu, double & lambda_mu, arma::vec & omega, arma::uword nm, 14 | const double c0, const double c1, double s, 15 | const arma::vec & psi_i, const arma::vec & prior_psi_mean, double & accept) { 16 | // phi_mu: the shrinkage parameter phi_mu 17 | // lambda_mu: the shrinkage parameter lambda_mu 18 | // omega: the idiosyncratic shrinkage parameters omega 19 | // nm: n_vars * n_determ (number of parameters) 20 | // c0: hyperparameter c0 21 | // c1: hyperparameter c1 22 | // s: scale of proposal 23 | // psi_i: the steady-state parameters 24 | // prior_psi_mean: the prior means of psi_i 25 | // accept: indicator for whether the proposal is accepted or not 26 | 27 | // Update omega 28 | double gig_lambda = phi_mu-0.5; 29 | //double gig_chi = lambda_mu * phi_mu; 30 | //arma::vec gig_psi = arma::pow(psi_i-prior_psi_mean, 2.0); 31 | 32 | arma::vec gig_chi = arma::pow(psi_i-prior_psi_mean, 2.0); 33 | double gig_psi = lambda_mu * phi_mu; 34 | 35 | for (arma::uword i = 0; i < nm; ++i) { 36 | //omega(i) = do_rgig1(gig_lambda, gig_chi, gig_psi(i)); 37 | omega(i) = do_rgig1(gig_lambda, gig_chi(i), gig_psi); 38 | } 39 | // Update lambda 40 | lambda_mu = R::rgamma((double)nm * phi_mu + c0, 1.0/(0.5 * phi_mu * arma::accu(omega) + c1)); 41 | 42 | // Update phi 43 | double phi_mu_proposal = phi_mu * std::exp(R::rnorm(0.0, s)); 44 | double prob = exp(posterior_phi_mu(lambda_mu, phi_mu_proposal, omega, nm)-posterior_phi_mu(lambda_mu, phi_mu, omega, nm))*phi_mu_proposal/phi_mu; 45 | double u = R::runif(0.0, 1.0); 46 | if (u < prob) { 47 | phi_mu = phi_mu_proposal; 48 | accept = 1.0; 49 | } else { 50 | accept = 0.0; 51 | } 52 | } 53 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(mfbvar) 3 | 4 | test_check("mfbvar") 5 | -------------------------------------------------------------------------------- /tests/testthat/Pi_minn.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/Pi_minn.rds -------------------------------------------------------------------------------- /tests/testthat/Pi_ss.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/Pi_ss.rds -------------------------------------------------------------------------------- /tests/testthat/Sigma_minn.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/Sigma_minn.rds -------------------------------------------------------------------------------- /tests/testthat/Sigma_ss.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/Sigma_ss.rds -------------------------------------------------------------------------------- /tests/testthat/Z_minn.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/Z_minn.rds -------------------------------------------------------------------------------- /tests/testthat/Z_ss.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/Z_ss.rds -------------------------------------------------------------------------------- /tests/testthat/mdd_minn.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/mdd_minn.rds -------------------------------------------------------------------------------- /tests/testthat/mdd_ss1.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/mdd_ss1.rds -------------------------------------------------------------------------------- /tests/testthat/mdd_ss2.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/mdd_ss2.rds -------------------------------------------------------------------------------- /tests/testthat/psi_ss.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/tests/testthat/psi_ss.rds -------------------------------------------------------------------------------- /tests/testthat/test_mfbvar.R: -------------------------------------------------------------------------------- 1 | library(mfbvar) 2 | context("Output") 3 | test_that("Output correct", { 4 | set.seed(10237) 5 | Y <- mfbvar::mf_sweden 6 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 7 | n_lags = 4, n_burnin = 100, n_reps = 300) 8 | 9 | prior_intervals <- matrix(c( 6, 7, 10 | 0.1, 0.2, 11 | 0, 0.5, 12 | -0.5, 0.5, 13 | 0.4, 0.6), ncol = 2, byrow = TRUE) 14 | psi_moments <- interval_to_moments(prior_intervals) 15 | prior_psi_mean <- psi_moments$prior_psi_mean 16 | prior_psi_Omega <- psi_moments$prior_psi_Omega 17 | prior_obj2 <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 18 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 19 | 20 | expect_true(!is.null(prior_obj2$d_fcst)) 21 | 22 | testthat::skip_on_cran() 23 | mod_minn <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "minn", n_fcst = 4) 24 | mod_ss <- estimate_mfbvar(prior_obj2, "ss") 25 | 26 | mdd_minn <- mdd(mod_minn, p_trunc = 0.5) 27 | mdd_ss1 <- mdd(mod_ss) 28 | 29 | }) 30 | context("Prior checks") 31 | test_that("Prior checks correct", { 32 | set.seed(10237) 33 | Y <- mfbvar::mf_sweden 34 | 35 | # If Y is not matrix/df 36 | expect_error(prior_obj <- set_prior(Y = "test", freq = c(rep("m", 4), "q"), 37 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 38 | 39 | # Including d 40 | expect_error(prior_obj <- set_prior(Y = Y, d = matrix(1, nrow = nrow(Y)-1, 1), freq = c(rep("m", 4), "q"), 41 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 42 | 43 | # freq 44 | expect_error(prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "s"), 45 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 46 | expect_error(prior_obj <- set_prior(Y = Y, freq = list(c(rep("m", 4), "s")), 47 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 48 | 49 | 50 | expect_error(prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 51 | aggregation = "triangular", 52 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 53 | expect_error(prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 54 | aggregation = "average", 55 | n_lags = 2, n_burnin = 100, n_reps = 1000)) 56 | # Using update 57 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 58 | n_lags = 4, n_burnin = 100, n_reps = 300) 59 | prior_obj2 <- update_prior(prior_obj, d = "intercept", Y = Y[1:100, ], n_fcst = 4) 60 | expect_is(prior_obj2$d_fcst, "matrix") 61 | expect_is(prior_obj2$d, "matrix") 62 | 63 | prior_obj2 <- update_prior(prior_obj, d = "intercept", Y = Y[1:90, ]) 64 | prior_obj2 <- update_prior(prior_obj2, n_fcst = 4) 65 | expect_is(prior_obj2$d_fcst, "matrix") 66 | expect_true(all(dim(prior_obj2$d_fcst) == c(4, 1))) 67 | }) 68 | 69 | test_that("list_to_matrix", { 70 | variables <- c("CPIAUCSL", "UNRATE", "GDPC1") 71 | convert_ts <- function(x, frequency) { 72 | ts(x, 73 | start = c(1980, 1), 74 | frequency = frequency) 75 | } 76 | convert_tsz <- function(x, frequency) { 77 | zoo::zooreg(x, 78 | start = c(1980, 1), 79 | frequency = frequency) 80 | } 81 | out <- list(rnorm(466), rnorm(467), rnorm(155)) 82 | ts_list <- c(lapply(out[1:2], convert_ts, frequency = 12), 83 | lapply(out[3], convert_ts, frequency = 4)) 84 | names(ts_list) <- variables 85 | 86 | tsz_list <- c(lapply(out[1:2], convert_tsz, frequency = 12), 87 | lapply(out[3], convert_tsz, frequency = 4)) 88 | names(tsz_list) <- variables 89 | 90 | ts_list2 <- list(monthly = cbind(CPIAUCSL = ts_list[[1]], UNRATE = ts_list[[2]]), GDPC1 = ts_list[[3]]) 91 | tsz_list2 <- list(monthly = cbind(CPIAUCSL = tsz_list[[1]], UNRATE = tsz_list[[2]]), GDPC1 = tsz_list[[3]]) 92 | 93 | expect_equal(list_to_matrix(tsz_list), list_to_matrix(ts_list)) 94 | expect_equal(list_to_matrix(tsz_list), list_to_matrix(ts_list)) 95 | expect_equal(list_to_matrix(tsz_list), list_to_matrix(ts_list2)) 96 | expect_equal(list_to_matrix(tsz_list), list_to_matrix(tsz_list2)) 97 | 98 | 99 | 100 | 101 | }) 102 | 103 | 104 | test_that("Prior checks correct", { 105 | set.seed(10237) 106 | Y <- mfbvar::mf_sweden 107 | 108 | # If Y is not matrix/df 109 | expect_error(prior_obj <- set_prior(Y = "test", freq = c(rep("m", 4), "q"), 110 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 111 | 112 | # Including d 113 | expect_error(prior_obj <- set_prior(Y = Y, d = matrix(1, nrow = nrow(Y)-1, 1), freq = c(rep("m", 4), "q"), 114 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 115 | 116 | # freq 117 | expect_error(prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "s"), 118 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 119 | expect_error(prior_obj <- set_prior(Y = Y, freq = list(c(rep("m", 4), "s")), 120 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 121 | 122 | 123 | expect_error(prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 124 | aggregation = "triangular", 125 | n_lags = 4, n_burnin = 100, n_reps = 1000)) 126 | expect_error(prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 127 | aggregation = "average", 128 | n_lags = 2, n_burnin = 100, n_reps = 1000)) 129 | # Using update 130 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 131 | n_lags = 4, n_burnin = 100, n_reps = 300) 132 | prior_obj2 <- update_prior(prior_obj, d = "intercept", Y = Y[1:100, ], n_fcst = 4) 133 | expect_is(prior_obj2$d_fcst, "matrix") 134 | expect_is(prior_obj2$d, "matrix") 135 | 136 | prior_obj2 <- update_prior(prior_obj, d = "intercept", Y = Y[1:90, ]) 137 | prior_obj2 <- update_prior(prior_obj2, n_fcst = 4) 138 | expect_is(prior_obj2$d_fcst, "matrix") 139 | expect_true(all(dim(prior_obj2$d_fcst) == c(4, 1))) 140 | }) 141 | 142 | test_that("List as input, no names", { 143 | set.seed(10237) 144 | Y <- mfbvar::mf_sweden 145 | Y_list <- c(lapply(Y[,1:4], function(x) ts(x, frequency = 12, start = c(1996, 8))), 146 | list(gdp = ts(Y[seq(from = 2, to = nrow(Y), by = 3), 5], frequency = 4, start = c(1996, 3)))) 147 | names(Y_list) <- NULL 148 | set.seed(10237) 149 | prior_obj2 <- set_prior(Y = Y_list, n_lags = 4, n_burnin = 10, n_reps = 10) 150 | 151 | prior_intervals <- matrix(c( 6, 7, 152 | 0.1, 0.2, 153 | 0, 0.5, 154 | -0.5, 0.5, 155 | 0.4, 0.6), ncol = 2, byrow = TRUE) 156 | psi_moments <- interval_to_moments(prior_intervals) 157 | prior_psi_mean <- psi_moments$prior_psi_mean 158 | prior_psi_Omega <- psi_moments$prior_psi_Omega 159 | prior_obj2 <- update_prior(prior_obj2, d = "intercept", prior_psi_mean = prior_psi_mean, 160 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 161 | set.seed(10) 162 | mod_minn2 <- estimate_mfbvar(mfbvar_prior = prior_obj2, prior = "minn", n_fcst = 12) 163 | expect_error(predict(mod_minn2), NA) 164 | 165 | }) 166 | -------------------------------------------------------------------------------- /tests/testthat/test_plot.R: -------------------------------------------------------------------------------- 1 | library(mfbvar) 2 | context("Plots") 3 | test_that("Forecasts (minn)", { 4 | set.seed(10237) 5 | Y <- mfbvar::mf_sweden 6 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 7 | n_lags = 4, n_burnin = 10, n_reps = 10) 8 | 9 | prior_intervals <- matrix(c( 6, 7, 10 | 0.1, 0.2, 11 | 0, 0.5, 12 | -0.5, 0.5, 13 | 0.4, 0.6), ncol = 2, byrow = TRUE) 14 | psi_moments <- interval_to_moments(prior_intervals) 15 | prior_psi_mean <- psi_moments$prior_psi_mean 16 | prior_psi_Omega <- psi_moments$prior_psi_Omega 17 | prior_obj <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 18 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 19 | 20 | testthat::skip_on_cran() 21 | set.seed(10) 22 | mod_minn <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "minn", n_fcst = 12) 23 | 24 | expect_error(plot(mod_minn), NA) 25 | expect_error(plot(mod_minn, plot_start = "2013-07-31"), NA) 26 | 27 | rownames(Y) <- as.character(floor_date(as_date(rownames(Y)), unit = "month")) 28 | set.seed(10) 29 | mod_minn <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "minn", n_fcst = 12, 30 | Y = Y) 31 | expect_error(plot(mod_minn), NA) 32 | expect_error(plot(mod_minn, plot_start = "2013-07-01"), NA) 33 | 34 | rownames(Y) <- NULL 35 | 36 | set.seed(10) 37 | mod_minn <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "minn", n_fcst = 12, 38 | Y = Y) 39 | expect_error(plot(mod_minn)) 40 | }) 41 | 42 | test_that("Forecasts (ss)", { 43 | set.seed(10237) 44 | Y <- mfbvar::mf_sweden 45 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 46 | n_lags = 4, n_burnin = 10, n_reps = 10) 47 | 48 | prior_intervals <- matrix(c( 6, 7, 49 | 0.1, 0.2, 50 | 0, 0.5, 51 | -0.5, 0.5, 52 | 0.4, 0.6), ncol = 2, byrow = TRUE) 53 | psi_moments <- interval_to_moments(prior_intervals) 54 | prior_psi_mean <- psi_moments$prior_psi_mean 55 | prior_psi_Omega <- psi_moments$prior_psi_Omega 56 | prior_obj <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 57 | prior_psi_Omega = prior_psi_Omega, n_fcst = 12) 58 | 59 | testthat::skip_on_cran() 60 | set.seed(10) 61 | mod_ss <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "ss") 62 | 63 | expect_error(plot(mod_ss), NA) 64 | expect_error(plot(mod_ss, plot_start = "2013-07-31"), NA) 65 | 66 | rownames(Y) <- as.character(floor_date(as_date(rownames(Y)), unit = "month")) 67 | set.seed(10) 68 | mod_ss <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "ss", Y = Y) 69 | expect_error(plot(mod_ss), NA) 70 | expect_error(plot(mod_ss, plot_start = "2013-07-01"), NA) 71 | 72 | rownames(Y) <- NULL 73 | 74 | set.seed(10) 75 | mod_ss <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "ss", Y = Y) 76 | expect_error(plot(mod_ss)) 77 | }) 78 | 79 | test_that("Prior", { 80 | set.seed(10237) 81 | Y <- mfbvar::mf_sweden 82 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 83 | n_lags = 4, n_burnin = 10, n_reps = 10) 84 | expect_error(plot(prior_obj), NA) 85 | 86 | rownames(Y) <- NULL 87 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 88 | n_lags = 4, n_burnin = 10, n_reps = 10) 89 | plot(prior_obj) 90 | }) 91 | 92 | test_that("varplot", { 93 | set.seed(10237) 94 | Y <- mfbvar::mf_sweden 95 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 96 | n_lags = 4, n_burnin = 10, n_reps = 10, n_fac = 1) 97 | 98 | prior_intervals <- matrix(c( 6, 7, 99 | 0.1, 0.2, 100 | 0, 0.5, 101 | -0.5, 0.5, 102 | 0.4, 0.6), ncol = 2, byrow = TRUE) 103 | psi_moments <- interval_to_moments(prior_intervals) 104 | prior_psi_mean <- psi_moments$prior_psi_mean 105 | prior_psi_Omega <- psi_moments$prior_psi_Omega 106 | prior_obj <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 107 | prior_psi_Omega = prior_psi_Omega, n_fcst = 12) 108 | 109 | testthat::skip_on_cran() 110 | set.seed(10) 111 | mod_ss <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "ss", variance = "fsv") 112 | expect_error(varplot(mod_ss, variables = "gdp"), NA) 113 | 114 | rownames(Y) <- NULL 115 | set.seed(10) 116 | mod_ss <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "ss", Y = Y, variance = "fsv") 117 | expect_error(varplot(mod_ss, variables = "gdp"), NA) 118 | 119 | colnames(Y) <- NULL 120 | set.seed(10) 121 | mod_ss <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "ss", Y = Y, variance = "fsv") 122 | expect_error(varplot(mod_ss, variables = 1), NA) 123 | }) 124 | 125 | test_that("Weekly-Monthly plots", { 126 | set.seed(10237) 127 | Y <- matrix(rnorm(400), 100, 4) 128 | Y[setdiff(1:100,seq(4, 100, by = 4)), 4] <- NA 129 | 130 | prior_obj <- set_prior(Y = Y, freq = c(rep("w", 3), "m"), 131 | n_lags = 4, n_reps = 10) 132 | 133 | prior_intervals <- matrix(c( 134 | -0.5, 0.5, 135 | -0.5, 0.5, 136 | -0.5, 0.5, 137 | -0.5, 0.5), ncol = 2, byrow = TRUE) 138 | psi_moments <- interval_to_moments(prior_intervals) 139 | prior_psi_mean <- psi_moments$prior_psi_mean 140 | prior_psi_Omega <- psi_moments$prior_psi_Omega 141 | prior_obj <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 142 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 143 | 144 | testthat::skip_on_cran() 145 | set.seed(10) 146 | mod_ss <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "ss", variance = "csv") 147 | expect_error(varplot(mod_ss, variables = 1), NA) 148 | expect_error(plot(mod_ss)) 149 | }) 150 | 151 | -------------------------------------------------------------------------------- /tests/testthat/test_predict.R: -------------------------------------------------------------------------------- 1 | library(mfbvar) 2 | context("Predict") 3 | test_that("Forecasts (mf)", { 4 | set.seed(10237) 5 | Y <- mfbvar::mf_sweden 6 | rownames(Y) <- as.character(lubridate::floor_date(lubridate::ymd(rownames(Y)), unit = "months")) 7 | prior_obj <- set_prior(Y = Y, freq = c(rep("m", 4), "q"), 8 | n_lags = 4, n_burnin = 10, n_reps = 10) 9 | 10 | prior_intervals <- matrix(c( 6, 7, 11 | 0.1, 0.2, 12 | 0, 0.5, 13 | -0.5, 0.5, 14 | 0.4, 0.6), ncol = 2, byrow = TRUE) 15 | psi_moments <- interval_to_moments(prior_intervals) 16 | prior_psi_mean <- psi_moments$prior_psi_mean 17 | prior_psi_Omega <- psi_moments$prior_psi_Omega 18 | prior_obj <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 19 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 20 | 21 | testthat::skip_on_cran() 22 | set.seed(10) 23 | mod_minn <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "minn", n_fcst = 12) 24 | expect_equal(predict(mod_minn) %>% 25 | dplyr::filter(variable == "gdp") %>% 26 | .$median, 27 | c(median(colMeans(mod_minn$Z_fcst[2:4,5,])), 28 | median(colMeans(mod_minn$Z_fcst[5:7,5,])), 29 | median(colMeans(mod_minn$Z_fcst[8:10,5,])), 30 | median(colMeans(mod_minn$Z_fcst[11:13,5,])), 31 | median(colMeans(mod_minn$Z_fcst[14:16,5,])))) 32 | 33 | expect_equal(predict(mod_minn, aggregate_fcst = FALSE) %>% 34 | dplyr::filter(variable == "gdp") %>% 35 | .$median, 36 | c(apply(mod_minn$Z_fcst[-1,5,], 1, median), use.names = FALSE)) 37 | 38 | 39 | Y_list <- c(lapply(Y[,1:4], function(x) ts(x, frequency = 12, start = c(1996, 8))), 40 | list(gdp = ts(Y[seq(from = 2, to = nrow(Y), by = 3), 5], frequency = 4, start = c(1996, 3)))) 41 | 42 | set.seed(10237) 43 | prior_obj2 <- set_prior(Y = Y_list, n_lags = 4, n_burnin = 10, n_reps = 10) 44 | 45 | prior_intervals <- matrix(c( 6, 7, 46 | 0.1, 0.2, 47 | 0, 0.5, 48 | -0.5, 0.5, 49 | 0.4, 0.6), ncol = 2, byrow = TRUE) 50 | psi_moments <- interval_to_moments(prior_intervals) 51 | prior_psi_mean <- psi_moments$prior_psi_mean 52 | prior_psi_Omega <- psi_moments$prior_psi_Omega 53 | prior_obj2 <- update_prior(prior_obj2, d = "intercept", prior_psi_mean = prior_psi_mean, 54 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 55 | set.seed(10) 56 | mod_minn2 <- estimate_mfbvar(mfbvar_prior = prior_obj2, prior = "minn", n_fcst = 12) 57 | 58 | expect_equal(predict(mod_minn), predict(mod_minn2)) 59 | 60 | }) 61 | 62 | test_that("Forecasts (monthly)", { 63 | set.seed(10237) 64 | Y <- mfbvar::mf_sweden 65 | rownames(Y) <- as.character(lubridate::floor_date(lubridate::ymd(rownames(Y)), unit = "months")) 66 | prior_obj <- set_prior(Y = Y[, -5], freq = rep("m", 4), 67 | n_lags = 4, n_burnin = 10, n_reps = 10) 68 | 69 | prior_intervals <- matrix(c( 6, 7, 70 | 0.1, 0.2, 71 | 0, 0.5, 72 | -0.5, 0.5), ncol = 2, byrow = TRUE) 73 | psi_moments <- interval_to_moments(prior_intervals) 74 | prior_psi_mean <- psi_moments$prior_psi_mean 75 | prior_psi_Omega <- psi_moments$prior_psi_Omega 76 | prior_obj <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 77 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 78 | 79 | testthat::skip_on_cran() 80 | set.seed(10) 81 | mod_minn <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "minn", n_fcst = 12) 82 | expect_equal(predict(mod_minn) %>% 83 | dplyr::filter(variable == "eti") %>% 84 | pull(median), 85 | c(apply(mod_minn$Z_fcst[-(1:4),4,], 1, median), use.names = FALSE)) 86 | 87 | Y_list <- lapply(Y[,1:4], function(x) ts(x, frequency = 12, start = c(1996, 8))) 88 | 89 | set.seed(10237) 90 | prior_obj2 <- set_prior(Y = Y_list, n_lags = 4, n_burnin = 10, n_reps = 10) 91 | 92 | prior_intervals <- matrix(c( 6, 7, 93 | 0.1, 0.2, 94 | 0, 0.5, 95 | -0.5, 0.5), ncol = 2, byrow = TRUE) 96 | psi_moments <- interval_to_moments(prior_intervals) 97 | prior_psi_mean <- psi_moments$prior_psi_mean 98 | prior_psi_Omega <- psi_moments$prior_psi_Omega 99 | prior_obj2 <- update_prior(prior_obj2, d = "intercept", prior_psi_mean = prior_psi_mean, 100 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 101 | set.seed(10) 102 | mod_minn2 <- estimate_mfbvar(mfbvar_prior = prior_obj2, prior = "minn", n_fcst = 12) 103 | 104 | expect_equal(predict(mod_minn), predict(mod_minn2)) 105 | }) 106 | 107 | test_that("Forecasts (quarterly)", { 108 | set.seed(10237) 109 | Y <- mfbvar::mf_sweden 110 | rownames(Y) <- as.character(lubridate::floor_date(lubridate::ymd(rownames(Y)), unit = "months")) 111 | prior_obj <- set_prior(Y = Y[seq(2, nrow(Y), by = 3), ], freq = rep("q", 5), 112 | n_lags = 4, n_burnin = 10, n_reps = 10) 113 | 114 | prior_intervals <- matrix(c( 6, 7, 115 | 0.1, 0.2, 116 | 0, 0.5, 117 | -0.5, 0.5, 118 | 1, 3), ncol = 2, byrow = TRUE) 119 | psi_moments <- interval_to_moments(prior_intervals) 120 | prior_psi_mean <- psi_moments$prior_psi_mean 121 | prior_psi_Omega <- psi_moments$prior_psi_Omega 122 | prior_obj <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 123 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 124 | 125 | testthat::skip_on_cran() 126 | set.seed(10) 127 | mod_minn <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "minn", n_fcst = 12) 128 | expect_equal(predict(mod_minn) %>% 129 | dplyr::filter(variable == "eti") %>% 130 | pull(median), 131 | as.numeric(apply(mod_minn$Z_fcst[-(1:4),4,], 1, median))) 132 | 133 | Y <- Y[seq(2, nrow(Y), by = 3), ] 134 | Y_list <- lapply(Y, function(x) ts(x, frequency = 4, start = c(1996, 3))) 135 | 136 | set.seed(10237) 137 | prior_obj2 <- set_prior(Y = Y_list, n_lags = 4, n_burnin = 10, n_reps = 10) 138 | 139 | prior_intervals <- matrix(c( 6, 7, 140 | 0.1, 0.2, 141 | 0, 0.5, 142 | -0.5, 0.5, 143 | 1, 3), ncol = 2, byrow = TRUE) 144 | psi_moments <- interval_to_moments(prior_intervals) 145 | prior_psi_mean <- psi_moments$prior_psi_mean 146 | prior_psi_Omega <- psi_moments$prior_psi_Omega 147 | prior_obj2 <- update_prior(prior_obj2, d = "intercept", prior_psi_mean = prior_psi_mean, 148 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 149 | set.seed(10) 150 | mod_minn2 <- estimate_mfbvar(mfbvar_prior = prior_obj2, prior = "minn", n_fcst = 12) 151 | 152 | expect_equal(predict(mod_minn), predict(mod_minn2)) 153 | }) 154 | 155 | test_that("Forecasts (weekly-monthly)", { 156 | set.seed(10237) 157 | Y <- matrix(rnorm(400), 100, 4) 158 | Y[setdiff(1:100,seq(4, 100, by = 4)), 4] <- NA 159 | 160 | prior_obj <- set_prior(Y = Y, freq = c(rep("w", 3), "m"), 161 | n_lags = 4, n_reps = 10) 162 | 163 | prior_intervals <- matrix(c( 164 | -0.5, 0.5, 165 | -0.5, 0.5, 166 | -0.5, 0.5, 167 | -0.5, 0.5), ncol = 2, byrow = TRUE) 168 | psi_moments <- interval_to_moments(prior_intervals) 169 | prior_psi_mean <- psi_moments$prior_psi_mean 170 | prior_psi_Omega <- psi_moments$prior_psi_Omega 171 | prior_obj <- update_prior(prior_obj, d = "intercept", prior_psi_mean = prior_psi_mean, 172 | prior_psi_Omega = prior_psi_Omega, n_fcst = 4) 173 | 174 | testthat::skip_on_cran() 175 | set.seed(10) 176 | mod_minn <- estimate_mfbvar(mfbvar_prior = prior_obj, prior = "minn", n_fcst = 12) 177 | expect_equal(predict(mod_minn, aggregate_fcst = FALSE) %>% 178 | dplyr::filter(variable == 4) %>% 179 | .$median, 180 | c(apply(mod_minn$Z_fcst[-(1:4),4,], 1, median), use.names = FALSE)) 181 | 182 | }) 183 | -------------------------------------------------------------------------------- /vignettes/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/vignettes/.DS_Store -------------------------------------------------------------------------------- /vignettes/alfred_data.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/vignettes/alfred_data.RData -------------------------------------------------------------------------------- /vignettes/figures/ridges-1.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/vignettes/figures/ridges-1.pdf -------------------------------------------------------------------------------- /vignettes/figures/ss_plots-1.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/vignettes/figures/ss_plots-1.pdf -------------------------------------------------------------------------------- /vignettes/figures/ss_plots-2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/vignettes/figures/ss_plots-2.pdf -------------------------------------------------------------------------------- /vignettes/figures/varplot-1.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/vignettes/figures/varplot-1.pdf -------------------------------------------------------------------------------- /vignettes/figures/varplot-2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/vignettes/figures/varplot-2.pdf -------------------------------------------------------------------------------- /vignettes/vignette_data.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ankargren/mfbvar/85c543a2fdbc6f7f9503b7ff93af6b4c3c615b20/vignettes/vignette_data.RData --------------------------------------------------------------------------------