প্রশ্নটি জিজ্ঞাসা করে যে সিরিজটি নিয়মিত কিন্তু বিভিন্ন বিরতিতে যখন নমুনা দেওয়া হয় তখন কীভাবে এক সময়ের সিরিজ ("সম্প্রসারণ") আরেকটি ("ভলিউম") পিছিয়ে যায় সেই পরিমাণটি কীভাবে সন্ধান করতে হয় ।
এই ক্ষেত্রে উভয় সিরিজ যুক্তিযুক্ত ধারাবাহিক আচরণ প্রদর্শন করে, হিসাবে পরিসংখ্যানগুলি দেখায়। এর দ্বারা বোঝা যায় (1) সামান্য বা কোনও প্রাথমিক স্মুথিংয়ের প্রয়োজন হতে পারে এবং (২) পুনর্নির্মাণটি লিনিয়ার বা চতুর্ভুজীয় দ্বিখণ্ডনের মতো সহজ হতে পারে। চতুষ্পদত্ব মসৃণতার কারণে কিছুটা ভাল হতে পারে। পুনরায় মডেলিংয়ের পরে, থ্রেডে যেমন দেখানো হয়েছে, ক্রস-রিলেশনশিপ সর্বাধিক করে ল্যাগটি পাওয়া যায় , দুটি অফসেট স্যাম্পলড ডেটা সিরিজের জন্য, তাদের মধ্যে অফসেটের সেরা অনুমানটি কী? ।
উদাহরণস্বরূপ , আমরা 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")
}
এটি একটি অশোধিত অ্যালগরিদম: একটি এফএফটি-ভিত্তিক গণনা দ্রুত হবে। তবে এই ডেটাগুলির জন্য (প্রায় 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
}
আমি ডেটাটি কমা-বিচ্ছিন্ন সিএসভি ফাইল হিসাবে ডাউনলোড করেছি এবং এর শিরোনামটি কেড়ে ফেলেছি। (শিরোনামটি আর এর জন্য কিছু সমস্যা সৃষ্টি করেছিল যা আমি নির্ণয় করতে পাত্তাই নি।)
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")
আমরা একটি লাইনের সাথে সামনে এবং পিছনে ট্র্যাক করার জন্য পয়েন্টগুলি সন্ধান করছি: যা থেকে ভিন্নতাগুলি ভলিউমে প্রসারণের সময়-পিছনে প্রতিক্রিয়াতে অরেখার প্রতিফলন করে। যদিও কিছু ভিন্নতা রয়েছে তবে সেগুলি বেশ ছোট। তবুও, সময়ের সাথে এই বিভিন্নতাগুলি কীভাবে পরিবর্তিত হয় তা কিছু শারীরবৃত্তীয় আগ্রহের কারণ হতে পারে। পরিসংখ্যান, বিশেষত এর অনুসন্ধান এবং দৃষ্টিভঙ্গি দিক সম্পর্কে দুর্দান্ত জিনিস হ'ল এটি কীভাবে দরকারী উত্তরের পাশাপাশি ভাল প্রশ্ন এবং ধারণা তৈরি করতে ঝোঁক ।