시계열에서 노이즈 패치를 강조 표시하려면 어떻게해야합니까?

수위와 속도 대 시간과 같은 많은 시계열 데이터가 있습니다. 유압 모델 시뮬레이션의 출력입니다. 모델이 예상대로 작동하는지 확인하기위한 검토 프로세스의 일부로, 데이터에 "흔들림"이 없도록 각 시계열을 플로팅해야합니다 (아래의 작은 흔들림 참조). 모델링 소프트웨어의 UI를 사용하는 것은이 데이터를 확인하는 매우 느리고 힘든 방법입니다. 따라서 짧은 VBA 매크로를 작성하여 결과를 포함하여 모델의 다양한 데이터 비트를 Excel로 가져 와서 한 번에 플롯했습니다. 시계열 데이터를 분석하고 의심되는 섹션을 강조하기 위해 또 다른 짧은 VBA 매크로를 작성하고 싶습니다.

지금까지 나의 유일한 생각은 데이터의 기울기에 대한 분석을 할 수 있다는 것입니다. 주어진 검색 창 내에서 기울기가 빠르게 양에서 음으로 여러 번 빠르게 변하는 곳은 불안정한 것으로 분류 할 수 있습니다. 더 간단한 트릭을 놓치고 있습니까? 기본적으로 "안정된"시뮬레이션은 매우 부드러운 곡선을 제공해야합니다. 갑작스런 변화는 계산이 불안정한 결과 일 수 있습니다.

간단하게하기 위해, 데이터의 강력한 평활도와 관련하여 잔차의 크기 (절대 값)를 분석하는 것이 좋습니다. 자동 감지의 경우 해당 크기를 표시기로 대체하는 것을 고려하십시오.$1-\alpha$, 그렇지 않으면 0 이 표시기를 매끄럽게하고 초과하는 평활화 된 값을 강조 표시합니다$\alpha$.

왼쪽 그림의 그래픽 $1201$데이터 포인트는 파란색으로 튼튼하고 로컬에서는 부드러운 검정색으로 표시됩니다. 오른쪽의 그래픽은 해당 부드러운 잔차의 크기를 보여줍니다. 검은 색 점선은 80 번째 백분위 수입니다 ($\alpha=0.2$). 빨간색 곡선은 위에서 설명한대로 구성되었지만 ($0$ 과 $1$) 플로팅을위한 절대 잔차의 중간 범위까지.

다양한 $\alpha$정밀도를 제어 할 수 있습니다. 이 경우 설정$\alpha$ 이하 $0.20$ 설정하는 동안 약 22 시간 동안 소음의 짧은 간격을 식별합니다. $\alpha$ ~보다 큰 $0.20$ 0 시간 근처에서 급격한 변화를 포착합니다.

매끄러운 세부 사항은별로 중요하지 않습니다. 이 예에서 황토는 (구현 부드럽게 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))