Soru, bir dizi serinin ("genişleme"), düzenli fakat farklı aralıklarla örneklendiğinde bir diğerinin ("hacim") ne kadar tutacağını soruyor .
Bu durumda, her iki seri de, rakamların göstereceği gibi, oldukça sürekli davranış sergilemektedir. Bu, (1) çok az veya hiç ilk düzleştirme gerekmeyebileceğini ve (2) yeniden örneklemenin doğrusal veya kuadratik enterpolasyon kadar basit olabileceği anlamına gelir. Kuadratik pürüzsüzlük nedeniyle biraz daha iyi olabilir. Yeniden örneklemeden sonra, gecikme, iş parçacığında gösterildiği gibi çapraz korelasyonu maksimize ederek bulunur. İki ofset örneklenmiş veri serisi için, aralarındaki ofsetin en iyi tahmini nedir? .
Örnek olarak , Rsözde verilen verileri kullanarak sözde kod için çalışabiliriz . Temel işlevsellik, çapraz korelasyon ve yeniden örnekleme ile başlayalım:
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")
}
Bu ham bir algoritma: FFT tabanlı bir hesaplama daha hızlı olacaktır. Ancak bu veriler için (yaklaşık 4000 değer içeren) yeterince iyi.
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
}
Verileri virgülle ayrılmış bir CSV dosyası olarak indirdim ve başlığını çıkardım. (Başlık, R için teşhis etmeyi umursamadığım bazı sorunlara neden oldu.)
data <- read.table("f:/temp/a.csv", header=FALSE, sep=",",
col.names=c("Sample","Time32Hz","Expansion","Time100Hz","Volume"))
Not: Bu çözüm, her bir veri serisinin, ikisinde de boşluk olmayan geçici bir sırada olduğunu varsayar. Bu, endeksleri zaman içinde vekil olarak değerlere kullanmasına ve bu endeksleri zamana dönüştürmek için zamansal örnekleme frekanslarına göre ölçeklendirmesine izin verir.
Bu enstrümanlardan birinin veya her ikisinin de zamanla biraz kaydığı ortaya çıkıyor. Devam etmeden önce bu tür trendleri kaldırmak iyidir. Ayrıca, sonunda ses sinyalinin sivrilmesi nedeniyle, onu kesmeliyiz.
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)
Sonuçtan en yüksek verimi almak için daha az sıklıkta olan serileri yeniden örnekliyorum.
e.frequency <- 32 # Herz
v.frequency <- 100 # Herz
e <- sapply(1:length(v), function(t) resample(expansion, e.frequency*t/v.frequency))
Şimdi çapraz korelasyon hesaplanabilir - verimlilik için sadece makul bir gecikme penceresi ararız - ve maksimum değerin bulunduğu gecikme tespit edilebilir.
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."))
Çıktı bize genişlemenin hacmini 1,85 saniye azalttığını söyler. (Son 3,5 saniye veri kırpılmamışsa, çıktı 1,84 saniye olacaktır.)
Her şeyi çeşitli şekillerde, tercihen görsel olarak kontrol etmek iyi bir fikirdir. İlk olarak, çapraz korelasyon işlevi :
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)
Daha sonra, iki seriyi zamanında kaydedelim ve bunları aynı eksenlerde birlikte çizelim .
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)
Çok iyi görünüyor! Olsa da, bir scatterplot ile kayıt kalitesini daha iyi anlayabiliriz . İlerlemeyi göstermek için zamanla renkleri değiştiriyorum.
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")
Bir çizgi boyunca ileri geri izleyeceğiniz noktaları arıyoruz: genişlemenin hacme zaman gecikmeli yanıtındaki doğrusal olmayanları yansıtan değişiklikler. Bazı varyasyonlar olmasına rağmen, oldukça küçüktür. Ancak, bu değişikliklerin zaman içinde nasıl değiştiği fizyolojik olarak ilgi çekici olabilir. İstatistiklerle ilgili harika bir şey, özellikle keşif ve görsel yönü, yararlı cevaplarla birlikte iyi sorular ve fikirler yaratma eğilimindedir .