時系列のノイズの多いパッチを強調表示するにはどうすればよいですか？

時系列データがたくさんあります-水位と速度vs時間。これは、水理モデルシミュレーションからの出力です。モデルが期待どおりに動作していることを確認するための確認プロセスの一環として、各時系列をプロットして、データに「ウォブル」がないことを確認する必要があります（以下のマイナーウォブルの例を参照）。モデリングソフトウェアのUIを使用すると、このデータを確認するのにかなり時間がかかり、面倒です。したがって、結果を含むモデルのさまざまなデータをExcelにインポートし、それらをすべて一度にプロットする短いVBAマクロを作成しました。時系列データを分析して疑わしいセクションを強調表示する別の短いVBAマクロを記述したいと思っています。

これまでの私の唯一の考えは、データの勾配について分析を行うことができるということです。特定の検索ウィンドウ内で勾配が正から負に複数回急速に変化する場所は、不安定であると分類できます。もっと簡単なトリックはありませんか？基本的に、「安定した」シミュレーションは非常に滑らかな曲線を提供するはずです。突然の変化は、計算の不安定性の結果である可能性があります。

簡単にするために、データのロバストな平滑化と比較した残差のサイズ（絶対値）を分析することをお勧めします。自動検出の場合、それらのサイズをインジケーターで置き換えることを検討してください。1が高い分位数を超えた場合は1、たとえばレベルでそれ以外の場合は0。このインジケーターを平滑化し、を超える平滑化された値を強調表示します。$1-\alpha$$\alpha$

左の図は、データポイントを青色でプロットし、ロバストで局所的な滑らかさを黒色でプロットしています。右の図は、そのスムーズの残差のサイズを示しています。黒い点線は80パーセンタイルです（対応）。赤い曲線は上記のように作成されていますが、（と値から）プロットするために絶対残差の中域にスケーリングされています。$1201$$\alpha=0.2$$0$$1$

変精度を制御できます。この例では、未満に設定すると、22時間あたりのノイズの短いギャップが識別されます。一方、超えるを設定すると、0時間近くの急激な変化も拾います。$\alpha$$\alpha$$0.20$$\alpha$$0.20$

スムーズの詳細はあまり問題ではありません。この例では黄土スムーズ（に実装Rようloessでspan=0.05、それをローカライズする）を使用したが、それでもウィンドウの平均は罰金をやっているだろう。絶対残差を平滑化するために、幅17のウィンドウ平均（約24分）を実行した後、ウィンドウ中央値を実行しました。これらのウィンドウ処理されたスムージングは​​、Excelでの実装が比較的簡単です。効率的なVBA実装（古いバージョンのExcelの場合、ソースコードは新しいバージョンでも機能するはずです）は、http：//www.quantdec.com/Excel/smoothing.htmで入手できます。

R コード

#
# Emulate the data in the plot.
#
xy <- matrix(c(0, 96.35,  0.3, 96.6, 0.7, 96.7, 1, 96.73, 1.5, 96.74, 2.5, 96.75, 
               4, 96.9, 5, 97.05, 7, 97.5, 10, 98.5, 12, 99.3, 12.5, 99.35, 
               13, 99.355, 13.5, 99.36, 14.5, 99.365, 15, 99.37, 15.5, 99.375, 
               15.6, 99.4, 15.7, 99.41, 20, 99.5, 25, 99.4, 27, 99.37),
             ncol=2, byrow=TRUE)
n <- 401
set.seed(17)
noise.x <- cumsum(rexp(n, n/max(xy[,1])))
noise.y <- rep(c(-1,1), ceiling(n/2))[1:n]
noise.amp <- runif(n, 0.8, 1.2) * 0.04
noise.amp <- noise.amp * ifelse(noise.x < 16 | noise.x > 24.5, 0.05, 1)
noise.y <- noise.y * noise.amp

g <- approxfun(noise.x, noise.y)
f <- splinefun(xy[,1], xy[,2])
x <- seq(0, max(xy[,1]), length.out=1201)
y <- f(x) + g(x)
#
# Plot the data and a smooth.
#
par(mfrow=c(1,2))
plot(range(xy[,1]), range(xy[,2]), type="n", main="Data", sub="With Smooth",
     xlab="Time (hours)", ylab="Water Level")
abline(h=seq(96, 100, by=0.5), col="#e0e0e0")
abline(v=seq(0, 30, by=5), col="#e0e0e0")
#curve(f(x) + g(x), xlim=range(xy[,1]), col="#2070c0", lwd=2, add=TRUE, n=1201)
lines(x,y, type="l", col="#2070c0", lwd=2)

span <- 0.05
fit <- loess(y ~ x, span=span)
y.hat <- predict(fit)
lines(fit$x, y.hat)
#
# Plot the absolute residuals to the smooth.
#
r <-  abs(resid(fit))
plot(fit$x, r, type="l", col="#808080",
     main="Absolute Residuals", sub="With Smooth and a Threshold",
     xlab="Time hours", ylab="Residual Water Level")
#
# Smooth plot an indicator of the smoothed residuals.
#
library(zoo)
smooth <- function(x, window=17) {
  x.1 <- rollapply(ts(x), window, mean)
  x.2 <- rollapply(x.1, window, median)
  return(as.vector(x.2))
}
alpha <- 0.2
threshold <- quantile(r, 1-alpha)
abline(h=threshold, lwd=2, lty=3)
r.hat <- smooth(r >threshold)
x.hat <- smooth(fit$x)
z <- max(r)/2 * (r.hat > alpha)
lines(x.hat, z, lwd=2, col="#c02020")
par(mfrow=c(1,1))