Какой генератор случайных чисел использует Excel VBA? - PullRequest
Новая
       56

Какой генератор случайных чисел использует Excel VBA?

7 голосов
/ 17 апреля 2020

Вопрос в названии - я пытался установить sh, какой генератор случайных чисел использует VBA, т. Е. В Randomize и Rnd? Согласно документации Microsoft, в Excel используется Mersenne Twister - что, по-видимому, очень хорошо, но вы не можете затравить. Кажется, я не могу найти ответ для VBA в документации Microsoft.

Я использую Excel 365 для этого, так как я понимаю, что это то, что может измениться от версии к версии.

1 Ответ

7 голосов
/ 22 апреля 2020

Единственная часть информации, которую я мог получить о текущем (то есть, Excel 365) генераторе случайных чисел, используемом Excel VBA, - это Visual Basi c для приложений / A PRNG для VBA (вики-книга) В котором говорится "Visual Basic от Microsoft c для приложений (VBA), в настоящее время использует линейный конгруэнтный генератор (LCG) для генерации псевдослучайных чисел в функции Rnd ()" и внизу "Эта страница последний раз редактировалась на 16 апреля 2020 года, в 06:55. " Одно это ответило бы на ваш вопрос.

Но так как это не обязательно авторитетный источник, вам придется проверить это. Является ли Excel VBA Rnd () действительно плохим? показывает пример того, как это сделать.

В качестве альтернативы, this показывает базовый c алгоритм для Rnd: 

x1 = ( x0 * a + c ) MOD m
Rnd() = x1/m

в Excel, где: 

Rnd() = returned value
m = modulus = (2^24)
x1 = new value
x0 = previous value (initial value 327680)
a = 1140671485
c = 12820163
Repeat length = m = (2^24) = 16,777,216

Вы можете реализовать его и сравнить полученные результаты с результатами Rnd и проверить его достоверность.

Примечание: вы правы в том, что это изменилось в разных версиях. См., Например, Насколько хороша функция RAND () в Excel для моделирования по методу Монте-Карло? В частности, обновление за 2007 год ( О точности статистических процедур в Microsoft Excel 2007 ) и 2010 ( О точности статистических процедур в Microsoft Excel 2010 ). Возможно, на данный момент есть ниша для еще одной статьи.

Что касается альтернативных генераторов, то, если вам не нравится то, что встроено, их там немало. Краткий список (некоторые опубликованы в комментариях) приведен здесь, код приведен ниже для ясности:

  1. Mersenne Twister в BASI C

  2. Код VBA - Wichmann-Hill (1982)

  3. Действительно ли Rnd () Excel VBA настолько плох? (ответы там)

  4. Алгоритм генератора случайных чисел Мерсена Твистера

Код из ссылок выше
  1. Реализация Кармин Артуро Сангиованни в Mersenne-Twister 
' Visual Basic Mersenne-Twister
' Author: Carmine Arturo Sangiovanni
'         carmine @ daygo.com.br
'     daygo_gaming @ hotmail.com
'
'         Aug 13,2004
'
'         based on C++ code
'
'
'   Jan 4, 2010
'   rev1
'   bug fixes sent by Takano Akio (aljee @ hiper.cx)
'   look for 'rev1:' to see changes

Option Explicit

Const N = 624
Const M = 397

Global mt(0 To N) As Currency
Global mti As Currency

Dim MATRIX_A As Currency
Dim UPPER_MASK As Currency
Dim LOWER_MASK As Currency
Dim FULL_MASK As Currency
Dim TEMPERING_MASK_B As Currency
Dim TEMPERING_MASK_C As Currency

Function tempering_shift_u(ty As Currency)
    tempering_shift_u = f_and(Int(ty / 2048@), FULL_MASK)
End Function

Function tempering_shift_s(ty As Currency)
    tempering_shift_s = and_ffffffff(ty * 128@)
End Function

Function tempering_shift_t(ty As Currency)
    tempering_shift_t = and_ffffffff(ty * 32768@)
End Function

Function tempering_shift_l(ty As Currency)
    tempering_shift_l = f_and(Int(ty / 262144@), FULL_MASK)
End Function

Function f_and(p1 As Currency, p2 As Currency)
    Dim v As Currency
    Dim i As Integer

    If (p1 < UPPER_MASK) And (p2 < UPPER_MASK) Then
        f_and = p1 And p2
    End If

    If (p1 < UPPER_MASK) And (p2 >= UPPER_MASK) Then
        f_and = p1 And (p2 - UPPER_MASK)
    End If

    If (p1 >= UPPER_MASK) And (p2 < UPPER_MASK) Then
        f_and = (p1 - UPPER_MASK) And p2
    End If

    If (p1 >= UPPER_MASK) And (p2 >= UPPER_MASK) Then
        f_and = (p1 - UPPER_MASK) And (p2 - UPPER_MASK)
        f_and = f_and + UPPER_MASK
    End If
End Function

Function f_or(p1 As Currency, p2 As Currency)
    Dim v As Currency
    Dim i As Integer
    Dim f As Boolean

    If (p1 < UPPER_MASK) And (p2 < UPPER_MASK) Then
        f_or = p1 Or p2
    End If
    If (p1 < UPPER_MASK) And (p2 >= UPPER_MASK) Then
        f_or = p1 Or (p2 - UPPER_MASK)
        f_or = f_or + UPPER_MASK
    End If
    If (p1 >= UPPER_MASK) And (p2 < UPPER_MASK) Then
        f_or = (p1 - UPPER_MASK) Or p2          'rev1: replaced 'And' with 'Or'
        f_or = f_or + UPPER_MASK
    End If
    If (p1 >= UPPER_MASK) And (p2 >= UPPER_MASK) Then
        f_or = (p1 - UPPER_MASK) Or (p2 - UPPER_MASK)   'rev1: replaced 'And' with 'Or'
        f_or = f_or + UPPER_MASK
    End If
End Function

Function f_xor(p1 As Currency, p2 As Currency)
    Dim v As Currency
    Dim i As Integer
    Dim f1 As Boolean, f2 As Boolean

    If (p1 < UPPER_MASK) And (p2 < UPPER_MASK) Then
        f_xor = p1 Xor p2
    End If
    If (p1 < UPPER_MASK) And (p2 >= UPPER_MASK) Then
        f_xor = p1 Xor (p2 - UPPER_MASK)
        f_xor = f_xor + UPPER_MASK
    End If
    If (p1 >= UPPER_MASK) And (p2 < UPPER_MASK) Then
        f_xor = (p1 - UPPER_MASK) Xor p2
        f_xor = f_xor + UPPER_MASK
    End If
    If (p1 >= UPPER_MASK) And (p2 >= UPPER_MASK) Then
        f_xor = (p1 - UPPER_MASK) Xor (p2 - UPPER_MASK)
    End If
End Function

Function f_lower(ByVal p1 As Currency)          'rev1: added ByBal
    Do
        If p1 < UPPER_MASK Then
            f_lower = p1
            Exit Do
        Else
            p1 = p1 - UPPER_MASK
        End If
    Loop
End Function

Function f_upper(ByVal p1 As Currency)          'rev1: added ByVal
    If p1 > LOWER_MASK Then
        f_upper = UPPER_MASK
    Else
        f_upper = 0
    End If
End Function

Function f_xor3(p1 As Currency, p2 As Currency, p3 As Currency)
    Dim v As Currency
    Dim tmp As Currency
    Dim i As Integer
    Dim f As Integer


    If (p1 < UPPER_MASK) And (p2 < UPPER_MASK) Then
        tmp = p1 Xor p2
    End If
    If (p1 < UPPER_MASK) And (p2 >= UPPER_MASK) Then
        tmp = p1 Xor (p2 - UPPER_MASK)
        tmp = tmp + UPPER_MASK
    End If
    If (p1 >= UPPER_MASK) And (p2 < UPPER_MASK) Then
        tmp = (p1 - UPPER_MASK) Xor p2
        tmp = tmp + UPPER_MASK
    End If
    If (p1 >= UPPER_MASK) And (p2 >= UPPER_MASK) Then
        tmp = (p1 - UPPER_MASK) Xor (p2 - UPPER_MASK)
    End If

    If (tmp < UPPER_MASK) And (p3 < UPPER_MASK) Then
        f_xor3 = tmp Xor p3
    End If
    If (tmp < UPPER_MASK) And (p3 >= UPPER_MASK) Then
        f_xor3 = tmp Xor (p3 - UPPER_MASK)
        f_xor3 = f_xor3 + UPPER_MASK
    End If
    If (tmp >= UPPER_MASK) And (p3 < UPPER_MASK) Then
        f_xor3 = (tmp - UPPER_MASK) Xor p3
        f_xor3 = f_xor3 + UPPER_MASK
    End If
    If (tmp >= UPPER_MASK) And (p3 >= UPPER_MASK) Then
        f_xor3 = (tmp - UPPER_MASK) Xor (p3 - UPPER_MASK)
    End If
End Function

Function and_ffffffff(ByVal c As Currency)      'rev1: added ByVal
    Dim e As Currency
    Dim i As Integer

    i = 32
    Do
        e = 2 ^ (i + 16)
        Do While c >= e
            c = c - e
        Loop
        i = i - 1
    Loop While i > 15
    and_ffffffff = c
End Function

Sub random_init(seed As Currency)
    mt(0) = and_ffffffff(seed)
    For mti = 1 To N - 1
        mt(mti) = and_ffffffff(69069 * mt(mti - 1))
    Next mti
End Sub

Function Mersenne_twister_random(max As Integer)

    Dim kk As Integer

    Dim ty1 As Currency
    Dim ty2 As Currency
    Dim y As Currency

    Dim mag01(0 To 1) As Currency

    MATRIX_A = 2567483615@              '&H9908b0df
    UPPER_MASK = 2147483648@            '&H80000000
    LOWER_MASK = 2147483647@            '&H7fffffff
    FULL_MASK = LOWER_MASK + UPPER_MASK '&Hffffffff
    TEMPERING_MASK_B = 2636928640@      '&H9d2c5680
    TEMPERING_MASK_C = 4022730752@      '&Hefc60000

    mag01(0) = 0@
    mag01(1) = MATRIX_A

    If mti >= N Then
        If mti = N + 1 Then
            random_init 4537
        End If

        For kk = 0 To (N - M) - 1
            y = f_or(f_upper(mt(kk)), f_lower(mt(kk + 1)))
            mt(kk) = f_xor3(mt(kk + M), Int(y / 2@), mag01(f_and(y, 1)))
        Next kk

        For kk = kk To (N - 1) - 1
            y = f_or(f_upper(mt(kk)), f_lower(mt(kk + 1)))
            mt(kk) = f_xor3(mt(kk + (M - N)), Int(y / 2@), mag01(f_and(y, 1)))
        Next kk

        y = f_or(f_upper(mt(N - 1)), f_lower(mt(0)))
        mt(N - 1) = f_xor3(mt(M - 1), Int(y / 2@), mag01(f_and(y, 1)))
        mti = 0
    End If

    '---------------------------------------------------
    y = mt(mti): mti = mti + 1

    '---------------------------------------------------
    y = f_xor(y, tempering_shift_u(y))

    ty1 = f_and(tempering_shift_s(y), TEMPERING_MASK_B)
    y = f_xor(y, ty1)

    ty1 = f_and(tempering_shift_t(y), TEMPERING_MASK_C)
    y = f_xor(y, ty1)

    y = f_xor(y, tempering_shift_l(y))

    '---------------------------------------------------
    If max = 0 Then
        Mersenne_twister_random = 0
    Else
        Mersenne_twister_random = Int(y / 32) Mod max
    End If
End Function
Код здесь должен быть сохранен как отдельный стандартный модуль в Excel. 
Option Explicit
Dim nSamples As Long
Dim nX As Long, nY As Long, nZ As Long

Sub TestRndX()
    'run this to obtain RndX() samples
    'Wichmann, Brian; Hill, David (1982), Algorithm AS183:
    'An Efficient and Portable Pseudo-Random Number Generator,
    'Journal of the Royal Statistical Society. Series C
    Dim n As Long

    'reset module variables
    nX = 0: nY = 0: nZ = 0

    RandomizeX
    For n = 1 To 10
        Debug.Print RndX()
        MsgBox RndX()
    Next n

    'reset module variables
    nX = 0: nY = 0: nZ = 0

End Sub

Sub TestScatterChartOfPRNG()
    'run this to make a point scatter chart
    'using samples from RndX

    Dim vA As Variant, n As Long
    Dim nS As Long, nR As Double

    'remove any other charts
    'DeleteAllCharts

    'reset module variables
    nX = 0: nY = 0: nZ = 0

    'set number of samples here
    nSamples = 1000
    ReDim vA(1 To 2, 1 To nSamples) 'dimension array

    'load array with PRNG samples
    RandomizeX
    For n = 1 To nSamples
        nR = RndX()
        vA(1, n) = n  'x axis data - sample numbers
        vA(2, n) = nR 'y axis data - prng values
    Next n

    'make scatter point chart from array
    ChartScatterPoints vA, 1, 2, nSamples & " Samples of RndX()", _
                "Sample Numbers", "PRNG Values [0,1]"

    'reset module work variables
    nX = 0: nY = 0: nZ = 0

End Sub

Sub RandomizeX(Optional ByVal nSeed As Variant)
   'sets variables for PRNG procedure RndX()

   Const MaxLong As Double = 2 ^ 31 - 1
   Dim nS As Long
   Dim nN As Double

   'make multiplier
   If IsMissing(nSeed) Then
      nS = Timer * 60
   Else
      nN = Abs(Int(Val(nSeed)))
      If nN > MaxLong Then 'no overflow
         nN = nN - Int(nN / MaxLong) * MaxLong
      End If
      nS = nN
   End If

   'update variables
   nX = (nS Mod 30269)
   nY = (nS Mod 30307)
   nZ = (nS Mod 30323)

   'avoid zero state
   If nX = 0 Then nX = 171
   If nY = 0 Then nY = 172
   If nZ = 0 Then nZ = 170

End Sub

Function RndX(Optional ByVal nSeed As Long = 1) As Double
   'PRNG - gets pseudo random number - use with RandomizeX
   'Wichmann-Hill algorithm of 1982

   Dim nResult As Double

   'initialize variables
   If nX = 0 Then
      nX = 171
      nY = 172
      nZ = 170
   End If

   'first update variables
   If nSeed <> 0 Then
      If nSeed < 0 Then RandomizeX (nSeed)
      nX = (171 * nX) Mod 30269
      nY = (172 * nY) Mod 30307
      nZ = (170 * nZ) Mod 30323
   End If

   'use variables to calculate output
   nResult = nX / 30269# + nY / 30307# + nZ / 30323#
   RndX = nResult - Int(nResult)

End Function

Sub ChartScatterPoints(ByVal vA As Variant, RowX As Long, RowY As Long, _
                     Optional sTitle As String = "", Optional sXAxis As String, _
                     Optional sYAxis As String)

    'array input must contain two data rows for x and y data
    'parameters for user title, x axis and y axis labels
    'makes a simple point scatter chart

    Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long, n As Long, bOptLim As Boolean
    Dim X As Variant, Y As Variant, sX As String, sY As String, sT As String, oC As Chart

    LBR = LBound(vA, 1): UBR = UBound(vA, 1)
    LBC = LBound(vA, 2): UBC = UBound(vA, 2)
    ReDim X(LBC To UBC)
    ReDim Y(LBC To UBC)

    'labels for specific charts
    If sTitle = "" Then sT = "Title Goes Here" Else sT = sTitle
    If sXAxis = "" Then sX = "X Axis Label Goes Here" Else sX = sXAxis
    If sYAxis = "" Then sY = "Y Axis Label Goes Here" Else sY = sYAxis

    If RowX < LBR Or RowX > UBR Or RowY < LBC Or RowY > UBC Then
        MsgBox "Parameter data rows out of range in ChartColumns - closing"
        Exit Sub
    End If

    'transfer data to chart arrays
    For n = LBC To UBC
        X(n) = vA(RowX, n) 'x axis data
        Y(n) = vA(RowY, n) 'y axis data
    Next n

    'make chart
    Charts.Add

    'set chart type
    ActiveChart.ChartType = xlXYScatter 'point scatter chart

    'remove unwanted series
    With ActiveChart
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
    End With


    'assign the data and labels to a series
    With ActiveChart.SeriesCollection
        If .Count = 0 Then .NewSeries
            If Val(Application.Version) >= 12 Then
                .Item(1).Values = Y
                .Item(1).XValues = X
            Else
                .Item(1).Select
                Names.Add "_", X
                ExecuteExcel4Macro "series.x(!_)"
                Names.Add "_", Y
                ExecuteExcel4Macro "series.y(,!_)"
                Names("_").Delete
            End If
    End With

    'apply title string, x and y axis strings, and delete legend
    With ActiveChart
        .HasTitle = True
        .ChartTitle.Text = sT
        .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
        .Axes(xlCategory).AxisTitle.Text = sX
        .SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
        .Axes(xlValue).AxisTitle.Text = sY
        .Legend.Delete
    End With

    'trim axes to suit
    With ActiveChart
    'X Axis
        .Axes(xlCategory).Select
        .Axes(xlCategory).MinimumScale = 0
        .Axes(xlCategory).MaximumScale = nSamples
        .Axes(xlCategory).MajorUnit = 500
        .Axes(xlCategory).MinorUnit = 100
        Selection.TickLabelPosition = xlLow

    'Y Axis
        .Axes(xlValue).Select
        .Axes(xlValue).MinimumScale = -0.2
        .Axes(xlValue).MaximumScale = 1.2
        .Axes(xlValue).MajorUnit = 0.1
        .Axes(xlValue).MinorUnit = 0.05
    End With


    ActiveChart.ChartArea.Select

    Set oC = Nothing

End Sub

Sub DeleteAllCharts5()
    'run this to delete all ThisWorkbook charts

    Dim oC

    Application.DisplayAlerts = False

    For Each oC In ThisWorkbook.Charts
        oC.Delete
    Next oC

    Application.DisplayAlerts = True

End Sub

Это ссылка SO.

Это рабочая книга для скачивания.

...