i created a code in VBA to calculate the amount of combinations for stirling numbers of second kind. But in following example only half of the values are correct.
The result should be 1,7,6,1 if n is equal to 4. (Wikipedia stirling numbers
I get 1,7,6.5,4.16
Sub stirlingerzahlen()
Dim n As Integer
Dim sum As Double
Dim subsum As Double
Dim k As Long
Dim j As Long
n = 4
For k = 1 To n Step 1
For j = 0 To k Step 1
subsum = 1 / Application.WorksheetFunction.Fact(k) * (-1) ^ (k - j) * Application.WorksheetFunction.Fact(k) / Application.WorksheetFunction.Fact(j) * j ^ n
sum = sum + subsum
Next
Sheets("Tabelle2").Cells(k, 1) = sum
sum = 0
Next
End Sub
Can someone find the mistake?
There is another version of the formula which seems to be easier to implement:
http://home.mathematik.uni-freiburg.de/junker/ss10/DAS-SS10.pdf
(Page 13)
And here the updated code:
Sub stirlingerzahlen()
Dim n As Integer
Dim sum As Double
Dim subsum As Double
Dim k As Long
Dim j As Long
n = 4
For k = 1 To n Step 1
For j = 0 To k
subsum = (((-1) ^ (k - j)) * ((j ^ n) / (Application.WorksheetFunction.Fact(j) * Application.WorksheetFunction.Fact(k - j))))
sum = sum + subsum
Next
Sheets("Tabelle2").Cells(k, 1) = sum
sum = 0
Next
End Sub
Related
I'm trying to write a recursive function so that it calculates the sum of the products of the combinations of values in a dynamic array. Right now I've been trying to make it work for a simpler case, but I really don't quite understand the structure I should follow for a recursive function. In this case there's supposed to be the sum of 28 two factor products, resulting 1.4
Sub SuPC()
Dim k As Long
Dim s As Long
Dim i As Long
Dim j As Long
k = 8
s = 2
HSum i, j, s, k
End Sub
Function HSum(i As Long, j As Long, s, k) As Double
Dim P As Variant
Dim z() As Double
Dim Tot As Double
ReDim z(0 To (k * s) - 1)
P = Array(1 / 2, 1 / 3, 1 / 4, 1 / 5, 1 / 6, 1 / 7, 1 / 8, 1 / 9)
If i <= k Then
HSum i + 1, j, s, k
If j <= s Then
HSum i, j + 1, s, k
If z(i) = 0 Then z(i) = 1
z(i) = P(j) * z(i)
End If
Tot = z(i) + Tot
End If
Range("J11") = Tot
End Function
If s and k were low fixated values, I could use For loops but the point is for them to be variable.
You should try to use tail recursion as this is just a sum of the products,
see here an example for tail recursion factoring.
Public Function fact_tail(n As Double) As Double
'Tail Recursion
'fact 4 = 4 * fact 3
' = 4* 3 * fact 2
' = 4* 3 * 2 * fact 1
' = 4* 3 * 2 * 1
'fact 4 = go(4, 1)
' = go((n - 1), (a * n))
' = go((4-1),(1*4))
' = go(3, 4)
' = go(3-1, 3*4)
' = go(2, 12)
' = go(2-1, 12*2)
' = go(1, 24)
' = 4* 3 * 2 * 1 = 24
fact_tail = go_fact(n, 1)
End Function
Private Function go_fact(n, a)
If n <= 1 Then
go_fact = a
Else
go_fact = go_fact((n - 1), (a * n))
End If
End Function
In the code below I have an n x n x n array of values. I need to identify the indices that contain the minimum, second to minimum, third to minimum, ..., and put them into their own array to be used later on in the code. CC is currently defined as a 11 x 11 x 11 array and I need to identify the minimums. Below is the setup of my array CC that contains the values. n is defined as the length of the array h2s, which happens to be 11 in this case. h2st is the sum of the values in h2s.
h2s = [1.099, 0.988, 0.7, 0.8, 0.5, 0.432, 0.8, 1.12, 0.93, 0.77, 0.658]
h2st = 0
n = Ubound(h2s) - Lbound(h2s) + 1
For i = 1 to n
h2st = h2st + h2s(i)
Next i
For i = 1 To n
For j = i + 1 To n
For k = j + 1 To n
CC(i, j, k) = Abs(h2st - ((h2s(i) + h2s(j) + h2s(k)) * (n / 3)))
Next k
Next j
Next i
You can use this function that takes a multidimensional array and returns an array of its n minimum values, where n is a parameter. Importantly, the elements in the returned array are a data structure of Type Point, containing the coordinates and the value of each found point.
You can easily adjust it for finding the n max values, just by changing two characters in the code, as indicated in comments (the initialization and the comparison)
Option Explicit
Type Point
X As Long
Y As Long
Z As Long
value As Double
End Type
Function minVals(ar() As Double, nVals As Long) As Point()
Dim i As Long, j As Long, k As Long, m As Long, n As Long, pt As Point
'Initialize returned array with max values.
pt.value = 9999999# ' <-------- change to -9999999# for finding max
ReDim ret(1 To nVals) As Point
For i = LBound(ret) To UBound(ret): ret(i) = pt: Next
For i = LBound(ar, 1) To UBound(ar, 1)
For j = LBound(ar, 2) To UBound(ar, 2)
For k = LBound(ar, 3) To UBound(ar, 3)
' Find first element greater than this value in the return array
For m = LBound(ret) To UBound(ret)
If ar(i, j, k) < ret(m).value Then ' <------- change to > for finding max
' shift the elements on this position and insert the current value
For n = UBound(ret) To m + 1 Step -1: ret(n) = ret(n - 1): Next n
pt.X = i: pt.Y = j: pt.Z = k: pt.value = ar(i, j, k)
ret(m) = pt
Exit For
End If
Next m
Next k
Next j
Next i
minVals = ret
End Function
Sub Test()
Dim i As Long, j As Long, k As Long, pt As Point
Const n As Long = 11
ReDim CC(1 To n, 1 To n, 1 To n) As Double
For i = 1 To n
For j = 1 To n
For k = 1 To n
CC(i, j, k) = Application.RandBetween(100, 100000)
Next k
Next j
Next i
' Testing the function: get the smalles 5 values and their coordinates
Dim mins() As Point: mins = minVals(CC, 5)
' Printing the results
For i = LBound(mins) To UBound(mins)
Debug.Print mins(i).value, mins(i).X, mins(i).Y, mins(i).Z
Next
End Sub
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
I am banging my head against the wall for a while now trying different techniques.
None of them are working well.
I have two strings.
I need to compare them and get an exact percentage of match,
ie. "four score and seven years ago" TO "for scor and sevn yeres ago"
Well, I first started by comparing every word to every word, tracking every hit, and percentage = count \ numOfWords. Nope, didn't take into account misspelled words.
("four" <> "for" even though it is close)
Then I started by trying to compare every char in each char, incrementing the string char if not a match (to count for misspellings). But, I would get false hits because the first string could have every char in the second but not in the exact order of the second. ("stuff avail" <> "stu vail" (but it would come back as such, low percentage, but a hit. 9 \ 11 = 81%))
SO, I then tried comparing PAIRS of chars in each string. If string1[i] = string2[k] AND string1[i+1] = string2[k+1], increment the count, and increment the "k" when it doesn't match (to track mispellings. "for" and "four" should come back with a 75% hit.) That doesn't seem to work either. It is getting closer, but even with an exact match it is only returns 94%. And then it really gets screwed up when something is really misspelled. (Code at the bottom)
Any ideas or directions to go?
Code
count = 0
j = 0
k = 0
While j < strTempName.Length - 2 And k < strTempFile.Length - 2
' To ignore non letters or digits '
If Not strTempName(j).IsLetter(strTempName(j)) Then
j += 1
End If
' To ignore non letters or digits '
If Not strTempFile(k).IsLetter(strTempFile(k)) Then
k += 1
End If
' compare pair of chars '
While (strTempName(j) <> strTempFile(k) And _
strTempName(j + 1) <> strTempFile(k + 1) And _
k < strTempFile.Length - 2)
k += 1
End While
count += 1
j += 1
k += 1
End While
perc = count / (strTempName.Length - 1)
Edit: I have been doing some research and I think I initially found the code from here and translated it to vbnet years ago. It uses the Levenshtein string matching algorithm.
Here is the code I use for that, hope it helps:
Sub Main()
Dim string1 As String = "four score and seven years ago"
Dim string2 As String = "for scor and sevn yeres ago"
Dim similarity As Single =
GetSimilarity(string1, string2)
' RESULT : 0.8
End Sub
Public Function GetSimilarity(string1 As String, string2 As String) As Single
Dim dis As Single = ComputeDistance(string1, string2)
Dim maxLen As Single = string1.Length
If maxLen < string2.Length Then
maxLen = string2.Length
End If
If maxLen = 0.0F Then
Return 1.0F
Else
Return 1.0F - dis / maxLen
End If
End Function
Private Function ComputeDistance(s As String, t As String) As Integer
Dim n As Integer = s.Length
Dim m As Integer = t.Length
Dim distance As Integer(,) = New Integer(n, m) {}
' matrix
Dim cost As Integer = 0
If n = 0 Then
Return m
End If
If m = 0 Then
Return n
End If
'init1
Dim i As Integer = 0
While i <= n
distance(i, 0) = System.Math.Max(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Max(System.Threading.Interlocked.Increment(j), j - 1)
End While
'find min distance
For i = 1 To n
For j = 1 To m
cost = (If(t.Substring(j - 1, 1) = s.Substring(i - 1, 1), 0, 1))
distance(i, j) = Math.Min(distance(i - 1, j) + 1, Math.Min(distance(i, j - 1) + 1, distance(i - 1, j - 1) + cost))
Next
Next
Return distance(n, m)
End Function
Did not work for me unless one (or both) of following are done:
1) use option compare statement "Option Compare Text" before any Import declarations and before Class definition (i.e. the very, very first line)
2) convert both strings to lowercase using .tolower
Xavier's code must be correct to:
While i <= n
distance(i, 0) = System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Min(System.Threading.Interlocked.Increment(j), j - 1)
End While
First off, here's my code:
Sub SimulatePortfolio()
Dim lambda As Double
Dim num As Integer
Dim cycles As Long
Column = 12
q = 1.5
lambda = 0.05
cycles = 100000
Dim data(1 To 100000, 1 To 10) As Integer
Dim values(1 To 10) As Double
For i = 1 To 10
values(i) = 0
Next i
temp = lambda
For i = 1 To cycles
lambda = temp
num = 10
t = 0
Dim temps(1 To 10) As Integer
For k = 1 To 10
temps(k) = 1000
Next k
Do While (t < 10 And num > 0)
t = t + tsim(lambda, num)
For j = 1 To 10
If (j > t) Then
temps(j) = temps(j) - 50
End If
Next j
num = num - 1
If (num <= 0) Then
Exit Do
End If
lambda = lambda * q
Loop
For l = 1 To 10
values(l) = values(l) + temps(l)
data(i, l) = temps(l)
Next l
Next i
For i = 1 To 10
Cells(i + 1, Column) = values(i) / cycles
'Problem occurs on this line:
Cells(i + 1, Column + 1).Value = Application.WorksheetFunction.Var(Application.WorksheetFunction.Index(data, i, 0))
Next i
End Sub
Function tsim(lambda As Double, num As Integer) As Double
Dim v As Double
Dim min As Double
Randomize
min = (-1 / lambda) * Log(Rnd)
For i = 1 To (num - 1)
Randomize
v = (-1 / lambda) * Log(Rnd)
If (min > v) Then
min = v
End If
Next i
tsim = min
End Function
When I set the value for cycles to 10000, it runs fine without a hitch. When I go to 100000 cycles, it gets an Error 13 at the indicated line of code.
Having been aware that Application.Tranpose is limited to 65536 rows with variants (throwing the same error) I tested the same issue with Index
It appears that Application.WorksheetFunction.Index also has a limit of 65536 rows when working with variants - but standard ranges are fine
So you will need to either need to dump data to a range and work on the range with Index, or work with two arrays
Sub Test()
Dim Y
Dim Z
'works in xl07/10
Debug.Print Application.WorksheetFunction.Index(Range("A1:A100000"), 1, 1)
Y = Range("A1:A65536")
`works
Debug.Print Application.WorksheetFunction.Index(Y, 1, 1)
'fails in xl07/10
Z = Range("A1:A65537")
Debug.Print Application.WorksheetFunction.Index(Z, 1, 1)
End Sub