1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
'BubSortRows
Function BubSortRows(passVec)
Dim tmpVec() As Double, temp() As Double
uVec = passVec
rownum = UBound(uVec, 1)
colnum = UBound(uVec, 2)
ReDim tmpVec(rownum, colnum) As Double
ReDim temp(colnum) As Double
For i = rownum - 1 To 1 Step -1
For j = 1 To i
If (uVec(j, 1) > uVec(j + 1, 1)) Then
For k = 1 To colnum
temp(k) = uVec(j + 1, k)
uVec(j + 1, k) = uVec(j, k)
uVec(j, k) = temp(k)
Next k
End If
Next j
Next i
BubSortRows = uVec
End Function
'GARCH Likelihood
Function GARCHMLE(rets, startParams)
Dim VAR() As Double
n = Application.Count(rets)
ReDim VARt(n) As Double
omega = startParams(1)
alpha = startParams(2)
beta = startParams(3)
'Error Checking
If ((omega < 0) Or (alpha < 0) Or (beta < 0)) Then
GARCHMLE1 = -9999
Else
VARt(n) = Application.VAR(rets)
GARCHMLE = -Log(VARt(n)) - (rets(n) ^ 2 / VARt(n))
For cnt = n - 1 To 1 Step -1
VARt(cnt) = omega + alpha * rets(cnt + 1) ^ 2 + beta * VARt(cnt + 1)
GARCHMLE = GARCHMLE - Log(VARt(cnt)) - (rets(cnt) ^ 2 / VARt(cnt))
Next cnt
End If
GARCHMLE = -GARCHMLE
End Function
'Finds GARCH MLEs
Function GARCHparams(rets, startParams) As Variant()
GARCHparams = NelderMead("GARCHMLE", rets, startParams)
End Function
'Nelder.Mead Algorithm
Function NelderMead(fname As String, rets, startParams)
Dim resMatrix() As Double
Dim x1() As Double, xn() As Double, xw() As Double, xbar() As Double, xr() As Double, xe() As Double, xc() As Double, xcc() As Double
Dim funRes() As Double, passParams() As Double
MAXFUN = 1000
TOL = 0.0000000001
rho = 1
Xi = 2
gam = 0.5
sigma = 0.5
paramnum = Application.Count(startParams)
ReDim resmat(paramnum + 1, paramnum + 1) As Double
ReDim x1(paramnum) As Double, xn(paramnum) As Double, xw(paramnum) As Double, xbar(paramnum) As Double, xr(paramnum) As Double, xe(paramnum) As Double, xc(paramnum) As Double, xcc(paramnum) As Double
ReDim funRes(paramnum + 1) As Double, passParams(paramnum)
For i = 1 To paramnum
resmat(1, i + 1) = startParams(i)
Next i
resmat(1, 1) = Run(fname, rets, startParams)
For j = 1 To paramnum
For i = 1 To paramnum
If (i = j) Then
If (startParams(i) = 0) Then
resmat(j + 1, i + 1) = 0.05
Else
resmat(j + 1, i + 1) = startParams(i) * 1.05
End If
Else
resmat(j + 1, i + 1) = startParams(i)
End If
passParams(i) = resmat(j + 1, i + 1)
Next i
resmat(j + 1, 1) = Run(fname, rets, passParams)
Next j
For Inum = 1 To MAXFUN
resmat = BubSortRows(resmat)
If (Abs(resmat(1, 1) - resmat(paramnum + 1, 1)) < TOL) Then
Exit For
End If
f1 = resmat(1, 1)
For i = 1 To paramnum
x1(i) = resmat(1, i + 1)
Next i
fn = resmat(paramnum, 1)
For i = 1 To paramnum
xn(i) = resmat(paramnum, i + 1)
Next i
fw = resmat(paramnum + 1, 1)
For i = 1 To paramnum
xw(i) = resmat(paramnum + 1, i + 1)
Next i
For i = 1 To paramnum
xbar(i) = 0
For j = 1 To paramnum
xbar(i) = xbar(i) + resmat(j, i + 1)
Next j
xbar(i) = xbar(i) / paramnum
Next i
For i = 1 To paramnum
xr(i) = xbar(i) + rho * (xbar(i) - xw(i))
Next i
fr = Run(fname, rets, xr)
shrink = 0
If ((fr >= f1) And (fr < fn)) Then
newpoint = xr
newf = fr
ElseIf (fr < f1) Then
'calculate expansion point
For i = 1 To paramnum
xe(i) = xbar(i) + Xi * (xr(i) - xbar(i))
Next i
fe = Run(fname, rets, xe)
If (fe < fr) Then
newpoint = xe
newf = fe
Else
newpoint = xr
newf = fr
End If
ElseIf (fr >= fn) Then
If ((fr >= fn) And (fr < fw)) Then
For i = 1 To paramnum
xc(i) = xbar(i) + gam * (xr(i) - xbar(i))
Next i
fc = Run(fname, rets, xc)
If (fc <= fr) Then
newpoint = xc
newf = fc
Else
shrink = 1
End If
Else
For i = 1 To paramnum
xcc(i) = xbar(i) - gam * (xbar(i) - xw(i))
Next i
fcc = Run(fname, rets, xcc)
If (fcc < fw) Then
newpoint = xcc
newf = fcc
Else
shrink = 1
End If
End If
End If
If (shrink = 1) Then
For scnt = 2 To paramnum + 1
For i = 1 To paramnum
resmat(scnt, i + 1) = x1(i) + sigma * (resmat(scnt, i + 1) - x1(1))
passParams(i) = resmat(scnt, i + 1)
Next i
resmat(scnt, 1) = Run(fname, rets, passParams)
Next scnt
Else
For i = 1 To paramnum
resmat(paramnum + 1, i + 1) = newpoint(i)
Next i
resmat(paramnum + 1, 1) = newf
End If
Next Inum
If (Inum = MAXFUN + 1) Then
MsgBox "Maximum Iteration (" & MAXFUN & ") exeeeded"
End If
resmat = BubSortRows(resmat)
For i = 1 To paramnum + 1
funRes(i) = resmat(1, i)
Next i
funRes(1) = funRes(1)
NelderMead = Application.Transpose(funRes)
End Function
Sub garch()
Dim WS(1) As Worksheet
Set WS(1) = ThisWorkbook.Worksheets("histo S&P500")
Dim i As Integer
Dim rets() As Double
ReDim rets(1 To 10)
For i = 1 To 10
rets(i) = WS(1).Cells(2 + i, 3)
Next i
Dim startParams() As Double
ReDim startParams(1 To 3)
startParams(1) = 0.0001
startParams(2) = 0.1
startParams(3) = 1
WS(1).Cells(1, 1) = GARCHparams(rets, startParams)
End Sub |
