La pregunta pregunta cómo encontrar la cantidad en la cual una serie de tiempo ("expansión") se queda atrás de otra ("volumen") cuando las series se muestrean a intervalos regulares pero diferentes .
En este caso, ambas series exhiben un comportamiento razonablemente continuo, como lo mostrarán las figuras. Esto implica que (1) puede ser necesario poco o nada de suavizado inicial y (2) el remuestreo puede ser tan simple como la interpolación lineal o cuadrática. Cuadrático puede ser ligeramente mejor debido a la suavidad. Después de volver a muestrear , el retraso se encuentra maximizando la correlación cruzada , como se muestra en el hilo, Para dos series de datos muestreados con desplazamiento, ¿cuál es la mejor estimación del desplazamiento entre ellos? .
Para ilustrar , podemos usar los datos suministrados en la pregunta, empleando Rel pseudocódigo. Comencemos con la funcionalidad básica, la correlación cruzada y el remuestreo:
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")
}
Este es un algoritmo crudo: un cálculo basado en FFT sería más rápido. Pero para estos datos (que involucran alrededor de 4000 valores) es lo suficientemente bueno.
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
}
Descargué los datos como un archivo CSV separado por comas y eliminé su encabezado. (El encabezado causó algunos problemas para R que no me importó diagnosticar).
data <- read.table("f:/temp/a.csv", header=FALSE, sep=",",
col.names=c("Sample","Time32Hz","Expansion","Time100Hz","Volume"))
Nota: Esta solución supone que cada serie de datos está en orden temporal sin espacios en ninguno de los dos. Esto le permite usar índices en los valores como indicadores del tiempo y escalar esos índices por las frecuencias de muestreo temporales para convertirlos en tiempos.
Resulta que uno o ambos instrumentos se desplazan un poco con el tiempo. Es bueno eliminar esas tendencias antes de continuar. Además, debido a que hay una disminución gradual de la señal de volumen al final, debemos recortarla.
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)
Vuelvo a muestrear las series menos frecuentes para obtener la mayor precisión del resultado.
e.frequency <- 32 # Herz
v.frequency <- 100 # Herz
e <- sapply(1:length(v), function(t) resample(expansion, e.frequency*t/v.frequency))
Ahora se puede calcular la correlación cruzada, por eficiencia buscamos solo una ventana razonable de retrasos, y se puede identificar el retraso donde se encuentra el valor máximo.
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 salida nos dice que la expansión demora el volumen en 1.85 segundos. (Si no se recortaran los últimos 3,5 segundos de datos, la salida sería 1,84 segundos).
Es una buena idea verificar todo de varias maneras, preferiblemente visualmente. Primero, la función de correlación cruzada :
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)
A continuación, registremos las dos series en el tiempo y tracémoslas juntas en los mismos ejes .
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)
¡Se ve bastante bien! Sin embargo, podemos tener una mejor idea de la calidad del registro con un diagrama de dispersión . Varío los colores por tiempo para mostrar la progresió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")
Estamos buscando los puntos para rastrear hacia adelante y hacia atrás a lo largo de una línea: las variaciones a partir de eso reflejan no linealidades en la respuesta retardada de la expansión al volumen. Aunque hay algunas variaciones, son bastante pequeñas. Sin embargo, cómo estas variaciones cambian con el tiempo puede ser de algún interés fisiológico. Lo maravilloso de las estadísticas, especialmente su aspecto exploratorio y visual, es cómo tiende a crear buenas preguntas e ideas junto con respuestas útiles .