R/dataprepf.R

In gamalamboy/stresstest: Implement the ETI Stress Testing Simulation

#' @import stats methods utils MASS zoo
#' @importFrom Rcpp evalCpp 
#' @useDynLib stresstest, .registration = TRUE


# Extract lag information from an equation
# 
# This is a helper function that is called with Ztprops.
.Ztprop <- function(formula, STR_PATTERN = "([[:alnum:]\\_]+)(\\.l([0-9]+)$)*")
{
    vnames <- all.vars(formula[[3]])
    
    vals <- data.frame(
    lags = as.numeric(gsub(STR_PATTERN, "\\3", vnames)),
    vars_indep = gsub(STR_PATTERN, "\\1", vnames), 
    vars_dep = all.vars(formula[[2]]),
    terms = vnames, stringsAsFactors = FALSE)
    vals$lags[ is.na(vals$lags)] <- 0
    
    attr( vals, "ql") <- attr( stats::terms.formula(formula), "intercept")
    attr( vals, "call") <- deparse( formula, width.cutoff = 500)
    
    vals
    
}

#' Extract lag and structure information from the SUR representation of 
#' a VAR model
#' 
#' This function extracts the lags, dependent and independent variables, and
#' whether the function has an intercept or not by interpreting the \code{ ForList}
#' object supplied. It then returns a data frame with these properties for
#' all the equations in the \code{ForList}.
#' 
#' Internally, the function is but a loop ran over the function \code{.Ztprop}, 
#' which specifies the values in the data.frame.
#' 
#' @param formula_list a \code{ForList} object to evaluate.
#'
#' @return an object of class \code{Ztprops}, which is a list containing the
#' following categories: \describe{
#' \item{vals}{a data.frame containing the names, lag number and equation
#' of each variable in each formula.}
#' \item{ql}{the intercept attribute of the formula.}
#' \item{call}{the system call}
#' }
#' 
#' @export 
Ztprops <- function(formula_list)
{
    if( !inherits( formula_list, "ForList")) stop( 
    "Object must be of class \"ForList\"\n")
    
    tmp <- lapply(formula_list, function(x) .Ztprop(x))
    
    tmpat <- do.call( rbind, lapply( tmp, function(x) c( ql = attr(x, "ql"),
    call = attr(x, "call"))))
    
    tmp <- do.call(rbind, tmp)
    
    class(tmp) <- c("data.frame", "Ztprops")
    
    attr(tmp, "callint") <- tmpat
    attr(tmp, "nterms") <- table(factor(tmp$vars_dep, levels = unique(
    tmp$vars_dep)))
    
    tmp
}

#' Create rows of the model matrix
#' 
#' This function interprets the output from a \code{Ztprops} object, and
#' in combination with the model dataset creates a row with the corresponding
#' variables and lag orders for each of the equations in th VAR.
#' 
#' @param data the data set (must be a \code{zoo} object).
#' @param ztprop1 a \code{Ztprops} object.
#' 
#' @return the list of Z vectors.
#' 
#' @rdname create-zmt
#' @export
.create.zmt = function(data, ztprop1)
{
    maxlen <- max( ztprop1$lags)
    zp <- lapply( 1:nrow(ztprop1), function(x)
    {
        t1 <- ztprop1$vars_indep[x]
        t2 <- ztprop1$lags[x]
        stats::lag(data[,t1], -t2, na.pad = TRUE)
    })
    
    names(zp) <- ztprop1$vars_indep
    
    do.call(cbind, zp)
}

#' Create the model matrices
#' 
#' This function creates two representations of the VAR model matrices: the
#' stacked form \eqn{Z=(Z_{1}^{T}, Z_{2}^{T}, \ldots, Z_{T}^{T})^{T}}, or a
#' list of \eqn{ Z_{t}} matrices.
#' 
#' Internally, this function calls .create.zmts to generate the VAR model rows,
#' then inserts them into a matrix of zeros in a particular order.
#' 
#' @param data the data set (a \code{zoo} object).
#' @param ztprop1 a \code{ Ztprops } object.
#' 
#' @return a 3-dimensional array.
#' @export
create.Z <- function( data, ztprop1)
{
    zmt1 <- .create.zmt(data, ztprop1)
    tabl <- attr(ztprop1, "nterms")
    
    rnum = length(tabl)
    cnum = sum(tabl)
    snum = nrow(zmt1)
    
    index1 <- cbind( rep( 1:rnum, tabl), 1:cnum)
    
    createZt <- function(datvec, Zt = matrix(0, rnum, cnum))
    {
        Zt[ index1] <- datvec
        Zt
    }
    
    Z <- array(0, dim = c( rnum, cnum, snum))
    
    dimnames(Z) <- list( names(tabl), colnames(zmt1), zoo::index(zmt1))
    
    for( i in 1:snum)
    {
        Z[,,i] <- createZt( zmt1[i,])
    }
    
    Z[,,(max(ztprop1$lags) + 1):snum ]
}

#' Create dependent variable representation for the VAR.
#' 
#' This function estimates the dependent variable vectors for
#' the equation-by-equation VAR in matrix form, then returns them in either
#' stacked form, or as a list.
#' 
#' @param data the data set (a \code{ zoo } object).
#' @param ztprop1 a \code{ Ztprops } object.
#' 
#' @return an array of class \code{ Ymat }.
#' @export
create.Y <- function( data, ztprop1)
{
    tabl <- names(attr(ztprop1,"nterms"))
    
    Y <- array(0, dim = c( length(tabl), nrow(data)))
    
    for( i in 1:nrow(data))
    {
        Y[,i] <- data[i,tabl]
    }
    
    dimnames(Y) <- list( tabl, zoo::index(data))
    
    Y[,(max(ztprop1$lags) + 1):dim(Y)[2], drop = FALSE]
}