EMD（经验模态分解）算法 一

参考R语言提取时间序列的周期性成分应用EMD，小波滤波器，BAXTER过滤器等的方法进行应用。

第一次尝试

首先安装依赖包

# install.packages("reshape2")
# install.packages("plm")
# install.packages("ggplot2")

加载包

library(reshape2)
library(plm)
library(ggplot2)

读取数据

load<-data.frame(read.csv("安徽最高.csv"))

观察数据

load

观察数据

重命名

names(load) <- c("Time","Load")

取对数

load[,"Load"] <- log(load[,"Load"]) 

观察对数负载随时间的变化

ggplot(load,aes(x=Time,y=Load)) + geom_line(size=.5) + theme_classic() + labs(title="对数负载")

对数负载

形状如上，波动还是挺大，冬天夏天用电处于高峰，没有特别明显的线性或非线性趋势。
尝试去除线性趋势看看。

dat <- data.frame("Time"=load[,"Time"],"Linearly.Detrended"=time.detrend)

报错

Error in data.frame(Time = load[, "Time"], Linearly.Detrended = time.detrend) :
找不到对象'time.detrend'

不知道为啥。。。time.detrend没用，怀疑作者少复制一行代码，全网没找到相关的代码。。跳过这一步。
找作者买来了代码，下面继续。。

先要对用负载对时间进行回归，获得残差，去除时间趋势

time.detrend <- residuals(lm(Load~ Time, data=load))

存储数据

dat <- data.frame("Time"=load[,"Time"],"Linearly.Detrended"=time.detrend)

看看结果

ggplot(dat,aes(x=Time,y=Linearly.Detrended)) + geom_hline(yintercept=0,colour="grey80") + geom_line(size=.5) + theme_classic() + labs(title="Linearly Detrended",y="")

Linearly Detrended

长得基本一模一样。。说明基本不存在线性趋势。

另一个类似的图

timedetrending = ggplot(dat = load, aes(x = Time, y = time.detrend)) + geom_hline(yintercept=0,colour="red") + geom_line(aes(color = time.detrend)) + labs(y="Linearly Detrended")

Linearly Detrended

做差分看看

# 差分
# 第一次差分 first difference
fd <- diff(load[,"Load"])
# 绘图
dat <- data.frame("Time"=dat[,"Time"],"First.Difference"=c(NA,fd),"Linearly.Detrended"=dat[,"Linearly.Detrended"])
g <- melt(dat,id.vars="Time",na.rm=TRUE)
levels(g[,2]) <- c("First Difference","Linear Trend")
# Define plot function
plot.cycles <- function(d,t) {
  ggplot(g,aes(x=Time,y=value,linetype=variable)) + 
    geom_hline(yintercept=0,colour="grey80") + # Create a horizontal line with value 0
    geom_line( size=.5) + # Create line with series and specify its thickness
    labs(x="Time",y="",title=t,linetype="Legend:") + # Title of the legend
    coord_cartesian(xlim=c(min(g[,1]),max(g[,1]))) + # Set displayed area
    guides(linetype=guide_legend()) + # Set the variables contained in the legend
    theme(legend.position="bottom", # Position of the legend
          legend.key=element_rect(fill="white"), # Set background of the legend keys
          panel.background = element_rect(fill = "white"), # Set background of the graph
          axis.line=element_line(size=.3,colour="black"), # Set the size and colour of the axes
          axis.text=element_text(colour="black"), # Set the colour of the axes text
          panel.grid=element_blank()) # Set grid lines off
}
# Plot
plot.cycles(d=g,t="Linearly Detrended vs. First Difference")

差分和linearly detrended的对比图

Linearly Detrended vs. First Difference

使用Hodrick Prescott过滤器

hp <- hpfilter(load[,"Load"],freq=1600)$cycle # Apply filter and obtain data of the cycle compontent
dat <- cbind(dat,data.frame("Hodrick.Prescott"=hp))
dat
g <- melt(dat[,c(1,4,3)],id.vars="Time",na.rm=TRUE)
levels(g[,2]) <- c("Hodrick Prescott","Linearly Detrended")
plot.cycles(g,"Hodrick Prescott vs. Linearly Detrended")
hpff <- data.frame("Time"=dat[,"Time"],"Hodrick.Prescott"=hp )
hpfilter = ggplot(data=hpff, aes(x = Time, y = hpff$Hodrick.Prescott )) + geom_hline(yintercept=0,colour="red") + geom_line(aes(color = Hodrick.Prescott)) + labs(y="Hodrick Prescott")
hpfilter

Hodrick.Prescott

Hodrick和Prescott（1981）开发了一种滤波器，它将时间序列分为趋势，周期和噪声分量。该hpfilter功能包含在mFilter包中，需要时间序列和平滑参数。文献表明后者的值为1600。但是，也可以选择更高的值。
下图显示了Hodrick-Prescott滤波器获得的实际GDP的周期性成分值，并将其与线性去趋势系列的值进行了比较。两个系列的行为看起来非常相似，只是HP系列在零附近波动较大，而线性去趋势系列仍然包含趋势的组成部分。此外，循环HP系列还包括一些类似噪音的组件。

Hodrick Prescott vs. Linearly Detrended

Baxter和King（1994,1999）提出了一种滤波器，它可以产生与HP滤波器类似的结果，但它可以消除上面显示的许多类似噪声的行为。该功能bkfilter也包含在mFilter包中。它需要系列，周期数量的下限和上限，假定周期发生（pl和pu），以及平滑因子nfix。文献（参见NBER，Stock和Watson（1999））表明商业周期持续6至32个月。这些值用于指定循环周期的下限和上限。BK滤波器的结果如下图所示。该方法的一个相对系列的缺点是平滑因子导致在系列的开始和结束时观察的丢失。这可能是小样本的问题。

Baxter King vs. Hodrick Prescott

小波滤波器

Yogo（2008）提出使用小波滤波器从时间序列数据中提取商业周期。这种方法的优点是该功能不仅可以提取系列的趋势，周期和噪声，而且可以更加具体地说明周期发生的周期。然而，由于该技术只能捕获2的幂的周期性，即2,4,8,16,32等，所以没有完全的自由度。
R中的方法实现也很简洁，但在使用之前需要一些额外的数据转换。一个有用的功能包含在waveslim包中并被称为mra（“多分辨率分析”）。它需要时间序列的不同版本和分解的深度。
该函数给出了多个系列，必须将它们累积起来cumsum，将它们转换回反映周期性模式的数据。此外，一些系列可以结合使用rowSums。当应该一起分析持续8到16和16到32个周期的周期时，这很有用，如下图所示。毫不奇怪，小波滤波器产生与BK滤波器类似的结果，因为循环周期的上限在两者中相等，下限仅相差2。

# 小波分解
wavelet <- as.data.frame(mra(diff(load[,2]),J=5)) # Apply filter
# Plot
dat <- cbind(dat,data.frame("Wavelet"=c(NA,cumsum(rowSums(wavelet[,3:4])))))
g <- melt(dat[,c(1,6,5)],id.vars="Time",na.rm=TRUE)
levels(g[,2]) <- c("Wavelet","Baxter King")
plot.cycles(g,"Wavelet vs. Baxter King")
wff <- data.frame("Time"=dat[,"Time"],"Wavelet.Filter"=dat$Wavelet)
waveletfilter = ggplot(data=wff, aes(x = Time, y = Wavelet.Filter )) + geom_hline(yintercept=0,colour="red") + geom_line(aes(color = Wavelet.Filter)) + labs(y="Wavelet Filter")
waveletfilter

Wavelet vs. Baxter King

经验模式分解（EMD）

基于Huang等人。（1998）Kozic和Sever（2014）提出经验模式分解作为商业周期提取的另一种方法。该函数emd可以在EMD包中找到，并且需要不同的时间序列，边界条件和规则，该规则指定迭代过程在哪个点获得了足够令人满意的结果并且可以停止。该滤波器方法的结果与HP，BK和小波滤波器相比有所不同。每项研究的任务都是评估使用这种方法是否合理。

# EMD经验模态分解
emd <- as.data.frame(emd(xt=diff(load[,2]),boundary="wave",stoprule="type2")$imf)
dat <- cbind(dat,data.frame("EMD"=c(NA,cumsum(rowSums(emd[,3:6])))))
g <- melt(dat[,c(1,7,4)],id.vars="Time",na.rm=TRUE)
levels(g[,2]) <- c("EMD","Hodrick Prescott")
plot.cycles(g,"EMD vs. Hodrick Prescott")
emdff <- data.frame("Time"=dat[,"Time"],"EMD.Filter"=dat$EMD)
emdfilter = ggplot(data=emdff, aes(x = Time, y = EMD.Filter )) + geom_hline(yintercept=0,colour="red") + geom_line(aes(color = EMD.Filter)) + labs(y="EMD Filter")
emdfilter

EMD vs. Hodrick Prescott

EMDfilter