生成有重复率的随机数序列

tlwh163

=====================================================================

***** 这一段不要了 换用后面的代码 *****


想不出什么更好的办法 先丢出来 帮忙看看怎么搞


''生成一组随机数序列,可以指定重复率  [ 参数: 待填充数组, 数据数量, 重复率% ]
Sub RanSequence(Result() As Long, ByVal ItemCount As Long, Optional ByVal Repetition As Byte = 0)
    If ItemCount < 2 Or Repetition > 100 Then Exit Sub
    ReDim Result(0 To ItemCount - 1): If UBound(Result) < 0 Then Exit Sub
    Dim i As Long, k As Long
    k = Fix(((100# - Repetition) / 100#) * ItemCount) '不重复的数量
    For i = 0 To k - 1: Result(i) = i: Next           '不重复的原始数据
    For i = k To ItemCount - 1        '附加重复的原始数据(如果有重复率)
        Result(i) = Fix(k * Rnd)
    Next
    Randomize                         '把数组打乱顺序
    For i = ItemCount - 1 To 1 Step -1
        k = Fix(i * Rnd)
        Result(i) = Result(i) Xor Result(k)
        Result(k) = Result(i) Xor Result(k)
        Result(i) = Result(i) Xor Result(k)
    Next
End Sub

=================================================================================================================

1. Private Sub Command1_Click()
   
2.     Dim a As Long, b As Long: a = 2: b = 5000     '概率区间 [a, b]
   
3.     Dim c As Long: c = (b - a) + 1                '区间长度 c = (b - a) + 1
   
4.     Dim n As Long: n = 100                        '数据总量 n = 100
   
5.     Dim p As Long: p = 20                         '重复率   p = 20 (%)
   
6.     Dim w As Long: w = Fix((100# - p) / 100# * n) '不重复的数量
   
7.     If c < w Then MsgBox "概率区间不够" : Exit Sub
   
8.     Dim x() As Long, y() As Long
   
9.     ReDim x(0 To c - 1): If UBound(x) = -1 Then MsgBox "内存不足": Exit Sub
   
10.     ReDim y(0 To n - 1): If UBound(y) = -1 Then MsgBox "内存不足": Exit Sub
    
11.     ''------生成一组随机数序列,可以指定重复率----------
    
12.     Dim i As Long, k As Long:     Randomize
    
13.     For i = 0 To c - 1: x(i) = a + i: Next        '填充概率区间
    
14.     For i = c - 1 To 1 Step -1
    
15.         k = Fix(Rnd * i)                          '概率区间打乱顺序
    
16.         x(i) = x(i) Xor x(k): x(k) = x(i) Xor x(k): x(i) = x(i) Xor x(k)
    
17.     Next
    
18.     For i = 0 To w - 1: y(i) = x(i): Next         '填充不重复的部分
    
19.     For i = w To n - 1
    
20.         k = Fix(Rnd * w): y(i) = y(k)             '从不重复的部分随机取数,造成重复
    
21.     Next
    
22.     For i = n - 1 To 1 Step -1
    
23.         k = Fix(Rnd * i)                          '再1次打乱顺序
    
24.         y(i) = y(i) Xor y(k): y(k) = y(i) Xor y(k): y(i) = y(i) Xor y(k)
    
25.     Next
    
26.     ''-------验证重复率--------------------------------
    
27.     w = 0
    
28.     For i = 0 To n - 1
    
29.         If y(i) <> (a - 1) Then
    
30.             w = w + 1
    
31.             For k = i + 1 To n - 1
    
32.                 If y(k) = y(i) Then y(k) = (a - 1)
    
33.             Next
    
34.         End If
    
35.     Next
    
36.     Debug.Print "不重复的数有 " & Str(w) & " 个",
    
37.     Debug.Print "重复率 = " & Str(Fix(CDbl(n - w) / n * 100#)) & "%"
    
38. End Sub

复制代码

AyalaRs

重复率的定义是什么

tlwh163

去掉所有出现的数值1次  剩下的就是重复项

重复率 = 重复项 / 总数量

比如:  0 1 2 3 4 5 (2) 6 7 (3) -> 重复率 20%

AyalaRs

如果重复率不是精确值可以这样，如果重复率必须准确没啥简单办法

1. Option Explicit
   
2. 
   
3. Private Sub Command1_Click()
   
4. Dim a, b, c, n '概率区间a b ,差值c,总量n
   
5. Dim p, p0, prnd '重复概率p 取样p0,随机数本身非重复率prnd
   
6. Dim i
   
7. Dim d()
   
8. a = 2
   
9. b = 5000
   
10. n = 100
    
11. p = 6
    
12. prnd = 0.92
    
13. c = b - a
    
14. ReDim d(n)
    
15. Randomize
    
16. For i = 0 To n - 1
    
17.    p0 = Rnd() * 100 - prnd * p
    
18.    If p0 > 0 Then
    
19.        d(i) = a + Fix(c * Rnd())
    
20.    Else
    
21.        d(i) = d(Fix(i * Rnd()))
    
22.    End If
    
23.    Debug.Print d(i)
    
24. 
    
25. Next
    
26. 
    
27. 
    
28. End Sub
    

复制代码

tlwh163

不知道能不能看到图片

似乎重复率不是很稳定啊

AyalaRs

增加稳定性可以通过统计 p0 < 0 的次数更加精准些当次数 大于 n * prnd *  p / 100 就不在插入重复值，不过这样样本的重复数就不均匀了