La question demande comment trouver l'ampleur d'une série temporelle ("expansion") par rapport à une autre ("volume") lorsque les séries sont échantillonnées à intervalles réguliers mais différents .
Dans ce cas, les deux séries présentent un comportement raisonnablement continu, comme le montrent les figures. Cela implique (1) peu ou pas de lissage initial peut être nécessaire et (2) le rééchantillonnage peut être aussi simple qu'une interpolation linéaire ou quadratique. Quadratique peut être légèrement meilleur en raison de la douceur. Après le rééchantillonnage, le décalage est trouvé en maximisant la corrélation croisée , comme indiqué dans le fil de discussion. Pour deux séries de données échantillonnées avec décalage, quelle est la meilleure estimation du décalage entre elles? .
Pour illustrer , nous pouvons utiliser les données fournies dans la question, en utilisant Rpour le pseudocode. Commençons par les fonctionnalités de base, la corrélation croisée et le rééchantillonnage:
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")
}
Il s'agit d'un algorithme grossier: un calcul basé sur FFT serait plus rapide. Mais pour ces données (impliquant environ 4000 valeurs), c'est assez bon.
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
}
J'ai téléchargé les données sous forme de fichier CSV séparé par des virgules et supprimé son en-tête. (L'en-tête a causé des problèmes pour R que je n'ai pas voulu diagnostiquer.)
data <- read.table("f:/temp/a.csv", header=FALSE, sep=",",
col.names=c("Sample","Time32Hz","Expansion","Time100Hz","Volume"))
NB Cette solution suppose que chaque série de données est dans l'ordre temporel sans aucune lacune dans l'une ou l'autre. Cela lui permet d'utiliser des index dans les valeurs en tant que proxys pour le temps et de mettre à l'échelle ces index en fonction des fréquences d'échantillonnage temporelles pour les convertir en temps.
Il s'avère que l'un ou les deux de ces instruments dérivent un peu avec le temps. Il est bon de supprimer ces tendances avant de continuer. De plus, comme il y a une diminution du signal de volume à la fin, nous devons le couper.
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)
Je rééchantillonne la série la moins fréquente afin d'obtenir le plus de précision possible du résultat.
e.frequency <- 32 # Herz
v.frequency <- 100 # Herz
e <- sapply(1:length(v), function(t) resample(expansion, e.frequency*t/v.frequency))
Maintenant, la corrélation croisée peut être calculée - pour plus d'efficacité, nous ne recherchons qu'une fenêtre raisonnable de décalages - et le décalage où la valeur maximale est trouvée peut être identifié.
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."))
La sortie nous indique que l'expansion est en retard de 1,85 seconde. (Si les 3,5 dernières secondes de données n'étaient pas écrêtées, la sortie serait de 1,84 seconde.)
C'est une bonne idée de tout vérifier de plusieurs façons, de préférence visuellement. Tout d'abord, la fonction de corrélation croisée :
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)
Ensuite, enregistrons les deux séries dans le temps et plaçons-les ensemble sur les mêmes axes .
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)
Ça a l'air plutôt bien! Cependant, nous pouvons avoir une meilleure idée de la qualité d'enregistrement avec un nuage de points . Je fais varier les couleurs dans le temps pour montrer la progression.
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")
Nous recherchons les points à suivre dans les deux sens le long d'une ligne: les variations qui reflètent les non-linéarités dans la réponse temporelle de l'expansion au volume. Bien qu'il existe quelques variantes, elles sont assez petites. Pourtant, la façon dont ces variations changent au fil du temps peut présenter un certain intérêt physiologique. Ce qui est merveilleux avec les statistiques, en particulier leur aspect exploratoire et visuel, c'est la façon dont elles ont tendance à créer de bonnes questions et idées ainsi que des réponses utiles .