Sulprobil
Search…
Iman Conover
"When your work speaks for itself, don't interrupt." [Henry J. Kaiser]
A VBA solution to generate correlated numbers with the Iman Conover approach is given here. I have included this code into my sbGenerateTestData application, too. If you like to apply a worksheet function solution, go here, please.
Please read my Disclaimer.
1
Function ImanConover(rInputMatrix As Range, _
2
rTargetCorrelation As Range) As Variant
3
'Implements the Iman-Conover method to generate random
4
'number vectors with a given correlation.
5
'Algorithm as described in:
6
'Mildenham, November 27, 2005
7
'Correlation and Aggregate Loss Distributions With An
8
'Emphasis On The Iman-Conover Method
9
Dim vX As Variant 'Input matrix
10
Dim vS As Variant 'Target correlation matrix
11
Dim vC As Variant 'Cholesky decomposition of vS
12
Dim vM As Variant 'Intermediate matrix M
13
Dim vE As Variant 'Covariance matrix E
14
Dim vF As Variant 'Cholesky decomposition of vE
15
Dim vT As Variant 'Intermediate matrix T
16
Dim d As Double, dS As Double
17
Dim i As Long, j As Long, k As Long
18
Dim lRow As Long, lCol As Long
19
20
With Application.WorksheetFunction
21
vX = .Transpose(.Transpose(rInputMatrix))
22
lRow = rInputMatrix.Rows.Count
23
lCol = rInputMatrix.Columns.Count
24
25
'#############################################################################
26
'# Check inputs #
27
'#############################################################################
28
29
If lCol <> rTargetCorrelation.Columns.Count _
30
And rTargetCorrelation.Rows.Count <> rTargetCorrelation.Columns.Count Then
31
'Structure of target correlation matrix needs to fit input matrix
32
ImanConover = CVErr(xlErrNum)
33
Exit Function
34
End If
35
vS = .Transpose(.Transpose(rTargetCorrelation))
36
For i = 1 To lCol
37
If vS(i, i) <> 1# Then
38
'Target correlation matrix not 1 on diagonal
39
ImanConover = CVErr(xlErrValue)
40
Exit Function
41
End If
42
For j = 1 To i - 1
43
If vS(i, j) <> vS(j, i) Then
44
'Target correlation matrix not symmetric
45
ImanConover = CVErr(xlErrValue)
46
Exit Function
47
End If
48
Next j
49
Next i
50
51
vC = .Transpose(Cholesky2(vS))
52
53
'#############################################################################
54
'# Create intermediate matrix M #
55
'#############################################################################
56
57
ReDim vMV(1 To lRow) As Double
58
d = 0#
59
dS = 0#
60
For i = 1 To Int(lRow / 2)
61
vMV(i) = .NormSInv(i / (lRow + 1))
62
vMV(lRow - i + 1) = -vMV(i)
63
d = d + 2# * vMV(i) * vMV(i)
64
Next i
65
If lRow Mod 2 = 1 Then vMV((lRow + 1) / 2) = 0 'Just for clarity, it's already 0
66
d = Sqr(d / lRow)
67
For i = 1 To lRow
68
vMV(i) = vMV(i) / d
69
Next i
70
71
vM = vX
72
For i = 1 To lRow
73
vM(i, 1) = vMV(i)
74
Next i
75
76
Dim vMW As Variant
77
For i = 2 To lCol
78
vMW = RandomShuffle2(vMV)
79
For j = 1 To lRow
80
vM(j, i) = vMW(j)
81
Next j
82
Next i
83
84
'#############################################################################
85
'# Calculate covariance matrix E #
86
'#############################################################################
87
88
vE = vC
89
For i = 1 To lCol
90
vE(i, i) = .Covar(.Index(.Transpose(vM), i), .Index(.Transpose(vM), i))
91
For j = i + 1 To lCol
92
vE(i, j) = .Covar(.Index(.Transpose(vM), i), .Index(.Transpose(vM), j))
93
vE(j, i) = vE(i, j)
94
Next j
95
Next i
96
97
vF = .Transpose(Cholesky2(vE))
98
99
vT = .MMult(.MMult(vM, .MInverse(vF)), vC)
100
101
'#############################################################################
102
'# Compute ranks of matrix T #
103
'#############################################################################
104
105
Dim vRT As Variant, vR As Variant
106
vRT = vX
107
For j = 1 To lCol
108
vR = IndexX(lRow, vT, j)
109
For i = 1 To lRow
110
vRT(i, j) = vR(i)
111
Next i
112
vR = IndexX(lRow, vX, j)
113
For i = 1 To lRow
114
vX(i, j) = vX(vR(i), j)
115
Next i
116
Next j
117
118
'#############################################################################
119
'# Calculate result matrix Y #
120
'#############################################################################
121
122
Dim vY As Variant
123
vY = vX
124
For i = 1 To lRow
125
For j = 1 To lCol
126
vY(i, j) = vX(vRT(i, j), j)
127
Next j
128
Next i
129
130
ImanConover = vY
131
End With
132
End Function
133
134
Function IndexX(n As Long, arr As Variant, colNo As Long) As Variant
135
'Indexes an array arr[1..n], i.e., outputs the array indx[1..n] such
136
'that arr[indx[j]] is in ascending order for j = 1, 2, . . . ,n. The
137
'input quantities n and arr are not changed. Translated from [31].
138
Const m As Long = 7
139
Const NSTACK As Long = 50
140
Dim i As Long, indxt As Long, ir As Long, itemp As Long, j As Long
141
Dim k As Long, l As Long
142
Dim jstack As Long, istack(1 To NSTACK) As Long
143
Dim a As Double
144
145
ir = n
146
l = 1
147
ReDim indx(1 To n) As Long
148
For j = 1 To n
149
indx(j) = j
150
Next j
151
152
Do While 1
153
If (ir - l < m) Then
154
For j = l + 1 To ir
155
indxt = indx(j)
156
a = arr(indxt, colNo)
157
For i = j - 1 To l Step -1
158
If (arr(indx(i), colNo) <= a) Then Exit For
159
indx(i + 1) = indx(i)
160
Next i
161
indx(i + 1) = indxt
162
Next j
163
If (jstack = 0) Then Exit Do
164
ir = istack(jstack)
165
jstack = jstack - 1
166
l = istack(jstack)
167
jstack = jstack - 1
168
Else
169
k = (l + ir) / 2
170
itemp = indx(k)
171
indx(k) = indx(l + 1)
172
indx(l + 1) = itemp
173
If (arr(indx(l), colNo) > arr(indx(ir), colNo)) Then
174
itemp = indx(l)
175
indx(l) = indx(ir)
176
indx(ir) = itemp
177
End If
178
If (arr(indx(l + 1), colNo) > arr(indx(ir), colNo)) Then
179
itemp = indx(l + 1)
180
indx(l + 1) = indx(ir)
181
indx(ir) = itemp
182
End If
183
If (arr(indx(l), colNo) > arr(indx(l + 1), colNo)) Then
184
itemp = indx(l)
185
indx(l) = indx(l + 1)
186
indx(l + 1) = itemp
187
End If
188
i = l + 1
189
j = ir
190
indxt = indx(l + 1)
191
a = arr(indxt, colNo)
192
Do While 1
193
Do
194
i = i + 1
195
Loop While (arr(indx(i), colNo) < a)
196
Do
197
j = j - 1
198
Loop While (arr(indx(j), colNo) > a)
199
If (j < i) Then Exit Do
200
itemp = indx(i)
201
indx(i) = indx(j)
202
indx(j) = itemp
203
Loop
204
indx(l + 1) = indx(j)
205
indx(j) = indxt
206
jstack = jstack + 2
207
If (jstack > NSTACK) Then
208
'STACK too small in indexx
209
IndexX = CVErr(xlErrNum)
210
Exit Function
211
End If
212
If (ir - i + 1 >= j - l) Then
213
istack(jstack) = ir
214
istack(jstack - 1) = i
215
ir = j - 1
216
Else
217
istack(jstack) = j - 1
218
istack(jstack - 1) = l
219
l = i
220
End If
221
End If
222
Loop
223
IndexX = indx
224
End Function
Copied!
Mildenhall_Example_on_Iman_Conover.xlsm
52KB
Binary
Mildenhall_Example_on_Iman_Conover.xlsm
Last modified 1yr ago
Copy link