mFilter/ 0000755 0001762 0000144 00000000000 13475567234 011674 5 ustar ligges users mFilter/NAMESPACE 0000644 0001762 0000144 00000001030 13344157010 013063 0 ustar ligges users #useDynLib("mFilter")
import("graphics", "stats", "utils")
export("mFilter",
# "mFilter.default",
# "mFilter.ts",
"bwfilter",
"bkfilter",
"cffilter",
"hpfilter",
"trfilter",
"print.mFilter",
"summary.mFilter",
"plot.mFilter",
"fitted.mFilter",
"residuals.mFilter"
)
S3method("mFilter", "ts")
S3method("print", "mFilter")
S3method("summary", "mFilter")
S3method("plot", "mFilter")
S3method("fitted", "mFilter")
S3method("residuals", "mFilter")
mFilter/NEWS.md 0000644 0001762 0000144 00000000123 13351510725 012750 0 ustar ligges users mFilter 0.1-4
==============
- 2018-09-22 Minor fixes for new R versions.
mFilter/data/ 0000755 0001762 0000144 00000000000 13344157010 012563 5 ustar ligges users mFilter/data/unemp.R 0000755 0001762 0000144 00000004031 13344157010 014033 0 ustar ligges users unemp <- structure(c(5.83333333333, 5.1, 5.26666666667, 5.6, 5.13333333333,
5.23333333333, 5.53333333333, 6.26666666667, 6.8, 7, 6.76666666667,
6.2, 5.63333333333, 5.53333333333, 5.56666666667, 5.53333333333,
5.76666666667, 5.73333333333, 5.5, 5.56666666667, 5.46666666667,
5.2, 5, 4.96666666667, 4.9, 4.66666666667, 4.36666666667, 4.1,
3.86666666667, 3.83333333333, 3.76666666667, 3.7, 3.83333333333,
3.83333333333, 3.8, 3.9, 3.73333333333, 3.56666666667, 3.53333333333,
3.4, 3.4, 3.43333333333, 3.56666666667, 3.56666666667, 4.16666666667,
4.76666666667, 5.16666666667, 5.83333333333, 5.93333333333, 5.9,
6.03333333333, 5.93333333333, 5.76666666667, 5.7, 5.56666666667,
5.36666666667, 4.93333333333, 4.93333333333, 4.8, 4.76666666667,
5.13333333333, 5.2, 5.63333333333, 6.6, 8.26666666667, 8.86666666667,
8.46666666667, 8.3, 7.73333333333, 7.56666666667, 7.73333333333,
7.76666666667, 7.5, 7.13333333333, 6.9, 6.66666666667, 6.33333333333,
6, 6.03333333333, 5.9, 5.86666666667, 5.7, 5.86666666667, 5.96666666667,
6.3, 7.33333333333, 7.66666666667, 7.4, 7.43333333333, 7.4, 7.4,
8.23333333333, 8.83333333333, 9.43333333333, 9.9, 10.66666666667,
10.36666666667, 10.13333333333, 9.36666666667, 8.53333333333,
7.86666666667, 7.43333333333, 7.43333333333, 7.3, 7.23333333333,
7.3, 7.2, 7.03333333333, 7.03333333333, 7.16666666667, 6.96666666667,
6.83333333333, 6.6, 6.26666666667, 6, 5.83333333333, 5.7, 5.46666666667,
5.46666666667, 5.33333333333, 5.2, 5.23333333333, 5.23333333333,
5.36666666667, 5.3, 5.33333333333, 5.7, 6.13333333333, 6.6, 6.83333333333,
6.86666666667, 7.1, 7.36666666667, 7.6, 7.63333333333, 7.36666666667,
7.13333333333, 7.06666666667, 6.8, 6.63333333333, 6.56666666667,
6.2, 6, 5.63333333333, 5.46666666667, 5.66666666667, 5.66666666667,
5.56666666667, 5.53333333333, 5.5, 5.26666666667, 5.33333333333,
5.26666666667, 5, 4.86666666667, 4.66666666667, 4.66666666667,
4.43333333333, 4.5, 4.43333333333, 4.3, 4.3, 4.23333333333, 4.1,
4.03333333333, 4.03333333333, 4, 3.96666666667), .Tsp = c(1959,
2000.75, 4), class = "ts")
mFilter/R/ 0000755 0001762 0000144 00000000000 13344157010 012053 5 ustar ligges users mFilter/R/cffilter.R 0000755 0001762 0000144 00000027406 13475550213 014017 0 ustar ligges users ### Christiano-Fitzgerald filter
cffilter <- function(x,pl=NULL,pu=NULL,root=FALSE,drift=FALSE,
type=c("asymmetric","symmetric","fixed","baxter-king",
"trigonometric"),nfix=NULL,theta=1)
{
type = match.arg(type)
if(is.null(root)) root <- FALSE
if(is.null(drift)) drift <- FALSE
if(is.null(theta)) theta <- 1
if(is.null(type)) type <- "asymmetric"
if(is.ts(x))
freq=frequency(x)
else
freq=1
if(is.null(pl))
{
if(freq > 1)
pl=trunc(freq*1.5)
else
pl=2
}
if(is.null(pu))
pu=trunc(freq*8)
if(is.null(nfix))
nfix = freq*3
nq=length(theta)-1;
b=2*pi/pl;
a=2*pi/pu;
xname=deparse(substitute(x))
xo = x
x = as.matrix(x)
n = nrow(x)
nvars = ncol(x)
if(n < 5)
warning("# of observations < 5")
if(n < (2*nq+1))
stop("# of observations must be at least 2*q+1")
if(pu <= pl)
stop("pu must be larger than pl")
if(pl < 2)
{
warning("pl less than 2 , reset to 2")
pl = 2
}
if(root != 0 && root != 1)
stop("root must be 0 or 1")
if(drift<0 || drift > 1)
stop("drift must be 0 or 1")
if((type == "fixed" || type == "baxter-king") && nfix < 1)
stop("fixed lag length must be >= 1")
if(type == "fixed" & nfix < nq)
stop("fixed lag length must be >= q")
if((type == "fixed" || type == "baxter-king") && nfix >= n/2)
stop("fixed lag length must be < n/2")
if(type == "trigonometric" && (n-2*floor(n/2)) != 0)
stop("trigonometric regressions only available for even n")
theta = as.matrix(theta)
m1 = nrow(theta)
m2 = ncol(theta)
if(m1 > m2)
th=theta
else
th=t(theta)
## compute g(theta)
## [g(1) g(2) .... g(2*nq+1)] correspond to [c(q),c(q-1),...,c(1),
## c(0),c(1),...,c(q-1),c(q)]
## cc = [c(0),c(1),...,c(q)]
## ?? thp=flipud(th)
g=convolve(th,th,type="open")
cc = g[(nq+1):(2*nq+1)]
## compute "ideal" Bs
j = 1:(2*n)
B = as.matrix(c((b-a)/pi, (sin(j*b)-sin(j*a))/(j*pi)))
## compute R using closed form integral solution
R = matrix(0,n,1)
if(nq > 0)
{
R0 = B[1]*cc[1] + 2*t(B[2:(nq+1)])%*%cc[2:(nq+1)]
R[1] = pi*R0
for(i in 2:n)
{
dj = Bge(i-2,nq,B,cc)
R[i] = R[i-1] - dj
}
}
else
{
R0 = B[1]*cc[1]
R[1] = pi*R0;
for(j in 2:n)
{
dj = 2*pi*B[j-1]*cc[1];
R[j] = R[j-1] - dj;
}
}
AA = matrix(0,n,n)
### asymmetric filter
if(type == "asymmetric")
{
if(nq==0)
{
for(i in 1:n)
{
AA[i,i:n] = t(B[1:(n-i+1)])
if(root)
AA[i,n] = R[n+1-i]/(2*pi)
}
AA[1,1] = AA[n,n]
## Use symmetry to construct bottom 'half' of AA
AAu = AA
AAu[!upper.tri(AAu)] <- 0
AA = AA + flipud(fliplr(AAu))
}
else
{
## CONSTRUCT THE A MATRIX size n x n
A = Abuild(n,nq,g,root)
Ainv = solve(A)
## CONSTRUCT THE d MATRIX size n x 1
for(np in 0:ceiling(n/2-1))
{
d = matrix(0,n,1)
ii = 0
for(jj in (np-root):(np+1+root-n))
{
ii = ii+1
d[ii] = Bge(jj,nq,B,cc)
}
if (root == 1)
d[n-1] = R[n-np]
## COMPUTE Bhat = inv(A)*d
Bhat = Ainv%*%d
AA[np+1,] = t(Bhat)
}
## Use symmetry to construct bottom 'half' of AA
AA[(ceiling(n/2)+1):n,] = flipud(fliplr(AA[1:floor(n/2),]))
}
}
### symmetric filter
if (type == "symmetric")
{
if(nq==0)
{
for(i in 2:ceiling(n/2))
{
np = i-1
AA[i,i:(i+np)] = t(B[1:(1+np)])
if(root)
AA[i,i+np] = R[np+1]/(2*pi);
AA[i,(i-1):(i-np)] = AA[i,(i+1):(i+np)];
}
## Use symmetry to construct bottom 'half' of AA
AA[(ceiling(n/2)+1):n,] = flipud(fliplr(AA[1:floor(n/2),]))
}
else
{
for(np in nq:ceiling(n/2-1))
{
nf = np
nn = 2*np+1
## CONSTRUCT THE A MATRIX size nn x nn
A = Abuild(nn,nq,g,root)
Ainv = solve(A)
## CONSTRUCT THE d MATRIX size nn x 1
d = matrix(0,nn,1)
ii = 0
for(jj in (np-root):(-nf+root))
{
ii = ii+1
d[ii] = Bge(jj,nq,B,cc)
}
if(root)
d[nn-1] = R[nf+1]
## COMPUTE Bhat = inv(A)*d
Bhat = Ainv%*%d
AA[np+1,1:(2*np+1)] = t(Bhat)
}
## Use symmetry to construct bottom 'half' of AA
AA[(ceiling(n/2)+1):n,] = flipud(fliplr(AA[1:floor(n/2),]))
}
}
### fixed length symmetric filter
if (type == "fixed")
{
if(nq==0)
{
bb = matrix(0,2*nfix+1,1)
bb[(nfix+1):(2*nfix+1)] = B[1:(nfix+1)]
bb[nfix:1] = B[2:(nfix+1)]
if(root)
{
bb[2*nfix+1] = R[nfix+1]/(2*pi)
bb[1] = R[nfix+1]/(2*pi)
}
for(i in (nfix+1):(n-nfix))
AA[i,(i-nfix):(i+nfix)] = t(bb)
}
else
{
nn = 2*nfix+1
## CONSTRUCT THE A MATRIX size nn x nn
A = Abuild(nn,nq,g,root)
Ainv = solve(A)
## CONSTRUCT THE d MATRIX size nn x 1
d = matrix(0,nn,1)
ii = 0
for(jj in (nfix-root):(-nfix+root))
{
ii = ii+1
d[ii] = Bge(jj,nq,B,cc)
}
if(root)
d[nn-1] = R[nn-nfix]
## COMPUTE Bhat = inv(A)*d
Bhat = Ainv%*%d
for(ii in (nfix+1):(n-nfix))
AA[ii,(ii-nfix):(ii+nfix)] = t(Bhat)
}
}
### Baxter-King filter
if (type == "baxter-king")
{
bb = matrix(0,2*nfix+1,1)
bb[(nfix+1):(2*nfix+1)] = B[1:(nfix+1)]
bb[nfix:1] = B[2:(nfix+1)]
bb = bb - sum(bb)/(2*nfix+1)
for(i in (nfix+1):(n-nfix))
AA[i,(i-nfix):(i+nfix)] = t(bb)
}
### Trigonometric Regression filter
if(type == "trigonometric")
{
jj = 1:(n/2)
## find frequencies in desired band omitting n/2;
jj = jj[((n/pu)<=jj & jj<=(n/pl) & jj<(n/2))]
if(!any(jj))
stop("frequency band is empty in trigonometric regression")
om = 2*pi*jj/n
if(pl > 2)
{
for(t in 1:n)
{
for(k in n:1)
{
l = t-k
tmp = sum(cos(om*l))
AA[t,k] = tmp
}
}
}
else
{
for(t in 1:n)
{
for(k in n:1)
{
l = t-k
tmp = sum(cos(om*l))
tmp2 = (cos(pi*(t-l))*cos(pi*t))/2
AA[t,k] = tmp + tmp2
}
}
}
AA = AA*2/n
}
### check that sum of all filters equal 0 if assuming unit root
if(root)
{
tst = max(abs(c(apply(AA,1,sum))))
if((tst > 1.e-09) && root)
{
warning("Bhat does not sum to 0 ")
cat("test =",tst,"\n")
}
}
### compute filtered time series using selected filter matrix AA
if(drift)
x = undrift(x)
x.cycle = AA%*%as.matrix(x)
if(type=="fixed" || type=="symmetric" || type=="baxter-king")
{
if(nfix>0)
x.cycle[c(1:nfix,(n-nfix+1):n)] = NA
}
x.trend = x-x.cycle
if(is.ts(xo))
{
tsp.x = tsp(xo)
x.cycle=ts(x.cycle,start=tsp.x[1],frequency=tsp.x[3])
x.trend=ts(x.trend,start=tsp.x[1],frequency=tsp.x[3])
x=ts(x,start=tsp.x[1],frequency=tsp.x[3])
}
if(type=="asymmetric")
title = "Chiristiano-Fitzgerald Asymmetric Filter"
if(type=="symmetric")
title = "Chiristiano-Fitzgerald Symmetric Filter"
if(type=="fixed")
title = "Chiristiano-Fitzgerald Fixed Length Filter"
if(type=="baxter-king")
title = "Baxter-King Fixed Length Filter"
if(type=="trigonometric")
title = "Trigonometric Regression Filter"
res <- list(cycle=x.cycle,trend=x.trend,fmatrix=AA,title=title,
xname=xname,call=as.call(match.call()),
type=type,pl=pl,pu=pu,nfix=nfix,root=root,drift=drift,
theta=theta,method="cffilter",x=x)
return(structure(res,class="mFilter"))
}
###======================================================================
### Functions
###======================================================================
Bge <- function(jj,nq,B,cc)
{
###
### closed form solution for integral of B(z)g(z)(1/z)^j (eqn 16)
### nq > 0, jj >= 0
### if nq = 0, y = 2*pi*B(absj+1)*cc(1);
###
absj =abs(jj)
if(absj >= nq)
{
dj = B[absj+1]*cc[1] + t(B[(absj+2):(absj+nq+1)])%*%cc[2:(nq+1)]
dj = dj + t(flipud(B[(absj-nq+1):absj]))%*%cc[2:(nq+1)]
}
else if(absj >= 1)
{
dj = B[absj+1]*cc[1] + t(B[(absj+2):(absj+nq+1)])%*%cc[2:(nq+1)]
dj = dj + t(flipud(B[1:absj]))%*%cc[2:(absj+1)]
dj = dj + t(B[2:(nq-absj+1)])%*%cc[(absj+2):(nq+1)]
}
else
dj = B[absj+1]*cc[1] + 2*t(B[2:(nq+1)])%*%cc[2:(nq+1)]
y = 2*pi*dj
return(y)
}
###
###-----------------------------------------------------------------------
###
Abuild <- function(nn,nq,g,root)
{
###
### builds the nn x nn A matrix in A.12
### if root == 1 (unit root)
### Abig is used to construct all but the last 2 rows of the A matrix
### elseif root == 0 (no unit root)
### Abig is used to construct the entire A matrix
###
if(root)
{
Abig=matrix(0,nn,nn+2*(nq-1))
for(j in 1:(nn-2))
Abig[j,j:(j+2*nq)] = t(g)
A = Abig[,nq:(nn+nq-1)]
## construct A(-f)
Q = -matrix(1,nn-1,nn)
##Q = tril(Q);
Q[upper.tri(Q)] <- 0
F = matrix(0,1,nn-1)
F[(nn-1-nq):(nn-1)] = g[1:(nq+1)]
A[(nn-1),] = F%*%Q
## construct last row of A
A[nn,] = matrix(1,1,nn)
}
else
{
Abig=matrix(0,nn,nn+2*(nq-0))
for(j in 1:nn)
{
Abig[j,j:(j+2*nq)] = c(g)
}
A = Abig[,(nq+1):(nn+nq)]
}
## multiply A by 2*pi
A = 2*pi*A
return(A)
}
###
###-----------------------------------------------------------------------
###
undrift <- function(x)
{
###
### This function removes the drift or a linear time trend from a time series using the formula
### drift = (x(n) - x(1)) / (n-1).
###
### Input: x - data matrix x where columns represent different variables, x is (n x # variables).
### Output: xun - data matrix same size as x with a different drift/trend removed from each variable.
###
x = as.matrix(x)
nv = dim(x)
n = nv[1]
nvars = nv[2]
xun = matrix(0,n,nvars)
dd = as.matrix(0:(n-1))
for(ivar in 1:nvars)
{
drift = (x[n,ivar]-x[1,ivar]) / (n-1)
xun[,ivar] = x[,ivar] - dd*drift
}
if(nvars==1) xun = c(xun)
return(xun)
}
###
###-----------------------------------------------------------------------
###
###?function that reverses the columns of a matrix (matlab equivalent)
flipud <- function(x) {apply(as.matrix(x),2,rev)}
###?function that reverses the rows of a matrix (matlab equivalent)
fliplr <- function(x) {t(apply(as.matrix(x),1,rev))}
mFilter/R/hpfilter.R 0000755 0001762 0000144 00000003572 13344157010 014025 0 ustar ligges users ### Hodrick-Prescott filter
hpfilter <- function(x,freq=NULL,type=c("lambda","frequency"),drift=FALSE)
{
if(is.null(drift)) drift <- FALSE
xname=deparse(substitute(x))
type=match.arg(type)
if(is.null(type)) type <- "lambda"
if(is.ts(x))
{
tsp.x <- tsp(x)
frq.x <- frequency(x)
if(type=="lambda")
{
if(is.null(freq))
{
if(frq.x==1)
lambda = 6
if(frq.x==4)
lambda = 1600
if(frq.x==12)
lambda = 129600
}
else
lambda = freq
}
}
else
{
if(type=="lambda")
{
if(is.null(freq))
stop("freq is NULL")
else
lambda = freq
}
}
if(type=="frequency")
{
if(is.null(freq))
stop("freq is NULL")
else
lambda = (2*sin(pi/freq))^-4
}
xo = x
x = as.matrix(x)
if(drift)
x = undrift(x)
n = length(x)
imat = diag(n)
Ln = rbind(matrix(0,1,n),diag(1,n-1,n))
Ln = (imat-Ln)%*%(imat-Ln)
Q = t(Ln[3:n,])
SIGMA.R = t(Q)%*%Q
SIGMA.n = diag(n-2)
g = t(Q)%*%as.matrix(x)
b = solve(SIGMA.n+lambda*SIGMA.R,g)
x.cycle = c(lambda*Q%*%b)
x.trend = x-x.cycle
if(is.ts(xo))
{
tsp.x = tsp(xo)
x.cycle=ts(x.cycle,start=tsp.x[1],frequency=tsp.x[3])
x.trend=ts(x.trend,start=tsp.x[1],frequency=tsp.x[3])
x=ts(x,start=tsp.x[1],frequency=tsp.x[3])
}
A = lambda*Q%*%solve(SIGMA.n+lambda*SIGMA.R)%*%t(Q)
res <- list(cycle=x.cycle,trend=x.trend,fmatrix=A,title="Hodrick-Prescott Filter",
xname=xname,call=as.call(match.call()),
type=type,lambda=lambda,method="hpfilter",x=x)
return(structure(res,class="mFilter"))
}
mFilter/R/bwfilter.R 0000755 0001762 0000144 00000003205 13344157010 014017 0 ustar ligges users ### Butterworth filter
bwfilter <- function(x,freq=NULL,nfix=NULL,drift=FALSE)
{
if(is.null(drift)) drift <- TRUE
xname=deparse(substitute(x))
if(is.ts(x))
frx=frequency(x)
else
frx=1
if(is.null(freq))
{
if(frx > 1)
freq=trunc(frx*2.5)
else
freq=2
}
if(is.null(nfix))
nfix = 2
xo = x
x = as.matrix(x)
if(drift)
x = undrift(x)
n = length(x)
cut.off = 2*pi/freq
mu = (1/tan(cut.off/2))^(2*nfix)
imat = diag(n)
Ln = rbind(matrix(0,1,n),diag(1,n-1,n))
Ln = imat-Ln
if(nfix > 1)
{
for(i in 1:(nfix-1))
Ln = (imat-Ln)%*%Ln
}
Q = t(Ln[3:n,])
SIGMA.R = t(Q)%*%Q
SIGMA.n = abs(SIGMA.R)
g = t(Q)%*%as.matrix(x)
b = solve(SIGMA.n+mu*SIGMA.R,g)
x.cycle = c(mu*Q%*%b)
x.trend = x-x.cycle
if(is.ts(xo))
{
tsp.x = tsp(xo)
x.cycle=ts(x.cycle,start=tsp.x[1],frequency=tsp.x[3])
x.trend=ts(x.trend,start=tsp.x[1],frequency=tsp.x[3])
x=ts(x,start=tsp.x[1],frequency=tsp.x[3])
}
A = mu*Q%*%solve(SIGMA.n+mu*SIGMA.R)%*%t(Q)
if(is.ts(xo))
{
tsp.x = tsp(xo)
x.cycle=ts(x.cycle,start=tsp.x[1],frequency=tsp.x[3])
x.trend=ts(x.trend,start=tsp.x[1],frequency=tsp.x[3])
x=ts(x,start=tsp.x[1],frequency=tsp.x[3])
}
res <- list(cycle=x.cycle,trend=x.trend,fmatrix=A,title="Butterworth Filter",
xname=xname,call=as.call(match.call()),
type="asymmetric",lambda=mu,nfix=nfix,freq=freq,method="bwfilter",x=x)
return(structure(res,class="mFilter"))
}
mFilter/R/mFilter.R 0000755 0001762 0000144 00000007727 13344157010 013620 0 ustar ligges users ## Generic mFilter functions
## Part of mFilter package
mFilter <- function(x, ...) UseMethod("mFilter")
mFilter.default <- function(x, ...) mFilter.ts(x, ...)
mFilter.ts <- function(x, filter=c("HP","BK","CF","BW","TR"), ...)
{
filt = match.arg(filter)
call = match.call()
ag = list(...)
switch(filt,
"HP" = {res <- hpfilter(x,freq=ag$freq,type=ag$type,drift=ag$drift)},
"BK" = {res <- bkfilter(x,pl=ag$pl,pu=ag$pu,nfix=ag$nfix,type=ag$type,drift=ag$drift)},
"CF" = {res <- cffilter(x,pl=ag$pl,pu=ag$pu,root=ag$root,drift=ag$drift,
type=ag$type, nfix=ag$nfix,theta=ag$theta)},
"BW" = {res <- bwfilter(x,freq=ag$freq,nfix=ag$nfix,drift=ag$drift)},
"TR" = {res <- trfilter(x,pl=ag$pl,pu=ag$pu,drift=ag$drift)}
)
res$xname <- deparse(substitute(x))
return(res)
}
print.mFilter <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
if (!inherits(x, "mFilter"))
stop("method is only for mFilter objects")
# Title:
cat("\nTitle:\n ")
cat(x$title, "\n")
## Call:
cat("\nCall:\n ")
cat(paste(deparse(x$call), sep = "\n", collapse = "\n"),
"\n", sep = "")
## Method:
cat("\nMethod:\n ", x$method, "\n", sep = "")
## Filter Type:
cat("\nFilter Type:\n ", x$type, "\n", sep = "")
## Series
cat("\nSeries:\n ", x$xname, "\n\n", sep = "")
names <- c(x$xname,"Trend","Cycle")
out <- cbind(x$x,x$trend,x$cycle)
colnames(out) <- names
rownames(out) <- time(x$x)
if(any(frequency(x$x) == c(4,12)))
print(out, digits=digits)
else
print(as.data.frame(out),digits = digits)
invisible(x)
}
summary.mFilter <- function(object, digits = max(3, getOption("digits") - 3), ...)
{
if (!inherits(object, "mFilter"))
stop("method is only for mFilter objects")
## Title:
cat("\nTitle:\n ")
cat(object$title, "\n")
## Call:
cat("\nCall:\n ")
cat(paste(deparse(object$call), sep = "\n", collapse = "\n"),
"\n", sep = "")
## Method:
cat("\nMethod:\n ", object$method, "\n", sep = "")
## Filter Type:
cat("\nFilter Type:\n ", object$type, "\n", sep = "")
## Series
cat("\nSeries:\n ", object$xname, "\n", sep = "")
names <- c(object$xname,"Trend","Cycle")
out <- cbind(object$x,object$trend,object$cycle)
colnames(out) <- names
rownames(out) <- time(object$x)
cat("\nDescriptive Statistics:\n ", "\n", sep = "")
print(summary(out), digits = digits)
#browser()
gof <- function(object)
{
res <- object$cycle
pe <- res/object$x
out <- c(mean(res,na.rm=TRUE), mean(res^2,na.rm=TRUE),
mean(abs(res),na.rm=TRUE), mean(pe,na.rm=TRUE), mean(abs(pe),na.rm=TRUE))
names(out) <- c("ME","MSE","MAE","MPE","MAPE")
return(out)
}
cat("\nIn-sample error measures:\n")
print(gof(object), digits = digits)
cat("\n")
#if(any(frequency(object$x) == c(4,12)))
#print(out)
#else
#print(as.data.frame(out))
invisible(object)
}
plot.mFilter <- function(x, reference.grid = TRUE, col = "steelblue", ask=interactive(), ...)
{
if (!inherits(x, "mFilter"))
stop("method is only for mFilter objects")
opar <- par(no.readonly=TRUE)
par(ask=ask,mfrow=c(2,1),mar=c(3,2,2,1))
ag <- list(...)
if(is.null(ag$main))
main <- paste(x$title, "of", x$xname)
ylim <- range(c(x$x,x$trend),na.rm=TRUE)
plot(x$x,type="l",main=main,ylab="",ylim=ylim,col=col,...)
lines(x$trend,col="red")
if (reference.grid) grid()
legend("topleft",legend=c(x$xname,"trend"),col=c(col,"red"),lty=rep(1,2),ncol=2)
plot(x$cycle,type="l",main="Cyclical component (deviations from trend)",
ylab="",col=col,...)
if (reference.grid) grid()
par(opar)
invisible(x)
}
residuals.mFilter <- function(object, ...) return(object$cycle)
fitted.mFilter <- function(object, ...) return(object$trend)
mFilter/R/trfilter.R 0000755 0001762 0000144 00000000631 13344157010 014034 0 ustar ligges users ###
### Trigonometric regression filter
trfilter <- function(x,pl=NULL,pu=NULL,drift=FALSE)
{
if(is.null(drift)) drift <- FALSE
call <- as.call(match.call())
xname <- deparse(substitute(x))
res <- cffilter(x,pl=pl,pu=pu,drift=drift,root=FALSE,
type="trigonometric",nfix=0,theta=1)
res$method <- "trfilter"
res$call <- call
res$xname <- xname
return(res)
}
mFilter/R/bkfilter.R 0000755 0001762 0000144 00000004245 13344157010 014010 0 ustar ligges users ### Baxter-King filter
bkfilter <- function(x,pl=NULL,pu=NULL,nfix=NULL,type=c("fixed","variable"),drift=FALSE)
{
if(is.null(drift)) drift <- FALSE
xname=deparse(substitute(x))
type = match.arg(type)
if(is.null(type)) type <- "fixed"
if(is.ts(x))
freq=frequency(x)
else
freq=1
if(is.null(pl))
{
if(freq > 1)
pl=trunc(freq*1.5)
else
pl=2
}
if(is.null(pu))
pu=trunc(freq*8)
b = 2*pi/pl
a = 2*pi/pu
n = length(x)
if(n<5)
warning("# of observations in Baxter-King filter < 5")
if(pu<=pl)
stop("pu must be larger than pl")
if(pl<2)
{
warning("in Baxter-King kfilter, pl less than 2 , reset to 2")
pl = 2
}
if(is.null(nfix))
nfix = freq*3
if(nfix>=n/2)
stop("fixed lag length must be < n/2")
j = 1:(2*n)
B = as.matrix(c((b-a)/pi,(sin(j*b)-sin(j*a))/(j*pi)))
AA = matrix(0,n,n)
if(type=="fixed")
{
bb = matrix(0,2*nfix+1,1)
bb[(nfix+1):(2*nfix+1)] = B[1:(nfix+1)]
bb[nfix:1] = B[2:(nfix+1)]
bb = bb-sum(bb)/(2*nfix+1)
for(i in (nfix+1):(n-nfix))
AA[i,(i-nfix):(i+nfix)] = t(bb)
}
if(type=="variable")
{
for(i in (nfix+1):(n-nfix))
{
j=min(c(i-1,n-i))
bb=matrix(0,2*j+1,1)
bb[(j+1):(2*j+1)] = B[1:(j+1)]
bb[j:1] = B[2:(j+1)]
bb = bb-sum(bb)/(2*j+1)
AA[i,(i-j):(i+j)] = t(bb)
}
}
xo = x
x = as.matrix(x)
if(drift)
x = undrift(x)
x.cycle = AA%*%as.matrix(x)
x.cycle[c(1:nfix,(n-nfix+1):n)] = NA
x.trend = x-x.cycle
if(is.ts(xo))
{
tsp.x = tsp(xo)
x.cycle=ts(x.cycle,start=tsp.x[1],frequency=tsp.x[3])
x.trend=ts(x.trend,start=tsp.x[1],frequency=tsp.x[3])
x=ts(x,start=tsp.x[1],frequency=tsp.x[3])
}
res <- list(cycle=x.cycle,trend=x.trend,fmatrix=AA,title="Baxter-King Filter",
xname=xname,call=as.call(match.call()),
type=type,pl=pl,pu=pu,nfix=nfix,method="bkfilter",x=x)
return(structure(res,class="mFilter"))
}
mFilter/R/zzz.R 0000755 0001762 0000144 00000001513 13344157010 013036 0 ustar ligges users #.First.lib <-
.onAttach <- function(libname, pkgname) {
# mylib <- dirname(system.file(package = "mFilter"))
# ver <- packageDescription("mFilter", lib.loc = mylib)["Version"]
ver <- packageDescription("mFilter")$Version
txt <- c("\n",
paste(sQuote("mFilter"), "version:", ver),
"\n",
paste(sQuote("mFilter"),
"is a package for time series filtering"),
"\n",
paste("See",
sQuote("library(help=\"mFilter\")"),
"for details"),
"\n",
paste("Author: Mehmet Balcilar, mbalcilar@yahoo.com"),
"\n"
)
if (interactive() || getOption("verbose")) {
msg = paste(strwrap(txt, indent = 4, exdent = 4), collapse = "\n")
packageStartupMessage(msg)
}
}
mFilter/README.md 0000644 0001762 0000144 00000003665 13351527745 013161 0 ustar ligges users
# mFilter
The mFilter package implements several time series filters useful for
smoothing and extracting trend and cyclical components of a time series.
The routines are commonly used in economics and finance, however they
should also be interest to other areas. Currently,
Christiano-Fitzgerald, Baxter-King, Hodrick-Prescott, Butterworth, and
trigonometric regression filters are included in the package.
## Installation
You can install the released version of mFilter from
[CRAN](https://CRAN.R-project.org) with:
``` r
install.packages("mFilter")
```
The development version can be installed with:
``` r
devtools::install_github("mbalcilar/mFilter")
```
## Example
This is a basic example which shows you how to do Butterworth filtering:
``` r
library(mFilter)
data(unemp)
unemp.bw <- bwfilter(unemp)
plot(unemp.bw)
```
``` r
unemp.bw1 <- bwfilter(unemp, drift=TRUE)
unemp.bw2 <- bwfilter(unemp, freq=8,drift=TRUE)
unemp.bw3 <- bwfilter(unemp, freq=10, nfix=3, drift=TRUE)
unemp.bw4 <- bwfilter(unemp, freq=10, nfix=4, drift=TRUE)
```
``` r
par(mfrow=c(2,1),mar=c(3,3,2,1),cex=.8)
plot(unemp.bw1$x,
main="Butterworth filter of unemployment: Trend,
drift=TRUE",col=1, ylab="")
lines(unemp.bw1$trend,col=2)
lines(unemp.bw2$trend,col=3)
lines(unemp.bw3$trend,col=4)
lines(unemp.bw4$trend,col=5)
legend("topleft",legend=c("series", "freq=10, nfix=2",
"freq=8, nfix=2", "freq=10, nfix=3", "freq=10, nfix=4"),
col=1:5, lty=rep(1,5), ncol=1)
```
``` r
plot(unemp.bw1$cycle,
main="Butterworth filter of unemployment: Cycle,drift=TRUE",
col=2, ylab="", ylim=range(unemp.bw3$cycle,na.rm=TRUE))
lines(unemp.bw2$cycle,col=3)
lines(unemp.bw3$cycle,col=4)
lines(unemp.bw4$cycle,col=5)
```
mFilter/MD5 0000644 0001762 0000144 00000002253 13475567234 012206 0 ustar ligges users c86d79b5f7e0f699084088c9ac68d1bc *DESCRIPTION
389b960ac7b6503dfbb24c3862ad141e *NAMESPACE
045b75db9290b21a8e6569c01ca54120 *NEWS.md
8e506fea92a6917457a4bc4023a52045 *R/bkfilter.R
8c2cd857fa56bbb852e9c3612c6d501f *R/bwfilter.R
67f91cd91cd88b2308313f9c07a79de8 *R/cffilter.R
9987211fa7ba3f302fcc5203768cbf32 *R/hpfilter.R
d262ba68c0423449ad443ff81160bfa5 *R/mFilter.R
e2a5cd36073dc05afbc5197dafabd137 *R/trfilter.R
2df418fd31dea108be3aaf1c3ba8d22d *R/zzz.R
5b02b567394a8222d5cf7e8878faf849 *README.md
c2dc9412dbd38296ab06a59e97ac96f7 *data/unemp.R
934c3a0a01eccc6c05721aefebe0c231 *man/bkfilter.Rd
ec1df9ea219dc3dc02dd112cd036c0e9 *man/bwfilter.Rd
f735e4469dcc61455a128eb81aefd041 *man/cffilter.Rd
f0909577b840c697d885fbfa0d3cd8bc *man/figures/README-ex1-1.png
133fea2d2345ffd54724f7a81d400f46 *man/figures/README-ex2-1.png
b170f69b586208710a672c78ab5e3c93 *man/figures/README-ex3-1.png
b13a19b94d89d8be462dab6881eab462 *man/hpfilter.Rd
169de2e03795e4248b9fa8cfc298d95c *man/mFilter-methods.Rd
8e37d934818beece8e4537e2415a9400 *man/mFilter-package.Rd
de42f0b163a39bb8b869c03faf5842fe *man/mFilter.Rd
57a265b776d9196700145c0ea2db0cd1 *man/trfilter.Rd
f4364b8e8b76b92a2affa0083d2e01d4 *man/unemp.Rd
mFilter/DESCRIPTION 0000644 0001762 0000144 00000001667 13475567234 013414 0 ustar ligges users Package: mFilter
Title: Miscellaneous Time Series Filters
Date: 2019-07-04
Version: 0.1-5
Author: Mehmet Balcilar
Depends: R (>= 2.2.0), stats
Suggests: tseries, pastecs, locfit, tseriesChaos, tsDyn, forecast
Description: The mFilter package implements several time series filters useful
for smoothing and extracting trend and cyclical components of a
time series. The routines are commonly used in economics and
finance, however they should also be interest to other areas.
Currently, Christiano-Fitzgerald, Baxter-King,
Hodrick-Prescott, Butterworth, and trigonometric regression
filters are included in the package.
Maintainer: Mehmet Balcilar
License: GPL (>= 2)
URL: http://www.mbalcilar.net
Encoding: UTF-8
RoxygenNote: 6.1.1
NeedsCompilation: no
Packaged: 2019-06-04 20:52:13 UTC; mbalcilar
Repository: CRAN
Date/Publication: 2019-06-04 22:20:12 UTC
mFilter/man/ 0000755 0001762 0000144 00000000000 13475554775 012455 5 ustar ligges users mFilter/man/figures/ 0000755 0001762 0000144 00000000000 13475554775 014121 5 ustar ligges users mFilter/man/figures/README-ex3-1.png 0000644 0001762 0000144 00000173643 13351527744 016422 0 ustar ligges users PNG
IHDR z4 iCCPkCGColorSpaceGenericRGB 8U]hU>sg#$Sl4t?
%
V46nI6"dΘ83OEP|1Ŀ (>/
% (>P苦;3ie|{g蹪X-2s=+WQ+]L6Ow[C{_F qbUvz?Zb1@/zcs>~if,ӈUSjF1_Mjbuݠpamhmçϙ>a\+5%QKFkm}ۖ?ޚD\!~6,-7SثŜvķ5Z;[rmS5{yDyH}r9|-ăFAJjI.[/]mK7KRDrYQO-Q||6
(0
MXd(@h2_f<:_δ*d>e\c?~,7?& ك^2Iq2"y