Como destacar patches barulhentos em uma série temporal?

Eu tenho muitos dados de séries temporais - níveis e velocidades da água versus tempo. É a saída de uma simulação de modelo hidráulico. Como parte do processo de revisão para confirmar que o modelo está executando como esperado, tenho que plotar cada série temporal para garantir que não haja "oscilações" nos dados (veja o exemplo de oscilação menor abaixo). Usar a interface do usuário do software de modelagem é uma maneira bastante lenta e trabalhosa de verificar esses dados. Portanto, escrevi uma macro VBA curta para importar vários bits de dados do modelo, incluindo resultados para o Excel e plotar todos de uma vez. Espero escrever outra macro VBA curta para analisar os dados da série temporal e destacar as seções suspeitas.

Meu único pensamento até agora é que eu poderia fazer algumas análises na inclinação dos dados. Qualquer local em que a inclinação mude rapidamente de positiva para negativa várias vezes em uma determinada janela de pesquisa pode ser classificado como instável. Estou perdendo alguns truques mais simples? Essencialmente, uma simulação "estável" deve fornecer uma curva muito suave. Qualquer mudança repentina provavelmente resultará de uma instabilidade nos cálculos.

Para simplificar, sugiro analisar os tamanhos (valores absolutos) dos resíduos em relação a uma suavização robusta dos dados. Para detecção automatizada, considere substituir esses tamanhos por um indicador: 1 quando excederem algum quantil alto, digamos no nível e 0 caso contrário. Suavize esse indicador e realce quaisquer valores suavizados que excedam .$1-\alpha$$\alpha$

O gráfico à esquerda representa pontos de dados em azul, juntamente com um robusto local suave em preto. O gráfico à direita mostra os tamanhos dos resíduos desse liso. A linha pontilhada preta é o percentil 80 (correspondendo a ). A curva vermelha é construída como descrito acima, mas foi escalada (dos valores de e ) para a faixa média dos resíduos absolutos para plotagem.$1201$$\alpha=0.2$$0$$1$

Variação permite controle sobre a precisão. Nesse caso, a configuração menor que identifica uma pequena lacuna no ruído em torno de 22 horas, enquanto a configuração maior que também capta a mudança rápida perto de 0 horas.$\alpha$$\alpha$$0.20$$\alpha$$0.20$

Os detalhes do liso não importam muito. Neste exemplo, um loess suavizar (implementado em Rcomo loesscom span=0.05a localizá-lo) foi usado, mas até mesmo uma janela médio teria feito bem. Para suavizar os resíduos absolutos, corri uma média com janelas da largura 17 (cerca de 24 minutos), seguida por uma mediana com janelas. Esses suaves janelas são relativamente fáceis de implementar no Excel. Uma implementação eficiente do VBA (para versões mais antigas do Excel, mas o código-fonte deve funcionar mesmo em novas versões) está disponível em http://www.quantdec.com/Excel/smoothing.htm .

R Código

#
# 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))