আমি সবচেয়ে সাধারণ সম্ভাব্য সমাধান বর্ণনা করব। এই সাধারণতার মধ্যে সমস্যা সমাধান করা আমাদের উল্লেখযোগ্যভাবে কমপ্যাক্ট সফ্টওয়্যার বাস্তবায়ন করতে দেয়: Rকোডের দুটি মাত্র দুটি লাইনই যথেষ্ট।
একটি ভেক্টর বাছাই করুন হিসাবে একই দৈর্ঘ্যের, , আপনার মত কোন বন্টন অনুযায়ী। যাক এর লিস্ট স্কোয়ার রিগ্রেশন এর অবশিষ্টাংশ হতে বিরুদ্ধে : এই চায়ের থেকে উপাদান । একটি উপযুক্ত একাধিক ফিরে যোগ করে থেকে , আমরা একটি ভেক্টর কোন পছন্দসই পারস্পরিক সম্পর্ক থাকার তৈরি করতে পারে সঙ্গে । একটি স্বেচ্ছাচারী অ্যাডেটিভ ধ্রুবক এবং ধনাত্মক গুণক ধ্রুবক পর্যন্ত - যা আপনি যে কোনও উপায়ে চয়ন করতে পারেন - সমাধানটি হ'লওয়াই ওয়াই ⊥ এক্স ওয়াই ওয়াই এক্স ওয়াই ওয়াই ⊥ ρ ওয়াইXYY⊥XYYXYY⊥ρY
XY;ρ=ρSD(Y⊥)Y+1−ρ2−−−−−√SD(Y)Y⊥.
(" " মানে কোনও স্ট্যান্ডার্ড বিচ্যুতির সমানুপাতিক কোনও গণনা forSD
এখানে Rকোড কাজ করছে । আপনি সরবরাহ না করলে কোডটি এর মানগুলি মাল্টিভারিয়েট স্ট্যান্ডার্ড সাধারণ বিতরণ থেকে আঁকবে।X
complement <- function(y, rho, x) {
if (missing(x)) x <- rnorm(length(y)) # Optional: supply a default if `x` is not given
y.perp <- residuals(lm(x ~ y))
rho * sd(y.perp) * y + y.perp * sd(y) * sqrt(1 - rho^2)
}
উদাহরণস্বরূপ, আমি উপাদান সহ একটি এলোমেলো তৈরি করেছি এবং এই সাথে বিভিন্ন নির্দিষ্ট পারস্পরিক সম্পর্কযুক্ত produced উত্পাদন করেছি । এগুলি সমস্ত একই ভেক্টর । এখানে তাদের স্ক্র্যাপপ্লটগুলি রয়েছে। প্রতিটি প্যানেলের নীচে "রাগপ্লটগুলি" সাধারণ ভেক্টর দেখায় ।50 X Y ; ρ ওয়াই এক্স = ( 1 , 2 , … , 50 ) ওয়াইY50XY;ρYX=(1,2,…,50)Y
প্লটগুলির মধ্যে একটি উল্লেখযোগ্য মিল রয়েছে, নেই :-))
আপনি যদি পরীক্ষা করতে চান, এখানে কোড রয়েছে যা এই ডেটা এবং চিত্রটি তৈরি করেছে। (আমি ফলাফলগুলি পরিবর্তন করতে এবং স্কেল করার স্বাধীনতা ব্যবহার করতে বিরক্ত করি নি, যা সহজ কাজ operations
y <- rnorm(50, sd=10)
x <- 1:50 # Optional
rho <- seq(0, 1, length.out=6) * rep(c(-1,1), 3)
X <- data.frame(z=as.vector(sapply(rho, function(rho) complement(y, rho, x))),
rho=ordered(rep(signif(rho, 2), each=length(y))),
y=rep(y, length(rho)))
library(ggplot2)
ggplot(X, aes(y,z, group=rho)) +
geom_smooth(method="lm", color="Black") +
geom_rug(sides="b") +
geom_point(aes(fill=rho), alpha=1/2, shape=21) +
facet_wrap(~ rho, scales="free")
BTW, এই পদ্ধতি নির্দ্ধিধায় একাধিক করার সাধারণীকরণ : যদি এটা গাণিতিকভাবে সম্ভব, এটি একটি পাবেন একটি সম্পূর্ণ সঙ্গে নিদিষ্ট সম্পর্কযুক্তরূপে থাকার সেট । থেকে সমস্ত এর প্রভাবগুলি খুঁজে পেতে কেবলমাত্র সর্বনিম্ন স্কোয়ারগুলি ব্যবহার করুন এবং এবং অবশিষ্টাংশের উপযুক্ত লিনিয়ার সংমিশ্রণ তৈরি করুন । (এটা জন্য একটি দ্বৈত ভিত্তিতে পরিপ্রেক্ষিতে এই কাজ করতে সাহায্য করে , যা একটি সিউডো-বিপরীত কম্পিউটিং দ্বারা প্রাপ্ত হয়। Follownig কোডের SVD ব্যবহার যে সম্পন্ন করার জন্য।)X Y 1 , Y 2 , … , Y k ; ρ 1 , ρ 2 , … , ρ k Y I Y I X Y i Y YYXY1,Y2,…,Yk;ρ1,ρ2,…,ρkYiYiXYiYY
এখানে আলগোরিদিমটির স্কেচ এখানে রয়েছে R, যেখানে ম্যাট্রিক্সের কলাম হিসাবে দেওয়া হয়েছে :Yiy
y <- scale(y) # Makes computations simpler
e <- residuals(lm(x ~ y)) # Take out the columns of matrix `y`
y.dual <- with(svd(y), (n-1)*u %*% diag(ifelse(d > 0, 1/d, 0)) %*% t(v))
sigma2 <- c((1 - rho %*% cov(y.dual) %*% rho) / var(e))
return(y.dual %*% rho + sqrt(sigma2)*e)
নিম্নলিখিত যারা পরীক্ষা করতে চান তাদের জন্য আরও একটি সম্পূর্ণ বাস্তবায়ন is
complement <- function(y, rho, x) {
#
# Process the arguments.
#
if(!is.matrix(y)) y <- matrix(y, ncol=1)
if (missing(x)) x <- rnorm(n)
d <- ncol(y)
n <- nrow(y)
y <- scale(y) # Makes computations simpler
#
# Remove the effects of `y` on `x`.
#
e <- residuals(lm(x ~ y))
#
# Calculate the coefficient `sigma` of `e` so that the correlation of
# `y` with the linear combination y.dual %*% rho + sigma*e is the desired
# vector.
#
y.dual <- with(svd(y), (n-1)*u %*% diag(ifelse(d > 0, 1/d, 0)) %*% t(v))
sigma2 <- c((1 - rho %*% cov(y.dual) %*% rho) / var(e))
#
# Return this linear combination.
#
if (sigma2 >= 0) {
sigma <- sqrt(sigma2)
z <- y.dual %*% rho + sigma*e
} else {
warning("Correlations are impossible.")
z <- rep(0, n)
}
return(z)
}
#
# Set up the problem.
#
d <- 3 # Number of given variables
n <- 50 # Dimension of all vectors
x <- 1:n # Optionally: specify `x` or draw from any distribution
y <- matrix(rnorm(d*n), ncol=d) # Create `d` original variables in any way
rho <- c(0.5, -0.5, 0) # Specify the correlations
#
# Verify the results.
#
z <- complement(y, rho, x)
cbind('Actual correlations' = cor(cbind(z, y))[1,-1],
'Target correlations' = rho)
#
# Display them.
#
colnames(y) <- paste0("y.", 1:d)
colnames(z) <- "z"
pairs(cbind(z, y))
