Ich werde die allgemeinste mögliche Lösung beschreiben. Die Lösung des Problems in dieser Allgemeinheit ermöglicht es uns, eine bemerkenswert kompakte Softwareimplementierung zu erzielen: Nur zwei kurze RCodezeilen reichen aus.
Wähle einen Vektor , der die gleiche Länge wie , nach einem der Verteilung Sie mögen. Lassen die Residuen der Regression der kleinsten Quadrate der seine gegen : Diese extrahiert die - Komponente von . Indem wir ein geeignetes Vielfaches von zu , können wir einen Vektor mit jeder gewünschten Korrelation mit erzeugen . Bis zu einer beliebigen additiven Konstante und positiven multiplikativen Konstante - die Sie nach Belieben wählen können - ist die LösungY Y ⊥ X Y Y X Y Y ⊥ & rgr; YXYY⊥XYYXYY⊥ρY
XY;ρ=ρSD(Y⊥)Y+1−ρ2−−−−−√SD(Y)Y⊥.
(" " steht für eine Berechnung, die proportional zu einer Standardabweichung ist.)SD
Hier ist RArbeitscode. Wenn Sie kein angeben, der Code seine Werte aus der multivariaten Standardnormalverteilung.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)
}
Zur Veranschaulichung habe ich ein zufälliges mit 50 Komponenten erzeugt und X Y erzeugt ; ρ mit verschiedenen spezifizierten Korrelationen mit diesem Y . Sie wurden alle mit demselben Startvektor X = ( 1 , 2 , … , 50 ) erstellt . Hier sind ihre Streudiagramme. Die "Rugplots" am unteren Rand jedes Panels zeigen den gemeinsamen Y- Vektor.Y50XY;ρYX=(1,2,…,50)Y
Es gibt eine bemerkenswerte Ähnlichkeit zwischen den Handlungen, nicht wahr :-).
Wenn Sie experimentieren möchten, finden Sie hier den Code, der diese Daten erzeugt hat, und die Abbildung. (Ich habe mich nicht darum gekümmert, die Freiheit zu nutzen, die Ergebnisse zu verschieben und zu skalieren. Das sind einfache Operationen.)
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")
YXY1,Y2,…,Yk;ρ1,ρ2,…,ρkYiYiXYiYY
RYiy
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)
Das Folgende ist eine vollständigere Implementierung für diejenigen, die experimentieren möchten.
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))
