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 |
Partager