R/RRegArch.R

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

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 May 7, 2019, 3:14 p.m.