मैं सबसे सामान्य संभव समाधान का वर्णन करूंगा। इस सामान्यता में समस्या को हल करने से हमें एक उल्लेखनीय कॉम्पैक्ट सॉफ़्टवेयर कार्यान्वयन प्राप्त करने की अनुमति मिलती है: Rकोड प्रत्यय की सिर्फ दो छोटी लाइनें ।
आप की तरह किसी भी वितरण के अनुसार , एक ही लंबाई के , के रूप में एक वेक्टर चुनें । को विरुद्ध के न्यूनतम वर्ग प्रतिगमन के अवशिष्ट होने दें : यह से घटक को निकालता है । एक उपयुक्त गुणक को वापस जोड़कर , हम साथ किसी भी वांछित सहसंबंध वाले वेक्टर का उत्पादन कर सकते हैं । एक मनमाना additive स्थिर और सकारात्मक गुणक स्थिरांक तक - जिसे आप किसी भी तरह से चुनने के लिए स्वतंत्र हैं - समाधान हैवाई वाई ⊥ एक्स वाई वाई एक्स वाई वाई ⊥ ρ YXYY⊥XYYXYY⊥ρY
XY;ρ=ρSD(Y⊥)Y+1−ρ2−−−−−√SD(Y)Y⊥.
(" " मानक विचलन के लिए आनुपातिक किसी भी गणना के लिए खड़ा है।)SD
यहां वर्किंग 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)
}
वर्णन करने के लिए, मैंने घटकों के साथ एक यादृच्छिक उत्पन्न किया और इस साथ विभिन्न निर्दिष्ट सहसंबंध होने वाले उत्पादन किया । वे सभी एक ही शुरुआती वेक्टर के साथ बनाए गए थे । यहाँ उनके बिखराव हैं। प्रत्येक पैनल के नीचे स्थित "रगप्लॉट्स" सामान्य वेक्टर दिखाते हैं ।Y50XY;ρYX=(1,2,…,50)Y
भूखंडों के बीच एक उल्लेखनीय समानता है, वहाँ :-) नहीं है।
यदि आप प्रयोग करना चाहते हैं, तो यहां कोड है जो इन आंकड़ों और आंकड़ों का उत्पादन करता है। (मैंने आसान संचालन के लिए परिणामों को शिफ्ट और स्केल करने की स्वतंत्रता का उपयोग करने की जहमत नहीं उठाई।)
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 का उपयोग करता है।)YXY1,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)
निम्नलिखित उन लोगों के लिए अधिक पूर्ण कार्यान्वयन है जो प्रयोग करना चाहते हैं।
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))
