R/RRegArch.R
In gaspardcc/PMMMF:
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.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
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()
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.