From af22332073148d76dfbeba79dbdf8a4612aefcdc Mon Sep 17 00:00:00 2001 From: jonlachmann Date: Thu, 26 Sep 2024 13:59:59 +0200 Subject: [PATCH] * Use roxygen for documentation. * Add the option to modify the priors of the bvarm model. --- .gitignore | 3 +- DESCRIPTION | 4 +- NAMESPACE | 83 ++++---- R/FEVD.R | 5 + R/Forecast.R | 456 ++++++++++++++++++++++------------------ R/IRF.R | 12 ++ R/Plot.R | 10 + R/States.R | 19 +- R/mode_check.R | 4 + R/zzz.R | 20 +- src/modules/bvarm_R.cpp | 4 +- 11 files changed, 359 insertions(+), 261 deletions(-) diff --git a/.gitignore b/.gitignore index b85777a..c4cd822 100644 --- a/.gitignore +++ b/.gitignore @@ -6,4 +6,5 @@ *.vscode /src/bmlib/include/armadillo* .Rproj.user -*.tmp \ No newline at end of file +*.tmp +.idea \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index ea92c6e..c789097 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -7,6 +7,7 @@ Author: Keith O'Hara Maintainer: Keith O'Hara Description: A package for estimating Bayesian macroeconometric models. License: GPL (>=2) +Encoding: UTF-8 Depends: R (>= 3.4.0), Rcpp (>= 0.12.2), @@ -22,4 +23,5 @@ RcppModules: bvarm_module, bvars_module, bvartvp_module, cvar_module, gensys_module, uhlig_module, dsge_gensys_module, dsge_uhlig_module, - dsgevar_gensys_module, dsgevar_uhlig_module \ No newline at end of file + dsgevar_gensys_module, dsgevar_uhlig_module +RoxygenNote: 7.3.2 diff --git a/NAMESPACE b/NAMESPACE index 24b273e..ad2f3db 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,39 +1,48 @@ -useDynLib(BMR) - -import(ggplot2) -importFrom(Rcpp, evalCpp) -importFrom(grid, grid.newpage, viewport, pushViewport, grid.layout) -importFrom("grDevices", "cairo_ps", "dev.list", "dev.off") -importFrom("stats", "acf", "embed", "optim", "pacf", "qnorm", "rnorm", "runif", "sd", "var") - -exportClasses("Rcpp_bvarm") -exportClasses("Rcpp_bvars") -exportClasses("Rcpp_bvarcnw") -exportClasses("Rcpp_bvarinw") -exportClasses("Rcpp_cvar") -exportClasses("Rcpp_bvartvp") -exportClasses("Rcpp_gensys") -exportClasses("Rcpp_uhlig") -exportClasses("Rcpp_dsge_gensys") -exportClasses("Rcpp_dsgevar_gensys") - -export(FEVD,IRF,IRFcomp,forecast,mode_check,prior,gtsplot) +# Generated by roxygen2: do not edit by hand +S3method(FEVD,Rcpp_bvarcnw) +S3method(FEVD,Rcpp_bvarinw) +S3method(FEVD,Rcpp_bvarm) +S3method(FEVD,Rcpp_bvars) +S3method(FEVD,Rcpp_cvar) +S3method(IRF,Rcpp_bvarcnw) +S3method(IRF,Rcpp_bvarinw) +S3method(IRF,Rcpp_bvarm) +S3method(IRF,Rcpp_bvars) +S3method(IRF,Rcpp_bvartvp) +S3method(IRF,Rcpp_cvar) +S3method(IRF,Rcpp_dsge_gensys) +S3method(IRF,Rcpp_dsge_uhlig) +S3method(IRF,Rcpp_dsgevar_gensys) +S3method(IRF,Rcpp_dsgevar_uhlig) +S3method(IRF,Rcpp_gensys) +S3method(IRF,Rcpp_uhlig) +S3method(forecast,Rcpp_bvarcnw) +S3method(forecast,Rcpp_bvarinw) +S3method(forecast,Rcpp_bvarm) +S3method(forecast,Rcpp_bvars) +S3method(forecast,Rcpp_cvar) +S3method(forecast,Rcpp_dsge_gensys) +S3method(forecast,Rcpp_dsge_uhlig) +S3method(forecast,Rcpp_dsgevar_gensys) +S3method(forecast,Rcpp_dsgevar_uhlig) +S3method(mode_check,Rcpp_dsge_gensys) +S3method(mode_check,Rcpp_dsge_uhlig) +S3method(mode_check,Rcpp_dsgevar_gensys) +S3method(mode_check,Rcpp_dsgevar_uhlig) +S3method(plot,Rcpp_bvarcnw) +S3method(plot,Rcpp_bvarinw) +S3method(plot,Rcpp_bvarm) +S3method(plot,Rcpp_bvars) +S3method(plot,Rcpp_bvartvp) +S3method(plot,Rcpp_cvar) +S3method(plot,Rcpp_dsge_gensys) +S3method(plot,Rcpp_dsge_uhlig) +S3method(plot,Rcpp_dsgevar_gensys) +S3method(plot,Rcpp_dsgevar_uhlig) +S3method(states,Rcpp_dsge_uhlig) +S3method(states,Rcpp_dsgevar_gensys) +S3method(states,Rcpp_dsgevar_uhlig) exportPattern("^[[:alpha:]]+") - -S3method(plot, Rcpp_bvarm) -S3method(plot, Rcpp_bvars) -S3method(plot, Rcpp_bvarcnw) -S3method(plot, Rcpp_bvarinw) -S3method(plot, Rcpp_bvartvp) -S3method(plot, Rcpp_dsge_gensys) -S3method(plot, Rcpp_dsgevar_gensys) - -S3method(forecast, Rcpp_bvarm) -S3method(forecast, Rcpp_bvars) -S3method(forecast, Rcpp_bvarcnw) -S3method(forecast, Rcpp_bvarinw) -S3method(forecast, Rcpp_cvar) - -S3method(mode_check, Rcpp_dsge_gensys) -S3method(mode_check, Rcpp_dsgevar_gensys) +importFrom(Rcpp,evalCpp) +useDynLib(BMR, .registration = TRUE) diff --git a/R/FEVD.R b/R/FEVD.R index 44de3ee..8bf3c7c 100644 --- a/R/FEVD.R +++ b/R/FEVD.R @@ -16,6 +16,7 @@ ## ################################################################################ +#' @export FEVD.Rcpp_bvarm <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE, save=FALSE,save_format=c("pdf","eps"), @@ -25,6 +26,7 @@ FEVD.Rcpp_bvarm <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.50, save,save_format,save_title,height,width) } +#' @export FEVD.Rcpp_bvars <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE, save=FALSE,save_format=c("pdf","eps"), @@ -34,6 +36,7 @@ FEVD.Rcpp_bvars <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.50, save,save_format,save_title,height,width) } +#' @export FEVD.Rcpp_bvarcnw <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE, save=FALSE,save_format=c("pdf","eps"), @@ -43,6 +46,7 @@ FEVD.Rcpp_bvarcnw <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.5 save,save_format,save_title,height,width) } +#' @export FEVD.Rcpp_bvarinw <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE, save=FALSE,save_format=c("pdf","eps"), @@ -52,6 +56,7 @@ FEVD.Rcpp_bvarinw <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.5 save,save_format,save_title,height,width) } +#' @export FEVD.Rcpp_cvar <- function(obj,periods=10,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE, save=FALSE,save_format=c("pdf","eps"), diff --git a/R/Forecast.R b/R/Forecast.R index 9374dd8..7b3b6a2 100644 --- a/R/Forecast.R +++ b/R/Forecast.R @@ -16,263 +16,301 @@ ## ################################################################################ -forecast.Rcpp_bvarm <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_var(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_bvarm <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_var(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } -forecast.Rcpp_bvars <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_var(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_bvars <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_var(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } -forecast.Rcpp_bvarcnw <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_var(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_bvarcnw <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_var(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } -forecast.Rcpp_bvarinw <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_var(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_bvarinw <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_var(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } -forecast.Rcpp_cvar <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_var(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_cvar <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_var(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } -forecast.Rcpp_dsge_gensys <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_dsge(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_dsge_gensys <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_dsge(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } -forecast.Rcpp_dsge_uhlig <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_dsge(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_dsge_uhlig <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_dsge(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } -forecast.Rcpp_dsgevar_gensys <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_var(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_dsgevar_gensys <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_var(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } -forecast.Rcpp_dsgevar_uhlig <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11,...) -{ - return=.forecast_var(obj,periods,shocks,plot,var_names,percentiles,use_mean,back_data,save,height,width) +#' @export +forecast.Rcpp_dsgevar_uhlig <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11, ...) { + return <- .forecast_var(obj, periods, shocks, plot, var_names, percentiles, use_mean, back_data, save, height, width) } # -.forecast_var <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11) -{ - M <- obj$M - n_draws <- dim(obj$beta_draws)[3] +.forecast_var <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11) { + M <- obj$M + n_draws <- dim(obj$beta_draws)[3] - forecast_cube = obj$forecast(periods,shocks)$forecast_vals + forecast_cube <- obj$forecast(periods, shocks)$forecast_vals - Y <- obj$Y + Y <- obj$Y - # + # + + forecast_sorted <- apply(forecast_cube, c(1, 2), sort) + forecast_sorted <- aperm(forecast_sorted, c(2, 3, 1)) + forecast_mean <- apply(forecast_sorted, c(1, 2), mean) + + upper_conf <- round(percentiles[3] * n_draws) + mid_conf <- round(percentiles[2] * n_draws) + lower_conf <- round(percentiles[1] * n_draws) + + # + # Plot - forecast_sorted <- apply(forecast_cube,c(1,2),sort) - forecast_sorted <- aperm(forecast_sorted,c(2,3,1)) - forecast_mean <- apply(forecast_sorted,c(1,2),mean) - - upper_conf <- round(percentiles[3]*n_draws) - mid_conf <- round(percentiles[2]*n_draws) - lower_conf <- round(percentiles[1]*n_draws) + Time <- FCL <- FCU <- FCM <- NULL + + # + + plot_vals <- array(NA, dim = c((periods + back_data), 4, M)) + + for (i in 1:M) { + FDataTemp <- 0 + + if (use_mean == TRUE) { # Use the mean or middle percentile? + FDataTemp <- data.frame(forecast_sorted[, i, lower_conf], forecast_mean[, i], forecast_sorted[, i, upper_conf]) + } else { + FDataTemp <- data.frame(forecast_sorted[, i, lower_conf], forecast_sorted[, i, mid_conf], forecast_sorted[, i, upper_conf]) + } + + FDataTemp <- as.matrix(FDataTemp) # - # Plot - - Time <- FCL <- FCU <- FCM <- NULL - + + if (back_data > 0) { + FDataTemp <- rbind(matrix(rep(Y[(nrow(Y) - back_data + 1):nrow(Y), i], 3), ncol = 3), FDataTemp) + } + + FDataTemp <- cbind(FDataTemp, (as.numeric(nrow(Y)) - back_data + 1):(nrow(Y) + periods)) + plot_vals[, , i] <- FDataTemp + } + + # + + if (plot) { + vplayout <- function(x, y) { + viewport(layout.pos.row = x, layout.pos.col = y) + } + + if (save == TRUE) { + if (class(dev.list()) != "NULL") { + dev.off() + } + cairo_ps(filename = "Forecast.eps", height = height, width = width) + } + # - - plot_vals <- array(NA,dim=c((periods+back_data),4,M)) - - for (i in 1:M) { - FDataTemp <- 0 - - if (use_mean == TRUE) { # Use the mean or middle percentile? - FDataTemp <- data.frame(forecast_sorted[,i,lower_conf],forecast_mean[,i],forecast_sorted[,i,upper_conf]) - } else { - FDataTemp <- data.frame(forecast_sorted[,i,lower_conf],forecast_sorted[,i,mid_conf],forecast_sorted[,i,upper_conf]) - } - - FDataTemp <- as.matrix(FDataTemp) - - # - - if(back_data > 0){ - FDataTemp <- rbind(matrix(rep(Y[(nrow(Y)-back_data+1):nrow(Y),i],3),ncol=3),FDataTemp) - } - - FDataTemp <- cbind(FDataTemp,(as.numeric(nrow(Y))-back_data+1):(nrow(Y)+periods)) - plot_vals[,,i] <- FDataTemp + + grid.newpage() + pushViewport(viewport(layout = grid.layout(M, 1))) + + if (class(var_names) != "character") { + var_names <- character(length = M) + for (i in 1:M) { + var_names[i] <- paste("VAR", i, sep = "") + } } - + # - if (plot) - { - vplayout <- function(x,y){viewport(layout.pos.row=x, layout.pos.col=y)} - - if (save==TRUE) { - if(class(dev.list()) != "NULL"){dev.off()} - cairo_ps(filename="Forecast.eps",height=height,width=width) - } - + if (back_data > 0) { + # Include a dashed line to mark where the forecast begins + for (i in 1:M) { + FCastName <- var_names[i] + FCDF <- plot_vals[, , i] + FCDF <- data.frame(FCDF) + colnames(FCDF) <- c("FCL", "FCM", "FCU", "Time") + # + print(ggplot(data = FCDF, aes(x = Time)) + + xlab("Time") + + ylab(paste("Forecast of ", FCastName)) + + geom_ribbon(aes(ymin = FCL, ymax = FCU), color = "blue", lty = 1, fill = "blue", alpha = 0.2, size = 0.1) + + geom_hline(yintercept = 0, colour = "grey30") + + geom_vline(xintercept = as.numeric(nrow(Y)), linetype = "longdash") + + geom_line(aes(y = FCM), color = "red", size = 2) + + theme(panel.background = element_rect(fill = "white", colour = "grey15")) + + theme(panel.grid.major = element_line(colour = "grey89")), vp = vplayout(i, 1)) # - - grid.newpage() - pushViewport(viewport(layout=grid.layout(M,1))) - - if (class(var_names) != "character") { - var_names <- character(length=M) - for (i in 1:M) { - var_names[i] <- paste("VAR",i,sep="") - } - } - + Sys.sleep(0.6) + } + } else { + for (i in 1:M) { + FCastName <- var_names[i] + FCDF <- plot_vals[, , i] + FCDF <- data.frame(FCDF) + colnames(FCDF) <- c("FCL", "FCM", "FCU", "Time") # - - if (back_data > 0) { - # Include a dashed line to mark where the forecast begins - for (i in 1:M) { - FCastName <- var_names[i] - FCDF <- plot_vals[,,i] - FCDF <- data.frame(FCDF) - colnames(FCDF) <- c("FCL","FCM","FCU","Time") - # - print(ggplot(data=FCDF,aes(x=Time)) + xlab("Time") + ylab(paste("Forecast of ",FCastName)) + geom_ribbon(aes(ymin=FCL,ymax=FCU),color="blue",lty=1,fill="blue",alpha=0.2,size=0.1) + geom_hline(yintercept=0,colour='grey30') + geom_vline(xintercept=as.numeric(nrow(Y)),linetype = "longdash") + geom_line(aes(y=FCM),color="red",size=2) + theme(panel.background = element_rect(fill='white', colour='grey15')) + theme(panel.grid.major = element_line(colour = 'grey89')),vp = vplayout(i,1)) - # - Sys.sleep(0.6) - } - } else { - for (i in 1:M) { - FCastName <- var_names[i] - FCDF <- plot_vals[,,i] - FCDF <- data.frame(FCDF) - colnames(FCDF) <- c("FCL","FCM","FCU","Time") - # - print(ggplot(data=FCDF,aes(x=Time)) + xlab("Time") + ylab(paste("Forecast of ",FCastName)) + geom_ribbon(aes(ymin=FCL,ymax=FCU),color="blue",lty=1,fill="blue",alpha=0.2,size=0.1) + geom_hline(yintercept=0,colour='grey30') + geom_line(aes(y=FCM),color="red",size=2) + theme(panel.background = element_rect(fill='white', colour='grey15')) + theme(panel.grid.major = element_line(colour = 'grey89')),vp = vplayout(i,1)) - # - Sys.sleep(0.6) - } - } - - if(save==TRUE){dev.off()} + print(ggplot(data = FCDF, aes(x = Time)) + + xlab("Time") + + ylab(paste("Forecast of ", FCastName)) + + geom_ribbon(aes(ymin = FCL, ymax = FCU), color = "blue", lty = 1, fill = "blue", alpha = 0.2, size = 0.1) + + geom_hline(yintercept = 0, colour = "grey30") + + geom_line(aes(y = FCM), color = "red", size = 2) + + theme(panel.background = element_rect(fill = "white", colour = "grey15")) + + theme(panel.grid.major = element_line(colour = "grey89")), vp = vplayout(i, 1)) + # + Sys.sleep(0.6) + } } - # + if (save == TRUE) { + dev.off() + } + } + + # - return=list(forecast_mean=forecast_mean,plot_vals=plot_vals) + return <- list(forecast_mean = forecast_mean, plot_vals = plot_vals) } -.forecast_dsge <- function(obj,periods=20,shocks=TRUE,plot=TRUE,var_names=NULL,percentiles=c(.05,.50,.95),use_mean=FALSE,back_data=0,save=FALSE,height=13,width=11) -{ - forecast_cube = obj$forecast(periods,shocks)$forecast_vals +.forecast_dsge <- function(obj, periods = 20, shocks = TRUE, plot = TRUE, var_names = NULL, percentiles = c(.05, .50, .95), use_mean = FALSE, back_data = 0, save = FALSE, height = 13, width = 11) { + forecast_cube <- obj$forecast(periods, shocks)$forecast_vals - M <- dim(forecast_cube)[2] - n_draws <- dim(forecast_cube)[3] + M <- dim(forecast_cube)[2] + n_draws <- dim(forecast_cube)[3] - Y <- obj$estim_data + Y <- obj$estim_data - # + # - forecast_sorted <- apply(forecast_cube,c(1,2),sort) - forecast_sorted <- aperm(forecast_sorted,c(2,3,1)) - forecast_mean <- apply(forecast_sorted,c(1,2),mean) - - upper_conf <- round(percentiles[3]*n_draws) - mid_conf <- round(percentiles[2]*n_draws) - lower_conf <- round(percentiles[1]*n_draws) + forecast_sorted <- apply(forecast_cube, c(1, 2), sort) + forecast_sorted <- aperm(forecast_sorted, c(2, 3, 1)) + forecast_mean <- apply(forecast_sorted, c(1, 2), mean) + + upper_conf <- round(percentiles[3] * n_draws) + mid_conf <- round(percentiles[2] * n_draws) + lower_conf <- round(percentiles[1] * n_draws) + + # + # Plot + + Time <- FCL <- FCU <- FCM <- NULL + + # + + plot_vals <- array(NA, dim = c((periods + back_data), 4, M)) + + for (i in 1:M) { + FDataTemp <- 0 + + if (use_mean == TRUE) { # Use the mean or middle percentile? + FDataTemp <- data.frame(forecast_sorted[, i, lower_conf], forecast_mean[, i], forecast_sorted[, i, upper_conf]) + } else { + FDataTemp <- data.frame(forecast_sorted[, i, lower_conf], forecast_sorted[, i, mid_conf], forecast_sorted[, i, upper_conf]) + } + + FDataTemp <- as.matrix(FDataTemp) # - # Plot - - Time <- FCL <- FCU <- FCM <- NULL - + + if (back_data > 0) { + FDataTemp <- rbind(matrix(rep(Y[(nrow(Y) - back_data + 1):nrow(Y), i], 3), ncol = 3), FDataTemp) + } + + FDataTemp <- cbind(FDataTemp, (as.numeric(nrow(Y)) - back_data + 1):(nrow(Y) + periods)) + plot_vals[, , i] <- FDataTemp + } + + # + + if (plot) { + vplayout <- function(x, y) { + viewport(layout.pos.row = x, layout.pos.col = y) + } + + if (save == TRUE) { + if (class(dev.list()) != "NULL") { + dev.off() + } + cairo_ps(filename = "Forecast.eps", height = height, width = width) + } + # - - plot_vals <- array(NA,dim=c((periods+back_data),4,M)) - - for (i in 1:M) { - FDataTemp <- 0 - - if (use_mean == TRUE) { # Use the mean or middle percentile? - FDataTemp <- data.frame(forecast_sorted[,i,lower_conf],forecast_mean[,i],forecast_sorted[,i,upper_conf]) - } else { - FDataTemp <- data.frame(forecast_sorted[,i,lower_conf],forecast_sorted[,i,mid_conf],forecast_sorted[,i,upper_conf]) - } - - FDataTemp <- as.matrix(FDataTemp) - - # - - if(back_data > 0){ - FDataTemp <- rbind(matrix(rep(Y[(nrow(Y)-back_data+1):nrow(Y),i],3),ncol=3),FDataTemp) - } - - FDataTemp <- cbind(FDataTemp,(as.numeric(nrow(Y))-back_data+1):(nrow(Y)+periods)) - plot_vals[,,i] <- FDataTemp + + grid.newpage() + pushViewport(viewport(layout = grid.layout(M, 1))) + + if (class(var_names) != "character") { + var_names <- character(length = M) + for (i in 1:M) { + var_names[i] <- paste("VAR", i, sep = "") + } } - + # - if (plot) - { - vplayout <- function(x,y){viewport(layout.pos.row=x, layout.pos.col=y)} - - if (save==TRUE) { - if(class(dev.list()) != "NULL"){dev.off()} - cairo_ps(filename="Forecast.eps",height=height,width=width) - } - + if (back_data > 0) { + # Include a dashed line to mark where the forecast begins + for (i in 1:M) { + FCastName <- var_names[i] + FCDF <- plot_vals[, , i] + FCDF <- data.frame(FCDF) + colnames(FCDF) <- c("FCL", "FCM", "FCU", "Time") # - - grid.newpage() - pushViewport(viewport(layout=grid.layout(M,1))) - - if (class(var_names) != "character") { - var_names <- character(length=M) - for (i in 1:M) { - var_names[i] <- paste("VAR",i,sep="") - } - } - + print(ggplot(data = FCDF, aes(x = Time)) + + xlab("Time") + + ylab(paste("Forecast of ", FCastName)) + + geom_ribbon(aes(ymin = FCL, ymax = FCU), color = "blue", lty = 1, fill = "blue", alpha = 0.2, size = 0.1) + + geom_hline(yintercept = 0, colour = "grey30") + + geom_vline(xintercept = as.numeric(nrow(Y)), linetype = "longdash") + + geom_line(aes(y = FCM), color = "red", size = 2) + + theme(panel.background = element_rect(fill = "white", colour = "grey15")) + + theme(panel.grid.major = element_line(colour = "grey89")), vp = vplayout(i, 1)) # - - if (back_data > 0) { - # Include a dashed line to mark where the forecast begins - for (i in 1:M) { - FCastName <- var_names[i] - FCDF <- plot_vals[,,i] - FCDF <- data.frame(FCDF) - colnames(FCDF) <- c("FCL","FCM","FCU","Time") - # - print(ggplot(data=FCDF,aes(x=Time)) + xlab("Time") + ylab(paste("Forecast of ",FCastName)) + geom_ribbon(aes(ymin=FCL,ymax=FCU),color="blue",lty=1,fill="blue",alpha=0.2,size=0.1) + geom_hline(yintercept=0,colour='grey30') + geom_vline(xintercept=as.numeric(nrow(Y)),linetype = "longdash") + geom_line(aes(y=FCM),color="red",size=2) + theme(panel.background = element_rect(fill='white', colour='grey15')) + theme(panel.grid.major = element_line(colour = 'grey89')),vp = vplayout(i,1)) - # - Sys.sleep(0.6) - } - } else { - for (i in 1:M) { - FCastName <- var_names[i] - FCDF <- plot_vals[,,i] - FCDF <- data.frame(FCDF) - colnames(FCDF) <- c("FCL","FCM","FCU","Time") - # - print(ggplot(data=FCDF,aes(x=Time)) + xlab("Time") + ylab(paste("Forecast of ",FCastName)) + geom_ribbon(aes(ymin=FCL,ymax=FCU),color="blue",lty=1,fill="blue",alpha=0.2,size=0.1) + geom_hline(yintercept=0,colour='grey30') + geom_line(aes(y=FCM),color="red",size=2) + theme(panel.background = element_rect(fill='white', colour='grey15')) + theme(panel.grid.major = element_line(colour = 'grey89')),vp = vplayout(i,1)) - # - Sys.sleep(0.6) - } - } - - if(save==TRUE){dev.off()} + Sys.sleep(0.6) + } + } else { + for (i in 1:M) { + FCastName <- var_names[i] + FCDF <- plot_vals[, , i] + FCDF <- data.frame(FCDF) + colnames(FCDF) <- c("FCL", "FCM", "FCU", "Time") + # + print(ggplot(data = FCDF, aes(x = Time)) + + xlab("Time") + + ylab(paste("Forecast of ", FCastName)) + + geom_ribbon(aes(ymin = FCL, ymax = FCU), color = "blue", lty = 1, fill = "blue", alpha = 0.2, size = 0.1) + + geom_hline(yintercept = 0, colour = "grey30") + + geom_line(aes(y = FCM), color = "red", size = 2) + + theme(panel.background = element_rect(fill = "white", colour = "grey15")) + + theme(panel.grid.major = element_line(colour = "grey89")), vp = vplayout(i, 1)) + # + Sys.sleep(0.6) + } } - - # - - return=list(forecast_mean=forecast_mean,plot_vals=plot_vals) + + if (save == TRUE) { + dev.off() + } + } + + # + + return <- list(forecast_mean = forecast_mean, plot_vals = plot_vals) } diff --git a/R/IRF.R b/R/IRF.R index 13f20ea..dc01c59 100644 --- a/R/IRF.R +++ b/R/IRF.R @@ -16,6 +16,7 @@ ## ################################################################################ +#' @export IRF.Rcpp_bvarm <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE,save=FALSE,save_format=c("pdf","eps"), save_title=NULL,height=13,width=13,...) @@ -24,6 +25,7 @@ IRF.Rcpp_bvarm <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var_n save,save_format,save_title,height,width) } +#' @export IRF.Rcpp_bvars <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE,save=FALSE,save_format=c("pdf","eps"), save_title=NULL,height=13,width=13,...) @@ -32,6 +34,7 @@ IRF.Rcpp_bvars <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var_n save,save_format,save_title,height,width) } +#' @export IRF.Rcpp_bvarcnw <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE,save=FALSE,save_format=c("pdf","eps"), save_title=NULL,height=13,width=13,...) @@ -40,6 +43,7 @@ IRF.Rcpp_bvarcnw <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var save,save_format,save_title,height,width) } +#' @export IRF.Rcpp_bvarinw <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE,save=FALSE,save_format=c("pdf","eps"), save_title=NULL,height=13,width=13,...) @@ -48,6 +52,7 @@ IRF.Rcpp_bvarinw <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var save,save_format,save_title,height,width) } +#' @export IRF.Rcpp_cvar <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,shocks_row_order=TRUE,save=FALSE,save_format=c("pdf","eps"), save_title=NULL,height=13,width=13,...) @@ -56,37 +61,44 @@ IRF.Rcpp_cvar <- function(obj,periods=10,cumulative=FALSE,cumul_inds=NULL,var_na save,save_format,save_title,height,width) } +#' @export IRF.Rcpp_bvartvp <- function(obj,periods=10,which_irfs=NULL,var_names=NULL,percentiles=c(.05,.50,.95), which_shock=NULL,which_response=NULL,save=FALSE,height=13,width=13,...) { .irf_bvartvp(obj,periods,which_irfs,var_names,percentiles,which_shock,which_response,save,height,width) } +#' @export IRF.Rcpp_gensys <- function(obj,periods=10,var_names=NULL,shocks_cov=NULL,save=FALSE,height=13,width=13,...) { .irf_dsge(obj,periods,var_names,shocks_cov,save,height,width) } +#' @export IRF.Rcpp_uhlig <- function(obj,periods=10,var_names=NULL,shocks_cov=NULL,save=FALSE,height=13,width=13,...) { .irf_dsge(obj,periods,var_names,shocks_cov,save,height,width) } +#' @export IRF.Rcpp_dsge_gensys <- function(obj,periods=10,obs_irfs=FALSE,var_names=NULL,percentiles=c(.05,.50,.95),save=FALSE,height=13,width=13,...) { .irf_edsge(obj,periods,obs_irfs,var_names,percentiles,save,height,width) } +#' @export IRF.Rcpp_dsge_uhlig <- function(obj,periods=10,obs_irfs=FALSE,var_names=NULL,percentiles=c(.05,.50,.95),save=FALSE,height=13,width=13,...) { .irf_edsge(obj,periods,obs_irfs,var_names,percentiles,save,height,width) } +#' @export IRF.Rcpp_dsgevar_gensys <- function(obj,periods,var_names=NULL,percentiles=c(.05,.50,.95),plot_comparison=TRUE,save=FALSE,height=13,width=13,...) { .irf_dsgevar(obj,periods,var_names,percentiles,plot_comparison,save,height,width) } +#' @export IRF.Rcpp_dsgevar_uhlig <- function(obj,periods,var_names=NULL,percentiles=c(.05,.50,.95),plot_comparison=TRUE,save=FALSE,height=13,width=13,...) { .irf_dsgevar(obj,periods,var_names,percentiles,plot_comparison,save,height,width) diff --git a/R/Plot.R b/R/Plot.R index 2164cc0..8a170c4 100644 --- a/R/Plot.R +++ b/R/Plot.R @@ -16,51 +16,61 @@ ## ################################################################################ +#' @export plot.Rcpp_bvarm <- function(x,type=1,var_names=NULL,save=FALSE,height=13,width=13,...) { .plotbvar(x,type,var_names,save,height,width) } +#' @export plot.Rcpp_bvars <- function(x,type=1,var_names=NULL,save=FALSE,height=13,width=13,...) { .plotbvar(x,type,var_names,save,height,width) } +#' @export plot.Rcpp_bvarcnw <- function(x,type=1,var_names=NULL,save=FALSE,height=13,width=13,...) { .plotbvar(x,type,var_names,save,height,width) } +#' @export plot.Rcpp_bvarinw <- function(x,type=1,var_names=NULL,save=FALSE,height=13,width=13,...) { .plotbvar(x,type,var_names,save,height,width) } +#' @export plot.Rcpp_bvartvp <- function(x,var_names=NULL,percentiles=c(.05,.50,.95),save=FALSE,height=13,width=13,...) { .plotbvartvp(x,var_names,percentiles,save,height,width) } +#' @export plot.Rcpp_cvar <- function(x,type=1,var_names=NULL,save=FALSE,height=13,width=13,...) { .plotbvar(x,type,var_names,save,height,width) } +#' @export plot.Rcpp_dsge_gensys <- function(x,par_names=NULL,BinDenom=40,trace_plot=FALSE,save=FALSE,height=13,width=13,...) { .plotedsge(x,par_names,BinDenom,trace_plot,save,height,width) } +#' @export plot.Rcpp_dsge_uhlig <- function(x,par_names=NULL,BinDenom=40,trace_plot=FALSE,save=FALSE,height=13,width=13,...) { .plotedsge(x,par_names,BinDenom,trace_plot,save,height,width) } +#' @export plot.Rcpp_dsgevar_gensys <- function(x,par_names=NULL,BinDenom=40,MCMCplot=FALSE,save=FALSE,height=13,width=13,...) { .plotdsgevar(x,par_names,BinDenom,MCMCplot,save,height,width) } +#' @export plot.Rcpp_dsgevar_uhlig <- function(x,par_names=NULL,BinDenom=40,MCMCplot=FALSE,save=FALSE,height=13,width=13,...) { .plotdsgevar(x,par_names,BinDenom,MCMCplot,save,height,width) diff --git a/R/States.R b/R/States.R index a10c79c..e5189f0 100644 --- a/R/States.R +++ b/R/States.R @@ -21,16 +21,19 @@ states.Rcpp_dsge_gensys <- function(obj,percentiles=c(.05,.50,.95),var_names=NUL return=.states_int(obj,percentiles,var_names,use_mean,save,height,width) } +#' @export states.Rcpp_dsge_uhlig <- function(obj,percentiles=c(.05,.50,.95),var_names=NULL,use_mean=FALSE,save=FALSE,height=13,width=11,...) { return=.states_int(obj,percentiles,var_names,use_mean,save,height,width) } +#' @export states.Rcpp_dsgevar_gensys <- function(obj,percentiles=c(.05,.50,.95),var_names=NULL,use_mean=FALSE,save=FALSE,height=13,width=11,...) { return=.states_int(obj,percentiles,var_names,use_mean,save,height,width) } +#' @export states.Rcpp_dsgevar_uhlig <- function(obj,percentiles=c(.05,.50,.95),var_names=NULL,use_mean=FALSE,save=FALSE,height=13,width=11,...) { return=.states_int(obj,percentiles,var_names,use_mean,save,height,width) @@ -40,7 +43,7 @@ states.Rcpp_dsgevar_uhlig <- function(obj,percentiles=c(.05,.50,.95),var_names=N .states_int <- function(obj,percentiles=c(.05,.50,.95),var_names=NULL,use_mean=FALSE,save=FALSE,height=13,width=11,...) { - + n_draws <- dim(obj$dsge_draws)[1] if (n_draws <= 0) { @@ -50,10 +53,10 @@ states.Rcpp_dsgevar_uhlig <- function(obj,percentiles=c(.05,.50,.95),var_names=N # filt_vals <- obj$states()$filter_vals - + n_data <- dim(filt_vals)[1] n_states <- dim(filt_vals)[2] - + filt_vals_sorted <- apply(filt_vals,c(1,2),sort) filt_vals_sorted <- aperm(filt_vals_sorted,c(2,3,1)) @@ -64,7 +67,7 @@ states.Rcpp_dsgevar_uhlig <- function(obj,percentiles=c(.05,.50,.95),var_names=N upper_conf <- round(percentiles[3]*n_draws) mid_conf <- round(percentiles[2]*n_draws) lower_conf <- round(percentiles[1]*n_draws) - + # plot_vals <- array(NA,dim=c(n_data,4,n_states)) @@ -89,11 +92,11 @@ states.Rcpp_dsgevar_uhlig <- function(obj,percentiles=c(.05,.50,.95),var_names=N if (class(var_names) != "character") { var_names <- character(length=n_states) - for (i in 1:n_states) { + for (i in 1:n_states) { var_names[i] <- paste("VAR",i,sep="") } } - + # # plotting @@ -103,7 +106,7 @@ states.Rcpp_dsgevar_uhlig <- function(obj,percentiles=c(.05,.50,.95),var_names=N MR <- 0; MC <- 0 plot_pages <- 1 - + if(n_states < 4){ MR <- n_states; MC <- 1 }else if(n_states == 4){ @@ -136,7 +139,7 @@ states.Rcpp_dsgevar_uhlig <- function(obj,percentiles=c(.05,.50,.95),var_names=N state_count <- 1 for (j in 1:plot_pages) { - + if(save==TRUE){ if(class(dev.list()) != "NULL"){dev.off()} diff --git a/R/mode_check.R b/R/mode_check.R index bd51304..ee26143 100644 --- a/R/mode_check.R +++ b/R/mode_check.R @@ -15,18 +15,22 @@ ## ################################################################################ +#' @export mode_check.Rcpp_dsge_gensys <- function(obj,mode_vals=NULL,grid_size=201,scale_val=1,par_names=NULL,save=FALSE,height=13,width=13,...){ .mode_check_int(obj,mode_vals,grid_size,scale_val,par_names,save,height,width) } +#' @export mode_check.Rcpp_dsge_uhlig <- function(obj,mode_vals=NULL,grid_size=201,scale_val=1,par_names=NULL,save=FALSE,height=13,width=13,...){ .mode_check_int(obj,mode_vals,grid_size,scale_val,par_names,save,height,width) } +#' @export mode_check.Rcpp_dsgevar_gensys <- function(obj,mode_vals=NULL,grid_size=201,scale_val=1,par_names=NULL,save=FALSE,height=13,width=13,...){ .mode_check_int(obj,mode_vals,grid_size,scale_val,par_names,save,height,width) } +#' @export mode_check.Rcpp_dsgevar_uhlig <- function(obj,mode_vals=NULL,grid_size=201,scale_val=1,par_names=NULL,save=FALSE,height=13,width=13,...){ .mode_check_int(obj,mode_vals,grid_size,scale_val,par_names,save,height,width) } diff --git a/R/zzz.R b/R/zzz.R index b34a1d0..0dd9a18 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -16,6 +16,20 @@ ## ################################################################################ -.onLoad <- function(libname, pkgname) { - suppressWarnings(Rcpp::loadRcppModules()) -} +#' @useDynLib BMR, .registration = TRUE +#' @importFrom Rcpp evalCpp +#' @exportPattern "^[[:alpha:]]+" +#' @export +Rcpp::loadModule("bvarcnw_module", TRUE) +Rcpp::loadModule("bvarinw_module", TRUE) +Rcpp::loadModule("bvarm_module", TRUE) +Rcpp::loadModule("bvars_module", TRUE) +Rcpp::loadModule("bvartvp_module", TRUE) +Rcpp::loadModule("cvar_module", TRUE) +Rcpp::loadModule("dsge_gensys_module", TRUE) +Rcpp::loadModule("dsge_uhlig_module", TRUE) +Rcpp::loadModule("dsgevar_gensys_module", TRUE) +Rcpp::loadModule("dsgevar_uhlig_module", TRUE) +Rcpp::loadModule("dsgevar_uhlig_module", TRUE) +Rcpp::loadModule("gensys_module", TRUE) +Rcpp::loadModule("uhlig_module", TRUE) diff --git a/src/modules/bvarm_R.cpp b/src/modules/bvarm_R.cpp index 0e8fef7..2e08fe0 100644 --- a/src/modules/bvarm_R.cpp +++ b/src/modules/bvarm_R.cpp @@ -63,8 +63,8 @@ RCPP_MODULE(bvarm_module) .field_readonly( "alpha_hat", &bm::bvarm::alpha_hat ) .field_readonly( "Sigma_hat", &bm::bvarm::Sigma_hat ) - .field_readonly( "alpha_pr_mean", &bm::bvarm::alpha_pr_mean ) - .field_readonly( "alpha_pr_var", &bm::bvarm::alpha_pr_var ) + .field( "alpha_pr_mean", &bm::bvarm::alpha_pr_mean ) + .field( "alpha_pr_var", &bm::bvarm::alpha_pr_var ) .field_readonly( "alpha_pt_mean", &bm::bvarm::alpha_pt_mean ) .field_readonly( "alpha_pt_var", &bm::bvarm::alpha_pt_var ) -- GitLab