如何在不重复预定义三元组中的特定元素的情况下随机化向量?
How to randomize a vector without repeating specific elements in predefined triples?
我从一个据称很简单的设置开始,结果变得非常具有挑战性:
比如说,我们有一个碗,里面有 W = 60 个白球,B = 10 个蓝球,G = 10 个绿球和 Y = 10 个黄球。
现在我开始从那个碗里抽出三元组并存储它们,直到碗变空。
但是,有一个规则:
规则:
Each triple may not contain more than one non-white ball of the same colour!
完成后,我对分别有 0、1、2 和 3 个非白球的三元组的比率感兴趣。
为了解决这个问题,我从抽取和拒绝样本的想法开始,直到有一个样本满足上面的规则。
我尝试使用此(希望可重现)代码:
W = rep(0, times = 60)
BGY = c(rep(1, times = 10),rep(2, times = 10),rep(3, times = 10))
sumup = matrix(c(rep(1,times=3)),byrow=FALSE)
OUTPUT = c(0,0,0,0)
getBALLS = function(W,BGY){
k = 0
while (k == 0){
POT = c(W, BGY)
STEPS = (length(W) + length(BGY))/3
randPOT <<- sample(POT, STEPS*3, replace=FALSE)
for(j in 1:STEPS){
if (.subset2(randPOT,3*j-2)!=.subset2(randPOT,3*j-1) &&
.subset2(randPOT,3*j-2)!= .subset2(randPOT,3*j) &&
.subset2(randPOT,3*j-1)!=.subset2(randPOT,3*j)){
next
}
else getBALLS(W, BGY)
}
k = 1
}
TABLES = matrix(randPOT, nrow=3, byrow=FALSE)
Bdistr = t(TABLES) %*% sumup
for(i in 1:STEPS){
if (.subset2(Bdistr,i)==1) OUTPUT[1] <<- .subset2(OUTPUT,1)+1
else if (.subset2(Bdistr,i)==0) OUTPUT[4] <<- .subset2(OUTPUT,4)+1
else if (.subset2(Bdistr,i)==2) OUTPUT[2] <<- .subset2(OUTPUT,2)+1
else OUTPUT[3] <<- .subset2(OUTPUT,3)+1
}
rOUTPUT = OUTPUT/ STEPS
return(rOUTPUT)
}
set.seed(1)
getBALLS(W,BGY)
不幸的是我遇到了两个问题:
- 循环迭代次数过多!似乎经常违反规则,这使得以这种方式进行采样可能不可行。
- 虽然我试图调用最有效的函数,但当有不止一种方法到达那里时(例如 .subset2 调用),我有一种感觉,这段代码在解决这个问题方面效率很低。
接下来我尝试了两阶段采样(更具体地说是 sampling
包中的 mstage
函数):
Stage1 = c( rep(0,12), rep(1,3), rep(2,3) )
Stage2 = c( rep(0,12), rep(1,3), rep(2,3) )
b = data.frame(Stage1, Stage2)
probs = list( list( (1/12) , (1/3), (1/3) ), list( rep(1/12,12),rep(1/3,3),rep(1/3,3) ) )
m = mstage( b, stage = list("cluster","cluster"), varnames = list("Stage1","Stage2"),
size = list(3,c(1,1,1)), method = "systematic", pik = probs)
虽然这也没有奏效,但我也觉得这种方法不太适合我的问题!
总而言之,在我看来有点像我在用大锤敲坚果,我觉得有一种更有效的方法来解决这个问题(特别是因为我想 运行 一些蒙特卡洛模拟之后)。
如有任何帮助,我将不胜感激!
提前致谢!
这是一种毫无疑问可以改进的替代方法,但我认为它具有某种统计意义(在三个样本中具有特定颜色使得另一种颜色不太可能出现在同一个三个样本中).
coloursinsamples <- function (W,B,G,Y){
WBGY <- c(W,B,G,Y)
if(sum(WBGY) %% 3 != 0){ warning("cannot take exact full sample") }
numbersamples <- sum(WBGY) / 3
if(max(WBGY[2:4]) > numbersamples){ warning("too many of a colour") }
weights <- rep(3,numbersamples)
sampleB <- sample(numbersamples, size=WBGY[2], prob=weights)
weights[sampleB] <- weights[sampleB]-1
sampleG <- sample(numbersamples, size=WBGY[3], prob=weights)
weights[sampleG] <- weights[sampleG]-1
sampleY <- sample(numbersamples, size=WBGY[4], prob=weights)
weights[sampleY] <- weights[sampleY]-1
numbercolours <- table(table(c(sampleB,sampleG,sampleY)))
result <- c("0" = numbersamples - sum(numbercolours), numbercolours)
if(! "1" %in% names(result)){ result <- c(result, "1"=0) }
if(! "2" %in% names(result)){ result <- c(result, "2"=0) }
if(! "3" %in% names(result)){ result <- c(result, "3"=0) }
result[as.character(0:3)]
}
set.seed(1)
coloursinsamples(6,1,1,1)
coloursinsamples(60,10,10,10)
coloursinsamples(600,100,100,100)
coloursinsamples(6000,1000,1000,1000)
我从一个据称很简单的设置开始,结果变得非常具有挑战性:
比如说,我们有一个碗,里面有 W = 60 个白球,B = 10 个蓝球,G = 10 个绿球和 Y = 10 个黄球。 现在我开始从那个碗里抽出三元组并存储它们,直到碗变空。 但是,有一个规则:
规则:
Each triple may not contain more than one non-white ball of the same colour!
完成后,我对分别有 0、1、2 和 3 个非白球的三元组的比率感兴趣。
为了解决这个问题,我从抽取和拒绝样本的想法开始,直到有一个样本满足上面的规则。
我尝试使用此(希望可重现)代码:
W = rep(0, times = 60)
BGY = c(rep(1, times = 10),rep(2, times = 10),rep(3, times = 10))
sumup = matrix(c(rep(1,times=3)),byrow=FALSE)
OUTPUT = c(0,0,0,0)
getBALLS = function(W,BGY){
k = 0
while (k == 0){
POT = c(W, BGY)
STEPS = (length(W) + length(BGY))/3
randPOT <<- sample(POT, STEPS*3, replace=FALSE)
for(j in 1:STEPS){
if (.subset2(randPOT,3*j-2)!=.subset2(randPOT,3*j-1) &&
.subset2(randPOT,3*j-2)!= .subset2(randPOT,3*j) &&
.subset2(randPOT,3*j-1)!=.subset2(randPOT,3*j)){
next
}
else getBALLS(W, BGY)
}
k = 1
}
TABLES = matrix(randPOT, nrow=3, byrow=FALSE)
Bdistr = t(TABLES) %*% sumup
for(i in 1:STEPS){
if (.subset2(Bdistr,i)==1) OUTPUT[1] <<- .subset2(OUTPUT,1)+1
else if (.subset2(Bdistr,i)==0) OUTPUT[4] <<- .subset2(OUTPUT,4)+1
else if (.subset2(Bdistr,i)==2) OUTPUT[2] <<- .subset2(OUTPUT,2)+1
else OUTPUT[3] <<- .subset2(OUTPUT,3)+1
}
rOUTPUT = OUTPUT/ STEPS
return(rOUTPUT)
}
set.seed(1)
getBALLS(W,BGY)
不幸的是我遇到了两个问题:
- 循环迭代次数过多!似乎经常违反规则,这使得以这种方式进行采样可能不可行。
- 虽然我试图调用最有效的函数,但当有不止一种方法到达那里时(例如 .subset2 调用),我有一种感觉,这段代码在解决这个问题方面效率很低。
接下来我尝试了两阶段采样(更具体地说是 sampling
包中的 mstage
函数):
Stage1 = c( rep(0,12), rep(1,3), rep(2,3) )
Stage2 = c( rep(0,12), rep(1,3), rep(2,3) )
b = data.frame(Stage1, Stage2)
probs = list( list( (1/12) , (1/3), (1/3) ), list( rep(1/12,12),rep(1/3,3),rep(1/3,3) ) )
m = mstage( b, stage = list("cluster","cluster"), varnames = list("Stage1","Stage2"),
size = list(3,c(1,1,1)), method = "systematic", pik = probs)
虽然这也没有奏效,但我也觉得这种方法不太适合我的问题!
总而言之,在我看来有点像我在用大锤敲坚果,我觉得有一种更有效的方法来解决这个问题(特别是因为我想 运行 一些蒙特卡洛模拟之后)。
如有任何帮助,我将不胜感激! 提前致谢!
这是一种毫无疑问可以改进的替代方法,但我认为它具有某种统计意义(在三个样本中具有特定颜色使得另一种颜色不太可能出现在同一个三个样本中).
coloursinsamples <- function (W,B,G,Y){
WBGY <- c(W,B,G,Y)
if(sum(WBGY) %% 3 != 0){ warning("cannot take exact full sample") }
numbersamples <- sum(WBGY) / 3
if(max(WBGY[2:4]) > numbersamples){ warning("too many of a colour") }
weights <- rep(3,numbersamples)
sampleB <- sample(numbersamples, size=WBGY[2], prob=weights)
weights[sampleB] <- weights[sampleB]-1
sampleG <- sample(numbersamples, size=WBGY[3], prob=weights)
weights[sampleG] <- weights[sampleG]-1
sampleY <- sample(numbersamples, size=WBGY[4], prob=weights)
weights[sampleY] <- weights[sampleY]-1
numbercolours <- table(table(c(sampleB,sampleG,sampleY)))
result <- c("0" = numbersamples - sum(numbercolours), numbercolours)
if(! "1" %in% names(result)){ result <- c(result, "1"=0) }
if(! "2" %in% names(result)){ result <- c(result, "2"=0) }
if(! "3" %in% names(result)){ result <- c(result, "3"=0) }
result[as.character(0:3)]
}
set.seed(1)
coloursinsamples(6,1,1,1)
coloursinsamples(60,10,10,10)
coloursinsamples(600,100,100,100)
coloursinsamples(6000,1000,1000,1000)