R/rdcc-series.R

In rgarch: Flexible GARCH modelling in R

#################################################################################
##
##   R package rgarch by Alexios Ghalanos Copyright (C) 2008, 2009, 2010, 2011
##   This file is part of the R package rgarch.
##
##   The R package rgarch is free software: you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as published by
##   the Free Software Foundation, either version 3 of the License, or
##   (at your option) any later version.
##
##   The R package rgarch is distributed in the hope that it will be useful,
##   but WITHOUT ANY WARRANTY; without even the implied warranty of
##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##   GNU General Public License for more details.
##
#################################################################################
# function to deal with the numerous data formats present
# we want to extract the date from the data
.extractmdata = function(data)
{
	tsclass = class(data)[1]
	valid.choices = c("timeSeries", "zoo", "zooreg", "data.frame",
			"xts", "matrix")
	if(!any(valid.choices == tsclass)) stop("\nrdcc-->error: class of data object not recognized")
	x = switch(tsclass,
			timeSeries = .mseries.timeSeries(data),
			zoo = .mseries.zoo(data),
			zooreg = .mseries.zoo(data),
			xts = .mseries.xts(data),
			data.frame = .mseries.dataframe(data),
			matrix = .mseries.matrix(data))
	return(x)
}

.mseries.timeSeries = function(data){
	asset.names = colnames(data)
	x = unclass(data)
	if(!is.null(dim(data)[2]) && dim(data)[2]==1) stop("only multivariate datasets supported")
	xdata = as.matrix(x)
	rdates = .makedate(as.character(time(data)))
	if(rdates$status){
		xdates = rdates$dates
		dformat = rdates$dformat
	} else{
		xdates = 1:length(x)
		dformat = "numeric"
	}
	return(list(data = xdata, pos = xdates, dformat = dformat, asset.names = asset.names))
}


.mseries.zoo = function(data){
	asset.names = colnames(data)
	if(is.null(asset.names)) asset.names = paste("Asset_", 1:dim(data)[2], sep = "")
	x = unclass(data)
	if(!is.null(dim(data)[2]) && dim(data)[2]==1) stop("only multivariate datasets supported")
	xdata = as.matrix(x)
	rdates = .makedate(as.character(index(data)))
	if(rdates$status){
		xdates = rdates$dates
		dformat = rdates$dformat
	} else{
		xdates = 1:length(x)
		dformat = "numeric"
	}
	return(list(data = xdata, pos = xdates, dformat = dformat, asset.names = asset.names))
}

.mseries.xts = function(data){
	asset.names = colnames(data)
	x = unclass(data)
	if(!is.null(dim(data)[2]) && dim(data)[2]==1) stop("only multivariate datasets supported")
	xdata = as.matrix(x)
	rdates = .makedate(as.character(index(data)))
	if(rdates$status){
		xdates = rdates$dates
		dformat = rdates$dformat
	} else{
		xdates = 1:length(x)
		dformat = "numeric"
	}
	return(list(data = xdata, pos = xdates, dformat = dformat, asset.names = asset.names))
}

.mseries.dataframe = function(data){
	asset.names = colnames(data)
	xdata = as.matrix(data)
	if(!is.null(dim(data)[2]) && dim(data)[2]==1) stop("only multivariate datasets supported")
	if(!is.null(rownames(data))){
		rdates = .makedate(rownames(data))
		if(rdates$status){
			xdates = rdates$dates
			dformat = rdates$dformat
		} else{
			xdates = 1:length(xdata)
			dformat = "numeric"
		}
	} else{
		xdates = 1:length(xdata)
		dformat = "numeric"
	}
	return(list(data = xdata, pos = xdates, dformat = dformat, asset.names = asset.names))
}

.mseries.matrix<-function(data){
	asset.names = colnames(data)
	if(is.null(asset.names)) asset.names = paste("Asset_", 1:dim(data)[2], sep = "")
	xdata = as.matrix(data)
	if(!is.null(dim(data)[2]) && dim(data)[2]==1) stop("only multivariate datasets supported")
	if(!is.null(rownames(data))){
		rdates = .makedate(rownames(data))
		if(rdates$status){
			xdates = rdates$dates
			dformat = rdates$dformat
		} else{
			xdates = as.character(1:length(xdata))
			dformat = "numeric"
		}
	} else{
		xdates = as.character(1:length(xdata))
		dformat = "numeric"
	}
	return(list(data = xdata, pos = xdates, dformat = dformat, asset.names = asset.names))
}

.makedate = function(x)
{
	# find the divisor: 4 cases "-", "/", ".", and no divisor
	allc = strsplit(x[1], "")
	
	if(any(allc[[1]] == "-")){
		dt = "-"
		ld = length(which(diff(which(allc[[1]]!="-"))==1))+3
		dte = t(apply(as.data.frame(x), 1, FUN=function(z) as.numeric(strsplit(z, dt)[[1]]) ))
	} else if(any(allc[[1]] == "/")){
		dt = "/"
		ld = length(which(diff(which(allc[[1]]!="/"))==1))+3
		dte = t(apply(as.data.frame(x), 1, FUN=function(z) as.numeric(strsplit(z, dt)[[1]]) ))
	} else if(any(allc[[1]] == ".")){
		dt = "."
		dte = t(apply(as.data.frame(x), 1, FUN=function(z) as.numeric(strsplit(z, dt)[[1]]) ))
	} else{
		# this is a little more complicated
		ld = length(allc[[1]])
		if(ld==6){
			dte = t(apply(as.data.frame(x), 1, FUN=function(z) 
								as.numeric(c(substr(z, 1,2), substr(z, 3,4), substr(z, 5,6)))))
		} else if(ld==8){
			# 2 cases either the 4 digit year is at the beginning or else at the end
			dte.1 = as.vector(t(apply(as.data.frame(x), 1, FUN=function(z) 
								as.numeric(c(substr(z, 1,2))))))
			dte.2 = as.vector(t(apply(as.data.frame(x), 1, FUN=function(z) 
										as.numeric(c(substr(z, 5,6))))))
			if(all(dte.1>18)){
				dte = t(apply(as.data.frame(x), 1, FUN=function(z) 
									as.numeric(c(substr(z, 1,4), substr(z, 5,6), substr(z, 7,8)))))
			} else if(all(dte.2>18)){
				dte = t(apply(as.data.frame(x), 1, FUN=function(z) 
									as.numeric(c(substr(z, 1,2), substr(z, 3,4), substr(z, 5,8)))))
			} else{
				return(list(status=0))
			}
		} else{
			return(list(status=0))	
		}
	}
	m = 0
	for(i in 1:3){
		if(all(dte[,i]<=12)) m = i
	}
	if(m==0) return(list(status=0))
	sq = 1:3
	sq = sq[-m]
	y = 0 
	for(i in sq){
		if(any(dte[,i]>31)) y = i
	}
	if(y==0) return(list(status=0))
	d = sq[-y]
	dmatrix = cbind(dte[,d], dte[,m], dte[,y])
	colnames(dmatrix) = c("d","m","y")
	if(ld==6){
		ddates = as.Date(paste(dmatrix[,3], dmatrix[,2], dmatrix[,1], sep = "-"), format="%y-%m-%d")
		dformat = "%y-%m-%d"
	} else{
		ddates = as.Date(paste(dmatrix[,3], dmatrix[,2], dmatrix[,1], sep = "-"), format="%Y-%m-%d")
		dformat = "%Y-%m-%d"
	}
	

	return(list(datesmat = dmatrix, dates = ddates, dformat = dformat, status=1))
}


#---------------------------------------------------------------------------------
# lag functions
.embed = function(data, k, by = 1, ascending = FALSE)
{
	# n = no of time points, k = number of columns
	# by = increment. normally =1 but if =b calc every b-th point
	# ascending If TRUE, points passed in ascending order else descending.
	# Note that embed(1:n,k) corresponds to embedX(n,k,by=1,rev=TRUE)
	# e.g. embedX(10,3)
	#if(is.null(dim(data)[1])) n = length(data) else n = dim(data)[1]
	data = matrix(data, ncol = 1)
	n = dim(data)[1]
	s = seq(1, n - k + 1, by)
	lens = length(s)
	cols = if (ascending) 1:k else k:1
	return(matrix(data[s + rep(cols, rep(lens, k)) - 1], lens))
}

.lagx = function(data, n.lag = 1, removeNA = FALSE, pad = NA)
{
	# has NAs
	data = as.matrix(data)
	n = dim(data)[1]
	d = dim(data)[2]
	if(dim(data)[2] == 1) data = matrix(data, ncol = 1)
	z = apply(data, 2, FUN = function(x) .embed(x, n.lag + 1)[, n.lag + 1])
	if(!removeNA) z = rbind(matrix(pad, ncol = d, nrow = n.lag), z)
	return(z)
}

.lagmatrix = function(data, n.lag = 1, pad = 0)
{
	n = length(as.numeric(data))
	z = matrix(NA, ncol = n.lag, nrow = n)
	for(i in 1:n.lag) z[,i] = .lagx(as.numeric(data), i, removeNA = FALSE, pad = pad)
	z = cbind(data, z)
	colnames(z) = paste("lag-", 0:n.lag, sep = "")
	return(z)
}

repmat = function(a, n, m)
{
	kronecker(matrix(1, n, m), a)
}

size = function(x, n = NULL)
{
	x = as.matrix(x)
	if(missing(n)) sol = c(n = dim(x)[1], m = dim(x)[2]) else sol = dim(x)[n]
	return(sol)
}

zeros = function(n = 1, m = 1)
{
	if(missing(m)) m = n
	sol = matrix(0, nrow = n, ncol = m)
	return(sol)
}

ones = function(n = 1, m = 1)
{
	if(missing(m)) m = n
	sol = matrix(1, nrow = n, ncol = m)
	return(sol)
}

newlagmatrix = function(x,nlags,xc)
{
	nlags = nlags+1
	xt = size(x, 1);
	newX = rbind(x, zeros(nlags, 1))
	lagmatrix = repmat(newX, nlags, 1)
	lagmatrix = matrix(lagmatrix[1:(size(lagmatrix,1)-nlags)], nrow = (xt+nlags-1), ncol = nlags)
	lagmatrix = lagmatrix[nlags:xt,]
	y = lagmatrix[,1]
	x = lagmatrix[,2:nlags]
	if(xc == 1) x = cbind(ones(size(x,1), 1), x)
	return(data.frame(y = y, x = x))
}

.colorgradient = function(n = 50, low.col = 0.6, high.col=0.7, saturation = 0.8) {
	if (n < 2) stop("n must be greater than 2")
	n1 = n%/%2
	n2 = - n - n1
	c(hsv(low.col, saturation, seq(1, 0.5, length = n1)),
			hsv(high.col, saturation, seq(0.5, 1, length = n2)))
}

.simlayout = function(m)
{
	if(m == 1){
		nf = c(1, 1, 2, 2)
		nf = layout(matrix(nf, 2, 2, byrow = TRUE), respect = TRUE)
		middle.plot = 1
	}
	if(m == 2){
		nf = c(1, 1, 1, 1, 0, 2, 2, 0, 3, 3, 3, 3)
		nf = layout(matrix(nf, 3, 4, byrow = TRUE), respect = TRUE)
		middle.plot = 2
	}
	if(m == 3){
		nf = c(1, 0, 0, 2, 0, 3, 3, 0, 4, 0, 0, 5)
		nf = layout(matrix(nf, 3, 4, byrow = TRUE), respect = TRUE)
		middle.plot = 3
	}
	if(m == 12){
		nf = c(1, 2, 3, 4,
				5, 6, 6, 7,
				8, 6, 6, 9,
				10, 11, 12, 13)		
		nf = layout(matrix(nf, 4, 4, byrow = TRUE), respect = TRUE)
	}
}

.sdigit = function(x){
	sid = as.numeric(strsplit(format(as.numeric(x), scientific=TRUE), "e")[[1]])[2]
	10^(-sid)
}

.stars = function(testvector, levels = c(0.01, 0.05, 0.1))
{
	N = length(testvector)
	ans = vector(mode="character", length = N)
	#recursive replacement
	z = which(testvector<levels[3])
	ans[z] = c("*")
	z = which(testvector<levels[2])
	ans[z] = c("**")
	z = which(testvector<levels[1])
	ans[z] = c("***")
	ans
}