Питання задає питання, як знайти суму, на яку один часовий ряд ("розширення") відстає інший ("об'єм"), коли рядки відбираються через регулярні, але різні інтервали.
У цьому випадку обидві серії демонструють досить постійну поведінку, як це показують фігури. Це означає, що (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")
}
Це непростий алгоритм: розрахунок на основі FFT був би швидшим. Але для цих даних (що включає близько 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")
Ми шукаємо точки, які слід відслідковувати вперед і назад по лінії: відхилення від цього відображають нелінійності в часовій відповіді розширення на об'єм. Хоча існують деякі варіанти, вони досить малі. Тим не менш, те , як ці зміни змінюються з часом, може представляти певний фізіологічний інтерес. Чудова річ у статистиці, особливо її дослідницькому та візуальному аспекті, - це те, як вона має тенденцію створювати хороші запитання та ідеї разом із корисними відповідями.