ケィオスの時系列解析メモランダム

時系列解析,生体情報学,数学・物理などの解説です.

【Rで時系列解析】スペクトルウインドーを使ったパワースペクトルの平滑化:Rの"spectrum"での"spans"オプションの意味

今回は,離散フーリエ変換でえられるギザギザなパワースペクトルを,滑らかにする「平滑化」についてです.いろいろ書きたいことはありますが,まずは,Rでお世話になることが多い"spectrum"というコマンドのオプション"spans"について説明します.今回の説明は,私が数値実験をして確認したことに基づいていますので,間違いがあるかもしれません.他人を簡単に信じないでください.

1. パワースペクトルの平滑化

 一般的な平滑化の説明をしておきます.離散フーリエ変換を使って計算されたパワースペクトルS(f_k)の平滑化は,重み\{w_j\} (j=-m, \cdots, 0, \cdots, m)を使って,

 \displaystyle \hat{S}(f_k) = \sum_{j=-m}^{m} w_{j}\, S(f_{k-j})

と表されます.

 移動平均で平滑化する場合は,

 \displaystyle w_{j} = \frac{1}{2m+1}\quad (-m \le j \le m)

です (下図).時系列の移動平均と同じように,パワースペクトルS(f_k)が平滑化されます.

m=2のときの例.

2. "spans"の使用例

 Rの"spectrum"コマンドを使ったことがない人もいるかもしれませんし,使ったことはあっても,"spans"オプションを指定したことがない人もいるかもしれませんので,まずは,数値実験の結果をお見せします.時系列は2次自己回帰過程 (a_1 = 1.6, a_2 = -0.9)で生成しました.時系列のベクトルデータをx.simとすれば,使ったコマンドは,

spectrum(x.sim, ...)

です."..."の部分はオプションコマンドが入ります.例えば,グラフを描かない場合は,

spectrum(x.sim, plot=FALSE)

とします.

 "spans"を使った結果は下の図です.平滑化していない結果 (左上)と比べて,平滑化すると,解析的結果 (赤破線)と推定結果 (青実線)の一致が良くなっています.

"spectrum"を使って推定したパワースペクトル

 指定した"spans"は,各図の上のタイトル部分に書いてあります.図の左上から順番に,対応するRのコマンドを書けば,

tmp <- spectrum(x.sim, plot=FALSE)
tmp <- spectrum(x.sim, spans=5, plot=FALSE)
tmp <- spectrum(x.sim, spans=15, plot=FALSE)
tmp <- spectrum(x.sim, spans=c(5,5), plot=FALSE)
tmp <- spectrum(x.sim, spans=c(15,15), plot=FALSE)
tmp <- spectrum(x.sim, spans=c(15,15,15,15,15,15), plot=FALSE)

です.この場合,"tmp$freq"に周波数,"tmp$spec"に推定されたスペクトル密度が入っています.

 "spans"を指定すれば,平滑化できていることは見て取れます.でも,これで何をやっているの? "spans=c(15,15,15,15,15,15)"って,マニュアルの使用例に載っていないし,ふざけてんのか? と感じる人も多いと思います.

3. Rのマニュアルの説明を見ると

 "spectrum"を実行した場合,デフォルトで実際の動いているのは"spec.pgram"のようです.Rコンソールで

?spec.pgram

を実行すれば,マニュアルを見ることができます.そこでは,"spans"のオプションについて,
 
 「ピリオドグラムを平滑化するために使用される修正ダニエルスムーザ (modified Daniell smoothers)の幅を与える奇数を並べたベクトル.」

と書いてあります.つまり,"spans=c(3,5,15,9,7,11)"のように,奇数のベクトルを指定しろということです.

 以下で,"spans=c(...)"の意味を読み解いていきます.

4. 修正ダニエルスムーザ (modified Daniell smoothers)とは

 まず,修正版ではない,元の「ダニエルスムーザ」は,単なる移動平均フィルタ (スムーザ)です.つまり,最初に説明した例と全く同じです.

【ダニエルスムーザ】
 平均をとる全幅 (点数)がL=2 m + 1のとき,
 \displaystyle w_{j} = \left\{
\begin{array}{ll}
\displaystyle \frac{1}{2m+1}  \quad& (-m \le j \le m)\\ 
\displaystyle 0 \quad & ({\rm otherwise}) 
\end{array}
\right.

 ダニエルスムーザと修正ダニエルスムーザの違いは,両端の点にあります (下図).

ダニエルスムーザ (左)と修正ダニエルスムーザ (右)

 上図の右のように修正ダニエルスムーザでは,両端の重みが,中央部の重みの半分になります.つまり,式で書くと以下です.

【修正ダニエルスムーザ】
 平均をとる全幅 (点数)がL=2 m + 1のとき,
 \displaystyle w_{j} = \left\{
\begin{array}{ll}
\displaystyle \frac{0.5}{2 m} \quad & (j = - m)\\ 
\displaystyle \frac{1}{2 m} \quad& (-(m-1) \le j \le m-1) \\
\displaystyle \frac{0.5}{2 m}  \quad& ( j = m ) \\
\displaystyle 0 \quad& ({\rm otherwise}) 
\end{array}
\right.

 何で端の重みのみ半分にするのか,私には理由は分かりません.想像で考えると,m=1のときなど,幅が小さいときに,中央の点の重みを大きくできるので,元の構造を壊さないように軽~くスムージングするには修正版が良いかもしれません.mが大きくなると,ダニエルも修正ダニエルも,結果はほぼ同じだと思います.

5. "spans"で指定する値の意味

 "spectrum"コマンドのオプション"spans"では,修正ダニエルスムーザの長さLを指定しています (L=2 m + 1).以下のように,

spectrum( ... , spans=L, ... )

1つの値Lだけ指定すれば,上で説明した修正ダニエルで平滑化されます.

 さらに,以下のように,

spectrum( ... , spans=c(L, M, N), ... )

ベクトルで指定すると,3回修正ダニエルスムーザがかけられます.つまり,1回目は長さLの修正ダニエルスムーザ,2回目は長さMの修正ダニエルスムーザ,3回目は長さNの修正ダニエルスムーザになります.

 このように,複数回修正ダニエルスムーザをかけると,重み\displaystyle w_{j}のバランスを変えられます.まだ,「確率密度関数の特性関数」と「畳込み定理」について説明していないので,ここからの説明は理解できない人がいるかもしれません.ポイントは,何回も何回も修正ダニエルスムーザ (あるいは,もとのダニエルスムーザ)をかけていくと,重み\displaystyle w_{j}正規分布に近づきます.2回だと三角形に近い重み分布になります.

修正ダニエルスムーザをかける回数と重みの関係.m=5の例.

 "spans"の設定により,平滑化をする重み\displaystyle \{w_{j}\}がどのようになるのかを見るRスクリプトを載せておきます.

spans <- "c(5,5,5)"
w0 <- kernel("modified.daniell",m=eval(parse(text = spans)))$coef
w <- c(rev(w0[-1]),w0)
m <- (length(w)-1)/2
j <- (-m):(m)
w.max <- max(w)
plot(j,w,ylim=c(0,w.max*1.1),pch=16,col=2,las=1,yaxs="i",main=paste("spans =",spans))
arrows(j, 0, j, w, col =2,length=0,lwd=2)

最初の行の

spans <- "c(5,5,5)"

の部分に,"spans=c(...)"で指定する右辺のベクトルを書いてください.

Rスクリプトの実行例."spans = c(5,5,5)"の場合.

 この記事も参考にしてください.
chaos-kiyono.hatenablog.com

おまけ

# 時系列の長さ (時系列は奇数長になります)
N <- 2^12
# 奇数に変換
N <- round(N/2)*2+1
# 半分
M <- (N-1)/2
#########################
# モデルの自己共分散関数を与える
# 例:AR(2)過程の自己共分散関数
AR2.model <- function(n,a1,a2,sig2){
 Cov <- c()
 Cov[1] <- sig2*(1-a2)/(1-a1^2-a2-a1^2*a2-a2^2+a2^3)
 Cov[2] <- Cov[1]*a1/(1-a2)
 for(k in 3:(n+1)){
  Cov[k] <- a1*Cov[k-1] + a2*Cov[k-2]
 }
 return(Cov)
}
# パラメタの設定
a1 <- 1.6
a2 <- -0.9
sig2 <- 1
# 【注意】[-M,M]区間ではなく,[0,2M-1]にしている
acov.model <- c(AR2.model(M,a1,a2,sig2),rev(AR2.model(M,a1,a2,sig2)[-1]))
lag <- c(0:M,-(M:1))
#########################
# 自己共分散関数のフーリエ変換
fft.model <- fft(acov.model)
PSD.model <- Re(fft.model)
f <- c((0:M)/N,-(M:1)/(N))
#########################
# 白色ノイズの生成
WN <- rnorm(N)
# ホワイトノイズのフーリエ変換
fft.WN <- fft(WN)
#########################
# サンプル時系列の生成
fft.sim <-  sqrt(PSD.model)*fft.WN
x.sim <- Re(fft(fft.sim,inverse=TRUE))/N
#########################
# 結果の描画
par(mfrow=c(2,3),cex.main=1.5,cex.axis=1.4,cex.lab=1.7,las=1,mar=c(5,5,2,2))
########################################################################
# PSDの推定
# spansなし
tmp <- spectrum(x.sim,plot="false")
freq <- tmp$freq
psd <- tmp$spec
#
plot(freq[freq > 0],psd[freq > 0],"l",log="xy",col=4,pch=16,xlim=c(f[2],0.5),xaxs="i",xlab="f",ylab="Periodogram",main=paste("without spans"),lwd=2,xaxt="n",yaxt="n")
lines(f[f > 0],PSD.model[f > 0],col=2,lwd=2,lty=2)
# 対数目盛を描く
axis(1,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(1,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
axis(2,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(2,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
########
legend("bottomleft", legend=c("Analytical Power Spectrum"), col=c(2), lty=c(2),lwd=c(2))
########################################################################
# PSDの推定
# spans=5
tmp <- spectrum(x.sim,spans=5,plot="false")
freq <- tmp$freq
psd <- tmp$spec
#
plot(freq[freq > 0],psd[freq > 0],"l",log="xy",col=4,pch=16,xlim=c(f[2],0.5),xaxs="i",xlab="f",ylab="Periodogram",main=paste("spans=5"),lwd=2,xaxt="n",yaxt="n")
lines(f[f > 0],PSD.model[f > 0],col=2,lwd=2,lty=2)
# 対数目盛を描く
axis(1,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(1,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
axis(2,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(2,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
########
legend("bottomleft", legend=c("Analytical Power Spectrum"), col=c(2), lty=c(2),lwd=c(2))
########################################################################
# PSDの推定
# spans=15
tmp <- spectrum(x.sim,spans=15,plot="false")
freq <- tmp$freq
psd <- tmp$spec
#
plot(freq[freq > 0],psd[freq > 0],"l",log="xy",col=4,pch=16,xlim=c(f[2],0.5),xaxs="i",xlab="f",ylab="Periodogram",main=paste("spans=15"),lwd=2,xaxt="n",yaxt="n")
lines(f[f > 0],PSD.model[f > 0],col=2,lwd=2,lty=2)
# 対数目盛を描く
axis(1,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(1,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
axis(2,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(2,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
########
legend("bottomleft", legend=c("Analytical Power Spectrum"), col=c(2), lty=c(2),lwd=c(2))
########################################################################
# PSDの推定
# spans=c(5,5)
tmp <- spectrum(x.sim,spans=c(5,5),plot="false")
freq <- tmp$freq
psd <- tmp$spec
#
plot(freq[freq > 0],psd[freq > 0],"l",log="xy",col=4,pch=16,xlim=c(f[2],0.5),xaxs="i",xlab="f",ylab="Periodogram",main=paste("spans=c(5,5)"),lwd=2,xaxt="n",yaxt="n")
lines(f[f > 0],PSD.model[f > 0],col=2,lwd=2,lty=2)
# 対数目盛を描く
axis(1,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(1,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
axis(2,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(2,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
########
legend("bottomleft", legend=c("Analytical Power Spectrum"), col=c(2), lty=c(2),lwd=c(2))
########################################################################
# PSDの推定
# spans=c(15,15)
tmp <- spectrum(x.sim,spans=c(15,15),plot="false")
freq <- tmp$freq
psd <- tmp$spec
#
plot(freq[freq > 0],psd[freq > 0],"l",log="xy",col=4,pch=16,xlim=c(f[2],0.5),xaxs="i",xlab="f",ylab="Periodogram",main=paste("spans=c(15,15)"),lwd=2,xaxt="n",yaxt="n")
lines(f[f > 0],PSD.model[f > 0],col=2,lwd=2,lty=2)
# 対数目盛を描く
axis(1,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(1,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
axis(2,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(2,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
########
legend("bottomleft", legend=c("Analytical Power Spectrum"), col=c(2), lty=c(2),lwd=c(2))
########################################################################
# PSDの推定
# spans=c(15,15,15,15,15,15)
tmp <- spectrum(x.sim,spans=c(15,15,15,15,15,15),plot="false")
freq <- tmp$freq
psd <- tmp$spec
#
plot(freq[freq > 0],psd[freq > 0],"l",log="xy",col=4,pch=16,xlim=c(f[2],0.5),xaxs="i",xlab="f",ylab="Periodogram",main=paste("spans=c(15,15,15,15,15,15)"),lwd=2,xaxt="n",yaxt="n")
lines(f[f > 0],PSD.model[f > 0],col=2,lwd=2,lty=2)
# 対数目盛を描く
axis(1,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(1,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
axis(2,at=10^(-5:5)%x%(1:9),label=FALSE,tck=-0.02)
tmp<-paste(paste(sep="","expression(10^",-5:5,")"),collapse=",")
v.label<-paste("axis(2,las=1,at=10^(-5:5),label=c(",tmp,"),tck=-0.03)",sep="")
eval(parse(text=v.label))
########
legend("bottomleft", legend=c("Analytical Power Spectrum"), col=c(2), lty=c(2),lwd=c(2))
##########################################################