Question

我有100个项目的清单。我想随机配对这些物品。这些对必须是唯一的，因此共有4950种可能性（100选2）。

在所有4950对中，我想随机选择1000对。但他们关键的是，我希望每个项目（100个项目）整体出现相同的次数（这里，20次）。

我尝试用代码实现这几次。当我尝试选择较少量的对时，它工作正常，但每次尝试使用完整的1000对时，我会陷入困境。

有没有人对方法有所了解？如果我改变我想选择的对的数量（例如，1500而不是1000个随机对）会怎样？

我的尝试（用VBA写的）：

Dim City1(4951) As Integer
Dim City2(4951) As Integer

Dim CityCounter(101) As Integer
Dim PairCounter(4951) As Integer

Dim i As Integer 
Dim j As Integer
Dim k As Integer
i = 1

While i < 101
    CityCounter(i) = 0
    i = i + 1
Wend

i = 1
While i < 4951
    PairCounter(i) = 0
    i = i + 1
Wend

i = 1
j = 1

While j < 101

    k = j + 1

    While k < 101
        City1(i) = j
        City2(i) = k

        k = k + 1
        i = i + 1       
    Wend

    j = j + 1

Wend

Dim temp As Integer

i = 1
While i < 1001

    temp = Random(1,4950)

    While ((PairCounter(temp) = 1) Or (CityCounter( (City1(temp)) ) = 20) Or (CityCounter( (City2(temp)) ) = 20))
        temp = Random(1,4950)
    Wend

    PairCounter(temp) = 1
    CityCounter( (City1(temp)) ) = (CityCounter( (City1(temp)) ) + 1)
    CityCounter( (City2(temp)) ) = (CityCounter( (City2(temp)) ) + 1)
    i = i + 1

Wend

Answer 1

列出一个列表，加扰它，并将每两个元素标记为一对。将这些对添加到对列表中。确保对列表进行排序。

加扰对列表，并将每对添加到“暂存”对列表中。检查它是否在对列表中。如果它在对列表中，则争抢并重新开始。如果您获得的整个列表没有任何重复项，请将暂存对列表添加到配对列表中并开始此段落。

由于这涉及最后的不确定性步骤，我不确定它会有多慢，但它应该有效。

Answer 2

这是旧线程，但我一直在寻找类似的东西，最后我自己做了。

算法不是100％随机的（在有点＆＃34;累了＆＃34;随机试验失败后开始系统筛选表:) - 无论如何对我来说 - ＆＃34;足够随机＆＃34;）但工作速度相当快，并且通常每隔一秒或第三次使用返回所需的表（不幸的是，但不是......）（如果每个项目有你需要的对数，请查看A1）。这是在Excel环境中运行的VBA代码。输出从A1单元开始指向当前工作表。

Option Explicit
Public generalmax%, oldgeneralmax%, generalmin%, alloweddiff%, i&
Public outtable() As Integer
Const maxpair = 100, upperlimit = 20


Sub generate_random_unique_pairs()
'by Kaper 2015.02 for stackoverflow.com/questions/14884975
Dim x%, y%, counter%
Randomize
ReDim outtable(1 To maxpair + 1, 1 To maxpair + 1)
Range("A1").Resize(maxpair + 1, maxpair + 1).ClearContents
alloweddiff = 1
Do
  i = i + 1
  If counter > (0.5 * upperlimit) Then 'try some systematic approach
    For x = 1 To maxpair - 1 ' top-left or:' To 1 Step -1 ' bottom-right
      For y = x + 1 To maxpair
        Call test_and_fill(x, y, counter)
      Next y
    Next x
    If counter > 0 Then
      alloweddiff = alloweddiff + 1
      counter = 0
    End If
  End If
  ' mostly used - random mode
  x = WorksheetFunction.RandBetween(1, maxpair - 1)
  y = WorksheetFunction.RandBetween(x + 1, maxpair)
  counter = counter + 1
  Call test_and_fill(x, y, counter)
  If counter = 0 Then alloweddiff = WorksheetFunction.Max(alloweddiff, 1)
  If i > (2.5 * upperlimit) Then Exit Do
Loop Until generalmin = upperlimit
Range("A1").Resize(maxpair + 1, maxpair + 1).Value = outtable
Range("A1").Value = generalmin
Application.StatusBar = ""
End Sub

Sub test_and_fill(x%, y%, ByRef counter%)
Dim temprowx%, temprowy%, tempcolx%, tempcoly%, tempmax%, j%
tempcolx = outtable(1, x + 1)
tempcoly = outtable(1, y + 1)
temprowx = outtable(x + 1, 1)
temprowy = outtable(y + 1, 1)
tempmax = 1+ WorksheetFunction.Max(tempcolx, tempcoly, temprowx, temprowy)
If tempmax <= (generalmin + alloweddiff) And tempmax <= upperlimit And outtable(y + 1, x + 1) = 0 Then
  counter = 0
  outtable(y + 1, x + 1) = 1
  outtable(x + 1, y + 1) = 1
  outtable(x + 1, 1) = 1 + outtable(x + 1, 1)
  outtable(y + 1, 1) = 1 + outtable(y + 1, 1)
  outtable(1, x + 1) = 1 + outtable(1, x + 1)
  outtable(1, y + 1) = 1 + outtable(1, y + 1)
  generalmax = WorksheetFunction.Max(generalmax, outtable(x + 1, 1), outtable(y + 1, 1), outtable(1, x + 1), outtable(1, y + 1))
  generalmin = outtable(x + 1, 1)
  For j = 1 To maxpair
    If outtable(j + 1, 1) < generalmin Then generalmin = outtable(j + 1, 1)
    If outtable(1, j + 1) < generalmin Then generalmin = outtable(1, j + 1)
  Next j
  If generalmax > oldgeneralmax Then
    oldgeneralmax = generalmax
    Application.StatusBar = "Working on pairs " & generalmax & "Total progress (non-linear): " & Format(1# * generalmax / upperlimit, "0%")
  End If
  alloweddiff = alloweddiff - 1
  i = 0
End If
End Sub

Answer 3

拥有一个数组appeared[]，可以跟踪每个项目已经出现在答案中的次数。假设每个元素必须出现k次。迭代数组，并且当前元素的appeared值小于k时，从该元素中选择一个随机对，它也出现少于k次。添加该对以回答并增加两者的外观计数。

Answer 4

创建一个二维100 * 100的布尔矩阵，全部为假
，将其中的1K设置为true，具有以下约束：
对角线应保持空白
任何行或列都不应超过20个真值
最后，每行和每列应该有20个True值。

现在，存在X = Y对角线对称性。只需添加以下约束：

对角线一侧的三角形应保持空白
在上述约束中，应该组合/添加对行和列的限制

随机唯一对

4 个答案: