Câu hỏi hỏi làm thế nào để tìm ra số lượng mà một chuỗi thời gian ("mở rộng") tụt lại một lần nữa ("âm lượng") khi chuỗi được lấy mẫu theo các khoảng thời gian đều đặn nhưng khác nhau .
Trong trường hợp này, cả hai loạt biểu hiện hành vi liên tục hợp lý, như các số liệu sẽ hiển thị. Điều này ngụ ý (1) ít hoặc không cần làm mịn ban đầu và (2) việc lấy lại mẫu có thể đơn giản như nội suy tuyến tính hoặc bậc hai. Quadratic có thể tốt hơn một chút do độ mịn. Sau khi lấy mẫu lại, độ trễ được tìm thấy bằng cách tối đa hóa mối tương quan chéo , như được hiển thị trong luồng, Đối với hai chuỗi dữ liệu được lấy mẫu bù, ước tính tốt nhất của độ lệch giữa chúng là gì? .
Để minh họa , chúng ta có thể sử dụng dữ liệu được cung cấp trong câu hỏi, sử dụng Rcho mã giả. Hãy bắt đầu với chức năng cơ bản, tương quan chéo và lấy mẫu lại:
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")
}
Đây là một thuật toán thô: tính toán dựa trên FFT sẽ nhanh hơn. Nhưng đối với những dữ liệu này (liên quan đến khoảng 4000 giá trị) thì đủ tốt.
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
}
Tôi đã tải xuống dữ liệu dưới dạng tệp CSV được phân tách bằng dấu phẩy và tước tiêu đề của nó. (Tiêu đề gây ra một số vấn đề cho R mà tôi không quan tâm để chẩn đoán.)
data <- read.table("f:/temp/a.csv", header=FALSE, sep=",",
col.names=c("Sample","Time32Hz","Expansion","Time100Hz","Volume"))
NB Giải pháp này giả định mỗi chuỗi dữ liệu theo thứ tự tạm thời không có khoảng trống trong một. Điều này cho phép nó sử dụng các chỉ mục thành các giá trị dưới dạng proxy theo thời gian và chia tỷ lệ các chỉ mục đó theo tần số lấy mẫu tạm thời để chuyển đổi chúng thành thời gian.
Nó chỉ ra rằng một hoặc cả hai dụng cụ này trôi đi một chút theo thời gian. Thật tốt khi loại bỏ các xu hướng như vậy trước khi tiếp tục. Ngoài ra, vì có sự giảm dần của tín hiệu âm lượng ở cuối, chúng ta nên cắt nó ra.
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)
Tôi lấy mẫu lại chuỗi ít hiệu quả để có được kết quả chính xác nhất.
e.frequency <- 32 # Herz
v.frequency <- 100 # Herz
e <- sapply(1:length(v), function(t) resample(expansion, e.frequency*t/v.frequency))
Bây giờ mối tương quan chéo có thể được tính toán - để đạt hiệu quả, chúng tôi chỉ tìm kiếm một cửa sổ độ trễ hợp lý - và độ trễ nơi tìm thấy giá trị tối đa có thể được xác định.
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."))
Đầu ra cho chúng ta biết rằng việc mở rộng bị chậm lại âm lượng 1,85 giây. (Nếu 3,5 giây cuối cùng của dữ liệu không được cắt bớt, đầu ra sẽ là 1,84 giây.)
Đó là một ý tưởng tốt để kiểm tra mọi thứ theo nhiều cách, tốt nhất là trực quan. Đầu tiên, hàm tương quan chéo :
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)
Tiếp theo, hãy đăng ký hai chuỗi thời gian và vẽ chúng cùng nhau trên cùng một trục .
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)
Có vẻ khá tốt! Tuy nhiên, chúng ta có thể hiểu rõ hơn về chất lượng đăng ký với một biểu đồ phân tán . Tôi thay đổi màu sắc theo thời gian để hiển thị sự tiến triển.
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")
Chúng tôi đang tìm kiếm các điểm để theo dõi qua lại dọc theo một dòng: các biến thể từ đó phản ánh sự phi tuyến tính trong phản ứng trễ thời gian của việc mở rộng thành âm lượng. Mặc dù có một số biến thể, chúng khá nhỏ. Tuy nhiên, làm thế nào những thay đổi này thay đổi theo thời gian có thể là một số lợi ích sinh lý. Điều tuyệt vời về thống kê, đặc biệt là khía cạnh khám phá và hình ảnh của nó, là cách nó có xu hướng tạo ra những câu hỏi và ý tưởng hay cùng với những câu trả lời hữu ích .