使用R模擬具有指定均值和相關性的兩個條件變量

Question

這個問題來自我之前的一個問題 ，其中生成兩個相關序列的問題在一定程度上得到了解決。 我們試圖產生兩個相關的序列，它們遵循具有某些參數的指數分布。 例如，需要滿足均值為1的變量tr和具有均值為-0.5的均值為2的另一個變量t滿足t> tr的條件。 在R中嘗試了以下代碼。

rho   <- -0.5
mu    <- rep(0,2)
Sigma <- matrix(rho, nrow=2, ncol=2) + diag(2)*(1 - rho)

library(MASS)

compute.tr.t <- function(req.n, paccept) {
  req.n      <- round(req.n / paccept)
  rawvars    <- mvrnorm(req.n, mu=mu, Sigma=Sigma)
  pvars      <- pnorm(rawvars)
  tr         <- qexp(pvars[,1], 1/1)
  t          <- qexp(pvars[,2], 1/2)
  keep       <- which(t > tr)
  return(data.frame(t=t[keep],tr=tr[keep]))
}

req.n   <- n
paccept <- 1
res     <- data.frame()

while (req.n > 0) {
  new.res <- compute.tr.t(req.n, paccept)
  res     <- rbind(res, new.res)
  req.n   <- n - nrow(res)
  paccept <- nrow(new.res) / n# updated paccept according to last step
}

由於不滿足條件t> tr的修剪數據而發生的問題：

1. 手段沒有保留。
2. 相關性未保留。

請參見下面的輸出。 顯然，由於施加了這樣的條件，位置發生了變化。

mean(res$tr)
 [1] 0.4660927
 mean(res$t)
 [1] 2.859441
 print(cor(res$tr,res$t))
 [1] -0.237159

我的問題：有沒有辦法實現兩個相關和條件變量（例如t> tr ），以使序列均值接近指定均值？ 我們可能會減少相關性，但是否有可能至少保留均值？

Answer 1

更新了答案 ，其中t的每個元素嚴格大於tr：

n     <- 100
rho   <- 0.5
mu    <- rep(0,2)
Sigma <- matrix(rho, nrow=2, ncol=2) + diag(2)*(1 - rho)

library(MASS)

compute.tr.t <- function(req.n, paccept) {
  req.n      <- round(req.n / paccept)
  rawvars    <- mvrnorm(req.n, mu=mu, Sigma=Sigma)
  pvars      <- pnorm(rawvars)
  tr         <- qexp(pvars[,1], 1/1)
  t          <- qexp(pvars[,2], 1/2)
  tr         <- tr[(tr-mean(tr))^2  <.25 ] # can play with this value
  t          <- t[(t-mean(t))^2  <.25 ]
  m          <- min(length(t), length(tr))
  t          <- t[1:m]
  tr         <- tr[1:m]
  return(data.frame(t=t,tr=tr))
}

req.n   <- n
paccept <- 1
res     <- data.frame()

while (req.n > 0) {
  new.res <- compute.tr.t(req.n, paccept)
  res     <- rbind(res, new.res)
  req.n   <- n - nrow(res)
  paccept <- nrow(new.res) / n
}

mean(res$t)

[1] 1.972218

mean(res$tr)

[1] 0.590776

table(res$t > res$tr) # should be all true, rarely you'll get 1 trivial false that you can kick out

  TRUE 132 

cor(res$t,res$tr) # suffered a little but not too bad, can probably improve

[1] .2527064

原始答案的均值（t）>均值（tr），但不是每個元素：

n     <- 100
rho   <- 0.5
mu    <- rep(0,2)
Sigma <- matrix(rho, nrow=2, ncol=2) + diag(2)*(1 - rho)

library(MASS)

compute.tr.t <- function(req.n, paccept) {
  req.n      <- round(req.n / paccept)
  rawvars    <- mvrnorm(req.n, mu=mu, Sigma=Sigma)
  pvars      <- pnorm(rawvars)
  tr         <- qexp(pvars[,1], 1/1)
  t          <- qexp(pvars[,2], 1/2)
  keep       <- which(t > tr)
  return(data.frame(t=t,tr=tr))
}

req.n   <- n
paccept <- 1
res     <- data.frame()

while (req.n > 0) {
  new.res <- compute.tr.t(req.n, paccept)
  res     <- rbind(res, new.res)
  req.n   <- n - nrow(res)
  paccept <- nrow(new.res) / n# updated paccept according to last step
}

mean(res$tr)

[1] 0.9399213

mean(res$t)

[1] 1.795431

print(cor(res$tr,res$t)) 

[1] 0.5075668

由於在某種程度上存在一定程度的隨機性，因此我第二次運行它並得到以下結果：

mean(res$tr)

[1] 1.001255

mean(res$t)

[1] 1.922343

print(cor(res$tr,res$t)) 

[1] 0.6648311

如果您對結果不太滿意，則運行一次后，可以滿足以下任一要求的精度：

while(
  (cor(res$tr,res$t) > .55 | cor(res$tr,res$t) < .45)
){
  n     <- 100
  rho   <- 0.5
  mu    <- rep(0,2)
  Sigma <- matrix(rho, nrow=2, ncol=2) + diag(2)*(1 - rho)

  library(MASS)

  compute.tr.t <- function(req.n, paccept) {
    req.n      <- round(req.n / paccept)
    rawvars    <- mvrnorm(req.n, mu=mu, Sigma=Sigma)
    pvars      <- pnorm(rawvars)
    tr         <- qexp(pvars[,1], 1/1)
    t          <- qexp(pvars[,2], 1/2)
    keep       <- which(t > tr)
    return(data.frame(t=t,tr=tr))
  }

  req.n   <- n
  paccept <- 1
  res     <- data.frame()

  while (req.n > 0) {
    new.res <- compute.tr.t(req.n, paccept)
    res     <- rbind(res, new.res)
    req.n   <- n - nrow(res)
    paccept <- nrow(new.res) / n# updated paccept according to last step
  }
}