R/RRegArch.R

Defines functions print.summary.RegArchFitClass summary.RegArchFitClass print.RegArchFitClass RegArchFit AsymptoticCovMat SetInitPoint optimgr optimfn RegArchGradLLH RegArchLLH RegArchSim VectorToRegArchParam.studentClass RegArchParamToVector.studentClass VectorToRegArchParam.normalClass RegArchParamToVector.normalClass GetNParam.condResidualsClass GetNParam.condVarClass VectorToRegArchParam.APARCHClass RegArchParamToVector.APARCHClass VectorToRegArchParam.EGARCHClass RegArchParamToVector.EGARCHClass VectorToRegArchParam.TARCHClass RegArchParamToVector.TARCHClass VectorToRegArchParam.GARCHClass RegArchParamToVector.GARCHClass VectorToRegArchParam.ARCHClass RegArchParamToVector.ARCHClass VectorToRegArchParam.ConstVarClass RegArchParamToVector.ConstVarClass RegArchParamToVector.condVarClass VectorToRegArchParam.LinRegClass RegArchParamToVector.LinRegClass VectorToRegArchParam.VarInMeanClass RegArchParamToVector.VarInMeanClass VectorToRegArchParam.StdInMeanClass RegArchParamToVector.StdInMeanClass VectorToRegArchParam.MAClass RegArchParamToVector.MAClass VectorToRegArchParam.ARClass RegArchParamToVector.ARClass VectorToRegArchParam.ConstMeanClass RegArchParamToVector.ConstMeanClass VectorToRegArchParam.condMeanClass RegArchParamToVector.condMeanClass GetNParam.condMeanClass VectorToRegArchParam.RegArchModelClass RegArchParamToVector.RegArchModelClass GetNParam.RegArchModelClass GetNParam.default VectorToRegArchParam RegArchParamToVector GetNParam print.RegArchModelClass namesParam.RegArchModelClass modelSet residualsSet print.studentClass namesParam.studentClass studentSet print.normalClass namesParam.normalClass print.condResidualsClass namesParam.condResidualsClass normalSet print.APARCHClass namesParam.APARCHClass aPARCHSet print.EGARCHClass namesParam.EGARCHClass eGARCHSet print.TARCHClass namesParam.TARCHClass tARCHSet print.GARCHClass namesParam.GARCHClass gARCHSet print.ARCHClass namesParam.ARCHClass aRCHSet print.ConstVarClass namesParam.ConstVarClass constVarSet namesParam.condVarClass print.condVarClass varSet print.LinRegClass namesParam.LinRegClass print.VarInMeanClass namesParam.VarInMeanClass print.StdInMeanClass namesParam.StdInMeanClass print.ConstMeanClass namesParam.ConstMeanClass print.MAClass namesParam.MAClass print.ARClass namesParam.ARClass namesParam.condMeanClass namesParam print.condMeanClass meanSet varInMeanSet stdInMeanSet linRegSet mASet aRSet constMeanSet

Documented in meanSet modelSet print.condMeanClass print.condResidualsClass print.condVarClass print.RegArchFitClass print.RegArchModelClass print.summary.RegArchFitClass RegArchFit RegArchSim residualsSet summary.RegArchFitClass varSet

 ###############################################################
 #### RRegArch version 1.0.0                                      
 ####                                                         
 #### File: RRegArch.R 
 ####                                                         
 #### Author: Ollivier TARAMASCO <[email protected]> 
 ####                                                         
 #### Date: 2009/03/30                                        
 ####                                                         
 ###############################################################

constMeanSet <- function(param)
{
    if (is.null(param))
    {   Res <- list(meanType=eConst, nParam = 1, Const=0.0)
    }
    else
    {   if (is.double(param))
        {   Res <- list(meanType=eConst, nParam = 1, Const=param)
        }
        else
        {    stop("wrong parameter type in constMeanSet\n")
        }
    }
    class(Res) <- "ConstMeanClass"
    return(Res)
}

aRSet <- function(param)
{
    if (is.integer(param))
    {    Res <- list(meanType=eAr, nAR=param, nParam = param, AR=rep(0, param))
    }
    else
    {  if (is.vector(param))
        {   nParam <- length(param)
            Res <- list(meanType=eAr, nAR = nParam, nParam=nParam, AR=param)
        }
        else
        {    stop("wrong parameter type in ARSet\n")
        }
    }
    class(Res) <- "ARClass"
    return(Res)
}

mASet <- function(param)
{
    if (is.integer(param))
    {    Res <- list(meanType=eMa, nMA=param, nParam=param, MA=rep(0, param))
    } 
    else
    {   if (is.vector(param))
        {   nParam <- length(param)
            Res <- list(meanType=eMa, nMA = nParam, nParam=nParam, MA=param)
        }   
        else
        {    stop("wrong parameter type in MASet\n")
        }
    }
    class(Res) <- "MAClass"
    return(Res)
}

linRegSet <- function(param)
{
    if (is.matrix(param))
    {   nObs <- as.integer(nrow(param))
        nBeta <- as.integer(ncol(param))
        Res <- list(meanType=eLinReg, nBeta=nBeta, nObs=nObs, nParam=nBeta, Beta=rep(0, nBeta), X=param)
    }
    else
    {   if (is.list(param))
        {   nBeta=length(param$Beta)
            Res <- list(meanType=eLinReg, nBeta=nBeta, nObs=nrow(param$X), nParam=nBeta, Beta=param$Beta, X=param$X)
        }
           else
        {    stop("wrong parameter type in linRegSet\n")
        }
    }
    class(Res) <- "LinRegClass"
    return(Res)
}     

stdInMeanSet <- function(param)
{
    if (is.null(param))
    {   Res <- list(meanType=eStdInmean, nParam=1, Delta=0.0)
    }
    else
    {   if (is.double(param))
        {   Res <- list(meanType=eStdInmean, nParam=1, Delta=param)
        }
        else
        {    stop("wrong parameter type in StdInMeanSet\n")
        }
    }
    class(Res) <- "StdInMeanClass"
    return(Res)
}

varInMeanSet <- function(param)
{
    if (is.null(param))
    {   Res <- list(meanType=eVarInMean, nParam=1, Delta=0.0)
    }
    else
    {   if (is.double(param))
        {   Res <- list(meanType=eVarInMean, nParam=1, Delta=param)
        }
        else
        {    stop("wrong parameter type in VarInMeanSet\n")
        }
    }
    class(Res) <- "VarInMeanClass"
    return(Res)
}

meanSet <- function(...)
{
    extras <- match.call(expand.dots = FALSE)$... 
    args <- list(...)
    argName <- NULL
    lextras <- length(extras)
    for (i in 1:lextras)
    {   argName <- c(argName, names(extras[i]))
    }    
    condMean <- rep(list(0), lextras)
    for (i in 1:lextras)
    {   Res<-switch(argName[i],
                    AR = aRSet(args[[i]]),
                    nAR = aRSet(as.integer(args[[i]])),
                    MA = mASet(args[[i]]),
                    nMA = mASet(as.integer(args[[i]])),
                    CONST = constMeanSet(args[[i]]), 
                    STDINMEAN = stdInMeanSet(args[[i]]),
                    VARINMEAN = varInMeanSet(args[[i]]),
                    LINREG = linRegSet(args[[i]])
                    )
        if (is.null(Res))
        {   mess <- sprintf("unknown '%s' argument in meanSet", argName[i])
            stop(mess)
        }
        condMean[[i]] <- Res 
    }
    class(condMean) <- "condMeanClass"
    return(condMean)
}        

print.condMeanClass <- function(x, ...)
{
    n<-length(x)
     for (i in 1:n)
        print(x[[i]])
}

namesParam <- function(object) UseMethod("namesParam")

namesParam.condMeanClass <- function(object)
{
    Res <- NULL
    n<-length(object)
    for (i in 1:n)
        Res<-c(Res, namesParam(object[[i]]))
    return(Res)
}
   
namesParam.ARClass <- function(object)
{   AuxNames <- NULL
    for (i in 1:object$nAR)
    {   AuxNames <- c(AuxNames, sprintf("AR[%d]", i))
    }
    return(AuxNames)
}

print.ARClass <- function(x, ...)
{
    cat(sprintf("\nAR[%d] model", x$nAR))
    Aux <- as.matrix(x$AR)
    row.names(Aux) <- namesParam(x)
    Aux1 <- as.data.frame(Aux)
    names(Aux1) <- " "
    print.data.frame(Aux1)
}

namesParam.MAClass <- function(object)
{   AuxNames <- NULL
    for (i in 1:object$nMA)
    {   AuxNames <- c(AuxNames, sprintf("MA[%d]", i))
    }
    return(AuxNames)
}
    
print.MAClass <- function(x, ...)
{
    cat(sprintf("\nMA[%d] model", x$nMA))
    Aux <- as.matrix(x$MA)
    row.names(Aux) <- namesParam(x)
    Aux1 <- as.data.frame(Aux)
    names(Aux1) <- " "
    print.data.frame(Aux1)
}


namesParam.ConstMeanClass <- function(object)
{   AuxNames <- "Const"
    return(AuxNames)
}

print.ConstMeanClass <- function(x, ...)
{
    cat(sprintf("\nConstant mean parameter"))
    Aux <- as.matrix(x$Const)
    row.names(Aux) <- namesParam(x)
     Aux1 <- as.data.frame(Aux)
    names(Aux1) <- " "
    print.data.frame(Aux1)

}

namesParam.StdInMeanClass <- function(object)
{   AuxNames <- "Delta"
    return(AuxNames)
}

print.StdInMeanClass <- function(x, ...)
{
    cat(sprintf("\nStandard deviation in mean Parameter"))
    Aux <- as.matrix(x$Delta)
    row.names(Aux) <- namesParam(x)
     Aux1 <- as.data.frame(Aux)
    names(Aux1) <- " "
    print.data.frame(Aux1)

}

namesParam.VarInMeanClass <- function(object)
{   AuxNames <- "Delta"
    return(AuxNames)
}

print.VarInMeanClass <- function(x, ...)
{
    cat(sprintf("\nVar In Mean Parameter"))
    Aux <- as.matrix(x$Delta)
    row.names(Aux) <- namesParam(x)
     Aux1 <- as.data.frame(Aux)
    names(Aux1) <- " "
    print.data.frame(Aux1)

}

namesParam.LinRegClass <- function(object)
{    AuxNames <- NULL
    for (i in 1:object$nBeta)
    {   AuxNames <- c(AuxNames, sprintf("Beta[%d]", i))
    }
 return(AuxNames)
}

print.LinRegClass <- function(x, ...)
{
    cat(sprintf("\nLinear regression parameters"))
    Aux <- as.matrix(x$Beta)
    row.names(Aux) <- namesParam(x)
    Aux1 <- as.data.frame(Aux)
    names(Aux1) <- " "
    print.data.frame(Aux1)

}

varSet <- function(...)
{
    extras <- match.call(expand.dots = FALSE)$...
    if (is.null(extras))
        stop('varSet must have one argument\n')
        
    args <- list(...)
    argName <- names(extras[1])
    arg <- args[[1]]
    Res<-switch(argName,
                    CONSTVAR = constVarSet(arg),
                    ARCH=aRCHSet(arg),
                    nARCH=aRCHSet(list(ConstVar=0.0, ARCH=rep(0, arg))),
                    GARCH=gARCHSet(arg),
                    nGARCH=gARCHSet(list(ConstVar=0.0, ARCH=rep(0, arg[1]), GARCH=rep(0, arg[2]))),
                    TARCH=tARCHSet(arg),
                    nTARCH=tARCHSet(list(ConstVar=0.0, ARCHPlus=rep(0, arg), ARCHMinus=rep(0, arg))),
                    EGARCH=eGARCHSet(arg),
                    nEGARCH=eGARCHSet(list(ConstVar=0.0, ARCH=rep(0, arg[1]), GARCH=rep(0, arg[2]), Theta=0, Gamma=0)),
                    APARCH=aPARCHSet(arg),
                    nAPARCH=aPARCHSet(list(ConstVar=0.0, ARCH=rep(0, arg[1]), Gamma=rep(0, arg[1]), GARCH=rep(0, arg[2]), Delta=2))
                )
     class(Res) <- c("condVarClass", class(Res))
     return(Res)
 }        

print.condVarClass <- function(x, ...)
{
    return(NextMethod("print", x)) 
}

namesParam.condVarClass <- function(object, ...)
{
    return(NextMethod("namesParam", object)) 
}

constVarSet <- function(Val)
{
    if (is.double(Val))
    {   Res <- list(varType=eConstVar, nParam=1, ConstVar=Val)
    }
    else
    {   if (is.list(Val))
            Res <- list(varType=eConstVar, nParam=1, ConstVar=Val[[1]])
    }
    class(Res) <- "ConstVarClass"
    return(Res)
}

namesParam.ConstVarClass <- function(object)
{   AuxNames <- "ConstVar"
    return(AuxNames)
}

print.ConstVarClass <- function(x, ...)
{
    cat(sprintf("Constant variance model\n"))
    Res <- rep(0, 1)
    Res[1] <- x$ConstVar
    names(Res) <- namesParam(x)
    Res1 <- as.data.frame(Res)
    names(Res1) <- " "
    print(Res1)
}

aRCHSet <- function(Param)
{   if (!is.list(Param))
        stop('Param must be a list (ConstVar="double", ARCH="vector of doubles")')
    if (length(Param) != 2)
        stop('Param must be a list (ConstVar="double", ARCH="vector of doubles")')
   
   if (is.null(Param$ConstVar))
        names(Param)[1] <- "ConstVar"
  
    if (is.null(Param$ARCH))
        names(Param)[2] <- "ARCH"
    
    if (!is.double(Param$ConstVar))
        stop('Param$ConstVar must be a double')
    
    if (!is.vector(Param$ARCH))
        stop('Param$ARCH must be a vector of doubles') 
            
    nARCH <- length(Param$ARCH)  
    Res <- list(varType=eARCH, nARCH = nARCH, nParam=nARCH+1, ConstVar=Param$ConstVar, ARCH=Param$ARCH)
    class(Res) <- "ARCHClass"
    return(Res)
}

namesParam.ARCHClass <- function(object)
{   AuxNames <- "ConstVar"
    for (i in 1:object$nARCH)
        AuxNames <- c(AuxNames, sprintf("ARCH[%d]", i))
   return(AuxNames)
}

print.ARCHClass <- function(x, ...)
{
    cat(sprintf("ARCH(%d) model\n", x$nARCH))
    Res <- rep(0, x$nARCH+1)
    Res[1] <- x$ConstVar
    Res[2:(x$nARCH+1)] <- x$ARCH
    names(Res) <- namesParam(x)
    Res1 <- as.data.frame(Res)
    names(Res1) <- " "
    print(Res1)
}

       
gARCHSet <- function(Param)
{   if (!is.list(Param))
        stop('Param must be a list (ConstVar="double", ARCH="vector of doubles", GARCH="vector of doubles")')
    if (length(Param) != 3)
         stop('Param must be a list (ConstVar="double", ARCH="vector of doubles", GARCH="vector of doubles")')
  
   if (is.null(Param$ConstVar))
        names(Param)[1] <- "ConstVar"
  
    if (is.null(Param$ARCH))
        names(Param)[2] <- "ARCH"
    
    if (is.null(Param$GARCH))
        names(Param)[3] <- "GARCH"
 
    if (!is.double(Param$ConstVar))
        stop('Param$ConstVar must be a double')
    
    if (!is.vector(Param$ARCH))
        stop('Param$ARCH must be a vector of doubles') 

    if (!is.vector(Param$GARCH))
        stop('Param$ARCH must be a vector of doubles') 
            
    nARCH <- length(Param$ARCH)  
    nGARCH <- length(Param$GARCH)
    Res <- list(varType=eGARCH, nARCH = nARCH, nGARCH=nGARCH, nParam=nARCH+nGARCH+1, ConstVar=Param$ConstVar, ARCH=Param$ARCH, GARCH=Param$GARCH)
    class(Res) <- "GARCHClass"
    return(Res)
}

namesParam.GARCHClass <- function(object)
{   AuxNames <- "ConstVar"
    for (i in 1:object$nARCH)
        AuxNames <- c(AuxNames, sprintf("ARCH[%d]", i))
     for (i in 1:object$nGARCH)
        AuxNames <- c(AuxNames, sprintf("GARCH[%d]", i))
   return(AuxNames)
}

print.GARCHClass <- function(x, ...)
{
    cat(sprintf("GARCH(%d, %d) model\n", x$nARCH, x$nGARCH))
    Res <- rep(0, x$nARCH+x$nGARCH+1)
    Res[1] <- x$ConstVar
    Res[2:(x$nARCH+1)] <- x$ARCH
    Res[(x$nARCH+2):(x$nARCH+x$nGARCH+1)] <- x$GARCH
    names(Res) <- namesParam(x)
    Res1 <- as.data.frame(Res)
    names(Res1) <- " "
    print(Res1)
}

tARCHSet <- function(Param)
{
   if (!is.list(Param))
        stop('Param must be a list (ConstVar="double", ARCHPlus="vector of doubles", ARCHMinus="vector of doubles")')
    if (length(Param) != 3)
         stop('Param must be a list (ConstVar="double", ARCHPlus="vector of doubles", ARCHMinus="vector of doubles")')
  
   if (is.null(Param$ConstVar))
        names(Param)[1] <- "ConstVar"
  
    if (is.null(Param$ARCHPlus))
        names(Param)[2] <- "ARCHPlus"
    
    if (is.null(Param$ARCHMinus))
        names(Param)[3] <- "ARCHMinus"
 
    if (!is.double(Param$ConstVar))
        stop('Param$ConstVar must be a double')
    
    if (!is.vector(Param$ARCHPlus))
        stop('Param$ARCHPlus must be a vector of doubles') 

    if (!is.vector(Param$ARCHMinus))
        stop('Param$ARCHMinus must be a vector of doubles') 
    
    if (length(Param$ARCHMinus) != length(Param$ARCHPlus))
        stop("Param$ARCHMinus and Param$ARCHPlus must have the same length")
           
    nARCH <- length(Param$ARCHPlus)  
    Res <- list(varType=eTARCH, nARCH = nARCH, nParam=2*nARCH+1, ConstVar=Param$ConstVar, ARCHPlus=Param$ARCHPlus, ARCHMinus=Param$ARCHMinus)
    class(Res) <- "TARCHClass"
    return(Res)
 }

namesParam.TARCHClass <- function(object)
{   AuxNames <- "ConstVar"
    for (i in 1:object$nARCH)
        AuxNames <- c(AuxNames, sprintf("ARCHPlus[%d]", i))
     for (i in 1:object$nARCH)
        AuxNames <- c(AuxNames, sprintf("ARCHMinus[%d]", i))
   return(AuxNames)
}

print.TARCHClass <- function(x, ...)
{
    cat(sprintf("TARCH(%d) model\n", x$nARCH))
    Res <- rep(0, 2*x$nARCH+1)
    Res[1] <- x$ConstVar
    Res[2:(x$nARCH+1)] <- x$ARCHPlus
    Res[(x$nARCH+2):(2*x$nARCH+1)] <- x$ARCHMinus
     names(Res) <- namesParam(x)
    Res1 <- as.data.frame(Res)
    names(Res1) <- " "
    print(Res1)
}

eGARCHSet <- function(Param)
{
    if (!is.list(Param))
        stop('Param must be a list (ConstVar="double", ARCH="vector of doubles", GARCH="vector of doubles", Theta="double", Gamma="Double")')
    if (length(Param) != 5)
        stop('Param must be a list (ConstVar="double", ARCH="vector of doubles", GARCH="vector of doubles", Theta="double", Gamma="Double")')
  
   if (is.null(Param$ConstVar))
        names(Param)[1] <- "ConstVar"
  
    if (is.null(Param$ARCH))
        names(Param)[2] <- "ARCH"
    
    if (is.null(Param$GARCH))
        names(Param)[3] <- "GARCH"
 
    if (is.null(Param$Theta))
        names(Param)[4] <- "Theta"
 
    if (is.null(Param$Gamma))
        names(Param)[5] <- "Gamma"
 
    if (!is.double(Param$ConstVar))
        stop('Param$ConstVar must be a double')
    
    if (!is.vector(Param$ARCH))
        stop('Param$ARCH must be a vector of doubles') 

    if (!is.vector(Param$GARCH))
        stop('Param$GARCH must be a vector of doubles') 
    
    if (!is.double(Param$Theta))
        stop('Param$Theta must be a double')
 
    if (!is.double(Param$Gamma))
        stop('Param$Gamma must be a double')
 
          
    nARCH <- length(Param$ARCH)  
    nGARCH <- length(Param$GARCH)
    Res <- list(varType=eEGARCH, nARCH = nARCH, nGARCH=nGARCH, nParam=nARCH+nGARCH+3, ConstVar=Param$ConstVar, ARCH=Param$ARCH, GARCH=Param$GARCH, Theta=Param$Theta, Gamma=Param$Gamma)
    class(Res) <- "EGARCHClass"
    return(Res)
}

namesParam.EGARCHClass <- function(object)
{   AuxNames <- "ConstVar"
    for (i in 1:object$nARCH)
        AuxNames <- c(AuxNames, sprintf("ARCH[%d]", i))
     for (i in 1:object$nGARCH)
        AuxNames <- c(AuxNames, sprintf("GARCH[%d]", i))
     AuxNames <- c(AuxNames, "Theta", "Gamma")
   return(AuxNames)
}

print.EGARCHClass <- function(x, ...)
{
    cat(sprintf("EGARCH(%d, %d) model\n", x$nARCH, x$nGARCH))
    Res <- rep(0, x$nARCH+x$nGARCH+3)
    Res[1] <- x$ConstVar
    Res[2:(x$nARCH+1)] <- x$ARCH
    Res[(x$nARCH+2):(x$nARCH+x$nGARCH+1)] <- x$GARCH
    Res[x$nARCH+x$nGARCH+2] <- x$Theta
    Res[x$nARCH+x$nGARCH+3] <- x$Gamma
    names(Res) <- namesParam(x)
    Res1 <- as.data.frame(Res)
    names(Res1) <- " "
    print(Res1)
}

aPARCHSet <- function(Param)
{
     if (!is.list(Param))
        stop('Param must be a list (ConstVar="double", ARCH="vector of doubles", Gamma = "Vector of doubles", GARCH="vector of doubles", Delta="double")')
    if (length(Param) != 5)
         stop('Param must be a list (ConstVar="double", ARCH="vector of doubles", Gamma = "Vector of doubles", GARCH="vector of doubles", Delta="double")')
  
   if (is.null(Param$ConstVar))
        names(Param)[1] <- "ConstVar"
  
    if (is.null(Param$ARCH))
        names(Param)[2] <- "ARCH"
    
    if (is.null(Param$Gamma))
        names(Param)[3] <- "Gamma"
 
    if (is.null(Param$GARCH))
        names(Param)[4] <- "GARCH"
 
    if (is.null(Param$Delta))
        names(Param)[4] <- "Delta"
 
  
    if (!is.double(Param$ConstVar))
        stop('Param$ConstVar must be a double')
    
    if (!is.vector(Param$ARCH))
        stop('Param$ARCH must be a vector of doubles') 

    if (!is.vector(Param$Gamma))
        stop('Param$Gamma must be a double')
        
    if (length(Param$ARCH) != length(Param$Gamma))
        stop("Param$ARCH and Param$Gamma must have the same length")
 
    if (!is.vector(Param$GARCH))
        stop('Param$GARCH must be a vector of doubles') 
    
    if (!is.double(Param$Delta))
        stop('Param$Delta must be a double')
 
          
    nARCH <- length(Param$ARCH)  
    nGARCH <- length(Param$GARCH)
    Res <- list(varType=eAPARCH, nARCH = nARCH, nGARCH=nGARCH, nParam=2*nARCH+nGARCH+2, ConstVar=Param$ConstVar, ARCH=Param$ARCH, Gamma=Param$Gamma, GARCH=Param$GARCH, Delta=Param$Delta)
    class(Res) <- "APARCHClass"
    return(Res)
}

namesParam.APARCHClass <- function(object)
{   AuxNames <- "ConstVar"
    for (i in 1:object$nARCH)
        AuxNames <- c(AuxNames, sprintf("ARCH[%d]", i))
     for (i in 1:object$nARCH)
        AuxNames <- c(AuxNames, sprintf("Gamma[%d]", i))
    for (i in 1:object$nGARCH)
        AuxNames <- c(AuxNames, sprintf("GARCH[%d]", i))
     AuxNames <- c(AuxNames, "Delta")
   return(AuxNames)
}

print.APARCHClass <- function(x, ...)
{
    cat(sprintf("APARCH(%d, %d) model\n", x$nARCH, x$nGARCH))
    Res <- rep(0, 2*x$nARCH+x$nGARCH+2)
    Res[1] <- x$ConstVar
    Res[2:(x$nARCH+1)] <- x$ARCH
    Res[(x$nARCH+2):(2*x$nARCH+1)] <- x$Gamma
    Res[(2*x$nARCH+2):(2*x$nARCH+x$nGARCH+1)] <- x$GARCH
    Res[2*x$nARCH+x$nGARCH+2] <- x$Delta
    
    names(Res) <- namesParam(x)
    Res1 <- as.data.frame(Res)
    names(Res1) <- " "
    print(Res1)
}

normalSet <- function()
{
    Res <- list(distrType=eNormal, nParam=0, distrParameter=NULL)
    class(Res) <-"normalClass"
    return(Res)
}

namesParam.condResidualsClass <- function(object, ...)
{
    return(NextMethod("namesParam", object)) 
}

print.condResidualsClass <- function(x, ...)
{
    return(NextMethod("print", x)) 
}

namesParam.normalClass<-function(object)
{
    return(NULL)
}

print.normalClass<-function(x, ...)
{
    cat(sprintf("Normal residuals\n"))
}

studentSet <- function(parameter)
{   if (!is.numeric(parameter))
        stop("parameter must be the number of d.o.f. for Student residuals\n")
        
    Res <- list(distrType=eStudent, nParam=1, distrParameter=parameter)
    class(Res) <- "studentClass"
    return(Res)
}

namesParam.studentClass<-function(object)
{
    return("dof")
}

print.studentClass <- function(x, ...)
{
    cat(sprintf("Student residuals with %f dof\n", x$distrParameter))
    
}

residualsSet<-function(condResiduals, parameter=NULL)
{
    if (is.na(match(condResiduals, c('NORMAL', 'STUDENT'))))
        stop("CondResid must be in ''NORMAL', 'STUDENT'\n")
 
    if (condResiduals == 'NORMAL')
    {   Res<-normalSet()
        class(Res) <- c("condResidualsClass", class(Res))
        return(Res)
    } 
    
    if (condResiduals == 'STUDENT')
    {   Res<-studentSet(parameter)
        class(Res) <- c("condResidualsClass", class(Res))
       return(Res)
    } 

}

modelSet <- function(condMean, condVar, condRes)
{
    Res <- list(condMean=condMean, condVar=condVar, condRes=condRes)
    class(Res)<-"RegArchModelClass"
    return(Res)
}

namesParam.RegArchModelClass<-function(object)
{
    return(c(namesParam(object$condMean), namesParam(object$condVar), namesParam(object$condRes)))
}

print.RegArchModelClass <- function(x, ...)
{
    if (!is.null(x$condMean))
    {   cat(sprintf("Conditional Mean Model:\n"))
        cat(sprintf("-----------------------"))
        print(x$condMean)
    }
    cat(sprintf("\nConditional Variance Model:\n"))
    cat(sprintf("---------------------------\n"))
    print(x$condVar)
    cat(sprintf("\nConditional Residuals Model:\n"))
    cat(sprintf("----------------------------\n"))
    print(x$condRes)
}

GetNParam<-function(object) UseMethod("GetNParam")
RegArchParamToVector <-function(object) UseMethod("RegArchParamToVector")
VectorToRegArchParam <- function(object, vect) UseMethod("VectorToRegArchParam")
GetNParam.default<-function(object)
{
    return(object$nParam)
}

GetNParam.RegArchModelClass <- function(object)
{
    if (!is.null(object$condMean))
    {   Res <- GetNParam(object$condMean) 
    }
    else
    {   Res <- 0
    }
    Res <- Res + GetNParam(object$condVar) + GetNParam(object$condRes)
    return(Res)
}

RegArchParamToVector.RegArchModelClass <- function(object)
{
    Res <- NULL
    if (!is.null(object$condMean))
    {   Res <- RegArchParamToVector(object$condMean) 
    }
    Res <- c(Res, RegArchParamToVector(object$condVar), RegArchParamToVector(object$condRes))
    return(Res)
}
    
VectorToRegArchParam.RegArchModelClass <- function(object, vect)
{
    Res <- object
    if (!is.null(object$condMean))
    {   Res$condMean <- VectorToRegArchParam(object$condMean, vect)   
        nParamMean <- GetNParam(object$condMean) 
    }
    else
    {   nParamMean <- 0
    }
    nParam <- GetNParam(object)
    vect1 <- vect[(nParamMean+1):nParam] 
    Res$condVar <- VectorToRegArchParam(object$condVar, vect1)
    nParamVar <- GetNParam(object$condVar)
    vect2 <- vect[(nParamMean+nParamVar+1):nParam] 
    Res$condRes <- VectorToRegArchParam(object$condRes, vect2)
    return(Res)
}


GetNParam.condMeanClass <- function(object)
{
    Res <- 0
    for (i in 1:length(object))
        Res <- Res+GetNParam(object[[i]])
    return(Res)
}

RegArchParamToVector.condMeanClass <- function(object)
{
    Res <- NULL
    for (i in 1:length(object))
    {   Res <- c(Res, RegArchParamToVector(object[[i]]))
    }
    return(Res)
}

VectorToRegArchParam.condMeanClass <- function(object, vect)
{   Res <- object
    j <- 1
    vect1 <- vect
    n <- length(vect)
    for (i in 1:length(object))
    {   Res[[i]] <- VectorToRegArchParam(object[[i]], vect1)
        j <- j + GetNParam(object[[i]])
        vect1 <- vect[j:n]
    }
    return(Res)
}

RegArchParamToVector.ConstMeanClass <- function(object)
{
    return(object$Const)
}

VectorToRegArchParam.ConstMeanClass <- function(object, vect)
{
    Res <- object
    Res$Const <- vect[1]
    return(Res)
}

RegArchParamToVector.ARClass <- function(object)
{
    return(object$AR)
}

VectorToRegArchParam.ARClass <- function(object, vect)
{
    Res <- object
    Res$AR <- vect[1:object$nAR]
    return(Res)
}

RegArchParamToVector.MAClass <- function(object)
{
    return(object$AR)
}

VectorToRegArchParam.MAClass <- function(object, vect)
{
    Res <- object
    Res$MA <- vect[1:object$nMA]
    return(Res)
}

RegArchParamToVector.StdInMeanClass <- function(object)
{
    return(object$Delta)
}

VectorToRegArchParam.StdInMeanClass <- function(object, vect)
{
    Res <- object
    Res$Delta <- vect[1]
    return(Res)
}

RegArchParamToVector.VarInMeanClass <- function(object)
{
    return(object$Delta)
}

VectorToRegArchParam.VarInMeanClass <- function(object, vect)
{
    Res <- object
    Res$Delta <- vect[1]
    return(Res)
}

RegArchParamToVector.LinRegClass <- function(object)
{
    return(object$Beta)
}

VectorToRegArchParam.LinRegClass <- function(object, vect)
{
    Res <- object
    Res$Beta <- vect[1:object$nBeta]
    return(Res)
}

RegArchParamToVector.condVarClass <- function(object)
{
    return(NextMethod(generic="RegArchParamToVector", object=object))
}

RegArchParamToVector.ConstVarClass <- function(object)
{
    return(object$ConstVar)
}

VectorToRegArchParam.ConstVarClass <- function(object, vect)
{
    Res <- object
    Res$ConstVar <- vect[1]
    return(Res)
}

RegArchParamToVector.ARCHClass <- function(object)
{
    return(c(object$ConstVar, object$ARCH))
}

VectorToRegArchParam.ARCHClass <- function(object, vect)
{
    Res <- object
    Res$ConstVar <- vect[1]
    Res$ARCH <- vect[2:(object$nARCH+1)]
    return(Res)
}

RegArchParamToVector.GARCHClass <- function(object)
{
    return(c(object$ConstVar, object$ARCH,  object$GARCH))
}

VectorToRegArchParam.GARCHClass <- function(object, vect)
{
    Res <- object
    Res$ConstVar <- vect[1]
    Res$ARCH <- vect[2:(object$nARCH+1)]
    Res$GARCH <- vect[(object$nARCH+2):(object$nARCH+object$nGARCH+1)]
    return(Res)
}

RegArchParamToVector.TARCHClass <- function(object)
{
    return(c(object$ConstVar, object$ARCHPlus,  object$ARCHMinus))
}

VectorToRegArchParam.TARCHClass <- function(object, vect)
{
    Res <- object
    Res$ConstVar <- vect[1]
    Res$ARCHPlus <- vect[2:(object$nARCH+1)]
    Res$ARCHMinus <- vect[(object$nARCH+2):(2*object$nARCH+1)]
    return(Res)
}

RegArchParamToVector.EGARCHClass <- function(object)
{
    return(c(object$ConstVar, object$ARCH,  object$GARCH, object$Theta, object$Gamma))
}

VectorToRegArchParam.EGARCHClass <- function(object, vect)
{
    Res <- object
    Res$ConstVar <- vect[1]
    Res$ARCH <- vect[2:(object$nARCH+1)]
    Res$GARCH <- vect[(object$nARCH+2):(object$nARCH+object$nGARCH+1)]
    Res$Theta <- vect[object$nARCH+object$nGARCH+2]
    Res$Gamma <- vect[object$nARCH+object$nGARCH+3]
    return(Res)
}

RegArchParamToVector.APARCHClass <- function(object)
{
    return(c(object$ConstVar, object$ARCH,  object$Gamma, object$GARCH, object$Delta ))
}

VectorToRegArchParam.APARCHClass <- function(object, vect)
{
    Res <- object
    Res$ConstVar <- vect[1]
    Res$ARCH <- vect[2:(object$nARCH+1)]
    Res$Gamma <- vect[(object$nARCH+2):(2*object$nARCH+1)]
    Res$GARCH <- vect[(2*object$nARCH+2):(2*object$nARCH+object$nGARCH+1)]
    Res$Delta <- vect[2*object$nARCH+object$nGARCH+2]
   return(Res)
}

GetNParam.condVarClass <- function(object)
{
    return(NextMethod(generic="GetNParam", object=object))
}

GetNParam.condResidualsClass <- function(object)
{
    return(NextMethod(generic="GetNParam", object=object))
}

RegArchParamToVector.normalClass <- function(object)
{
    return(NULL)
}

VectorToRegArchParam.normalClass <- function(object, vect)
{
    Res<-object
    return(Res)
}

RegArchParamToVector.studentClass <- function(object)
{
    return(object$distrParameter)
}

VectorToRegArchParam.studentClass <- function(object, vect)
{
    Res <- object
    Res$distrParameter <- vect[1]
    return(Res)
}

RegArchSim <- function(nSimul, model)
{   nSim <- as.integer(nSimul)
    if (class(model) != "RegArchModelClass")
    {   stop("model must be a RegArchModelClass parameter. See modelSet")
    }
    
    model1 <- setStorageMode(model)
    Res1 <- .Call(C_RRegArchSimul, nSim, model1)
    names(Res1) <- c("Yt", "mt", "ht", "ut", "Epst")  
    return(Res1)         
}

RegArchLLH <- function(Yt, model)
{
    if (!is.vector(Yt))
        stop("Yt must be a vector\n")
    if (class(model) != "RegArchModelClass")
    {   stop("model must be a RegArchModelClass parameter. See modelSet")
    }
    model1 <- setStorageMode(model)
    storage.mode(Yt) <- "double"
    Res1 <- .Call(C_RRegArchLLH, length(Yt), list(Yt), model1)
    return(Res1)
}
 
RegArchGradLLH <- function(Yt, model)
{
    if (!is.vector(Yt))
        stop("Yt must be a vector\n")
    if (class(model) != "RegArchModelClass")
    {   stop("model must be a RegArchModelClass parameter. See modelSet")
    }
    model1 <- setStorageMode(model)
    storage.mode(Yt) <- "double"
    Res1 <- .Call(C_RRegArchGradLLH, length(Yt), list(Yt), model1)
    return(Res1)
}

optimfn <- function(Theta, Yt, model)
{
    model1 <- VectorToRegArchParam(model, Theta)
    Res <- -RegArchLLH(Yt, model1)
    return(Res)
}

optimgr <- function(Theta, Yt, model)
{
    model1 <- VectorToRegArchParam(model, Theta)
    Res <- -RegArchGradLLH(Yt, model1)
    return(Res)
}

SetInitPoint <- function(Yt, model)
{
    nMean <- GetNParam(model$condMean)
    nVar <- GetNParam(model$condVar)
    nRes <- GetNParam(model$condRes)
    j1 <- 1
    jmean <- 0
    for (i in 1:length(model$condMean))
    {   if (model$condMean[[i]]$meanType == eConst)
        {    jmean <- j1
        }
        else
        {   j1 <- j1 + GetNParam(model$condMean[[i]])
        }
    }
    Theta <- rep(0, nMean+nVar+nRes)
    
    if (jmean > 0)
        Theta[jmean] <- mean(Yt)
    
    if (!is.na(match(model$condVar$varType,c(eConstVar, eARCH, eGARCH, eTARCH))))
        Theta[nMean+1] <- var(Yt)
    else
    {   if (model$condVar$varType == eEGARCH)
            Theta[nMean+1] <- log(var(Yt))
        else
        {   Theta[nMean+1] <- var(Yt)
            Theta[nMean+nVar] <- 2
        }
    }
    if (nRes > 0)
        Theta[nMean+nVar+1] <- 50
    return(Theta)
}

 AsymptoticCovMat <- function(Yt, model, hh)
 {  if (!is.vector(Yt))
        stop("Yt must be a vector\n")
    if (class(model) != "RegArchModelClass")
    {   stop("model must be a RegArchModelClass parameter. See modelSet")
    }
    model1 <- setStorageMode(model)
    storage.mode(Yt) <- "double"
    Res1 <- .Call(C_RAsymptoticCovMat, length(Yt), list(Yt), model1, hh)
    return(Res1)
}

RegArchFit <- function(Yt, model, initPoint=NULL, method=NULL, h=1e-3, control = list())
{
	if (is.null(initPoint))
	{   Theta <- SetInitPoint(Yt, model)
	}
	else
	{   if (class(initPoint) == 'RegArchModelClass')
			Theta <- RegArchParamToVector(initPoint)
		else
			Theta <- initPoint
	}
	
	if (is.null(method))
		method <- c("Nelder-Mead")
		
    gr <- if (method == "SANN") NULL else optimgr
	
	if (.Call(C_IsGSLAvailable))
	{	Res0 <- .Call(C_RRegArchFit, list(Theta), length(Yt), list(Yt), model, method, -Inf, Inf, control)
	}
	else
	{	Res0 <- optim(par=Theta, fn=optimfn, gr=gr, Yt=Yt, model=model,
			method = method, lower = -Inf, upper = Inf, control = control, hessian = FALSE)
	}
	Res1 <- VectorToRegArchParam(model,Res0$par)
	matCov <- AsymptoticCovMat(Yt, Res1, h) 
	Res2 <- list(param=Res1, asymptCov=matCov, LLH=Res0$value, convergence=Res0$convergence)
	class(Res2) <- "RegArchFitClass"
	return(Res2)
}

print.RegArchFitClass <- function(x, ...)
{
    if (x$convergence != 0)
        cat(sprintf("No convergence\n"))
    print(x$param)
    cat(sprintf("LLH: %f\n", x$LLH))
}

summary.RegArchFitClass <- function(object, ...)
{
    ans = NULL
 
    label <- namesParam(object$param)
    asymptVar <- diag(object$asymptCov)
    se.coef <- sqrt(asymptVar)
    Value <- RegArchParamToVector(object$param)
    tval = Value/se.coef
    prob = 2 * (1 - pnorm(abs(tval)))
    
    Noms <- namesParam(object$param)
    ans$coef = cbind(Value, se.coef, tval, prob)
    dimnames(ans$coef) = list(Noms, c(" Estimate", 
        " Std. Error", " t value", "Pr(>|t|)"))
    class(ans) <- 'summary.RegArchFitClass'
    return(ans)
}

print.summary.RegArchFitClass <- function(x, ...)
{  
     cat("\nCoefficient(s):\n")
    cat("---------------\n")
    signif.stars = getOption("show.signif.stars")
    digits = max(4, getOption("digits") - 4)
    printCoefmat(x$coef, digits = digits, signif.stars = signif.stars, ...)
     
    invisible()
}

Try the RRegArch package in your browser

Any scripts or data that you put into this service are public.

RRegArch documentation built on May 2, 2019, 4:59 p.m.