mFilter/0000755000176000001440000000000011714716775011724 5ustar ripleyusersmFilter/MD50000644000176000001440000000163011714716775012234 0ustar ripleyusersff4ef75e119e6f37247a0fe31af1d797 *DESCRIPTION 7aca97179faf804a36c05b71e8ff17f9 *NAMESPACE 056489901aa696f20d3f4238d5c3507a *R/bkfilter.R a5a93df689145680f69cec93b90240db *R/bwfilter.R 244dbf3675eed10e0a3689bf2e8f9701 *R/cffilter.R ec7181d29283062ea4a74c1b5282b6d2 *R/hpfilter.R d262ba68c0423449ad443ff81160bfa5 *R/mFilter.R e2a5cd36073dc05afbc5197dafabd137 *R/trfilter.R 147c5c8a22abc12327d263cd315cd9f7 *R/zzz.R c2dc9412dbd38296ab06a59e97ac96f7 *data/unemp.R 3edafa5df229b5a17630cd6631b288fb *man/bkfilter.Rd c6ca2f95f6b2cd959721bc430e3eae3f *man/bwfilter.Rd 51bab14072aa9c3a0522a65726cb436b *man/cffilter.Rd ab883f4129b441832c08135a032f73e8 *man/hpfilter.Rd 6b4b4a7924d59c0345ec2d450455c596 *man/mFilter-methods.Rd 7c04240ecb06bf9473f84e178bba3519 *man/mFilter-package.Rd cf048935fbcf2f427b151142779b8fde *man/mFilter.Rd 3fb51565e5e324c743d90049b9703b38 *man/trfilter.Rd 5b3b617f878fffd9225f742c44f8100b *man/unemp.Rd mFilter/R/0000755000176000001440000000000010710705554012111 5ustar ripleyusersmFilter/R/zzz.R0000644000176000001440000000132310525645150013067 0ustar ripleyusers#.First.lib <- .onLoad <- function(lib, pkg) { mylib <- dirname(system.file(package = "mFilter")) ver <- packageDescription("mFilter", lib = mylib)["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")) writeLines(strwrap(txt, indent = 4, exdent = 4)) } mFilter/R/trfilter.R0000644000176000001440000000063110524445730014067 0ustar ripleyusers### ### 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/mFilter.R0000644000176000001440000000772710710373540013647 0ustar ripleyusers## 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/hpfilter.R0000644000176000001440000000356710524445554014070 0ustar ripleyusers### 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,star=tsp.x[1],frequency=tsp.x[3]) x.trend=ts(x.trend,star=tsp.x[1],frequency=tsp.x[3]) x=ts(x,star=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/cffilter.R0000644000176000001440000002740110526153612014033 0ustar ripleyusers### 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,star=tsp.x[1],frequency=tsp.x[3]) x.trend=ts(x.trend,star=tsp.x[1],frequency=tsp.x[3]) x=ts(x,star=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/bwfilter.R0000644000176000001440000000317710524445510014056 0ustar ripleyusers### 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,star=tsp.x[1],frequency=tsp.x[3]) x.trend=ts(x.trend,star=tsp.x[1],frequency=tsp.x[3]) x=ts(x,star=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,star=tsp.x[1],frequency=tsp.x[3]) x.trend=ts(x.trend,star=tsp.x[1],frequency=tsp.x[3]) x=ts(x,star=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/bkfilter.R0000644000176000001440000000424210524445604014040 0ustar ripleyusers### 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,star=tsp.x[1],frequency=tsp.x[3]) x.trend=ts(x.trend,star=tsp.x[1],frequency=tsp.x[3]) x=ts(x,star=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/NAMESPACE0000644000176000001440000000077410523423216013131 0ustar ripleyusers#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("print", "mFilter") S3method("summary", "mFilter") S3method("plot", "mFilter") S3method("fitted", "mFilter") S3method("residuals", "mFilter") mFilter/man/0000755000176000001440000000000010710705552012461 5ustar ripleyusersmFilter/man/unemp.Rd0000644000176000001440000000300410524567030014071 0ustar ripleyusers\name{unemp} \alias{unemp} \title{US Quarterly Unemployment Series} \usage{ data(unemp) } \description{ Quarterly US unemployment series for 1959.1 to 2000.4. \emph{number of observations} : 168 \emph{observation} : country \emph{country} : United States } \format{A time series containing : \describe{ \item{unemp}{unemployment rate (average of months in quarter) } } } \source{ Bureau of Labor Statistics, OECD, Federal Reserve. } \references{ Stock, James H. and Mark W. Watson (2003) \emph{Introduction to Econometrics}, Addison-Wesley Educational Publishers, \url{http://wps.aw.com/aw_stockwatsn_economtrcs_1}, chapter 12 and 14. } \author{ Mehmet Balcilar, \email{mbalcilar@yahoo.com} } \examples{ ## library(mFilter) data(unemp) unemp.hp <- mFilter(unemp,filter="HP") # Hodrick-Prescott filter unemp.bk <- mFilter(unemp,filter="BK") # Baxter-King filter unemp.cf <- mFilter(unemp,filter="CF") # Christiano-Fitzgerald filter opar <- par(no.readonly=TRUE) par(mfrow=c(2,1),mar=c(3,3,2,1)) plot(unemp,main="Unemployment Series & Estimated Trend",col=1,ylab="") lines(unemp.hp$trend,col=2) lines(unemp.bk$trend,col=3) lines(unemp.cf$trend,col=4) legend("topleft",legend=c("series", "HP","BK","CF"),col=1:4, lty=rep(1,4),ncol=2) plot(unemp.hp$cycle,main="Estimated Cyclical Component",col=2, ylim=c(-2,2),ylab="") lines(unemp.bk$cycle,col=3) lines(unemp.cf$cycle,col=4) legend("topleft",legend=c("HP","BK","CF"),col=2:4,lty=rep(1,3),ncol=2) par(opar) } \keyword{datasets} mFilter/man/trfilter.Rd0000644000176000001440000001255310525641500014605 0ustar ripleyusers\name{trfilter} \alias{trfilter} \title{ Trigonometric regression filter of a time series } \description{ This function uses trigonometric regression filter for estimating cyclical and trend components of a time series. The function computes cyclical and trend components of the time series using a lower and upper cut-off frequency in the spirit of a band pass filter. } \usage{ trfilter(x,pl=NULL,pu=NULL,drift=FALSE) } \arguments{ \item{x}{a regular time series.} \item{pl}{integer. minimum period of oscillation of desired component (pl<=2).} \item{pu}{integer. maximum period of oscillation of desired component (2<=pl Depends: R (>= 2.2.0), stats Suggests: tseries, pastecs, locfit, tseriesChaos, RTisean, tsDyn, forecast Description: The 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/mFilter, http://www.r-project.org Packaged: Tue Nov 6 09:32:46 2007; mehmet Repository: CRAN Date/Publication: 2007-11-06 10:00:46 mFilter/data/0000755000176000001440000000000010710705552012617 5ustar ripleyusersmFilter/data/unemp.R0000644000176000001440000000403110521612764014066 0ustar ripleyusersunemp <- 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")