La domanda chiede come trovare la quantità con cui una serie temporale ("espansione") è in ritardo di un'altra ("volume") quando le serie vengono campionate a intervalli regolari ma diversi .
In questo caso entrambe le serie mostrano un comportamento ragionevolmente continuo, come mostreranno le figure. Ciò implica che (1) potrebbe essere necessario un livellamento iniziale minimo o nullo e (2) il ricampionamento può essere semplice quanto l'interpolazione lineare o quadratica. Quadratico può essere leggermente migliore a causa della scorrevolezza. Dopo il ricampionamento, il ritardo viene rilevato massimizzando la correlazione incrociata , come mostrato nel thread, Per due serie di dati campionate offset, qual è la migliore stima dell'offset tra di loro? .
Per illustrare , possiamo usare i dati forniti nella domanda, impiegando Rlo pseudocodice. Cominciamo con le funzionalità di base, la correlazione incrociata e il ricampionamento:
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")
}
Questo è un algoritmo grezzo: un calcolo basato su FFT sarebbe più veloce. Ma per questi dati (che coinvolgono circa 4000 valori) è abbastanza buono.
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
}
Ho scaricato i dati come file CSV separato da virgole e ho rimosso la sua intestazione. (L'intestazione ha causato alcuni problemi per R che non mi interessava diagnosticare.)
data <- read.table("f:/temp/a.csv", header=FALSE, sep=",",
col.names=c("Sample","Time32Hz","Expansion","Time100Hz","Volume"))
NB Questa soluzione presuppone che ogni serie di dati sia in ordine temporale senza lacune in nessuno dei due. Ciò gli consente di utilizzare gli indici nei valori come proxy per il tempo e di ridimensionare tali indici in base alle frequenze temporali di campionamento per convertirli in tempi.
Si scopre che uno o entrambi questi strumenti si spostano un po 'nel tempo. È bene rimuovere tali tendenze prima di procedere. Inoltre, poiché alla fine si verifica una riduzione del segnale del volume, dovremmo eliminarlo.
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)
Ho ricampionare l' meno serie -frequenti al fine di ottenere il massimo di precisione fuori dal risultato.
e.frequency <- 32 # Herz
v.frequency <- 100 # Herz
e <- sapply(1:length(v), function(t) resample(expansion, e.frequency*t/v.frequency))
Ora la correlazione incrociata può essere calcolata - per efficienza cerchiamo solo una ragionevole finestra di ritardi - e si può identificare il ritardo in cui si trova il valore massimo.
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."))
L'output ci dice che l'espansione ritarda il volume di 1,85 secondi. (Se gli ultimi 3,5 secondi di dati non fossero tagliati, l'output sarebbe 1,84 secondi.)
È una buona idea controllare tutto in diversi modi, preferibilmente visivamente. Innanzitutto, la funzione di correlazione incrociata :
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)
Quindi, registriamo le due serie in tempo e le tracciamo insieme sugli stessi assi .
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)
Sembra abbastanza buono! Tuttavia, possiamo capire meglio la qualità della registrazione con un diagramma a dispersione . Varia i colori nel tempo per mostrare la progressione.
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")
Stiamo cercando i punti da tracciare avanti e indietro lungo una linea: variazioni che riflettono non linearità nella risposta ritardata dell'espansione al volume. Sebbene ci siano alcune variazioni, sono piuttosto piccole. Tuttavia, come queste variazioni cambiano nel tempo possono essere di qualche interesse fisiologico. La cosa meravigliosa delle statistiche, in particolare del suo aspetto esplorativo e visivo, è come tende a creare buone domande e idee insieme a risposte utili .