सादगी के लिए, मैं डेटा के एक मजबूत चिकनी के सापेक्ष अवशिष्टों के आकार (पूर्ण मूल्यों) का विश्लेषण करने का सुझाव दूंगा। स्वचालित पहचान के लिए, उन आकारों को एक संकेतक द्वारा प्रतिस्थापित करने पर विचार करें: 1 जब वे कुछ उच्च मात्रा से अधिक होते हैं, तो स्तर पर कहते हैं1 - α, और 0 अन्यथा। इस सूचक को चिकना करें और अधिक से अधिक चिकने मूल्यों को उजागर करेंα।
बाएँ भूखंडों पर ग्राफिक 1201नीले रंग में डेटा बिंदुओं के साथ-साथ काले रंग में एक मजबूत, स्थानीय चिकनी। दाईं ओर का ग्राफिक उस चिकने के अवशिष्ट के आकार को दर्शाता है। काली बिंदीदार रेखा उनकी 80 वीं प्रतिशतक (इसके अनुरूप) हैα = 0.2)। लाल वक्र का निर्माण ऊपर वर्णित के रूप में किया गया है, लेकिन इसे (मानों से) बढ़ाया गया है0 तथा 1) साजिश रचने के लिए पूर्ण अवशिष्टों की व्यवस्था।
परिवर्तनीय αसटीक पर नियंत्रण की अनुमति देता है। इस उदाहरण में, सेटिंगα से कम 0.20 सेटिंग करते समय, लगभग 22 घंटों के शोर में एक छोटे से अंतराल की पहचान करता है α से अधिक 0.20 0 घंटे के पास तेजी से बदलाव भी करता है।
चिकनी का विवरण ज्यादा मायने नहीं रखता है। इस उदाहरण में एक लेस चिकनी (में लागू Rके रूप में loessके साथ span=0.05यह स्थानीय बनाना) इस्तेमाल किया गया था, लेकिन फिर भी एक विंडोड मतलब किया ठीक होगा। पूर्ण अवशिष्टों को सुचारू करने के लिए मैंने चौड़ाई 17 (लगभग 24 मिनट) की खिड़की के माध्यम से पीछा किया। ये विंडो स्मूथ एक्सेल में लागू करने के लिए अपेक्षाकृत आसान हैं। एक कुशल VBA कार्यान्वयन (एक्सेल के पुराने संस्करणों के लिए, लेकिन नए संस्करणों में भी काम करने के लिए स्रोत कोड) 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))
