File Coverage

lib/Math/Business/BlackScholes/Binaries/Greeks/Vega.pm
Criterion Covered Total %
statement 120 123 97.5
branch 11 14 78.5
condition 2 3 66.6
subroutine 20 20 100.0
pod 0 13 0.0
total 153 173 88.4


line stmt bran cond sub pod time code
1             package Math::Business::BlackScholes::Binaries::Greeks::Vega;
2 1     1   7 use strict;
  1         2  
  1         27  
3 1     1   5 use warnings;
  1         2  
  1         42  
4              
5             our $VERSION = '0.06'; ## VERSION
6              
7             =head1 NAME
8              
9             Math::Business::BlackScholes::Binaries::Greeks::Vega
10              
11             =head1 DESCRIPTION
12              
13             Gets the Vega for different options, Vanilla and Foreign for all our bet types
14              
15             =cut
16              
17             =head1 SUBROUTINES
18              
19             See L
20              
21             =cut
22              
23 1     1   6 use List::Util qw( max );
  1         2  
  1         67  
24 1     1   7 use Math::CDF qw( pnorm );
  1         1  
  1         33  
25 1     1   5 use Math::Trig;
  1         1  
  1         174  
26 1     1   10 use Math::Business::BlackScholesMerton::Binaries;
  1         3  
  1         51  
27 1     1   7 use Math::Business::BlackScholes::Binaries::Greeks::Math qw( dgauss );
  1         2  
  1         1746  
28              
29             sub vanilla_call {
30 36     36 0 3878 my ($S, $K, $t, $r_q, $mu, $vol) = @_;
31              
32 36         112 my $d1 = (log($S / $K) + ($mu + $vol * $vol / 2.0) * $t) / ($vol * sqrt($t));
33 36         119 my $vega = $S * sqrt($t) * exp(($mu - $r_q) * $t) * dgauss($d1);
34 36         79 return $vega;
35             }
36              
37             sub vanilla_put {
38 6     6 0 3634 my ($S, $K, $t, $r_q, $mu, $vol) = @_;
39              
40             # Same as vega of vanilla call
41 6         16 return vanilla_call($S, $K, $t, $r_q, $mu, $vol);
42             }
43              
44             sub call {
45 16     16 0 3938 my ($S, $U, $t, $r_q, $mu, $vol) = @_;
46              
47 16         82 my $d1 = (log($S / $U) + ($mu + $vol * $vol / 2.0) * $t) / ($vol * sqrt($t));
48 16         32 my $d2 = $d1 - $vol * sqrt($t);
49 16         63 my $vega = -exp(-$r_q * $t) * dgauss($d2) * $d1 / $vol;
50 16         53 return $vega;
51             }
52              
53             sub put {
54 16     16 0 3970 my ($S, $D, $t, $r_q, $mu, $vol) = @_;
55              
56 16         61 my $d1 = (log($S / $D) + ($mu + $vol * $vol / 2.0) * $t) / ($vol * sqrt($t));
57 16         31 my $d2 = $d1 - $vol * sqrt($t);
58 16         53 my $vega = exp(-$r_q * $t) * dgauss($d2) * $d1 / $vol;
59 16         49 return $vega;
60             }
61              
62             sub expirymiss {
63 10     10 0 4112 my ($S, $U, $D, $t, $r_q, $mu, $vol) = @_;
64              
65 10         32 return call($S, $U, $t, $r_q, $mu, $vol) + put($S, $D, $t, $r_q, $mu, $vol);
66             }
67              
68             sub expiryrange {
69 5     5 0 3123 my ($S, $U, $D, $t, $r_q, $mu, $vol) = @_;
70              
71 5         16 return -1 * expirymiss($S, $U, $D, $t, $r_q, $mu, $vol);
72             }
73              
74             sub onetouch {
75 13     13 0 4490 my ($S, $U, $t, $r_q, $mu, $vol, $w) = @_;
76              
77 13 100       40 if (not defined $w) {
78 7         10 $w = 0;
79             }
80              
81 13         25 my $sqrt_t = sqrt($t);
82              
83 13         37 my $theta = ($mu / $vol) + (0.5 * $vol);
84              
85 13         24 my $theta_ = ($mu / $vol) - (0.5 * $vol);
86              
87             # Floor v_ squared at just above zero in case negative interest rates push it negative.
88 13         88 my $v_ = sqrt(max($Math::Business::BlackScholesMerton::Binaries::SMALL_VALUE_MU, ($theta_ * $theta_) + (2 * (1 - $w) * $r_q)));
89              
90 13         54 my $e = (log($S / $U) - ($vol * $v_ * $t)) / ($vol * $sqrt_t);
91              
92 13         34 my $e_ = (-log($S / $U) - ($vol * $v_ * $t)) / ($vol * $sqrt_t);
93              
94 13 100       42 my $eta = ($S > $U) ? 1 : -1;
95              
96 13         38 my $pa_e = (log($U / $S) / ($vol * $vol * $sqrt_t)) + (($theta_ * $theta) / ($vol * $v_) * $sqrt_t);
97 13         33 my $pa_e_ = (-log($U / $S) / ($vol * $vol * $sqrt_t)) + (($theta_ * $theta) / ($vol * $v_) * $sqrt_t);
98 13         30 my $A = -($theta + $theta_ + ($theta_ * $theta / $v_) + $v_) / ($vol * $vol);
99 13         31 my $A_ = -($theta + $theta_ - ($theta_ * $theta / $v_) - $v_) / ($vol * $vol);
100              
101 13         111 my $part1 =
102             pnorm(-$eta * $e) * $A * log($U / $S) - $eta * dgauss($e) * $pa_e;
103 13         56 my $part2 =
104             pnorm($eta * $e_) * $A_ * log($U / $S) + $eta * dgauss($e_) * $pa_e_;
105 13         48 my $vega = (($U / $S)**(($theta_ + $v_) / $vol)) * $part1 + (($U / $S)**(($theta_ - $v_) / $vol)) * $part2;
106              
107 13         43 return $vega * exp(-$w * $r_q * $t);
108             }
109              
110             sub notouch {
111 6     6 0 4663 my ($S, $U, $t, $r_q, $mu, $vol, $w) = @_;
112              
113             # No touch bet always pay out at end
114 6         15 $w = 1;
115              
116 6         21 return -1 * onetouch($S, $U, $t, $r_q, $mu, $vol, $w);
117             }
118              
119             sub upordown {
120 13     13 0 4868 my ($S, $U, $D, $t, $r_q, $mu, $vol, $w) = @_;
121              
122             # $w = 0, paid at hit
123             # $w = 1, paid at end
124 13 100       38 if (not defined $w) { $w = 0; }
  7         14  
125              
126 13         45 return ot_up_ko_down_pelsser_1997($S, $U, $D, $t, $r_q, $mu, $vol, $w) + ot_down_ko_up_pelsser_1997($S, $U, $D, $t, $r_q, $mu, $vol, $w);
127             }
128              
129             sub w_common_function_pelsser_1997 {
130 78     78 0 199 my ($S, $U, $D, $t, $r_q, $mu, $vol, $w, $eta) = @_;
131              
132 78         120 my $pi = Math::Trig::pi;
133              
134 78         141 my $h = log($U / $D);
135 78         115 my $x = log($S / $D);
136              
137             # $eta = 1, onetouch up knockout down
138             # $eta = 0, onetouch down knockout up
139             # This variable used to check stability
140 78 50       199 if (not defined $eta) {
141 0         0 die
142             "$0: (w_common_function_pelsser_1997) Wrong usage of this function for S=$S, U=$U, D=$D, t=$t, r_q=$r_q, mu=$mu, vol=$vol, w=$w. eta not defined.";
143             }
144 78 100       178 if ($eta == 0) { $x = $h - $x; }
  39         54  
145              
146 78         149 my $r_dash = $r_q * (1 - $w);
147 78         126 my $mu_new = $mu - (0.5 * $vol * $vol);
148 78         225 my $mu_dash = sqrt(max($Math::Business::BlackScholesMerton::Binaries::SMALL_VALUE_MU, ($mu_new * $mu_new) + (2 * $vol * $vol * $r_dash)));
149              
150 78         129 my $omega = ($vol * $vol);
151              
152 78         118 my $series_part = 0;
153 78         100 my $hyp_part = 0;
154              
155 78         190 my $stability_constant =
156             Math::Business::BlackScholesMerton::Binaries::get_stability_constant_pelsser_1997($S, $U, $D, $t, $r_q, $mu, $vol, $w, $eta, 1);
157              
158 78         1614 my $iterations_required = Math::Business::BlackScholesMerton::Binaries::get_min_iterations_pelsser_1997($S, $U, $D, $t, $r_q, $mu, $vol, $w);
159              
160 78         5982 for (my $k = 1; $k < $iterations_required; $k++) {
161 1710         3041 my $lambda_k_dash = (0.5 * (($mu_dash * $mu_dash) / $omega + ($k * $k * $pi * $pi * $vol * $vol) / ($h * $h)));
162              
163             # d{lambda_k}/dw
164 1710         2963 my $dlambdak_domega = 0.5 * (-($mu_new / $omega) - (($mu_new * $mu_new) / ($omega * $omega)) + (($k * $k * $pi * $pi) / ($h * $h)));
165              
166 1710         2559 my $beta_k = exp(-$lambda_k_dash * $t) / $lambda_k_dash;
167              
168             # d{beta_k}/d{lambda_k}
169 1710         2820 my $dbetak_dlambdak = -exp(-$lambda_k_dash * $t) * (($t * $lambda_k_dash + 1) / ($lambda_k_dash**2));
170              
171             # d{beta_k}/dw
172 1710         2124 my $dbetak_domega = $dlambdak_domega * $dbetak_dlambdak;
173              
174 1710         2674 my $phi =
175             (1.0 / ($h * $h)) * ($omega * $dbetak_domega + $beta_k) * $k;
176              
177 1710         2929 $series_part += $phi * $pi * sin($k * $pi * ($h - $x) / $h);
178              
179             #
180             # For vega, the stability function is 2* $vol * $phi, for volga/vanna it is different,
181             # but we shall ignore for now.
182             #
183 1710 50 66     4298 if ($k == 1
184             and (not(abs(2 * $vol * $phi) < $stability_constant)))
185             {
186 0         0 die
187             "$0: PELSSER VEGA formula for S=$S, U=$U, D=$D, t=$t, r_q=$r_q, mu=$mu, vol=$vol, w=$w, eta=$eta cannot be evaluated because PELSSER VEGA stability conditions (2 * $vol * $phi less than $stability_constant) not met. This could be due to barriers too big, volatilities too low, interest/dividend rates too high, or machine accuracy too low.";
188             }
189             }
190              
191 78         124 my $alpha = $mu_dash / ($vol * $vol);
192 78         161 my $dalpha_domega = -(($mu_new * $omega) + (2 * $mu_new * $mu_new) + (2 * $r_dash * $omega)) / (2 * $alpha * $omega * $omega * $omega);
193              
194             # We have to handle the special case where the denominator approaches 0, see our documentation in
195             # quant/Documents/Breakout_bet.tex under the SVN "quant" module.
196 78 50       214 if ((Math::Trig::sinh($alpha * $h)**2) == 0) {
197 0         0 $hyp_part = 0;
198             } else {
199 78         962 $hyp_part =
200             ($dalpha_domega / (2 * (Math::Trig::sinh($alpha * $h)**2))) *
201             (($h + $x) * Math::Trig::sinh($alpha * ($h - $x)) - ($h - $x) * Math::Trig::sinh($alpha * ($h + $x)));
202             }
203              
204 78         2112 my $dc_domega = ($hyp_part - $series_part) * exp(-$r_q * $w * $t);
205              
206 78         194 return $dc_domega;
207             }
208              
209             sub ot_up_ko_down_pelsser_1997 {
210 13     13 0 34 my ($S, $U, $D, $t, $r_q, $mu, $vol, $w) = @_;
211              
212 13         33 my $mu_new = $mu - (0.5 * $vol * $vol);
213 13         38 my $h = log($U / $D);
214 13         24 my $x = log($S / $D);
215 13         25 my $omega = ($vol * $vol);
216              
217 13         55 my $c = Math::Business::BlackScholesMerton::Binaries::common_function_pelsser_1997($S, $U, $D, $t, $r_q, $mu, $vol, $w, 1);
218 13         3582 my $dc_domega = w_common_function_pelsser_1997($S, $U, $D, $t, $r_q, $mu, $vol, $w, 1);
219              
220 13         49 my $dVu_domega =
221             -((0.5 * $omega + $mu_new) * ($h - $x) / ($omega * $omega)) * $c;
222 13         21 $dVu_domega += $dc_domega;
223 13         30 $dVu_domega *= exp($mu_new * ($h - $x) / $omega);
224              
225 13         49 return $dVu_domega * (2 * $vol);
226             }
227              
228             sub ot_down_ko_up_pelsser_1997 {
229 13     13 0 41 my ($S, $U, $D, $t, $r_q, $mu, $vol, $w) = @_;
230              
231 13         22 my $mu_new = $mu - (0.5 * $vol * $vol);
232 13         28 my $x = log($S / $D);
233 13         26 my $omega = ($vol * $vol);
234              
235 13         35 my $c = Math::Business::BlackScholesMerton::Binaries::common_function_pelsser_1997($S, $U, $D, $t, $r_q, $mu, $vol, $w, 0);
236 13         3690 my $dc_domega = w_common_function_pelsser_1997($S, $U, $D, $t, $r_q, $mu, $vol, $w, 0);
237              
238 13         33 my $dVl_domega =
239             ((0.5 * $omega + $mu_new) * $x / ($omega * $omega)) * $c;
240 13         21 $dVl_domega += $dc_domega;
241 13         25 $dVl_domega *= exp(-$mu_new * $x / $omega);
242              
243 13         44 return $dVl_domega * (2 * $vol);
244             }
245              
246             sub range {
247 6     6 0 4281 my ($S, $U, $D, $t, $r_q, $mu, $vol, $w) = @_;
248              
249             # Range always pay out at end
250 6         13 $w = 1;
251              
252 6         22 return -1 * upordown($S, $U, $D, $t, $r_q, $mu, $vol, $w);
253             }
254              
255             1;
256