Finding minimum point of a function - vb.net

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.

Related

type mismatch error in VBA, where is the mistake

Hey I have no idea why I get an error "run time error 13 type mismatch". Thats my code and the place where I get an error:
EDIT: That is my code:
Function payoff(S_T, K, CallPut As String)
If CallPut = "call" Then
omega = 1
Else: omega = -1
End If
payoff = WorksheetFunction.Max(omega * (S_T - K), 0)
End Function
Function BS_trajektoria(S_0 As Double, T As Double, r As Double, q As Double, sigma As Double, N As Long) As Double()
Randomize
Dim S() As Double
Dim delta_t As Double
Dim i As Long
ReDim S(N)
S(0) = S_0
delta_t = T / N
For i = 1 To N
S(i) = S(i - 1) * Exp((r - q - 0.5 * sigma ^ 2) * delta_t + sigma * delta_t ^ 0.5 * Application.NormSInv(Rnd))
Next i
BS_trajektoria = S
End Function
Function barrier_MC(S_0 As Double, K As Double, T As Double, r As Double, q As Double, sigma As Double, _
B As Double, N As Long, num_of_sim As Long, CallPut As String, BarType As String) As Double
Randomize
Dim max_value As Double
Dim suma_wyplat As Double
Dim wyplata As Double
Dim i As Long
Dim S() As Double
suma_wyplat = 0
If (BarType = "DO" Or BarType = "DI") And B > S_0 Then
MsgBox "Too high barrier!"
Exit Function
ElseIf (BarType = "UO" Or BarType = "UI") And B < S_0 Then
MsgBox "Too low barrier!"
Exit Function
End If
With WorksheetFunction
For i = 1 To num_of_sim
S = BS_trajektoria(S_0, T, r, q, sigma, N)
max_value = .Max(S)
If max_value >= B Then
wyplata = 0
Else
wyplata = payoff(S(N), K, CallPut)
End If
suma_wyplat = suma_wyplat + wyplata
Next i
End With
barrier_MC = Exp(-r * T) * suma_wyplat / num_of_sim
End Function
Sub test3()
MsgBox barrier_MC(100, 100, 1, 0.05, 0.02, 0.2, 120, 1000, 1000000, "call", "UO")
End Sub
Anyone know where is the problem? For smaller value of N and num_of_sim everything works fine, the problem is when I use bigger values for these variables.
If you declare a new Double variable called rand and modify the main loop so that it looks like:
For i = 1 To N
rand = Rnd
S(i) = S(i - 1) * Exp((r - q - 0.5 * sigma ^ 2) * delta_t + sigma * delta_t ^ 0.5 * Application.NormSInv(rand))
Next i
you will see that the problem always happens when rand = 0. Why it throws that particular error is a bit of a mystery, but it is what it is. As a fix, what you could do is to keep the code as modified above with the following twist:
For i = 1 To N
rand = Rnd
If rand = 0 Then rand = 0.0000001
S(i) = S(i - 1) * Exp((r - q - 0.5 * sigma ^ 2) * delta_t + sigma * delta_t ^ 0.5 * Application.NormSInv(rand))
Next i
Then the code will run without error. It is still somewhat slow, but optimizing it (if possible) would be for a different question.

spacing between two points in 3d cordinate system

i am a bit new to this but I'm trying to create a randomly generated 3d coordinate points with equal spacing, I've tried using for each loop but im confused on how to use in. the purpose is to generate sphere around that point but some sphere are overlapping each other. thanks in advance. the code below is to show how I'm generating the sphere
For i = 0 To noofsp - 1
x = Rnd(1) * maxDist
ws1.Cells(i + 5, 2) = x
y = Rnd(1) * maxDist
ws1.Cells(i + 5, 3) = y
z = Rnd(1) * maxDist
ws1.Cells(i + 5, 4) = z
centers.Add({x, y, z})
Next
You'll need to check the new point against all the other points to make sure that your new point is at a greater distance that the sum of the radii of your new sphere and each sphere you're checking against
You'll need to use pythagoras' theorem to check that the distances and I found the code below from this site. The code on the site is written in c#, but here is the vb.net version.
Public Function Distance3D(x1 As Double, y1 As Double, z1 As Double, x2 As Double, y2 As Double, z2 As Double) As Double
' __________________________________
'd = √ (x2-x1)^2 + (y2-y1)^2 + (z2-z1)^2
'
'Our end result
Dim result As Double
'Take x2-x1, then square it
Dim part1 As Double = Math.Pow((x2 - x1), 2)
'Take y2-y1, then square it
Dim part2 As Double = Math.Pow((y2 - y1), 2)
'Take z2-z1, then square it
Dim part3 As Double = Math.Pow((z2 - z1), 2)
'Add both of the parts together
Dim underRadical As Double = part1 + part2 + part3
'Get the square root of the parts
result = Math.Sqrt(underRadical)
'Return our result
Return result
End Function
To generate the spheres, you would need to expand your code to include checking the new point against all the previously generated points. That code is below with comments.
I have assumed the definition of a variable called minDistance to specify how far apart the centre of the spheres should be. I'm also assuming that all the spheres are the same size. The number should be twice the radius of the spheres
Private Sub GenerateSpheres()
Randomize
For i As Integer = 0 To noofsp - 1
Dim distanceOK As Boolean = False
Dim x, y, z As Integer
'keep generating points until one is found that is
'far enough away. When it is, add it to your data
While distanceOK = False
x = Rnd(1) * maxDist
y = Rnd(1) * maxDist
z = Rnd(1) * maxDist
'If no other points have been generated yet, don't bother
'checking your new point
If centers.Count = 0 Then
distanceOK = True
Else
'If other points exist, loop through the list and check distance
For j As Integer = 0 To centers.Count - 1
'if the point is too close to any other, stop checking,
'exit the For Loop and the While Loop will generate a new
'coordinate for checking, and so on
Dim dist As Integer = Distance3D(centers(j)(0), centers(j)(1), centers(j)(2), x, y, z)
If dist <= minDistance Then
distanceOK = False
'exit the For loop and start the next iteration of the While Loop
Continue While
End If
Next
'If all previous points have been checked none are too close
'flag distanceOK as true
distanceOK = True
End If
End While
'ws1.Cells(i + 5, 2) = x
'ws1.Cells(i + 5, 3) = y
'ws1.Cells(i + 5, 4) = z
centers.Add({x, y, z})
Next
End Sub

Type mismatch error when generating random numbers

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.

Perlin Noise acting strange

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

Ignore overflow error when multiplication result is bigger than what a double can hold

During some iterative optimization, the following VBA code for the computation of the bivariate normal CDF sometimes throws an Overflow error on the line with z = hx * hy * c inside the while loop of the upper function.
I debugged the code and the overflow occurs when the numbers being multiplied result in a number bigger than what a double can hold.
Can you show me how to handle the problem by ignoring the iterations of the loop with such high values - I guess that's the only feasible solution (?). I tried myself with a On Error Goto nextiteration line before the multiplication and placing the nextiteration jump point before the Wend, but the error persists.
Function tetrachoric(x As Double, y As Double, rho As Double) As Double
Const FACCURACY As Double = 0.0000000000001
Const MinStopK As Integer = 20
Dim k As Integer
Dim c As Double
Dim z As Double
Dim s As Double
Dim hx As Double
Dim hx1 As Double
Dim hx2 As Double
Dim hy As Double
Dim hy1 As Double
Dim hy2 As Double
Dim CheckPass As Integer
hx = 1
hy = 1
hx1 = 0
hy1 = 0
k = 0
c = rho
z = c
s = z
CheckPass = 0
While CheckPass < MinStopK
k = k + 1
hx2 = hx1
hy2 = hy1
hx1 = hx
hy1 = hy
hx = x * hx1 - (k - 1) * hx2
hy = y * hy1 - (k - 1) * hy2
c = c * rho / (k + 1)
z = hx * hy * c
s = s + z
If Abs(z / s) < FACCURACY Then
CheckPass = CheckPass + 1
Else
CheckPass = 0
End If
Wend
tetrachoric = s
End Function
Public Function bivnor(x As Double, y As Double, rho As Double) As Double
'
' bivnor function
' Calculates bivariat normal CDF F(x,y,rho) for a pair of standard normal
' random variables with correlation RHO
'
If rho = 0 Then
bivnor = Application.WorksheetFunction.NormSDist(x) * _
Application.WorksheetFunction.NormSDist(y)
Else
bivnor = Application.WorksheetFunction.NormSDist(x) * _
Application.WorksheetFunction.NormSDist(y) + _
Application.WorksheetFunction.NormDist(x, 0, 1, False) * _
Application.WorksheetFunction.NormDist(y, 0, 1, False) * _
tetrachoric(x, y, rho)
End If
End Function
Source: Available for download at http://michael.marginalq.com/
you're hitting on the limits of the computer architecture. Many complex algorithms can't be implemented 1:1 with their mathematical representation because of performance reasons and/or erroneous behavior when overflowing. There's an exceptionally good blog about these issues - John D. Cook.
Please take a look here for a better implementation.
You can also try binding an external library, that gives you arbitrary precision number handling, of course implemented using very expensive (in terms of CPU time) software algorithms. More can be found here.
Updated code using On Error Resume Next instead of On Error Goto:
While CheckPass < MinStopK
k = k + 1
hx2 = hx1
hy2 = hy1
hx1 = hx
hy1 = hy
hx = x * hx1 - (k - 1) * hx2
hy = y * hy1 - (k - 1) * hy2
c = c * rho / (k + 1)
On Error Resume Next
z = hx * hy * c
If Err.Number = 0 Then
s = s + z
If Abs(z / s) < FACCURACY Then
CheckPass = CheckPass + 1
Else
CheckPass = 0
End If
Else
Err.Clear
End If
Wend
http://www.codeproject.com/KB/recipes/float_point.aspx treats how to "Use Logarithms to Avoid Overflow and Underflow", which is a simple but quite effective way of working around overflow problems. In fact, it's so simple yet logical, why haven't we thought of that solution ourselves? ;)