Is there anybody know how to make normal distributed random number in vb.net?
thank you
From this forum post :
Usage:
GaussNumDist(Mean, Standard Deviation, Sample Size)
Code example below, which will populate GaussNumArray() with the sample of numbers, whose distribution will have the mean and standard deviation specified:
Imports System.Math
Module Module1
Friend GaussNumArray() As Double
Friend intICell As Long
Friend Function GaussNumDist(ByVal Mean As Double, ByVal StdDev As Double, ByVal SampleSize As Integer)
intICell = 1 'Loop variable
ReDim GaussNumArray(SampleSize)
Do While (intICell < (SampleSize + 1))
Call NumDist(Mean, StdDev)
Application.DoEvents()
Loop
End Function
Sub NumDist(ByVal meanin As Double, ByVal sdin As Double)
'---------------------------------------------------------------------------------
'Converts uniform random numbers over the region 0 to 1 into Gaussian distributed
'random numbers using Box-Muller algorithm.
'Adapted from Numerical Recipes in C
'---------------------------------------------------------------------------------
'Defining variables
Dim dblR1 As Double
Dim dblR2 As Double
Dim mean As Double
Dim var As Double
Dim circ As Double
Dim trans As Double
Dim dblY1 As Double
Dim dblY2 As Double
Dim Pi As Double
Pi = 4 * Atan(1)
'Get two random numbers
dblR1 = (2 * UniformRandomNumber()) - 1
dblR2 = (2 * UniformRandomNumber()) - 1
circ = (dblR1 ^ 2) + (dblR2 ^ 2) 'Radius of circle
If circ >= 1 Then 'If outside unit circle, then reject number
Call NumDist(meanin, sdin)
Exit Sub
End If
'Transform to Gaussian
trans = Sqrt(-2 * Log(circ) / circ)
dblY1 = (trans * dblR1 * sdin) + meanin
dblY2 = (trans * dblR2 * sdin) + meanin
GaussNumArray(intICell) = dblY1 'First number
'Increase intICell for next random number
intICell = (intICell + 1)
GaussNumArray(intICell) = dblY2 'Second number
'Increase intICell again ready for next call of ConvertNumberDistribution
intICell = (intICell + 1)
End Sub
Friend Function UniformRandomNumber() As Double
'-----------------------------------------------------------------------------------
'Outputs random numbers with a period of > 2x10^18 in the range 0 to 1 (exclusive)
'Implements a L'Ecuyer generator with Bays-Durham shuffle
'Adapted from Numerical Recipes in C
'-----------------------------------------------------------------------------------
'Defining constants
Const IM1 As Double = 2147483563
Const IM2 As Double = 2147483399
Const AM As Double = (1.0# / IM1)
Const IMM1 As Double = (IM1 - 1.0#)
Const IA1 As Double = 40014
Const IA2 As Double = 40692
Const IQ1 As Double = 53668
Const IQ2 As Double = 52774
Const IR1 As Double = 12211
Const IR2 As Double = 3791
Const NTAB As Double = 32
Const NDIV As Double = (1.0# + IM1 / NTAB)
Const ESP As Double = 0.00000012
Const RNMX As Double = (1.0# - ESP)
Dim iCell As Integer
Dim idum As Double
Dim j As Integer
Dim k As Long
Dim temp As Double
Static idum2 As Long
Static iy As Long
Static iv(NTAB) As Long
idum2 = 123456789
iy = 0
'Seed value required is a negative integer (idum)
Randomize()
idum = (-Rnd() * 1000)
'For loop to generate a sequence of random numbers based on idum
For iCell = 1 To 10
'Initialize generator
If (idum <= 0) Then
'Prevent idum = 0
If (-(idum) < 1) Then
idum = 1
Else
idum = -(idum)
End If
idum2 = idum
For j = (NTAB + 7) To 0
k = ((idum) / IQ1)
idum = ((IA1 * (idum - (k * IQ1))) - (k * IR1))
If (idum < 0) Then
idum = (idum + IM1)
End If
If (j < NTAB) Then
iv(j) = idum
End If
Next j
iy = iv(0)
End If
'Start here when not initializing
k = (idum / IQ1)
idum = ((IA1 * (idum - (k * IQ1))) - (k * IR1))
If (idum < 0) Then
idum = (idum + IM1)
End If
k = (idum2 / IQ2)
idum2 = ((IA2 * (idum2 - (k * IQ2))) - (k * IR2))
If (idum2 < 0) Then
idum2 = idum2 + IM2
End If
j = (iy / NDIV)
iy = (iv(j) - idum2)
iv(j) = idum
If (iy < 1) Then
iy = (iy + IMM1)
End If
temp = AM * iy
If (temp <= RNMX) Then
'Return the value of the random number
UniformRandomNumber = temp
End If
Next iCell
End Function
End Module
You can use following line
Dim x1 as Double = MathNet.Numerics.Distributions.Normal.Sample(MEAN, STDEV)
Math.Net Numeric package can be installed using following NuGet command
Install-Package MathNet.Numerics -Version 4.9.0
You can found more information on NuGet site
Related
I have the following code:
Sub UpdateBlock()
'Define empty variables for each attribute
Dim ent As AcadEntity
Dim oBkRef As AcadBlockReference
Dim Insertpoints As Variant
Dim A As Double
Dim tag As String
Dim material As String
Dim actualLength As String
Dim cutOff As Double
Dim cutLengths As Double
Dim totalLengths As Double
Dim weight As Double
Dim purchaseLength As Double
Dim decimalLength As Double
Dim lengthWeight As Double
Dim totalLengthWeight As Double
Dim cutLengthWeight As Double
Dim cutWeight As Double
Dim order As Double
Dim feet As Double
Dim inches As Double
Dim fraction As Double
Dim fracVal As Variant
'First we go over every object in the modelspace
For Each ent In ThisDrawing.ModelSpace
'Check if the object is a block
If ent.ObjectName = "AcDbBlockReference" Then
Set oBkRef = ent
'If the object is a block then check if its the block we are looking for
If oBkRef.EffectiveName = "AUTOTAG-MATERIAL" Then
A = A + 1
'Get Current Attributes
attlist = oBkRef.GetAttributes
For i = LBound(attlist) To UBound(attlist)
Select Case attlist(i).TagString
Case "ACTUAL-LENGTH"
actualLength = attlist(i).TextString
Case "PURCHASE-LENGTH"
purchaseLength = attlist(i).TextString
Case "CUT-OFF"
cutOff = Frac2Num(attlist(i).TextString)
Case "DECIMAL-LENGTH"
feet = Split(actualLength)(0)
inches = Split(actualLength)(1)
fracVal = Split(actualLength)(2)
If Not IsNull(Split(actualLength)(2)) Then
fraction = Frac2Num(fracVal)
Else
fraction = 0
End If
decimalLength = Round((((feet * 12) + (inches + fraction)) / 12) - cutOff, 2)
attlist(i).TextString = decimalLength
Case "WEIGHT"
weight = attlist(i).TextString
Case "CUT-WEIGHT"
cutWeight = weight * decimalLength
attlist(i).TextString = cutWeight
Case "LENGTH-WEIGHT"
lengthWeight = weight * purchaseLength
attlist(i).TextString = lengthWeight
Case "TOTAL-LENGTHS"
totalLengths = attlist(i).TextString
Case "CUT-LENGTHS"
cutLength = attlist(i).TextString
Case "TOTAL-LENGTH-WEIGHT"
totalLengthWeight = lengthWeight * totalLengths
attlist(i).TextString = totalLengthWeight
Case "CUT-LENGTH-WEIGHT"
totalCutWeight = lengthWeight * cutLength
attlist(i).TextString = totalCutWeight
End Select
Next
End If
End If
Next ent
End Sub
Function Frac2Num(ByVal X As String) As Double
Dim P As Integer, N As Double, Num As Double, Den As Double
X = Trim$(X)
P = InStr(X, "/")
If P = 0 Then
N = Val(X)
Else
Den = Val(Mid$(X, P + 1))
If Den = 0 Then Error 11 ' Divide by zero
X = Trim$(Left$(X, P - 1))
P = InStr(X, " ")
If P = 0 Then
Num = Val(X)
Else
Num = Val(Mid$(X, P + 1))
N = Val(Left$(X, P - 1))
End If
End If
If Den <> 0 Then
N = N + Num / Den
End If
Frac2Num = N
End Function
The variable fraction / fracVal comes from a tag in AutoCAD that is a length, that will always be at least "0 0", but may be "0 0 0" it is a length in feet, inches, and fractional inches. So some possible values could be "8 5", "16 11 11/16", "0 5 3/8" etc.
What I need is a check for when the fraction is not there.
Any suggestions?
I would split the string on the space and see if the ubound of the resulting array is 2. So something like this
If Ubound(Split(thisString, " ")) = 2 then
'fractional part is present
End If
Another option is the Like Operator:
If thisString Like "#* #* #*/#*" Then
# matches any single digit (0–9) and * matches zero or more characters.
but since you split the string anyway, I would store the result of the split in a variable and check the number of items in it with UBound as shown in the other answer.
I have the following function that when I run it says #value! error.
I would appreciate any help.
Function Bootstrap(S As Object, Z As Object, L As Double)
Dim j As Integer
Dim a() As Double
Dim b() As Double
Dim n As Integer
Dim Q() As Double
Dim sum As Double
Dim P As Double
ReDim a(1 To n)
ReDim b(1 To n)
ReDim Q(1 To n)
dt = 1
sum = 0
Q(0) = 0
For j = 1 To n - 1
S.Cells(j, 1).Value = a(j)
Z.Cells(j, 2).Value = b(j)
P = Z(j) * (L * Q(j-1) - (L + dt * a(n) * Q(j))
sum = sum + P
Next j
Bootstrap = sum
End Function
Bootstrapping function calculates the following value
In fact I am trying to calculate this formula
Q(t,Tn)=(∑(j=1)to(n-1) Z(t,Tj)[LQ(t,Tj-1)-(L+dtSn)Q(t,Tj)]/[Z(t,Tn)(L+dt*Sn)] +(Q(t,Tn-1)L)/(L+dtSn)
Inputs given are[S1 ,S2,….Sn ],[Z(t,T1),Z(t,T2)…..Z(t,Tn)]and and L=0.4
Try this code : entered as =Bootstrap(A1:B1,A2:B2,0.4)
I have corrected the following
- Assigning the ranges to variants
- defining dt as double
- Dim Q() as 0 to n
- using A() and b() in the formula
- the input ranges are rows not columns
Function Bootstrap(S As Range, Z As Range, L As Double) As Double
Dim j As Integer
Dim a As Variant
Dim b As Variant
Dim n As Integer
Dim Q() As Double
Dim sum As Double
Dim P As Double
Dim dt As Double
n = Application.WorksheetFunction.Max(S.Columns.Count, Z.Columns.Count)
a = S.Value
b = Z.Value
dt = 1
sum = 0
ReDim Q(0 To n)
Q(0) = 0
For j = 1 To n - 1
P = b(1, j) * (L * Q(j - 1)) - (L + dt * a(1, j) * Q(j - 1))
sum = sum + P
Q(j) = sum
Next j
Bootstrap = sum
End Function
Take the habit to format and increment your code, especially before posting it!
You need to type the output of the function (on the line of the function name)
A parenthesis is missing from the line P = Z(j) * (L*Q(j-1)-(L+ dt * a(n) * Q(j))
n is empty (and so are a, b and Q) when you try to redim your arrays, so you need to define them!
Z(j) will also give you an error, because it is a Range, you need Z.Cells(i,j)
Try this :
Function Bootstrap(S As Range, Z As Range, L As Double) As Double
Dim j As Integer
Dim a() As Double
Dim b() As Double
Dim n As Integer
Dim Q() As Double
Dim sum As Double
Dim P As Double
n = Application.WorksheetFunction.Max(S.Columns.count, Z.Columns.count)
a = S.Value
b = Z.Value
dt = 1
sum = 0
ReDim Q(1 To n)
Q(0) = 0
'Q(1) = "??"
For j = 1 To n - 1
P = b(1, j) * (L * Q(j - 1)) - (L + dt * a(1, j) * Q(j - 1))
sum = sum + P
Q(j) = sum
Next j
Bootstrap = sum
End Function
If I have a convex curve, and want to find the minimum point (x,y) using a for or while loop. I am thinking of something like
dim y as double
dim LastY as double = 0
for i = 0 to a large number
y=computefunction(i)
if lasty > y then exit for
next
how can I that minimum point? (x is always > 0 and integer)
Very Close
you just need to
dim y as double
dim smallestY as double = computefunction(0)
for i = 0 to aLargeNumber as integer
y=computefunction(i)
if smallestY > y then smallestY=y
next
'now that the loop has finished, smallestY should contain the lowest value of Y
If this code takes a long time to run, you could quite easily turn it into a multi-threaded loop using parallel.For - for example
dim y as Double
dim smallestY as double = computefunction(0)
Parallel.For(0, aLargeNumber, Sub(i As Integer)
y=computefunction(i)
if smallestY > y then smallestY=y
End Sub)
This would automatically create separate threads for each iteration of the loop.
For a sample function:
y = 0.01 * (x - 50) ^ 2 - 5
or properly written like this:
A minimum is mathematically obvious at x = 50 and y = -5, you can verify with google:
Below VB.NET console application, converted from python, finds a minimum at x=50.0000703584199, y=-4.9999999999505, which is correct for the specified tolerance of 0.0001:
Module Module1
Sub Main()
Dim result As Double = GoldenSectionSearch(AddressOf ComputeFunction, 0, 100)
Dim resultString As String = "x=" & result.ToString + ", y=" & ComputeFunction(result).ToString
Console.WriteLine(resultString) 'prints x=50.0000703584199, y=-4.9999999999505
End Sub
Function GoldenSectionSearch(f As Func(Of Double, Double), xStart As Double, xEnd As Double, Optional tol As Double = 0.0001) As Double
Dim gr As Double = (Math.Sqrt(5) - 1) / 2
Dim c As Double = xEnd - gr * (xEnd - xStart)
Dim d As Double = xStart + gr * (xEnd - xStart)
While Math.Abs(c - d) > tol
Dim fc As Double = f(c)
Dim fd As Double = f(d)
If fc < fd Then
xEnd = d
d = c
c = xEnd - gr * (xEnd - xStart)
Else
xStart = c
c = d
d = xStart + gr * (xEnd - xStart)
End If
End While
Return (xEnd + xStart) / 2
End Function
Function ComputeFunction(x As Double)
Return 0.01 * (x - 50) ^ 2 - 5
End Function
End Module
Side note: your initial attempt to find minimum is assuming a function is discrete, which is very unlikely in real life. What you would get with a simple for loop is a very rough estimate, and a long time to find it, as linear search is least efficient among other methods.
When I generate random numbers, I sometimes get (not always) the following error:
Run-time error '13': type mismatch.
on line Z = Sqr(time) * Application.NormSInv(Rnd()) (and the end of the second for loop).
Why do I get this error?
I think it has something to do with the fact that it contains Rnd().
Sub asiancall()
'defining variables
Dim spot As Double
Dim phi As Integer
Dim rd_cont As Double
Dim rf_cont As Double
Dim lambda As Double
Dim muY As Double
Dim sigmaY As Double
Dim vol As Double
Dim implied_vol As Double
Dim spotnext As Double
Dim time As Double
Dim sum As Double
Dim i As Long
Dim mean As Double
Dim payoff_mean As Double
Dim StDev As Double
Dim K As Double
Dim Egamma0 As Double
Dim mulTv As Double
Dim prod As Double
Dim U As Double
Dim Pois As Double
Dim Q As Double
Dim Z As Long
Dim gamma As Double
Dim payoff As Double
Dim payoff_sum As Double
Dim secondmoment As Double
Dim j As Long
Dim N As Long
Dim mu As Double
Dim sum1 As Double
'read input data
spot = Range("B3")
rd_cont = Range("C5")
rf_cont = Range("C4")
muY = Range("B17")
sigmaY = Range("B18")
lambda = Range("B16")
K = Range("F33")
implied_vol = Range("F35")
N = Range("F34")
vol = Range("B6")
'calculations
sum_BS = 0
payoff_BS = 0
mean_BS = 0
secondmoment_BS = 0
For j = 1 To N
spotnext = spot
spotnext_BS = spot
time = 0
sum1 = 0
time = 184 / (360 * 6)
For i = 1 To 6
' 'Merton uitvoeren
Egamma0 = Exp(muY + sigmaY * sigmaY * 0.5) - 1
mu = rd_cont - rf_cont
mulTv = (mu - lambda * Egamma0 - implied_vol * implied_vol * 0.5) * time
sum = 0
prod = 1
Do While sum <= time
U = Rnd()
Pois = -Log(U) / lambda
sum = sum + Pois
Q = Application.NormInv(Rnd(), muY, sigmaY)
gamma = Exp(Q) - 1
prod = prod * (1 + gamma)
Loop
prod = prod / (1 + gamma)
Z = Sqr(time) * Application.NormSInv(Rnd())
spotnext = spotnext * Exp(mulTv + implied_vol * Z) * prod
sum1 = sum1 + spotnext
Next i
mean = sum1 / 6
payoff = Application.Max(mean - K, 0)
payoff_sum = payoff_sum + payoff
secondmoment = secondmoment + payoff * payoff
Next j
Following up on the community wiki answer I posted, a possible solution is this:
Function RndExcludingZero()
Do
RndExcludingZero = Rnd()
Loop While RndExcludingZero = 0
End Function
Usage:
Z = Sqr(time) * Application.NormSInv(RndExcludingZero())
Rnd() returns values >=0 and <1.
At some point it is bound to return 0. When given 0 as input in Excel, NormSInv returns the #NUM!
Excel error.* When called in VBA via Application.NormSInv(0), it returns a Variant of subtype Error with value "Error 2036" (equivalent to the #NUM! Excel error).
Such Variant/Errors cannot be implicitly coerced to a numerical value (which is what the * operator expects) and thus in this case, you will get the type mismatch error.
You will only get this error when Rnd() happens to return 0, which is consistent with your observation that the error occurs only sometimes.
* This was first remarked by user3964075 in a now defunct comment to the question.
I am trying to implement a 2D Perlin Noise in VB.Net. I've spent the whole day searching for sources that explain the subject and one of the most notable was this article by Hugo Elias
Most of the implementation went well. On the exception of a very important part that did not seem to work in VB.Net, causing overflows.
function Noise1(integer x, integer y)
n = x + y * 57
n = (n<<13) ^ n;
return ( 1.0 - ( (n * (n * n * 15731 + 789221) + 1376312589) & 7fffffff) / 1073741824.0);
end function
In VB.net I translated it to
Private Function Noise(tX As Integer, tY As Integer) As Double
'Return a double between -1 & 1 according to a fixed random seed
Dim n As Integer = tX + tY * 57
n = (n << 13) Xor n
Return (1.0 - ((n * (n * n * 15731 + 789221) + BaseSeed) And &H7FFFFFFF) / 1073741824.0)
End Function
Which cause overflows.
Since the idea seem to be to simply generate a fractional number between -1 and 1. I've made this little function which create a Integer Number based on the coordinates and BaseSeed. BaseSeed(999999) being the base for every noise I'll create in this particular part of my game.
Private Function Noise(tX As Integer, tY As Integer) As Double
Dim tSeed As Integer
tSeed = WrapInteger(789221, BaseSeed, (tX * 1087) + (tY * 2749))
RandomGenerator = New Random(tSeed)
Return (RandomGenerator.Next(-10000, 10001) / 10000)
End Function
WrapInteger simply makes sure that the number will always be in the range of an integer, to avoid overflow errors.
Public Function WrapInteger(ByVal Lenght As Integer, ByVal Position As Integer, ByVal Movement As Integer) As Integer
Lenght += 1
Return ((Position + Movement) + (Lenght * ((Abs(Movement) \ Lenght) + 1))) Mod Lenght
End Function
When I fire it up with a Persistence of 0.25, 6 Octaves and a starting frequency of 2. this is what I get. This is a 128x128 pixel bitmap that I scaled.
Result
Anyone have an idea of why it would be so linear? When I look at this picture I have the feeling that it's not far from the truth, as if it only worked in 1D. All suposition.
Below you will find my entire PerlinNoise Class. I think the rest of it is just fine, but I added it for reference purpose. Beside, I haven't been able to find a single VB implementation of Perlin Noise on the internet. So I guess if I can fix this one, it might help others. There seem to be alot of question about Perlin noise malfunction on StackOverflow
Public Class cdPerlinNoise
Private RandomGenerator As Random
Private BaseSeed As Integer
Private Persistence As Double
Private Frequency As Integer
Private Octaves As Integer
Public Sub New(tSeed As Integer, tPersistence As Double, tOctaves As Integer, tFrequency As Integer)
Frequency = tFrequency
BaseSeed = tSeed
Persistence = tPersistence
Octaves = tOctaves
End Sub
Private Function Noise(tX As Integer, tY As Integer) As Double
Dim tSeed As Integer
tSeed = WrapInteger(789221, BaseSeed, (tX * 1087) + (tY * 2749))
RandomGenerator = New Random(tSeed)
Return (RandomGenerator.Next(-10000, 10001) / 10000)
End Function
Private Function SmoothNoise(tX As Integer, tY As Integer) As Double
Dim Corners As Double = (Noise(tX - 1, tY - 1) + Noise(tX + 1, tY - 1) + Noise(tX - 1, tY + 1) + Noise(tX + 1, tY + 1)) / 16
Dim Sides As Double = (Noise(tX - 1, tY) + Noise(tX + 1, tY) + Noise(tX, tY - 1) + Noise(tX, tY + 1)) / 8
Return (Noise(tX, tY) / 4) + Corners + Sides
End Function
Private Function InterpolateCosine(tA As Double, tB As Double, tX As Double) As Double
Dim f As Double = (1 - Cos(tX * 3.1415927)) * 0.5
Return tA * (1 - f) + tB * f
End Function
Private Function Interpolate2D(tX As Double, tY As Double) As Double
Dim WholeX As Integer = CInt(Fix(tX))
Dim RemainsX As Double = tX - WholeX
Dim WholeY As Integer = CInt(Fix(tY))
Dim RemainsY As Double = tY - WholeY
Dim v1 As Double = SmoothNoise(WholeX, WholeY)
Dim v2 As Double = SmoothNoise(WholeX + 1, WholeY)
Dim v3 As Double = SmoothNoise(WholeX, WholeY + 1)
Dim v4 As Double = SmoothNoise(WholeX + 1, WholeY + 1)
Dim i1 As Double = InterpolateCosine(v1, v2, RemainsX)
Dim i2 As Double = InterpolateCosine(v3, v4, RemainsX)
Return InterpolateCosine(i1, i2, RemainsY)
End Function
Public Function PerlinValue(tX As Double, tY As Double) As Double
Dim Total As Double = 0
Dim Frequency As Double
Dim Amplitude As Double
For i = 0 To Octaves - 1
Frequency = Frequency ^ i
Amplitude = Persistence ^ i
Total = Total + (Interpolate2D(tX * Frequency, tY * Frequency) * Amplitude)
Next
Return Total
End Function
Public Function ScaleNoise(ByVal tX As Double, ByVal tY As Double, ByVal OutputLow As Double, ByVal OutputHigh As Double) As Double
Dim Range1 As Double
Dim Range2 As Double
Dim Result As Double
Range1 = 1 - -1
Range2 = OutputHigh - OutputLow
'(B*C - A*D)/R1 + n1*(R2/R1)
Result = (((1 * OutputLow) - (-1 * OutputHigh)) / Range1) + ((PerlinValue(tX, tY) * (Range2 / Range1)))
If Result < OutputLow Then
Return OutputLow
ElseIf Result > OutputHigh Then
Return OutputHigh
Else
Return Result
End If
End Function
End Class