1

我有一个包含 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
4

4 回答 4

1

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

该算法不是 100% 随机的（在对不成功的随机试验有点“厌倦”之后开始系统筛选表格 :) - 无论如何对我来说 - “足够随机”）但运行速度相当快，并返回所需的表格（不幸并非总是如此，但是...）通常每第二次或第三次使用一次（如果每个项目有您需要的配对数量，请查看 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
于 2015-02-17T14:50:21.700 回答
1

拿一个列表，打乱它，然后将每两个元素标记为一对。将这些对添加到对列表中。确保对列表进行排序。

打乱对的列表，并将每对添加到“分段”对列表中。检查它是否在对列表中。如果它在对列表中，请争夺并重新开始。如果您获得了没有任何重复的整个列表，请将暂存的配对列表添加到配对列表中并重新开始本段。

由于这涉及到最后一个不确定的步骤，我不确定它会有多慢，但它应该可以工作。

于 2013-02-14T22:21:02.587 回答
0

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

于 2013-02-14T22:20:35.533 回答
0
  • 创建一个二维 100*100 布尔矩阵，全部为 False
  • 在这 10K 个布尔值中，将其中的 1K 个设置为 true，并具有以下约束：
  • 对角线应该保持空白
  • 任何行或列都不应有超过 20 个真值
  • 最后，每一行和每一列都应该有 20 个 True 值。

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

  • 对角线一侧的三角形应保持空白
  • 在上述约束中，应合并/添加对行和列的限制
于 2013-02-14T22:55:36.317 回答