I need a pseudo random number generator for 2D Monte Carlo simulation that doesn't have the characteristic hyperplanes that you get with simple LCGs. I tested the random number generator Rnd() in Excel 2013 using the following code (takes about 5 secs to run):
Sub ZoomRNG()
Randomize
For i = 1 To 1000
Found = False
Do
x = Rnd() ' 2 random numbers between 0.0 and 1.0
y = Rnd()
If ((x > 0.5) And (x < 0.51)) Then
If ((y > 0.5) And (y < 0.51)) Then
' Write if both x & y in a narrow range
Cells(i, 1) = i
Cells(i, 2) = x
Cells(i, 3) = y
Found = True
End If
End If
Loop While (Not Found)
Next i
End Sub
Here is a simple plot of x vs y from running the above code
Not only is it not very random-looking, it has more obvious hyperplanes than the infamous RANDU algorithm does in 2D. Basically, am I using the function incorrectly or is the Rnd() function in VBA actually not the least bit usable?
For comparison, here's what I get for the Mersenne Twister MT19937 in C++.
To yield a better random generator and to make its performance faster, I modified your code like this:
Const N = 1000 'Put this on top of your code module
Sub ZoomRNG()
Dim RandXY(1 To N, 1 To 3) As Single, i As Single, x As Single, y As Single
For i = 1 To N
Randomize 'Put this in the loop to generate a better random numbers
Do
x = Rnd
y = Rnd
If x > 0.5 And x < 0.51 Then
If y > 0.5 And y < 0.51 Then
RandXY(i, 1) = i
RandXY(i, 2) = x
RandXY(i, 3) = y
Exit Do
End If
End If
Loop
Next
Cells(1, 9).Resize(N, 3) = RandXY
End Sub
I obtain this after plotting the result
The result looks better than your code's output. Modifying the above code a little bit to something like this
Const N = 1000
Sub ZoomRNG()
Dim RandXY(1 To N, 1 To 3) As Single, i As Single, x As Single, y As Single
For i = 1 To N
Randomize
Do
x = Rnd
If x > 0.5 And x < 0.51 Then
y = Rnd
If y > 0.5 And y < 0.51 Then
RandXY(i, 1) = i
RandXY(i, 2) = x
RandXY(i, 3) = y
Exit Do
End If
End If
Loop
Next
Cells(1, 9).Resize(N, 3) = RandXY
End Sub
yields a better result than the previous one
Sure the Mersenne Twister MT19937 in C++ is still better, but the last result is quite good for conducting Monte-Carlo simulations. FWIW, you might be interested in reading this paper: On the accuracy of statistical procedures in Microsoft Excel 2010.
That seems like it would take on average 1000 * 100 * 100 iterations to complete and VBA is usually a bit slower than native Excel formulas. Consider this example
Sub ZoomRNG()
t = Timer
[a1:a1000] = "=ROW()"
[b1:c1000] = "=RAND()/100+0.5"
[a1:c1000] = [A1:C1000].Value
Debug.Print CDbl(Timer - t) ' 0.0546875 seconds
End Sub
Update
It's not that bad at all! This will work too even without Randomize
Sub ZoomRNGs() ' VBA.Rnd returns Single
t = Timer
For i = 1 To 1000
Cells(i, 1) = i
Cells(i, 2) = Rnd / 100 + 0.5
Cells(i, 3) = Rnd / 100 + 0.5
Next i
Debug.Print Timer - t ' 0.25 seconds
End Sub
Sub ZoomRNGd() ' the Excel Function RAND() returns Double
t = Timer
For i = 1 To 1000
Cells(i, 1) = i
Cells(i, 2) = [RAND()] / 100 + 0.5
Cells(i, 3) = [RAND()] / 100 + 0.5
Next i
Debug.Print Timer - t ' 0.625 seconds
End Sub
and Single has about half of the precision of Double :
s = Rnd: d = [RAND()]
Debug.Print s; d; Len(Str(s)); Len(Str(d)) ' " 0.2895625 0.580839555868045 9 17 "
Update 2
I found C alternative that is as fast as VBA Rnd.
C:\Windows\System32\msvcrt.dll is the Microsoft C Runtime Library:
Declare Function rand Lib "msvcrt" () As Long ' this in a VBA module
and then you can use it like this x = rand / 32767 in your code:
Sub ZoomRNG()
t = Timer
Dim i%, x#, y#, Found As Boolean
For i = 1 To 1000
Found = False
Do
x = rand / 32767 ' RAND_MAX = 32,767
y = rand / 32767
If ((x > 0.5) And (x < 0.51)) Then
If ((y > 0.5) And (y < 0.51)) Then
' Write if both x & y in a narrow range
Cells(i, 1) = i
Cells(i, 2) = x
Cells(i, 3) = y
Found = True
End If
End If
Loop While (Not Found)
Next i
Debug.Print Timer - t ' 2.875 seconds
End Sub
After reading this question I got curious and found the paper
"Assessing Excel VBA Suitability for Monte Carlo Simulation" by Alexei Botchkarev that is available here. Both RAND and RND functions are not recommended, but as pointed out in the paper the Mersenne Twister has been implemented in VBA by Jerry Wang.
A quick search led me to this nicely commented Version that has been updated the last 2015/2/28: http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/VERSIONS/BASIC/MTwister.xlsb
Source: http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/VERSIONS/BASIC/basic.html
All LCGs will generate hyperplanes. The quality of the LCG increases with decreasing distance between these hyperplanes. So, having more hyperplanes than RANDU is a good thing.
The MT plot looks much better because it is NOT an LCG. Indeed, any non-LCG pRNG could have a random looking plot and still be a bad.
To avoid the problem of 2D correlations, you could use the same LCG for x and y but have different seeds for x and y. Of course, this will not work with RND because you cannot have two separate streams. You will need an LCG pRNG that takes the seed as an argument by reference.
As a balance between speed and goodness, I was thinking of combining them like
for...
z = [rand()] ' good but slow.
for .. ' just a few
t = z + rnd()
t = t - int(t)
...
Remember that good entropy + bad entropy = better entropy.
That said, only 0.05ms per [rand()].
Related
I am trying to create an automated Goal Seek script for a interlinked cells and workbook. However, perhaps due to the complexity and number of interlinks, somehow under a certain condition the Goal Seek function converges at a very high or low x-value.
Is there a way to improve its accuracy by setting some kind of boundary (a < x < b) similar to that in Solver. The reason I don't want to add solver in VBA is that because some of the other users may not be activating their Solver add-ins.
This is what the Goal Seek value gives me for an initial guess of x =
0.5h = 500
This is what the X-value should be, with a random guess of x = 100
Another alternative that I could think about is to create some sort of manual iteration (e.g. Bisection method) Sub Routine, but again, the equations are pretty complex so this may not be ideal.
What I am doing at the moment is that to preset an initial value for the x if y (another parameter) is negative or positive. I reckon this has eliminated most of the invalid result, but it still gives an error on one or two occasion. Appreciate your input. Thanks.
Sub Guess()
' ------------- For Guessing Initial X-Value -----------
Dim i As Integer, j As Integer
For i = 4 To 11
For j = 18 To 25
If Worksheets("Crack Width").Range("I" & j) < 0 Then
'------------------------Pre-guess X_value to be 0.5X_bal if N<0-------------
Worksheets("Calcs").Range("B" & i) = Worksheets("Calcs").Range("C" & i).Value * 0.5
If Worksheets("Calcs").Range("B" & i) = 0 Then Worksheets("Calcs").Range("B" & i).ClearContent
i = i + 1
ElseIf Worksheets("Crack Width").Range("I" & j) >= 0 Then
'------------------------Pre-guess X_value to be 0.5h if N>0-------------
Worksheets("Calcs").Range("B" & i) = Worksheets("Calcs").Range("E" & i).Value * 0.5
If Worksheets("Calcs").Range("B" & i) = 0 Then Worksheets("Calcs").Range("B" & i).ClearContents
i = i + 1
End If
Next j
Next i
End Sub
I am running a Do Until loop that is lowering the value in target cells, starting at .99, (x=.99) and then using those values to complete a calculation. I need this loop to stop if 1 of 2 conditions is met.
Calculated value is within 10% of the target.
OR
x = .75
If the calculation doesn't match the target, the loop will lower x by .005 and try again. But I want .75 to be the lower limit of x.
Do Until
(Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Range("J23").Value * -1 >= Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Range("U28").Value * 0.9 And Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Range("J23").Value * -1 <= Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Range("U28").Value * 1.1) Or (x = 0.75)
Deal_ID = VBA.Right(Workbooks("Weekly Option Update (Master).xlsm").Sheets("GDD Group").Cells(i, "G").Value, 7)
Sheets("Correlation").Range("E7").Value = x
Workbooks("Group 4 Correlation Solver").Sheets("Correlation").Range("F8").Value = x
Workbooks("Group 4 Correlation Solver").Sheets("Correlation").Range("C9").Value = x
Workbooks("Group 4 Correlation Solver").Sheets("Correlation").Range("D10").Value = x
Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Calculate
x = x - 0.005
Workbooks("Weekly Option Update (Master).xlsm").Sheets("GDD Group").Cells(i, "H") = x + 0.005
Loop
My code might not be the most efficient but it does currently run. The issue is that it is not looking at the 2nd condition of the lower limit of x. It simply keeps going until the calculated value is within 10% of the target.
I apologize in advance for the code format. The block right beneath "Do Until" is the code in question with the "and" and "or".
Boy that's a mouthful! Extract local variables, there's no need to repeatedly dereference the same objects over and over and over every time!
Local variables make things much easier to debug, too.
Dim solverBook As Workbook
Set solverBook = Application.Workbooks("Group 4 Correlation Solver")
Dim weeklyOptionBook As Workbook
Set weeklyOptionBook = Application.Workbooks("Weekly Option Update (Master).xlsm")
Dim gddGroupSheet As Worksheet
Set gddGroupSheet = weeklyOptionBook.Worksheets("GDD Group")
Dim structureSheet As Worksheet
Set structureSheet = solverBook.Worksheets("STRUCTURETOOL")
Dim currentValue As Double
currentValue = structureSheet.Range("J23").Value ' CAUTION: possible type mismatch here
Dim targetValue As Double
targetValue = structureSheet.Range("U28").Value ' CAUTION: possible type mismatch here
Const threshold As Double = 0.1
Const limit As Double = 0.75
Dim correlationSheet As Worksheet
Set correlationSheet = solverBook.Worksheets("Correlation")
Do Until (currentValue * -1 >= targetValue * (1 - threshold) _
And currentValue * -1 <= targetValue * (1 + threshold)) _
Or x <= limit
Deal_Id = Right$(gddGroupSheet.Cells(i, "G").Value, 7)
correlationSheet.Range("E7,F8,C9,D10").Value = x
structureSheet.Calculate
gddGroupSheet.Cells(i, "H") = x
x = x - 0.005
currentValue = structureSheet.Range("J23").Value ' CAUTION: possible type mismatch here
targetValue = structureSheet.Range("U28").Value ' CAUTION: possible type mismatch here
Loop
Don't use = when dealing with floating points. Or x <= limit is probably the solution to your immediate problem.
I would just use an If to test the second condition:
x = 1
Do Until x = 0.75
if Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Range("J23").Value * -1 >= Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Range("U28").Value * 0.9 And Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Range("J23").Value * -1 <= Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Range("U28").Value * 1.1 then exit do
Deal_ID = VBA.Right(Workbooks("Weekly Option Update (Master).xlsm").Sheets("GDD Group").Cells(i, "G").Value, 7)
Sheets("Correlation").Range("E7").Value = x
Workbooks("Group 4 Correlation Solver").Sheets("Correlation").Range("F8").Value = x
Workbooks("Group 4 Correlation Solver").Sheets("Correlation").Range("C9").Value = x
Workbooks("Group 4 Correlation Solver").Sheets("Correlation").Range("D10").Value = x
Workbooks("Group 4 Correlation Solver").Sheets("STRUCTURETOOL").Calculate
x = x - 0.005
Workbooks("Weekly Option Update (Master).xlsm").Sheets("GDD Group").Cells(i, "H") = x + 0.005
Loop
I am trying to generate random colors (2,6) using the following code below; however, my end goal is to generate white color (2) more than the rest of the colors. Would appreciate if someone could help. Thank you.
GenerateColor = Int(Rnd() * 5) + 2
It is a probably a good idea to separate the randomization logic and the logic, which forces a given color to be created more often. E.g., this one works quite ok, giving equal chances to each number:
randomColor = CLng(rnd() * 5) + 2
However, once you obtain the randomColor, it could be changed based on some percentage, named priorityPercentage in the function:
Public Sub TestMe()
Dim counter As Long
Dim randomColor As Long
With Worksheets(1)
.Cells.Clear
For counter = 1 To 1000000
randomColor = CLng(rnd() * 5) + 2
.Cells(counter, 1) = GenerateColor(randomColor, 2, (0.4 - 0.4 * 1 / 6))
Next
.Cells(1, 2).Formula = "=COUNTIF(A:A,2)"
End With
End Sub
Public Function GenerateColor(randomColor As Long, _
priorityColor As Long, _
priorityPercentage As Double) As Long
If rnd() <= priorityPercentage Then
GenerateColor = priorityColor
Exit Function
End If
GenerateColor = CLng(rnd() * 5) + 2
End Function
This example runs 1 million times and it writes in B2 the count of the 2. The reason to pass 0.4 - 0.4 * 1.6 in the parameter, is to make sure, that the chance for 2 is exactly 40%. We have 1/6 for each of the possible 6 numbers - [2,3,4,5,6,7]. Thus, the times when we do not enter in If rnd() <= priorityPercentage are also taken into account.
In Excel VBA, I am tossing four coins and counting the number of heads. The code I am using is:
CoinHeads = Int(Round(Rnd(), 0)) + Int(Round(Rnd(), 0)) + Int(Round(Rnd(), 0)) + Int(Round(Rnd(), 0))
This works, but I am wondering if there is a simpler way to do this in Excel VBA code that would still give me the same distribution of head counts from 0 to 4. Thanks for any advice!
If you wanted just to simplify your statements a little bit you could use Int(2 * Rnd()) instead:
CoinHeads = Int(2 * Rnd()) + Int(2 * Rnd()) + Int(2 * Rnd()) + Int(2 * Rnd())
Other than that you can segment the number of heads like #Comintern says in their comment.
You should write a little function and pass the number of heads as parameter to generalize your code (here tossing head if the random number is larger than or equal to 0.5):
Public Function getNumberOfHeads(ByVal nb As Integer) As Integer
Dim nbHeads As Integer: nbHeads = 0
Randomize
For j = 0 To nb
If Rnd() >= 0.5 Then nbHeads = nbHeads + 1
Next j
getNumberOfHeads = nbHeads
End Function
And then you use it like this in your code:
numberOfHeads = getNumberOfHeads(4)
I'm using excel time format "hh:mm:ss.000" and adding 50ms at a time to cells in consecutive rows via VBA:
Dim dblTimestamp As Double
dblTimestamp = Selection.Value ' origin timestamp
' Setup base time increment of 50ms over 20 minutes
For i = 1 To Selection.Rows.Count
Selection.Rows(i).Value2 = dblTimestamp + (2# / (864000# * 4#))
dblTimestamp = dblTimestamp + (2# / (864000# * 4#))
Next i
So you see the origin time below on 5/23/2015 and things start out fine:
5/23/2015 05:30:00.000
05:30:00.050
05:30:00.100
05:30:00.150
05:30:00.200
05:30:00.250
The problem is that the precision/rounding errors start to show up after a couple minutes (~1840 rows):
05:31:32.100
05:31:32.149
05:31:32.199
05:31:32.249
And then after 20 minutes it's more pronounced:
05:49:59.793
05:49:59.843
05:49:59.893
05:49:59.943
05:49:59.993
Can I use some other datatype for my calculations or do I have to brute force and add an extra millisecond every ~1840 rows?
I'd prefer a solution that would also apply when I change the time step to 200ms
This should do the trick. Note that I removed your "selection" reference and am instead using "Now()" as the time stamp and placing values in cells A2 through A20000. Functionally, you could combine all the time helper stuff into a single rounding function, but I designed it the way it is to feel more object oriented and to demonstrate a paradigm that's more adaptable. Hope this helps.
'A type used to store time data
Type TimeHelper
MS As Double
BaseTime As Double
End Type
'Value to use as millisecond
Const MilSec = 1 / 86400000
Sub Test()
Dim t As Double
t = Now()
Dim step As Double
step = 75
Dim TH As TimeHelper
For i = 2 To 200000
t = t + step * MilSec
TH = GetTimeHelper(t)
t = RoundMS(TH, step)
Cells(i, 1).Value2 = t
Next i
End Sub
Function GetTimeHelper(t As Double) As TimeHelper
x = t
'Unrounded Hours
x = (x - Round(x, 0)) * 24
'Unrounded Minutes
x = (x - Round(x, 0)) * 60
'Seconds as Milliseconds
GetTimeHelper.MS = (x - Round(x, 0)) * 60000
'Time rounded down to nearest minute by removing millisecond value
GetTimeHelper.BaseTime = t - (GetTimeHelper.MS * MilSec)
End Function
Function RoundMS(TH As TimeHelper, m As Double)
'Construct a time from basetime and milliseconds
'with milliseconds rounded to nearest multiple of m
RoundMS = TH.BaseTime + (Round(TH.MS / m, 0) * m) * MilSec
End Function
You need to round your date value after you have done the addition. Excel dates are stored as numbers under the hood and time is represented by a decimal. For example, 42249.6282730324 is 02/09/2015 (< to the left of the decimal) 15:04:43.550 (< to the right of the decimal) So you need to round this number. Here is a good post showing how you can do this using the INT, CEILING and MOD functions. http://exceluser.com/formulas/roundtime.htm.
I actually just decided to check the text value after every row to see if it ended in a 9 and then add a millisecond if necessary:
Dim dblTimestamp As Double
dblTimestamp = Selection.Value ' origin timestamp
' Setup base time increment of 50ms over 20 minutes
For i = 1 To Selection.Rows.Count
Selection.Rows(i).Value2 = dblTimestamp + (2# / (864000# * 4#))
dblTimestamp = dblTimestamp + (2# / (864000# * 4#))
' check to see if previous value ended in 9 indicating loss of precision
' e.g. 05:30:00.999 instead of 05:30:01.000
If Right(Selection.Rows(i).Cells(1).Text,1)="9") Then
dblTimestamp = dblTimestamp + (1#/86400000#) ' add 1 ms
Selection.Rows(i).Value2 = dblTimestamp
End If
Next i
This was good enough for my situation but P57's answer should still be good enough for other situations.