Pertanyaannya adalah bagaimana menemukan jumlah yang satu seri waktu ("ekspansi") tertinggal dari yang lain ("volume") ketika seri sampel pada interval reguler tetapi berbeda .
Dalam hal ini kedua seri menunjukkan perilaku yang cukup berkelanjutan, seperti yang ditunjukkan oleh gambar. Ini menyiratkan (1) sedikit atau tidak ada pemulusan awal mungkin diperlukan dan (2) resampling dapat sesederhana interpolasi linier atau kuadratik. Kuadrat mungkin sedikit lebih baik karena kehalusannya. Setelah melakukan resampling, lag ditemukan dengan memaksimalkan korelasi silang , seperti yang ditunjukkan dalam utas, Untuk dua seri data sampel offset, apa estimasi terbaik offset di antara mereka? .
Untuk mengilustrasikannya , kita dapat menggunakan data yang disediakan dalam pertanyaan, yang digunakan Runtuk kodesemu. Mari kita mulai dengan fungsionalitas dasar, korelasi silang dan resampling:
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")
}
Ini adalah algoritma kasar: perhitungan berbasis FFT akan lebih cepat. Tetapi untuk data ini (melibatkan sekitar 4.000 nilai) cukup baik.
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
}
Saya mengunduh data sebagai file CSV yang dipisah koma dan melepas header-nya. (Header menyebabkan beberapa masalah untuk R yang saya tidak mau diagnosa.)
data <- read.table("f:/temp/a.csv", header=FALSE, sep=",",
col.names=c("Sample","Time32Hz","Expansion","Time100Hz","Volume"))
NB Solusi ini mengasumsikan setiap seri data dalam urutan temporal tanpa celah di salah satu dari keduanya. Ini memungkinkannya untuk menggunakan indeks ke dalam nilai sebagai proksi untuk waktu dan untuk skala indeks tersebut dengan frekuensi temporal sampling untuk mengubahnya menjadi waktu.
Ternyata satu atau kedua instrumen ini melayang sedikit dari waktu ke waktu. Ada baiknya untuk menghapus tren seperti itu sebelum melanjutkan. Juga, karena ada pengurangan sinyal volume di bagian akhir, kita harus memotongnya.
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)
Saya menguji ulang seri yang kurang sering untuk mendapatkan hasil yang paling presisi.
e.frequency <- 32 # Herz
v.frequency <- 100 # Herz
e <- sapply(1:length(v), function(t) resample(expansion, e.frequency*t/v.frequency))
Sekarang korelasi silang dapat dihitung - untuk efisiensi kami hanya mencari jendela keterlambatan yang masuk akal - dan kelambatan di mana nilai maksimum ditemukan dapat diidentifikasi.
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."))
Output memberi tahu kita bahwa ekspansi memperlambat volume sebesar 1,85 detik. (Jika 3,5 detik terakhir data tidak terpotong, output akan menjadi 1,84 detik.)
Sebaiknya periksa semuanya dengan beberapa cara, terutama secara visual. Pertama, fungsi korelasi silang :
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)
Selanjutnya, mari kita daftarkan dua seri dalam waktu dan plot bersama pada sumbu yang sama .
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)
Terlihat bagus! Namun, kami bisa lebih memahami kualitas pendaftaran dengan sebaran . Saya memvariasikan warna pada waktu untuk menunjukkan perkembangan.
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")
Kami mencari titik untuk melacak bolak-balik sepanjang garis: variasi dari yang mencerminkan nonlinier dalam respons ekspansi volume terhadap waktu yang terlambat. Meskipun ada beberapa variasi, mereka cukup kecil. Namun, bagaimana variasi ini berubah dari waktu ke waktu mungkin merupakan hal yang menarik secara fisiologis. Hal yang luar biasa tentang statistik, terutama aspek eksplorasi dan visualnya, adalah bagaimana statistik cenderung menciptakan pertanyaan dan gagasan yang baik bersama dengan jawaban yang bermanfaat .