Tôi sẽ mô tả các giải pháp chung nhất có thể. Giải quyết vấn đề theo tính tổng quát này cho phép chúng tôi đạt được một triển khai phần mềm nhỏ gọn đáng chú ý: chỉ cần hai dòng Rmã ngắn .
Chọn một vectơ , có cùng độ dài với , theo bất kỳ phân phối nào bạn muốn. Hãy là dư của các hình vuông hồi quy nhất của so với : đây trích xuất thành phần từ . Bằng cách thêm lại một bội số phù hợp của để , chúng tôi có thể tạo ra một vector có bất kỳ mong muốn tương quan với . Lên đến một hằng số cộng gộp tùy ý và hằng số nhân dương - mà bạn có thể tự do lựa chọn theo bất kỳ cách nào - giải pháp làY Y ⊥ X Y Y X Y Y ⊥ ρ YXYY⊥XYYXYY⊥ρY
XY;ρ=ρSD(Y⊥)Y+1−ρ2−−−−−√SD(Y)Y⊥.
(" " là viết tắt của mọi phép tính tỷ lệ với độ lệch chuẩn.)SD
Đây là Rmã làm việc . Nếu bạn không cung cấp , mã sẽ rút ra các giá trị của nó từ phân phối chuẩn chuẩn đa biến.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)
}
Để minh họa, tôi đã tạo một ngẫu nhiên với thành phần và tạo ra có các mối tương quan được chỉ định khác nhau với này . Tất cả chúng đều được tạo với cùng một vectơ bắt đầu . Dưới đây là những phân tán của họ. Các "tấm thảm" ở dưới cùng của mỗi bảng hiển thị vectơ chung .50 X Y ; ρ Y X = ( 1 , 2 , ... , 50 )Y50XY;ρYX=(1,2,…,50)Y
Có một sự tương đồng đáng chú ý giữa các lô, không có :-).
Nếu bạn muốn thử nghiệm, đây là mã tạo ra những dữ liệu và hình này. (Tôi không bận tâm sử dụng quyền tự do để thay đổi và chia tỷ lệ kết quả, đây là những thao tác dễ dàng.)
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, phương pháp này dễ dàng khái quát hóa cho nhiều hơn một : nếu có thể về mặt toán học, nó sẽ tìm thấy một có các mối tương quan được chỉ định với toàn bộ bộ . Chỉ cần sử dụng bình phương tối thiểu thông thường để loại bỏ các hiệu ứng của tất cả từ và tạo thành một tổ hợp tuyến tính phù hợp của và phần dư. (Nó giúp thực hiện điều này trên cơ sở kép cho , thu được bằng cách tính toán nghịch đảo giả. Mã follownig sử dụng SVD của để thực hiện điều đó.)Y Y i Y i X Y i Y YXY1,Y2,…,Yk;ρ1,ρ2,…,ρkYiYiXYiYY
Đây là bản phác thảo của thuật toán R, trong đó được đưa ra dưới dạng các cột của ma trận :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)
Sau đây là một triển khai đầy đủ hơn cho những người muốn thử nghiệm.
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))
