คำถามจะถามว่าจะหาจำนวนได้อย่างไรในซีรีส์ครั้งเดียว ("ส่วนขยาย") จะล่าช้าอีกครั้ง ("ระดับเสียง") เมื่อสุ่มตัวอย่างซีรีย์ตามช่วงเวลาปกติ แต่แตกต่างกัน
ในกรณีนี้ทั้งสองซีรีส์มีพฤติกรรมต่อเนื่องอย่างสมเหตุสมผลเนื่องจากตัวเลขจะปรากฏขึ้น สิ่งนี้หมายถึง (1) อาจจำเป็นต้องมีการปรับให้เรียบเริ่มต้นเพียงเล็กน้อยหรือไม่มีเลยก็ได้และ (2) การปรับตัวอย่างใหม่อาจทำได้ง่ายเช่นเดียวกับการประมาณเชิงเส้นหรือกำลังสอง กำลังสองอาจดีกว่าเล็กน้อยเนื่องจากความเรียบเนียน หลังจาก resampling อีกครั้งความล่าช้าจะพบได้โดยการเพิ่มความสัมพันธ์ข้ามให้มากที่สุดดังที่แสดงในเธรดสำหรับชุดข้อมูลที่สุ่มตัวอย่างสองชุดค่าประมาณที่ดีที่สุดของ offset ระหว่างพวกมันคืออะไร .
เพื่อแสดงให้เห็นว่าเราสามารถใช้ข้อมูลที่ให้มาในคำถามโดยใช้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"))
NB วิธีการแก้ปัญหานี้ถือว่าข้อมูลแต่ละชุดอยู่ในลำดับชั่วคราวโดยไม่มีช่องว่างทั้งคู่ สิ่งนี้ช่วยให้มันสามารถใช้ดัชนีเป็นค่าเป็นพร็อกซีสำหรับเวลาและปรับดัชนีดัชนีเหล่านั้นด้วยความถี่การสุ่มตัวอย่างชั่วคราวเพื่อแปลงให้เป็นเวลา
ปรากฎว่าเครื่องมือเหล่านี้หนึ่งหรือทั้งสองล่องลอยไปตามกาลเวลาเล็กน้อย เป็นการดีที่จะลบแนวโน้มดังกล่าวก่อนดำเนินการต่อ นอกจากนี้เนื่องจากมีการลดลงของสัญญาณเสียงที่ส่วนท้ายเราควรตัดออก
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)
ฉัน resample ชุดความถี่น้อยกว่าเพื่อให้ได้ผลลัพธ์ที่แม่นยำที่สุด
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")
เรากำลังมองหาจุดที่จะติดตามไปมาในแนวเส้น: การเปลี่ยนแปลงจากที่สะท้อนให้เห็นถึงความไม่เชิงเส้นในการตอบสนองล่าช้าของการขยายตัวสู่ระดับเสียง แม้ว่าจะมีบางรูปแบบ แต่ก็มีขนาดที่ค่อนข้างเล็ก ทว่ารูปแบบเหล่านี้เปลี่ยนแปลงไปตามกาลเวลาอาจเป็นประโยชน์ทางสรีรวิทยาบ้าง สิ่งมหัศจรรย์เกี่ยวกับสถิติโดยเฉพาะด้านการสำรวจและการมองเห็นของมันคือวิธีที่จะสร้างคำถามและแนวคิดที่ดีพร้อมกับคำตอบที่เป็นประโยชน์