सवाल पूछता है कि कैसे राशि का पता लगाएं जिसके द्वारा एक समय श्रृंखला ("विस्तार") एक और ("वॉल्यूम") को बंद कर देती है जब श्रृंखला को नियमित लेकिन अलग-अलग अंतराल पर नमूना लिया जाता है।
इस मामले में, दोनों श्रृंखला यथोचित रूप से निरंतर व्यवहार प्रदर्शित करती हैं, जैसा कि आंकड़े दिखाएंगे। इसका तात्पर्य है (1) थोड़ा या कोई प्रारंभिक चौरसाई की आवश्यकता नहीं हो सकती है और (2) पुनरुत्पादन रैखिक या द्विघात प्रक्षेप के समान सरल हो सकता है। चिकनाई के कारण द्विघात थोड़ा बेहतर हो सकता है। रेज़मैपलिंग के बाद, अंतराल को क्रॉस-सहसंबंध को अधिकतम करके पाया जाता है , जैसा कि धागे में दिखाया गया है, दो ऑफ़सेट नमूना डेटा श्रृंखला के लिए, उनके बीच ऑफ़सेट का सबसे अच्छा अनुमान क्या है? ।
समझाने के लिए , हम प्रश्न में दिए गए डेटा का उपयोग कर सकते हैं, छद्मकोड के Rलिए नियोजित कर सकते हैं । आइए बुनियादी कार्यक्षमता, क्रॉस-सहसंबंध और पुनर्निर्माण के साथ शुरू करें:
cor.cross <- function(x0, y0, i=0) {
#
# Sample autocorrelation at (integral) lag `i`:
# Positive `i` compares future values of `x` to present values of `y`';
# negative `i` compares past values of `x` to present values of `y`.
#
if (i < 0) {x<-y0; y<-x0; i<- -i}
else {x<-x0; y<-y0}
n <- length(x)
cor(x[(i+1):n], y[1:(n-i)], use="complete.obs")
}
यह एक क्रूड एल्गोरिदम है: एक एफएफटी-आधारित गणना तेजी से होगी। लेकिन इन आंकड़ों के लिए (लगभग 4000 मान शामिल हैं) यह काफी अच्छा है।
resample <- function(x,t) {
#
# Resample time series `x`, assumed to have unit time intervals, at time `t`.
# Uses quadratic interpolation.
#
n <- length(x)
if (n < 3) stop("First argument to resample is too short; need 3 elements.")
i <- median(c(2, floor(t+1/2), n-1)) # Clamp `i` to the range 2..n-1
u <- t-i
x[i-1]*u*(u-1)/2 - x[i]*(u+1)*(u-1) + x[i+1]*u*(u+1)/2
}
मैंने डेटा को अल्पविराम से अलग CSV फ़ाइल के रूप में डाउनलोड किया और उसके हेडर को छीन लिया। (हेडर ने R के लिए कुछ समस्याएं पैदा कीं जिनका मैंने निदान करने की परवाह नहीं की।)
data <- read.table("f:/temp/a.csv", header=FALSE, sep=",",
col.names=c("Sample","Time32Hz","Expansion","Time100Hz","Volume"))
एनबी यह समाधान मानता है कि डेटा की प्रत्येक श्रृंखला अस्थायी क्रम में है जिसमें कोई भी अंतराल नहीं है। यह समय के लिए परदे के पीछे के रूप में मूल्यों में अनुक्रमित का उपयोग करने की अनुमति देता है और उन अनुक्रमितों को समय-समय पर परिवर्तित करने के लिए अस्थायी नमूने आवृत्तियों द्वारा स्केल करता है।
यह पता चला है कि इन उपकरणों में से एक या दोनों समय के साथ थोड़ा बह जाते हैं। आगे बढ़ने से पहले इस तरह के रुझानों को दूर करना अच्छा है। इसके अलावा, क्योंकि अंत में वॉल्यूम सिग्नल की एक टैपिंग है, हमें इसे क्लिप करना चाहिए।
n.clip <- 350 # Number of terminal volume values to eliminate
n <- length(data$Volume) - n.clip
indexes <- 1:n
v <- residuals(lm(data$Volume[indexes] ~ indexes))
expansion <- residuals(lm(data$Expansion[indexes] ~ indexes)
मैं परिणाम से सबसे सटीक प्राप्त करने के लिए कम- सीरीज़ श्रृंखला को फिर से तैयार करता हूं ।
e.frequency <- 32 # Herz
v.frequency <- 100 # Herz
e <- sapply(1:length(v), function(t) resample(expansion, e.frequency*t/v.frequency))
अब क्रॉस-सहसंबंध की गणना की जा सकती है - दक्षता के लिए हम केवल लैग्स की एक उचित विंडो खोजते हैं - और लैग जहां अधिकतम मूल्य पाया जाता है, को पहचाना जा सकता है।
lag.max <- 5 # Seconds
lag.min <- -2 # Seconds (use 0 if expansion must lag volume)
time.range <- (lag.min*v.frequency):(lag.max*v.frequency)
data.cor <- sapply(time.range, function(i) cor.cross(e, v, i))
i <- time.range[which.max(data.cor)]
print(paste("Expansion lags volume by", i / v.frequency, "seconds."))
आउटपुट हमें बताता है कि विस्तार 1.85 सेकंड तक वॉल्यूम बढ़ाता है। (यदि पिछले 3.5 सेकंड के डेटा को क्लिप नहीं किया गया था, तो आउटपुट 1.84 सेकंड होगा।)
यह एक अच्छा विचार है कि सब कुछ कई तरीकों से जांचा जाए, अधिमानतः नेत्रहीन। सबसे पहले, क्रॉस-सहसंबंध समारोह :
plot(time.range * (1/v.frequency), data.cor, type="l", lwd=2,
xlab="Lag (seconds)", ylab="Correlation")
points(i * (1/v.frequency), max(data.cor), col="Red", cex=2.5)
अगला, समय में दो श्रृंखलाओं को पंजीकृत करें और उन्हें एक ही अक्ष पर एक साथ प्लॉट करें ।
normalize <- function(x) {
#
# Normalize vector `x` to the range 0..1.
#
x.max <- max(x); x.min <- min(x); dx <- x.max - x.min
if (dx==0) dx <- 1
(x-x.min) / dx
}
times <- (1:(n-i))* (1/v.frequency)
plot(times, normalize(e)[(i+1):n], type="l", lwd=2,
xlab="Time of volume measurement, seconds", ylab="Normalized values (volume is red)")
lines(times, normalize(v)[1:(n-i)], col="Red", lwd=2)
यह बहुत अच्छा लग रहा है! हम एक बिखराव के साथ पंजीकरण गुणवत्ता की बेहतर समझ प्राप्त कर सकते हैं , हालांकि। मैं प्रगति दिखाने के लिए समय-समय पर रंग बदलता रहता हूं।
colors <- hsv(1:(n-i)/(n-i+1), .8, .8)
plot(e[(i+1):n], v[1:(n-i)], col=colors, cex = 0.7,
xlab="Expansion (lagged)", ylab="Volume")
हम एक पंक्ति के साथ आगे और पीछे ट्रैक करने के लिए बिंदुओं की तलाश कर रहे हैं: इससे भिन्नताएं मात्रा के विस्तार के समय-अंतरालित प्रतिक्रिया में गैर-भिन्नता को दर्शाती हैं। हालांकि कुछ विविधताएं हैं, वे बहुत छोटे हैं। फिर भी, समय के साथ ये बदलाव कैसे बदलते हैं , यह कुछ शारीरिक रुचि हो सकती है। आंकड़ों के बारे में अद्भुत बात, विशेष रूप से इसके खोजपूर्ण और दृश्य पहलू, यह है कि यह उपयोगी उत्तरों के साथ अच्छे सवाल और विचार कैसे पैदा करता है।