R/midas_qr_methods.R

In midasr: Mixed Data Sampling Regression

##' @export
##' @method print midas_qr
print.midas_qr <- function(x, digits=max(3,getOption("digits") - 3), ...) {
    print.midas_r(x)
}

##' @export
##' @method coef midas_qr
coef.midas_qr <- function(object, midas = FALSE, term_names = NULL, ...) {
    if (is.null(term_names)) coef.midas_r(object, midas, ...)
    else {
        if (length(object$tau) > 1) {
            mc <- object$midas_coefficients
            if (length(setdiff(term_names,names(object$term_info))) > 0) 
                stop("Some of the term names are not present in estimated MIDAS regression")
            if (midas) {
                res <- lapply(object$term_info[term_names], function(x) object$midas_coefficients[x$midas_coef_index,])
            } else {
                res <- lapply(object$term_info[term_names], function(x) object$coefficients[x$coef_index,])
            }
            names(res) <- NULL
            if (length(res) == 1) return(res[[1]])
            else return(unlist(res))
        } else coef.midas_r(object, midas, term_names, ...)
    }        
 
}

## Code is borrowed from summary.nlrq in quantreg
##' @export
##' @method summary midas_qr
summary.midas_qr <- function(object, ... ) {
    y <- object$residuals
    tau <- object$tau
    cfs <- coef(object)
    
    do_f <- function(yy, cf, tau) {
        XX <- object$model[, -1] %*% object$gradD(cf)
        f <- summary(rq(yy ~ XX - 1, tau), se = "boot", covariance = TRUE, ...)
        f$coefficients[, 1] <- cf
        f$coefficients[, 3] <- f$coefficients[, 1]/f$coefficients[, 2]
        f$coefficients[, 4] <- if (f$rdf > 0) 2 * (1 - pt(abs(f$coef[, 3]), f$rdf))
        dimnames(f$coefficients)[[1]] <- names(cf)
        f$call <- object$call
        f$tau <- tau
        f
    }
    
    if (length(tau) > 1) {
        all_f <- vector(mode = "list", length(tau))
        for (i in 1:length(tau)) {
            cff <- as.vector(cfs[,i])
            names(cff) <- rownames(cfs)
            all_f[[i]] <- do_f(as.vector(y[, i]), cff, tau[i])
        }
        cf <- lapply(all_f, coef)
    } else {
        all_f <- do_f(as.vector(y), cfs, tau)
        cf <- coef(all_f)
    }
    
    ans <- list(formula = formula(object$terms), residuals = y,
                call = object$call,
                f = all_f,
                tau = object$tau,
                coefficients = cf, midas_coefficients = coef(object, midas = TRUE),
                lhs_start = object$lhs_start, lhs_end = object$lhs_end, class_lhs = class(object$lhs))
    
    class(ans) <- "summary.midas_qr"
    ans
}

##' @export
##' @method print summary.midas_qr
print.summary.midas_qr <- function(x, digits =max(3, getOption("digits") - 3 ), 
                                   signif.stars = getOption("show.signif.stars"), ...)  {
    
    cat(paste("\nMIDAS quantile regression model with \"", x$class_lhs[1], 
              "\" data:\n", sep = ""))
    cat(paste("Start = ", x$lhs_start, 
              ", End = ", x$lhs_end, 
              "\n", sep = ""))
    cat("\n Formula", deparse(formula(x)),"\n")
    cat("\n Parameters:\n")
    cf <- coef(x)
    if (length(x$tau) > 1) {
        for (i in 1:length(x$tau)) {
            cat("\n tau:", x$tau[i], "\n")    
            printCoefmat(cf[[i]], digits = digits, signif.stars = signif.stars,...)
        }
    } else {
        cat("\n tau:", x$tau, "\n")    
        printCoefmat(coef(x), digits = digits, signif.stars = signif.stars,...)
    }
    invisible(x)   
}