stresstest.Rcheck/00_pkg_src/stresstest/R/priorf.R

In gamalamboy/stresstest: Implement the ETI Stress Testing Simulation

#' Interface for entering the prior Beta using \code{ dataentry() }
#' 
#' This function creates a Beta vector of parameters using the structure
#' given in the \code{ Ztprops } object, then a) assigns the values in the
#' \emph{bvals} argument, or b) opens an editor interface to input said
#' values.
#' 
#' @param ztprop1 the model structure (a \code{ Ztprops } object).
#' @param bvals numeric. If NULL, an interface to \code{ dataentry() } is
#' activated; if not, then the value supplied is used as a Beta vector.
#' 
#' @return a column vector.
#' @rdname priorBeta
#' @export
.priorBeta <- function( ztprop1, bvals = NULL )
{
    if( !is.null( bvals)) beta2 <- bvals else
    {
        
        beta1 <- rep(0, nrow(ztprop1))
        beta1 <- split(beta1, ztprop1$vars_dep)
        
        names(beta1) <- attr(ztprop1, "callint")[,"call"]
        
        gh <- as.list(rep( "numeric", length(beta1)))
        
        cat(" ##### Minnesota Prior Beta #####\n", "Please edit the prior",
        "means for the following equations:\n\n")
        beta2 <- utils::dataentry( beta1, gh)
        
        beta2 <- unlist(unname(beta2))
        
        while( length( beta2) != sum( vapply( beta1, length, numeric(1))))
        {
            cat("ERROR: Dimensions Changed! Please Re-Enter:\n\n")
            beta2 <- utils::dataentry( beta1, gh)
            beta2 <- unlist(unname(beta2))
        }
    }
    
    matrix(beta2, ncol = 1, dimnames = list( ztprop1$terms, "Beta"))
        
}

#' Compute the Litterman (Minnesota) prior for the covariance matrix
#' specification
#' 
#' This function creates a Litterman prior covariance matrix for the parameter
#' vector. 
#' 
#' The Litterman (or Minnesota) prior is a diagonal covariance
#' specification with elements defined in the following way:
#' \enumerate{
#' \item for own lags, use \eqn{ \frac{ \lambda}{ l^{2} }}, where \eqn{l} is
#' the lag order of the coefficient.
#' \item for lags of other endogenous variables, use \eqn{ \theta \frac{ 
#' \sigma_{ii} }{ \sigma_{jj} } }, where \eqn{ i \neq j }.
#' \item for exogenous variables, use \eqn{ \gamma \sigma_{k} }, where 
#' \eqn{ \gamma } lies between 0 and 1.}
#' 
#' @param data a \code{zoo} object.
#' @param ztprop1 a \code{ Ztprops} object containing the model structure.
#' @param decay the type of decay throughout the lag order coefficients in the
#' model. Defaults to \eqn{ \frac{ 1 }{ x^{2} } }.
#' @param params a list containing the values of \eqn{ \lambda}, \eqn{ \theta},
#' and \eqn{ \gamma}. If NULL, a \code{ dataentry } interface will open to
#' specify the parameters.
#' 
#' @return a matrix with additional class \code{ PriorVBeta}.
#' @rdname priorVbeta
#' @export
.priorVbeta <- function( data, ztprop1, decay = 2, params = NULL)
{
    props <- ztprop1
    
    props$exog <- !props$vars_indep %in% props$vars_dep
    
    indepl <- props$terms
        
    sd_indep <- apply( data[,props$vars_indep], 2, stats::sd, na.rm = TRUE)
    sd_indep[ "i0"] <- 1
    
    sd_dep <- apply( data[,props$vars_dep], 2, stats::sd, na.rm = TRUE)
    tp <- props$vars_indep != props$vars_dep & !props$exog
    
    sd_data <- ifelse( tp == TRUE, sd_indep / sd_dep, sd_indep)
    
    names( sd_data) <- names( sd_indep)
    
    if( is.null(params))
    {
        cat( "###### Minnesota Prior Variance #####\nPlease input the",
        "following parameters for the prior variance\nspecification:\n
        lambda -- Prior variance on own lags.
        theta -- Prior variance on exogenous variables and their lags.
        gamma -- Prior variance on endogenous variables and their lags,
        expressed as a share of lambda in [0,1].\n\n")
        vbeta <- list( lambda = 1, theta = 1, gamma = 1)
        vbeta2 <- utils::dataentry( vbeta, as.list( rep( "numeric", 3)))
    } else vbeta2 <- params
        
    list2env( vbeta2, envir = environment())
    
    coef_orig <- with( props, setNames( sd_data[ vars_indep], vars_indep))
    
    coef_change <- with( props, cbind(
    coef_lambda = coef_orig * as.numeric( vars_indep == vars_dep) * lambda,
    coef_theta = coef_orig * as.numeric( exog) * theta,
    coef_gamma = coef_orig * as.numeric( tp) * lambda * gamma ))
    
    coef_change <- rowSums( coef_change)
    
    bl <- ifelse( props$lags == 0, 1, props$lags)
    
    res1 <- diag( coef_change * bl^decay)

    dimnames(res1) <- list( indepl, indepl)
    class(res1) <- c("matrix", "PriorVBeta")
    res1
}

#' Specify the prior covariance matrix for the model.
#' 
#' This function specifies the prior covariance matrix, based upon the values
#' received in the parameter \code{ value}. If said parameter is NULL, then
#' a \code{ dataentry } interface is used to obtain the covariance prior. The
#' matrix is assumed diagonal when specifying \code{ value}.
#' 
#' @param ztprop1 a \code{ Ztprops } object containing the model structure.
#' @param value a vector of values for the diagonal of the covariance matrix.
#' 
#' @return a matrix with additional class \code{ PriorVar}.
#' @rdname priorVar
#' @export
.priorVar <- function( ztprop1, value = NULL)
{

    callint <- attr(ztprop1, "callint")
    
    res1 <- diag( nrow(callint)) * 1e6
    sn <- unique(ztprop1$vars_dep)
    dimnames( res1) <- list( sn, sn)
    
    if( is.null(value))
    {
        cat( "##### Prior Variance of System #####\nPlease enter the",
        "prior variances for the equations:\n")
        res1 <- do.call(rbind, unname(utils::de( res1 )))
        
    } else res1 <- res1 / 1e6 * value
    
    dimnames(res1) <- c( rep( list(sn), 2))
    class( res1) <- c("matrix", "PriorVar")
    
    res1
}