가장 일반적인 해결책을 설명하겠습니다. 이러한 일반적인 문제를 해결하면 두 줄의 짧은 R코드만으로도 매우 간단한 소프트웨어 구현을 달성 할 수 있습니다 .
벡터 선택 같은 길이, , 당신이 원하는 분포에 따라. 하자 의 최소 제곱 회귀의 잔차 수 에 대한 : 이것은 추출 에서 구성 요소를 . 다수의 적합한 다시 추가함으로써 로 , 우리는 임의의 상관 관계를 갖는 벡터 생성 할 수있다 와 . 임의의 추가 상수 및 양의 곱셈 상수까지-어떤 방식 으로든 자유롭게 선택할 수 있습니다.Y Y ⊥ X Y Y X Y Y ⊥ ρ 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)
}
예를 들어, 성분 으로 임의의 를 생성 하고이 와 다양한 지정된 상관 관계를 갖는 를 생성했습니다 . 그것들은 모두 같은 시작 벡터 졌습니다. 다음은 그들의 산점도입니다. 각 패널의 맨 아래에있는 "러품"은 일반적인 벡터를 보여줍니다 .50 X Y ; ρ Y X = ( 1 , 2 , … , 50 ) YY50XY;ρ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를 사용하여 이를 수행합니다.)X Y 1 , Y 2 , ... , Y의 K ; ρ 1 , ρ 2 , … , ρ k Y i Y i X Y i Y YYXY1,Y2,…,Yk;ρ1,ρ2,…,ρkYiYiXYiYY
여기에서 알고리즘의 스케치의 R1, 행렬의 열로 주어진다는 :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))
