找回密码
 立即注册→加入我们

QQ登录

只需一步,快速开始

搜索
热搜: 下载 VB C 实现 编写
查看: 226|回复: 5

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

[复制链接]
发表于 2024-11-16 21:50:11 | 显示全部楼层 |阅读模式

欢迎访问技术宅的结界,请注册或者登录吧。

您需要 登录 才可以下载或查看,没有账号?立即注册→加入我们

×
本帖最后由 tlwh163 于 2024-11-18 20:08 编辑

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

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


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


''生成一组随机数序列,可以指定重复率  [ 参数: 待填充数组, 数据数量, 重复率% ]
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

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

Private Sub Command1_Click()
    Dim a As Long, b As Long: a = 2: b = 5000     '概率区间 [a, b]
    Dim c As Long: c = (b - a) + 1                '区间长度 c = (b - a) + 1
    Dim n As Long: n = 100                        '数据总量 n = 100
    Dim p As Long: p = 20                         '重复率   p = 20 (%)
    Dim w As Long: w = Fix((100# - p) / 100# * n) '不重复的数量
    If c < w Then MsgBox "概率区间不够" : Exit Sub
    Dim x() As Long, y() As Long
    ReDim x(0 To c - 1): If UBound(x) = -1 Then MsgBox "内存不足": Exit Sub
    ReDim y(0 To n - 1): If UBound(y) = -1 Then MsgBox "内存不足": Exit Sub
    ''------生成一组随机数序列,可以指定重复率----------
    Dim i As Long, k As Long:     Randomize
    For i = 0 To c - 1: x(i) = a + i: Next        '填充概率区间
    For i = c - 1 To 1 Step -1
        k = Fix(Rnd * i)                          '概率区间打乱顺序
        x(i) = x(i) Xor x(k): x(k) = x(i) Xor x(k): x(i) = x(i) Xor x(k)
    Next
    For i = 0 To w - 1: y(i) = x(i): Next         '填充不重复的部分
    For i = w To n - 1
        k = Fix(Rnd * w): y(i) = y(k)             '从不重复的部分随机取数,造成重复
    Next
    For i = n - 1 To 1 Step -1
        k = Fix(Rnd * i)                          '再1次打乱顺序
        y(i) = y(i) Xor y(k): y(k) = y(i) Xor y(k): y(i) = y(i) Xor y(k)
    Next
    ''-------验证重复率--------------------------------
    w = 0
    For i = 0 To n - 1
        If y(i) <> (a - 1) Then
            w = w + 1
            For k = i + 1 To n - 1
                If y(k) = y(i) Then y(k) = (a - 1)
            Next
        End If
    Next
    Debug.Print "不重复的数有 " & Str(w) & " 个",
    Debug.Print "重复率 = " & Str(Fix(CDbl(n - w) / n * 100#)) & "%"
End Sub


回复

使用道具 举报

发表于 2024-11-16 23:28:25 | 显示全部楼层
重复率的定义是什么
回复 赞! 靠!

使用道具 举报

 楼主| 发表于 2024-11-17 09:40:49 | 显示全部楼层
去掉所有出现的数值1次  剩下的就是重复项

重复率 = 重复项 / 总数量

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

使用道具 举报

发表于 2024-11-17 14:26:21 | 显示全部楼层
如果重复率不是精确值可以这样,如果重复率必须准确没啥简单办法
  1. Option Explicit

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

  23. Next


  24. End Sub
复制代码
回复 赞! 靠!

使用道具 举报

 楼主| 发表于 2024-11-17 21:39:30 | 显示全部楼层
不知道能不能看到图片

似乎重复率不是很稳定啊
1.png
回复 赞! 靠!

使用道具 举报

发表于 2024-11-17 22:22:30 | 显示全部楼层
增加稳定性可以通过统计 p0 < 0 的次数更加精准些当次数 大于 n * prnd *  p / 100 就不在插入重复值,不过这样样本的重复数就不均匀了
回复 赞! 靠!

使用道具 举报

本版积分规则

QQ|Archiver|小黑屋|技术宅的结界 ( 滇ICP备16008837号 )|网站地图

GMT+8, 2024-12-12 10:23 , Processed in 0.033357 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表