R/RRegArch.R

Defines functions print.summary.RegArchFitClass summary.RegArchFitClass RRegArchModelToVector ComputeIandJmatrices AsymptoticCovMat RegArchGradLLH RegArchLLH print.RegArchFitClass RegArchFit RegArchSim print.NLOPTResultClass print.GSLResultClass nloptResultNamesAndClass gslResultNamesAndClass nolptErrorComment gslErrorComment setNLOPTParam setGSLParam print.RegArchModelClass namesParam.RegArchModelClass regArchValuesNamesAndClass regArchModelNamesAndClass modelSet condResidualsNamesAndClass residualsSet print.skewtClass namesParam.skewtClass skewtNamesAndClass skewtSet print.gedClass namesParam.gedClass gedNamesAndClass gedSet print.studentClass namesParam.studentClass studentNamesAndClass studentSet print.normalClass namesParam.normalClass print.condResidualsClass namesParam.condResidualsClass normalNamesAndClass normalSet condVarNamesAndClass print.UgarchClass namesParam.UgarchClass ugarchNamesAndClass ugarchSet print.FigarchClass namesParam.FigarchClass figarchNamesAndClass figarchSet print.AparchClass namesParam.AparchClass eaparchNamesAndClass aparchSet print.EgarchClass namesParam.EgarchClass egarchNamesAndClass egarchSet print.TarchClass namesParam.TarchClass tarchNamesAndClass tarchSet print.GarchClass namesParam.GarchClass garchNamesAndClass garchSet print.ArchClass namesParam.ArchClass archNamesAndClass archSet print.ConstVarClass namesParam.ConstVarClass constVarNamesAndClass constVarSet namesParam.condVarClass print.condVarClass varSet print.ArfimaClass namesParam.ArfimaClass 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 AddCondMean print.condMeanClass condMeanNamesAndClass meanSet arfimaNamesAndClass arfimaSet varInMeanNamesAndClass varInMeanSet stdInMeanNamesAndClass stdInMeanSet linRegNamesAndClass linRegSet mANamesAndClass mASet aRNamesAndClass aRSet constMeanNamesAndClass constMeanSet

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

constMeanNamesAndClass <- function(x)
{
    names(x) <- c("meanType", "nParam", "Const")
    class(x) <- "ConstMeanClass"
    return(x)
}

aRSet <- function(param)
{
    if (!is.vector(param))
    {   stop("wrong parameter type in meanSet(Ar=..) or meanSet(nAr=..)\n")
    }
    else
    {   nAr <- length(param)
        Res <- list(meanType=eAr, nParam=nAr, nAr = nAr, Ar=param)
    }
    class(Res) <- "ArClass"
    return(Res)
}

aRNamesAndClass <- function(x)
{
    names(x) <- c("meanType", "nParam", "nAr", "Ar")
    class(x) <- "ArClass"
    return(x)
}

mASet <- function(param)
{
    if (is.vector(param))
    {   nMa <- length(param)
        Res <- list(meanType=eMa, nParam=nMa, nMa = nMa, Ma=param)
    }
    else
    {    stop("wrong parameter type in meanSet(Ma=..) or meanSet(nMa=...)\n")
    }
    class(Res) <- "MaClass"
    return(Res)
}

mANamesAndClass <- function(x)
{
    names(x) <- c("meanType", "nParam", "nMa", "Ma")
    class(x) <- "MaClass"
    return(x)
}

linRegSet <- function(param)
{
    if (is.vector(param))
    {   nBeta=length(param)
        Res <- list(meanType=eLinReg, nParam=nBeta, nBeta=nBeta, Beta=param)
    }
    else
    {    stop("wrong parameter type in meanSet(LinReg=...) or meanSet(nLinReg=...)\n")
    }
    class(Res) <- "LinRegClass"
    return(Res)
}

linRegNamesAndClass <- function(x)
{
    names(x) <- c("meanType", "nParam", "nBeta", "Beta")
    class(x) <- "LinRegClass"
    return(x)
}

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

stdInMeanNamesAndClass <- function(x)
{
    names(x) <- c("meanType", "nParam", "Delta")
    class(x) <- "StdInMeanClass"
    return(x)
}

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

varInMeanNamesAndClass <- function(x)
{
    names(x) <- c("meanType", "nParam", "Delta")
    class(x) <- "VarInMeanClass"
    return(x)
}


arfimaSet <- function(param)
{
    if (is.list(param))
    {   if (!is.null(param$Ar) && !is.null(param$Ma) && !is.null(param$FracD))
        {
            nAr <- length(param$Ar)
            nMa <- length(param$Ma)
            Res <- list(meanType=eArfima, nParam=nAr+nMa+1, nAr=nAr, nMa=nMa, Ar=param$Ar, Ma=param$Ma, FracD=param$FracD)
        }
        else
        {    stop("wrong parameter type in meanSet(Arfima=list(Ar=.., Ma=.., FracD=..)\n")
        }
    }
    else
    {   if (is.vector(param))
        {   if (length(param) == 2)
            {   nAr=as.integer(param[1])
                nMa=as.integer(param[2])
                Res <- list(meanType=eArfima, nParam=nAr+nMa+1, nAr=nAr, nMa=nMa, Ar=rep(0, nAr), Ma=rep(0, nMa), FracD=1.0)
            }
            else
            {    stop("wrong parameter type in meanSet(Arfima=c(..., ...))\n")
            }
        }
        else
        {    stop("wrong parameter type in meanSet(Arfima=...)\n")
        }
    }
    class(Res) <- "ArfimaClass"
    return(Res)
}

arfimaNamesAndClass <- function(x)
{
    names(x) <- c("meanType", "nParam", "nAr", "nMa", "Ar", "Ma", "FracD")
    class(x) <- "ArfimaClass"
    return(x)
}

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],
                    Const = constMeanSet(args[[i]]),
                    Ar = aRSet(args[[i]]),
                    nAr = aRSet(rep(0, args[[i]])),
                    Ma =  mASet(args[[i]]),
                    nMa = mASet(rep(0, args[[i]])),
                    StdInMean = stdInMeanSet(args[[i]]),
                    VarInMean = varInMeanSet(args[[i]]),
                    LinReg = linRegSet(args[[i]]),
                    nLinReg = linRegSet(rep(0, args[[i]])),
                    Arfima = arfimaSet(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)
}

condMeanNamesAndClass <- function(x)
{
    n <- length(x)
    for (i in 1:n)
    {
        if (x[[i]][1] == eConst)
        {   x[[i]] <- constMeanNamesAndClass(x[[i]])
        }
        else if (x[[i]][1] == eAr)
        {   x[[i]] <- aRNamesAndClass(x[[i]])
        }
        else if (x[[i]][1] == eMa)
        {   x[[i]] <- mANamesAndClass(x[[i]])
        }
        else if (x[[i]][1] == eLinReg)
        {   x[[i]] <- linRegNamesAndClass(x[[i]])
        }
        else if (x[[i]][1] == eStdInmean)
        {   x[[i]] <- StdInMeanNamesAndClass(x[[i]])
        }
        else if (x[[i]][1] == eVarInMean)
        {   x[[i]] <- varInMeanNamesAndClass(x[[i]])
        }
        else if (x[[i]][1] == eArfima)
        {
            x[[i]] <- arfimaNamesAndClass(x[[i]])
        }
    }
    class(x) <- "condMeanClass"
    return(x)
}

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

AddCondMean <- function(m1,m2)
{
    if (class(m1) != "condMeanClass")
        stop("m1 parameter must be a condMeanClass object\n")
    if (class(m2) != "condMeanClass")
        stop("m2 parameter must be a condMeanClass object\n")
    Res <- c(m1,m2)
    class(Res) <- "condMeanClass"
    return(Res)
}

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)
}


namesParam.ArfimaClass <- function(object)
{   AuxNames <- NULL
    for (i in 1:object$nAr)
    {   AuxNames <- c(AuxNames, sprintf("AR[%d]", i))
    }
    for (i in 1:object$nMa)
    {   AuxNames <- c(AuxNames, sprintf("MA[%d]", i))
    }
    AuxNames <- c(AuxNames, "FracD")
    return(AuxNames)
}

print.ArfimaClass <- function(x, ...)
{
    cat(sprintf("\nArfima(%d,%d) model", x$nAr, x$nMa))
    Aux <- as.matrix(x$Ar)
    Aux <- rbind(Aux, as.matrix(x$Ma))
    Aux <- rbind(Aux, as.matrix(x$FracD))
    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, as.integer(arg)))),
                    Garch=garchSet(arg),
                    nGarch=garchSet(list(ConstVar=0.0, Arch=rep(0, as.integer(arg[1])), Garch=rep(0, as.integer(arg[2])))),
                    Tarch=tarchSet(arg),
                    nTarch=tarchSet(list(ConstVar=0.0, ArchPlus=rep(0, as.integer(arg)), ArchMinus=rep(0, as.integer(arg)))),
                    Egarch=egarchSet(arg),
                    nEgarch=egarchSet(list(ConstVar=0.0, Arch=rep(0, as.integer(arg[1])), Garch=rep(0, as.integer(arg[2])), Teta=0, Gamma=0)),
                    Aparch=aparchSet(arg),
                    nAparch=aparchSet(list(ConstVar=0.0, Arch=rep(0, as.integer(arg[1])), Gamma=rep(0, as.integer(arg[1])), Garch=rep(0, as.integer(arg[2])), Delta=2)),
                    Figarch=figarchSet(arg),
                    nFigarch=figarchSet(list(ConstVar=0.0, Arch=rep(0, as.integer(arg[1])), Garch=rep(0, as.integer(arg[2])), FracD=arg[3])),
                    Ugarch=ugarchSet(arg),
                    nUgarch=ugarchSet(list(ExistConstBool=as.logical(arg[1]), Beta=rep(0, as.integer(arg[2])), ConstVar=0.0, Arch=rep(0, as.integer(arg[3])), Garch=rep(0, as.integer(arg[4]))))
               )
     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
    {
        stop('wrong parameter type varSet(ConstVar=..)\n')

    }
    class(Res) <- "ConstVarClass"
    return(Res)
}

constVarNamesAndClass <- function(x)
{
    names(x) <- c("varType", "nParam", "ConstVar")
    class(x) <- "ConstVarClass"
    return(x)
}


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, nParam=nArch+1, nArch = nArch, ConstVar=Param$ConstVar, Arch=Param$Arch)
    class(Res) <- "ArchClass"
    return(Res)
}

archNamesAndClass <- function(x)
{
    names(x) <- c("varType", "nParam", "nArch", "ConstVar", "Arch")
    class(x) <- "ArchClass"
    return(x)
}
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$Garch must be a vector of doubles')

    nArch<- length(Param$Arch)
    nGarch <- length(Param$Garch)
    Res <- list(varType=eGarch, nParam=nArch+nGarch+1, nArch=nArch, nGarch=nGarch, ConstVar=Param$ConstVar, Arch=Param$Arch, Garch=Param$Garch)
    class(Res) <- "GarchClass"
    return(Res)
}

garchNamesAndClass <- function(x)
{
    names(x) <- c("varType", "nParam", "nArch", "nGarch", "ConstVar", "Arch", "Garch")
    class(x) <- "GarchClass"
    return(x)
}

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 <-c(x$ConstVar, x$Arch, 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,  nParam=2*nArch+1, nArch = nArch, ConstVar=Param$ConstVar, ArchPlus=Param$ArchPlus, ArchMinus=Param$ArchMinus)
    class(Res) <- "TarchClass"
    return(Res)
 }

tarchNamesAndClass <- function(x)
{
    names(x) <- c("varType", "nParam", "nArch", "ConstVar", "ArchPlus", "ArchMinus")
    class(x) <- "GarchClass"
    return(x)
}

namesParam.TarchClass <- 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("ARCH-[%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", Teta="double", Gamma="double")')
    if (length(Param) != 5)
        stop('Param must be a list (ConstVar="double", Arch="vector of doubles", Garch="vector of doubles", Teta="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$Teta))
        names(Param)[4] <- "Teta"

    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$Teta))
        stop('Param$Teta 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, nParam=nArch+nGarch+3, nArch = nArch, nGarch=nGarch, ConstVar=Param$ConstVar, Arch=Param$Arch, Garch=Param$Garch, Teta=Param$Teta, Gamma=Param$Gamma)
    class(Res) <- "EgarchClass"
    return(Res)
}

egarchNamesAndClass <- function(x)
{
    names(x) <- c("varType", "nParam", "nArch", "nGarch", "ConstVar", "Arch", "Garch", "Teta", "Gamma")
    class(x) <- "EgarchClass"
    return(x)
}

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, "Teta", "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$Teta
    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)[5] <- "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 vector')

    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,  nParam=2*nArch+nGarch+2, nArch = nArch, nGarch=nGarch, ConstVar=Param$ConstVar, Arch=Param$Arch, Gamma=Param$Gamma, Garch=Param$Garch, Delta=Param$Delta)
    class(Res) <- "AparchClass"
    return(Res)
}

eaparchNamesAndClass <- function(x)
{
names(x) <- c("varType", "nParam", "nArch", "nGarch", "ConstVar", "Arch", "Gamma", "Garch", "Delta")
class(x) <- "AparchClass"
return(x)
}

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)
}

figarchSet <- function(Param)
{
if (!is.list(Param))
        stop('Param must be a list (ConstVar="double", Arch="vector of doubles",Garch="vector of doubles", FracD="double")')
    if (length(Param) != 4)
         stop('Param must be a list (ConstVar="double", Arch="vector of doubles",Garch="vector of doubles", FracD="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$FracD))
        names(Param)[4] <- "FracD"

    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$FracD))
        stop('Param$FracD must be a double')


    nArch <- length(Param$Arch)
    nGarch <- length(Param$Garch)
    Res <- list(varType=eFigarch, nParam=nArch+nGarch+2, nArch = nArch, nGarch=nGarch,  ConstVar=Param$ConstVar, Arch=Param$Arch, Garch=Param$Garch, FracD=Param$FracD)
    class(Res) <- "FigarchClass"
    return(Res)
}

figarchNamesAndClass <- function(x)
{
    names(x) <- c("varType", "nParam", "nArch", "nGarch", "ConstVar", "Arch", "Garch", "FracD")
    class(x) <- "FigarchClass"
    return(x)
}

namesParam.FigarchClass <- 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, "Frac. d")
    return(AuxNames)
}

print.FigarchClass <- function(x, ...)
{
    cat(sprintf("FIGARCH(%d, %d) model\n", x$nArch, x$nGarch))
    Res <- c(x$ConstVar, x$Arch, x$Garch, x$FracD)
    names(Res) <- namesParam(x)
    Res1 <- as.data.frame(Res)
    names(Res1) <- " "
    print(Res1)
}

ugarchSet <- function(Param)
{   if (!is.list(Param))
        stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')
    ll <- length(Param)

    if ( (ll < 4) || (ll > 5) )
         stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')

    if (is.null(Param$ExistConstBool))
        stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')

    if ( (ll == 4) && (Param$ExistConstBool))
        stop('Error in ugarchSet: if ExistConstBool=TRUE, ConstVar must be set')

 #   if (!is.logical(Param$ExistConstBool))
 #       stop('ExistConstBool must be a boolean')

    if (is.null(Param$Beta))
        stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')

    if (ll == 5)
    {   if (is.null(Param$ConstVar))
        stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')

        if (is.null(Param$Arch))
        stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')

        if (is.null(Param$Garch))
        stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')
    }
    else
    {
        if (is.null(Param$Arch))
            stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')

        if (is.null(Param$Garch))
            stop('Param must be a list (ExistConstBool = "boolean", Beta="Vector of doubles", [ConstVar="double"], Arch="vector of doubles", Garch="vector of doubles")')

    }
    if (!is.vector(Param$Beta))
        stop('Beta must be a vector')


    if (ll == 5)
    {   if (!is.double(Param$ConstVar))
            stop('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')

    nArch<- length(Param$Arch)
    nGarch <- length(Param$Garch)
    nBeta <- length(Param$Beta)
    if (ll == 5)
        ConstVar <- Param$ConstVar
    else
        ConstVar <- 0

    Res <- list(varType=eUgarch, nParam=nArch+nGarch+nBeta+1*(Param$ExistConstBool), nArch=nArch, nGarch=nGarch, nBeta=nBeta, ExistConstBool=as.integer(Param$ExistConstBool), Beta=Param$Beta, ConstVar=ConstVar, Arch=Param$Arch, Garch=Param$Garch)
    class(Res) <- "UgarchClass"
    return(Res)
}

ugarchNamesAndClass <- function(x)
{
    names(x) <- c("varType", "nParam", "nArch", "nGarch", "nBeta", "ExistConstBool", "Beta", "ConstVar", "Arch", "Garch")
    class(x) <- "UgarchClass"
    return(x)
}


namesParam.UgarchClass <- function(object)
{   if (object$ExistConstBool)
    {   AuxNames <- "ConstVar"
    }
    else
    {    AuxNames <-NULL
    }
    for (i in 1:object$nBeta)
        AuxNames <- c(AuxNames, sprintf("BetaV[%d]", i))
    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.UgarchClass <- function(x, ...)
{
    cat(sprintf("UGARCH(%d, %d) model\n", x$nArch, x$nGarch))
    if (x$ExistConstBool)
    {   nn <- 1
        Res <- x$ConstVar
    }
    else
    {   nn <- 0
        Res <- NULL
    }
    Res <- c(Res, x$Beta, x$Arch, x$Garch)
    names(Res) <- namesParam(x)
    Res1 <- as.data.frame(Res)
    names(Res1) <- " "
    print(Res1)
}

condVarNamesAndClass <- function(x)
{
    if (x[1] == eConstVar)
    {   x <- constVarNamesAndClass(x)
    }
    else if (x[1] == eArch)
    {   x <- archNamesAndClass(x)
    }
    else if (x[1] == eGarch)
    {   x <- garchNamesAndClass(x)
    }
    else if (x[1] == eTarch)
    {   x <- tarchNamesAndClass(x)
    }
    else if (x[1] == eEgarch)
    {   x <- egarchNamesAndClass(x)
    }
    else if (x[1] == eAparch)
    {   x <- eaparchNamesAndClass(x)
    }
    else if (x[1] == eFigarch)
    {   x <- figarchNamesAndClass(x)
    }
    else if (x[1] == eUgarch)
    {   x <- ugarchNamesAndClass(x)
    }

    return(x)
}

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

normalNamesAndClass <- function(x)
{
    names(x) <- c("distrType", "nParam", "distrParameter")
    class(x) <- "normalClass"
    return(x)
}

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 (length(parameter)!=1)
        stop("parameter must be the number of d.o.f. for Student residuals\n")
    if (parameter <= 2)
        stop("the number of d.o.f. must be greater than 2\n")
    Res <- list(distrType=eStudent, nParam=1, distrParameter=parameter)
    class(Res) <- "studentClass"
    return(Res)
}

studentNamesAndClass <- function(x)
{
    names(x) <- c("distrType", "nParam", "distrParameter")
    class(x) <- "studentClass"
    return(x)
}

namesParam.studentClass<-function(object)
{   return("d.o.f.")
}

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

gedSet <- function(parameter)
{   if (length(parameter)!=1)
        stop("parameter must be the beta parameter for Ged residuals\n")
    if (parameter<0)
        stop("beta must be positive")

    Res <- list(distrType=eGed, nParam=1, distrParameter=parameter)
    class(Res) <- "gedClass"
    return(Res)
}

gedNamesAndClass <- function(x)
{
    names(x) <- c("distrType", "nParam", "distrParameter")
    class(x) <- "gedClass"
    return(x)
}

namesParam.gedClass<-function(object)
{   return("beta")
}

print.gedClass <- function(x, ...)
{   cat(sprintf("GED residuals with beta=%f\n", x$distrParameter))
}


skewtSet <- function(parameter)
{   if (length(parameter) != 2)
        stop("parameter must be the number of d.o.f. and gamma for skewt residuals\n")
    if (parameter[1] < 1)
        stop("number of d.o.f. must be strictly positive")
    if (parameter[2] < 0)
        stop("gamma must be positive")
    Res <- list(distrType=eSkewt, nParam=2, distrParameter=parameter)
    class(Res) <- "skewtClass"
    return(Res)
}

skewtNamesAndClass <- function(x)
{
    names(x) <- c("distrType", "nParam", "distrParameter")
    class(x) <- "skewtClass"
    return(x)
}

namesParam.skewtClass<-function(object)
{   return(c("d.o.f.", "gamma"))
}

print.skewtClass <- function(x, ...)
{   cat(sprintf("skewt residuals with %f dof and gamma=%f\n", x$distrParameter[1], x$distrParameter[2]))
}

residualsSet<-function(condResiduals, parameter=NULL)
{
    if (is.na(match(condResiduals, c('Normal', 'Student', 'Ged', 'Skewt'))))
        stop("CondResid must be in 'Normal', 'Student', 'Ged', 'Skewt'\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)
    }

    if (condResiduals == 'Ged')
    {   Res<-gedSet(parameter)
        class(Res) <- c("condResidualsClass", class(Res))
        return(Res)
    }

    if (condResiduals == 'Skewt')
    {   Res<-skewtSet(parameter)
        class(Res) <- c("condResidualsClass", class(Res))
        return(Res)
    }
}

condResidualsNamesAndClass <- function(x)
{
    if (x[1] == eNormal)
    {   x <- normalNamesAndClass(x)
    }
    else if (x[1] == eStudent)
    {   x <- studentNamesAndClass(x)
    }
    else if (x[1] == eGed)
    {   x <- gedNamesAndClass(x)
    }
    else if (x[1] == eSkewt)
    {   x <- skewtNamesAndClass(x)
    }
    return(x)
}

modelSet <- function(condMean, condVar, condRes)
{
    if (!is.null(condMean))
    {
        if (class(condMean) != "condMeanClass")
            stop("condMean must be a condMeanClass object or a NULL object. See condMeanSet.\n")
    }
    if (class(condVar)[1] != "condVarClass")
        stop("condVar must be a condVarClass object. See condVarSet.\n")
    if (class(condRes)[1] != "condResidualsClass")
        stop("condRes must be a condResidualsClass object. See condResidualsSet.\n")
    Res <- list(condMean=condMean, condVar=condVar, condRes=condRes)
    class(Res)<-"RegArchModelClass"
    return(Res)
}

regArchModelNamesAndClass <- function(x)
{
    if (!is.null(x[[1]]))
    {    x1 <- condMeanNamesAndClass(x[[1]])
    }
    else
        x1 <- NULL
    x2 <- condVarNamesAndClass(x[[2]])
    x3 <- condResidualsNamesAndClass(x[[3]])
    writeLines("[regArchModelNamesAndClass] ------\n object x[[3]][1]:\n")
    print(x[[3]][1])
    writeLines("object x3:\n")
    print(class(x3))
    writeLines("--------------------\n")
    xx <- list(condMean=x1, condVar=x2, condRes=x3)
    class(xx) <- "RegArchModelClass"
    return(xx)
}

regArchValuesNamesAndClass <- function(Yt, Xt, x)
{
    Res <- list(Yt=Yt, Xt=Xt, mt=x[[1]], ht=x[[2]], ut=x[[3]], epst=x[[4]])
    class(Res) <- "RegArchValueClass"
    return(Res)
}

namesParam.RegArchModelClass<-function(object)
{
    if (!is.null(object$condMean))
        return(c(namesParam(object$condMean), namesParam(object$condVar), namesParam(object$condRes)))
    else
        return(c(NULL,namesParam(object$condVar), namesParam(object$condRes)))
}

print.RegArchModelClass <- function(x, ...)
{
    if (!is.null(x$condMean))
    {   cat(sprintf("Conditional Mean Model:\n"))
        cat(sprintf("-----------------------"))
        if (is.list(x$condMean))
        {
            for (i in 1:length(x$condMean))
                print(x$condMean[[i]])
        }
        else
        {   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)
}

setGSLParam <- function(Algo = "gsl_BFGS", StepSize=0.01, Tol=0.1, StopValue=1e-6, NMaxIter=1000, NMaxSeconds = 100, Verbose=FALSE)
{
    if (is.character(Algo))
    {   AlgoType <-match(Algo, gslAlgoTypeStr)
        if (is.na(AlgoType))
        {   myMess <- sprintf("'%s'", gslAlgoTypeStr[1])
            for (i in 2:length(gslAlgoTypeStr))
            {    myMess<-sprintf("%s, '%s'", myMess, gslAlgoTypeStr[i])
            }
            myMess<-sprintf("Algo parameter must be in %s", myMess)
            stop(myMess)
        }
    }
    else
    {   if (!is.integer(Algo))
        {   stop("Algo parameter must be an integer or a string.")
        }
        else
        {   if ( (Algo > length(gslAlgoTypeStr) | (Algo < 1)) )
            {   myMess <- sprintf("Algo parameter must be an integer in 1..%d", length(gslAlgoTypeStr))
                stop(myMess)
            }
            else
                AlgoType = Algo
        }
   }
	Res <- list(AlgoType = AlgoType, StepSize = StepSize, Tol=Tol, StopValue = StopValue, NMaxIter=NMaxIter, NMaxSeconds=NMaxSeconds, Verbose=Verbose)
    class(Res) <- "GSLAlgoParamClass"
    return(Res)
}

setNLOPTParam <- function(Algo="nlopt_ld_tnewton", MaxComputeTime=600, StopVal=1e299, fTol=1e-6, xTol=1e-6, Verbose=FALSE, MaxFuncEval=1e299)
{   if (is.character(Algo))
    {   AlgoType <-match(Algo, nloptAlgoTypeStr)
        if (is.na(AlgoType))
        {   myMess <- sprintf("'%s'", nloptAlgoTypeStr[1])
            for (i in 2:length(nloptAlgoTypeStr))
               myMess <- sprintf("%s, '%s'", myMess, nloptAlgoTypeStr[i])
            myMess <- sprintf("Algo parameter must be in %s", myMess)
            stop(myMess)
        }
    }
    else
    {   if (!is.integer(Algo))
        {   stop("Algo parameter must be an integer or a string.")
        }
        else
        {   if ( (Algo >= length(nloptAlgoTypeStr) | (Algo < 1)) )
            {   myMess <- sprintf("Algo parameter must be an integer in 0..%d", length(nloptAlgoTypeStr)-1)
                stop(myMess)
            }
            else
                AlgoType = Algo
        }
   }
   Res <- list(AlgoType=AlgoType, MaxComputeTime=MaxComputeTime, StopVal=StopVal, fTol=fTol, xTol=xTol, Verbose=Verbose, MaxFuncEval=MaxFuncEval)
   class(Res) <- "NLOPTAlgoParam"
   return(Res)
}

gslErrorComment <- function(status)
{
      if (status==0)
        return("SUCCESS")
      else if (status == -1)
        return("General failure")
      else if (status ==-2)
        return("iteration has not converged")
      else if (status == 1)
        return("input domain error, e.g sqrt(-1)")
      else if (status == 2)
        return("output range error, e.g. exp(1e100)")
      else if (status == 3)
        return("invalid pointer")
      else if (status == 4)
        return("invalid argument supplied by user")
      else if (status == 5)
        return("generic failure")
      else if (status == 6)
        return("factorization failed")
      else if (status == 7)
        return("sanity check failed - shouldn't happen")
      else if (status == 8)
        return("malloc failed")
      else if (status == 9)
        return("problem with user-supplied function")
      else if (status == 10)
        return("iterative process is out of control")
      else if (status == 11)
        return("exceeded max number of iterations")
      else if (status == 12)
        return("tried to divide by zero")
      else if (status == 13)
        return("user specified an invalid tolerance")
      else if (status == 14)
        return("failed to reach the specified tolerance")
      else if (status == 15)
        return("underflow")
      else if (status == 16)
        return("overflow")
      else if (status == 17)
        return("loss of accuracy")
      else if (status == 18)
        return("failed because of roundoff error")
      else if (status == 19)
        return("matrix, vector lengths are not conformant")
      else if (status == 20)
        return("matrix not square")
      else if (status == 21)
        return("apparent singularity detected")
      else if (status == 22)
        return("integral or series is divergent")
      else if (status == 23)
        return("requested feature is not supported by the hardware")
      else if (status == 24)
        return("requested feature not (yet) implemented")
      else if (status == 25)
        return("cache limit exceeded")
      else if (status == 26)
        return("table limit exceeded")
      else if (status == 27)
        return("iteration is not making progress towards solution")
      else if (status == 28)
        return("jacobian evaluations are not improving the solution")
      else if (status == 29)
        return("cannot reach the specified tolerance in F")
      else if (status == 30)
        return("cannot reach the specified tolerance in X")
      else if (status == 31)
        return("cannot reach the specified tolerance in gradient")
      else if (status == 32)
        return("end of file")
}

nolptErrorComment <- function(status)
{
    if (status==-1)
        return("generic failure code")
    else if (status==-2)
        return("Invalid arguments")
    else if (status == -3)
        return("Out of memory")
    else if (status == -4)
        return("Roundoff limited")
    else if (status == -5)
        return("forced stop")
    else if (status == 1)
        return("Generic success")
    else if (status == 2)
        return("StopVal reached")
    else if (status == 3)
        return("fTol reached")
    else if (status == 4)
        return("xTol reached")
    else if (status == 5)
        return("MaxEval reached")
    else if (status == 6)
        return("MaxTime reached")
}

gslResultNamesAndClass <- function(x)
{
   y <- list(NIter=x[[1]][1], Convergence=as.logical(x[[2]][1]), CritValue=x[[3]][1], GradLLH=x[[4]], LLHValue=x[[5]][1], ComputeTime=x[[6]][1], ConvergenceStatus=x[[7]][1], ConvergenceComment=gslErrorComment(x[[7]][1]))
   class(y) <-"GSLResultClass"
   return(y)
}

nloptResultNamesAndClass <- function(x, AlgoNum)
{
    y <- list(Convergence = as.logical(x[[1]][1]), LLHValue=x[[2]][1], ConvergenceStatus=x[[3]][1], ConvergenceComment=nolptErrorComment(x[[3]][1]), ComputeTime=x[[4]][1], AlgoName=nloptAlgoName[AlgoNum+1])
    class(y) <-"NLOPTResultClass"
    return(y)
}


print.GSLResultClass <- function(x, ...)
{
    cat(sprintf("GSL Multimin Algorithm summary:\n"))
    cat(sprintf("-------------------------------\n"))
    if (x$Convergence)
    {   cat(sprintf("Convergence: TRUE\n"))
    }
    else
    {
        cat(sprintf("Convegence: FALSE\n"))
        cat(sprintf("Reason: %s\n", x$ConvergenceComment))
    }
    cat(sprintf("#Iter.: %d\n", x$NIter))
    cat(sprintf("Computing time = %f s\n", x$ComputeTime))
    cat(sprintf("Critical Value = %f\n", x$CritValue))
    cat(sprintf("LLH Value = %f s\n", x$LLHValue))
}

print.NLOPTResultClass <- function(x, ...)
{
    cat(sprintf("NLOPT Algorithm summary:\n"))
    cat(sprintf("------------------------\n"))
    cat(sprintf("Algorithm: %s\n", x$AlgoName))
    if (x$Convergence)
    {   cat(sprintf("Convergence: TRUE\n"))
    }
    else
    {
        cat(sprintf("Convegence: FALSE\n"))
        cat(sprintf("Reason: %s\n", x$ConvergenceComment))
    }
    cat(sprintf("Computing time = %f s\n", x$ComputeTime))
    cat(sprintf("LLH Value = %f\n", x$LLHValue))
}


RegArchSim <- function(nSimul, model, Xt=NULL)
{   nSim <- as.integer(nSimul)
    if (class(model) != "RegArchModelClass")
    {   stop("model must be a RegArchModelClass parameter. See modelSet")
    }

    model1 <- setStorageMode(model)
    if (!is.null(Xt))
    {
        storage.mode(Xt) <- "double"
    }
    Res1 <- .Call("RRegArchSimul", nSim, model1, Xt)
    names(Res1) <- c("Yt", "mt", "ht", "ut", "Epst")
    return(Res1)
}

RegArchFit <- function(model, Yt, AlgoParam=NULL, initPoint=NULL, Xt = NULL)
{   if (is.null(AlgoParam))
    {   AlgoParam <- setGSLParam()
    }

    model1 <- setStorageMode(model)
    print(model1$condRes)
    writeLines("\n")
    param1 <- setStorageMode(AlgoParam)
    if (class(AlgoParam) == "GSLAlgoParamClass")
    {   OptimLib <- as.integer(1)
    }
    else
    {
        OptimLib <- as.integer(2)
    }
#    value <- list(Yt=Yt, Xt=Xt)
    storage.mode(OptimLib) <- "integer"
    storage.mode(Yt) <- "double"
    if (!is.null(Xt))
    {   Xt <- as.matrix(Xt)
        storage.mode(Xt) <- "double"
    }
    if (!is.null(initPoint))
    {   if (class(initPoint) != "RegArchModelClass")
        {    stop("initPoint must be a RegArchModelClass object")
        }
        initPoint1 <- setStorageMode(initPoint)
    }
    else
    {   initPoint1 <- NULL
    }

    Res1 <- .Call("RRegArchFit", OptimLib,  model1, Yt, param1, initPoint1, Xt)
    # print(Res1[[1]])
    # writeLines("\n")
    if (class(AlgoParam) == "GSLAlgoParamClass")
    {   names(Res1) <- c("RegArchModel", "GSLResult", "Values")
        Res1$RegArchModel <- regArchModelNamesAndClass(Res1$RegArchModel)
        Res1$GSLResult <- gslResultNamesAndClass(Res1$GSLResult)
        Res1$Values <-regArchValuesNamesAndClass(Yt, Xt, Res1$Values)
        Res <- list(RegArchModel=Res1$RegArchModel, GSLResult=Res1$GSLResult, Values=Res1$Values)
    }
    else
    {   names(Res1) <- c("RegArchModel", "NLOPTResult", "Values")
        Res1$RegArchModel <- regArchModelNamesAndClass(Res1$RegArchModel)
        Res1$NLOPTResult <- nloptResultNamesAndClass(Res1$NLOPTResult, AlgoParam$Algo)
        Res1$Values <-regArchValuesNamesAndClass(Yt, Xt, Res1$Values)
        Res <- list(RegArchModel=Res1$RegArchModel, NLOPTResult=Res1$NLOPTResult, Values=Res1$Values)
    }
    class(Res) <- "RegArchFitClass"
    return(Res)
}

print.RegArchFitClass <- function(x ,...)
{
    if (!is.null(x$GSLResult))
    {   print(x$GSLResult)
    }
    else
    {
        print(x$NLOPTResult)
    }
    cat(sprintf("\n-----------------\n"))
    cat(sprintf(" Estimated Model:\n"))
    cat(sprintf("-----------------\n\n"))
    print(x$RegArchModel)
}


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("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("RRegArchGradLLH", length(Yt), list(Yt), model1)
    return(Res1)
}


 AsymptoticCovMat <- function(model, Yt, Xt=NULL)
 {
 if (!is.vector(Yt))
        stop("Yt must be a vector\n")
    if (!is.null(Xt))
    {
        if (!is.matrix(Xt))
        stop("Xt must be a matrix\n")
    }
    if (class(model) != "RegArchModelClass")
    {   stop("model must be a RegArchModelClass parameter. See modelSet")
    }
    model1 <- setStorageMode(model)
    storage.mode(Yt) <- "double"
    if (!is.null(Xt))
    {    storage.mode(Xt) <- "double"
    }

    Res1 <- .Call("RAsymptoticCovMat", model1, Yt, Xt)
    return(Res1)
}

 ComputeIandJmatrices <- function(model, Yt, Xt=NULL)
 {
 if (!is.vector(Yt))
        stop("Yt must be a vector\n")
    if (!is.null(Xt))
    {
        if (!is.matrix(Xt))
        stop("Xt must be a matrix\n")
    }
    if (class(model) != "RegArchModelClass")
    {   stop("model must be a RegArchModelClass parameter. See modelSet")
    }
    model1 <- setStorageMode(model)
    storage.mode(Yt) <- "double"
    if (!is.null(Xt))
    {    storage.mode(Xt) <- "double"
    }

    Res1 <- .Call("RComputeIandJ", model1, Yt, Xt)
    Res2 <- list(I=Res1[[1]], J=Res1[[2]])
    return(Res2)
}

RRegArchModelToVector <- function(model)
{
    model1 <- setStorageMode(model)
    Res <- .Call("RRegArchModelToVector", model1)
    return(Res)
}

summary.RegArchFitClass <- function(object, ...)
{
    ans = NULL
    asymptoticCovMat <- AsymptoticCovMat(object$RegArchModel, object$Values$Yt, object$Values$Xt)

    label <- namesParam(object$RegArchModel)
    asymptVar <- diag(asymptoticCovMat)
    se.coef <- sqrt(asymptVar)
    Value <- RRegArchModelToVector(object$RegArchModel)
    tval = Value/se.coef
    prob = 2 * (1 - pnorm(abs(tval)))

    ans$coef = cbind(Value, se.coef, tval, prob)
    dimnames(ans$coef) = list(label, 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()
}
gaspardcc/PMMMF documentation built on March 22, 2018, 6:52 a.m.