Codebase list fextremes / 2ed2404
Import Debian changes 221.10065-1 fextremes (221.10065-1) unstable; urgency=low * New upstream release * debian/watch: One more fix for regular expression Dirk Eddelbuettel 5 years ago
101 changed file(s) with 15742 addition(s) and 12637 deletion(s). Raw diff Collapse all Expand all
+4
-4
DESCRIPTION less more
00 Package: fExtremes
1 Version: 220.10063
2 Date: 1996 - 2005
3 Title: Financial Software Collection - fExtremes
1 Version: 221.10065
2 Date: 1996 - 2006
3 Title: Rmetrics - Extreme Financial Market Data
44 Author: Diethelm Wuertz and many others, see the SOURCE file
55 Depends: R (>= 1.9.0), methods, fBasics, fCalendar, fSeries, fMultivar
66 Maintainer: Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
1010 "Financial Engineering and Computational Finance"
1111 License: GPL Version 2 or later
1212 URL: http://www.rmetrics.org
13 Packaged: Wed Nov 2 08:26:53 2005; myself
13 Packaged: Mon Feb 20 14:46:25 2006; myself
+1159
-0
R/051A-ExtremesData.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION PART I: Explorative Data Analysis
31 # emdPlot Plots empirical distribution function
32 # qqPlot Creates a quantile-quantile plot
33 # qqbayesPlot Creates qq-Plot with 95 percent intervals
34 # qPlot Creates exploratory QQ plot for EV analysis
35 # mePlot Creates a sample mean excess plot
36 # mxfPlot Plots the mean excess function
37 # mrlPlot Returns a mean residual life plot with confidence levels
38 # recordsPlot Plots records development
39 # ssrecordsPlot Plots records development of data subsamples
40 # msratioPlot Plots ratio of maximums and sums
41 # .sllnPlot Verify Kolmogorov's Strong Law of large Numbers
42 # .lilPlot Verify Hartman-Wintner's Law of the iterated logarithm
43 # xacfPlot Plots autocorrelations of exceedences
44 # interactivePlot Plots several graphs interactively
45 # gridVector Creates from two vectors rectangular grid points
46 ################################################################################
47
48
49 ################################################################################
50 # FUNCTION PART II: Data Preprocessing:
51 # findThreshold Finds extreme values above a threshold
52 # blocks Creates data blocks on vectors and time series
53 # blockMaxima Calculates block maxima on vectors and time series
54 # deCluster Declusters a point process
55 ################################################################################
56
57
58 # PART I:
59
60
61 emdPlot =
62 function(x, doplot = TRUE, plottype = c("", "x", "y", "xy"),
63 labels = TRUE, ...)
64 { # A function imported from R-package evir
65
66 # Description:
67 # Plots empirical distribution function
68
69 # Arguments:
70 # plottype - which axes should be on a log scale:
71 # "x" denotes x-axis only; "y" denotes y-axis only,
72 # "xy" || "yx" both axes, "" denotes neither of the
73 # axis
74
75 # FUNCTION:
76
77 # Settings:
78 alog = plottype[1]
79
80 # Convert from univariate 'timSeries':
81 if (is.timeSeries(x)) x = as.vector(x)
82
83 # Convert x to a vector, if the input is a data.frame.
84 if (is.data.frame(x)) x = x[,1]
85 xs = x = sort(as.numeric(x))
86 ys = y = 1 - ppoints(x)
87
88 if (plottype == "x") {
89 xs = x[x > 0]
90 ys = y[x > 0] }
91 if (plottype == "y") {
92 xs = x[y > 0]
93 ys = y[y > 0] }
94 if (plottype == "xy") {
95 xs = x[x > 0 & y > 0]
96 ys = y[x > 0 & y > 0] }
97
98 # Plot:
99 if (doplot) {
100 if (labels) {
101 xlab = "x"
102 ylab = "1-F(x)"
103 main = "Empirical Distribution" }
104 else {
105 xlab = ""
106 ylab = ""
107 main = "" }
108 plot(xs, ys, log = alog, xlab = xlab, ylab = ylab, main = main, ...)
109 if (labels) grid()
110 }
111
112 # Result:
113 result = data.frame(x, y)
114
115 # Return Value:
116 if (doplot) return(invisible(result)) else return(result)
117 }
118
119
120 # ------------------------------------------------------------------------------
121
122
123 qqPlot =
124 function (x, doplot = TRUE, labels = TRUE, ...)
125 { # A function written by Diethelm Wuertz
126
127 # Description:
128 # Creates Quantile-Quantile Plot
129
130 # FUNCTION:
131
132 # Convert from univariate 'timSeries':
133 if (is.timeSeries(x)) x = as.vector(x)
134
135 # Convert x to a vector, if the input is a data.frame.
136 if (is.data.frame(x)) x = x[, 1]
137
138 # Plot:
139 if (doplot) {
140 if (labels) {
141 xlab = "Normal Quantiles"
142 ylab = "Empirical Quantiles"
143 main = "Normal QQ-Plot"
144 print(main) }
145 else {
146 xlab = ""
147 ylab = ""
148 main = "" }
149 qqnorm(x, xlab = xlab, ylab = ylab, main = main, ...)
150 qqline(x)
151 if (labels) grid()
152 }
153
154 # Return Value:
155 if (doplot) return(invisible(x)) else return(x)
156 }
157
158
159 # ------------------------------------------------------------------------------
160
161
162 qqbayesPlot =
163 function(x, doplot = TRUE, labels = TRUE, ...)
164 { # A function implemented by Diethelm Wuertz
165
166 # Description:
167 # Example of a Normal quantile plot of data x to provide a visual
168 # assessment of its conformity with a normal (data is standardised
169 # first).
170
171 # Details:
172 # The ordered data values are posterior point estimates of the
173 # underlying quantile function. So, if you plot the ordered data
174 # values (y-axis) against the exact theoretical quantiles (x-axis),
175 # you get a scatter that should be close to a straight line if the
176 # data look like a random sample from the theoretical distribution.
177 # This function chooses the normal as the theory, to provide a
178 # graphical/visual assessment of how normal the data appear.
179 # To help with assessing the relevance of sampling variability on
180 # just "how close" to the normal the data appears, we add (very)
181 # approximate posterior 95% intervals for the uncertain quantile
182 # function at each point (Based on approximate theory) .
183
184 # Author:
185 # Prof. Mike West, mw@stat.duke.edu
186
187 # Note:
188 # Source from
189 # http://www.stat.duke.edu/courses/Fall99/sta290/Notes/
190
191 # FUNCTION:
192
193 # Convert from univariate 'timSeries':
194 if (is.timeSeries(x)) x = as.vector(x)
195
196 # Settings:
197 mydata = x
198 n = length(mydata)
199 p = (1:n)/(n+1)
200 x = (mydata-mean(mydata))/sqrt(var(mydata))
201 x = sort(x)
202 z = qnorm(p)
203
204 # Plot:
205 if (doplot) {
206 if (labels) {
207 xlab = "Standard Normal Quantiles"
208 ylab = "Ordered Data"
209 main = "Normal QQ-Plot with 95% Intervals" }
210 else {
211 xlab = ""
212 ylab = ""
213 main = "" }
214 plot(z, x, xlab = xlab, ylab = ylab, main = main, ...)
215 abline(0, 1, col = "steelblue")
216 if (labels) grid()
217 }
218
219 # 95% Intervals:
220 s = 1.96*sqrt(p*(1-p)/n)
221 pl = p-s; i = pl<1&pl>0
222 lower = quantile(x, probs = pl[i])
223 if (doplot) lines(z[i], lower, col = 3)
224 pl = p+s; i = pl < 1 & pl > 0
225 upper = quantile(x, probs = pl[i])
226 if (doplot) lines(z[i], upper, col = 3)
227
228 # Result:
229 result = data.frame(lower, upper)
230
231 # Return Value:
232 if (doplot) return(invisible(result)) else return(result)
233 }
234
235
236 # ------------------------------------------------------------------------------
237
238
239 qPlot =
240 function(x, xi = 0, trim = NA, threshold = NA, doplot = TRUE,
241 labels = TRUE, ...)
242 { # A function imported from R-package evir
243
244 # Description:
245 # Creates an exploratory QQplot for Extreme Value Analysis.
246
247 # FUNCTION:
248
249 # Convert from univariate 'timSeries':
250 if (is.timeSeries(x)) x = as.vector(x)
251
252 # Settings:
253 line = TRUE
254
255 # Convert x to a vector, if the input is a data.frame.
256 if(is.data.frame(x)) x = x[,1]
257 x = as.numeric(x)
258 if (!is.na(threshold)) x = x[x >= threshold]
259 if (!is.na(trim)) x = x[x < trim]
260 if (xi == 0) {
261 y = qexp(ppoints(x)) }
262 if( xi != 0) {
263 y = qgpd(ppoints(x), xi = xi) }
264
265 # Plot:
266 if (doplot) {
267 if (labels) {
268 xlab = "Ordered Data"
269 ylab = "Quantiles"
270 if (xi == 0) {
271 ylab = paste("Exponential", ylab) }
272 if (xi != 0) {
273 ylab = paste("GPD(xi=", xi, ") ", ylab, sep = "") }
274 main = "Exploratory QQ Plot" }
275 else {
276 xlab = ""
277 ylab = ""
278 main = "" }
279 plot(sort(x), y, xlab = xlab, ylab = ylab, main = main, ...)
280 if (line) abline(lsfit(sort(x), y))
281 if (labels) grid()
282 }
283
284 # Result:
285 result = data.frame(x = sort(x), y)
286
287 # Return Value:
288 if (doplot) return(invisible(result)) else return(result)
289 }
290
291
292 # ------------------------------------------------------------------------------
293
294
295 mxfPlot =
296 function (x, tail = 0.05, doplot = TRUE, labels = TRUE, ...)
297 { # A function written by D. Wuertz
298
299 # Description:
300 # Creates a simple mean excess function plot.
301
302 # FUNCTION:
303
304 # Convert from univariate 'timSeries':
305 if (is.timeSeries(x)) x = as.vector(x)
306
307 # Convert x to a vector, if the input is a data.frame.
308 if(is.data.frame(x)) x = x[,1]
309 u = rev(sort(x))
310 n = length(x)
311 u = u[1:floor(tail*n)]
312 n = length(u)
313 e = (cumsum(u)-(1:n)*u)/(1:n)
314
315 # Plot
316 if (doplot) {
317 if (labels) {
318 xlab = "Threshold: u"
319 ylab = "Mean Excess: e"
320 main = "Mean Excess Function" }
321 else {
322 xlab = ""
323 ylab = ""
324 main = "" }
325 plot (u, e, xlab = xlab, ylab = ylab, main = main, ...)
326 if (labels) grid()
327 }
328
329 # Result:
330 result = data.frame(threshold = u, excess = e)
331
332 # Return Values:
333 if (doplot) return(invisible(result)) else return(result)
334 }
335
336
337 # ------------------------------------------------------------------------------
338
339
340 mrlPlot =
341 function(x, conf = 0.95, umin = NA, umax=NA, nint = 100,
342 doplot = TRUE, plottype = c("autoscale", ""), labels = TRUE, ...)
343 { # A function implemented by Diethelm Wuertz
344
345 # Description:
346 # Create a mean residual life plot with
347 # confidence intervals.
348
349 # Note:
350 # "autoscale" added by DW.
351
352 # References:
353 # A function originally written by S. Coles
354
355 # FUNCTION:
356
357 # Convert from univariate 'timSeries':
358 if (is.timeSeries(x)) x = as.vector(x)
359
360 # Settings:
361 plottype = plottype[1]
362 if (plottype == "autoscale") {
363 autoscale = TRUE }
364 else {
365 autoscale = FALSE }
366
367 # Convert x to a vector, if the input is a data.frame.
368 if (is.data.frame(x)) x = x[,1]
369 if (is.na(umin)) umin = mean(x)
370 if (is.na(umax)) umax = max(x)
371 sx = xu = xl = rep(NA, nint)
372 u = seq(umin, umax, length = nint)
373 for(i in 1:nint) {
374 x = x[x >= u[i]]
375 sx[i] = mean(x - u[i])
376 sdev = sqrt(var(x))
377 n = length(x)
378 xu[i] = sx[i] + (qnorm((1 + conf)/2) * sdev)/sqrt(n)
379 xl[i] = sx[i] - (qnorm((1 + conf)/2) * sdev)/sqrt(n) }
380
381 # Plot:
382 if (doplot) {
383 if (labels) {
384 xlab = "Threshold: u"
385 ylab = "Mean Excess: e"
386 main = "Mean Residual Live Plot"
387 } else {
388 xlab = ""
389 ylab = ""
390 main = ""
391 }
392 if (autoscale) {
393 ylim = c(min(xl[!is.na(xl)]), max(xu[!is.na(xu)]))
394 plot(u, sx, type = "l", lwd = 2, xlab = xlab,
395 ylab = ylab, ylim = ylim, main = main, ...)
396 } else {
397 plot(u[!is.na(xl)], sx[!is.na(xl)], type = "l",
398 lwd = 2, xlab = xlab, ylab = ylab, main = main, ...)
399 }
400 lines(u[!is.na(xl)], xl[!is.na(xl)], col = "steelblue")
401 lines(u[!is.na(xu)], xu[!is.na(xu)], col = "steelblue")
402 if (labels) grid()
403 }
404
405 # Result
406 result = data.frame(threshold = u, mrl = sx)
407
408 # Return Value:
409 if (doplot) return(invisible(result)) else return(result)
410 }
411
412
413 # ------------------------------------------------------------------------------
414
415
416 mePlot =
417 function(x, doplot = TRUE, labels = TRUE, ...)
418 { # A function implemented by Diethelm Wuertz
419
420 # Description:
421 # Create a Mean Excess Plot
422
423 # Reference:
424 # A function imported from R-package evir
425
426 # FUNCTION:
427
428 # Convert from univariate 'timSeries':
429 if (is.timeSeries(x)) x = as.vector(x)
430
431 # Settings:
432 omit = 0
433
434 # Internal Function:
435 myrank = function(x, na.last = TRUE){
436 ranks = sort.list(sort.list(x, na.last = na.last))
437 if(is.na(na.last))
438 x = x[!is.na(x)]
439 for(i in unique(x[duplicated(x)])) {
440 which = x == i & !is.na(x)
441 ranks[which] = max(ranks[which]) }
442 ranks }
443
444 # Convert x to a vector, if the input is a data.frame.
445 if(is.data.frame(x)) x = x[,1]
446 x = as.numeric(x)
447 n = length(x)
448 x = sort(x)
449 n.excess = unique(floor(length(x) - myrank(x)))
450 points = unique(x)
451 nl = length(points)
452 n.excess = n.excess[-nl]
453 points = points[-nl]
454 excess = cumsum(rev(x))[n.excess] - n.excess * points
455 y = excess/n.excess
456 xx = points[1:(nl-omit)]
457 yy = y[1:(nl-omit)]
458
459 # Plot:
460 if (doplot) {
461 if (labels) {
462 xlab = "Threshold: u"
463 ylab = "Mean Excess: e"
464 main = "Mean Excess Plot" }
465 else {
466 xlab = ""
467 ylab = ""
468 main = "" }
469 plot(xx, yy, xlab = xlab, ylab = ylab, main = main, ...)
470 if (labels) grid()
471 }
472
473 # Results:
474 result = data.frame(threshold = xx, me = yy)
475
476 # Return Value:
477 if (doplot) return(invisible(result)) else return(result)
478
479 }
480
481
482 # -----------------------------------------------------------------------------
483
484
485 recordsPlot =
486 function(x, conf = 0.95, doplot = TRUE, labels = TRUE, ...)
487 { # A function implemented by Diethelm Wuertz
488
489 # Description:
490 # Creates a records plot.
491
492 # Note:
493 # A function imported from R-package evir,
494 # original name in EVIR: records
495
496 # FUNCTION:
497
498 # Convert from univariate 'timSeries':
499 if (is.timeSeries(x)) x = as.vector(x)
500
501 # Settings:
502 conf.level = conf
503
504 # Convert x to a vector, if the input is a data.frame.
505 if (is.data.frame(x)) x = x[,1]
506
507 # Records:
508 record = cummax(x)
509 expected = cumsum(1/(1:length(x)))
510 se = sqrt(expected - cumsum(1/((1:length(x))^2)))
511 trial = (1:length(x))[!duplicated(record)]
512 record = unique(record)
513 number = 1:length(record)
514 expected = expected[trial]
515 se = se[trial]
516
517 # Plot:
518 if (doplot) {
519 if (labels) {
520 xlab = "Trials"
521 ylab = "Records"
522 main = "Plot of Record Development" }
523 else {
524 xlab = ""
525 ylab = ""
526 main = "" }
527 ci = qnorm(0.5 + conf.level/2)
528 upper = expected + ci * se
529 lower = expected - ci * se
530 lower[lower < 1] = 1
531 yr = range(upper, lower, number)
532 plot(trial, number, log = "x", ylim = yr,
533 xlab = xlab, ylab = ylab, main = main, ...)
534 lines(trial, expected)
535 lines(trial, upper, lty = 2)
536 lines(trial, lower, lty = 2)
537 if (labels) grid()
538 }
539
540 # Result:
541 result = data.frame(number, record, trial, expected, se)
542
543 # Return Value:
544 if (doplot) return(invisible(result)) else return(result)
545 }
546
547
548 # ------------------------------------------------------------------------------
549
550
551 ssrecordsPlot =
552 function (x, subsamples = 10, doplot = TRUE, plottype = c("lin", "log"),
553 labels = TRUE, ...)
554 { # A function implemented by Diethelm Wuertz
555
556 # Description:
557 # Creates a plot of records on subsamples.
558
559 # note:
560 # Changes:
561 # 2003/09/06 - argument list made consistent
562
563 # FUNCTION:
564
565 # Convert from univariate 'timSeries':
566 if (is.timeSeries(x)) x = as.vector(x)
567
568 # Convert x to a vector, if the input is a data.frame.
569 if(is.data.frame(x)) x = x[, 1]
570
571 # Plot type:
572 plottype = plottype[1]
573
574 # Records:
575 save = x
576 cluster = floor(length(save)/subsamples)
577 records = c()
578 for (i in 1:subsamples) {
579 x = save[((i-1)*cluster+1):(i*cluster)]
580 y = 1:length(x)
581 u = x[1]
582 v = x.records = 1
583 while (!is.na(v)) {
584 u = x[x > u][1]
585 v = y[x > u][1]
586 if(!is.na(v)) x.records = c(x.records, v)
587 }
588 if (i == 1) {
589 nc = 1:length(x)
590 csmean = cumsum(1/nc)
591 cssd = sqrt(cumsum(1/nc-1/(nc*nc)))
592 ymax = csmean[length(x)]+2*cssd[length(x)]
593 # Plot:
594 if (doplot) {
595 if (plottype == "log") nc = log(nc)
596 if (labels) {
597 if (plottype == "lin") xlab = "n"
598 if (plottype == "log") xlab = "log(n)"
599 ylab = "N(n)"
600 }
601 main = "Subsample Records Plot"
602 plot (nc, csmean+cssd, type = "l", ylim = c(0, ymax),
603 xlab = xlab, ylab = ylab, main = main, ...)
604 grid()
605 } else {
606 plot (nc, csmean+cssd, type = "l", ylim = c(0, ymax), ...)
607 }
608 lines(nc, csmean, col = "steelblue")
609 lines(nc, csmean-cssd, col = "steelblue")
610 }
611 y.records = 1:length(x.records)
612 x.records = x.records[y.records < ymax]
613 if (doplot) {
614 if (plottype == "log") x.records = log(x.records)
615 points(x.records, y.records[y.records<ymax], pch = i)
616 }
617 records[i] = y.records[length(y.records)]
618 }
619
620 # Result:
621 subsample = 1:subsamples
622 result = data.frame(subsample, records)
623
624 # Return Value:
625 if (doplot) return(invisible(result)) else return(result)
626 }
627
628
629 # ------------------------------------------------------------------------------
630
631
632 msratioPlot =
633 function (x, p = 1:4, doplot = TRUE, plottype = c("autoscale", ""),
634 labels = TRUE, ...)
635 { # A function implemented by Diethelm Wuertz
636
637 # Description:
638 # Creates a Plot of maximum and sum ratio.
639
640 # FUNCTION:
641
642 # Convert from univariate 'timSeries':
643 if (is.timeSeries(x)) x = as.vector(x)
644
645 # Settings:
646 plottype = plottype[1]
647 if (plottype == "autoscale") {
648 autoscale = TRUE }
649 else {
650 autoscale = FALSE }
651 if (autoscale) ylim = c(0,1)
652
653 # Convert x to a vector, if the input is a data.frame.
654 if(is.data.frame(x)) x = x[,1]
655
656 # Plot:
657 if (doplot) {
658 if (labels) {
659 xlab = "Trials"
660 ylab = "Records"
661 main = "Plot of Record Development" }
662 else {
663 xlab = ""
664 ylab = ""
665 main = "" }
666 if (autoscale) {
667 plot(c(0, length(x)), y = ylim, xlab = xlab,
668 ylab = ylab, main = main, type = "n", ...) }
669 else {
670 plot(c(0, length(x)), xlab = xlab,
671 ylab = ylab, main = main, type = "n", ...) }
672 if (labels) grid()
673 }
674
675 # Color numbering:
676 i = 1
677
678 # Suppress warnings for points outside the frame:
679 ratios = matrix(rep(0, times=length(x)*length(p)), byrow=TRUE,
680 ncol=length(p))
681 if (doplot) par(err=-1)
682
683 # Loop over all exponents p:
684 for (q in p) {
685 rnp = cummax(abs(x)^q) / cumsum(abs(x)^q)
686 i = i + 1
687 ratios[,q] = rnp
688 if (doplot) lines (rnp, col=i) }
689
690 # Result:
691 result = data.frame(ratios)
692
693 # Return Value:
694 if (doplot) return(invisible(result)) else return(result)
695 }
696
697
698 # ------------------------------------------------------------------------------
699
700
701 .sllnPlot =
702 function (x, mean = NULL, main = "SLLN", ...)
703 { # A function written by Diethelm Wuertz
704
705 # Description:
706 # Verify Kolmogorov's Strong Law of large Numbers
707
708 # Arguments:
709 # x - sequence of iid non-degenerate rvs.
710
711 # References:
712 # Embrechts et al. p. 61, Theorem 2.1.3
713
714 # FUNCTION:
715
716 # Verify SLLN:
717 if (is.null(mean)) mean=mean(cumsum(x)/(1:length(x)))
718 nx = length(x)
719 plot(cumsum(x)/(1:nx), xlab = "n", ylab = "x", type = "l", main = main, ...)
720 lines(c(0, nx), c(mu, mu), col = 2)
721 y = cumsum(x)/(1:nx)
722
723 # Return Value:
724 invisible(y)
725 }
726
727
728 # ------------------------------------------------------------------------------
729
730
731 .lilPlot =
732 function (x, mean = NULL, sd = NULL, main = "LIL", ...)
733 { # A function written by Diethelm Wuertz
734
735 # Description:
736 # Verify Hartman-Wintner's Law of the iterated logarithm
737
738 # Arguments:
739 # x - sequence of iid non-degenerate rvs.
740
741 # References:
742 # Embrechts et al. p. 67. Theorem 2.1.13
743
744 # FUNCTION:
745
746 # Verify LIL:
747 lx = length(x)
748 nx = 1:lx
749 fact = sqrt(2*nx*log(log(nx)))
750 if (is.null(mean)) mean = mean(cumsum(x))
751 if (is.null(sd)) sd = sqrt(var(x))
752 y = (cumsum(x)-mean*nx)/fact/sd
753 plot(x = nx, y = y, xlab = "n", ylab = "x",
754 ylim = range(y[!is.na(y)], -1, 1), type = "l", main = main, ...)
755 lines(c(0,lx), c(1,1), col=2)
756 lines(c(0,lx), c(-1,-1), col=2)
757
758 # Return Value:
759 y
760 }
761
762
763 # ------------------------------------------------------------------------------
764
765
766 xacfPlot =
767 function(x, threshold = 0.95, lag.max = 15, doplot = TRUE, ...)
768 { # A function implemented by Diethelm Wuertz
769
770 # Description:
771 # Creates plots of exceedences, one for the
772 # heights and one for the distances.
773
774 # FUNCTION:
775
776 # Convert from univariate 'timSeries':
777 if (is.timeSeries(x)) x = as.vector(x)
778
779 # Settings:
780 # Sorry, user specified labels not yet implemented.
781 labels = TRUE
782 if (labels) {
783 xlab = c("Index", "Lag")
784 ylab = c("Heights", "Distances", "ACF")
785 main = c("Heights over Threshold", "Distances between Heights",
786 "Series Heights", "Series Distances") }
787
788 # Convert x to a vector, if the input is a data.frame.
789 if (is.data.frame(x)) x = x[,1]
790 # Heights/Distances
791 threshold = sort(x)[round(threshold*length(x))]
792 Heights = (x-threshold)[(x-threshold)>0]
793 Distances = diff((1:length(x))[(x-threshold)>0])
794
795 # Plot:
796 if (doplot) {
797 plot (Heights, type="h", xlab = xlab[1], ylab = ylab[1],
798 main = main[1], ...)
799 plot (Distances,type="h", xlab = xlab[1], ylab = ylab[2],
800 main = main[2], ...) }
801
802 # Correlations:
803 Heights = as.vector(acf(Heights, lag.max=lag.max, plot = doplot,
804 xlab = xlab[2], ylab = ylab[3], main = main[3], ...)$acf)
805 Distances = as.vector(acf(Distances, lag.max=lag.max, plot = doplot,
806 xlab = xlab[2], ylab = ylab[3], main = main[4], ...)$acf)
807
808 # Result:
809 lag = as.vector(0:(lag.max))
810 result = data.frame(lag, Heights, Distances)
811
812 # Return Value:
813 if (doplot) return(invisible(result)) else return(result)
814 }
815
816
817 # ******************************************************************************
818
819
820 interactivePlot =
821 function(x, choices = paste("Plot", 1:9),
822 plotFUN = paste("plot.", 1:9, sep = ""), which = "all", ...)
823 { # A function implemented by Diethelm Wuertz
824
825 # Description:
826 # Plot method for an object of class "template".
827
828 # Arguments:
829 # x - an object to be plotted
830 # choices - the character string for the choice menu
831 # plotFUN - the names of the plot functions
832 # which - plot selection, which graph should be
833 # displayed. If a character string named "ask" the
834 # user is interactively asked which to plot, if
835 # a logical vector of length N, those plots which
836 # are set "TRUE" are displayed, if a character string
837 # named "all" all plots are displayed.
838
839 # Note:
840 # At maximum 9 plots are supported.
841
842 # FUNCTION:
843
844 # Some cecks:
845 if (length(choices) != length(plotFUN))
846 stop("Arguments choices and plotFUN must be of same length.")
847 if (length(which) > length(choices))
848 stop("Arguments which has incorrect length.")
849 if (length(which) > length(plotFUN))
850 stop("Arguments which has incorrect length.")
851 if (length(choices) > 9)
852 stop("Sorry, only 9 plots at max are supported.")
853
854 # Internal "askPlot" Function:
855 multPlot = function (x, choices, ...)
856 {
857 # Selective Plot:
858 selectivePlot = function (x, choices, FUN, which){
859 # Internal Function:
860 askPlot = function (x, choices, FUN) {
861 # Pick and Plot:
862 pick = 1; n.plots = length(choices)
863 while (pick > 0) { pick = menu (
864 choices = paste("plot:", choices),
865 title = "\nMake a plot selection (or 0 to exit):")
866 if (pick > 0) match.fun(FUN[pick])(x) } }
867 if (as.character(which[1]) == "ask") {
868 askPlot(x, choices = choices, FUN = FUN, ...) }
869 else {
870 for (i in 1:n.plots) if (which[i]) match.fun(FUN[i])(x) }
871 invisible() }
872 # match Functions, up to nine ...
873 if (length(plotFUN) < 9) plotFUN =
874 c(plotFUN, rep(plotFUN[1], times = 9 - length(plotFUN)))
875 plot.1 = match.fun(plotFUN[1]); plot.2 = match.fun(plotFUN[2])
876 plot.3 = match.fun(plotFUN[3]); plot.4 = match.fun(plotFUN[4])
877 plot.5 = match.fun(plotFUN[5]); plot.6 = match.fun(plotFUN[6])
878 plot.7 = match.fun(plotFUN[7]); plot.8 = match.fun(plotFUN[8])
879 plot.9 = match.fun(plotFUN[9])
880 pick = 1
881 while (pick > 0) { pick = menu (
882 ### choices = paste("plot:", choices),
883 choices = paste(" ", choices),
884 title = "\nMake a plot selection (or 0 to exit):")
885 # up to 9 plot functions ...
886 switch (pick, plot.1(x), plot.2(x), plot.3(x), plot.4(x),
887 plot.5(x), plot.6(x), plot.7(x), plot.8(x), plot.9(x) )
888 }
889 }
890
891 # Plot:
892 if (is.numeric(which)) {
893 Which = rep(FALSE, times = length(choices))
894 Which[which] = TRUE
895 which = Which
896 }
897 if (which[1] == "all") {
898 which = rep(TRUE, times = length(choices))
899 }
900 if (which[1] == "ask") {
901 multPlot(x, choices, ...)
902 } else {
903 for ( i in 1:length(which) ) {
904 FUN = match.fun(plotFUN[i])
905 if (which[i]) FUN(x)
906 }
907 }
908
909 # Return Value:
910 invisible(x)
911 }
912
913
914 # ******************************************************************************
915
916
917 gridVector =
918 function(x, y)
919 { # A function implemented by Diethelm Wuertz, GPL
920
921 # Description:
922 # Creates from two vectors x and y all grid points
923
924 # Details:
925 # The two vectors x and y span a rectangular grid with nx=length(x)
926 # times ny=length(y) points which are returned as a matrix of size
927 # (nx*ny) times 2.
928
929 # Arguments:
930 # x, y - two numeric vectors of length m and n which span the
931 # rectangular grid of size m times n.
932
933 # Value:
934 # returns a list with two elements X and Y each of length m
935 # times n
936
937 # Example:
938 # > gridVector(1:3, 1:2)
939 # [,1] [,2]
940 # [1,] 1 1
941 # [2,] 2 1
942 # [3,] 3 1
943 # [4,] 1 2
944 # [5,] 2 2
945 # [6,] 3 2
946
947 # FUNCTION:
948
949 # Prepare for Input:
950 nx = length(x)
951 ny = length(y)
952 xoy = cbind(rep(x, ny), as.vector(matrix(y, nx, ny, byrow = TRUE)))
953 X = matrix(xoy, nx * ny, 2, byrow = FALSE)
954
955 # Return Value:
956 list(X = X[,1], Y = X[,2])
957 }
958
959
960 ################################################################################
961
962
963 # PART II:
964
965
966 findThreshold =
967 function(x, n = NA)
968 { # A function implemented by Diethelm Wuertz
969
970 # Description:
971 # Finds upper thresold for a given number of Extremes.
972
973 # Arguments:
974 # n - a numeric value or vector giving number of extremes
975 # above the threshold. If "n" is not specified, "n"
976 # is set to an integer representing 5% of the data
977 # from the whole data set "x".
978
979 # Note:
980 # Imported from R-package evir/EVIS.
981
982 # FUNCTION:
983
984 # Settings:
985 if(is.na(n[1])) n = floor(0.05*length(x))
986
987 # Continue:
988 x = rev(sort(as.numeric(x)))
989 thresholds = unique(x)
990 indices = match(x[n], thresholds)
991 indices = pmin(indices + 1, length(thresholds))
992
993 # Return Value:
994 thresholds[indices]
995 }
996
997
998 # ------------------------------------------------------------------------------
999
1000
1001 blocks =
1002 function(x, block = "month", FUN = max)
1003 { # A function implemented by Diethelm Wuertz
1004
1005 # Description:
1006 # Creates data blocks on vectors and time series.
1007
1008 # Note:
1009 # Imported from R-package evir/EVIS.
1010
1011 # FUNCTION:
1012
1013 # Settings:
1014 data = x
1015
1016 # Compute:
1017 n.all = length(data)
1018 if (is.character(block)) {
1019 times = as.POSIXlt(attributes(data)$times)
1020 if (block %in% c("semester", "quarter")) {
1021 sem = quart = times$mon
1022 sem[sem %in% 0:5] = quart[quart %in% 0:2] = 0
1023 sem[sem %in% 6:11] = quart[quart %in% 3:5] = 1
1024 quart[quart %in% 6:8] = 2
1025 quart[quart %in% 9:11] = 3 }
1026 grouping = switch(block,
1027 semester = paste(times$year, sem),
1028 quarter = paste(times$year, quart),
1029 quarters = paste(times$year, quart),
1030 month = paste(times$year, times$mon),
1031 months = paste(times$year, times$mon),
1032 year = times$year,
1033 years = times$year,
1034 stop("unknown time period"))
1035 newdata = tapply(data, grouping, FUN=FUN) }
1036 else {
1037 data = as.numeric(data)
1038 nblocks = (length(data) %/% block) + 1
1039 grouping = rep(1:nblocks, rep(block, nblocks))[1:length(data)]
1040 newdata = tapply(data, grouping, FUN=FUN)}
1041
1042 # Return Value:
1043 result = newdata
1044 result
1045 }
1046
1047
1048 # -----------------------------------------------------------------------------
1049
1050
1051 blockMaxima =
1052 function(x, block = "month", details = FALSE, doplot = TRUE, ...)
1053 { # A function implemented by Diethelm Wuertz
1054
1055 # Description:
1056 # Calculates block maxima on vectors and time series.
1057
1058 # Arguments:
1059 # x - may be alternatively as.vector or as.ts
1060 # block - as.numeric: length of a block
1061 # as.character: year | semester | quarter | month
1062
1063 # Note:
1064 # Calls McNeils Splus function blocks()
1065 # Output data as vector of transposed
1066 # result to get proper order of data!
1067
1068 # FUNCTION:
1069
1070 # Settings
1071 x = blocks(x, block)
1072
1073 # Plot:
1074 if (doplot) {
1075 plot(as.vector(x), type="h", ylab = "Block Maxima", ...)
1076 title(main = paste(block, "- Block Maxima"))
1077 grid() }
1078
1079 # Details:
1080 # if details == FALSE a vector is returned, i.e details are removed!
1081 if (!details) x = as.vector(x[is.na(x) == FALSE])
1082
1083 # Return Value:
1084 x
1085 }
1086
1087
1088 # -----------------------------------------------------------------------------
1089
1090
1091 deCluster =
1092 function(x, run = NA, doplot = TRUE)
1093 { # A function implemented by Diethelm Wuertz
1094
1095 # Description:
1096 # Declusters a point process
1097
1098 # Note:
1099 # Imported from R-package evir/EVIS.
1100
1101 # FUNCTION:
1102
1103 # Settings:
1104 labels = TRUE
1105
1106 # Imported Function:
1107 series = x
1108 picture = doplot
1109 n = length(as.numeric(series))
1110 times = attributes(series)$times
1111 if (is.null(times))
1112 stop("`series' must have a `times' attribute")
1113 as.posix = is.character(times) || inherits(times, "POSIXt") ||
1114 inherits(times, "date") || inherits(times, "dates")
1115 if (as.posix)
1116 gaps = as.numeric(difftime(as.POSIXlt(times)[2:n],
1117 as.POSIXlt(times)[1:(n - 1)], units = "days"))
1118 else gaps = as.numeric(diff(times))
1119 longgaps = gaps > run
1120 if (sum(longgaps) <= 1)
1121 stop("Decluster parameter too large")
1122 cluster = c(0, cumsum(longgaps))
1123 cmax = tapply(as.numeric(series), cluster, max)
1124 newtimes = times[match(cmax, series)]
1125 newseries = structure(series[match(cmax, series)], times = newtimes)
1126 n = length(as.numeric(newseries))
1127 if (as.posix) {
1128 newgaps = as.numeric(difftime(as.POSIXlt(newtimes)[2:n],
1129 as.POSIXlt(newtimes)[1:(n - 1)], units = "days"))
1130 times = as.POSIXlt(times)
1131 newtimes = as.POSIXlt(newtimes) }
1132 else {
1133 newgaps = as.numeric(diff(newtimes)) }
1134
1135 # Plot:
1136 if (doplot) {
1137 # cat("Declustering picture...\n")
1138 # cat(paste("Data reduced from", length(as.numeric(series)),
1139 # "to", length(as.numeric(newseries)), "\n"))
1140 # par(mfrow = c(2, 2))
1141 if (labels) {
1142 main = "de-Clustering"
1143 plot(times, series, type = "h", main = main)
1144 qPlot(gaps)
1145 plot(newtimes, newseries, type = "h", main = main)
1146 qPlot(newgaps) }
1147 }
1148
1149 # Result:
1150 ans = newseries
1151
1152 # Return Value:
1153 ans
1154 }
1155
1156
1157 ################################################################################
1158
+1114
-0
R/052A-GevModelling.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: GEV DISTRIBUTION FAMILY: [USE FROM EVD]
31 # devd Density for the GEV Distribution
32 # pevd Probability for the GEV Distribution
33 # qevd Quantiles for the GEV Distribution
34 # revd Random variates for the GEV Distribution
35 # FUNCTION: GEV DISTRIBUTION FAMILY: [USE FROM EVIS]
36 # dgev Density for the GEV Distribution
37 # pgev Probability for the GEV Distribution
38 # qgev Quantiles for the GEV Distribution
39 # rgev Random variates for the GEV Distribution
40 # FUNCTION: MOMENTS:
41 # .gevMoments Computes true statistics for GEV distribution
42 ################################################################################
43
44
45 ################################################################################
46 # FUNCTION: GEV MODELLING FROM EVIS:
47 # gevSim Simulates GEV including Gumbel rvs [EVIS/EVIR]
48 # gevFit Fits GEV Distribution
49 # print.gevFit Print Method for object of class "gevFit"
50 # plot.gevFit Plot Method for object of class "gevFit"
51 # summary.gevFit Summary Method for object of class "gevFit"
52 # FUNCTION: ADDITIONAL PLOT:
53 # gevrlevelPlot Calculates Return Levels Based on GEV Fit
54 ################################################################################
55
56
57 ################################################################################
58 # FUNCTION: MDA ESTIMATORS:
59 # hillPlot Plot Hill's estimator
60 # shaparmPlot Pickands, Hill & Decker-Einmahl-deHaan Estimator
61 # shaparmPickands Auxiliary function called by shaparmPlot
62 # shaparmHill ... called by shaparmPlot
63 # shaparmDehaan ... called by shaparmPlot
64 ################################################################################
65
66
67 # PART I: GEV DISTRIBUTION FAMILY: [USE FROM EVD]
68
69
70 devd =
71 function (x, loc = 0, scale = 1, shape = 0, log = FALSE)
72 {
73 # FUNCTION:
74
75 if (min(scale) <= 0)
76 stop("invalid scale")
77 if (length(shape) != 1)
78 stop("invalid shape")
79 x = (x - loc)/scale
80 if (shape == 0)
81 d = log(1/scale) - x - exp(-x)
82 else {
83 nn = length(x)
84 xx = 1 + shape * x
85 xxpos = xx[xx > 0 | is.na(xx)]
86 scale = rep(scale, length.out = nn)[xx > 0 | is.na(xx)]
87 d = numeric(nn)
88 d[xx > 0 | is.na(xx)] = log(1/scale) - xxpos^(-1/shape) -
89 (1/shape + 1) * log(xxpos)
90 d[xx <= 0 & !is.na(xx)] = -Inf
91 }
92 if (!log)
93 d = exp(d)
94 d
95 }
96
97
98 # ------------------------------------------------------------------------------
99
100
101 pevd =
102 function (q, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
103 {
104 # FUNCTION:
105
106 if (min(scale) <= 0)
107 stop("invalid scale")
108 if (length(shape) != 1)
109 stop("invalid shape")
110 q = (q - loc)/scale
111 if (shape == 0)
112 p = exp(-exp(-q))
113 else p = exp(-pmax(1 + shape * q, 0)^(-1/shape))
114 if (!lower.tail)
115 p = 1 - p
116 p
117 }
118
119
120 # ------------------------------------------------------------------------------
121
122
123 qevd =
124 function (p, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
125 {
126 # FUNCTION:
127
128 if (min(p, na.rm = TRUE) <= 0 || max(p, na.rm = TRUE) >=
129 1)
130 stop("`p' must contain probabilities in (0,1)")
131 if (min(scale) < 0)
132 stop("invalid scale")
133 if (length(shape) != 1)
134 stop("invalid shape")
135 if (!lower.tail)
136 p = 1 - p
137 if (shape == 0)
138 return(loc - scale * log(-log(p)))
139 else return(loc + scale * ((-log(p))^(-shape) - 1)/shape)
140 }
141
142
143 # ------------------------------------------------------------------------------
144
145
146 revd =
147 function (n, loc = 0, scale = 1, shape = 0)
148 {
149 # FUNCTION:
150
151 if (min(scale) < 0)
152 stop("invalid scale")
153 if (length(shape) != 1)
154 stop("invalid shape")
155 if (shape == 0)
156 return(loc - scale * log(rexp(n)))
157 else return(loc + scale * (rexp(n)^(-shape) - 1)/shape)
158 }
159
160
161 # ******************************************************************************
162
163
164 dgev =
165 function(x, xi = 1, mu = 0, sigma = 1, log = FALSE)
166 { # A function implemented from evd
167
168 # Description:
169 # GEV Density Function
170 # Note: 1 + xi*(x-mu)/sigma > 0
171 # xi > 0 Frechet
172 # xi = 0 Gumbel
173 # xi < 0 weibl
174
175 # FUNCTION:
176
177 # Settings:
178 loc = mu
179 scale = sigma
180 shape = xi
181
182 # Density function:
183 if (min(scale) <= 0)
184 stop("invalid scale")
185 if (length(shape) != 1)
186 stop("invalid shape")
187 x = (x - loc)/scale
188 if (shape == 0)
189 d = log(1/scale) - x - exp(-x)
190 else {
191 nn = length(x)
192 xx = 1 + shape * x
193 xxpos = xx[xx > 0 | is.na(xx)]
194 scale = rep(scale, length.out = nn)[xx > 0 | is.na(xx)]
195 d = numeric(nn)
196 d[xx > 0 | is.na(xx)] = log(1/scale) - xxpos^(-1/shape) -
197 (1/shape + 1) * log(xxpos)
198 d[xx <= 0 & !is.na(xx)] = -Inf
199 }
200 if (!log)
201 d = exp(d)
202
203 # Return Value:
204 d
205 }
206
207
208 # ------------------------------------------------------------------------------
209
210
211 pgev =
212 function(q, xi = 1, mu = 0, sigma = 1, lower.tail = TRUE)
213 { # A function implemented from evd
214
215 # Description:
216 # GEV Probability Function
217 # Note: 1 + xi*(x-mu)/sigma > 0
218 # xi > 0 Frechet
219 # xi = 0 Gumbel
220 # xi < 0 Weibull
221
222 # FUNCTION:
223
224 # Settings:
225 loc = mu
226 scale = sigma
227 shape = xi
228
229 # Probability function:
230 if (min(scale) <= 0)
231 stop("invalid scale")
232 if (length(shape) != 1)
233 stop("invalid shape")
234 q = (q - loc)/scale
235 if (shape == 0)
236 p = exp(-exp(-q))
237 else p = exp(-pmax(1 + shape * q, 0)^(-1/shape))
238 if (!lower.tail)
239 p = 1 - p
240
241 # Return Value:
242 p
243 }
244
245
246 # ------------------------------------------------------------------------------
247
248
249 qgev =
250 function (p, xi = 1, mu = 0, sigma = 1, lower.tail = TRUE)
251 { # A function implemented from evd
252
253 # Description:
254 # GEV Quantile Function
255 # Note: 1 + xi*(x-mu)/sigma > 0
256 # xi > 0 Frechet
257 # xi = 0 Gumbel
258 # xi < 0 Weibull
259
260 # FUNCTION:
261
262 # Settings:
263 loc = mu
264 scale = sigma
265 shape = xi
266
267 # Return Value:
268 if (min(p, na.rm = TRUE) < 0 || max(p, na.rm = TRUE) > 1)
269 stop("`p' must contain probabilities in (0,1)")
270 if (min(scale) < 0)
271 stop("invalid scale")
272 if (length(shape) != 1)
273 stop("invalid shape")
274 if (!lower.tail)
275 p = 1 - p
276 if (shape == 0)
277 q = loc - scale * log(-log(p))
278 else
279 q = loc + scale * ((-log(p))^(-shape) - 1)/shape
280
281 # Return Value:
282 q
283 }
284
285
286 # ------------------------------------------------------------------------------
287
288
289 rgev =
290 function (n, xi = 1, mu = 0, sigma = 1)
291 { # A function implemented from evd
292
293 # Description:
294 # GEV Random Variables
295 # Note: 1 + xi*(x-mu)/sigma > 0
296 # xi > 0 Frechet
297 # xi = 0 Gumbel
298 # xi < 0 Weibull
299
300 # FUNCTION:
301
302 # Settings:
303 loc = mu
304 scale = sigma
305 shape = xi
306
307 # Return Value:
308 if (min(scale) < 0)
309 stop("invalid scale")
310 if (length(shape) != 1)
311 stop("invalid shape")
312 if (shape == 0)
313 r = loc - scale * log(rexp(n))
314 else
315 r = loc + scale * (rexp(n)^(-shape) - 1)/shape
316
317 # Return Value:
318 r
319 }
320
321
322 # ------------------------------------------------------------------------------
323
324
325 .gevMoments =
326 function(xi, mu = 0, beta = 1)
327 { # A function implemented by Diethelm Wuertz
328
329 # Description:
330 # Compute true statistics for Generalized Extreme Value distribution
331
332 # Value:
333 # Returns true mean for xi < 1 and variance for xi < 1/2
334 # of GEV distribution, otherwise NaN is returned
335
336 # FUNCTION:
337
338 # MEAN: Returns for x >= 1 NaN:
339 g = c(1, 0, NaN)
340 xinv = 1/ ( xi + sign(abs(xi)) - 1 )
341 # For xi = the result is eulers constant
342 euler = 0.57721566490153286060651209008240243104
343 xi0 = c(0, mu+beta*euler, 0)
344
345 # Supress warning for NaN's from Gamma Function:
346 options(warn = -1)
347 gevMean = mu + beta * xinv * (gamma(1-xi)-1) * g[sign(xi-1)+2] +
348 xi0[(sign(xi)+2)]
349 options(warn = 0)
350
351 # VAR: Returns for x >= 1 NaN:
352 g = c(1, 0, NaN)
353 xinv = 1/ ( xi + sign(abs(xi)) - 1 )
354 xi0 = c(0, (beta*pi)^2 / 6, 0)
355
356 # Supress warning for NaN's from Gamma Function:
357 options(warn=-1)
358 gevVar = (beta*xinv)^2 * (gamma(1-2*xi) - gamma(1-xi)^2 ) *
359 g[sign(2*xi-1)+2] + xi0[(sign(xi)+2)]
360 options(warn = 0)
361
362 # Return Value:
363 list(mean = gevMean, var = gevVar)
364 }
365
366
367 ################################################################################
368
369
370 # GEV MODELLING FROM EVIS:
371
372
373 gevSim =
374 function(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
375 { # A function implemented by Diethelm Wuertz
376
377 # Description:
378 # Generates random variates from a GEV distribution
379
380 # FUNCTION:
381
382 # Simulate:
383 ans = rgev(n = n, xi = model$shape, mu = model$location,
384 sigma = model$scale)
385
386 # Return Value:
387 ans
388 }
389
390
391 # ------------------------------------------------------------------------------
392
393
394 gevFit =
395 function(x, block = NA, type = c("mle", "pwm"), gumbel = FALSE, ...)
396 { # A function implemented by Diethelm Wuertz
397
398 # Description:
399 # Fits parameters to a GEV distribution
400
401 # Note:
402 # Argument named "method is already used for the selection
403 # of the MLE optimization algorithm, therfore we use here
404 # "type".
405
406 # FUNCTION:
407
408 # Settings:
409 call = match.call()
410 type = type[1]
411
412 # Internal Function:
413 gev.pwm = function(data, block = NA, ...) {
414 # Probability Weighted Moment method.
415 # Blocks and data:
416 n.all = NA
417 if (!is.na(block)) {
418 n.all = length(data)
419 if (is.character(block)) {
420 times = as.POSIXlt(attributes(data)$times)
421 if (block %in% c("semester", "quarter")) {
422 sem = quart = times$mon
423 sem[sem %in% 0:5] = quart[quart %in% 0:2] = 0
424 sem[sem %in% 6:11] = quart[quart %in% 3:5] = 1
425 quart[quart %in% 6:8] = 2
426 quart[quart %in% 9:11] = 3 }
427 grouping = switch(block,
428 semester = paste(times$year, sem),
429 quarter = paste(times$year, quart),
430 month = paste(times$year, times$mon),
431 year = times$year,
432 stop("unknown time period"))
433 data = tapply(data, grouping, max) }
434 else {
435 data = as.numeric(data)
436 nblocks = (length(data)%/%block) + 1
437 grouping = rep(1:nblocks, rep(block, nblocks))[1:length(data)]
438 data = tapply(data, grouping, max) } }
439 data = as.numeric(data)
440 n = length(data)
441
442 # Internal Function - Sample Moments:
443 sampwm = function (x, nmom) {
444 # a = 0, b = 0, kind = 1
445 x = rev(sort(x))
446 moments = rep(0, nmom)
447 moments[1] = mean(x)
448 n = length(x)
449 for (i in 1:n) {
450 weight = 1/n
451 for (j in 2:nmom) {
452 weight = weight*(n-i-j+2)/(n-j+1)
453 moments[j] = moments[j] + weight*x[i] } }
454 return(moments) }
455
456 # Internal Function:
457 y = function(x, w0, w1, w2) { (3^x-1)/(2^x-1) - (3*w2 - w0)/(2*w1 - w0) }
458 # Calculate:
459 w = sampwm(data, nmom = 3)
460 w0 = w[1]
461 w1 = w[2]
462 w2 = w[3]
463 xi = uniroot(f = y, interval = c(-5,+5),
464 w0 = w[1], w1 = w[2], w2 = w[3])$root
465 sigma = beta = (2*w1-w0)*xi / gamma(1-xi) / (2^xi-1)
466 mu = w0 + beta*(1-gamma(1-xi))/xi
467 # Output:
468 fit = list(n.all = n.all, n = n, data = data, bock = block,
469 par.ests = c(xi, sigma, mu), par.ses = rep(NA, 3),
470 varcov = matrix(rep(NA, 9), 3, 3), converged = NA,
471 nllh.final = NA, call=match.call(), selected = "pwm")
472 names(fit$par.ests) = c("xi", "sigma", "mu")
473 names(fit$par.ses) = c("xi", "sigma", "mu")
474 # Return Value:
475 class(fit) = "gev"
476 fit }
477
478 # Internal Function:
479 gumbel.pwm = function(data, block = NA, ...) {
480 # "Probability Weighted Moment" method.
481 # Blocks and data:
482 n.all = NA
483 if (!is.na(block)) {
484 n.all = length(data)
485 if (is.character(block)) {
486 times = as.POSIXlt(attributes(data)$times)
487 if (block %in% c("semester", "quarter")) {
488 sem = quart = times$mon
489 sem[sem %in% 0:5] = quart[quart %in% 0:2] = 0
490 sem[sem %in% 6:11] = quart[quart %in% 3:5] = 1
491 quart[quart %in% 6:8] = 2
492 quart[quart %in% 9:11] = 3 }
493 grouping = switch(block,
494 semester = paste(times$year, sem),
495 quarter = paste(times$year, quart),
496 month = paste(times$year, times$mon),
497 year = times$year,
498 stop("unknown time period"))
499 data = tapply(data, grouping, max) }
500 else {
501 data = as.numeric(data)
502 nblocks = (length(data)%/%block) + 1
503 grouping = rep(1:nblocks, rep(block, nblocks))[1:length(data)]
504 data = tapply(data, grouping, max) } }
505 data = as.numeric(data)
506 n = length(data)
507 # Sample Moments:
508 x = rev(sort(data))
509 lambda = c(mean(x), 0)
510 for (i in 1:n) {
511 weight = (n-i)/(n-1)/n
512 lambda[2] = lambda[2] + weight*x[i] }
513 # Calculate Parameters:
514 xi = 0
515 sigma = beta = lambda[2]/log(2)
516 mu = lambda[1] - 0.5772*beta
517 # Output:
518 fit = list(n.all = n.all, n = n, data = data, block = block,
519 par.ests = c(sigma, mu), par.ses = rep(NA, 2),
520 varcov = matrix(rep(NA, 4), 2, 2), converged = NA,
521 nllh.final = NA, call = match.call(), selected = "pwm")
522 names(fit$par.ests) = c("sigma", "mu")
523 names(fit$par.ses) = c("sigma", "mu")
524 # Return Value:
525 class(fit) = "gev" # not gumbel!
526 fit }
527
528 # Estimate Parameters:
529 if (gumbel) {
530 # Add Call and Type
531 if (length(type) > 1) type = type[1]
532 # Probability Weighted Moment Estimation
533 if (type == "pwm") {
534 fitted = gumbel.pwm(data = x, block = block, ...) }
535 # Maximum Log Likelihood Estimation
536 # Use Alexander McNeils EVIS:
537 if (type == "mle") {
538 fitted = gumbel(data = x, block = block, ...) } }
539 else {
540 # Add Call and Type
541 if (length(type) > 1) type = type[1]
542 # Probability Weighted Moment Estimation:
543 if (type == "pwm") {
544 fitted = gev.pwm(data = x, block = block, ...) }
545 # Maximum Log Likelihood Estimation
546 # Use Alexander McNeils EVIS (renames as gev.mle)
547 if (type == "mle") {
548 fitted = gev(data = x, block = block, ...) } }
549
550 # Compute Residuals:
551 if (gumbel) {
552 # GUMBEL:
553 xi = 0
554 sigma = fitted$par.ests[1]
555 mu = fitted$par.ests[2]
556 fitted$residuals = exp( - exp( - (fitted$data - mu)/sigma)) }
557 else {
558 # GEV:
559 xi = fitted$par.ests[1]
560 sigma = fitted$par.ests[2]
561 mu = fitted$par.ests[3]
562 fitted$residuals = (1 + (xi * (fitted$data - mu))/sigma)^(-1/xi) }
563
564 # Make Unique:
565 fit = list()
566 fit$fit = fitted
567 fit$call = call
568 fit$type = c(if(gumbel) "gum" else "gev", type[1])
569 fit$par.ests = fitted$par.ests
570 fit$par.ses = fitted$par.ses
571 fit$residuals = fitted$residuals
572 fit$fitted.values = fitted$data - fitted$residuals
573 fit$llh = fitted$nllh.final
574 fit$converged = fitted$converged
575
576 # Return Value:
577 class(fit) = "gevFit"
578 fit
579 }
580
581
582 # ------------------------------------------------------------------------------
583
584
585 print.gevFit =
586 function(x, ...)
587 { # A function implemented by Diethelm Wuertz
588
589 # Description:
590 # Print Method for an object of class "gevFit".
591
592 # FUNCTION:
593
594 # Function Call:
595 cat("\nCall:\n")
596 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
597
598 # Estimation Type:
599 cat("\nEstimation Type:", x$type, "\n")
600
601 # Estimated Parameters:
602 cat("\nEstimated Parameters:\n")
603 print(x$par.ests)
604 cat("\n")
605
606 # Return Value:
607 invisible(x)
608 }
609
610
611 # ------------------------------------------------------------------------------
612
613
614 plot.gevFit =
615 function(x, which = "all", ...)
616 { # A function implemented by Diethelm Wuertz
617
618 # Description:
619 # Plot method for an object of class "gevFit".
620
621 # Details:
622 # plot.gev:
623 # Data are converted to unit exponentially distributed residuals
624 # under null hypothesis that GEV fits. Two diagnostics for iid
625 # exponential data are offered:
626 # "Scatterplot of Residuals" and "QQplot of Residuals"
627
628 # FUNCTION:
629
630 # Internal Plot Functions:
631 plot.1 <<- function(x) {
632 # Time Series Plot of Block Maxima:
633 plot(x$fit$data, type = "h", col = "steelblue",
634 xlab = "Index",
635 ylab = "Data",
636 main = "Block Maxima")
637 }
638 plot.2 <<- function(x) {
639 # Lowess Fit to Scatterplot of Residuals:
640 plot(x$residuals, pch = 19, cex = 0.5,
641 xlab = "Ordering",
642 ylab = "Residuals",
643 main = "Scatterplot of Residuals")
644 lines(lowess(1:length(x$residuals), x$residuals),
645 col = "steelblue")
646 grid()
647 }
648 plot.3 <<- function(x) {
649 # Histogram Plot of Residuals with Gaussian Fit:
650 hist(x$residuals, probability = TRUE, breaks = "FD",
651 col = "steelblue", border = "white",
652 xlab = "Residuals",
653 ylab = "Density",
654 main = "GEV Fit and Residual Histrogram")
655 # xi = x$par.ests[1]
656 # sigma = x$par.ests[2]
657 # mu = x$par.ests[3]
658 # r = range(x$residuals)
659 }
660 plot.4 <<- function(x) {
661 # Quantile-Quantile Plot:
662 # evir::qplot
663 qplot(x$residuals, col = "steelblue", pch = 19, cex = 0.5,
664 # xlab = "Ordered Data",
665 # ylab = "Exponential Quantiles",
666 main = "Quantile-Quantile Plot")
667 grid()
668 }
669
670 # Plot:
671 interactivePlot(
672 x = x,
673 choices = c(
674 "Block Maxima Plot",
675 "Scatterplot of Residuals",
676 "Histogram of Residuals",
677 "Quantile Quantile Plot"),
678 plotFUN = c(
679 "plot.1",
680 "plot.2",
681 "plot.3",
682 "plot.4"),
683 which = which)
684
685 # Return Value:
686 invisible(x)
687 }
688
689
690 # ------------------------------------------------------------------------------
691
692
693 summary.gevFit =
694 function(object, doplot = TRUE, which = "all", ...)
695 {
696 # A function implemented by Diethelm Wuertz
697
698 # Description:
699 # Summary method for an object of class "gevFit".
700
701 # FUNCTION:
702
703 # Print:
704 print(object, ...)
705
706 # Summary:
707 if (object$type[2] == "mle") {
708 cat("\nStandard Deviations:\n"); print(object$par.ses)
709 cat("\nLog-Likelihood Value: ", object$llh)
710 cat("\nType of Convergence: ", object$converged, "\n") }
711 cat("\n")
712
713 # Plot:
714 if (doplot) plot(object, which = which, ...)
715 cat("\n")
716
717 # Return Value:
718 invisible(object)
719 }
720
721
722 # ------------------------------------------------------------------------------
723
724
725 gevrlevelPlot =
726 function(object, k.blocks = 20, add = FALSE, ...)
727 { # A function implemented by Diethelm Wuertz
728
729 # Description:
730 # Calculates Return Levels Based on GEV Fit
731
732 # FUNCTION:
733
734 # Settings
735 fit = object
736
737 # Use "rlevel.gev":
738 ans = rlevel.gev(out = fit$fit, k.blocks = k.blocks, add = add, ...)
739 ans = c(min = ans[1], v = ans[2], max = ans[3])
740
741 # Return Value:
742 ans
743 }
744
745
746 ################################################################################
747
748
749 # PART III: MDA ESTIMATORS:
750
751
752 hillPlot =
753 function(x, option = c("alpha", "xi", "quantile"), start = 15, end = NA,
754 reverse = FALSE, p = NA, ci = 0.95, autoscale = TRUE, labels = TRUE, ...)
755 { # A function implemented by Diethelm Wuertz
756
757 # Description:
758 # Plots the results from the Hill Estimator.
759
760 # Note:
761 # Imported from R-package evir
762
763 # Settings:
764 data = as.numeric(x)
765 ordered = rev(sort(data))
766 ordered = ordered[ordered > 0]
767 n = length(ordered)
768 option = match.arg(option)
769 if((option == "quantile") && (is.na(p)))
770 stop("Input a value for the probability p")
771 if((option == "quantile") && (p < 1 - start/n)) {
772 cat("Graph may look strange !! \n\n")
773 cat(paste("Suggestion 1: Increase `p' above",
774 format(signif(1 - start/n, 5)), "\n"))
775 cat(paste("Suggestion 2: Increase `start' above ",
776 ceiling(length(data) * (1 - p)), "\n"))
777 }
778 k = 1:n
779 loggs = logb(ordered)
780 avesumlog = cumsum(loggs)/(1:n)
781 xihat = c(NA, (avesumlog - loggs)[2:n])
782 alphahat = 1/xihat
783 y = switch(option,
784 alpha = alphahat,
785 xi = xihat,
786 quantile = ordered * ((n * (1 - p))/k)^(-1/alphahat))
787 ses = y/sqrt(k)
788 if(is.na(end)) end = n
789 x = trunc(seq(from = min(end, length(data)), to = start))
790 y = y[x]
791 ylabel = option
792 yrange = range(y)
793 if(ci && (option != "quantile")) {
794 qq = qnorm(1 - (1 - ci)/2)
795 u = y + ses[x] * qq
796 l = y - ses[x] * qq
797 ylabel = paste(ylabel, " (CI, p =", ci, ")", sep = "")
798 yrange = range(u, l)
799 }
800 if(option == "quantile") ylabel = paste("Quantile, p =", p)
801 index = x
802 if(reverse) index = - x
803 if(autoscale)
804 plot(index, y, ylim = yrange, type = "l", xlab = "", ylab = "",
805 axes = FALSE, ...)
806 else plot(index, y, type = "l", xlab = "", ylab = "", axes = FALSE, ...)
807 axis(1, at = index, lab = paste(x), tick = FALSE)
808 axis(2)
809 threshold = findThreshold(data, x)
810 axis(3, at = index, lab = paste(format(signif(threshold, 3))),
811 tick = FALSE)
812 box()
813 if(ci && (option != "quantile")) {
814 lines(index, u, lty = 2, col = 2)
815 lines(index, l, lty = 2, col = 2)}
816 if(labels) {
817 title(xlab = "Order Statistics", ylab = ylabel)
818 mtext("Threshold", side = 3, line = 3)}
819
820 # Return Value:
821 invisible(list(x = index, y = y))
822 }
823
824
825 # ------------------------------------------------------------------------------
826
827
828 shaparmPlot =
829 function (x, revert = FALSE, standardize = FALSE, tails = 0.01*(1:10),
830 doplot = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
831 which = c(TRUE, TRUE, TRUE), doprint = TRUE, both.tails = TRUE,
832 xi.range = c(-0.5, 1.5), alpha.range = c(0, 10))
833 { # A function written by D. Wuertz
834
835 # Description:
836 # Displays Pickands, Einmal-Decker-deHaan, and Hill
837 # estimators together with several plot variants.
838
839 # FUNCTION:
840
841 # Settings:
842 select.doplot = which
843 if (revert) x = -x
844 if (standardize) x = (x-mean(x))/sqrt(var(x))
845 ylim1 = xi.range
846 ylim2 = alpha.range
847 z = rep(mean(ylim2), length(tails))
848 ylim1 = xi.range
849 ylim2 = alpha.range
850 p1 = p2 = h1 = h2 = d1 = d2 = m1 = m2 = rep(0,length(tails))
851 for ( i in (1:length(tails)) ) {
852 tail = tails[i]
853
854 # Printing/Plotting Staff:
855 if(doprint) cat("Taildepth: ", tail, "\n")
856 if(select.doplot[1]) {
857 xi = shaparmPickands (x, tail, ylim1, doplot=doplot[i],
858 both.tails, )
859 p1[i] = xi$xi[1]; p2[i] = xi$xi[3] }
860 if(select.doplot[2]) {
861 xi = shaparmHill (x, tail, ylim1, doplot=doplot[i],
862 both.tails)
863 h1[i] = xi$xi[1]; h2[i] = xi$xi[3] }
864 if(select.doplot[3]) {
865 xi = shaparmDEHaan (x, tail, ylim1, doplot=doplot[i],
866 both.tails)
867 d1[i] = xi$xi[1]; d2[i] = xi$xi[3] }
868 if(doprint) {
869 cat("Pickands - Hill - DeckerEinmaalDeHaan: \n")
870 print(c(p1[i], h1[i], d1[i]))
871 if (both.tails) print(c(p2[i], h2[i], d2[i]))}
872 cat("\n") }
873
874
875 # Plot Pickands' Summary:
876 if(select.doplot[1]) {
877 plot (tails, z, type="n", xlab="tail depth", ylab="alpha",
878 ylim=ylim2, main="Pickands Summary")
879 y1 = 1/p1
880 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
881 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
882 points (x1, y1, col=2); lines(x1, y1, col=2)
883 if (both.tails) {
884 y1 = 1/p2
885 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
886 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
887 points (x1, y1, col=3); lines(x1, y1, col=3)} }
888
889 # Plot Hill Summary:
890 if(select.doplot[2]) {
891 plot (tails, z, type="n", xlab="tail depth", ylab="alpha",
892 ylim=ylim2, main="Hill Summary")
893 y1 = 1/h1
894 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
895 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
896 points (x1, y1, col=2); lines(x1, y1, col=2)
897 if (both.tails) {
898 y1 = 1/h2
899 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
900 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
901 points (x1, y1, col=3); lines(x1, y1, col=3)} }
902
903 # Plot Deckers-Einmahl-deHaan Summary
904 if(select.doplot[3]) {
905 plot (tails, z, type="n", xlab="tail depth", ylab="alpha",
906 ylim=ylim2,
907 main="Deckers-Einmahl-deHaan Summary")
908 y1 = 1/d1
909 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
910 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
911 points (x1, y1, col=2); lines(x1, y1, col=2)
912 if (both.tails) {
913 y1 = 1/d2
914 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
915 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
916 points (x1, y1, col=3); lines(x1, y1, col=3)} }
917
918 # Return Value:
919 lower = list(pickands=p1, hill=h1, dehaan=d1)
920 if (both.tails) {
921 upper = list(pickands=p2, hill=h2, dehaan=d2)
922 result = list(tails=tails, lower=lower, upper=upper) }
923 else {
924 result = list(tails=tails, lower=lower) }
925 result
926 }
927
928
929 # ------------------------------------------------------------------------------
930
931
932 shaparmPickands =
933 function (x, tail, yrange, doplot = TRUE, both.tails = TRUE, ...)
934 { # A function written by D. Wuertz
935
936 # FUNCTION:
937
938 # Order Residuals:
939 ordered1 = rev(sort(abs(x[x < 0])))
940 if (both.tails) ordered2 = rev(sort(abs(x[x > 0])))
941 n1 = length(ordered1)
942 if (both.tails) n2 = length(ordered2)
943 ordered1 = ordered1[1:floor(tail*n1)]
944 if (both.tails) ordered2 = ordered2[1:floor(tail*n2)]
945 n1 = length(ordered1)
946 if (both.tails) n2 = length(ordered2)
947
948 # Pickands Estimate:
949 k1 = 1:(n1%/%4)
950 if (both.tails) k2 = 1:(n2%/%4)
951 pickands1 = log ((c(ordered1[k1])-c(ordered1[2*k1])) /
952 (c(ordered1[2*k1])-c(ordered1[4*k1]))) / log(2)
953 if (both.tails) pickands2 = log ((c(ordered2[k2])-c(ordered2[2*k2])) /
954 (c(ordered2[2*k2])-c(ordered2[4*k2]))) / log(2)
955
956 # Prepare Plot:
957 y1 = pickands1[pickands1 > yrange[1] & pickands1 < yrange[2]]
958 x1 = log10(1:length(pickands1))[pickands1 > yrange[1] &
959 pickands1 < yrange[2]]
960 if (both.tails) {
961 y2 = pickands2[pickands2 > yrange[1] & pickands2 < yrange[2]]
962 x2 = log10(1:length(pickands2))[pickands2 > yrange[1] &
963 pickands2 < yrange[2]] }
964 if (doplot) {
965 par(err=-1)
966 plot (x1, y1, xlab="log scale", ylab="xi", ylim=yrange,
967 main="Pickands Estimator", type="n")
968 title(sub=paste("tail depth:", as.character(tail)))
969 lines(x1, y1, type="p", pch=2, col=2)
970 if (both.tails) lines(x2, y2, type="p", pch=6, col=3) }
971
972 # Calculate invers "xi":
973 my1 = mean(y1, na.rm = TRUE)
974 if (both.tails) my2 = mean(y2, na.rm = TRUE)
975 sy1 = sqrt(var(y1, na.rm = TRUE))
976 if (both.tails) sy2 = sqrt(var(y2, na.rm = TRUE))
977
978 # Plot:
979 if (doplot) {
980 par(err=-1)
981 lines(c(x1[1], x1[length(x1)]), c(my1,my1), type="l",
982 lty=1, col=2)
983 if (both.tails) lines(c(x2[1], x2[length(x2)]), c(my2,my2),
984 type="l", lty=1, col=3) }
985
986 # Return Result:
987 result = list(xi=c(my1, sy1))
988 if (both.tails) result = list(xi=c(my1, sy1, my2, sy2))
989 result
990 }
991
992
993 # ------------------------------------------------------------------------------
994
995
996 shaparmHill =
997 function (x, tail, yrange, doplot = TRUE, both.tails = TRUE, ...)
998 { # A Function written by D. Wuertz
999
1000 # ORDER RESIDUALS:
1001 ordered1 = rev(sort(abs(x[x < 0])))
1002 if (both.tails) ordered2 = rev(sort(abs(x[x > 0])))
1003 n1 = length(ordered1)
1004 if (both.tails) n2 = length(ordered2)
1005 ordered1 = ordered1[1:floor(tail*n1)]
1006 if (both.tails) ordered2 = ordered2[1:floor(tail*n2)]
1007 n1 = length(ordered1)
1008 if (both.tails) n2 = length(ordered2)
1009 # HILLS ESTIMATE:
1010 hills1 = c((cumsum(log(ordered1))/(1:n1)-log(ordered1))[2:n1])
1011 if (both.tails) hills2 = c((cumsum(log(ordered2))/(1:n2) -
1012 log(ordered2))[2:n2])
1013 # PREPARE PLOT:
1014 y1 = hills1[hills1 > yrange[1] & hills1 < yrange[2]]
1015 x1 = log10(1:length(hills1))[hills1 > yrange[1] &
1016 hills1 < yrange[2]]
1017 if (both.tails) {
1018 y2 = hills2[hills2 > yrange[1] & hills2 < yrange[2]]
1019 x2 = log10(1:length(hills2))[hills2 > yrange[1] &
1020 hills2 < yrange[2]]}
1021 if (doplot) {
1022 par(err=-1)
1023 plot (x1, y1, xlab="log scale", ylab="xi", ylim=yrange,
1024 main="Hill Estimator", type="n")
1025 title(sub=paste("tail depth:", as.character(tail)))
1026 lines(x1, y1, type="p", pch=2, col=2)
1027 if (both.tails) lines(x2, y2, type="p", pch=6, col=3) }
1028 # CALCULATE INVERSE XI:
1029 my1 = mean(y1, na.rm = TRUE)
1030 if (both.tails) my2 = mean(y2, na.rm = TRUE)
1031 sy1 = sqrt(var(y1, na.rm = TRUE))
1032 if (both.tails) sy2 = sqrt(var(y2, na.rm = TRUE))
1033 if (doplot) {
1034 par(err=-1)
1035 lines(c(x1[1], x1[length(x1)]), c(my1,my1), type="l",
1036 lty=1, col=2)
1037 if (both.tails) lines(c(x2[1], x2[length(x2)]), c(my2,my2),
1038 type="l",lty=1, col=3) }
1039 # Return Result:
1040 result = list(xi=c(my1, sy1))
1041 if (both.tails) result = list(xi=c(my1, sy1, my2, sy2))
1042 result
1043 }
1044
1045
1046 # ------------------------------------------------------------------------------
1047
1048
1049 shaparmDEHaan =
1050 function (x, tail, yrange, doplot = TRUE, both.tails = TRUE, ...)
1051 { # A function written by D. Wuertz
1052
1053 # ORDER RESIDUALS:
1054 ordered1 = rev(sort(abs(x[x < 0])))
1055 if (both.tails) ordered2 = rev(sort(abs(x[x > 0])))
1056 n1 = length(ordered1)
1057 if (both.tails) n2 = length(ordered2)
1058 ordered1 = ordered1[1:floor(tail*n1)]
1059 if (both.tails) ordered2 = ordered2[1:floor(tail*n2)]
1060 n1 = length(ordered1)
1061 if (both.tails) n2 = length(ordered2)
1062 # DECKERS-EINMAHL-deHAAN ESTIMATE:
1063 ns0 = 1
1064 n1m = n1-1; ns1 = ns0; ns1p = ns1+1
1065 bod1 = c( cumsum(log(ordered1))[ns1:n1m]/(ns1:n1m) -
1066 log(ordered1)[ns1p:n1] )
1067 bid1 = c( cumsum((log(ordered1))^2)[ns1:n1m]/(ns1:n1m) -
1068 2*cumsum(log(ordered1))[ns1:n1m]*log(ordered1)[ns1p:n1]/(ns1:n1m) +
1069 ((log(ordered1))^2)[ns1p:n1] )
1070 dehaan1 = ( 1.0 + bod1 + ( 0.5 / ( bod1^2/bid1 - 1 ) ))
1071 if (both.tails) {
1072 n2m = n2-1; ns2 = ns0; ns2p = ns2+1
1073 bod2 = c( cumsum(log(ordered2))[ns2:n2m]/(ns2:n2m) -
1074 log(ordered2)[ns2p:n2] )
1075 bid2 = c( cumsum((log(ordered2))^2)[ns2:n2m]/(ns2:n2m) -
1076 2*cumsum(log(ordered2))[ns2:n2m]*log(ordered2)[ns2p:n2]/(ns2:n2m) +
1077 ((log(ordered2))^2)[ns2p:n2] )
1078 dehaan2 = ( 1.0 + bod2 + ( 0.5 / ( bod2^2/bid2 - 1 ) )) }
1079 # PREPARE PLOT:
1080 y1 = dehaan1[dehaan1 > yrange[1] & dehaan1 < yrange[2]]
1081 x1 = log10(1:length(dehaan1))[dehaan1 > yrange[1] &
1082 dehaan1 < yrange[2]]
1083 if (both.tails) {
1084 y2 = dehaan2[dehaan2 > yrange[1] & dehaan2 < yrange[2]]
1085 x2 = log10(1:length(dehaan2))[dehaan2 > yrange[1] &
1086 dehaan2 < yrange[2]] }
1087 if (doplot) {
1088 par(err=-1)
1089 plot (x1, y1, xlab="log scale", ylab="xi", ylim=yrange,
1090 main="Deckers - Einmahl - de Haan Estimator", type="n")
1091 title(sub=paste("tail depth:", as.character(tail)))
1092 lines(x1, y1, type="p", pch=2, col=2)
1093 if (both.tails) lines(x2, y2, type="p", pch=6, col=3) }
1094 # CALCULATE INVERSE XI:
1095 my1 = mean(y1, na.rm = TRUE)
1096 if (both.tails) my2 = mean(y2, na.rm = TRUE)
1097 sy1 = sqrt(var(y1, na.rm = TRUE))
1098 if (both.tails) sy2 = sqrt(var(y2, na.rm = TRUE))
1099 if (doplot) {
1100 par(err=-1)
1101 lines(c(x1[1], x1[length(x1)]), c(my1,my1), type="l",
1102 lty=1, col=2)
1103 if (both.tails) lines(c(x2[1], x2[length(x2)]), c(my2, my2),
1104 type = "l", lty = 1, col = 3) }
1105 # Return Result:
1106 result = list(xi = c(my1, sy1))
1107 if (both.tails) result = list(xi=c(my1, sy1, my2, sy2))
1108 result
1109 }
1110
1111
1112 ################################################################################
1113
+155
-0
R/053A-GpdModelling.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 # ##############################################################################
30 # FUNCTION: GPD DISTRIBUTION FAMILY:
31 # dgpd Density for the Generalized Pareto DF [USE FROM EVIS]
32 # pgpd Probability for the Generalized Pareto DF
33 # qgpd Quantiles for the Generalized Pareto DF
34 # rgpd Random variates for the Generalized Pareto DF
35 # FUNCTION: MOMENTS:
36 # .gpdMoments Computes true statistics for GPD distribution
37 ################################################################################
38
39
40 dgpd =
41 function(x, xi = 1, mu = 0, beta = 1)
42 { # A function written by Diethelm Wuertz
43
44 # FUNCTION:
45
46 # Density:
47 y = (x - mu)
48 if (xi == 0) {
49 d = (1-exp(-y/beta))/beta }
50 else {
51 d = 1/beta * (1 + (xi*y)/beta)^((-1/xi) - 1) }
52
53 d[y < 0] = 0
54 if (xi < 0) d[y > (-1/xi)] = 0
55
56 # Return Value:
57 d
58 }
59
60
61 # ------------------------------------------------------------------------------
62
63
64 pgpd =
65 function(q, xi = 1, mu = 0, beta = 1)
66 { # A function written by Diethelm Wuertz
67
68 # FUNCTION:
69
70 # Probability:
71 y = (q - mu)
72 if (xi == 0) {
73 p = y/beta + exp(-y/beta) -1 }
74 else {
75 p = (1 - (1 + (xi*y)/beta)^(-1/xi)) }
76
77 p[y < 0] = 0
78 if (xi < 0) p[y > (-1/xi)] = 1
79
80 # Return Value:
81 p
82 }
83
84
85 # ------------------------------------------------------------------------------
86
87
88 qgpd =
89 function(p, xi = 1, mu = 0, beta = 1)
90 { # A function written by Diethelm Wuertz
91
92 # FUNCTION:
93
94 # Quantiles:
95 if (xi == 0)
96 q = mu - beta*log(1-p)
97 else
98 q = mu + (beta/xi) * ((1 - p)^( - xi) - 1)
99
100 # Return Value:
101 q
102 }
103
104
105 # ------------------------------------------------------------------------------
106
107
108 rgpd =
109 function(n, xi = 1, mu = 0, beta = 1)
110 { # A function written by Diethelm Wuertz
111
112 # FUNCTION:
113
114 # Random variates:
115 rvs = mu + (beta/xi) * ((1 - runif(n))^( - xi) - 1)
116
117 # Return Value:
118 rvs
119 }
120
121
122 # ------------------------------------------------------------------------------
123
124
125 .gpdMoments =
126 function(xi, mu = 0, beta = 1)
127 { # A function implemented by Diethelm Wuertz
128
129 # Description:
130 # Compute true statistics for Generalized Pareto distribution
131
132 # Value:
133 # Returns true mean of Generalized Pareto distribution
134 # for xi < 1 else NaN
135 # Returns true variance of Generalized Pareto distribution
136 # for xi < 1 else NaN
137
138 # FUNCTION:
139
140 # MEAN: Rreturns 1 for x <= 0 and -Inf's's else
141 a = c(1, NaN, NaN)
142 gpdMean = beta/(1-xi)*a[sign(xi-1)+2]
143
144 # VAR: Rreturns 1 for x <= 0 and -Inf's's else
145 a = c(1, NaN, NaN)
146 gpdVar = beta*beta/(1-xi)^2/(1-2*xi) * a[sign(2*xi-1)+2]
147
148 # Return Value:
149 list(mean = gevMean, var = gevVar)
150 }
151
152
153 ################################################################################
154
+417
-0
R/053B-GpdFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: GPD MODELLING FROM EVIS:
31 # gpdSim Simulates GPD rvs
32 # gpdFit Fits GPD Distribution
33 # print.gpd Print Method for object of class "gpd"
34 # plot.gpd Plot Method for object of class "gpd"
35 # summary.gpd Summary Method for object of class "gpd"
36 # FUNCTION: ADDITIONAL PLOTS:
37 # gpdtailPlot Plots Tail Estimate From GPD Model
38 # gpdquantPlot Plots of GPD Tail Estimate of a High Quantile
39 # gpdshapePlot Plots for GPD Shape Parameter
40 # gpdqPlot Adds Quantile Estimates to plot.gpd
41 # gpdsfallPlot Adds Expected Shortfall Estimates to a GPD Plot
42 # FUNCTION: ADDITIONAL FUNCTION:
43 # gpdriskmeasures Calculates Quantiles and Expected Shortfalls
44 ################################################################################
45
46
47 gpdSim =
48 function(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
49 { # A function implemented by Diethelm Wuertz
50
51 # Description:
52 # Generates random variates from a GPD distribution
53
54
55 # FUNCTION:
56
57 # Simulate:
58 rgpd(n = n, xi = model$shape, mu = model$location, beta = model$scale)
59 }
60
61
62 # ------------------------------------------------------------------------------
63
64
65 gpdFit =
66 function(x, threshold = NA, nextremes = NA, type = c("mle", "pwm"),
67 information = c("observed", "expected"), ...)
68 { # A function implemented by Diethelm Wuertz
69
70 # Description:
71 # Returns an object of class `"gpd"' representing the fit of a
72 # generalized Pareto model to excesses over a high threshold
73
74 # Notes:
75 # This is a wrapper to EVIR's 'gpd' function.
76
77 # FUNCTION:
78
79 # Make the fit:
80 call = match.call()
81 type = type[1]
82 # if (is.na(threshold) & is.na(nextremes)) threshold = min(x)
83 if (type == "mle") {
84 type = "ml"
85 }
86 fitted = gpd(data = x, threshold = threshold, nextremes = nextremes,
87 method = type, information = information, ...)
88
89 # Residuals:
90 xi = fitted$par.ests["xi"]
91 beta = fitted$par.ests["beta"]
92 excess = as.numeric(fitted$data) - fitted$threshold
93 residuals = log(1 + (xi * excess)/beta)/xi
94
95 # Make Unique:
96 fit = list()
97 fit$fit = fitted
98 fit$call = call
99 fit$type = c("gpd", type[1])
100 fit$par.ests = fitted$par.ests
101 fit$par.ses = fitted$par.ses
102 fit$residuals = residuals
103 fit$fitted.values = fitted$data - residuals
104 fit$llh = fitted$nllh.final
105 fit$converged = fitted$converged
106
107 # Return Value:
108 class(fit) = "gpdFit"
109 fit
110 }
111
112
113 # ------------------------------------------------------------------------------
114
115
116 print.gpdFit =
117 function(x, ...)
118 { # A function implemented by Diethelm Wuertz
119
120 # Description:
121 # Print Method for an object of class 'gpdFit'
122
123 # FUNCTION:
124
125 # Function Call:
126 cat("\nCall:\n")
127 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
128
129 # Estimation Type:
130 cat("\nEstimation Type:", x$type, "\n")
131
132 # Estimated Parameters:
133 cat("\nEstimated Parameters:\n")
134 print(x$par.ests)
135 cat("\n")
136
137 # Return Value:
138 invisible(x)
139 }
140
141
142 # ------------------------------------------------------------------------------
143
144
145 plot.gpdFit =
146 function(x, which = "all", ...)
147 { # A function implemented by Diethelm Wuertz
148
149 # Description:
150 # Plot method for objects of class 'gpdFit'
151
152 # FUNCTION:
153
154 # Plot Functions:
155 plot.1 <<- function(x, ...) {
156 fit = x
157 data = fit$fit$data
158 xi = fit$par.ests[1]
159 beta = fit$par.est[2]
160 threshold = fit$fit$threshold
161 optlog = NA
162 extend = 1.5
163 labels = TRUE
164 # Start:
165 plotmin = threshold
166 if (extend <= 1) stop("extend must be > 1")
167 plotmax = max(data) * extend
168 xx = seq(from = 0, to = 1, length = 1000)
169 z = qgpd(xx, xi, threshold, beta)
170 z = pmax(pmin(z, plotmax), plotmin)
171 ypoints = ppoints(sort(data))
172 y = pgpd(z, xi, threshold, beta)
173 type = "eplot"
174 if (!is.na(optlog)) alog = optlog
175 else alog = "x"
176 if (alog == "xy") stop("Double log does not make much sense")
177 yylab = "Fu(x-u)"
178 shape = xi
179 scale = beta
180 location = threshold
181 plot(sort(data), ypoints, xlim = range(plotmin, plotmax),
182 ylim = range(ypoints, y, na.rm = TRUE), xlab = "",
183 ylab = "", log = alog, axes = TRUE,
184 main = "Excess Distribution", ...)
185 lines(z[y >= 0], y[y >= 0])
186 xxlab = "x"
187 if (alog == "x" || alog == "xy" || alog == "yx")
188 xxlab = paste(xxlab, "(on log scale)")
189 if (alog == "xy" || alog == "yx" || alog == "y")
190 yylab = paste(yylab, "(on log scale)")
191 title(xlab = xxlab, ylab = yylab) }
192 plot.2 <<- function(x, ...) {
193 fit = x
194 data = fit$fit$data
195 xi = fit$par.ests[1]
196 beta = fit$par.est[2]
197 threshold = fit$fit$threshold
198 optlog = NA
199 extend = 1.5 #; if(extend <= 1) stop("extend must be > 1")
200 labels = TRUE
201 # Start:
202 plotmin = threshold
203 if (extend <= 1) stop("extend must be > 1")
204 plotmax = max(data) * extend
205 xx = seq(from = 0, to = 1, length = 1000)
206 z = qgpd(xx, xi, threshold, beta)
207 z = pmax(pmin(z, plotmax), plotmin)
208 ypoints = ppoints(sort(data))
209 y = pgpd(z, xi, threshold, beta)
210 type = "tail"
211 if (!is.na(optlog)) alog = optlog
212 else alog = "xy"
213 prob = fit$fit$p.less.thresh
214 ypoints = (1 - prob) * (1 - ypoints)
215 y = (1 - prob) * (1 - y)
216 yylab = "1-F(x)"
217 shape = xi
218 scale = beta * (1 - prob)^xi
219 location = threshold - (scale * ((1 - prob)^( - xi) - 1))/xi
220 plot(sort(data), ypoints, xlim = range(plotmin, plotmax),
221 ylim = range(ypoints, y, na.rm = TRUE), xlab = "",
222 ylab = "", log = alog, axes = TRUE,
223 main = "Tail of Underlying Distribution", ...)
224 lines(z[y >= 0], y[y >= 0])
225 xxlab = "x"
226 if (alog == "x" || alog == "xy" || alog == "yx")
227 xxlab = paste(xxlab, "(on log scale)")
228 if (alog == "xy" || alog == "yx" || alog == "y")
229 yylab = paste(yylab, "(on log scale)")
230 title(xlab = xxlab, ylab = yylab) }
231 plot.3 <<- function(x, ...) {
232 res = x$residuals
233 plot(res,
234 ylab = "Residuals",
235 xlab = "Ordering",
236 main = "Scatterplot of Residuals", ...)
237 lines(lowess(1:length(res), res)) }
238 plot.4 <<- function(x, ...) {
239 qplot(x$residuals,
240 main = "QQ-Plot of Residuals", ...) }
241
242 # Plot:
243 interactivePlot(
244 x = x,
245 choices = c(
246 "Excess Distribution",
247 "Tail of Underlying Distribution",
248 "Scatterplot of Residuals",
249 "QQ-Plot of Residuals"),
250 plotFUN = c(
251 "plot.1",
252 "plot.2",
253 "plot.3",
254 "plot.4"),
255 which = which)
256
257 # Return Value:
258 invisible(x)
259 }
260
261
262 # ------------------------------------------------------------------------------
263
264
265 summary.gpdFit =
266 function(object, doplot = TRUE, which = "all", ...)
267 { # A function written by Diethelm Wuertz
268
269 # Description:
270 # Summary method for objects of class "gpdFit"
271
272 # FUNCTION:
273
274 # Print:
275 print(object, ...)
276
277 # Summary:
278 # For MLE print additionally:
279 cat("\nStandard Deviations:\n"); print(object$par.ses)
280 cat("\nLog-Likelihood Value: ", object$llh)
281 cat("\nType of Convergence: ", object$conv, "\n")
282 cat("\n")
283
284 # Plot:
285 if (doplot) plot(object, which = which, ...)
286 cat("\n")
287
288 # Return Value:
289 invisible(object)
290 }
291
292
293 # ******************************************************************************
294
295
296 gpdtailPlot =
297 function(fit, optlog = NA, extend = 1.5, labels = TRUE, ...)
298 { # A function implemented by Diethelm Wuertz
299
300 # Description:
301 # Plots Tail Estimate From GPD Model
302
303 # FUNCTION:
304
305 # Return Value:
306 tailplot(x = fit$fit, optlog = optlog, extend = extend,
307 labels = labels, ...)
308 }
309
310
311 # ------------------------------------------------------------------------------
312
313
314 gpdquantPlot =
315 function(data, p = 0.99, models = 30, start = 15, end = 500,
316 reverse = TRUE, ci = 0.95, autoscale = TRUE, labels = TRUE, ...)
317 { # A function implemented by Diethelm Wuertz
318
319 # Description:
320 # Plots of GPD Tail Estimate of a High Quantile
321
322 # FUNCTION:
323
324 # Return Value:
325 quant(data = data, p = p, models = models, start = start, end = end,
326 reverse = reverse, ci = ci, auto.scale = autoscale, labels = labels,
327 ...)
328 }
329
330
331 # ------------------------------------------------------------------------------
332
333
334 gpdshapePlot =
335 function(data, models = 30, start = 15, end = 500, reverse = TRUE,
336 ci = 0.95, autoscale = TRUE, labels = TRUE, ...)
337 { # A function implemented by Diethelm Wuertz
338
339 # Description:
340 # Plots for GPD Shape Parameter
341
342 # FUNCTION:
343
344 # Return Value:
345 shape(data = data, models = models, start = start, end = end,
346 reverse = reverse, ci = ci, auto.scale = autoscale,
347 labels = labels, ...)
348 }
349
350
351 # ------------------------------------------------------------------------------
352
353
354 gpdqPlot =
355 function(x, pp = 0.99, ci.type = c("likelihood", "wald"), ci.p = 0.95,
356 like.num = 50)
357 { # A function implemented by Diethelm Wuertz
358
359 # Description:
360 # Adds Quantile Estimates to plot.gpd
361
362 # Arguments:
363 # x - an object of class 'gpdFit'
364 # pp - the probability level
365
366 # FUNCTION:
367
368 # Return Value:
369 gpd.q(x = x, pp = pp, ci.type = ci.type, ci.p = ci.p, like.num = like.num)
370 }
371
372
373 # ------------------------------------------------------------------------------
374
375
376 gpdsfallPlot =
377 function(x, pp = 0.99, ci.p = 0.95, like.num = 50)
378 { # A function implemented by Diethelm Wuertz
379
380 # Description:
381 # Adds Expected Shortfall Estimates to a GPD Plot
382
383 # Arguments:
384 # x - an object of class 'gpdFit'
385 # pp - the probability level
386
387 # FUNCTION:
388
389 # Return Value:
390 gpd.sfall(x = x, pp = pp, ci.p = ci.p, like.num = like.num)
391 }
392
393
394 # ------------------------------------------------------------------------------
395
396
397 gpdriskmeasures =
398 function(x, plevels = c(0.99, 0.995, 0.999, 0.9995, 0.9999))
399 { # A function implemented by Diethelm Wuertz
400
401 # Description:
402 # Calculates Quantiles and Expected Shortfalls
403
404 # Arguments:
405 # x - an object of class 'gpdFit'
406 # p - a numeric value or vector of probability levels
407
408 # FUNCTION:
409
410 # Return Value:
411 as.data.frame(riskmeasures(x = x$fit, p = plevels))
412 }
413
414
415 # ******************************************************************************
416
+285
-0
R/053C-PotFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: POT MODELLING FROM EVIS:
31 # potSim Peaks over a threshold from arbitrary series
32 # potFit Fits with POT method
33 # print.potFit Print Method for object of class "potFit"
34 # plot.potFit Print Method for object of class "potFit"
35 # summary.potFit Summary Method for object of class "potFit"
36 # REQUIRES:
37 # ts Package ts (is preloaded)
38 ################################################################################
39
40
41 potSim =
42 function(x, threshold, nextremes = NA, run = NA)
43 { # A function implemented by Diethelm Wuertz
44
45 # Description:
46 # Generates from an arbitray rvs sequence a series with
47 # the peaks over a threshold
48
49 # Settings:
50 data = x
51 n = length(as.numeric(data))
52 times = attributes(data)$times
53 if (is.null(times)) {
54 times = 1:n
55 attributes(data)$times = times
56 start = 1
57 end = n
58 span = end - start}
59 else {
60 start = times[1]
61 end = times[n]
62 span = as.numeric(difftime(as.POSIXlt(times)[n], as.POSIXlt(times)[1],
63 units = "days"))}
64
65 if (is.na(nextremes) && is.na(threshold))
66 stop("Enter either a threshold or the number of upper extremes")
67 if (!is.na(nextremes) && !is.na(threshold))
68 stop("Enter EITHER a threshold or the number of upper extremes")
69 if (!is.na(nextremes))
70 threshold = findthresh(as.numeric(data), nextremes)
71 if (threshold > 10) {
72 factor = 10^(floor(log10(threshold)))
73 cat(paste("If singularity problems occur divide data",
74 "by a factor, perhaps", factor, "\n")) }
75
76 exceedances.its = structure(data[data > threshold], times = times[data >
77 threshold])
78 n.exceed = length(as.numeric(exceedances.its))
79 p.less.thresh = 1 - n.exceed/n
80 if (!is.na(run)) {
81 exceedances.its = decluster(exceedances.its, run, picture)
82 n.exceed = length(exceedances.its) }
83 intensity = n.exceed/span
84 exceedances = as.numeric(exceedances.its)
85
86
87 # Return Value:
88 exceedances
89 }
90
91
92 # ------------------------------------------------------------------------------
93
94
95 potFit =
96 function(x, threshold = NA, nextremes = NA, run = NA, ...)
97 { # A function implemented by Diethelm Wuertz
98
99 # Description:
100 # Parameter Estimation for the POT model.
101
102 # FUNCTION:
103
104 # Call pot() from evir:
105 call = match.call()
106 fitted = pot(data = x, threshold = threshold, nextremes = nextremes,
107 run = run, picture = FALSE, ...)
108
109 # Compute Residuals:
110 xi = fitted$par.ests[1]
111 beta = fitted$par.ests[4]
112 threshold = fitted$threshold
113 fitted$residuals =
114 as.vector(log(1 + (xi * (fitted$data - threshold))/beta)/xi)
115
116 # Gaps:
117 x = fitted
118 x$rawdata = x$data
119 n = length(as.numeric(x$rawdata))
120 x$times = attributes(x$rawdata)$times
121 if (is.character(x$times) || inherits(x$times, "POSIXt") ||
122 inherits(x$times, "date") || inherits(x$times, "dates")) {
123 x$times = as.POSIXlt(x$times)
124 x$gaps = as.numeric(difftime(x$times[2:n], x$times[1:(n - 1)],
125 units = "days")) * x$intensity }
126 else {
127 x$times = 1:n
128 x$gaps = as.numeric(diff(x$times)) * x$intensity }
129 fitted$times = x$times
130 fitted$rawdata = x$rawdata
131 fitted$gaps = x$gaps
132
133 # Add:
134 fit = list()
135 fit$fit = fitted
136 fit$call = call
137 fit$type = c("pot", "mle")
138 fit$par.ests = fitted$par.ests
139 fit$par.ses = fitted$par.ses
140 fit$residuals = fitted$residuals
141 fit$fitted.values = fitted$data - fitted$residuals
142 fit$llh = fitted$nllh.final
143 fit$converged = fitted$converged
144
145 # Return Value:
146 class(fit) = "potFit"
147 fit
148 }
149
150
151 # ******************************************************************************
152
153
154 print.potFit =
155 function(x, ...)
156 { # A function implemented by Diethelm Wuertz
157
158 # Description:
159 # Print Method for object of class "potFit"
160
161 # FUNCTION:
162
163 # Function Call:
164 cat("\nCall:\n")
165 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
166
167 # Estimation Type:
168 cat("\nEstimation Type:", x$type, "\n")
169
170 # Estimated Parameters:
171 cat("\nEstimated Parameters:\n")
172 print(x$par.ests)
173 cat("\n")
174
175 # Decluster Run Length:
176 if (!is.na(fit$fit$run))
177 cat("\nDecluster Runlength:", x$fit$run, "\n")
178
179 # Return Value:
180 invisible(x)
181 }
182
183
184 # ------------------------------------------------------------------------------
185
186
187 plot.potFit =
188 function(x, which = "all", ...)
189 { # A function implemented by Diethelm Wuertz
190
191 # Description:
192 # Plot method for objects of class "potFit".
193
194 # FUNCTION:
195
196 # Plot functions:
197 plot.1 <<- function(x, ...) {
198 plot(x$times, x$rawdata , type = "h",
199 main = "Point Process of Exceedances", ...) }
200 plot.2 <<- function(x, ...) {
201 plot(x$gaps, ylab = "Gaps", xlab = "Ordering",
202 main = "Scatterplot of Gaps", ...)
203 lines(lowess(1:length(x$gaps), x$gaps)) }
204 plot.3 <<- function(x, ...) {
205 qplot(x$gaps,
206 main = "QQ-Plot of Gaps", ...) }
207 plot.4 <<- function(x, ...) {
208 acf(x$gaps, lag.max=20,
209 main = "ACF of Gaps", ...) }
210 plot.5 <<- function(x, ...) {
211 plot(x$residuals, ylab = "Residuals", xlab = "Ordering",
212 main = "Scatterplot of Residuals", ...)
213 lines(lowess(1:length(x$residuals), x$residuals)) }
214 plot.6 <<- function (x, ...) {
215 qplot(x$residuals,
216 main = "QQ-Plot of Residuals", ...) }
217 plot.7 <<- function (x, ...) {
218 acf(x$residuals, lag.max = 20,
219 main = "ACF of Residuals", ...) }
220 fit <<- fit; plot.8 <<- function (x, ...) {
221 if (which == "ask") {
222 plot.gpd(x)
223 plot.potFit(fit, which = "ask") } }
224
225 # Plot:
226 interactivePlot(
227 x = x$fit,
228 choices = c(
229 "Point Process of Exceedances",
230 "Scatterplot of Gaps",
231 "QQ-Plot of Gaps",
232 "ACF of Gaps",
233 "Scatterplot of Residuals",
234 "QQ-Plot of Residuals",
235 "ACF of Residuals",
236 "GOTO GPD Plots"),
237 plotFUN = c(
238 "plot.1",
239 "plot.2",
240 "plot.3",
241 "plot.4",
242 "plot.5",
243 "plot.6",
244 "plot.7",
245 "plot.8"),
246 which = which)
247
248 # Return Value:
249 invisible(x)
250 }
251
252
253 # ------------------------------------------------------------------------------
254
255
256 summary.potFit =
257 function(object, doplot = TRUE, which = "all", ...)
258 { # A function implemented by Diethelm Wuertz
259
260 # Description:
261 # Summary Method for object of class "potFit"
262
263 # FUNCTION:
264
265 # Print:
266 print(object, ...)
267
268 # Summary:
269 cat("\nStandard Deviations:\n"); print(object$par.ses)
270 cat("\nLog-Likelihood Value: ", object$llh)
271 cat("\nType of Convergence: ", object$converged, "\n")
272 cat("\n")
273
274 # Plot:
275 if (doplot) plot.potFit(object, which = which, ...)
276 cat("\n")
277
278 # Return Value:
279 invisible(object)
280 }
281
282
283 # ******************************************************************************
284
+305
-0
R/054A-ExtremesGlm.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: GEV MODELLING FROM ISMEV:
31 # gevglmFit Fits GEV Distribution
32 # print.gevglmFit Print Method for object of class "gevglm"
33 # plot.gevglmFit Plot Method for object of class "gevglm"
34 # summary.gevglmFit Summary Method for object of class "gevglm"
35 # FUNCTION: ADDITIONAL PLOTS:
36 # gevglmprofPlot Profile Log-likelihoods for Stationary GEV Models
37 # gevglmprofxiPlot Profile Log-likelihoods for Stationary GEV Models
38 ################################################################################
39
40
41 gevglmFit =
42 function(x, y = NULL, gumbel = FALSE, mul = NULL, sigl = NULL, shl = NULL,
43 mulink = identity, siglink = identity, shlink = identity, show = FALSE,
44 method = "Nelder-Mead", maxit = 10000, ...)
45 { # A function written by Diethelm Wuertz
46
47 # Description:
48 # Fits GEV Distribution
49
50 # Note:
51 # This is a function wrapper to the functions 'gev.fit' and
52 # 'gum.fit' which are part of the R package 'ismev'.
53
54 # FUNCTION:
55
56 # Fit - Use gev.fit() and gum.fit() from R's ismev Package:
57 call = match.call()
58 if (gumbel) {
59 fitted = gum.fit(xdat = x, ydat = y, mul = mul, sigl = sigl,
60 mulink = mulink, siglink = siglink, show = show,
61 method = method, maxit = maxit, ...) }
62 else {
63 fitted = gev.fit(xdat = x, ydat = y, mul = mul, sigl = sigl, shl = shl,
64 mulink = mulink, siglink = siglink, shlink = shlink, show = show,
65 method = method, maxit = maxit, ...) }
66 fitted$gumbel = gumbel
67
68 # Standard Errors and Covariance Matrix:
69 if (gumbel) {
70 # Parameters - We take the same order as in gevFit:
71 mle = rev(fitted$mle)
72 names(mle) = c("sigma", "mu")
73 se = rev(fitted$se)
74 names(se) = c("sigma", "mu")
75 covar = fitted$cov
76 covar[1,1] = fitted$cov[2,2]
77 covar[2,2] = fitted$cov[1,1] }
78 else {
79 # Parameters - We take the same order as in gevFit:
80 mle = rev(fitted$mle)
81 names(mle) = c("xi", "sigma", "mu")
82 se = rev(fitted$se)
83 names(se) = c("xi", "sigma", "mu")
84 covar = fitted$cov
85 covar[1,1] = fitted$cov[3,3]
86 covar[3,3] = fitted$cov[1,1]
87 covar[1,2] = covar[2,1] = fitted$cov[2,3]
88 covar[2,3] = covar[3,2] = fitted$cov[1,2] }
89 fitted$covar = covar
90
91 # Calculate Residuals:
92 if (gumbel) {
93 # GUMBEL:
94 xi = 0
95 sigma = mle[1]
96 mu = mle[2]
97 residuals = exp( - exp( - (fitted$data - mu)/sigma)) }
98 else {
99 # GEV:
100 xi = fitted$mle[1]
101 sigma = fitted$mle[2]
102 mu = fitted$mle[3]
103 residuals = (1 + (xi * (fitted$data - mu))/sigma)^(-1/xi) }
104
105 # Add:
106 fit = list()
107 fit$fit = fitted
108 fit$call = match.call()
109 fit$type = c(if(gumbel) "gumglm" else "gevglm", "mle")
110 fit$par.ests = mle
111 fit$par.ses = se
112 fit$residuals = residuals
113 fit$fitted.values = x - residuals
114 fit$llh = fitted$nllh
115 fit$converged = fitted$conv
116
117 # Return Value:
118 class(fit) = "gevglmFit"
119 fit
120 }
121
122
123 # ******************************************************************************
124
125
126 print.gevglmFit =
127 function(x, ...)
128 { # A function implemented by Diethelm Wuertz
129
130 # Description:
131 # Print method for objects of class 'gevglmFit'
132
133 # FUNCTION:
134
135 # Function Call:
136 cat("\nCall:\n")
137 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
138
139 # Estimation Type:
140 cat("\nEstimation Type:", x$type, "\n")
141
142 # Fitted Parameters:
143 cat("\nEstimated Parameters:\n")
144 print(x$par.ests)
145 cat("\n")
146
147 # Return Value:
148 invisible(x)
149 }
150
151
152 # ------------------------------------------------------------------------------
153
154
155 plot.gevglmFit =
156 function(x, which = "ask", ...)
157 { # A function implemented by Diethelm Wuertz
158
159 # Description:
160 # Plot method for objects of class 'gevglmFit'
161
162 # FUNCTION:
163
164 # Settings:
165 fit = x
166
167 # Internal "plot.n" Function:
168 plot.1 <<- function(x, ...) {
169 if (x$gumbel) x$mle = c(x$mle, 0)
170 gev.pp(x$mle, x$data) }
171 plot.2 <<- function(x, ...) {
172 if (x$gumbel) x$mle = c(x$mle, 0)
173 gev.qq(x$mle, x$data) }
174 plot.3 <<- function(x, ...) {
175 if (x$gumbel) {
176 fit$mle = c(x$mle, 0)
177 gum.rl(x$mle, x$cov, x$data) }
178 else {
179 gev.rl(x$mle, x$cov, x$data) } }
180 plot.4 <<- function(x, ...) {
181 if (x$gumbel) x$mle = c(x$mle, 0)
182 gev.his(x$mle, x$data) }
183 plot.5 <<- function(x, ...) {
184 n = length(x$data)
185 z = (1:n)/(n + 1)
186 plot(z, exp( - exp( - sort(x$data))),
187 xlab = "empirical", ylab = "model")
188 abline(0, 1, col = 4)
189 title("Residual Probability Plot") }
190 plot.6 <<- function(x, ...) {
191 n = length(x$data)
192 z = (1:n)/(n + 1)
193 plot( - log( - log(z)), sort(x$data),
194 xlab = "empirical", ylab = "model")
195 abline(0, 1, col = 4)
196 title("Residual Quantile Plot (Gumbel Scale)") }
197
198 # Plot:
199 if (fit$fit$trans) {
200 # Non-Stationary Plots: plot 11-12
201 interactivePlot(
202 x = x$fit,
203 choices = c(
204 "Residual Probability Plot",
205 "Residual Quantile Plot"),
206 plotFUN = c(
207 "plot.5",
208 "plot.6"),
209 which = which) }
210 else {
211 # Stationary Plots: plot 01-04
212 interactivePlot(
213 x = x$fit,
214 choices = c(
215 "Residual Probability Plot",
216 "Residual Quantile Plot",
217 "Return Level Plot",
218 "Density Plot"),
219 plotFUN = c(
220 "plot.1",
221 "plot.2",
222 "plot.3",
223 "plot.4"),
224 which = which) }
225
226 # Return Value:
227 invisible(x)
228 }
229
230
231 # ------------------------------------------------------------------------------
232
233
234 summary.gevglmFit =
235 function(object, doplot = TRUE, which = "all", ...)
236 { # A function implemented by Diethelm Wuertz
237
238 # Description:
239 # Summary method for objects of class 'gevglmFit'
240
241 # FUNCTION:
242
243 # Print:
244 print(object, ...)
245
246 # Summary:
247 cat("\nStandard Deviations:\n"); print(object$par.ses)
248 cat("\nLog-Likelihood Value: ", object$llh)
249 cat("\nType of Convergence: ", object$converged, "\n")
250 cat("\n")
251
252 # Plot:
253 if (doplot) plot(object, which = which, ...)
254 cat("\n")
255
256 # Return Result
257 invisible(object)
258 }
259
260
261 # ******************************************************************************
262
263
264 gevglmprofPlot =
265 function(object, m, xlow, xup, conf = 0.95, nint = 100)
266 { # A function implemented by Diethelm Wuertz
267
268 # Description:
269 # Profile Log-likelihoods for Stationary GEV Models.
270
271 # FUNCTION:
272
273 # Compute:
274 if (object$fit$gumbel) {
275 stop("Not for Gumbel type distributions") }
276 else {
277 gev.prof(z = object$fit, m = m, xlow = xlow, xup = xup , conf = conf,
278 nint = nint) }
279 }
280
281
282 # ------------------------------------------------------------------------------
283
284
285 gevglmprofxiPlot =
286 function(object, xlow, xup, conf = 0.95, nint = 100)
287 { # A function implemented by Diethelm Wuertz
288
289 # Description:
290 # Profile Log-likelihoods for Stationary GEV Models.
291
292 # FUNCTION:
293
294 # Compute:
295 if (object$fit$gumbel) {
296 stop("Not for Gumbel type distributions") }
297 else {
298 gev.profxi(z = object$fit, xlow = xlow, xup = xup, conf = conf,
299 nint = nint) }
300 }
301
302
303 # ******************************************************************************
304
+252
-0
R/054B-GpdGlmFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: GPD MODELLING FROM ISMEV:
31 # gpdglmFit Fits GPD Distribution
32 # print.gpdglmFit Print Method for object of class "gpdglm"
33 # plot.gpdglmFit Plot Method for object of class "gpdglm"
34 # summary.gpdglmFit Summary Method for object of class "gevglm"
35 # FUNCTION: ADDITIONAL PLOTS:
36 # gpdglmprofPlot Profile Log-likelihoods for Stationary GPD Models
37 # gpdglmprofxiPlot Profile Log-likelihoods for Stationary GPD Models
38 ################################################################################
39
40
41 gpdglmFit =
42 function(x, threshold = min(x), npy = 365, y = NULL, sigl = NULL, shl = NULL,
43 siglink = identity, shlink = identity, show = FALSE, method = "Nelder-Mead",
44 maxit = 10000, ...)
45 { # A function implemented by Diethelm Wuertz
46
47 # Description:
48
49 # FUNCTION:
50
51 # Function Call:
52 call = match.call()
53 # Fit Parameters:
54 fitted = gpd.fit(xdat = x, threshold = threshold, npy = npy, ydat = y,
55 sigl = sigl, shl = shl, siglink = siglink, shlink = shlink,
56 show = show, method = method, maxit = maxit, ...)
57 # Add names attribute:
58 names(fitted$se) = names(fitted$mle) = c("sigma", "mle")
59
60 # Add:
61 fit = list()
62 fit$fit = fitted
63 fit$call = call
64 fit$type = c("gpdglm", "mle")
65 fit$par.ests = fitted$mle
66 fit$par.ses = fitted$se
67 fit$residuals = fitted$residuals
68 fit$fitted.values = x - fitted$residuals
69 fit$llh = fitted$nllh
70 fit$converged = fitted$conv
71
72 # Return Value:
73 class(fit) = "gpdglmFit"
74 fit
75 }
76
77
78 # ------------------------------------------------------------------------------
79
80
81 print.gpdglmFit =
82 function(x, ...)
83 { # A function implemented by Diethelm Wuertz
84
85 # Description:
86 # Print Method for an object of class 'gpdglmFit'
87
88 # FUNCTION:
89
90 # Print Call:
91 cat("\nCall:\n")
92 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
93
94 if (fit$fit$trans) {
95 # Still to do:
96 print.default(x) }
97 else {
98 # Estimation Type:
99 cat("\nEstimation Type:", x$type, "\n")
100 # Fitted Parameters:
101 cat("\nEstimated Parameters:\n")
102 print(x$par.ests)
103 cat("\n") }
104
105 # Return Value:
106 invisible(x)
107 }
108
109
110 # ------------------------------------------------------------------------------
111
112
113 plot.gpdglmFit =
114 function(x, which = "all", ...)
115 { # A function implemented by Diethelm Wuertz
116
117 # Description:
118 # Print Method for an object of class 'gpdglmFit'
119
120 # FUNCTION:
121
122 # Plot Functions:
123 if(x$fit$trans) {
124 plot.1 <<- function(x, ...) {
125 n = length(x$data)
126 plot(
127 x = (1:n)/(n + 1),
128 y = 1 - exp( - sort(x$data)),
129 xlab = "Empirical",
130 ylab = "Model")
131 abline(0, 1, col = 4)
132 title("Residual Probability Plot") }
133 plot.2 <<- function(x, ...) {
134 n = length(x$data)
135 plot(
136 x = - log( 1 - (1:n)/(n+1) ),
137 y = sort(x$data),
138 ylab = "Empirical",
139 xlab = "Model")
140 abline(0, 1, col = 4)
141 title("Residual Quantile Plot (Exptl. Scale)") } }
142 else {
143 plot.1 <<- function(x, ...) {
144 gpd.pp(x$mle, x$threshold, x$data) }
145 plot.2 <<- function(x, ...) {
146 gpd.qq(x$mle, x$threshold, x$data) }
147 plot.3 <<- function(x, ...) {
148 gpd.rl(x$mle, x$threshold, x$rate, x$n, x$npy,
149 x$cov, x$data, x$xdata) }
150 plot.4 <<- function(x, ...) {
151 gpd.his(x$mle, x$threshold, x$data) } }
152
153 # Plot:
154 if (fit$fit$trans) {
155 interactivePlot(
156 x = x$fit,
157 choices = c(
158 "Excess Distribution",
159 "QQ-Plot of Residuals"),
160 plotFUN = c(
161 "plot.1",
162 "plot.2"),
163 which = which) }
164 else {
165 interactivePlot(
166 x = x$fit,
167 choices = c(
168 "Probability Plot",
169 "Quantile Plot",
170 "Return Level Plot",
171 "Histogram Plot"),
172 plotFUN = c(
173 "plot.1",
174 "plot.2",
175 "plot.3",
176 "plot.4"),
177 which = which) }
178
179 # Return Value:
180 invisible(x)
181 }
182
183
184 # ------------------------------------------------------------------------------
185
186
187 summary.gpdglmFit =
188 function(object, doplot = TRUE, which = "all", ...)
189 { # A function written by Diethelm Wuertz
190
191 # Description:
192 # Summary Method for an object of class 'gpdglmFit'
193
194 # FUNCTION:
195
196 # Print:
197 print(object, ...)
198
199 # Summary:
200 cat("\nStandard Deviations:\n"); print(object$par.ses)
201 cat("\nLog-Likelihood Value: ", object$llh)
202 cat("\nType of Convergence: ", object$converged, "\n")
203 cat("\n")
204
205 # Plot:
206 if (doplot) plot(object, which = which, ...)
207 cat("\n")
208
209 # Return Value:
210 invisible(object)
211 }
212
213
214 # ******************************************************************************
215
216
217 gpdglmprofPlot =
218 function(fit, m, xlow, xup, conf = 0.95, nint = 100, ...)
219 { # A function implemented by Diethelm Wuertz
220
221 # Description:
222 # Profile Log-likelihoods for Stationary GPD Models
223
224 # FUNCTION:
225
226 # Compute:
227 gpd.prof(z = fit$fit, m = m, xlow = xlow, xup = xup , conf = conf,
228 nint = nint)
229 }
230
231
232 # ------------------------------------------------------------------------------
233
234
235 gpdglmprofxiPlot =
236 function(fit, xlow, xup, conf = 0.95, nint = 100, ...)
237 { # A function implemented by Diethelm Wuertz
238
239 # Description:
240 # Profile Log-likelihoods for Stationary GPD Models
241
242 # FUNCTION:
243
244 # Compute:
245 gpd.profxi(z = fit$fit, xlow = xlow, xup = xup, conf = conf,
246 nint = nint, ...)
247 }
248
249
250 # ******************************************************************************
251
+206
-0
R/054C-PPFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: POINT PROCESS MODELLING FROM ISMEV:
31 # ppFit Fits Point Process Model
32 # print.ppFit Print Method for object of class "ppFit"
33 # plot.ppFit Plot Method for object of class "ppFit"
34 # summary.ppFit Summary Method for object of class "ppFit"
35 ################################################################################
36
37
38 ppFit =
39 function(x, threshold, npy = 365, y = NULL, mul = NULL, sigl = NULL,
40 shl = NULL, mulink = identity, siglink = identity, shlink = identity,
41 method = "Nelder-Mead", maxit = 10000, ...)
42 { # A function implemented by Diethelm Wuertz
43
44 # Description:
45
46 # FUNCTION:
47
48 # Function Call:
49 call = match.call()
50 # Fit Parameters:
51 fitted = pp.fit(xdat = x, threshold = threshold, npy = npy, ydat = y,
52 mul = mul, sigl = sigl, shl = shl, mulink = mulink, siglink = siglink,
53 shlink = shlink, show = FALSE, method = method, maxit = maxit, ...)
54 names(fitted$mle) =names(fitted$se) = c("xi", "sigma", "mu")
55 # Compute Residuals:
56 residuals = NA
57 # cat("\nVariance Covariance Matrix:\n")
58 # covar = fit$cov
59 # covar[1,1] = fit$cov[3,3]
60 # covar[3,3] = fit$cov[1,1]
61 # covar[1,2] = covar[2,1] = fit$cov[2,3]
62 # covar[2,3] = covar[3,2] = fit$cov[1,2]
63 # print(covar)
64
65 # Add:
66 fit= list()
67 fit$fit = fitted
68 fit$call = call
69 fit$type = c("pp", "mle")
70 fit$par.ests = fitted$mle
71 fit$par.ses = fitted$se
72 fit$residuals = residuals
73 fit$fitted.values = x - residuals
74 fit$llh = fitted$nllh
75 fit$converged = fitted$conv
76
77 # Return Value:
78 class(fit) = "ppFit"
79 fit
80 }
81
82
83 # ------------------------------------------------------------------------------
84
85
86 print.ppFit =
87 function(x, ...)
88 { # A function implemented by Diethelm Wuertz
89
90 # Description:
91 # Print method for an object of class 'ppFit'
92
93 # FUNCTION:
94
95 # Print Call:
96 cat("\nCall:\n")
97 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
98
99 if (x$fit$trans) {
100 # Still to do:
101 print.default(x) }
102 else {
103 # Parameters - We use the same order as in gevFit:
104 cat("\nParameter Estimate:\n")
105 print(x$par.ests) }
106
107 # Return Value:
108 invisible(x)
109 }
110
111
112 # ------------------------------------------------------------------------------
113
114
115 plot.ppFit =
116 function(x, which = "ask", ...)
117 { # A function implemented by Diethelm Wuertz
118
119 # Description:
120 # Plot method for an object of class 'ppFit'
121
122 # FUNCTION:
123
124 # Plot Functions:
125 if (x$fit$trans) {
126 plot.1 <<- function(x, ...) {
127 n <- length(x$data)
128 xx <- (1:n)/(n + 1)
129 plot(xx, sort(x$data), xlab = "empirical", ylab = "model")
130 abline(0, 1, col = 3)
131 title("Residual Probability Plot") }
132 plot.2 <<- function(x, ...) {
133 n <- length(x$data)
134 xx <- (1:n)/(n + 1)
135 plot(-log(1 - xx), -log(1 - sort(x$data)), ylab = "empirical",
136 xlab = "model")
137 abline(0, 1, col = 3)
138 title("Residual quantile Plot (Exptl. Scale)") } }
139 else {
140 plot.1 <<- function(x, ...) {
141 # Probability Plot:
142 pp.pp(x$mle, x$threshold, x$npy, x$data) }
143 plot.2 <<- function(x, ...) {
144 # Quantile Plot:
145 pp.qq(x$mle, x$threshold, x$npy, x$data) } }
146
147 # Plot:
148 if (x$fit$trans) {
149 interactivePlot(
150 x = x$fit,
151 choices = c(
152 "Residual Probability Plot",
153 "Residual Quantile Plot"),
154 plotFUN = c(
155 "plot.1",
156 "plot.2"),
157 which = which) }
158 else {
159 interactivePlot(
160 x = x$fit,
161 choices = c(
162 "Probability Plot",
163 "Quantile Plot"),
164 plotFUN = c(
165 "plot.1",
166 "plot.2"),
167 which = which) }
168
169 # Return Value:
170 invisible(x)
171 }
172
173
174 # ------------------------------------------------------------------------------
175
176
177 summary.ppFit =
178 function(object, doplot = TRUE, which = "all", ...)
179 { # A function implemented by Diethelm Wuertz
180
181 # Description:
182 # Summary method for an object of class 'ppFit'
183
184 # FUNCTION:
185
186 # Print:
187 print(object, ...)
188
189 # Summary:
190 cat("\nStandard Deviations:\n"); print(object$par.ses)
191 cat("\nLog-Likelihood Value: ", object$llh)
192 cat("\nType of Convergence: ", object$converged, "\n")
193 cat("\n")
194
195 # Plot:
196 if (doplot) plot.ppFit(object, which = which, ...)
197 cat("\n")
198
199 # Return Value:
200 invisible(object)
201 }
202
203
204 # ******************************************************************************
205
+223
-0
R/054D-RlargFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: R-LARGEST ORDER MODELLING FROM ISMEV:
31 # rlargFit Fits r-largest Order Statistic Model
32 # print.rlargFit Print Method for object of class "rlargFit"
33 # plot.rlargFit Plot Method for object of class "rlargFit"
34 # summary.rlargFit Summary Method for object of class "rlargFit"
35 ################################################################################
36
37
38 rlargFit =
39 function(x, r = dim(x)[2], y = NULL, mul = NULL, sigl = NULL, shl = NULL,
40 mulink = identity, siglink = identity, shlink = identity, method =
41 "Nelder-Mead", maxit = 10000, ...)
42 { # A function implemented by Diethelm Wuertz
43
44 # Description:
45 # Maximum-likelihood fitting for the order statistic model,
46 # including generalized linear modelling of each parameter.
47
48 # FUNCTION:
49
50 # Function Call:
51 call = match.call()
52
53 # Fit Parameters
54 fitted = rlarg.fit(xdat = x, r = r, ydat = y, mul = mul, sigl = sigl,
55 shl = shl, mulink = mulink, siglink = siglink, shlink = shlink,
56 show = FALSE, method = method, maxit = maxit, ...)
57
58 # Further Values:
59 mle = rev(fitted$mle)
60 se = rev(fitted$se)
61 names(mle) = names(se) = c("xi", "sigma", "mu")
62 covar = fitted$cov
63 covar[1,1] = fitted$cov[3,3]
64 covar[3,3] = fitted$cov[1,1]
65 covar[1,2] = covar[2,1] = fitted$cov[2,3]
66 covar[2,3] = covar[3,2] = fitted$cov[1,2]
67
68 # Make Unique:
69 fit = list()
70 fit$fit = fitted
71 fit$call = call
72 fit$type = c("mle", "rlarg")
73 fit$par.ests = mle
74 fit$par.ses = se
75 fit$residuals = as.matrix(fitted$data)
76 fit$fitted.values = as.matrix(x) - fit$residuals
77 fit$cov = covar
78 fit$llh = fitted$nllh
79 fit$converged = fitted$conv
80
81 # Return Value:
82 class(fit) = "rlargFit"
83 fit
84 }
85
86
87 # ******************************************************************************
88
89
90 print.rlargFit =
91 function(x, ...)
92 { # A function implemented by Diethelm Wuertz
93
94 # Description:
95 # Print Method for object of class "rlargFit"
96
97 # Notes:
98 # The ismev package has no print method. It uses the command
99 # > summary.rlargFit(fit = fit, details = FALSE, doplot = FALSE, ...)
100
101 # FUNCTION:
102
103 # Function Call:
104 cat("\nCall:\n")
105 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
106
107 # Estimation Type:
108 cat("\nEstimation Type:", x$type, "\n")
109
110 # Estimated summaryParameters:
111 cat("\nEstimated Parameters:\n")
112 print(x$par.ests)
113 cat("\n")
114
115 # Return Value:
116 invisible(x)
117 }
118
119
120 # ------------------------------------------------------------------------------
121
122
123 plot.rlargFit =
124 function(x, which = "all", ...)
125 { # A function implemented by Diethelm Wuertz
126
127 # Description:
128 # Plot method for objects of class "rlargFit".
129
130 # FUNCTION:
131
132 # Plot Functions:
133 if (x$fit$trans) {
134 # Non-Stationary:
135 plot.1 <<- function(x, ...) {
136 for (i in 1:z$r) {
137 # Probability and Quantile Plots:
138 rlarg.pp(c(0, 1, 0), x$data[, 1:x$r], i)
139 rlarg.qq(c(0, 1, 0), x$data[, 1:x$r], i) } } }
140 else {
141 # Stationary - GEV Plots:
142 plot.1 <<- function(x, ...) {
143 gev.pp(x$mle, x$data[, 1]) }
144 plot.2 <<- function(x, ...) {
145 gev.qq(x$mle, x$data[, 1]) }
146 plot.3 <<- function(x, ...) {
147 gev.rl(x$mle, x$cov, x$data[, 1]) }
148 plot.4 <<- function(x, ...) {
149 gev.his(x$mle, x$data[, 1]) }
150 fit <<- fit; plot.5 <<- function(x, ...) {
151 par(ask = TRUE)
152 for (i in 1:fit$fit$r) {
153 # Probability and Quantile Plots:
154 rlarg.pp(x$mle, x$data, i)
155 rlarg.qq(x$mle, x$data, i) }
156 par(ask = FALSE) } }
157
158 # Plot:
159 if (x$fit$trans) {
160 interactivePlot(
161 x = x$fit,
162 choices = c(
163 "Probability Plot",
164 "Quantile Plot"),
165 plotFUN = c(
166 "plot.1",
167 "plot.2"),
168 which = which) }
169 else {
170 interactivePlot(
171 x = x$fit,
172 choices = c(
173 "GEV Probability Plot",
174 "GEV Quantile Plot",
175 "GEV Return Level Plot",
176 "GEV Histogram Plot",
177 "R-Largest PP and QQ Plots"),
178 plotFUN = c(
179 "plot.1",
180 "plot.2",
181 "plot.3",
182 "plot.4",
183 "plot.5"),
184 which = which) }
185
186 # Return Value:
187 invisible(x)
188 }
189
190
191 # ------------------------------------------------------------------------------
192
193
194 summary.rlargFit =
195 function(object, doplot = TRUE, which = "all", ...)
196 { # A function implemented by Diethelm Wuertz
197
198 # Description:
199 # Summary Method for object of class "rlargFit".
200
201 # FUNCTION:
202
203 # Print:
204 print(object, ...)
205
206 # Summary:
207 cat("\nStandard Deviations:\n"); print(object$par.ses)
208 cat("\nLog-Likelihood Value: ", object$llh)
209 cat("\nType of Convergence: ", object$converged, "\n")
210 cat("\n")
211
212 # Plot:
213 if (doplot) plot(object, which = which, ...)
214 cat("\n")
215
216 # Return Value:
217 invisible(object)
218 }
219
220
221 # ******************************************************************************
222
+139
-0
R/055A-ExtremeIndex.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: EXTREMAL INDEX:
31 # exindexesPlot Calculate and Plot Theta(1,2,3)
32 # exindexPlot Calculate Theta(1,2) and Plot Theta(1)
33 ################################################################################
34
35
36 exindexesPlot =
37 function (x, block=20, quantiles = seq(0.990,0.999,0.001), doplot = TRUE, ...)
38 { # A function written by D. Wuertz
39
40 # Description:
41 # Calculates and Plots Theta(1,2,3)
42
43 # FUNCTION:
44
45 # Settings:
46 main = "Extremal Index"
47 doprint = FALSE
48
49 # Block Size:
50 blocklength = block # argument renamed
51
52 # Note, in finance the x's should be residuals
53 resid = x
54
55 # Extremal Index - Theta_1, Theta_2 and Theta_3
56 k = floor(length(resid)/blocklength) # Number of blocks
57 n = k*blocklength # Number of data points
58
59 # Now organize your residuels:
60 # 1) truncate the rest of the time series,
61 # 2) arrange them in matrix form,
62 # 3) sort them in reverse order, ie. from high (pos) to low (neg)
63 resid1 = resid[1:(k*blocklength)]
64 resid1 = matrix(resid1, ncol = blocklength, byrow = TRUE)
65 ordered1 = sort(resid1)
66
67 # Threshold values associated to quantiles:
68 z0 = ordered1[floor(quantiles*length(resid1))]
69
70 # Printing:
71 if (doprint) {print(z0); print(n); print(k) }
72
73 # Presettings:
74 theta1 = theta2 = theta3 = rep(0, times = length(quantiles))
75
76 # Calculate Extremal Imdex:
77 run = 0
78 for ( z in z0 ) {
79 run = run + 1
80 # N - number of exceedences:
81 N = length(resid1[resid1>z])
82 # K - number of blocks with exceedences:
83 K = sum(sign(apply(resid1,1,max)-z)+1)/2
84 if (K/k < 1) theta1[run] = (k/n) * log(1-K/k) / log(1-N/n)
85 else theta1[run] = NA
86 theta2[run] = K/N
87 x = 1:n
88 xx = diff(x[resid1 > z])
89 xx = xx[xx>blocklength]
90 theta3[run] = length(xx)/N
91 # Printing:
92 if (doprint) {
93 print(c(N, K, quantiles[run], z))
94 print(c(theta1[run], theta2[run], theta3[run]))} }
95
96 # Plotting:
97 if (doplot) {
98 plot(quantiles, theta1,
99 xlim = c(quantiles[1], quantiles[length(quantiles)]),
100 ylim = c(0, 1.2), type = "b", pch = 1,
101 ylab = " Theta 1,2,3", main = main, ...)
102 points(quantiles, theta2, pch = 2, col = 3)
103 points(quantiles, theta3, pch = 4, col = 4) }
104
105 # Return Value:
106 data.frame(thresholds=z0, theta1=theta1, theta2=theta2, theta3=theta3)
107 }
108
109
110 # -----------------------------------------------------------------------------
111
112
113 exindexPlot =
114 function(x, block = "month", start = 5, end = NA,
115 plottype = c("thresh", "K"), labels = TRUE, autoscale = TRUE, ...)
116 { # A function implemented by Diethelm Wuertz
117
118 # Description:
119 # Calculates Theta(1,2) and plots Theta(1)
120
121 # Notes:
122 # Wraps "exindex" from Alexander McNeil's evir package
123
124 # FUNCTION:
125
126 # Wrapper:
127 plottype = plottype[1]
128 reverse = FALSE
129 if (plottype == "K") reverse = TRUE
130 ans = exindex(data = x, block = block , start = start, end = end,
131 reverse = reverse, auto.scale = autoscale, labels = labels, ...)
132
133 # Return Value:
134 ans
135 }
136
137
138 # ******************************************************************************
+2784
-0
R/056A-ExtremesBuiltin.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # BUILIN - PACKAGE DESCRIPTION:
31 # Package: evir
32 # Version: 1.1
33 # Date: 2004-05-05
34 # Title: Extreme Values in R
35 # Author: S original (EVIS) by Alexander McNeil
36 # <mcneil@math.ethz.ch>, R port by Alec
37 # Stephenson <alec_stephenson@hotmail.com>.
38 # Maintainer: Alec Stephenson <alec_stephenson@hotmail.com>
39 # Depends: R (>= 1.5.0)
40 # Description: Functions for extreme value theory, which may be
41 # divided into the following groups; exploratory data analysis,
42 # block maxima, peaks over thresholds (univariate and bivariate),
43 # point processes, gev/gpd distributions.
44 # License: GPL (Version 2 or above)
45 # URL: http://www.maths.lancs.ac.uk/~stephena/
46 # Packaged: Wed May 5 15:29:24 2004; stephena
47 ################################################################################
48
49
50 ################################################################################
51 # BUILTIN - PACKAGE DESCRIPTION:
52 # Package: ismev
53 # Version: 1.1
54 # Date: 2003/11/25
55 # Title: An Introduction to Statistical Modeling of Extreme Values
56 # Author: Original S functions by Stuart Coles
57 # <Stuart.Coles@bristol.ac.uk>, R port and R documentation files
58 # by Alec Stephenson <a.stephenson@lancaster.ac.uk>.
59 # Maintainer: Alec Stephenson <a.stephenson@lancaster.ac.uk>
60 # Depends: R (>= 1.5.0)
61 # Description: Functions to support the computations carried out in
62 # `An Introduction to Statistical Modeling of Extreme Values' by
63 # Stuart Coles. The functions may be divided into the following
64 # groups; maxima/minima, order statistics, peaks over thresholds
65 # and point processes.
66 # License: GPL (Version 2 or above)
67 # URL: http://www.maths.lancs.ac.uk/~stephena/
68 ################################################################################
69
70
71 # This file contains the following functions:
72 # gev.fit gev.diag gev.pp gev.qq gev.rl gev.his
73 # gevf gevq gev.dens gev.profxi gev.prof
74
75
76 "gev.fit" <-
77 function(xdat, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL,
78 mulink = identity, siglink = identity, shlink = identity, show = TRUE,
79 method = "Nelder-Mead", maxit = 10000, ...)
80 {
81 #
82 # obtains mles etc for gev distn
83 #
84 z <- list()
85 npmu <- length(mul) + 1
86 npsc <- length(sigl) + 1
87 npsh <- length(shl) + 1
88 z$trans <- FALSE # if maximization fails, could try
89 # changing in1 and in2 which are
90 # initial values for minimization routine
91 in2 <- sqrt(6 * var(xdat))/pi
92 in1 <- mean(xdat) - 0.57722 * in2
93 if(is.null(mul)) {
94 mumat <- as.matrix(rep(1, length(xdat)))
95 muinit <- in1
96 }
97 else {
98 z$trans <- TRUE
99 mumat <- cbind(rep(1, length(xdat)), ydat[, mul])
100 muinit <- c(in1, rep(0, length(mul)))
101 }
102 if(is.null(sigl)) {
103 sigmat <- as.matrix(rep(1, length(xdat)))
104 siginit <- in2
105 }
106 else {
107 z$trans <- TRUE
108 sigmat <- cbind(rep(1, length(xdat)), ydat[, sigl])
109 siginit <- c(in2, rep(0, length(sigl)))
110 }
111 if(is.null(shl)) {
112 shmat <- as.matrix(rep(1, length(xdat)))
113 shinit <- 0.1
114 }
115 else {
116 z$trans <- TRUE
117 shmat <- cbind(rep(1, length(xdat)), ydat[, shl])
118 shinit <- c(0.1, rep(0, length(shl)))
119 }
120 z$model <- list(mul, sigl, shl)
121 z$link <- deparse(substitute(c(mulink, siglink, shlink)))
122 init <- c(muinit, siginit, shinit)
123 gev.lik <- function(a) {
124 # computes neg log lik of gev model
125 mu <- mulink(mumat %*% (a[1:npmu]))
126 sc <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
127 xi <- shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)]))
128 y <- (xdat - mu)/sc
129 y <- 1 + xi * y
130 if(any(y <= 0) || any(sc <= 0)) return(10^6)
131 sum(log(sc)) + sum(y^(-1/xi)) + sum(log(y) * (1/xi + 1))
132 }
133 x <- optim(init, gev.lik, hessian = TRUE, method = method,
134 control = list(maxit = maxit, ...))
135 z$conv <- x$convergence
136 mu <- mulink(mumat %*% (x$par[1:npmu]))
137 sc <- siglink(sigmat %*% (x$par[seq(npmu + 1, length = npsc)]))
138 xi <- shlink(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)]))
139 z$nllh <- x$value
140 z$data <- xdat
141 if(z$trans) {
142 z$data <- - log(as.vector((1 + (xi * (xdat - mu))/sc)^(
143 -1/xi)))
144 }
145 z$mle <- x$par
146 z$cov <- solve(x$hessian)
147 z$se <- sqrt(diag(z$cov))
148 z$vals <- cbind(mu, sc, xi)
149 if(show) {
150 if(z$trans)
151 print(z[c(2, 3, 4)])
152 else print(z[4])
153 if(!z$conv)
154 print(z[c(5, 7, 9)])
155 }
156 invisible(z)
157 }
158
159 "gev.diag" <-
160 function(z)
161 {
162 #
163 # produces diagnostic plots for output of
164 # gev.fit stored in z
165 #
166 n <- length(z$data)
167 x <- (1:n)/(n + 1)
168 if(z$trans) {
169 oldpar <- par(mfrow = c(1, 2))
170 plot(x, exp( - exp( - sort(z$data))), xlab =
171 "Empirical", ylab = "Model")
172 abline(0, 1, col = 4)
173 title("Residual Probability Plot")
174 plot( - log( - log(x)), sort(z$data), ylab =
175 "Empirical", xlab = "Model")
176 abline(0, 1, col = 4)
177 title("Residual Quantile Plot (Gumbel Scale)")
178 }
179 else {
180 oldpar <- par(mfrow = c(2, 2))
181 gev.pp(z$mle, z$data)
182 gev.qq(z$mle, z$data)
183 gev.rl(z$mle, z$cov, z$data)
184 gev.his(z$mle, z$data)
185 }
186 par(oldpar)
187 invisible()
188 }
189
190 "gev.pp" <-
191 function(a, dat)
192 {
193 #
194 # sub-function for gev.diag
195 # produces probability plot
196 #
197 plot((1:length(dat))/length(dat), gevf(a, sort(dat)), xlab =
198 "Empirical", ylab = "Model", main = "Probability Plot")
199 abline(0, 1, col = 4)
200 }
201
202 "gev.qq" <-
203 function(a, dat)
204 {
205 #
206 # function called by gev.diag
207 # produces quantile plot
208 #
209 plot(gevq(a, 1 - (1:length(dat)/(length(dat) + 1))), sort(dat), ylab =
210 "Empirical", xlab = "Model", main = "Quantile Plot")
211 abline(0, 1, col = 4)
212 }
213
214 "gev.rl" <-
215 function(a, mat, dat)
216 {
217 #
218 # function called by gev.diag
219 # produces return level curve and 95 % confidence intervals
220 # on usual scale
221 #
222 eps <- 1e-006
223 a1 <- a
224 a2 <- a
225 a3 <- a
226 a1[1] <- a[1] + eps
227 a2[2] <- a[2] + eps
228 a3[3] <- a[3] + eps
229 f <- c(seq(0.01, 0.09, by = 0.01), 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7,
230 0.8, 0.9, 0.95, 0.99, 0.995, 0.999)
231 q <- gevq(a, 1 - f)
232 d1 <- (gevq(a1, 1 - f) - q)/eps
233 d2 <- (gevq(a2, 1 - f) - q)/eps
234 d3 <- (gevq(a3, 1 - f) - q)/eps
235 d <- cbind(d1, d2, d3)
236 v <- apply(d, 1, q.form, m = mat)
237 plot(-1/log(f), q, log = "x", type = "n", xlim = c(0.1, 1000), ylim = c(
238 min(dat, q), max(dat, q)), xlab = "Return Period", ylab =
239 "Return Level")
240 title("Return Level Plot")
241 lines(-1/log(f), q)
242 lines(-1/log(f), q + 1.96 * sqrt(v), col = 4)
243 lines(-1/log(f), q - 1.96 * sqrt(v), col = 4)
244 points(-1/log((1:length(dat))/(length(dat) + 1)), sort(dat))
245 }
246
247 "gev.his" <-
248 function(a, dat)
249 {
250 #
251 # Plots histogram of data and fitted density
252 # for output of gev.fit stored in z
253 #
254 h <- hist(dat, prob = TRUE, plot = FALSE)
255 if(a[3] < 0) {
256 x <- seq(min(h$breaks), min(max(h$breaks), (a[1] - a[2]/a[3] -
257 0.001)), length = 100)
258 }
259 else {
260 x <- seq(max(min(h$breaks), (a[1] - a[2]/a[3] + 0.001)), max(h$
261 breaks), length = 100)
262 }
263 y <- gev.dens(a, x)
264 hist(dat, prob = TRUE, ylim = c(0, max(y)), xlab = "z", ylab = "f(z)",
265 main = "Density Plot")
266 points(dat, rep(0, length(dat)))
267 lines(x, y)
268 }
269
270 "gevf" <-
271 function(a, z)
272 {
273 #
274 # ancillary function calculates gev dist fnc
275 #
276 if(a[3] != 0) exp( - (1 + (a[3] * (z - a[1]))/a[2])^(-1/a[3])) else
277 gum.df(z, a[1], a[2])
278 }
279
280 "gevq" <-
281 function(a, p)
282 {
283 if(a[3] != 0)
284 a[1] + (a[2] * (( - log(1 - p))^( - a[3]) - 1))/a[3]
285 else gum.q(p, a[1], a[2])
286 }
287
288 "gev.dens" <-
289 function(a, z)
290 {
291 #
292 # evaluates gev density with parameters a at z
293 #
294 if(a[3] != 0) (exp( - (1 + (a[3] * (z - a[1]))/a[2])^(-1/a[3])) * (1 + (
295 a[3] * (z - a[1]))/a[2])^(-1/a[3] - 1))/a[2] else {
296 gum.dens(c(a[1], a[2]), z)
297 }
298 }
299
300 "gev.profxi" <-
301 function(z, xlow, xup, conf = 0.95, nint = 100)
302 {
303 #
304 # plots profile log-likelihood for shape parameter
305 # in gev model
306 #
307 cat("If routine fails, try changing plotting interval", fill = TRUE)
308 v <- numeric(nint)
309 x <- seq(xup, xlow, length = nint)
310 sol <- c(z$mle[1], z$mle[2])
311 gev.plikxi <- function(a) {
312 # computes profile neg log lik
313 if (abs(xi) < 10^(-6)) {
314 y <- (z$data - a[1])/a[2]
315 if(a[2] <= 0) l <- 10^6
316 else l <- length(y) * log(a[2]) + sum(exp(-y)) + sum(y)
317 }
318 else {
319 y <- (z$data - a[1])/a[2]
320 y <- 1 + xi * y
321 if(a[2] <= 0 || any(y <= 0))
322 l <- 10^6
323 else l <- length(y) * log(a[2]) + sum(y^(-1/xi)) + sum(log(y
324 )) * (1/xi + 1)
325 }
326 l
327 }
328 for(i in 1:nint) {
329 xi <- x[i]
330 opt <- optim(sol, gev.plikxi)
331 sol <- opt$par ; v[i] <- opt$value
332 }
333 plot(x, - v, type = "l", xlab = "Shape Parameter", ylab =
334 "Profile Log-likelihood")
335 ma <- - z$nllh
336 abline(h = ma, col = 4)
337 abline(h = ma - 0.5 * qchisq(conf, 1), col = 4)
338 invisible()
339 }
340
341 "gev.prof" <-
342 function(z, m, xlow, xup, conf = 0.95, nint = 100)
343 {
344 #
345 # plots profile log likelihood for m 'year' return level
346 # in gev model
347 #
348 if(m <= 1) stop("`m' must be greater than one")
349 cat("If routine fails, try changing plotting interval", fill = TRUE)
350 p <- 1/m
351 v <- numeric(nint)
352 x <- seq(xlow, xup, length = nint)
353 sol <- c(z$mle[2], z$mle[3])
354 gev.plik <- function(a) {
355 # computes profile neg log lik
356 if (abs(a[2]) < 10^(-6)) {
357 mu <- xp + a[1] * log(-log(1 - p))
358 y <- (z$data - mu)/a[1]
359 if(is.infinite(mu) || a[1] <= 0) l <- 10^6
360 else l <- length(y) * log(a[1]) + sum(exp(-y)) + sum(y)
361 }
362 else {
363 mu <- xp - a[1]/a[2] * (( - log(1 - p))^( - a[2]) - 1)
364 y <- (z$data - mu)/a[1]
365 y <- 1 + a[2] * y
366 if(is.infinite(mu) || a[1] <= 0 || any(y <= 0))
367 l <- 10^6
368 else l <- length(y) * log(a[1]) + sum(y^(-1/a[2])) + sum(log(
369 y)) * (1/a[2] + 1)
370 }
371 l
372 }
373 for(i in 1:nint) {
374 xp <- x[i]
375 opt <- optim(sol, gev.plik)
376 sol <- opt$par ; v[i] <- opt$value
377 }
378 plot(x, - v, type = "l", xlab = "Return Level", ylab =
379 " Profile Log-likelihood")
380 ma <- - z$nllh
381 abline(h = ma, col = 4)
382 abline(h = ma - 0.5 * qchisq(conf, 1), col = 4)
383 invisible()
384 }
385
386 # This file contains the following functions:
387 # gpd.fitrange gpd.fit gpd.diag gpd.pp gpd.qq gpd.rl
388 # gpd.his gpdf gpdq gpdq2 gpd.dens gpd.profxi gpd.prof
389
390 "gpd.fitrange" <-
391 function(data, umin, umax, nint = 10, show = FALSE)
392 {
393 #
394 # computes mle's in gpd model, adjusted for threshold,
395 # over range of threshold choices.
396 #
397 m <- s <- up <- ul <- matrix(0, nrow = nint, ncol = 2)
398 u <- seq(umin, umax, length = nint)
399 for(i in 1:nint) {
400 z <- gpd.fit(data, u[i], show = show)
401 m[i, ] <- z$mle
402 m[i, 1] <- m[i, 1] - m[i, 2] * u[i]
403 d <- matrix(c(1, - u[i]), ncol = 1)
404 v <- t(d) %*% z$cov %*% d
405 s[i, ] <- z$se
406 s[i, 1] <- sqrt(v)
407 up[i, ] <- m[i, ] + 1.96 * s[i, ]
408 ul[i, ] <- m[i, ] - 1.96 * s[i, ]
409 }
410 names <- c("Modified Scale", "Shape")
411 oldpar <- par(mfrow = c(2, 1))
412 for(i in 1:2) {
413 um <- max(up[, i])
414 ud <- min(ul[, i])
415 plot(u, m[, i], ylim = c(ud, um), xlab = "Threshold", ylab =
416 names[i], type = "b")
417 for(j in 1:nint)
418 lines(c(u[j], u[j]), c(ul[j, i], up[j, i]))
419 }
420 par(oldpar)
421 invisible()
422 }
423
424 "gpd.fit" <-
425 function(xdat, threshold, npy = 365, ydat = NULL, sigl = NULL, shl = NULL,
426 siglink = identity, shlink = identity, show = TRUE, method = "Nelder-Mead",
427 maxit = 10000, ...)
428 {
429 #
430 # obtains mles etc for gpd model
431 #
432 z <- list()
433 npsc <- length(sigl) + 1
434 npsh <- length(shl) + 1
435 n <- length(xdat)
436 z$trans <- FALSE
437 if(is.function(threshold))
438 stop("`threshold' cannot be a function")
439 u <- rep(threshold, length.out = n)
440 if(length(unique(u)) > 1) z$trans <- TRUE
441 xdatu <- xdat[xdat > u]
442 xind <- (1:n)[xdat > u]
443 u <- u[xind]
444 in2 <- sqrt(6 * var(xdat))/pi
445 in1 <- mean(xdat, na.rm = TRUE) - 0.57722 * in2
446 if(is.null(sigl)) {
447 sigmat <- as.matrix(rep(1, length(xdatu)))
448 siginit <- in2
449 }
450 else {
451 z$trans <- TRUE
452 sigmat <- cbind(rep(1, length(xdatu)), ydat[xind, sigl])
453 siginit <- c(in2, rep(0, length(sigl)))
454 }
455 if(is.null(shl)) {
456 shmat <- as.matrix(rep(1, length(xdatu)))
457 shinit <- 0.1
458 }
459 else {
460 z$trans <- TRUE
461 shmat <- cbind(rep(1, length(xdatu)), ydat[xind, shl])
462 shinit <- c(0.1, rep(0, length(shl)))
463 }
464 init <- c(siginit, shinit)
465 z$model <- list(sigl, shl)
466 z$link <- deparse(substitute(c(siglink, shlink)))
467 z$threshold <- threshold
468 z$nexc <- length(xdatu)
469 z$data <- xdatu
470 gpd.lik <- function(a) {
471 # calculates gpd neg log lik
472 sc <- siglink(sigmat %*% (a[seq(1, length = npsc)]))
473 xi <- shlink(shmat %*% (a[seq(npsc + 1, length = npsh)]))
474 y <- (xdatu - u)/sc
475 y <- 1 + xi * y
476 if(min(sc) <= 0)
477 l <- 10^6
478 else {
479 if(min(y) <= 0)
480 l <- 10^6
481 else {
482 l <- sum(log(sc)) + sum(log(y) * (1/xi + 1))
483 }
484 }
485 l
486 }
487 x <- optim(init, gpd.lik, hessian = TRUE, method = method,
488 control = list(maxit = maxit, ...))
489 sc <- siglink(sigmat %*% (x$par[seq(1, length = npsc)]))
490 xi <- shlink(shmat %*% (x$par[seq(npsc + 1, length = npsh)]))
491 z$conv <- x$convergence
492 z$nllh <- x$value
493 z$vals <- cbind(sc, xi, u)
494 if(z$trans) {
495 z$data <- - log(as.vector((1 + (xi * (xdatu - u))/sc)^(-1/xi))
496 )
497 }
498 z$mle <- x$par
499 z$rate <- length(xdatu)/n
500 z$cov <- solve(x$hessian)
501 z$se <- sqrt(diag(z$cov))
502 z$n <- n
503 z$npy <- npy
504 z$xdata <- xdat
505 if(show) {
506 if(z$trans)
507 print(z[c(2, 3)])
508 if(length(z[[4]]) == 1)
509 print(z[4])
510 print(z[c(5, 7)])
511 if(!z$conv)
512 print(z[c(8, 10, 11, 13)])
513 }
514 invisible(z)
515 }
516
517 "gpd.diag" <-
518 function(z)
519 {
520 #
521 # produces diagnostic plots for gpd model
522 # estimated using gpd.fit with output stored in z
523 #
524 n <- length(z$data)
525 x <- (1:n)/(n + 1)
526 if(z$trans) {
527 oldpar <- par(mfrow = c(1, 2))
528 plot(x, 1 - exp( - sort(z$data)), xlab = "Empirical",
529 ylab = "Model")
530 abline(0, 1, col = 4)
531 title("Residual Probability Plot")
532 plot( - log(1 - x), sort(z$data), ylab = "Empirical",
533 xlab = "Model")
534 abline(0, 1, col = 4)
535 title("Residual Quantile Plot (Exptl. Scale)")
536 }
537 else {
538 oldpar <- par(mfrow = c(2, 2))
539 gpd.pp(z$mle, z$threshold, z$data)
540 gpd.qq(z$mle, z$threshold, z$data)
541 gpd.rl(z$mle, z$threshold, z$rate, z$n, z$npy, z$cov, z$
542 data, z$xdata)
543 gpd.his(z$mle, z$threshold, z$data)
544 }
545 par(oldpar)
546 invisible()
547 }
548
549 "gpd.pp" <-
550 function(a, u, dat)
551 {
552 #
553 # function called by gpd.diag
554 # produces probability plot for gpd model
555 #
556 plot((1:length(dat))/length(dat), gpdf(a, u, sort(dat)), xlab =
557 "Empirical", ylab = "Model", main = "Probability Plot")
558 abline(0, 1, col = 4)
559 }
560
561 "gpd.qq" <-
562 function(a, u, dat)
563 {
564 #
565 # function called by gpd.diag
566 # produces quantile plot for gpd model
567 #
568 plot(gpdq(a, u, 1 - (1:length(dat)/(length(dat) + 1))), sort(dat), ylab
569 = "Empirical", xlab = "Model", main = "Quantile Plot")
570 abline(0, 1, col = 4)
571 }
572
573 "gpd.rl" <-
574 function(a, u, la, n, npy, mat, dat, xdat)
575 {
576 #
577 # function called by gpd.diag
578 # produces return level curve and 95% confidence intervals
579 # for fitted gpd model
580 a <- c(la, a)
581 eps <- 1e-006
582 a1 <- a
583 a2 <- a
584 a3 <- a
585 a1[1] <- a[1] + eps
586 a2[2] <- a[2] + eps
587 a3[3] <- a[3] + eps
588 jj <- seq(-1, 3.75 + log10(npy), by = 0.1)
589 m <- c(1/la, 10^jj)
590 q <- gpdq2(a[2:3], u, la, m)
591 d1 <- (gpdq2(a1[2:3], u, la, m) - q)/eps
592 d2 <- (gpdq2(a2[2:3], u, la, m) - q)/eps
593 d3 <- (gpdq2(a3[2:3], u, la, m) - q)/eps
594 d <- cbind(d1, d2, d3)
595 mat <- matrix(c((la * (1 - la))/n, 0, 0, 0, mat[1, 1], mat[1, 2], 0,
596 mat[2, 1], mat[2, 2]), nc = 3)
597 v <- apply(d, 1, q.form, m = mat)
598 plot(m/npy, q, log = "x", type = "n", xlim = c(0.1, max(m)/npy), ylim
599 = c(u, max(xdat, q[q > u - 1] + 1.96 * sqrt(v)[q > u - 1])),
600 xlab = "Return period (years)", ylab = "Return level", main =
601 "Return Level Plot")
602 lines(m[q > u - 1]/npy, q[q > u - 1])
603 lines(m[q > u - 1]/npy, q[q > u - 1] + 1.96 * sqrt(v)[q > u - 1], col
604 = 4)
605 lines(m[q > u - 1]/npy, q[q > u - 1] - 1.96 * sqrt(v)[q > u - 1], col
606 = 4)
607 nl <- n - length(dat) + 1
608 sdat <- sort(xdat)
609 points((1/(1 - (1:n)/(n + 1))/npy)[sdat > u], sdat[sdat > u])
610 # points(1/(1 - (1:n)/(n + 1))/npy,
611 # sort(xdat))
612 # abline(h = u, col = 3)
613 }
614
615 "gpd.his" <-
616 function(a, u, dat)
617 {
618 #
619 # function called by gpd.diag
620 # produces histogram and density plot
621 #
622 h <- hist(dat, prob = TRUE, plot = FALSE)
623 x <- seq(u, max(h$breaks), length = 100)
624 y <- gpd.dens(a, u, x)
625 hist(dat, prob = TRUE, ylim = c(0, max(y)), xlab = "x", ylab = "f(x)",
626 main = "Density Plot")
627 lines(x, y, col = 4)
628 }
629
630 "gpdf" <-
631 function(a, u, z)
632 {
633 #
634 # ancillary function
635 # calculates gpd distribution function
636 #
637 1 - (1 + (a[2] * (z - u))/a[1])^(-1/a[2])
638 }
639
640 "gpdq" <-
641 function(a, u, p)
642 u + (a[1] * (p^( - a[2]) #
643 # ancillary function
644 # computes gpd quantiles
645 #
646 - 1))/a[2]
647
648 "gpdq2" <-
649 function(a, u, la, m)
650 {
651 #
652 # ancillary function
653 # calculates quantiles of gpd model
654 #
655 u + (a[1] * ((m * la)^(a[2]) - 1))/a[2]
656 }
657
658 "gpd.dens" <-
659 function(a, u, z)
660 {
661 #
662 # ancillary function computes gpd density
663 #
664 (1 + (a[2] * (z - u))/a[1])^(-1/a[2] - 1)/a[1]
665 }
666
667 "gpd.profxi" <-
668 function(z, xlow, xup, conf = 0.95, nint = 100)
669 {
670 #
671 # plots profile log likelihood for shape parameter
672 # in gpd model
673 #
674 cat("If routine fails, try changing plotting interval", fill = TRUE)
675 xdat <- z$data ; u <- z$threshold
676 v <- numeric(nint)
677 x <- seq(xup, xlow, length = nint)
678 sol <- z$mle[1]
679 gpd.plikxi <- function(a) {
680 # calculates profile log lik
681 if(abs(xi) < 10^(-4)) l <- length(xdat) * log(a) + sum(xdat - u)/a
682 else {
683 y <- (xdat - u)/a
684 y <- 1 + xi * y
685 if(any(y <= 0) || a <= 0)
686 l <- 10^6
687 else l <- length(xdat) * log(a) + sum(log(y)) * (1/xi + 1)
688 }
689 l
690 }
691 for(i in 1:nint) {
692 xi <- x[i]
693 opt <- optim(sol, gpd.plikxi, method = "BFGS")
694 sol <- opt$par ; v[i] <- opt$value
695 }
696 plot(x, - v, type = "l", xlab = "Shape Parameter", ylab =
697 "Profile Log-likelihood")
698 ma <- - z$nllh
699 abline(h = ma, lty = 1)
700 abline(h = ma - 0.5 * qchisq(conf, 1), lty = 1)
701 invisible()
702 }
703
704 "gpd.prof" <-
705 function(z, m, xlow, xup, npy = 365, conf = 0.95, nint = 100)
706 {
707 #
708 # plots profile log-likelihood for m-year return level
709 # in gpd model
710 #
711 cat("If routine fails, try changing plotting interval", fill = TRUE)
712 xdat <- z$data ; u <- z$threshold ; la <- z$rate
713 v <- numeric(nint)
714 x <- seq(xlow, xup, length = nint)
715 m <- m * npy
716 sol <- z$mle[2]
717 gpd.plik <- function(a) {
718 # calculates profile neg log lik
719 if(m != Inf) sc <- (a * (xp - u))/((m * la)^a - 1) else sc <- (u - xp)/
720 a
721 if(abs(a) < 10^(-4))
722 l <- length(xdat) * log(sc) + sum(xdat - u)/sc
723 else {
724 y <- (xdat - u)/sc
725 y <- 1 + a * y
726 if(any(y <= 0) || sc <= 0)
727 l <- 10^6
728 else l <- length(xdat) * log(sc) + sum(log(y)) * (1/a + 1)
729 }
730 l
731 }
732 for(i in 1:nint) {
733 xp <- x[i]
734 opt <- optim(sol, gpd.plik, method = "BFGS")
735 sol <- opt$par ; v[i] <- opt$value
736 }
737 plot(x, - v, type = "l", xlab = "Return Level", ylab =
738 "Profile Log-likelihood")
739 ma <- - z$nllh
740 abline(h = ma)
741 abline(h = ma - 0.5 * qchisq(conf, 1))
742 invisible()
743 }
744
745 # This file contains the following functions:
746 # gum.fit gum.diag gum.rl gum.df gum.q gum.dens
747
748 "gum.fit" <-
749 function(xdat, ydat = NULL, mul = NULL, sigl = NULL, mulink = identity,
750 siglink = identity, show = TRUE, method = "Nelder-Mead", maxit = 10000, ...)
751 {
752 #
753 # finds mles etc for gumbel model
754 #
755 z <- list()
756 npmu <- length(mul) + 1
757 npsc <- length(sigl) + 1
758 z$trans <- FALSE
759 in2 <- sqrt(6 * var(xdat))/pi
760 in1 <- mean(xdat) - 0.57722 * in2
761 if(is.null(mul)) {
762 mumat <- as.matrix(rep(1, length(xdat)))
763 muinit <- in1
764 }
765 else {
766 z$trans <- TRUE
767 mumat <- cbind(rep(1, length(xdat)), ydat[, mul])
768 muinit <- c(in1, rep(0, length(mul)))
769 }
770 if(is.null(sigl)) {
771 sigmat <- as.matrix(rep(1, length(xdat)))
772 siginit <- in2
773 }
774 else {
775 z$trans <- TRUE
776 sigmat <- cbind(rep(1, length(xdat)), ydat[, sigl])
777 siginit <- c(in2, rep(0, length(sigl)))
778 }
779 z$model <- list(mul, sigl)
780 z$link <- c(deparse(substitute(mulink)), deparse(substitute(siglink)))
781 init <- c(muinit, siginit)
782 gum.lik <- function(a) {
783 # calculates neg log lik of gumbel model
784 mu <- mulink(mumat %*% (a[1:npmu]))
785 sc <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
786 if(any(sc <= 0)) return(10^6)
787 y <- (xdat - mu)/sc
788 sum(log(sc)) + sum(y) + sum(exp( - y))
789 }
790 x <- optim(init, gum.lik, hessian = TRUE, method = method,
791 control = list(maxit = maxit, ...))
792 z$conv <- x$convergence
793 if(!z$conv) {
794 mu <- mulink(mumat %*% (x$par[1:npmu]))
795 sc <- siglink(sigmat %*% (x$par[seq(npmu + 1, length = npsc)]))
796 z$nllh <- x$value
797 z$data <- xdat
798 if(z$trans) {
799 z$data <- as.vector((xdat - mu)/sc)
800 }
801 z$mle <- x$par
802 z$cov <- solve(x$hessian)
803 z$se <- sqrt(diag(z$cov))
804 z$vals <- cbind(mu, sc)
805 }
806 if(show) {
807 if(z$trans)
808 print(z[c(2, 3, 4)])
809 else print(z[4])
810 if(!z$conv)
811 print(z[c(5, 7, 9)])
812 }
813 invisible(z)
814 }
815
816 "gum.diag" <-
817 function(z)
818 {
819 #
820 # produces diagnostic plots for output of
821 # gum.fit stored in z
822 #
823 z$mle <- c(z$mle, 0)
824 n <- length(z$data)
825 x <- (1:n)/(n + 1)
826 if(z$trans) {
827 oldpar <- par(mfrow = c(1, 2))
828 plot(x, exp( - exp( - sort(z$data))), xlab = "empirical",
829 ylab = "model")
830 abline(0, 1, col = 4)
831 title("Residual Probability Plot")
832 plot( - log( - log(x)), sort(z$data), xlab =
833 "empirical", ylab = "model")
834 abline(0, 1, col = 4)
835 title("Residual Quantile Plot (Gumbel Scale)")
836 }
837 else {
838 oldpar <- par(mfrow = c(2, 2))
839 gev.pp(z$mle, z$data)
840 gev.qq(z$mle, z$data)
841 gum.rl(z$mle, z$cov, z$data)
842 gev.his(z$mle, z$data)
843 }
844 par(oldpar)
845 invisible()
846 }
847
848 "gum.rl" <-
849 function(a, mat, dat)
850 {
851 #
852 # function called by gum.diag
853 # produces return level curve and 95 % confidence intervals
854 # on usual scale for gumbel model
855 #
856 eps <- 1e-006
857 a1 <- a
858 a2 <- a
859 a1[1] <- a[1] + eps
860 a2[2] <- a[2] + eps
861 f <- c(seq(0.01, 0.09, by = 0.01), 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7,
862 0.8, 0.9, 0.95, 0.99, 0.995, 0.999)
863 q <- gevq(a, 1 - f)
864 d1 <- (gevq(a1, 1 - f) - q)/eps
865 d2 <- (gevq(a2, 1 - f) - q)/eps
866 d <- cbind(d1, d2)
867 v <- apply(d, 1, q.form, m = mat)
868 plot(-1/log(f), q, log = "x", type = "n", xlim = c(0.1, 1000), ylim = c(
869 min(dat, q), max(dat, q)), xlab = "Return Period", ylab =
870 "Return Level")
871 title("Return Level Plot")
872 lines(-1/log(f), q)
873 lines(-1/log(f), q + 1.96 * sqrt(v), col = 4)
874 lines(-1/log(f), q - 1.96 * sqrt(v), col = 4)
875 points(-1/log((1:length(dat))/(length(dat) + 1)), sort(dat))
876 }
877
878 "gum.df" <-
879 function(x, a, b)
880 {
881 #
882 # ancillary function calculates dist fnc of gumbel model
883 #
884 exp( - exp( - (x - a)/b))
885 }
886
887 "gum.q" <-
888 function(x, a, b)
889 {
890 #
891 # ancillary routine
892 # calculates quantiles of gumbel distn
893 #
894 a - b * log( - log(1 - x))
895 }
896
897 "gum.dens" <-
898 function(a, x)
899 {
900 #
901 # ancillary function calculates density for gumbel model
902 #
903 y <- (x - a[1])/a[2]
904 (exp( - y) * exp( - exp( - y)))/a[2]
905 }
906
907 # This file contains the following functions:
908 # identity q.form mrl.plot
909
910 "identity" <-
911 function(x)
912 x
913
914 "q.form" <-
915 function(d, m)
916 {
917 #
918 # ancillary routine
919 # evaluates quadratic forms
920 #
921 t(as.matrix(d)) %*% m %*% as.matrix(d)
922 }
923
924 "mrl.plot" <-
925 function(data, umin = min(data), umax = max(data) - 0.1, conf = 0.95, nint =
926 100)
927 {
928 #
929 # function to produce empirical mean residual life plot
930 # as function of threshold.
931 # confidence intervals included as well.
932 #
933 x <- xu <- xl <- numeric(nint)
934 u <- seq(umin, umax, length = nint)
935 for(i in 1:nint) {
936 data <- data[data > u[i]]
937 x[i] <- mean(data - u[i])
938 sdev <- sqrt(var(data))
939 n <- length(data)
940 xu[i] <- x[i] + (qnorm((1 + conf)/2) * sdev)/sqrt(n)
941 xl[i] <- x[i] - (qnorm((1 + conf)/2) * sdev)/sqrt(n)
942 }
943 plot(u, x, type = "l", xlab = "u", ylab = "Mean Excess", ylim = c(min(
944 xl[!is.na(xl)]), max(xu[!is.na(xu)])))
945 lines(u[!is.na(xl)], xl[!is.na(xl)], lty = 2)
946 lines(u[!is.na(xu)], xu[!is.na(xu)], lty = 2)
947 }
948
949 # This file contains the following functions:
950 # pp.fitrange pp.fit pp.diag pp.pp pp.qq
951 # ppf ppq ppp
952
953 "pp.fitrange" <-
954 function(data, umin, umax, npy = 365, nint = 10, show = FALSE)
955 {
956 #
957 # produces estimates and 95% confidence intervals
958 # for point process model across range of thresholds
959 #
960 m <- s <- up <- ul <- matrix(0, nrow = nint, ncol = 3)
961 u <- seq(umin, umax, length = nint)
962 for(i in 1:nint) {
963 z <- pp.fit(data, u[i], npy, show = show)
964 m[i, ] <- z$mle
965 s[i, ] <- z$se
966 up[i, ] <- z$mle + 1.96 * z$se
967 ul[i, ] <- z$mle - 1.96 * z$se
968 }
969 names <- c("Location", "Scale", "Shape")
970 oldpar <- par(mfrow = c(1, 3))
971 for(i in 1:3) {
972 um <- max(up[, i])
973 ud <- min(ul[, i])
974 plot(u, m[, i], ylim = c(ud, um), xlab = "Threshold", ylab =
975 names[i], type = "b")
976 for(j in 1:nint)
977 lines(c(u[j], u[j]), c(ul[j, i], up[j, i]))
978 }
979 par(oldpar)
980 invisible()
981 }
982
983 "pp.fit" <-
984 function(xdat, threshold, npy = 365, ydat = NULL, mul = NULL, sigl = NULL,
985 shl = NULL, mulink = identity, siglink = identity, shlink = identity,
986 show = TRUE, method = "Nelder-Mead", maxit = 10000, ...)
987 {
988 z <- list()
989 npmu <- length(mul) + 1
990 npsc <- length(sigl) + 1
991 npsh <- length(shl) + 1
992 n <- length(xdat)
993 z$trans <- FALSE
994 if(is.function(threshold))
995 stop("`threshold' cannot be a function")
996 u <- rep(threshold, length.out = n)
997 if(length(unique(u)) > 1) z$trans <- TRUE
998 xdatu <- xdat[xdat > u]
999 xind <- (1:n)[xdat > u]
1000 u <- u[xind]
1001 in2 <- sqrt(6 * var(xdat))/pi
1002 in1 <- mean(xdat) - 0.57722 * in2
1003 if(is.null(mul)) {
1004 mumat <- as.matrix(rep(1, length(xdatu)))
1005 muinit <- in1
1006 }
1007 else {
1008 z$trans <- TRUE
1009 mumat <- cbind(rep(1, length(xdatu)), ydat[xind, mul])
1010 muinit <- c(in1, rep(0, length(mul)))
1011 }
1012 if(is.null(sigl)) {
1013 sigmat <- as.matrix(rep(1, length(xdatu)))
1014 siginit <- in2
1015 }
1016 else {
1017 z$trans <- TRUE
1018 sigmat <- cbind(rep(1, length(xdatu)), ydat[xind, sigl])
1019 siginit <- c(in2, rep(0, length(sigl)))
1020 }
1021 if(is.null(shl)) {
1022 shmat <- as.matrix(rep(1, length(xdatu)))
1023 shinit <- 0.1
1024 }
1025 else {
1026 z$trans <- TRUE
1027 shmat <- cbind(rep(1, length(xdatu)), ydat[xind, shl])
1028 shinit <- c(0.1, rep(0, length(shl)))
1029 }
1030 init <- c(muinit, siginit, shinit)
1031 z$model <- list(mul, sigl, shl)
1032 z$link <- deparse(substitute(c(mulink, siglink, shlink)))
1033 z$threshold <- threshold
1034 z$npy <- npy
1035 z$nexc <- length(xdatu)
1036 z$data <- xdatu
1037 pp.lik <- function(a) {
1038 mu <- mulink(mumat %*% (a[1:npmu]))
1039 sc <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
1040 xi <- shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)]))
1041 if(any(sc <= 0)) return(10^6)
1042 if(min(1 + ((xi * (u - mu))/sc)) < 0) {
1043 l <- 10^6
1044 }
1045 else {
1046 y <- (xdatu - mu)/sc
1047 y <- 1 + xi * y
1048 if(min(y) <= 0)
1049 l <- 10^6
1050 else l <- sum(log(sc)) + sum(log(y) * (1/xi + 1)) + n/npy *
1051 mean((1 + (xi * (u - mu))/sc)^(-1/xi))
1052 }
1053 l
1054 }
1055 x <- optim(init, pp.lik, hessian = TRUE, method = method,
1056 control = list(maxit = maxit, ...))
1057 mu <- mulink(mumat %*% (x$par[1:npmu]))
1058 sc <- siglink(sigmat %*% (x$par[seq(npmu + 1, length = npsc)]))
1059 xi <- shlink(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)]))
1060 z$conv <- x$convergence
1061 z$nllh <- x$value
1062 z$vals <- cbind(mu, sc, xi, u)
1063 z$gpd <- apply(z$vals, 1, ppp, npy)
1064 if(z$trans) {
1065 z$data <- as.vector((1 + (xi * (xdatu - u))/z$gpd[2, ])^(-1/xi
1066 ))
1067 }
1068 z$mle <- x$par
1069 z$cov <- solve(x$hessian)
1070 z$se <- sqrt(diag(z$cov))
1071 if(show) {
1072 if(z$trans)
1073 print(z[c(2, 3)])
1074 if(length(z[[4]]) == 1)
1075 print(z[4])
1076 print(z[c(5, 6, 8)])
1077 if(!z$conv)
1078 print(z[c(9, 12, 14)])
1079 }
1080 invisible(z)
1081 }
1082
1083 "pp.diag" <-
1084 function(z)
1085 {
1086 n <- length(z$data)
1087 x <- (1:n)/(n + 1)
1088 if(z$trans) {
1089 oldpar <- par(mfrow = c(1, 2))
1090 plot(x, sort(z$data), xlab = "empirical", ylab = "model")
1091 abline(0, 1, col = 3)
1092 title("Residual Probability Plot")
1093 plot( - log(1 - x), - log(1 - sort(z$data)), ylab =
1094 "empirical", xlab = "model")
1095 abline(0, 1, col = 3)
1096 title("Residual quantile Plot (Exptl. Scale)")
1097 }
1098 else {
1099 oldpar <- par(mfrow = c(1, 2), pty = "s")
1100 pp.pp(z$mle, z$threshold, z$npy, z$data)
1101 pp.qq(z$mle, z$threshold, z$npy, z$data)
1102 }
1103 par(oldpar)
1104 invisible()
1105 }
1106
1107 "pp.pp" <-
1108 function(a, u, npy, dat)
1109 {
1110 #
1111 # function called by pp.diag
1112 # produces probability plot
1113 #
1114 y <- apply(as.matrix(sort(dat)), 1, ppf, a = a, u = u, npy = npy)
1115 plot((1:length(dat))/length(dat), y, xlab = "empirical", ylab = "model",
1116 main = "Probability plot")
1117 abline(0, 1, col = 4)
1118 }
1119
1120 "pp.qq" <-
1121 function(a, u, npy, dat)
1122 {
1123 #
1124 # function called by pp.diag
1125 # computes quantile plot
1126 #
1127 y <- apply(as.matrix((length(dat):1/(length(dat) + 1))), 1, ppq, a = a,
1128 u = u, npy = npy)
1129 plot(y, sort(dat), ylab = "empirical", xlab = "model", main =
1130 "Quantile Plot")
1131 abline(0, 1, col = 4)
1132 }
1133
1134 "ppf" <-
1135 function(a, z, u, npy)
1136 {
1137 #
1138 # ancillary function
1139 # calculates distribution function in point process model
1140 #
1141 b <- ppp(c(a, u), npy)
1142 1 - (1 + (b[3] * (z - u))/b[2])^(-1/b[3])
1143 }
1144
1145 "ppq" <-
1146 function(a, u, npy, p)
1147 {
1148 #
1149 # ancillary routine
1150 # finds quantiles in point process model
1151 #
1152 b <- ppp(c(a, u), npy)
1153 u + (b[2] * (((p))^( - b[3]) - 1))/b[3]
1154 }
1155
1156 "ppp" <-
1157 function(a, npy)
1158 {
1159 u <- a[4]
1160 la <- 1 - exp( - (1 + (a[3] * (u - a[1]))/a[2])^(-1/a[3])/npy)
1161 sc <- a[2] + a[3] * (u - a[1])
1162 xi <- a[3]
1163 c(la, sc, xi)
1164 }
1165
1166 # This file contains the following functions:
1167 # rlarg.fit rlarg.diag rlarg.pp rlarg.qq
1168 # rlargf rlargq rlargq2
1169
1170 "rlarg.fit" <-
1171 function(xdat, r = dim(xdat)[2], ydat = NULL, mul = NULL, sigl = NULL,
1172 shl = NULL, mulink = identity, siglink = identity, shlink = identity,
1173 show = TRUE, method = "Nelder-Mead", maxit = 10000, ...)
1174 {
1175 #
1176 # calculates mles etc for rlargest order statistic model
1177 #
1178 z <- list()
1179 npmu <- length(mul) + 1
1180 npsc <- length(sigl) + 1
1181 npsh <- length(shl) + 1
1182 z$trans <- FALSE
1183 in2 <- sqrt(6 * var(xdat[, 1]))/pi
1184 in1 <- mean(xdat[, 1]) - 0.57722 * in2
1185 if(is.null(mul)) {
1186 mumat <- as.matrix(rep(1, dim(xdat)[1]))
1187 muinit <- in1
1188 }
1189 else {
1190 z$trans <- TRUE
1191 mumat <- cbind(rep(1, dim(xdat)[1]), ydat[, mul])
1192 muinit <- c(in1, rep(0, length(mul)))
1193 }
1194 if(is.null(sigl)) {
1195 sigmat <- as.matrix(rep(1, dim(xdat)[1]))
1196 siginit <- in2
1197 }
1198 else {
1199 z$trans <- TRUE
1200 sigmat <- cbind(rep(1, dim(xdat)[1]), ydat[, sigl])
1201 siginit <- c(in2, rep(0, length(sigl)))
1202 }
1203 if(is.null(shl)) {
1204 shmat <- as.matrix(rep(1, dim(xdat)[1]))
1205 shinit <- 0.1
1206 }
1207 else {
1208 z$trans <- TRUE
1209 shmat <- cbind(rep(1, dim(xdat)[1]), ydat[, shl])
1210 shinit <- c(0.1, rep(0, length(shl)))
1211 }
1212 xdatu <- xdat[, 1:r, drop = FALSE]
1213 init <- c(muinit, siginit, shinit)
1214 z$model <- list(mul, sigl, shl)
1215 z$link <- deparse(substitute(c(mulink, siglink, shlink)))
1216 u <- apply(xdatu, 1, min, na.rm = TRUE)
1217 rlarg.lik <- function(a) {
1218 # calculates neg log lik
1219 mu <- mulink(drop(mumat %*% (a[1:npmu])))
1220 sc <- siglink(drop(sigmat %*% (a[seq(npmu + 1, length = npsc)])))
1221 xi <- shlink(drop(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)])))
1222 if(any(sc <= 0)) return(10^6)
1223 y <- 1 + xi * (xdatu - mu)/sc
1224 if(min(y, na.rm = TRUE) <= 0)
1225 l <- 10^6
1226 else {
1227 y <- (1/xi+1) * log(y) + log(sc)
1228 y <- rowSums(y, na.rm = TRUE)
1229 l <- sum((1 + xi * (u - mu)/sc)^(-1/xi) + y)
1230 }
1231 l
1232 }
1233 x <- optim(init, rlarg.lik, hessian = TRUE, method = method,
1234 control = list(maxit = maxit, ...))
1235 mu <- mulink(drop(mumat %*% (x$par[1:npmu])))
1236 sc <- siglink(drop(sigmat %*% (x$par[seq(npmu + 1, length = npsc)])))
1237 xi <- shlink(drop(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)])))
1238 z$conv <- x$convergence
1239 z$nllh <- x$value
1240 z$data <- xdat
1241 if(z$trans) {
1242 for(i in 1:r)
1243 z$data[, i] <- - log((1 + (as.vector(xi) * (xdat[, i] -
1244 as.vector(mu)))/as.vector(sc))^(-1/as.vector(xi
1245 )))
1246 }
1247 z$mle <- x$par
1248 z$cov <- solve(x$hessian)
1249 z$se <- sqrt(diag(z$cov))
1250 z$vals <- cbind(mu, sc, xi)
1251 z$r <- r
1252 if(show) {
1253 if(z$trans)
1254 print(z[c(2, 3)])
1255 print(z[4])
1256 if(!z$conv)
1257 print(z[c(5, 7, 9)])
1258 }
1259 invisible(z)
1260 }
1261
1262 "rlarg.diag" <-
1263 function(z, n = z$r)
1264 {
1265 #
1266 # takes output from rlarg.fit
1267 # produces probability and quantile plots for
1268 # each order statistic
1269 #
1270 z2 <- z
1271 z2$data <- z$data[, 1]
1272 oldpar <- par(ask = TRUE, mfcol = c(2, 2))
1273 if(z$trans) {
1274 for(i in 1:n) {
1275 rlarg.pp(c(0, 1, 0), z$data[, 1:z$r], i)
1276 rlarg.qq(c(0, 1, 0), z$data[, 1:z$r], i)
1277 }
1278 }
1279 else {
1280 gev.diag(z2)
1281 for(i in 1:n) {
1282 rlarg.pp(z$mle, z$data, i)
1283 rlarg.qq(z$mle, z$data, i)
1284 }
1285 }
1286 par(oldpar)
1287 invisible()
1288 }
1289
1290 "rlarg.pp" <-
1291 function(a, dat, k)
1292 {
1293 #
1294 # ancillary function
1295 # calculates probability plot in r largest model
1296 #
1297 da <- dat[!is.na(dat[, k]), k]
1298 plot((1:length(da))/length(da), rlargf(a, sort(da), k), xlab = "", ylab
1299 = "")
1300 title(paste("k=", k, sep = ""), cex = 0.7)
1301 abline(0, 1, col = 4)
1302 }
1303
1304 "rlarg.qq" <-
1305 function(a, dat, k)
1306 {
1307 #
1308 # ancillary function
1309 # calculates quantile plot in r largest model
1310 #
1311 da <- dat[!is.na(dat[, k]), k]
1312 plot(rlargq(a, 1 - (1:length(da)/(length(da) + 1)), k, da), sort(da),
1313 xlab = "", ylab = "")
1314 title(paste("k=", k, sep = ""), cex = 0.7)
1315 abline(0, 1, col = 4)
1316 }
1317
1318 "rlargf" <-
1319 function(a, z, k)
1320 {
1321 #
1322 # ancillary function
1323 # calculates dist fnc in r largest model
1324 #
1325 eps <- 10^(-6)
1326 res <- NULL
1327 if(abs(a[3]) < eps)
1328 tau <- exp( - (z - a[1])/a[2])
1329 else tau <- (1 + (a[3] * (z - a[1]))/a[2])^(-1/a[3])
1330 for(i in 1:length(tau)) {
1331 if(is.na(tau[i]))
1332 res[i] <- 1
1333 else res[i] <- exp( - tau[i]) * sum(tau[i]^(0:(k - 1))/gamma(1:(
1334 k)))
1335 }
1336 res
1337 }
1338
1339 "rlargq" <-
1340 function(a, p, k, dat)
1341 {
1342 #
1343 # ancillary routine
1344 # for finding quantiles in r largest model
1345 res <- NULL
1346 for(i in 1:length(p)) {
1347 inter <- c(min(dat) - 1, max(dat) + 1)
1348 res[i] <- uniroot(rlargq2, inter, a = a, kk = k, p = p[i])$root
1349 }
1350 res
1351 }
1352
1353 "rlargq2" <-
1354 function(x, a, kk, p)
1355 {
1356 #
1357 # ancillary routine
1358 # for finding quantiles in r largest model
1359 #
1360 res <- rlargf(a, x, kk) - (1 - p)
1361 res
1362 }
1363
1364 ################################################################################
1365
1366 "gev" <-
1367 function(data, block = NA, ...)
1368 {
1369 n.all <- NA
1370 if(!is.na(block)) {
1371 n.all <- length(data)
1372 if(is.character(block)) {
1373 times <- as.POSIXlt(attributes(data)$times)
1374 if(block %in% c("semester", "quarter")) {
1375 sem <- quart <- times$mon
1376 sem[sem %in% 0:5] <- quart[quart %in% 0:2] <- 0
1377 sem[sem %in% 6:11] <- quart[quart %in% 3:5] <- 1
1378 quart[quart %in% 6:8] <- 2
1379 quart[quart %in% 9:11] <- 3
1380 }
1381 grouping <- switch(block,
1382 semester = paste(times$year, sem),
1383 quarter = paste(times$year, quart),
1384 month = paste(times$year, times$mon),
1385 year = times$year,
1386 stop("unknown time period"))
1387 data <- tapply(data, grouping, max)
1388 }
1389 else {
1390 data <- as.numeric(data)
1391 nblocks <- (length(data) %/% block) + 1
1392 grouping <- rep(1:nblocks, rep(block, nblocks))[1:length(data)]
1393 data <- tapply(data, grouping, max)
1394 }
1395 }
1396 data <- as.numeric(data)
1397 n <- length(data)
1398 sigma0 <- sqrt(6 * var(data))/pi
1399 mu0 <- mean(data) - 0.57722 * sigma0
1400 xi0 <- 0.1
1401 theta <- c(xi0, sigma0, mu0)
1402 negloglik <- function(theta, tmp)
1403 {
1404 y <- 1 + (theta[1] * (tmp - theta[3]))/theta[2]
1405 if((theta[2] < 0) || (min(y) < 0))
1406 out <- 1e+06
1407 else {
1408 term1 <- length(tmp) * logb(theta[2])
1409 term2 <- sum((1 + 1/theta[1]) * logb(y))
1410 term3 <- sum(y^(-1/theta[1]))
1411 out <- term1 + term2 + term3
1412 }
1413 out
1414 }
1415 fit <- optim(theta, negloglik, hessian = TRUE, ..., tmp = data)
1416 if(fit$convergence)
1417 warning("optimization may not have succeeded")
1418 par.ests <- fit$par
1419 varcov <- solve(fit$hessian)
1420 par.ses <- sqrt(diag(varcov))
1421 out <- list(n.all = n.all, n = n, data = data, block = block, par.ests
1422 = par.ests, par.ses = par.ses, varcov = varcov, converged =
1423 fit$convergence, nllh.final = fit$value)
1424 names(out$par.ests) <- c("xi", "sigma", "mu")
1425 names(out$par.ses) <- c("xi", "sigma", "mu")
1426 class(out) <- "gev"
1427 out
1428 }
1429
1430 "gumbel" <-
1431 function(data, block = NA, ...)
1432 {
1433 n.all <- NA
1434 data <- as.numeric(data)
1435 if(!is.na(block)) {
1436 n.all <- length(data)
1437 if(fg <- n.all %% block) {
1438 data <- c(data, rep(NA, block - fg))
1439 warning(paste("final group contains only", fg, "observations"))
1440 }
1441 data <- apply(matrix(data, nrow = block), 2, max, na.rm = TRUE)
1442 }
1443 n <- length(data)
1444 sigma0 <- sqrt(6 * var(data))/pi
1445 mu0 <- mean(data) - 0.57722 * sigma0
1446 theta <- c(sigma0, mu0)
1447 negloglik <- function(theta, tmp)
1448 {
1449 y <- (tmp - theta[2])/theta[1]
1450 if(theta[1] < 0)
1451 out <- 1e+06
1452 else {
1453 term1 <- length(tmp) * logb(theta[1])
1454 term2 <- sum(y)
1455 term3 <- sum(exp( - y))
1456 out <- term1 + term2 + term3
1457 }
1458 out
1459 }
1460 fit <- optim(theta, negloglik, hessian = TRUE, ..., tmp = data)
1461 if(fit$convergence)
1462 warning("optimization may not have succeeded")
1463 par.ests <- fit$par
1464 varcov <- solve(fit$hessian)
1465 par.ses <- sqrt(diag(varcov))
1466 out <- list(n.all = n.all, n = n, data = data, block = block, par.ests
1467 = par.ests, par.ses = par.ses, varcov = varcov, converged =
1468 fit$convergence, nllh.final = fit$value)
1469 names(out$par.ests) <- c("sigma", "mu")
1470 names(out$par.ses) <- c("sigma", "mu")
1471 class(out) <- "gev"
1472 out
1473 }
1474
1475 "plot.gev" <-
1476 function(x, ...)
1477 {
1478 par.ests <- x$par.ests
1479 mu <- par.ests["mu"]
1480 sigma <- par.ests["sigma"]
1481 if(!("xi" %in% names(par.ests)))
1482 xi <- 0
1483 else xi <- par.ests["xi"]
1484 if(xi != 0)
1485 residuals <- (1 + (xi * (x$data - mu))/sigma)^(-1/xi)
1486 else residuals <- exp( - exp( - (x$data - mu)/sigma))
1487 choices <- c("Scatterplot of Residuals", "QQplot of Residuals")
1488 tmenu <- paste("plot:", choices)
1489 pick <- 1
1490 while(pick > 0) {
1491 pick <- menu(tmenu, title =
1492 "\nMake a plot selection (or 0 to exit):")
1493 switch(pick,
1494 {
1495 plot(residuals, ylab = "Residuals",
1496 xlab = "Ordering", ...)
1497 lines(lowess(1:length(residuals), residuals))
1498 },
1499 qplot(residuals, ...))
1500 }
1501 }
1502
1503 "rlevel.gev" <-
1504 function(out, k.blocks = 20, add = FALSE, ...)
1505 {
1506 par.ests <- out$par.ests
1507 mu <- par.ests["mu"]
1508 sigma <- par.ests["sigma"]
1509 if(!("xi" %in% names(par.ests)))
1510 stop("Use this function after a GEV rather than a Gumbel fit")
1511 else xi <- par.ests["xi"]
1512 pp <- 1/k.blocks
1513 v <- qgev((1 - pp), xi, mu, sigma)
1514 if(add) abline(h = v)
1515 data <- out$data
1516 overallmax <- out$nllh.final
1517 sigma0 <- sqrt(6 * var(data))/pi
1518 xi0 <- 0.01
1519 theta <- c(xi0, sigma0)
1520 parloglik <- function(theta, tmp, pp, rli)
1521 {
1522 mu <- rli + (theta[2] * (1 - ( - logb(1 - pp))^( - theta[
1523 1])))/theta[1]
1524 y <- 1 + (theta[1] * (tmp - mu))/theta[2]
1525 if((theta[2] < 0) | (min(y) < 0))
1526 out <- 1e+06
1527 else {
1528 term1 <- length(tmp) * logb(theta[2])
1529 term2 <- sum((1 + 1/theta[1]) * logb(y))
1530 term3 <- sum(y^(-1/theta[1]))
1531 out <- term1 + term2 + term3
1532 }
1533 out
1534 }
1535 parmax <- NULL
1536 rl <- v * c(0.5, 0.6, 0.7, 0.8, 0.85, 0.9, 0.95, 1, 1.1, 1.2,
1537 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, 3, 3.25, 3.5, 4.5)
1538 for(i in 1:length(rl)) {
1539 fit <- optim(theta, parloglik, hessian = FALSE, tmp = data,
1540 pp = pp, rli = rl[i])
1541 parmax <- rbind(parmax, fit$value)
1542 }
1543 parmax <- - parmax
1544 overallmax <- - overallmax
1545 crit <- overallmax - qchisq(0.9999, 1)/2
1546 cond <- parmax > crit
1547 rl <- rl[cond]
1548 parmax <- parmax[cond]
1549 smth <- spline(rl, parmax, n = 200)
1550 aalpha <- qchisq(0.95, 1)
1551 if(!add) {
1552 plot(rl, parmax, type = "p", ...)
1553 abline(h = overallmax - aalpha/2)
1554 abline(v = v)
1555 lines(smth)
1556 }
1557 ind <- smth$y > overallmax - aalpha/2
1558 ci <- range(smth$x[ind])
1559 if(add) {
1560 abline(h = ci[1], lty = 2, col = 2)
1561 abline(h = ci[2], lty = 2, col = 2)
1562 }
1563 as.numeric(c(ci[1], v, ci[2]))
1564 }
1565
1566
1567 "gpdbiv" <-
1568 function(data1 = NA, data2 = NA, u1 = NA, u2 = NA, ne1 = NA,
1569 ne2 = NA, global = FALSE, method = "BFGS", ...)
1570 {
1571 data1 <- as.numeric(data1)
1572 data2 <- as.numeric(data2)
1573
1574 Zfunc <- function(y, u, lambda, xi, sigma)
1575 (lambda^-1) * (1 + (xi * pmax((y - u), 0))/sigma)^(1/xi)
1576 Kfunc <- function(y, u, lambda, xi, sigma)
1577 -lambda^(-xi) * (sigma^-1) * (Zfunc(y, u, lambda, xi, sigma))^(1 - xi)
1578 Vfunc <- function(x, y, alpha)
1579 (x^(-1/alpha) + y^(-1/alpha))^alpha
1580 Vfunc1 <- function(x, y, alpha)
1581 -x^(-(1/alpha) - 1) * (x^(-1/alpha) + y^(-1/alpha))^(alpha - 1)
1582 Vfunc2 <- function(x, y, alpha)
1583 -(alpha - 1) * (alpha^-1) * (x * y)^(-(1/alpha) - 1) *
1584 (x^(-1/alpha) + y^(-1/alpha))^(alpha - 2)
1585 fun <- list(Z = Zfunc, K = Kfunc, V = Vfunc, V1 = Vfunc1, V2 = Vfunc2)
1586
1587 if(is.na(ne1) && is.na(u1))
1588 stop(paste("Enter either a threshold or",
1589 "the number of upper extremes for margin 1"))
1590 if(!is.na(ne1) && !is.na(u1))
1591 stop(paste("Enter EITHER a threshold or",
1592 "the number of upper extremes for margin 1"))
1593 if(is.na(ne2) && is.na(u2))
1594 stop(paste("Enter either a threshold or",
1595 "the number of upper extremes for margin 2"))
1596 if(!is.na(ne2) && !is.na(u2))
1597 stop(paste("Enter EITHER a threshold or",
1598 "the number of upper extremes for margin 2"))
1599
1600 out1 <- gpd(data1, threshold = u1, ne = ne1)
1601 par.ests1 <- out1$par.ests
1602 par.ses1 <- out1$par.ses
1603
1604 out2 <- gpd(data2, threshold = u2, ne = ne2)
1605 par.ests2 <- out2$par.ests
1606 par.ses2 <- out2$par.ses
1607
1608 uu <- c(out1$threshold, out2$threshold)
1609 ne <- c(out1$n.exceed, out2$n.exceed)
1610 mpar <- c(par.ests1, par.ests2)
1611
1612 delta1 <- as.numeric(data1 > uu[1])
1613 delta2 <- as.numeric(data2 > uu[2])
1614 lambda1 <- sum(delta1)/length(data1)
1615 lambda2 <- sum(delta2)/length(data2)
1616
1617 theta <- 0.8
1618 if(global) {
1619 theta <- c(theta, mpar)
1620 mpar <- NULL
1621 }
1622
1623 negloglik <- function(theta, data1, data2, uu, delta1, delta2,
1624 lambda1, lambda2, mpar, fun)
1625 {
1626 alpha <- theta[1]
1627 if(is.null(mpar)) {
1628 xi1 <- theta[2] ; sigma1 <- theta[3]
1629 xi2 <- theta[4] ; sigma2 <- theta[5]
1630 }
1631 else {
1632 xi1 <- mpar[1] ; sigma1 <- mpar[2]
1633 xi2 <- mpar[3] ; sigma2 <- mpar[4]
1634 }
1635 cond1 <- (alpha <= 0) | (alpha >= 1)
1636 cond2 <- sigma1 <= 0
1637 cond3 <- sigma2 <= 0
1638 if(cond1 || cond2 || cond3)
1639 out <- 1e+06
1640 else {
1641 term4 <- (1 - delta1) * (1 - delta2) * logb(1 -
1642 fun$V(lambda1^-1, lambda2^-1, alpha))
1643 term3 <- delta1 * (1 - delta2) * logb(fun$K(data1, uu[1], lambda1,
1644 xi1, sigma1) * fun$V1(fun$Z(data1, uu[1], lambda1, xi1,
1645 sigma1), lambda2^-1, alpha))
1646 term2 <- delta2 * (1 - delta1) * logb(fun$K(data2, uu[2], lambda2,
1647 xi2, sigma2) * fun$V1(fun$Z(data2, uu[2], lambda2, xi2,
1648 sigma2), lambda1^-1, alpha))
1649 term1 <- delta1 * delta2 * logb(fun$K(data1, uu[1], lambda1, xi1,
1650 sigma1) * fun$K(data2, uu[2], lambda2, xi2, sigma2) *
1651 fun$V2(fun$Z(data1, uu[1], lambda1, xi1, sigma1), fun$Z(data2,
1652 uu[2], lambda2, xi2, sigma2), alpha))
1653 allterm <- term1 + term2 + term3 + term4
1654 out <- - sum(allterm)
1655 }
1656 out
1657 }
1658 fit <- optim(theta, negloglik, hessian = TRUE, method = method, ...,
1659 data1 = data1, data2 = data2, uu = uu,
1660 delta1 = delta1, delta2 = delta2, lambda1 = lambda1,
1661 lambda2 = lambda2, mpar = mpar, fun = fun)
1662 if(fit$convergence)
1663 warning("optimization may not have succeeded")
1664 par.ests <- fit$par
1665 varcov <- solve(fit$hessian)
1666 par.ses <- sqrt(diag(varcov))
1667 alpha <- par.ests[1]
1668 alpha.se <- par.ses[1]
1669 if(global) {
1670 par.ests1 <- c(par.ests[2], par.ests[3])
1671 names(par.ests1) <- c("xi", "beta")
1672 par.ses1 <- c(par.ses[2], par.ses[3])
1673 par.ests2 <- c(par.ests[4], par.ests[5])
1674 names(par.ests2) <- c("xi", "beta")
1675 par.ses2 <- c(par.ses[4], par.ses[5])
1676 }
1677 out <- list(data1 = data1[delta1 == 1], delta1 = (delta1 ==
1678 1 & delta2 == 1)[delta1 == 1], data2 = data2[
1679 delta2 == 1], delta2 = (delta1 == 1 & delta2 == 1)[delta2 ==
1680 1], u1 = uu[1], ne1 = ne[1], lambda1 = lambda1, u2 = uu[2],
1681 ne2 = ne[2], lambda2 = lambda2, alpha = alpha, alpha.se = alpha.se,
1682 par.ests1 = par.ests1, par.ses1 = par.ses1, par.ests2 =
1683 par.ests2, par.ses2 = par.ses2, converged = fit$convergence,
1684 nllh.final = fit$value, dependence = "logistic",
1685 dep.func = Vfunc)
1686 class(out) <- "gpdbiv"
1687 out
1688 }
1689
1690 "interpret.gpdbiv" <-
1691 function(out, x, y)
1692 {
1693 Vfuncf <- out$dep.func
1694 newfunc <- function(x, y, alpha, u1, lambda1, xi1, sigma1, u2, lambda2,
1695 xi2, sigma2, vfunc)
1696 {
1697 Zfunc <- function(y, u, lambda, xi, sigma)
1698 (lambda^-1) * (1 + (xi * pmax((y - u), 0))/sigma)^(1/xi)
1699 1 - vfunc(Zfunc(x, u1, lambda1, xi1, sigma1), Zfunc(y, u2,
1700 lambda2, xi2, sigma2), alpha)
1701 }
1702 marg <- function(x, u1, lambda1, xi1, sigma1)
1703 {
1704 1 - lambda1 * (1 + (xi1 * (x - u1))/sigma1)^(-1/xi1)
1705 }
1706 newfunc2 <- function(x, y, alpha, u1, lambda1, xi1, sigma1, u2, lambda2,
1707 xi2, sigma2, marg, newfunc, vfunc)
1708 {
1709 1 - marg(x, u1, lambda1, xi1, sigma1) - marg(y, u2, lambda2, xi2,
1710 sigma2) + newfunc(x, y, alpha, u1, lambda1, xi1, sigma1, u2,
1711 lambda2, xi2, sigma2, vfunc)
1712 }
1713
1714 if(out$u1 > x) stop("Point below x threshold")
1715 if(out$u2 > y) stop("Point below y threshold")
1716 p1 <- 1 - marg(x, out$u1, out$lambda1, out$par.ests1[1], out$
1717 par.ests1[2])
1718 p2 <- 1 - marg(y, out$u2, out$lambda2, out$par.ests2[1], out$
1719 par.ests2[2])
1720 p12 <- newfunc2(x, y, out$alpha, out$u1, out$lambda1, out$par.ests1[1],
1721 out$par.ests1[2], out$u2, out$lambda2, out$par.ests2[1],
1722 out$par.ests2[2], marg, newfunc, Vfuncf)
1723
1724 cat("Thresholds:", out$u1, out$u2, "\n")
1725 cat("Extreme levels of interest (x,y):", x, y, "\n")
1726 cat("P(X exceeds x)", p1, "\n")
1727 cat("P(Y exceeds y)", p2, "\n")
1728 cat("P(X exceeds x AND Y exceeds y)", p12, "\n")
1729 cat("P(X exceeds x) * P(Y exceeds y)", p1 * p2, "\n")
1730 cat("P(Y exceeds y GIVEN X exceeds x)", p12/p1, "\n")
1731 cat("P(X exceeds x GIVEN Y exceeds y)", p12/p2, "\n")
1732 invisible(as.numeric(c(p1, p2, p12, p1 * p2, p12/p1, p12/p2)))
1733 }
1734
1735 "plot.gpdbiv" <-
1736 function(x, extend = 1.1, n.contours = 15, ...)
1737 {
1738 Zfunc <- function(y, u, lambda, xi, sigma)
1739 (lambda^-1) * (1 + (xi * pmax((y - u), 0))/sigma)^(1/xi)
1740
1741 joint <- function(xx, y, alpha, u1, lambda1, xi1, sigma1, u2, lambda2,
1742 xi2, sigma2, Vfunc)
1743 {
1744 1 - Vfunc(Zfunc(xx, u1, lambda1, xi1, sigma1),
1745 Zfunc(y, u2, lambda2, xi2, sigma2), alpha)
1746 }
1747 marg <- function(xx, u1, lambda1, xi1, sigma1)
1748 {
1749 1 - lambda1 * (1 + (xi1 * (xx - u1))/sigma1)^(-1/xi1)
1750 }
1751 survivor <- function(xx, y, alpha, u1, lambda1, xi1, sigma1, u2,
1752 lambda2, xi2, sigma2, marg, joint, Vfunc)
1753 {
1754 1 - marg(xx, u1, lambda1, xi1, sigma1) - marg(y, u2, lambda2,
1755 xi2, sigma2) + joint(xx, y, alpha, u1, lambda1, xi1,
1756 sigma1, u2, lambda2, xi2, sigma2, Vfunc)
1757 }
1758
1759 xx <- seq(from = x$u1, to = extend * max(x$data1), length = 200)
1760 y <- seq(from = x$u2, to = extend * max(x$data2), length = 200)
1761 choices <- c("Exceedance data",
1762 "Contours of Bivariate Distribution Function",
1763 "Contours of Bivariate Survival Function",
1764 "Tail of Marginal 1", "Tail of Marginal 2")
1765 tmenu <- paste("plot:", choices)
1766 pick <- 1
1767 while(pick > 0) {
1768 par(mfrow = c(1, 1))
1769 pick <- menu(tmenu, title =
1770 "\nMake a plot selection (or 0 to exit):")
1771 if(pick == 1) {
1772 par(mfrow = c(2, 1))
1773 plot(x$data1, main = "Marginal1", type = "n", ...)
1774 points((1:length(x$data1))[x$delta1 == 0],
1775 x$data1[x$delta1 == 0])
1776 points((1:length(x$data1))[x$delta1 == 1],
1777 x$data1[x$delta1 == 1], col = 2)
1778 plot(x$data2, main = "Marginal2", type = "n", ...)
1779 points((1:length(x$data2))[x$delta2 == 0],
1780 x$data2[x$delta2 == 0])
1781 points((1:length(x$data2))[x$delta2 == 1],
1782 x$data2[x$delta2 == 1], col = 2)
1783 }
1784 if(pick == 4) {
1785 x$name <- "Marginal1"
1786 x$par.ests <- x$par.ests1
1787 x$data <- x$data1
1788 x$threshold <- x$u1
1789 x$p.less.thresh <- 1 - x$lambda1
1790 tailplot(x, ...)
1791 }
1792 if(pick == 5) {
1793 x$name <- "Marginal2"
1794 x$par.ests <- x$par.ests2
1795 x$data <- x$data2
1796 x$threshold <- x$u2
1797 x$p.less.thresh <- 1 - x$lambda2
1798 tailplot(x, ...)
1799 }
1800 if(pick == 2) {
1801 z <- outer(xx, y, joint, alpha = x$alpha, u1 = x$u1,
1802 lambda1 = x$lambda1, xi1 = x$par.ests1[1],
1803 sigma1 = x$par.ests1[2], u2 = x$u2, lambda2 =
1804 x$lambda2, xi2 = x$par.ests2[1], sigma2 =
1805 x$par.ests2[2], Vfunc = x$dep.func)
1806 par(xaxs = "i", yaxs = "i")
1807 contour(xx, y, z, nlevels = n.contours, main = "Joint", ...)
1808 }
1809 if(pick == 3) {
1810 z2 <- outer(xx, y, survivor, alpha = x$alpha, u1 = x$u1,
1811 lambda1 = x$lambda1, xi1 = x$par.ests1[1],
1812 sigma1 = x$par.ests1[2], u2 = x$u2, lambda2 =
1813 x$lambda2, xi2 = x$par.ests2[1], sigma2 =
1814 x$par.ests2[2], marg = marg, joint = joint,
1815 Vfunc = x$dep.func)
1816 level.thresh <- x$lambda1 + x$lambda2 - (x$lambda1^(1/x$alpha) +
1817 x$lambda2^(1/x$alpha))^x$alpha
1818 contour(xx, y, z2, nlevels = n.contours, main = "Survival", ...)
1819 }
1820 }
1821 }
1822
1823 "emplot" <-
1824 function(data, alog = "x", labels = TRUE, ...)
1825 {
1826 data <- sort(as.numeric(data))
1827 ypoints <- 1 - ppoints(data)
1828 plot(data, ypoints, log = alog, xlab = "", ylab = "", ...)
1829 if(labels) {
1830 xxlab <- "x"
1831 yylab <- "1 - F(x)"
1832 if(alog != "")
1833 xxlab <- paste(xxlab, "(on log scale)")
1834 if(alog == "xy" || alog == "yx")
1835 yylab <- paste(yylab, "(on log scale)")
1836 title(xlab = xxlab, ylab = yylab)
1837 }
1838 invisible(list(x = data, y = ypoints))
1839 }
1840
1841 "exindex" <-
1842 function(data, block, start = 5, end = NA, reverse = FALSE,
1843 auto.scale = TRUE, labels = TRUE, ...)
1844 {
1845 sorted <- rev(sort(as.numeric(data)))
1846 n <- length(sorted)
1847 if(is.character(block)) {
1848 times <- as.POSIXlt(attributes(data)$times)
1849 if(block %in% c("semester", "quarter")) {
1850 sem <- quart <- times$mon
1851 sem[sem %in% 0:5] <- quart[quart %in% 0:2] <- 0
1852 sem[sem %in% 6:11] <- quart[quart %in% 3:5] <- 1
1853 quart[quart %in% 6:8] <- 2
1854 quart[quart %in% 9:11] <- 3
1855 }
1856 grouping <- switch(block,
1857 semester = paste(times$year, sem),
1858 quarter = paste(times$year, quart),
1859 month = paste(times$year, times$mon),
1860 year = times$year,
1861 stop("unknown time period"))
1862 b.lengths <- as.numeric(tapply(data, grouping, length))
1863 b.maxima <- as.numeric(tapply(data, grouping, max))
1864 }
1865 else {
1866 data <- as.numeric(data)
1867 nblocks <- (length(data) %/% block) + 1
1868 grouping <- rep(1:nblocks, rep(block, nblocks))[1:length(data)]
1869 b.lengths <- tapply(data, grouping, length)
1870 b.maxima <- tapply(data, grouping, max)
1871 }
1872 b.lengths <- b.lengths[!is.na(b.lengths)]
1873 b.maxima <- rev(sort(b.maxima[!is.na(b.maxima)]))
1874 if(is.numeric(block)) r <- block
1875 else r <- round(mean(b.lengths[2:(length(b.lengths) - 1)]))
1876 k <- round(n/r)
1877 un <- unique(b.maxima)[-1]
1878 K <- match(un, b.maxima) - 1
1879 N <- match(un, sorted) - 1
1880 if(is.na(end)) end <- k
1881 cond <- (K < end) & (K >= start)
1882 un <- un[cond]
1883 K <- K[cond]
1884 N <- N[cond]
1885 theta2 <- K/N
1886 theta <- logb(1 - K/k)/(r * logb(1 - N/n))
1887 out <- cbind(N, K, un, theta2, theta)
1888 yrange <- range(theta)
1889 index <- K
1890 if(reverse) index <- - K
1891 if(auto.scale)
1892 plot(index, theta, ylim = yrange, type = "l", xlab = "", ylab = "",
1893 axes = FALSE, ...)
1894 else plot(index, theta, type = "l", xlab = "", ylab = "", axes =
1895 FALSE, ...)
1896 axis(1, at = index, lab = paste(K), tick = FALSE)
1897 axis(2)
1898 axis(3, at = index, lab = paste(format(signif(un, 3))), tick = FALSE)
1899 box()
1900 if(labels) {
1901 ylabel <- paste("theta (", k, " blocks of size ", r, ")", sep = "")
1902 title(xlab = "K", ylab = ylabel)
1903 mtext("Threshold", side = 3, line = 3)
1904 }
1905 invisible(out)
1906 }
1907
1908 "hill" <-
1909 function(data, option = c("alpha","xi","quantile"), start = 15, end = NA,
1910 reverse = FALSE, p = NA, ci = 0.95, auto.scale = TRUE, labels = TRUE, ...)
1911 {
1912 data <- as.numeric(data)
1913 ordered <- rev(sort(data))
1914 ordered <- ordered[ordered > 0]
1915 n <- length(ordered)
1916 option <- match.arg(option)
1917 if((option == "quantile") && (is.na(p)))
1918 stop("Input a value for the probability p")
1919 if((option == "quantile") && (p < 1 - start/n)) {
1920 cat("Graph may look strange !! \n\n")
1921 cat(paste("Suggestion 1: Increase `p' above",
1922 format(signif(1 - start/n, 5)), "\n"))
1923 cat(paste("Suggestion 2: Increase `start' above ",
1924 ceiling(length(data) * (1 - p)), "\n"))
1925 }
1926 k <- 1:n
1927 loggs <- logb(ordered)
1928 avesumlog <- cumsum(loggs)/(1:n)
1929 xihat <- c(NA, (avesumlog - loggs)[2:n])
1930 alphahat <- 1/xihat
1931 y <- switch(option,
1932 alpha = alphahat,
1933 xi = xihat,
1934 quantile = ordered * ((n * (1 - p))/k)^(-1/alphahat))
1935 ses <- y/sqrt(k)
1936 if(is.na(end)) end <- n
1937 x <- trunc(seq(from = min(end, length(data)), to = start))
1938 y <- y[x]
1939 ylabel <- option
1940 yrange <- range(y)
1941 if(ci && (option != "quantile")) {
1942 qq <- qnorm(1 - (1 - ci)/2)
1943 u <- y + ses[x] * qq
1944 l <- y - ses[x] * qq
1945 ylabel <- paste(ylabel, " (CI, p =", ci, ")", sep = "")
1946 yrange <- range(u, l)
1947 }
1948 if(option == "quantile") ylabel <- paste("Quantile, p =", p)
1949 index <- x
1950 if(reverse) index <- - x
1951 if(auto.scale)
1952 plot(index, y, ylim = yrange, type = "l", xlab = "", ylab = "",
1953 axes = FALSE, ...)
1954 else plot(index, y, type = "l", xlab = "", ylab = "", axes = FALSE, ...)
1955 axis(1, at = index, lab = paste(x), tick = FALSE)
1956 axis(2)
1957 threshold <- findthresh(data, x)
1958 axis(3, at = index, lab = paste(format(signif(threshold, 3))),
1959 tick = FALSE)
1960 box()
1961 if(ci && (option != "quantile")) {
1962 lines(index, u, lty = 2, col = 2)
1963 lines(index, l, lty = 2, col = 2)
1964 }
1965 if(labels) {
1966 title(xlab = "Order Statistics", ylab = ylabel)
1967 mtext("Threshold", side = 3, line = 3)
1968 }
1969 invisible(list(x = index, y = y))
1970 }
1971
1972 "meplot" <-
1973 function(data, omit = 3, labels = TRUE, ...)
1974 {
1975 data <- as.numeric(data)
1976 n <- length(data)
1977 myrank <- function(x, na.last = TRUE)
1978 {
1979 ranks <- sort.list(sort.list(x, na.last = na.last))
1980 if(is.na(na.last))
1981 x <- x[!is.na(x)]
1982 for(i in unique(x[duplicated(x)])) {
1983 which <- x == i & !is.na(x)
1984 ranks[which] <- max(ranks[which])
1985 }
1986 ranks
1987 }
1988 data <- sort(data)
1989 n.excess <- unique(floor(length(data) - myrank(data)))
1990 points <- unique(data)
1991 nl <- length(points)
1992 n.excess <- n.excess[-nl]
1993 points <- points[-nl]
1994 excess <- cumsum(rev(data))[n.excess] - n.excess * points
1995 y <- excess/n.excess
1996 xx <- points[1:(nl-omit)] ; yy <- y[1:(nl-omit)]
1997 plot(xx, yy, xlab = "", ylab = "", ...)
1998 if(labels) title(xlab = "Threshold", ylab = "Mean Excess")
1999 invisible(list(x = xx, y = yy))
2000 }
2001
2002 "qplot" <-
2003 function(data, xi = 0, trim = NA, threshold = NA, line = TRUE,
2004 labels = TRUE, ...)
2005 {
2006 data <- as.numeric(data)
2007 if(!is.na(threshold)) data <- data[data >= threshold]
2008 if(!is.na(trim)) data <- data[data < trim]
2009 if(xi == 0) {
2010 add <- "Exponential Quantiles"
2011 y <- qexp(ppoints(data))
2012 }
2013 if(xi != 0) {
2014 add <- paste("GPD Quantiles; xi =", xi)
2015 y <- qgpd(ppoints(data), xi = xi)
2016 }
2017 plot(sort(data), y, xlab = "", ylab = "", ...)
2018 if(labels) title(xlab = "Ordered Data", ylab = add)
2019 if(line) abline(lsfit(sort(data), y))
2020 invisible(list(x = sort(data), y = y))
2021 }
2022
2023 "records" <-
2024 function(data, do.plot = TRUE, conf.level = 0.95, ...)
2025 {
2026 data <- as.numeric(data)
2027 record <- cummax(data)
2028 expected <- cumsum(1/(1:length(data)))
2029 se <- sqrt(expected - cumsum(1/((1:length(data))^2)))
2030 trial <- (1:length(data))[!duplicated(record)]
2031 record <- unique(record)
2032 number <- 1:length(record)
2033 expected <- expected[trial]
2034 se <- se[trial]
2035 if(do.plot) {
2036 ci <- qnorm(0.5 + conf.level/2)
2037 upper <- expected + ci * se
2038 lower <- expected - ci * se
2039 lower[lower < 1] <- 1
2040 yr <- range(upper, lower, number)
2041 plot(trial, number, log = "x", ylim = yr, xlab = "Trial",
2042 ylab = "Records", main = "Plot of Record Development", ...)
2043 lines(trial, expected)
2044 lines(trial, upper, lty = 2)
2045 lines(trial, lower, lty = 2)
2046 }
2047 data.frame(number, record, trial, expected, se)
2048 }
2049
2050 "gpd" <-
2051 function(data, threshold = NA, nextremes = NA, method = c("ml","pwm"),
2052 information = c("observed","expected"), ...)
2053 {
2054 data <- as.numeric(data)
2055 n <- length(data)
2056 if(is.na(nextremes) && is.na(threshold))
2057 stop("Enter either a threshold or the number of upper extremes")
2058 if(!is.na(nextremes) && !is.na(threshold))
2059 stop("Enter EITHER a threshold or the number of upper extremes")
2060 if(!is.na(nextremes))
2061 threshold <- findthresh(data, nextremes)
2062 exceedances <- data[data > threshold]
2063 excess <- exceedances - threshold
2064 Nu <- length(excess)
2065 xbar <- mean(excess)
2066 method <- match.arg(method)
2067 if(method == "ml") {
2068 s2 <- var(excess)
2069 xi0 <- -0.5 * (((xbar * xbar)/s2) - 1)
2070 beta0 <- 0.5 * xbar * (((xbar * xbar)/s2) + 1)
2071 theta <- c(xi0, beta0)
2072 negloglik <- function(theta, tmp)
2073 {
2074 xi <- theta[1]
2075 beta <- theta[2]
2076 cond1 <- beta <= 0
2077 cond2 <- (xi <= 0) && (max(tmp) > ( - beta/xi))
2078 if(cond1 || cond2)
2079 f <- 1e+06
2080 else {
2081 y <- logb(1 + (xi * tmp)/beta)
2082 y <- y/xi
2083 f <- length(tmp) * logb(beta) + (1 + xi) * sum(y)
2084 }
2085 f
2086 }
2087 fit <- optim(theta, negloglik, hessian = TRUE, ..., tmp = excess)
2088 if(fit$convergence)
2089 warning("optimization may not have succeeded")
2090 par.ests <- fit$par
2091 converged <- fit$convergence
2092 nllh.final <- fit$value
2093 information <- match.arg(information)
2094 if(information == "observed") varcov <- solve(fit$hessian)
2095 if(information == "expected") {
2096 one <- (1 + par.ests[1])^2 / Nu
2097 two <- (2 * (1 + par.ests[1]) * par.ests[2]^2) / Nu
2098 cov <- - ((1 + par.ests[1]) * par.ests[2]) / Nu
2099 varcov <- matrix(c(one, cov, cov, two), 2)
2100 }
2101 }
2102 if(method == "pwm") {
2103 a0 <- xbar
2104 gamma <- -0.35
2105 delta <- 0
2106 pvec <- ((1:Nu) + delta)/(Nu + delta)
2107 a1 <- mean(sort(excess) * (1 - pvec))
2108 xi <- 2 - a0/(a0 - 2 * a1)
2109 beta <- (2 * a0 * a1)/(a0 - 2 * a1)
2110 par.ests <- c(xi, beta)
2111 denom <- Nu * (1 - 2 * xi) * (3 - 2 * xi)
2112 if(xi > 0.5) {
2113 denom <- NA
2114 warning("Asymptotic standard errors not available for",
2115 "PWM Method when xi > 0.5")
2116 }
2117 one <- (1 - xi) * (1 - xi + 2 * xi^2) * (2 - xi)^2
2118 two <- (7 - 18 * xi + 11 * xi^2 - 2 * xi^3) * beta^2
2119 cov <- beta * (2 - xi) * (2 - 6 * xi + 7 * xi^2 - 2 * xi^3)
2120 varcov <- matrix(c(one, cov, cov, two), 2) / denom
2121 information <- "expected"
2122 converged <- NA
2123 nllh.final <- NA
2124 }
2125 par.ses <- sqrt(diag(varcov))
2126 p.less.thresh <- 1 - Nu/n
2127 out <- list(n = length(data), data = exceedances, threshold =
2128 threshold, p.less.thresh = p.less.thresh, n.exceed = Nu,
2129 method = method, par.ests = par.ests, par.ses = par.ses,
2130 varcov = varcov, information = information, converged =
2131 converged, nllh.final = nllh.final)
2132 names(out$par.ests) <- c("xi", "beta")
2133 names(out$par.ses) <- c("xi", "beta")
2134 class(out) <- "gpd"
2135 out
2136 }
2137
2138 "gpd.q" <-
2139 function(x, pp, ci.type = c("likelihood","wald"), ci.p = 0.95,
2140 like.num = 50)
2141 {
2142 if(x$dist != "gpd")
2143 stop("This function is used only with GPD curves")
2144 if(length(pp) > 1)
2145 stop("One probability at a time please")
2146 threshold <- x$lastfit$threshold
2147 par.ests <- x$lastfit$par.ests
2148 xihat <- par.ests["xi"]
2149 betahat <- par.ests["beta"]
2150 varcov <- x$lastfit$varcov
2151 p.less.thresh <- x$lastfit$p.less.thresh
2152 lambda <- 1
2153 if(x$type == "tail") lambda <- 1/(1 - p.less.thresh)
2154 a <- lambda * (1 - pp)
2155 gfunc <- function(a, xihat) (a^( - xihat) - 1) / xihat
2156 gfunc.deriv <- function(a, xihat)
2157 ( - (a^( - xihat) - 1)/xihat - a^( - xihat) * logb(a)) / xihat
2158 q <- threshold + betahat * gfunc(a, xihat)
2159 if(q < x$plotmax) abline(v = q, lty = 2)
2160 out <- as.numeric(q)
2161 ci.type <- match.arg(ci.type)
2162 if(ci.type == "wald") {
2163 if(class(x$lastfit) != "gpd")
2164 stop("Wald method requires model be fitted with gpd (not pot)")
2165 scaling <- threshold
2166 betahat <- betahat/scaling
2167 xivar <- varcov[1, 1]
2168 betavar <- varcov[2, 2]/(scaling^2)
2169 covar <- varcov[1, 2]/scaling
2170 term1 <- betavar * (gfunc(a, xihat))^2
2171 term2 <- xivar * (betahat^2) * (gfunc.deriv(a, xihat))^2
2172 term3 <- 2 * covar * betavar * gfunc(a, xihat) * gfunc.deriv(a, xihat)
2173 qvar <- term1 + term2 + term3
2174 if(qvar < 0) stop("Negative estimate of quantile variance")
2175 qse <- scaling * sqrt(qvar)
2176 qq <- qnorm(1 - (1 - ci.p)/2)
2177 upper <- q + qse * qq
2178 lower <- q - qse * qq
2179 if(upper < x$plotmax) abline(v = upper, lty = 2, col = 2)
2180 if(lower < x$plotmax) abline(v = lower, lty = 2, col = 2)
2181 out <- as.numeric(c(lower, q, qse, upper))
2182 names(out) <- c("Lower CI", "Estimate", "Std.Err", "Upper CI")
2183 }
2184 if(ci.type == "likelihood") {
2185 parloglik <- function(theta, tmp, a, threshold, xpi)
2186 {
2187 beta <- (theta * (xpi - threshold))/(a^( - theta) - 1)
2188 if((beta <= 0) || ((theta <= 0) && (max(tmp) > ( - beta/theta))))
2189 f <- 1e+06
2190 else {
2191 y <- logb(1 + (theta * tmp)/beta)
2192 y <- y/theta
2193 f <- length(tmp) * logb(beta) + (1 + theta) * sum(y)
2194 }
2195 f
2196 }
2197 theta <- xihat
2198 parmax <- NULL
2199 xp <- exp(seq(from = logb(threshold), to = logb(x$plotmax),
2200 length = like.num))
2201 excess <- as.numeric(x$lastfit$data - threshold)
2202 for(i in 1:length(xp)) {
2203 fit2 <- optim(theta, parloglik, method = "BFGS", hessian = FALSE,
2204 tmp = excess, a = a, threshold = threshold, xpi = xp[i])
2205 parmax <- rbind(parmax, fit2$value)
2206 }
2207 parmax <- - parmax
2208 overallmax <- - parloglik(xihat, excess, a, threshold, q)
2209 crit <- overallmax - qchisq(0.999, 1)/2
2210 cond <- parmax > crit
2211 xp <- xp[cond]
2212 parmax <- parmax[cond]
2213 par(new = TRUE)
2214 dolog <- ""
2215 if(x$alog == "xy" || x$alog == "x") dolog <- "x"
2216 plot(xp, parmax, type = "n", xlab = "", ylab = "", axes = FALSE,
2217 xlim = range(x$plotmin, x$plotmax),
2218 ylim = range(overallmax, crit), log = dolog)
2219 axis(4, at = overallmax - qchisq(c(0.95, 0.99), 1)/2,
2220 labels = c("95", "99"), tick = TRUE)
2221 aalpha <- qchisq(ci.p, 1)
2222 abline(h = overallmax - aalpha/2, lty = 2, col = 2)
2223 cond <- !is.na(xp) & !is.na(parmax)
2224 smth <- spline(xp[cond], parmax[cond], n = 200)
2225 lines(smth, lty = 2, col = 2)
2226 ci <- smth$x[smth$y > overallmax - aalpha/2]
2227 out <- c(min(ci), q, max(ci))
2228 names(out) <- c("Lower CI", "Estimate", "Upper CI")
2229 }
2230 out
2231 }
2232
2233 "gpd.sfall" <-
2234 function(x, pp, ci.p = 0.95, like.num = 50)
2235 {
2236 if(x$dist != "gpd")
2237 stop("This function is used only with GPD curves")
2238 if(length(pp) > 1)
2239 stop("One probability at a time please")
2240 threshold <- x$lastfit$threshold
2241 par.ests <- x$lastfit$par.ests
2242 xihat <- par.ests["xi"]
2243 betahat <- par.ests["beta"]
2244 varcov <- x$lastfit$varcov
2245 p.less.thresh <- x$lastfit$p.less.thresh
2246 lambda <- 1
2247 if(x$type == "tail") lambda <- 1/(1 - p.less.thresh)
2248 a <- lambda * (1 - pp)
2249 gfunc <- function(a, xihat) (a^( - xihat) - 1) / xihat
2250 q <- threshold + betahat * gfunc(a, xihat)
2251 s <- q + (betahat + xihat * (q - threshold))/(1 - xihat)
2252 if(s < x$plotmax) abline(v = s, lty = 2)
2253 out <- as.numeric(s)
2254 parloglik <- function(theta, tmp, a, threshold, xpi)
2255 {
2256 beta <- ((1 - theta) * (xpi - threshold)) /
2257 (((a^( - theta) - 1)/theta) + 1)
2258 if((beta <= 0) || ((theta <= 0) && (max(tmp) > ( - beta/theta))))
2259 f <- 1e+06
2260 else {
2261 y <- logb(1 + (theta * tmp)/beta)
2262 y <- y/theta
2263 f <- length(tmp) * logb(beta) + (1 + theta) * sum(y)
2264 }
2265 f
2266 }
2267 theta <- xihat
2268 parmax <- NULL
2269 xp <- exp(seq(from = logb(threshold), to = logb(x$plotmax),
2270 length = like.num))
2271 excess <- as.numeric(x$lastfit$data - threshold)
2272 for(i in 1:length(xp)) {
2273 fit2 <- optim(theta, parloglik, method = "BFGS", hessian = FALSE,
2274 tmp = excess, a = a, threshold = threshold, xpi = xp[i])
2275 parmax <- rbind(parmax, fit2$value)
2276 }
2277 parmax <- - parmax
2278 overallmax <- - parloglik(xihat, excess, a, threshold, s)
2279 crit <- overallmax - qchisq(0.999, 1)/2
2280 cond <- parmax > crit
2281 xp <- xp[cond]
2282 parmax <- parmax[cond]
2283 par(new = TRUE)
2284 dolog <- ""
2285 if(x$alog == "xy" || x$alog == "x") dolog <- "x"
2286 plot(xp, parmax, type = "n", xlab = "", ylab = "", axes = FALSE, xlim =
2287 range(x$plotmin, x$plotmax), ylim =
2288 range(overallmax, crit), log = dolog)
2289 axis(4, at = overallmax - qchisq(c(0.95, 0.99), 1)/2,
2290 labels = c("95", "99"), tick = TRUE)
2291 aalpha <- qchisq(ci.p, 1)
2292 abline(h = overallmax - aalpha/2, lty = 2, col = 2)
2293 cond <- !is.na(xp) & !is.na(parmax)
2294 smth <- spline(xp[cond], parmax[cond], n = 200)
2295 lines(smth, lty = 2, col = 2)
2296 ci <- smth$x[smth$y > overallmax - aalpha/2]
2297 out <- c(min(ci), s, max(ci))
2298 names(out) <- c("Lower CI", "Estimate", "Upper CI")
2299 out
2300 }
2301
2302 "plot.gpd" <-
2303 function(x, optlog = NA, extend = 1.5, labels = TRUE, ...)
2304 {
2305 data <- as.numeric(x$data)
2306 threshold <- x$threshold
2307 xi <- x$par.ests["xi"]
2308 beta <- x$par.ests["beta"]
2309 choices <- c("Excess Distribution", "Tail of Underlying Distribution",
2310 "Scatterplot of Residuals", "QQplot of Residuals")
2311 tmenu <- paste("plot:", choices)
2312 pick <- 1
2313 lastcurve <- NULL
2314 while(pick > 0) {
2315 pick <- menu(tmenu, title =
2316 "\nMake a plot selection (or 0 to exit):")
2317 if(pick >= 3) {
2318 excess <- data - threshold
2319 res <- logb(1 + (xi * excess)/beta) / xi
2320 lastcurve <- NULL
2321 }
2322 if(pick == 3) {
2323 plot(res, ylab = "Residuals", xlab = "Ordering", ...)
2324 lines(lowess(1:length(res), res))
2325 }
2326 if(pick == 4) qplot(res, ...)
2327 if(pick == 1 || pick == 2) {
2328 plotmin <- threshold
2329 if(extend <= 1) stop("extend must be > 1")
2330 plotmax <- max(data) * extend
2331 xx <- seq(from = 0, to = 1, length = 1000)
2332 z <- qgpd(xx, xi, threshold, beta)
2333 z <- pmax(pmin(z, plotmax), plotmin)
2334 ypoints <- ppoints(sort(data))
2335 y <- pgpd(z, xi, threshold, beta)
2336 }
2337 if(pick == 1) {
2338 type <- "eplot"
2339 if(!is.na(optlog))
2340 alog <- optlog
2341 else alog <- "x"
2342 if(alog == "xy")
2343 stop("Double log plot of Fu(x-u) does\nnot make much sense")
2344 yylab <- "Fu(x-u)"
2345 shape <- xi
2346 scale <- beta
2347 location <- threshold
2348 }
2349 if(pick == 2) {
2350 type <- "tail"
2351 if(!is.na(optlog))
2352 alog <- optlog
2353 else alog <- "xy"
2354 prob <- x$p.less.thresh
2355 ypoints <- (1 - prob) * (1 - ypoints)
2356 y <- (1 - prob) * (1 - y)
2357 yylab <- "1-F(x)"
2358 shape <- xi
2359 scale <- beta * (1 - prob)^xi
2360 location <- threshold - (scale * ((1 - prob)^( - xi) - 1))/xi
2361 }
2362 if(pick == 1 || pick == 2) {
2363 plot(sort(data), ypoints, xlim = range(plotmin, plotmax),
2364 ylim = range(ypoints, y, na.rm = TRUE), xlab = "",
2365 ylab = "", log = alog, axes = TRUE, ...)
2366 lines(z[y >= 0], y[y >= 0])
2367 if(labels) {
2368 xxlab <- "x"
2369 if(alog == "x" || alog == "xy" || alog == "yx")
2370 xxlab <- paste(xxlab, "(on log scale)")
2371 if(alog == "xy" || alog == "yx" || alog == "y")
2372 yylab <- paste(yylab, "(on log scale)")
2373 title(xlab = xxlab, ylab = yylab)
2374 }
2375 details <- paste("threshold = ", format(signif(threshold, 3)),
2376 " xi = ", format(signif(shape, 3)),
2377 " scale = ", format(signif(scale, 3)),
2378 " location = ", format(signif(location, 3)),
2379 sep = "")
2380 print(details)
2381 lastcurve <- list(lastfit = x, type = type, dist = "gpd",
2382 plotmin = plotmin, plotmax = plotmax, alog = alog,
2383 location = as.numeric(location), shape = as.numeric(shape),
2384 scale = as.numeric(scale))
2385 }
2386 }
2387 invisible(lastcurve)
2388 }
2389
2390 "quant" <-
2391 function(data, p = 0.99, models = 30, start = 15, end = 500,
2392 reverse = TRUE, ci = 0.95, auto.scale = TRUE, labels = TRUE,
2393 ...)
2394 {
2395 data <- as.numeric(data)
2396 n <- length(data)
2397 if(ci) qq <- qnorm(1 - (1 - ci)/2)
2398 exceed <- trunc(seq(from = min(end, n), to = start, length = models))
2399 if(p < 1 - min(exceed)/n) {
2400 cat("Graph may look strange !! \n\n")
2401 cat(paste("Suggestion 1: Increase `p' above",
2402 format(signif(1 - min(exceed)/n, 5)), "\n"))
2403 cat(paste("Suggestion 2: Increase `start' above ",
2404 ceiling(length(data) * (1 - p)), "\n"))
2405 }
2406 gpd.dummy <- function(nex, data)
2407 {
2408 out <- gpd(data = data, nex = nex, information = "expected")
2409 c(out$threshold, out$par.ests[1], out$par.ests[2],
2410 out$varcov[1, 1], out$varcov[2, 2], out$varcov[1, 2])
2411 }
2412 mat <- apply(as.matrix(exceed), 1, gpd.dummy, data = data)
2413 thresh <- mat[1, ]
2414 xihat <- mat[2, ]
2415 betahat <- mat[3, ]
2416 lambda <- length(data)/exceed
2417 a <- lambda * (1 - p)
2418 gfunc <- function(a, xihat) (a^( - xihat) - 1) / xihat
2419 qest <- thresh + betahat * gfunc(a, xihat)
2420 l <- u <- qest
2421 yrange <- range(qest)
2422 if(ci) {
2423 xivar <- mat[4, ]
2424 betavar <- mat[5, ]
2425 covar <- mat[6, ]
2426 scaling <- thresh
2427 betahat <- betahat/scaling
2428 betavar <- betavar/(scaling^2)
2429 covar <- covar/scaling
2430 gfunc.deriv <- function(a, xihat)
2431 ( - (a^( - xihat) - 1)/xihat - a^( - xihat) * logb(a)) / xihat
2432 term1 <- betavar * (gfunc(a, xihat))^2
2433 term2 <- xivar * (betahat^2) * (gfunc.deriv(a, xihat))^2
2434 term3 <- 2 * covar * betavar * gfunc(a, xihat) * gfunc.deriv(a, xihat)
2435 qvar <- term1 + term2 + term3
2436 if(min(qvar) < 0)
2437 stop(paste("Conditioning problems lead to estimated negative",
2438 "quantile variance", sep = "\n"))
2439 qse <- scaling * sqrt(qvar)
2440 u <- qest + qse * qq
2441 l <- qest - qse * qq
2442 yrange <- range(qest, u, l)
2443 }
2444 mat <- rbind(thresh, qest, exceed, l, u)
2445 dimnames(mat) <- list(c("threshold", "qest", "exceedances", "lower",
2446 "upper"), NULL)
2447 index <- exceed
2448 if(reverse) index <- - exceed
2449 if(auto.scale)
2450 plot(index, qest, ylim = yrange, type = "l", xlab = "", ylab = "",
2451 axes = FALSE, ...)
2452 else plot(index, qest, type = "l", xlab = "", ylab = "",
2453 axes = FALSE, ...)
2454 axis(1, at = index, lab = paste(exceed))
2455 axis(2)
2456 axis(3, at = index, lab = paste(format(signif(thresh, 3))))
2457 box()
2458 if(ci) {
2459 lines(index, l, lty = 2, col = 2)
2460 lines(index, u, lty = 2, col = 2)
2461 }
2462 if(labels) {
2463 labely <- paste(p, "Quantile")
2464 if(ci) labely <- paste(labely, " (CI, p = ", ci, ")", sep = "")
2465 title(xlab = "Exceedances", ylab = labely)
2466 mtext("Threshold", side = 3, line = 3)
2467 }
2468 invisible(mat)
2469 }
2470
2471 "riskmeasures" <-
2472 function(x, p)
2473 {
2474 u <- x$threshold
2475 par.ests <- x$par.ests
2476 xihat <- par.ests["xi"]
2477 betahat <- par.ests["beta"]
2478 p.less.thresh <- x$p.less.thresh
2479 lambda <- 1/(1 - p.less.thresh)
2480 quant <- function(pp, xi, beta, u, lambda)
2481 {
2482 a <- lambda * (1 - pp)
2483 u + (beta * (a^( - xi) - 1))/xi
2484 }
2485 short <- function(pp, xi, beta, u, lambda)
2486 {
2487 a <- lambda * (1 - pp)
2488 q <- u + (beta * (a^( - xi) - 1))/xi
2489 (q * (1 + (beta - xi * u)/q)) / (1 - xi)
2490 }
2491 q <- quant(p, xihat, betahat, u, lambda)
2492 es <- short(p, xihat, betahat, u, lambda)
2493 rtn <- cbind(p, quantile = q, sfall = es)
2494 row.names(rtn) <- NULL
2495 rtn
2496 }
2497
2498 "shape" <-
2499 function(data, models = 30, start = 15, end = 500, reverse = TRUE, ci =
2500 0.95, auto.scale = TRUE, labels = TRUE, ...)
2501 {
2502 data <- as.numeric(data)
2503 qq <- 0
2504 if(ci) qq <- qnorm(1 - (1 - ci)/2)
2505 x <- trunc(seq(from = min(end, length(data)), to = start, length = models))
2506 gpd.dummy <- function(nex, data)
2507 {
2508 out <- gpd(data = data, nex = nex, information = "expected")
2509 c(out$threshold, out$par.ests[1], out$par.ses[1])
2510 }
2511 mat <- apply(as.matrix(x), 1, gpd.dummy, data = data)
2512 mat <- rbind(mat, x)
2513 dimnames(mat) <- list(c("threshold", "shape", "se", "exceedances"), NULL)
2514 thresh <- mat[1, ]
2515 y <- mat[2, ]
2516 yrange <- range(y)
2517 if(ci) {
2518 u <- y + mat[3, ] * qq
2519 l <- y - mat[3, ] * qq
2520 yrange <- range(y, u, l)
2521 }
2522 index <- x
2523 if(reverse) index <- - x
2524 if(auto.scale)
2525 plot(index, y, ylim = yrange, type = "l", xlab = "", ylab = "",
2526 axes = FALSE, ...)
2527 else plot(index, y, type = "l", xlab = "", ylab = "", axes = FALSE, ...)
2528 axis(1, at = index, lab = paste(x), tick = FALSE)
2529 axis(2)
2530 axis(3, at = index, lab = paste(format(signif(thresh, 3))), tick = FALSE)
2531 box()
2532 if(ci) {
2533 lines(index, u, lty = 2, col = 2)
2534 lines(index, l, lty = 2, col = 2)
2535 }
2536 if(labels) {
2537 labely <- "Shape (xi)"
2538 if(ci) labely <- paste(labely, " (CI, p = ", ci, ")", sep = "")
2539 title(xlab = "Exceedances", ylab = labely)
2540 mtext("Threshold", side = 3, line = 3)
2541 }
2542 invisible(mat)
2543 }
2544
2545 "tailplot" <-
2546 function(x, optlog = NA, extend = 1.5, labels = TRUE, ...)
2547 {
2548 data <- as.numeric(x$data)
2549 threshold <- x$threshold
2550 xi <- x$par.ests["xi"]
2551 beta <- x$par.ests["beta"]
2552 plotmin <- threshold
2553 if(extend <= 1) stop("extend must be > 1")
2554 plotmax <- max(data) * extend
2555 xx <- seq(from = 0, to = 1, length = 1000)
2556 z <- qgpd(xx, xi, threshold, beta)
2557 z <- pmax(pmin(z, plotmax), plotmin)
2558 ypoints <- ppoints(sort(data))
2559 y <- pgpd(z, xi, threshold, beta)
2560 type <- "tail"
2561 if(!is.na(optlog))
2562 alog <- optlog
2563 else alog <- "xy"
2564 prob <- x$p.less.thresh
2565 ypoints <- (1 - prob) * (1 - ypoints)
2566 y <- (1 - prob) * (1 - y)
2567 yylab <- "1-F(x)"
2568 shape <- xi
2569 scale <- beta * (1 - prob)^xi
2570 location <- threshold - (scale * ((1 - prob)^( - xi) - 1))/xi
2571 plot(sort(data), ypoints, xlim = range(plotmin, plotmax), ylim =
2572 range(ypoints, y, na.rm = TRUE), xlab = "", ylab = "", log = alog,
2573 axes = TRUE, ...)
2574 lines(z[y >= 0], y[y >= 0])
2575 if(labels) {
2576 xxlab <- "x"
2577 if(alog == "x" || alog == "xy" || alog == "yx")
2578 xxlab <- paste(xxlab, "(on log scale)")
2579 if(alog == "xy" || alog == "yx" || alog == "y")
2580 yylab <- paste(yylab, "(on log scale)")
2581 title(xlab = xxlab, ylab = yylab)
2582 }
2583 lastcurve <- list(lastfit = x, type = type, dist = "gpd",
2584 plotmin = plotmin, plotmax = plotmax, alog = alog, location =
2585 as.numeric(location), shape = as.numeric(shape), scale =
2586 as.numeric(scale))
2587 invisible(lastcurve)
2588 }
2589
2590 "plot.pot" <-
2591 function(x, ...)
2592 {
2593 rawdata <- x$data
2594 n <- length(as.numeric(rawdata))
2595 times <- attributes(rawdata)$times
2596 if(is.character(times) || inherits(times, "POSIXt") ||
2597 inherits(x, "date") || inherits(x, "dates")) {
2598 times <- as.POSIXlt(times)
2599 gaps <- as.numeric(difftime(times[2:n], times[1:(n-1)],
2600 units = "days")) * x$intensity
2601 }
2602 else gaps <- as.numeric(diff(times)) * x$intensity
2603 data <- as.numeric(rawdata)
2604 threshold <- x$threshold
2605 par.ests <- x$par.ests
2606 xi <- par.ests[1]
2607 beta <- par.ests[4]
2608 residuals <- logb(1 + (xi * (data - threshold))/beta)/xi
2609 choices <- c("Point Process of Exceedances", "Scatterplot of Gaps",
2610 "Qplot of Gaps", "ACF of Gaps", "Scatterplot of Residuals",
2611 "Qplot of Residuals", "ACF of Residuals", "Go to GPD Plots")
2612 tmenu <- paste("plot:", choices)
2613 pick <- 1
2614 lastcurve <- NULL
2615 while(pick > 0) {
2616 pick <- menu(tmenu, title =
2617 "\nMake a plot selection (or 0 to exit):")
2618 if(pick %in% c(4,7)) require("ts", quietly = TRUE)
2619 if(pick %in% 1:7) lastcurve <- NULL
2620 switch(pick,
2621 {
2622 plot(times, rawdata, type = "h", sub = paste("Point process of",
2623 length(as.numeric(rawdata)), "exceedances of threshold",
2624 format(signif(threshold, 3))), ...)
2625 },
2626 {
2627 plot(gaps, ylab = "Gaps", xlab = "Ordering", ...)
2628 lines(lowess(1:length(gaps), gaps))
2629 },
2630 qplot(gaps, ...),
2631 acf(gaps, lag.max = 20, ...),
2632 {
2633 plot(residuals, ylab = "Residuals", xlab = "Ordering", ...)
2634 lines(lowess(1:length(residuals), residuals))
2635 },
2636 qplot(residuals, ...),
2637 acf(residuals, lag.max = 20, ...),
2638 lastcurve <- plot.gpd(x, ...))
2639 }
2640 invisible(lastcurve)
2641 }
2642
2643 "pot" <-
2644 function(data, threshold = NA, nextremes = NA, run = NA,
2645 picture = TRUE, ...)
2646 {
2647 n <- length(as.numeric(data))
2648 times <- attributes(data)$times
2649 if(is.null(times)) {
2650 times <- 1:n
2651 attributes(data)$times <- times
2652 start <- 1
2653 end <- n
2654 span <- end - start
2655 }
2656 else {
2657 start <- times[1]
2658 end <- times[n]
2659 span <- as.numeric(difftime(as.POSIXlt(times)[n],
2660 as.POSIXlt(times)[1], units = "days"))
2661 }
2662
2663 if(is.na(nextremes) && is.na(threshold))
2664 stop("Enter either a threshold or the number of upper extremes")
2665 if(!is.na(nextremes) && !is.na(threshold))
2666 stop("Enter EITHER a threshold or the number of upper extremes")
2667 if(!is.na(nextremes))
2668 threshold <- findthresh(as.numeric(data), nextremes)
2669 if(threshold > 10) {
2670 factor <- 10^(floor(log10(threshold)))
2671 cat(paste("If singularity problems occur divide data",
2672 "by a factor, perhaps", factor, "\n"))
2673 }
2674 exceedances.its <- structure(data[data > threshold], times =
2675 times[data > threshold])
2676 n.exceed <- length(as.numeric(exceedances.its))
2677 p.less.thresh <- 1 - n.exceed/n
2678 if(!is.na(run)) {
2679 exceedances.its <- decluster(exceedances.its, run, picture)
2680 n.exceed <- length(exceedances.its)
2681 }
2682 intensity <- n.exceed/span
2683 exceedances <- as.numeric(exceedances.its)
2684 xbar <- mean(exceedances) - threshold
2685 s2 <- var(exceedances)
2686 shape0 <- -0.5 * (((xbar * xbar)/s2) - 1)
2687 extra <- ((length(exceedances)/span)^( - shape0) - 1)/shape0
2688 betahat <- 0.5 * xbar * (((xbar * xbar)/s2) + 1)
2689 scale0 <- betahat/(1 + shape0 * extra)
2690 loc0 <- 0
2691 theta <- c(shape0, scale0, loc0)
2692 negloglik <- function(theta, exceedances, threshold, span)
2693 {
2694 if((theta[2] <= 0) || (min(1 + (theta[1] * (exceedances -
2695 theta[3])) / theta[2]) <= 0))
2696 f <- 1e+06
2697 else {
2698 y <- logb(1 + (theta[1] * (exceedances - theta[3])) / theta[2])
2699 term3 <- (1/theta[1] + 1) * sum(y)
2700 term1 <- span * (1 + (theta[1] * (threshold - theta[3])) /
2701 theta[2])^(-1/theta[1])
2702 term2 <- length(y) * logb(theta[2])
2703 f <- term1 + term2 + term3
2704 }
2705 f
2706 }
2707 fit <- optim(theta, negloglik, hessian = TRUE, ..., exceedances =
2708 exceedances, threshold = threshold, span = span)
2709 if(fit$convergence)
2710 warning("optimization may not have succeeded")
2711 par.ests <- fit$par
2712 varcov <- solve(fit$hessian)
2713 par.ses <- sqrt(diag(varcov))
2714 beta <- par.ests[2] + par.ests[1] * (threshold - par.ests[3])
2715 par.ests <- c(par.ests, beta)
2716 out <- list(n = length(data), period = c(start, end), data =
2717 exceedances.its, span = span, threshold = threshold,
2718 p.less.thresh = p.less.thresh, n.exceed = n.exceed, run = run,
2719 par.ests = par.ests, par.ses = par.ses, varcov = varcov,
2720 intensity = intensity, nllh.final = fit$value, converged
2721 = fit$convergence)
2722 names(out$par.ests) <- c("xi", "sigma", "mu", "beta")
2723 names(out$par.ses) <- c("xi", "sigma", "mu")
2724 class(out) <- "pot"
2725 out
2726 }
2727
2728 "decluster" <-
2729 function(series, run = NA, picture = TRUE)
2730 {
2731 n <- length(as.numeric(series))
2732 times <- attributes(series)$times
2733 if(is.null(times)) stop("`series' must have a `times' attribute")
2734 as.posix <- is.character(times) || inherits(times, "POSIXt") ||
2735 inherits(times, "date") || inherits(times, "dates")
2736 if(as.posix)
2737 gaps <- as.numeric(difftime(as.POSIXlt(times)[2:n],
2738 as.POSIXlt(times)[1:(n-1)], units = "days"))
2739 else gaps <- as.numeric(diff(times))
2740 longgaps <- gaps > run
2741 if(sum(longgaps) <= 1)
2742 stop("Decluster parameter too large")
2743 cluster <- c(0, cumsum(longgaps))
2744 cmax <- tapply(as.numeric(series), cluster, max)
2745 newtimes <- times[match(cmax, series)]
2746 newseries <- structure(series[match(cmax, series)], times = newtimes)
2747 n <- length(as.numeric(newseries))
2748
2749 if(as.posix) {
2750 newgaps <- as.numeric(difftime(as.POSIXlt(newtimes)[2:n],
2751 as.POSIXlt(newtimes)[1:(n-1)], units = "days"))
2752 times <- as.POSIXlt(times)
2753 newtimes <- as.POSIXlt(newtimes)
2754 }
2755 else newgaps <- as.numeric(diff(newtimes))
2756
2757 if(picture) {
2758 cat("Declustering picture...\n")
2759 cat(paste("Data reduced from", length(as.numeric(series)),
2760 "to", length(as.numeric(newseries)), "\n"))
2761 par(mfrow = c(2, 2))
2762 plot(times, series, type = "h")
2763 qplot(gaps)
2764 plot(newtimes, newseries, type = "h")
2765 qplot(newgaps)
2766 par(mfrow = c(1, 1))
2767 }
2768 newseries
2769 }
2770
2771 "findthresh" <-
2772 function(data, ne)
2773 {
2774 data <- rev(sort(as.numeric(data)))
2775 thresholds <- unique(data)
2776 indices <- match(data[ne], thresholds)
2777 indices <- pmin(indices + 1, length(thresholds))
2778 thresholds[indices]
2779 }
2780
2781
2782 ################################################################################
2783
+128
-0
R/057A-ExtremesTools.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: DESCRIPTION:
31 # xmpExtremes Sets Prompt
32 # xmpfExtremes Popups the example menu
33 ################################################################################
34
35
36 xmpExtremes =
37 function(prompt = "")
38 { # A function implemented by Diethelm WUertz
39
40 # Description:
41 # Sets prompt
42
43 # FUNCTION:
44
45 # Return Value:
46 invisible(prompt)
47 }
48
49
50 # ------------------------------------------------------------------------------
51
52
53 xmpfExtremes =
54 function()
55 { # A function implemented by Diethelm WUertz
56
57 # Description:
58 # Popups the example menu
59
60 # FUNCTION:
61
62 # Popup:
63 path = paste(.Library,"/fExtremes", sep = "")
64 entries = .read.fExtremes.00Index (file.path(path, "demoIndex"))
65 example = select.list(entries[,1])
66 selected = 0
67 for (i in 1:length(entries[,1])) {
68 if (example == entries[i,1]) selected = i
69 }
70 if (example == "") {
71 cat("\nNo demo selected\n")
72 } else {
73 cat("\nLibrary: ", "fExtremes", "\nExample: ",
74 entries[selected, 1], "\nTitle: ", entries[selected, 2], "\n")
75 source(paste(path, "/demo/", example, ".R", sep = ""))
76 }
77 if(TRUE) {
78 cat("\n")
79 }
80
81 # Return Value:
82 invisible()
83 }
84
85
86 # ------------------------------------------------------------------------------
87
88
89 .read.fExtremes.00Index =
90 function (file)
91 {
92 if (is.character(file)) {
93 if (file == "") {
94 file <- stdin()
95 } else {
96 file <- file(file, "r")
97 on.exit(close(file))
98 }
99 }
100 if (!inherits(file, "connection"))
101 stop(paste("argument",
102 sQuote("file"), "must be a character string or connection"))
103 y <- matrix("", nr = 0, nc = 2)
104 x <- paste(readLines(file), collapse = "\n")
105 for (chunk in unlist(strsplit(x, "\n[ \n]*\n"))) {
106 entries <- try({
107 if (regexpr("( | )", chunk) == -1)
108 NULL
109 else {
110 chunk <- gsub("\n[ ]+", " ", chunk)
111 x <- strsplit(unlist(strsplit(chunk, "\n")), "[ ]")
112 cbind(unlist(lapply(x, "[[", 1)), unlist(lapply(x,
113 function(t) {
114 paste(t[-c(1, which(nchar(t) == 0))], collapse = " ")
115 })))
116 }
117 })
118 if (!inherits(entries, "try-error") && NCOL(entries) == 2)
119 y <- rbind(y, entries)
120 }
121 colnames(y) <- c("Item", "Description")
122 y
123 }
124
125
126 ################################################################################
127
+0
-1092
R/51A-ExtremesData.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION PART I: Explorative Data Analysis
31 # emdPlot Plots empirical distribution function
32 # qqPlot Creates a quantile-quantile plot
33 # qqbayesPlot Creates qq-Plot with 95 percent intervals
34 # qPlot Creates exploratory QQ plot for EV analysis
35 # mePlot Creates a sample mean excess plot
36 # mxfPlot Plots the mean excess function
37 # mrlPlot Returns a mean residual life plot with confidence levels
38 # recordsPlot Plots records development
39 # ssrecordsPlot Plots records development of data subsamples
40 # msratioPlot Plots ratio of maximums and sums
41 # xacfPlot Plots autocorrelations of exceedences
42 # interactivePlot Plots several graphs interactively
43 # gridVector Creates from two vectors rectangular grid points
44 ################################################################################
45
46
47 ################################################################################
48 # FUNCTION PART II: Data Preprocessing:
49 # findThreshold Finds extreme values above a threshold
50 # blocks Creates data blocks on vectors and time series
51 # blockMaxima Calculates block maxima on vectors and time series
52 # deCluster Declusters a point process
53 ################################################################################
54
55
56 # PART I:
57
58
59 emdPlot =
60 function(x, doplot = TRUE, plottype = c("", "x", "y", "xy"),
61 labels = TRUE, ...)
62 { # A function imported from R-package evir
63
64 # Description:
65 # Plots empirical distribution function
66
67 # Arguments:
68 # plottype - which axes should be on a log scale:
69 # "x" denotes x-axis only; "y" denotes y-axis only,
70 # "xy" || "yx" both axes, "" denotes neither of the
71 # axis
72
73 # FUNCTION:
74
75 # Settings:
76 alog = plottype[1]
77
78 # Convert from univariate 'timSeries':
79 if (is.timeSeries(x)) x = as.vector(x)
80
81 # Convert x to a vector, if the input is a data.frame.
82 if (is.data.frame(x)) x = x[,1]
83 xs = x = sort(as.numeric(x))
84 ys = y = 1 - ppoints(x)
85
86 if (plottype == "x") {
87 xs = x[x > 0]
88 ys = y[x > 0] }
89 if (plottype == "y") {
90 xs = x[y > 0]
91 ys = y[y > 0] }
92 if (plottype == "xy") {
93 xs = x[x > 0 & y > 0]
94 ys = y[x > 0 & y > 0] }
95
96 # Plot:
97 if (doplot) {
98 if (labels) {
99 xlab = "x"
100 ylab = "1-F(x)"
101 main = "Empirical Distribution" }
102 else {
103 xlab = ""
104 ylab = ""
105 main = "" }
106 plot(xs, ys, log = alog, xlab = xlab, ylab = ylab, main = main, ...)
107 if (labels) grid()
108 }
109
110 # Result:
111 result = data.frame(x, y)
112
113 # Return Value:
114 if (doplot) return(invisible(result)) else return(result)
115 }
116
117
118 # ------------------------------------------------------------------------------
119
120
121 qqPlot =
122 function (x, doplot = TRUE, labels = TRUE, ...)
123 { # A function written by Diethelm Wuertz
124
125 # Description:
126 # Creates Quantile-Quantile Plot
127
128 # FUNCTION:
129
130 # Convert from univariate 'timSeries':
131 if (is.timeSeries(x)) x = as.vector(x)
132
133 # Convert x to a vector, if the input is a data.frame.
134 if (is.data.frame(x)) x = x[, 1]
135
136 # Plot:
137 if (doplot) {
138 if (labels) {
139 xlab = "Normal Quantiles"
140 ylab = "Empirical Quantiles"
141 main = "Normal QQ-Plot"
142 print(main) }
143 else {
144 xlab = ""
145 ylab = ""
146 main = "" }
147 qqnorm(x, xlab = xlab, ylab = ylab, main = main, ...)
148 qqline(x)
149 if (labels) grid()
150 }
151
152 # Return Value:
153 if (doplot) return(invisible(x)) else return(x)
154 }
155
156
157 # ------------------------------------------------------------------------------
158
159
160 qqbayesPlot =
161 function(x, doplot = TRUE, labels = TRUE, ...)
162 { # A function implemented by Diethelm Wuertz
163
164 # Description:
165 # Example of a Normal quantile plot of data x to provide a visual
166 # assessment of its conformity with a normal (data is standardised
167 # first).
168
169 # Details:
170 # The ordered data values are posterior point estimates of the
171 # underlying quantile function. So, if you plot the ordered data
172 # values (y-axis) against the exact theoretical quantiles (x-axis),
173 # you get a scatter that should be close to a straight line if the
174 # data look like a random sample from the theoretical distribution.
175 # This function chooses the normal as the theory, to provide a
176 # graphical/visual assessment of how normal the data appear.
177 # To help with assessing the relevance of sampling variability on
178 # just "how close" to the normal the data appears, we add (very)
179 # approximate posterior 95% intervals for the uncertain quantile
180 # function at each point (Based on approximate theory) .
181
182 # Author:
183 # Prof. Mike West, mw@stat.duke.edu
184
185 # Note:
186 # Source from
187 # http://www.stat.duke.edu/courses/Fall99/sta290/Notes/
188
189 # FUNCTION:
190
191 # Convert from univariate 'timSeries':
192 if (is.timeSeries(x)) x = as.vector(x)
193
194 # Settings:
195 mydata = x
196 n = length(mydata)
197 p = (1:n)/(n+1)
198 x = (mydata-mean(mydata))/sqrt(var(mydata))
199 x = sort(x)
200 z = qnorm(p)
201
202 # Plot:
203 if (doplot) {
204 if (labels) {
205 xlab = "Standard Normal Quantiles"
206 ylab = "Ordered Data"
207 main = "Normal QQ-Plot with 95% Intervals" }
208 else {
209 xlab = ""
210 ylab = ""
211 main = "" }
212 plot(z, x, xlab = xlab, ylab = ylab, main = main, ...)
213 abline(0, 1, col = "steelblue")
214 if (labels) grid()
215 }
216
217 # 95% Intervals:
218 s = 1.96*sqrt(p*(1-p)/n)
219 pl = p-s; i = pl<1&pl>0
220 lower = quantile(x, probs = pl[i])
221 if (doplot) lines(z[i], lower, col = 3)
222 pl = p+s; i = pl < 1 & pl > 0
223 upper = quantile(x, probs = pl[i])
224 if (doplot) lines(z[i], upper, col = 3)
225
226 # Result:
227 result = data.frame(lower, upper)
228
229 # Return Value:
230 if (doplot) return(invisible(result)) else return(result)
231 }
232
233
234 # ------------------------------------------------------------------------------
235
236
237 qPlot =
238 function(x, xi = 0, trim = NA, threshold = NA, doplot = TRUE,
239 labels = TRUE, ...)
240 { # A function imported from R-package evir
241
242 # Description:
243 # Creates an exploratory QQplot for Extreme Value Analysis.
244
245 # FUNCTION:
246
247 # Convert from univariate 'timSeries':
248 if (is.timeSeries(x)) x = as.vector(x)
249
250 # Settings:
251 line = TRUE
252
253 # Convert x to a vector, if the input is a data.frame.
254 if(is.data.frame(x)) x = x[,1]
255 x = as.numeric(x)
256 if (!is.na(threshold)) x = x[x >= threshold]
257 if (!is.na(trim)) x = x[x < trim]
258 if (xi == 0) {
259 y = qexp(ppoints(x)) }
260 if( xi != 0) {
261 y = qgpd(ppoints(x), xi = xi) }
262
263 # Plot:
264 if (doplot) {
265 if (labels) {
266 xlab = "Ordered Data"
267 ylab = "Quantiles"
268 if (xi == 0) {
269 ylab = paste("Exponential", ylab) }
270 if (xi != 0) {
271 ylab = paste("GPD(xi=", xi, ") ", ylab, sep = "") }
272 main = "Exploratory QQ Plot" }
273 else {
274 xlab = ""
275 ylab = ""
276 main = "" }
277 plot(sort(x), y, xlab = xlab, ylab = ylab, main = main, ...)
278 if (line) abline(lsfit(sort(x), y))
279 if (labels) grid()
280 }
281
282 # Result:
283 result = data.frame(x = sort(x), y)
284
285 # Return Value:
286 if (doplot) return(invisible(result)) else return(result)
287 }
288
289
290 # ------------------------------------------------------------------------------
291
292
293 mxfPlot =
294 function (x, tail = 0.05, doplot = TRUE, labels = TRUE, ...)
295 { # A function written by D. Wuertz
296
297 # Description:
298 # Creates a simple mean excess function plot.
299
300 # FUNCTION:
301
302 # Convert from univariate 'timSeries':
303 if (is.timeSeries(x)) x = as.vector(x)
304
305 # Convert x to a vector, if the input is a data.frame.
306 if(is.data.frame(x)) x = x[,1]
307 u = rev(sort(x))
308 n = length(x)
309 u = u[1:floor(tail*n)]
310 n = length(u)
311 e = (cumsum(u)-(1:n)*u)/(1:n)
312
313 # Plot
314 if (doplot) {
315 if (labels) {
316 xlab = "Threshold: u"
317 ylab = "Mean Excess: e"
318 main = "Mean Excess Function" }
319 else {
320 xlab = ""
321 ylab = ""
322 main = "" }
323 plot (u, e, xlab = xlab, ylab = ylab, main = main, ...)
324 if (labels) grid()
325 }
326
327 # Result:
328 result = data.frame(threshold = u, excess = e)
329
330 # Return Values:
331 if (doplot) return(invisible(result)) else return(result)
332 }
333
334
335 # ------------------------------------------------------------------------------
336
337
338 mrlPlot =
339 function(x, conf = 0.95, umin = NA, umax=NA, nint = 100,
340 doplot = TRUE, plottype = c("autoscale", ""), labels = TRUE, ...)
341 { # A function implemented by Diethelm Wuertz
342
343 # Description:
344 # Create a mean residual life plot with
345 # confidence intervals.
346
347 # Note:
348 # "autoscale" added by DW.
349
350 # References:
351 # A function originally written by S. Coles
352
353 # FUNCTION:
354
355 # Convert from univariate 'timSeries':
356 if (is.timeSeries(x)) x = as.vector(x)
357
358 # Settings:
359 plottype = plottype[1]
360 if (plottype == "autoscale") {
361 autoscale = TRUE }
362 else {
363 autoscale = FALSE }
364
365 # Convert x to a vector, if the input is a data.frame.
366 if (is.data.frame(x)) x = x[,1]
367 if (is.na(umin)) umin = mean(x)
368 if (is.na(umax)) umax = max(x)
369 sx = xu = xl = rep(NA, nint)
370 u = seq(umin, umax, length = nint)
371 for(i in 1:nint) {
372 x = x[x >= u[i]]
373 sx[i] = mean(x - u[i])
374 sdev = sqrt(var(x))
375 n = length(x)
376 xu[i] = sx[i] + (qnorm((1 + conf)/2) * sdev)/sqrt(n)
377 xl[i] = sx[i] - (qnorm((1 + conf)/2) * sdev)/sqrt(n) }
378
379 # Plot:
380 if (doplot) {
381 if (labels) {
382 xlab = "Threshold: u"
383 ylab = "Mean Excess: e"
384 main = "Mean Residual Live Plot"
385 } else {
386 xlab = ""
387 ylab = ""
388 main = ""
389 }
390 if (autoscale) {
391 ylim = c(min(xl[!is.na(xl)]), max(xu[!is.na(xu)]))
392 plot(u, sx, type = "l", lwd = 2, xlab = xlab,
393 ylab = ylab, ylim = ylim, main = main, ...)
394 } else {
395 plot(u[!is.na(xl)], sx[!is.na(xl)], type = "l",
396 lwd = 2, xlab = xlab, ylab = ylab, main = main, ...)
397 }
398 lines(u[!is.na(xl)], xl[!is.na(xl)], col = "steelblue")
399 lines(u[!is.na(xu)], xu[!is.na(xu)], col = "steelblue")
400 if (labels) grid()
401 }
402
403 # Result
404 result = data.frame(threshold = u, mrl = sx)
405
406 # Return Value:
407 if (doplot) return(invisible(result)) else return(result)
408 }
409
410
411 # ------------------------------------------------------------------------------
412
413
414 mePlot =
415 function(x, doplot = TRUE, labels = TRUE, ...)
416 { # A function implemented by Diethelm Wuertz
417
418 # Description:
419 # Create a Mean Excess Plot
420
421 # Reference:
422 # A function imported from R-package evir
423
424 # FUNCTION:
425
426 # Convert from univariate 'timSeries':
427 if (is.timeSeries(x)) x = as.vector(x)
428
429 # Settings:
430 omit = 0
431
432 # Internal Function:
433 myrank = function(x, na.last = TRUE){
434 ranks = sort.list(sort.list(x, na.last = na.last))
435 if(is.na(na.last))
436 x = x[!is.na(x)]
437 for(i in unique(x[duplicated(x)])) {
438 which = x == i & !is.na(x)
439 ranks[which] = max(ranks[which]) }
440 ranks }
441
442 # Convert x to a vector, if the input is a data.frame.
443 if(is.data.frame(x)) x = x[,1]
444 x = as.numeric(x)
445 n = length(x)
446 x = sort(x)
447 n.excess = unique(floor(length(x) - myrank(x)))
448 points = unique(x)
449 nl = length(points)
450 n.excess = n.excess[-nl]
451 points = points[-nl]
452 excess = cumsum(rev(x))[n.excess] - n.excess * points
453 y = excess/n.excess
454 xx = points[1:(nl-omit)]
455 yy = y[1:(nl-omit)]
456
457 # Plot:
458 if (doplot) {
459 if (labels) {
460 xlab = "Threshold: u"
461 ylab = "Mean Excess: e"
462 main = "Mean Excess Plot" }
463 else {
464 xlab = ""
465 ylab = ""
466 main = "" }
467 plot(xx, yy, xlab = xlab, ylab = ylab, main = main, ...)
468 if (labels) grid()
469 }
470
471 # Results:
472 result = data.frame(threshold = xx, me = yy)
473
474 # Return Value:
475 if (doplot) return(invisible(result)) else return(result)
476
477 }
478
479
480 # -----------------------------------------------------------------------------
481
482
483 recordsPlot =
484 function(x, conf = 0.95, doplot = TRUE, labels = TRUE, ...)
485 { # A function implemented by Diethelm Wuertz
486
487 # Description:
488 # Creates a records plot.
489
490 # Note:
491 # A function imported from R-package evir,
492 # original name in EVIR: records
493
494 # FUNCTION:
495
496 # Convert from univariate 'timSeries':
497 if (is.timeSeries(x)) x = as.vector(x)
498
499 # Settings:
500 conf.level = conf
501
502 # Convert x to a vector, if the input is a data.frame.
503 if (is.data.frame(x)) x = x[,1]
504
505 # Records:
506 record = cummax(x)
507 expected = cumsum(1/(1:length(x)))
508 se = sqrt(expected - cumsum(1/((1:length(x))^2)))
509 trial = (1:length(x))[!duplicated(record)]
510 record = unique(record)
511 number = 1:length(record)
512 expected = expected[trial]
513 se = se[trial]
514
515 # Plot:
516 if (doplot) {
517 if (labels) {
518 xlab = "Trials"
519 ylab = "Records"
520 main = "Plot of Record Development" }
521 else {
522 xlab = ""
523 ylab = ""
524 main = "" }
525 ci = qnorm(0.5 + conf.level/2)
526 upper = expected + ci * se
527 lower = expected - ci * se
528 lower[lower < 1] = 1
529 yr = range(upper, lower, number)
530 plot(trial, number, log = "x", ylim = yr,
531 xlab = xlab, ylab = ylab, main = main, ...)
532 lines(trial, expected)
533 lines(trial, upper, lty = 2)
534 lines(trial, lower, lty = 2)
535 if (labels) grid()
536 }
537
538 # Result:
539 result = data.frame(number, record, trial, expected, se)
540
541 # Return Value:
542 if (doplot) return(invisible(result)) else return(result)
543 }
544
545
546 # ------------------------------------------------------------------------------
547
548
549 ssrecordsPlot =
550 function (x, subsamples = 10, doplot = TRUE, plottype = c("lin", "log"),
551 labels = TRUE, ...)
552 { # A function implemented by Diethelm Wuertz
553
554 # Description:
555 # Creates a plot of records on subsamples.
556
557 # note:
558 # Changes:
559 # 2003/09/06 - argument list made consistent
560
561 # FUNCTION:
562
563 # Convert from univariate 'timSeries':
564 if (is.timeSeries(x)) x = as.vector(x)
565
566 # Convert x to a vector, if the input is a data.frame.
567 if(is.data.frame(x)) x = x[, 1]
568
569 # Plot type:
570 plottype = plottype[1]
571
572 # Records:
573 save = x
574 cluster = floor(length(save)/subsamples)
575 records = c()
576 for (i in 1:subsamples) {
577 x = save[((i-1)*cluster+1):(i*cluster)]
578 y = 1:length(x)
579 u = x[1]
580 v = x.records = 1
581 while (!is.na(v)) {
582 u = x[x > u][1]
583 v = y[x > u][1]
584 if(!is.na(v)) x.records = c(x.records, v)
585 }
586 if (i == 1) {
587 nc = 1:length(x)
588 csmean = cumsum(1/nc)
589 cssd = sqrt(cumsum(1/nc-1/(nc*nc)))
590 ymax = csmean[length(x)]+2*cssd[length(x)]
591 # Plot:
592 if (doplot) {
593 if (plottype == "log") nc = log(nc)
594 if (labels) {
595 if (plottype == "lin") xlab = "n"
596 if (plottype == "log") xlab = "log(n)"
597 ylab = "N(n)"
598 }
599 main = "Subsample Records Plot"
600 plot (nc, csmean+cssd, type = "l", ylim = c(0, ymax),
601 xlab = xlab, ylab = ylab, main = main, ...)
602 grid()
603 } else {
604 plot (nc, csmean+cssd, type = "l", ylim = c(0, ymax), ...)
605 }
606 lines(nc, csmean, col = "steelblue")
607 lines(nc, csmean-cssd, col = "steelblue")
608 }
609 y.records = 1:length(x.records)
610 x.records = x.records[y.records < ymax]
611 if (doplot) {
612 if (plottype == "log") x.records = log(x.records)
613 points(x.records, y.records[y.records<ymax], pch = i)
614 }
615 records[i] = y.records[length(y.records)]
616 }
617
618 # Result:
619 subsample = 1:subsamples
620 result = data.frame(subsample, records)
621
622 # Return Value:
623 if (doplot) return(invisible(result)) else return(result)
624 }
625
626
627 # ------------------------------------------------------------------------------
628
629
630 msratioPlot =
631 function (x, p = 1:4, doplot = TRUE, plottype = c("autoscale", ""),
632 labels = TRUE, ...)
633 { # A function implemented by Diethelm Wuertz
634
635 # Description:
636 # Creates a Plot of maximum and sum ratio.
637
638 # FUNCTION:
639
640 # Convert from univariate 'timSeries':
641 if (is.timeSeries(x)) x = as.vector(x)
642
643 # Settings:
644 plottype = plottype[1]
645 if (plottype == "autoscale") {
646 autoscale = TRUE }
647 else {
648 autoscale = FALSE }
649 if (autoscale) ylim = c(0,1)
650
651 # Convert x to a vector, if the input is a data.frame.
652 if(is.data.frame(x)) x = x[,1]
653
654 # Plot:
655 if (doplot) {
656 if (labels) {
657 xlab = "Trials"
658 ylab = "Records"
659 main = "Plot of Record Development" }
660 else {
661 xlab = ""
662 ylab = ""
663 main = "" }
664 if (autoscale) {
665 plot(c(0, length(x)), y = ylim, xlab = xlab,
666 ylab = ylab, main = main, type = "n", ...) }
667 else {
668 plot(c(0, length(x)), xlab = xlab,
669 ylab = ylab, main = main, type = "n", ...) }
670 if (labels) grid()
671 }
672
673 # Color numbering:
674 i = 1
675
676 # Suppress warnings for points outside the frame:
677 ratios = matrix(rep(0, times=length(x)*length(p)), byrow=TRUE,
678 ncol=length(p))
679 if (doplot) par(err=-1)
680
681 # Loop over all exponents p:
682 for (q in p) {
683 rnp = cummax(abs(x)^q) / cumsum(abs(x)^q)
684 i = i + 1
685 ratios[,q] = rnp
686 if (doplot) lines (rnp, col=i) }
687
688 # Result:
689 result = data.frame(ratios)
690
691 # Return Value:
692 if (doplot) return(invisible(result)) else return(result)
693 }
694
695
696 # ------------------------------------------------------------------------------
697
698
699 xacfPlot =
700 function(x, threshold = 0.95, lag.max = 15, doplot = TRUE, ...)
701 { # A function implemented by Diethelm Wuertz
702
703 # Description:
704 # Creates plots of exceedences, one for the
705 # heights and one for the distances.
706
707 # FUNCTION:
708
709 # Convert from univariate 'timSeries':
710 if (is.timeSeries(x)) x = as.vector(x)
711
712 # Settings:
713 # Sorry, user specified labels not yet implemented.
714 labels = TRUE
715 if (labels) {
716 xlab = c("Index", "Lag")
717 ylab = c("Heights", "Distances", "ACF")
718 main = c("Heights over Threshold", "Distances between Heights",
719 "Series Heights", "Series Distances") }
720
721 # Convert x to a vector, if the input is a data.frame.
722 if (is.data.frame(x)) x = x[,1]
723 # Heights/Distances
724 threshold = sort(x)[round(threshold*length(x))]
725 Heights = (x-threshold)[(x-threshold)>0]
726 Distances = diff((1:length(x))[(x-threshold)>0])
727
728 # Plot:
729 if (doplot) {
730 plot (Heights, type="h", xlab = xlab[1], ylab = ylab[1],
731 main = main[1], ...)
732 plot (Distances,type="h", xlab = xlab[1], ylab = ylab[2],
733 main = main[2], ...) }
734
735 # Correlations:
736 Heights = as.vector(acf(Heights, lag.max=lag.max, plot = doplot,
737 xlab = xlab[2], ylab = ylab[3], main = main[3], ...)$acf)
738 Distances = as.vector(acf(Distances, lag.max=lag.max, plot = doplot,
739 xlab = xlab[2], ylab = ylab[3], main = main[4], ...)$acf)
740
741 # Result:
742 lag = as.vector(0:(lag.max))
743 result = data.frame(lag, Heights, Distances)
744
745 # Return Value:
746 if (doplot) return(invisible(result)) else return(result)
747 }
748
749
750 # ******************************************************************************
751
752
753 interactivePlot =
754 function(x, choices = paste("Plot", 1:9),
755 plotFUN = paste("plot.", 1:9, sep = ""), which = "all", ...)
756 { # A function implemented by Diethelm Wuertz
757
758 # Description:
759 # Plot method for an object of class "template".
760
761 # Arguments:
762 # x - an object to be plotted
763 # choices - the character string for the choice menu
764 # plotFUN - the names of the plot functions
765 # which - plot selection, which graph should be
766 # displayed. If a character string named "ask" the
767 # user is interactively asked which to plot, if
768 # a logical vector of length N, those plots which
769 # are set "TRUE" are displayed, if a character string
770 # named "all" all plots are displayed.
771
772 # Note:
773 # At maximum 9 plots are supported.
774
775 # FUNCTION:
776
777 # Some cecks:
778 if (length(choices) != length(plotFUN))
779 stop("Arguments choices and plotFUN must be of same length.")
780 if (length(which) > length(choices))
781 stop("Arguments which has incorrect length.")
782 if (length(which) > length(plotFUN))
783 stop("Arguments which has incorrect length.")
784 if (length(choices) > 9)
785 stop("Sorry, only 9 plots at max are supported.")
786
787 # Internal "askPlot" Function:
788 multPlot = function (x, choices, ...)
789 {
790 # Selective Plot:
791 selectivePlot = function (x, choices, FUN, which){
792 # Internal Function:
793 askPlot = function (x, choices, FUN) {
794 # Pick and Plot:
795 pick = 1; n.plots = length(choices)
796 while (pick > 0) { pick = menu (
797 choices = paste("plot:", choices),
798 title = "\nMake a plot selection (or 0 to exit):")
799 if (pick > 0) match.fun(FUN[pick])(x) } }
800 if (as.character(which[1]) == "ask") {
801 askPlot(x, choices = choices, FUN = FUN, ...) }
802 else {
803 for (i in 1:n.plots) if (which[i]) match.fun(FUN[i])(x) }
804 invisible() }
805 # match Functions, up to nine ...
806 if (length(plotFUN) < 9) plotFUN =
807 c(plotFUN, rep(plotFUN[1], times = 9 - length(plotFUN)))
808 plot.1 = match.fun(plotFUN[1]); plot.2 = match.fun(plotFUN[2])
809 plot.3 = match.fun(plotFUN[3]); plot.4 = match.fun(plotFUN[4])
810 plot.5 = match.fun(plotFUN[5]); plot.6 = match.fun(plotFUN[6])
811 plot.7 = match.fun(plotFUN[7]); plot.8 = match.fun(plotFUN[8])
812 plot.9 = match.fun(plotFUN[9])
813 pick = 1
814 while (pick > 0) { pick = menu (
815 ### choices = paste("plot:", choices),
816 choices = paste(" ", choices),
817 title = "\nMake a plot selection (or 0 to exit):")
818 # up to 9 plot functions ...
819 switch (pick, plot.1(x), plot.2(x), plot.3(x), plot.4(x),
820 plot.5(x), plot.6(x), plot.7(x), plot.8(x), plot.9(x) )
821 }
822 }
823
824 # Plot:
825 if (is.numeric(which)) {
826 Which = rep(FALSE, times = length(choices))
827 Which[which] = TRUE
828 which = Which
829 }
830 if (which[1] == "all") {
831 which = rep(TRUE, times = length(choices))
832 }
833 if (which[1] == "ask") {
834 multPlot(x, choices, ...)
835 } else {
836 for ( i in 1:length(which) ) {
837 FUN = match.fun(plotFUN[i])
838 if (which[i]) FUN(x)
839 }
840 }
841
842 # Return Value:
843 invisible(x)
844 }
845
846
847 # ******************************************************************************
848
849
850 gridVector =
851 function(x, y)
852 { # A function implemented by Diethelm Wuertz, GPL
853
854 # Description:
855 # Creates from two vectors x and y all grid points
856
857 # Details:
858 # The two vectors x and y span a rectangular grid with nx=length(x)
859 # times ny=length(y) points which are returned as a matrix of size
860 # (nx*ny) times 2.
861
862 # Arguments:
863 # x, y - two numeric vectors of length m and n which span the
864 # rectangular grid of size m times n.
865
866 # Value:
867 # returns a list with two elements X and Y each of length m
868 # times n
869
870 # Example:
871 # > gridVector(1:3, 1:2)
872 # [,1] [,2]
873 # [1,] 1 1
874 # [2,] 2 1
875 # [3,] 3 1
876 # [4,] 1 2
877 # [5,] 2 2
878 # [6,] 3 2
879
880 # FUNCTION:
881
882 # Prepare for Input:
883 nx = length(x)
884 ny = length(y)
885 xoy = cbind(rep(x, ny), as.vector(matrix(y, nx, ny, byrow = TRUE)))
886 X = matrix(xoy, nx * ny, 2, byrow = FALSE)
887
888 # Return Value:
889 list(X = X[,1], Y = X[,2])
890 }
891
892
893 ################################################################################
894
895
896 # PART II:
897
898
899 findThreshold =
900 function(x, n = NA)
901 { # A function implemented by Diethelm Wuertz
902
903 # Description:
904 # Finds upper thresold for a given number of Extremes.
905
906 # Arguments:
907 # n - a numeric value or vector giving number of extremes
908 # above the threshold. If "n" is not specified, "n"
909 # is set to an integer representing 5% of the data
910 # from the whole data set "x".
911
912 # Note:
913 # Imported from R-package evir/EVIS.
914
915 # FUNCTION:
916
917 # Settings:
918 if(is.na(n[1])) n = floor(0.05*length(x))
919
920 # Continue:
921 x = rev(sort(as.numeric(x)))
922 thresholds = unique(x)
923 indices = match(x[n], thresholds)
924 indices = pmin(indices + 1, length(thresholds))
925
926 # Return Value:
927 thresholds[indices]
928 }
929
930
931 # ------------------------------------------------------------------------------
932
933
934 blocks =
935 function(x, block = "month", FUN = max)
936 { # A function implemented by Diethelm Wuertz
937
938 # Description:
939 # Creates data blocks on vectors and time series.
940
941 # Note:
942 # Imported from R-package evir/EVIS.
943
944 # FUNCTION:
945
946 # Settings:
947 data = x
948
949 # Compute:
950 n.all = length(data)
951 if (is.character(block)) {
952 times = as.POSIXlt(attributes(data)$times)
953 if (block %in% c("semester", "quarter")) {
954 sem = quart = times$mon
955 sem[sem %in% 0:5] = quart[quart %in% 0:2] = 0
956 sem[sem %in% 6:11] = quart[quart %in% 3:5] = 1
957 quart[quart %in% 6:8] = 2
958 quart[quart %in% 9:11] = 3 }
959 grouping = switch(block,
960 semester = paste(times$year, sem),
961 quarter = paste(times$year, quart),
962 quarters = paste(times$year, quart),
963 month = paste(times$year, times$mon),
964 months = paste(times$year, times$mon),
965 year = times$year,
966 years = times$year,
967 stop("unknown time period"))
968 newdata = tapply(data, grouping, FUN=FUN) }
969 else {
970 data = as.numeric(data)
971 nblocks = (length(data) %/% block) + 1
972 grouping = rep(1:nblocks, rep(block, nblocks))[1:length(data)]
973 newdata = tapply(data, grouping, FUN=FUN)}
974
975 # Return Value:
976 result = newdata
977 result
978 }
979
980
981 # -----------------------------------------------------------------------------
982
983
984 blockMaxima =
985 function(x, block = "month", details = FALSE, doplot = TRUE, ...)
986 { # A function implemented by Diethelm Wuertz
987
988 # Description:
989 # Calculates block maxima on vectors and time series.
990
991 # Arguments:
992 # x - may be alternatively as.vector or as.ts
993 # block - as.numeric: length of a block
994 # as.character: year | semester | quarter | month
995
996 # Note:
997 # Calls McNeils Splus function blocks()
998 # Output data as vector of transposed
999 # result to get proper order of data!
1000
1001 # FUNCTION:
1002
1003 # Settings
1004 x = blocks(x, block)
1005
1006 # Plot:
1007 if (doplot) {
1008 plot(as.vector(x), type="h", ylab = "Block Maxima", ...)
1009 title(main = paste(block, "- Block Maxima"))
1010 grid() }
1011
1012 # Details:
1013 # if details == FALSE a vector is returned, i.e details are removed!
1014 if (!details) x = as.vector(x[is.na(x) == FALSE])
1015
1016 # Return Value:
1017 x
1018 }
1019
1020
1021 # -----------------------------------------------------------------------------
1022
1023
1024 deCluster =
1025 function(x, run = NA, doplot = TRUE)
1026 { # A function implemented by Diethelm Wuertz
1027
1028 # Description:
1029 # Declusters a point process
1030
1031 # Note:
1032 # Imported from R-package evir/EVIS.
1033
1034 # FUNCTION:
1035
1036 # Settings:
1037 labels = TRUE
1038
1039 # Imported Function:
1040 series = x
1041 picture = doplot
1042 n = length(as.numeric(series))
1043 times = attributes(series)$times
1044 if (is.null(times))
1045 stop("`series' must have a `times' attribute")
1046 as.posix = is.character(times) || inherits(times, "POSIXt") ||
1047 inherits(times, "date") || inherits(times, "dates")
1048 if (as.posix)
1049 gaps = as.numeric(difftime(as.POSIXlt(times)[2:n],
1050 as.POSIXlt(times)[1:(n - 1)], units = "days"))
1051 else gaps = as.numeric(diff(times))
1052 longgaps = gaps > run
1053 if (sum(longgaps) <= 1)
1054 stop("Decluster parameter too large")
1055 cluster = c(0, cumsum(longgaps))
1056 cmax = tapply(as.numeric(series), cluster, max)
1057 newtimes = times[match(cmax, series)]
1058 newseries = structure(series[match(cmax, series)], times = newtimes)
1059 n = length(as.numeric(newseries))
1060 if (as.posix) {
1061 newgaps = as.numeric(difftime(as.POSIXlt(newtimes)[2:n],
1062 as.POSIXlt(newtimes)[1:(n - 1)], units = "days"))
1063 times = as.POSIXlt(times)
1064 newtimes = as.POSIXlt(newtimes) }
1065 else {
1066 newgaps = as.numeric(diff(newtimes)) }
1067
1068 # Plot:
1069 if (doplot) {
1070 # cat("Declustering picture...\n")
1071 # cat(paste("Data reduced from", length(as.numeric(series)),
1072 # "to", length(as.numeric(newseries)), "\n"))
1073 # par(mfrow = c(2, 2))
1074 if (labels) {
1075 main = "de-Clustering"
1076 plot(times, series, type = "h", main = main)
1077 qPlot(gaps)
1078 plot(newtimes, newseries, type = "h", main = main)
1079 qPlot(newgaps) }
1080 }
1081
1082 # Result:
1083 ans = newseries
1084
1085 # Return Value:
1086 ans
1087 }
1088
1089
1090 ################################################################################
1091
+0
-1067
R/52A-GevModelling.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: GEV DISTRIBUTION FAMILY: [USE FROM EVD]
31 # devd Density for the GEV Distribution
32 # pevd Probability for the GEV Distribution
33 # qevd Quantiles for the GEV Distribution
34 # revd Random variates for the GEV Distribution
35 # FUNCTION: GEV DISTRIBUTION FAMILY: [USE FROM EVIS]
36 # dgev Density for the GEV Distribution
37 # pgev Probability for the GEV Distribution
38 # qgev Quantiles for the GEV Distribution
39 # rgev Random variates for the GEV Distribution
40 ################################################################################
41
42
43 ################################################################################
44 # FUNCTION: GEV MODELLING FROM EVIS:
45 # gevSim Simulates GEV including Gumbel rvs [EVIS/EVIR]
46 # gevFit Fits GEV Distribution
47 # print.gevFit Print Method for object of class "gevFit"
48 # plot.gevFit Plot Method for object of class "gevFit"
49 # summary.gevFit Summary Method for object of class "gevFit"
50 # FUNCTION: ADDITIONAL PLOT:
51 # gevrlevelPlot Calculates Return Levels Based on GEV Fit
52 ################################################################################
53
54
55 ################################################################################
56 # FUNCTION: MDA ESTIMATORS:
57 # hillPlot Plot Hill's estimator
58 # shaparmPlot Pickands, Hill & Decker-Einmahl-deHaan Estimator
59 # shaparmPickands Auxiliary function called by shaparmPlot
60 # shaparmHill ... called by shaparmPlot
61 # shaparmDehaan ... called by shaparmPlot
62 ################################################################################
63
64
65 # PART I: GEV DISTRIBUTION FAMILY: [USE FROM EVD]
66
67
68 devd =
69 function (x, loc = 0, scale = 1, shape = 0, log = FALSE)
70 {
71 # FUNCTION:
72
73 if (min(scale) <= 0)
74 stop("invalid scale")
75 if (length(shape) != 1)
76 stop("invalid shape")
77 x = (x - loc)/scale
78 if (shape == 0)
79 d = log(1/scale) - x - exp(-x)
80 else {
81 nn = length(x)
82 xx = 1 + shape * x
83 xxpos = xx[xx > 0 | is.na(xx)]
84 scale = rep(scale, length.out = nn)[xx > 0 | is.na(xx)]
85 d = numeric(nn)
86 d[xx > 0 | is.na(xx)] = log(1/scale) - xxpos^(-1/shape) -
87 (1/shape + 1) * log(xxpos)
88 d[xx <= 0 & !is.na(xx)] = -Inf
89 }
90 if (!log)
91 d = exp(d)
92 d
93 }
94
95
96 # ------------------------------------------------------------------------------
97
98
99 pevd =
100 function (q, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
101 {
102 # FUNCTION:
103
104 if (min(scale) <= 0)
105 stop("invalid scale")
106 if (length(shape) != 1)
107 stop("invalid shape")
108 q = (q - loc)/scale
109 if (shape == 0)
110 p = exp(-exp(-q))
111 else p = exp(-pmax(1 + shape * q, 0)^(-1/shape))
112 if (!lower.tail)
113 p = 1 - p
114 p
115 }
116
117
118 # ------------------------------------------------------------------------------
119
120
121 qevd =
122 function (p, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
123 {
124 # FUNCTION:
125
126 if (min(p, na.rm = TRUE) <= 0 || max(p, na.rm = TRUE) >=
127 1)
128 stop("`p' must contain probabilities in (0,1)")
129 if (min(scale) < 0)
130 stop("invalid scale")
131 if (length(shape) != 1)
132 stop("invalid shape")
133 if (!lower.tail)
134 p = 1 - p
135 if (shape == 0)
136 return(loc - scale * log(-log(p)))
137 else return(loc + scale * ((-log(p))^(-shape) - 1)/shape)
138 }
139
140
141 # ------------------------------------------------------------------------------
142
143
144 revd =
145 function (n, loc = 0, scale = 1, shape = 0)
146 {
147 # FUNCTION:
148
149 if (min(scale) < 0)
150 stop("invalid scale")
151 if (length(shape) != 1)
152 stop("invalid shape")
153 if (shape == 0)
154 return(loc - scale * log(rexp(n)))
155 else return(loc + scale * (rexp(n)^(-shape) - 1)/shape)
156 }
157
158
159 # ******************************************************************************
160
161
162 dgev =
163 function(x, xi = 1, mu = 0, sigma = 1, log = FALSE)
164 { # A function implemented from evd
165
166 # Description:
167 # GEV Density Function
168 # Note: 1 + xi*(x-mu)/sigma > 0
169 # xi > 0 Frechet
170 # xi = 0 Gumbel
171 # xi < 0 weibl
172
173 # FUNCTION:
174
175 # Settings:
176 loc = mu
177 scale = sigma
178 shape = xi
179
180 # Density function:
181 if (min(scale) <= 0)
182 stop("invalid scale")
183 if (length(shape) != 1)
184 stop("invalid shape")
185 x = (x - loc)/scale
186 if (shape == 0)
187 d = log(1/scale) - x - exp(-x)
188 else {
189 nn = length(x)
190 xx = 1 + shape * x
191 xxpos = xx[xx > 0 | is.na(xx)]
192 scale = rep(scale, length.out = nn)[xx > 0 | is.na(xx)]
193 d = numeric(nn)
194 d[xx > 0 | is.na(xx)] = log(1/scale) - xxpos^(-1/shape) -
195 (1/shape + 1) * log(xxpos)
196 d[xx <= 0 & !is.na(xx)] = -Inf
197 }
198 if (!log)
199 d = exp(d)
200
201 # Return Value:
202 d
203 }
204
205
206 # ------------------------------------------------------------------------------
207
208
209 pgev =
210 function(q, xi = 1, mu = 0, sigma = 1, lower.tail = TRUE)
211 { # A function implemented from evd
212
213 # Description:
214 # GEV Probability Function
215 # Note: 1 + xi*(x-mu)/sigma > 0
216 # xi > 0 Frechet
217 # xi = 0 Gumbel
218 # xi < 0 Weibull
219
220 # FUNCTION:
221
222 # Settings:
223 loc = mu
224 scale = sigma
225 shape = xi
226
227 # Probability function:
228 if (min(scale) <= 0)
229 stop("invalid scale")
230 if (length(shape) != 1)
231 stop("invalid shape")
232 q = (q - loc)/scale
233 if (shape == 0)
234 p = exp(-exp(-q))
235 else p = exp(-pmax(1 + shape * q, 0)^(-1/shape))
236 if (!lower.tail)
237 p = 1 - p
238
239 # Return Value:
240 p
241 }
242
243
244 # ------------------------------------------------------------------------------
245
246
247 qgev =
248 function (p, xi = 1, mu = 0, sigma = 1, lower.tail = TRUE)
249 { # A function implemented from evd
250
251 # Description:
252 # GEV Quantile Function
253 # Note: 1 + xi*(x-mu)/sigma > 0
254 # xi > 0 Frechet
255 # xi = 0 Gumbel
256 # xi < 0 Weibull
257
258 # FUNCTION:
259
260 # Settings:
261 loc = mu
262 scale = sigma
263 shape = xi
264
265 # Return Value:
266 if (min(p, na.rm = TRUE) < 0 || max(p, na.rm = TRUE) > 1)
267 stop("`p' must contain probabilities in (0,1)")
268 if (min(scale) < 0)
269 stop("invalid scale")
270 if (length(shape) != 1)
271 stop("invalid shape")
272 if (!lower.tail)
273 p = 1 - p
274 if (shape == 0)
275 q = loc - scale * log(-log(p))
276 else
277 q = loc + scale * ((-log(p))^(-shape) - 1)/shape
278
279 # Return Value:
280 q
281 }
282
283
284 # ------------------------------------------------------------------------------
285
286
287 rgev =
288 function (n, xi = 1, mu = 0, sigma = 1)
289 { # A function implemented from evd
290
291 # Description:
292 # GEV Random Variables
293 # Note: 1 + xi*(x-mu)/sigma > 0
294 # xi > 0 Frechet
295 # xi = 0 Gumbel
296 # xi < 0 Weibull
297
298 # FUNCTION:
299
300 # Settings:
301 loc = mu
302 scale = sigma
303 shape = xi
304
305 # Return Value:
306 if (min(scale) < 0)
307 stop("invalid scale")
308 if (length(shape) != 1)
309 stop("invalid shape")
310 if (shape == 0)
311 r = loc - scale * log(rexp(n))
312 else
313 r = loc + scale * (rexp(n)^(-shape) - 1)/shape
314
315 # Return Value:
316 r
317 }
318
319
320 ################################################################################
321
322
323 # GEV MODELLING FROM EVIS:
324
325
326 gevSim =
327 function(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
328 { # A function implemented by Diethelm Wuertz
329
330 # Description:
331 # Generates random variates from a GEV distribution
332
333 # FUNCTION:
334
335 # Simulate:
336 ans = rgev(n = n, xi = model$shape, mu = model$location,
337 sigma = model$scale)
338
339 # Return Value:
340 ans
341 }
342
343
344 # ------------------------------------------------------------------------------
345
346
347 gevFit =
348 function(x, block = NA, type = c("mle", "pwm"), gumbel = FALSE, ...)
349 { # A function implemented by Diethelm Wuertz
350
351 # Description:
352 # Fits parameters to a GEV distribution
353
354 # Note:
355 # Argument named "method is already used for the selection
356 # of the MLE optimization algorithm, therfore we use here
357 # "type".
358
359 # FUNCTION:
360
361 # Settings:
362 call = match.call()
363 type = type[1]
364
365 # Internal Function:
366 gev.pwm = function(data, block = NA, ...) {
367 # Probability Weighted Moment method.
368 # Blocks and data:
369 n.all = NA
370 if (!is.na(block)) {
371 n.all = length(data)
372 if (is.character(block)) {
373 times = as.POSIXlt(attributes(data)$times)
374 if (block %in% c("semester", "quarter")) {
375 sem = quart = times$mon
376 sem[sem %in% 0:5] = quart[quart %in% 0:2] = 0
377 sem[sem %in% 6:11] = quart[quart %in% 3:5] = 1
378 quart[quart %in% 6:8] = 2
379 quart[quart %in% 9:11] = 3 }
380 grouping = switch(block,
381 semester = paste(times$year, sem),
382 quarter = paste(times$year, quart),
383 month = paste(times$year, times$mon),
384 year = times$year,
385 stop("unknown time period"))
386 data = tapply(data, grouping, max) }
387 else {
388 data = as.numeric(data)
389 nblocks = (length(data)%/%block) + 1
390 grouping = rep(1:nblocks, rep(block, nblocks))[1:length(data)]
391 data = tapply(data, grouping, max) } }
392 data = as.numeric(data)
393 n = length(data)
394
395 # Internal Function - Sample Moments:
396 sampwm = function (x, nmom) {
397 # a = 0, b = 0, kind = 1
398 x = rev(sort(x))
399 moments = rep(0, nmom)
400 moments[1] = mean(x)
401 n = length(x)
402 for (i in 1:n) {
403 weight = 1/n
404 for (j in 2:nmom) {
405 weight = weight*(n-i-j+2)/(n-j+1)
406 moments[j] = moments[j] + weight*x[i] } }
407 return(moments) }
408
409 # Internal Function:
410 y = function(x, w0, w1, w2) { (3^x-1)/(2^x-1) - (3*w2 - w0)/(2*w1 - w0) }
411 # Calculate:
412 w = sampwm(data, nmom = 3)
413 w0 = w[1]
414 w1 = w[2]
415 w2 = w[3]
416 xi = uniroot(f = y, interval = c(-5,+5),
417 w0 = w[1], w1 = w[2], w2 = w[3])$root
418 sigma = beta = (2*w1-w0)*xi / gamma(1-xi) / (2^xi-1)
419 mu = w0 + beta*(1-gamma(1-xi))/xi
420 # Output:
421 fit = list(n.all = n.all, n = n, data = data, bock = block,
422 par.ests = c(xi, sigma, mu), par.ses = rep(NA, 3),
423 varcov = matrix(rep(NA, 9), 3, 3), converged = NA,
424 nllh.final = NA, call=match.call(), selected = "pwm")
425 names(fit$par.ests) = c("xi", "sigma", "mu")
426 names(fit$par.ses) = c("xi", "sigma", "mu")
427 # Return Value:
428 class(fit) = "gev"
429 fit }
430
431 # Internal Function:
432 gumbel.pwm = function(data, block = NA, ...) {
433 # "Probability Weighted Moment" method.
434 # Blocks and data:
435 n.all = NA
436 if (!is.na(block)) {
437 n.all = length(data)
438 if (is.character(block)) {
439 times = as.POSIXlt(attributes(data)$times)
440 if (block %in% c("semester", "quarter")) {
441 sem = quart = times$mon
442 sem[sem %in% 0:5] = quart[quart %in% 0:2] = 0
443 sem[sem %in% 6:11] = quart[quart %in% 3:5] = 1
444 quart[quart %in% 6:8] = 2
445 quart[quart %in% 9:11] = 3 }
446 grouping = switch(block,
447 semester = paste(times$year, sem),
448 quarter = paste(times$year, quart),
449 month = paste(times$year, times$mon),
450 year = times$year,
451 stop("unknown time period"))
452 data = tapply(data, grouping, max) }
453 else {
454 data = as.numeric(data)
455 nblocks = (length(data)%/%block) + 1
456 grouping = rep(1:nblocks, rep(block, nblocks))[1:length(data)]
457 data = tapply(data, grouping, max) } }
458 data = as.numeric(data)
459 n = length(data)
460 # Sample Moments:
461 x = rev(sort(data))
462 lambda = c(mean(x), 0)
463 for (i in 1:n) {
464 weight = (n-i)/(n-1)/n
465 lambda[2] = lambda[2] + weight*x[i] }
466 # Calculate Parameters:
467 xi = 0
468 sigma = beta = lambda[2]/log(2)
469 mu = lambda[1] - 0.5772*beta
470 # Output:
471 fit = list(n.all = n.all, n = n, data = data, block = block,
472 par.ests = c(sigma, mu), par.ses = rep(NA, 2),
473 varcov = matrix(rep(NA, 4), 2, 2), converged = NA,
474 nllh.final = NA, call = match.call(), selected = "pwm")
475 names(fit$par.ests) = c("sigma", "mu")
476 names(fit$par.ses) = c("sigma", "mu")
477 # Return Value:
478 class(fit) = "gev" # not gumbel!
479 fit }
480
481 # Estimate Parameters:
482 if (gumbel) {
483 # Add Call and Type
484 if (length(type) > 1) type = type[1]
485 # Probability Weighted Moment Estimation
486 if (type == "pwm") {
487 fitted = gumbel.pwm(data = x, block = block, ...) }
488 # Maximum Log Likelihood Estimation
489 # Use Alexander McNeils EVIS:
490 if (type == "mle") {
491 fitted = gumbel(data = x, block = block, ...) } }
492 else {
493 # Add Call and Type
494 if (length(type) > 1) type = type[1]
495 # Probability Weighted Moment Estimation:
496 if (type == "pwm") {
497 fitted = gev.pwm(data = x, block = block, ...) }
498 # Maximum Log Likelihood Estimation
499 # Use Alexander McNeils EVIS (renames as gev.mle)
500 if (type == "mle") {
501 fitted = gev(data = x, block = block, ...) } }
502
503 # Compute Residuals:
504 if (gumbel) {
505 # GUMBEL:
506 xi = 0
507 sigma = fitted$par.ests[1]
508 mu = fitted$par.ests[2]
509 fitted$residuals = exp( - exp( - (fitted$data - mu)/sigma)) }
510 else {
511 # GEV:
512 xi = fitted$par.ests[1]
513 sigma = fitted$par.ests[2]
514 mu = fitted$par.ests[3]
515 fitted$residuals = (1 + (xi * (fitted$data - mu))/sigma)^(-1/xi) }
516
517 # Make Unique:
518 fit = list()
519 fit$fit = fitted
520 fit$call = call
521 fit$type = c(if(gumbel) "gum" else "gev", type[1])
522 fit$par.ests = fitted$par.ests
523 fit$par.ses = fitted$par.ses
524 fit$residuals = fitted$residuals
525 fit$fitted.values = fitted$data - fitted$residuals
526 fit$llh = fitted$nllh.final
527 fit$converged = fitted$converged
528
529 # Return Value:
530 class(fit) = "gevFit"
531 fit
532 }
533
534
535 # ------------------------------------------------------------------------------
536
537
538 print.gevFit =
539 function(x, ...)
540 { # A function implemented by Diethelm Wuertz
541
542 # Description:
543 # Print Method for an object of class "gevFit".
544
545 # FUNCTION:
546
547 # Function Call:
548 cat("\nCall:\n")
549 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
550
551 # Estimation Type:
552 cat("\nEstimation Type:", x$type, "\n")
553
554 # Estimated Parameters:
555 cat("\nEstimated Parameters:\n")
556 print(x$par.ests)
557 cat("\n")
558
559 # Return Value:
560 invisible(x)
561 }
562
563
564 # ------------------------------------------------------------------------------
565
566
567 plot.gevFit =
568 function(x, which = "all", ...)
569 { # A function implemented by Diethelm Wuertz
570
571 # Description:
572 # Plot method for an object of class "gevFit".
573
574 # Details:
575 # plot.gev:
576 # Data are converted to unit exponentially distributed residuals
577 # under null hypothesis that GEV fits. Two diagnostics for iid
578 # exponential data are offered:
579 # "Scatterplot of Residuals" and "QQplot of Residuals"
580
581 # FUNCTION:
582
583 # Internal Plot Functions:
584 plot.1 <<- function(x) {
585 # Time Series Plot of Block Maxima:
586 plot(x$fit$data, type = "h", col = "steelblue",
587 xlab = "Index",
588 ylab = "Data",
589 main = "Block Maxima")
590 }
591 plot.2 <<- function(x) {
592 # Lowess Fit to Scatterplot of Residuals:
593 plot(x$residuals, pch = 19, cex = 0.5,
594 xlab = "Ordering",
595 ylab = "Residuals",
596 main = "Scatterplot of Residuals")
597 lines(lowess(1:length(x$residuals), x$residuals),
598 col = "steelblue")
599 grid()
600 }
601 plot.3 <<- function(x) {
602 # Histogram Plot of Residuals with Gaussian Fit:
603 hist(x$residuals, probability = TRUE, breaks = "FD",
604 col = "steelblue", border = "white",
605 xlab = "Residuals",
606 ylab = "Density",
607 main = "GEV Fit and Residual Histrogram")
608 # xi = x$par.ests[1]
609 # sigma = x$par.ests[2]
610 # mu = x$par.ests[3]
611 # r = range(x$residuals)
612 }
613 plot.4 <<- function(x) {
614 # Quantile-Quantile Plot:
615 # evir::qplot
616 qplot(x$residuals, col = "steelblue", pch = 19, cex = 0.5,
617 # xlab = "Ordered Data",
618 # ylab = "Exponential Quantiles",
619 main = "Quantile-Quantile Plot")
620 grid()
621 }
622
623 # Plot:
624 interactivePlot(
625 x = x,
626 choices = c(
627 "Block Maxima Plot",
628 "Scatterplot of Residuals",
629 "Histogram of Residuals",
630 "Quantile Quantile Plot"),
631 plotFUN = c(
632 "plot.1",
633 "plot.2",
634 "plot.3",
635 "plot.4"),
636 which = which)
637
638 # Return Value:
639 invisible(x)
640 }
641
642
643 # ------------------------------------------------------------------------------
644
645
646 summary.gevFit =
647 function(object, doplot = TRUE, which = "all", ...)
648 {
649 # A function implemented by Diethelm Wuertz
650
651 # Description:
652 # Summary method for an object of class "gevFit".
653
654 # FUNCTION:
655
656 # Print:
657 print(object, ...)
658
659 # Summary:
660 if (object$type[2] == "mle") {
661 cat("\nStandard Deviations:\n"); print(object$par.ses)
662 cat("\nLog-Likelihood Value: ", object$llh)
663 cat("\nType of Convergence: ", object$converged, "\n") }
664 cat("\n")
665
666 # Plot:
667 if (doplot) plot(object, which = which, ...)
668 cat("\n")
669
670 # Return Value:
671 invisible(object)
672 }
673
674
675 # ------------------------------------------------------------------------------
676
677
678 gevrlevelPlot =
679 function(object, k.blocks = 20, add = FALSE, ...)
680 { # A function implemented by Diethelm Wuertz
681
682 # Description:
683 # Calculates Return Levels Based on GEV Fit
684
685 # FUNCTION:
686
687 # Settings
688 fit = object
689
690 # Use "rlevel.gev":
691 ans = rlevel.gev(out = fit$fit, k.blocks = k.blocks, add = add, ...)
692 ans = c(min = ans[1], v = ans[2], max = ans[3])
693
694 # Return Value:
695 ans
696 }
697
698
699 ################################################################################
700
701
702 # PART III: MDA ESTIMATORS:
703
704
705 hillPlot =
706 function(x, option = c("alpha", "xi", "quantile"), start = 15, end = NA,
707 reverse = FALSE, p = NA, ci = 0.95, autoscale = TRUE, labels = TRUE, ...)
708 { # A function implemented by Diethelm Wuertz
709
710 # Description:
711 # Plots the results from the Hill Estimator.
712
713 # Note:
714 # Imported from R-package evir
715
716 # Settings:
717 data = as.numeric(x)
718 ordered = rev(sort(data))
719 ordered = ordered[ordered > 0]
720 n = length(ordered)
721 option = match.arg(option)
722 if((option == "quantile") && (is.na(p)))
723 stop("Input a value for the probability p")
724 if((option == "quantile") && (p < 1 - start/n)) {
725 cat("Graph may look strange !! \n\n")
726 cat(paste("Suggestion 1: Increase `p' above",
727 format(signif(1 - start/n, 5)), "\n"))
728 cat(paste("Suggestion 2: Increase `start' above ",
729 ceiling(length(data) * (1 - p)), "\n"))
730 }
731 k = 1:n
732 loggs = logb(ordered)
733 avesumlog = cumsum(loggs)/(1:n)
734 xihat = c(NA, (avesumlog - loggs)[2:n])
735 alphahat = 1/xihat
736 y = switch(option,
737 alpha = alphahat,
738 xi = xihat,
739 quantile = ordered * ((n * (1 - p))/k)^(-1/alphahat))
740 ses = y/sqrt(k)
741 if(is.na(end)) end = n
742 x = trunc(seq(from = min(end, length(data)), to = start))
743 y = y[x]
744 ylabel = option
745 yrange = range(y)
746 if(ci && (option != "quantile")) {
747 qq = qnorm(1 - (1 - ci)/2)
748 u = y + ses[x] * qq
749 l = y - ses[x] * qq
750 ylabel = paste(ylabel, " (CI, p =", ci, ")", sep = "")
751 yrange = range(u, l)
752 }
753 if(option == "quantile") ylabel = paste("Quantile, p =", p)
754 index = x
755 if(reverse) index = - x
756 if(autoscale)
757 plot(index, y, ylim = yrange, type = "l", xlab = "", ylab = "",
758 axes = FALSE, ...)
759 else plot(index, y, type = "l", xlab = "", ylab = "", axes = FALSE, ...)
760 axis(1, at = index, lab = paste(x), tick = FALSE)
761 axis(2)
762 threshold = findThreshold(data, x)
763 axis(3, at = index, lab = paste(format(signif(threshold, 3))),
764 tick = FALSE)
765 box()
766 if(ci && (option != "quantile")) {
767 lines(index, u, lty = 2, col = 2)
768 lines(index, l, lty = 2, col = 2)}
769 if(labels) {
770 title(xlab = "Order Statistics", ylab = ylabel)
771 mtext("Threshold", side = 3, line = 3)}
772
773 # Return Value:
774 invisible(list(x = index, y = y))
775 }
776
777
778 # ------------------------------------------------------------------------------
779
780
781 shaparmPlot =
782 function (x, revert = FALSE, standardize = FALSE, tails = 0.01*(1:10),
783 doplot = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
784 which = c(TRUE, TRUE, TRUE), doprint = TRUE, both.tails = TRUE,
785 xi.range = c(-0.5, 1.5), alpha.range = c(0, 10))
786 { # A function written by D. Wuertz
787
788 # Description:
789 # Displays Pickands, Einmal-Decker-deHaan, and Hill
790 # estimators together with several plot variants.
791
792 # FUNCTION:
793
794 # Settings:
795 select.doplot = which
796 if (revert) x = -x
797 if (standardize) x = (x-mean(x))/sqrt(var(x))
798 ylim1 = xi.range
799 ylim2 = alpha.range
800 z = rep(mean(ylim2), length(tails))
801 ylim1 = xi.range
802 ylim2 = alpha.range
803 p1 = p2 = h1 = h2 = d1 = d2 = m1 = m2 = rep(0,length(tails))
804 for ( i in (1:length(tails)) ) {
805 tail = tails[i]
806
807 # Printing/Plotting Staff:
808 if(doprint) cat("Taildepth: ", tail, "\n")
809 if(select.doplot[1]) {
810 xi = shaparmPickands (x, tail, ylim1, doplot=doplot[i],
811 both.tails, )
812 p1[i] = xi$xi[1]; p2[i] = xi$xi[3] }
813 if(select.doplot[2]) {
814 xi = shaparmHill (x, tail, ylim1, doplot=doplot[i],
815 both.tails)
816 h1[i] = xi$xi[1]; h2[i] = xi$xi[3] }
817 if(select.doplot[3]) {
818 xi = shaparmDEHaan (x, tail, ylim1, doplot=doplot[i],
819 both.tails)
820 d1[i] = xi$xi[1]; d2[i] = xi$xi[3] }
821 if(doprint) {
822 cat("Pickands - Hill - DeckerEinmaalDeHaan: \n")
823 print(c(p1[i], h1[i], d1[i]))
824 if (both.tails) print(c(p2[i], h2[i], d2[i]))}
825 cat("\n") }
826
827
828 # Plot Pickands' Summary:
829 if(select.doplot[1]) {
830 plot (tails, z, type="n", xlab="tail depth", ylab="alpha",
831 ylim=ylim2, main="Pickands Summary")
832 y1 = 1/p1
833 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
834 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
835 points (x1, y1, col=2); lines(x1, y1, col=2)
836 if (both.tails) {
837 y1 = 1/p2
838 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
839 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
840 points (x1, y1, col=3); lines(x1, y1, col=3)} }
841
842 # Plot Hill Summary:
843 if(select.doplot[2]) {
844 plot (tails, z, type="n", xlab="tail depth", ylab="alpha",
845 ylim=ylim2, main="Hill Summary")
846 y1 = 1/h1
847 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
848 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
849 points (x1, y1, col=2); lines(x1, y1, col=2)
850 if (both.tails) {
851 y1 = 1/h2
852 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
853 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
854 points (x1, y1, col=3); lines(x1, y1, col=3)} }
855
856 # Plot Deckers-Einmahl-deHaan Summary
857 if(select.doplot[3]) {
858 plot (tails, z, type="n", xlab="tail depth", ylab="alpha",
859 ylim=ylim2,
860 main="Deckers-Einmahl-deHaan Summary")
861 y1 = 1/d1
862 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
863 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
864 points (x1, y1, col=2); lines(x1, y1, col=2)
865 if (both.tails) {
866 y1 = 1/d2
867 x1 = tails [y1>ylim2[1] & y1<ylim2[2]]
868 y1 = y1 [y1>ylim2[1] & y1<ylim2[2]]
869 points (x1, y1, col=3); lines(x1, y1, col=3)} }
870
871 # Return Value:
872 lower = list(pickands=p1, hill=h1, dehaan=d1)
873 if (both.tails) {
874 upper = list(pickands=p2, hill=h2, dehaan=d2)
875 result = list(tails=tails, lower=lower, upper=upper) }
876 else {
877 result = list(tails=tails, lower=lower) }
878 result
879 }
880
881
882 # ------------------------------------------------------------------------------
883
884
885 shaparmPickands =
886 function (x, tail, yrange, doplot = TRUE, both.tails = TRUE, ...)
887 { # A function written by D. Wuertz
888
889 # FUNCTION:
890
891 # Order Residuals:
892 ordered1 = rev(sort(abs(x[x < 0])))
893 if (both.tails) ordered2 = rev(sort(abs(x[x > 0])))
894 n1 = length(ordered1)
895 if (both.tails) n2 = length(ordered2)
896 ordered1 = ordered1[1:floor(tail*n1)]
897 if (both.tails) ordered2 = ordered2[1:floor(tail*n2)]
898 n1 = length(ordered1)
899 if (both.tails) n2 = length(ordered2)
900
901 # Pickands Estimate:
902 k1 = 1:(n1%/%4)
903 if (both.tails) k2 = 1:(n2%/%4)
904 pickands1 = log ((c(ordered1[k1])-c(ordered1[2*k1])) /
905 (c(ordered1[2*k1])-c(ordered1[4*k1]))) / log(2)
906 if (both.tails) pickands2 = log ((c(ordered2[k2])-c(ordered2[2*k2])) /
907 (c(ordered2[2*k2])-c(ordered2[4*k2]))) / log(2)
908
909 # Prepare Plot:
910 y1 = pickands1[pickands1 > yrange[1] & pickands1 < yrange[2]]
911 x1 = log10(1:length(pickands1))[pickands1 > yrange[1] &
912 pickands1 < yrange[2]]
913 if (both.tails) {
914 y2 = pickands2[pickands2 > yrange[1] & pickands2 < yrange[2]]
915 x2 = log10(1:length(pickands2))[pickands2 > yrange[1] &
916 pickands2 < yrange[2]] }
917 if (doplot) {
918 par(err=-1)
919 plot (x1, y1, xlab="log scale", ylab="xi", ylim=yrange,
920 main="Pickands Estimator", type="n")
921 title(sub=paste("tail depth:", as.character(tail)))
922 lines(x1, y1, type="p", pch=2, col=2)
923 if (both.tails) lines(x2, y2, type="p", pch=6, col=3) }
924
925 # Calculate invers "xi":
926 my1 = mean(y1, na.rm = TRUE)
927 if (both.tails) my2 = mean(y2, na.rm = TRUE)
928 sy1 = sqrt(var(y1, na.rm = TRUE))
929 if (both.tails) sy2 = sqrt(var(y2, na.rm = TRUE))
930
931 # Plot:
932 if (doplot) {
933 par(err=-1)
934 lines(c(x1[1], x1[length(x1)]), c(my1,my1), type="l",
935 lty=1, col=2)
936 if (both.tails) lines(c(x2[1], x2[length(x2)]), c(my2,my2),
937 type="l", lty=1, col=3) }
938
939 # Return Result:
940 result = list(xi=c(my1, sy1))
941 if (both.tails) result = list(xi=c(my1, sy1, my2, sy2))
942 result
943 }
944
945
946 # ------------------------------------------------------------------------------
947
948
949 shaparmHill =
950 function (x, tail, yrange, doplot = TRUE, both.tails = TRUE, ...)
951 { # A Function written by D. Wuertz
952
953 # ORDER RESIDUALS:
954 ordered1 = rev(sort(abs(x[x < 0])))
955 if (both.tails) ordered2 = rev(sort(abs(x[x > 0])))
956 n1 = length(ordered1)
957 if (both.tails) n2 = length(ordered2)
958 ordered1 = ordered1[1:floor(tail*n1)]
959 if (both.tails) ordered2 = ordered2[1:floor(tail*n2)]
960 n1 = length(ordered1)
961 if (both.tails) n2 = length(ordered2)
962 # HILLS ESTIMATE:
963 hills1 = c((cumsum(log(ordered1))/(1:n1)-log(ordered1))[2:n1])
964 if (both.tails) hills2 = c((cumsum(log(ordered2))/(1:n2) -
965 log(ordered2))[2:n2])
966 # PREPARE PLOT:
967 y1 = hills1[hills1 > yrange[1] & hills1 < yrange[2]]
968 x1 = log10(1:length(hills1))[hills1 > yrange[1] &
969 hills1 < yrange[2]]
970 if (both.tails) {
971 y2 = hills2[hills2 > yrange[1] & hills2 < yrange[2]]
972 x2 = log10(1:length(hills2))[hills2 > yrange[1] &
973 hills2 < yrange[2]]}
974 if (doplot) {
975 par(err=-1)
976 plot (x1, y1, xlab="log scale", ylab="xi", ylim=yrange,
977 main="Hill Estimator", type="n")
978 title(sub=paste("tail depth:", as.character(tail)))
979 lines(x1, y1, type="p", pch=2, col=2)
980 if (both.tails) lines(x2, y2, type="p", pch=6, col=3) }
981 # CALCULATE INVERSE XI:
982 my1 = mean(y1, na.rm = TRUE)
983 if (both.tails) my2 = mean(y2, na.rm = TRUE)
984 sy1 = sqrt(var(y1, na.rm = TRUE))
985 if (both.tails) sy2 = sqrt(var(y2, na.rm = TRUE))
986 if (doplot) {
987 par(err=-1)
988 lines(c(x1[1], x1[length(x1)]), c(my1,my1), type="l",
989 lty=1, col=2)
990 if (both.tails) lines(c(x2[1], x2[length(x2)]), c(my2,my2),
991 type="l",lty=1, col=3) }
992 # Return Result:
993 result = list(xi=c(my1, sy1))
994 if (both.tails) result = list(xi=c(my1, sy1, my2, sy2))
995 result
996 }
997
998
999 # ------------------------------------------------------------------------------
1000
1001
1002 shaparmDEHaan =
1003 function (x, tail, yrange, doplot = TRUE, both.tails = TRUE, ...)
1004 { # A function written by D. Wuertz
1005
1006 # ORDER RESIDUALS:
1007 ordered1 = rev(sort(abs(x[x < 0])))
1008 if (both.tails) ordered2 = rev(sort(abs(x[x > 0])))
1009 n1 = length(ordered1)
1010 if (both.tails) n2 = length(ordered2)
1011 ordered1 = ordered1[1:floor(tail*n1)]
1012 if (both.tails) ordered2 = ordered2[1:floor(tail*n2)]
1013 n1 = length(ordered1)
1014 if (both.tails) n2 = length(ordered2)
1015 # DECKERS-EINMAHL-deHAAN ESTIMATE:
1016 ns0 = 1
1017 n1m = n1-1; ns1 = ns0; ns1p = ns1+1
1018 bod1 = c( cumsum(log(ordered1))[ns1:n1m]/(ns1:n1m) -
1019 log(ordered1)[ns1p:n1] )
1020 bid1 = c( cumsum((log(ordered1))^2)[ns1:n1m]/(ns1:n1m) -
1021 2*cumsum(log(ordered1))[ns1:n1m]*log(ordered1)[ns1p:n1]/(ns1:n1m) +
1022 ((log(ordered1))^2)[ns1p:n1] )
1023 dehaan1 = ( 1.0 + bod1 + ( 0.5 / ( bod1^2/bid1 - 1 ) ))
1024 if (both.tails) {
1025 n2m = n2-1; ns2 = ns0; ns2p = ns2+1
1026 bod2 = c( cumsum(log(ordered2))[ns2:n2m]/(ns2:n2m) -
1027 log(ordered2)[ns2p:n2] )
1028 bid2 = c( cumsum((log(ordered2))^2)[ns2:n2m]/(ns2:n2m) -
1029 2*cumsum(log(ordered2))[ns2:n2m]*log(ordered2)[ns2p:n2]/(ns2:n2m) +
1030 ((log(ordered2))^2)[ns2p:n2] )
1031 dehaan2 = ( 1.0 + bod2 + ( 0.5 / ( bod2^2/bid2 - 1 ) )) }
1032 # PREPARE PLOT:
1033 y1 = dehaan1[dehaan1 > yrange[1] & dehaan1 < yrange[2]]
1034 x1 = log10(1:length(dehaan1))[dehaan1 > yrange[1] &
1035 dehaan1 < yrange[2]]
1036 if (both.tails) {
1037 y2 = dehaan2[dehaan2 > yrange[1] & dehaan2 < yrange[2]]
1038 x2 = log10(1:length(dehaan2))[dehaan2 > yrange[1] &
1039 dehaan2 < yrange[2]] }
1040 if (doplot) {
1041 par(err=-1)
1042 plot (x1, y1, xlab="log scale", ylab="xi", ylim=yrange,
1043 main="Deckers - Einmahl - de Haan Estimator", type="n")
1044 title(sub=paste("tail depth:", as.character(tail)))
1045 lines(x1, y1, type="p", pch=2, col=2)
1046 if (both.tails) lines(x2, y2, type="p", pch=6, col=3) }
1047 # CALCULATE INVERSE XI:
1048 my1 = mean(y1, na.rm = TRUE)
1049 if (both.tails) my2 = mean(y2, na.rm = TRUE)
1050 sy1 = sqrt(var(y1, na.rm = TRUE))
1051 if (both.tails) sy2 = sqrt(var(y2, na.rm = TRUE))
1052 if (doplot) {
1053 par(err=-1)
1054 lines(c(x1[1], x1[length(x1)]), c(my1,my1), type="l",
1055 lty=1, col=2)
1056 if (both.tails) lines(c(x2[1], x2[length(x2)]), c(my2, my2),
1057 type = "l", lty = 1, col = 3) }
1058 # Return Result:
1059 result = list(xi = c(my1, sy1))
1060 if (both.tails) result = list(xi=c(my1, sy1, my2, sy2))
1061 result
1062 }
1063
1064
1065 ################################################################################
1066
+0
-122
R/53A-GpdModelling.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 # ##############################################################################
30 # FUNCTION: GPD DISTRIBUTION FAMILY:
31 # dgpd Density for the Generalized Pareto DF [USE FROM EVIS]
32 # pgpd Probability for the Generalized Pareto DF
33 # qgpd Quantiles for the Generalized Pareto DF
34 # rgpd Random variates for the Generalized Pareto DF
35 ################################################################################
36
37
38 dgpd =
39 function(x, xi = 1, mu = 0, beta = 1)
40 { # A function written by Diethelm Wuertz
41
42 # FUNCTION:
43
44 # Density:
45 y = (x - mu)
46 if (xi == 0) {
47 d = (1-exp(-y/beta))/beta }
48 else {
49 d = 1/beta * (1 + (xi*y)/beta)^((-1/xi) - 1) }
50
51 d[y < 0] = 0
52 if (xi < 0) d[y > (-1/xi)] = 0
53
54 # Return Value:
55 d
56 }
57
58
59 # ------------------------------------------------------------------------------
60
61
62 pgpd =
63 function(q, xi = 1, mu = 0, beta = 1)
64 { # A function written by Diethelm Wuertz
65
66 # FUNCTION:
67
68 # Probability:
69 y = (q - mu)
70 if (xi == 0) {
71 p = y/beta + exp(-y/beta) -1 }
72 else {
73 p = (1 - (1 + (xi*y)/beta)^(-1/xi)) }
74
75 p[y < 0] = 0
76 if (xi < 0) p[y > (-1/xi)] = 1
77
78 # Return Value:
79 p
80 }
81
82
83 # ------------------------------------------------------------------------------
84
85
86 qgpd =
87 function(p, xi = 1, mu = 0, beta = 1)
88 { # A function written by Diethelm Wuertz
89
90 # FUNCTION:
91
92 # Quantiles:
93 if (xi == 0)
94 q = mu - beta*log(1-p)
95 else
96 q = mu + (beta/xi) * ((1 - p)^( - xi) - 1)
97
98 # Return Value:
99 q
100 }
101
102
103 # ------------------------------------------------------------------------------
104
105
106 rgpd =
107 function(n, xi = 1, mu = 0, beta = 1)
108 { # A function written by Diethelm Wuertz
109
110 # FUNCTION:
111
112 # Random variates:
113 rvs = mu + (beta/xi) * ((1 - runif(n))^( - xi) - 1)
114
115 # Return Value:
116 rvs
117 }
118
119
120 # ******************************************************************************
121
+0
-417
R/53B-GpdFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: GPD MODELLING FROM EVIS:
31 # gpdSim Simulates GPD rvs
32 # gpdFit Fits GPD Distribution
33 # print.gpd Print Method for object of class "gpd"
34 # plot.gpd Plot Method for object of class "gpd"
35 # summary.gpd Summary Method for object of class "gpd"
36 # FUNCTION: ADDITIONAL PLOTS:
37 # gpdtailPlot Plots Tail Estimate From GPD Model
38 # gpdquantPlot Plots of GPD Tail Estimate of a High Quantile
39 # gpdshapePlot Plots for GPD Shape Parameter
40 # gpdqPlot Adds Quantile Estimates to plot.gpd
41 # gpdsfallPlot Adds Expected Shortfall Estimates to a GPD Plot
42 # FUNCTION: ADDITIONAL FUNCTION:
43 # gpdriskmeasures Calculates Quantiles and Expected Shortfalls
44 ################################################################################
45
46
47 gpdSim =
48 function(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
49 { # A function implemented by Diethelm Wuertz
50
51 # Description:
52 # Generates random variates from a GPD distribution
53
54
55 # FUNCTION:
56
57 # Simulate:
58 rgpd(n = n, xi = model$shape, mu = model$location, beta = model$scale)
59 }
60
61
62 # ------------------------------------------------------------------------------
63
64
65 gpdFit =
66 function(x, threshold = NA, nextremes = NA, type = c("mle", "pwm"),
67 information = c("observed", "expected"), ...)
68 { # A function implemented by Diethelm Wuertz
69
70 # Description:
71 # Returns an object of class `"gpd"' representing the fit of a
72 # generalized Pareto model to excesses over a high threshold
73
74 # Notes:
75 # This is a wrapper to EVIR's 'gpd' function.
76
77 # FUNCTION:
78
79 # Make the fit:
80 call = match.call()
81 type = type[1]
82 # if (is.na(threshold) & is.na(nextremes)) threshold = min(x)
83 if (type == "mle") {
84 type = "ml"
85 }
86 fitted = gpd(data = x, threshold = threshold, nextremes = nextremes,
87 method = type, information = information, ...)
88
89 # Residuals:
90 xi = fitted$par.ests["xi"]
91 beta = fitted$par.ests["beta"]
92 excess = as.numeric(fitted$data) - fitted$threshold
93 residuals = log(1 + (xi * excess)/beta)/xi
94
95 # Make Unique:
96 fit = list()
97 fit$fit = fitted
98 fit$call = call
99 fit$type = c("gpd", type[1])
100 fit$par.ests = fitted$par.ests
101 fit$par.ses = fitted$par.ses
102 fit$residuals = residuals
103 fit$fitted.values = fitted$data - residuals
104 fit$llh = fitted$nllh.final
105 fit$converged = fitted$converged
106
107 # Return Value:
108 class(fit) = "gpdFit"
109 fit
110 }
111
112
113 # ------------------------------------------------------------------------------
114
115
116 print.gpdFit =
117 function(x, ...)
118 { # A function implemented by Diethelm Wuertz
119
120 # Description:
121 # Print Method for an object of class 'gpdFit'
122
123 # FUNCTION:
124
125 # Function Call:
126 cat("\nCall:\n")
127 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
128
129 # Estimation Type:
130 cat("\nEstimation Type:", x$type, "\n")
131
132 # Estimated Parameters:
133 cat("\nEstimated Parameters:\n")
134 print(x$par.ests)
135 cat("\n")
136
137 # Return Value:
138 invisible(x)
139 }
140
141
142 # ------------------------------------------------------------------------------
143
144
145 plot.gpdFit =
146 function(x, which = "all", ...)
147 { # A function implemented by Diethelm Wuertz
148
149 # Description:
150 # Plot method for objects of class 'gpdFit'
151
152 # FUNCTION:
153
154 # Plot Functions:
155 plot.1 <<- function(x, ...) {
156 fit = x
157 data = fit$fit$data
158 xi = fit$par.ests[1]
159 beta = fit$par.est[2]
160 threshold = fit$fit$threshold
161 optlog = NA
162 extend = 1.5
163 labels = TRUE
164 # Start:
165 plotmin = threshold
166 if (extend <= 1) stop("extend must be > 1")
167 plotmax = max(data) * extend
168 xx = seq(from = 0, to = 1, length = 1000)
169 z = qgpd(xx, xi, threshold, beta)
170 z = pmax(pmin(z, plotmax), plotmin)
171 ypoints = ppoints(sort(data))
172 y = pgpd(z, xi, threshold, beta)
173 type = "eplot"
174 if (!is.na(optlog)) alog = optlog
175 else alog = "x"
176 if (alog == "xy") stop("Double log does not make much sense")
177 yylab = "Fu(x-u)"
178 shape = xi
179 scale = beta
180 location = threshold
181 plot(sort(data), ypoints, xlim = range(plotmin, plotmax),
182 ylim = range(ypoints, y, na.rm = TRUE), xlab = "",
183 ylab = "", log = alog, axes = TRUE,
184 main = "Excess Distribution", ...)
185 lines(z[y >= 0], y[y >= 0])
186 xxlab = "x"
187 if (alog == "x" || alog == "xy" || alog == "yx")
188 xxlab = paste(xxlab, "(on log scale)")
189 if (alog == "xy" || alog == "yx" || alog == "y")
190 yylab = paste(yylab, "(on log scale)")
191 title(xlab = xxlab, ylab = yylab) }
192 plot.2 <<- function(x, ...) {
193 fit = x
194 data = fit$fit$data
195 xi = fit$par.ests[1]
196 beta = fit$par.est[2]
197 threshold = fit$fit$threshold
198 optlog = NA
199 extend = 1.5 #; if(extend <= 1) stop("extend must be > 1")
200 labels = TRUE
201 # Start:
202 plotmin = threshold
203 if (extend <= 1) stop("extend must be > 1")
204 plotmax = max(data) * extend
205 xx = seq(from = 0, to = 1, length = 1000)
206 z = qgpd(xx, xi, threshold, beta)
207 z = pmax(pmin(z, plotmax), plotmin)
208 ypoints = ppoints(sort(data))
209 y = pgpd(z, xi, threshold, beta)
210 type = "tail"
211 if (!is.na(optlog)) alog = optlog
212 else alog = "xy"
213 prob = fit$fit$p.less.thresh
214 ypoints = (1 - prob) * (1 - ypoints)
215 y = (1 - prob) * (1 - y)
216 yylab = "1-F(x)"
217 shape = xi
218 scale = beta * (1 - prob)^xi
219 location = threshold - (scale * ((1 - prob)^( - xi) - 1))/xi
220 plot(sort(data), ypoints, xlim = range(plotmin, plotmax),
221 ylim = range(ypoints, y, na.rm = TRUE), xlab = "",
222 ylab = "", log = alog, axes = TRUE,
223 main = "Tail of Underlying Distribution", ...)
224 lines(z[y >= 0], y[y >= 0])
225 xxlab = "x"
226 if (alog == "x" || alog == "xy" || alog == "yx")
227 xxlab = paste(xxlab, "(on log scale)")
228 if (alog == "xy" || alog == "yx" || alog == "y")
229 yylab = paste(yylab, "(on log scale)")
230 title(xlab = xxlab, ylab = yylab) }
231 plot.3 <<- function(x, ...) {
232 res = x$residuals
233 plot(res,
234 ylab = "Residuals",
235 xlab = "Ordering",
236 main = "Scatterplot of Residuals", ...)
237 lines(lowess(1:length(res), res)) }
238 plot.4 <<- function(x, ...) {
239 qplot(x$residuals,
240 main = "QQ-Plot of Residuals", ...) }
241
242 # Plot:
243 interactivePlot(
244 x = x,
245 choices = c(
246 "Excess Distribution",
247 "Tail of Underlying Distribution",
248 "Scatterplot of Residuals",
249 "QQ-Plot of Residuals"),
250 plotFUN = c(
251 "plot.1",
252 "plot.2",
253 "plot.3",
254 "plot.4"),
255 which = which)
256
257 # Return Value:
258 invisible(x)
259 }
260
261
262 # ------------------------------------------------------------------------------
263
264
265 summary.gpdFit =
266 function(object, doplot = TRUE, which = "all", ...)
267 { # A function written by Diethelm Wuertz
268
269 # Description:
270 # Summary method for objects of class "gpdFit"
271
272 # FUNCTION:
273
274 # Print:
275 print(object, ...)
276
277 # Summary:
278 # For MLE print additionally:
279 cat("\nStandard Deviations:\n"); print(object$par.ses)
280 cat("\nLog-Likelihood Value: ", object$llh)
281 cat("\nType of Convergence: ", object$conv, "\n")
282 cat("\n")
283
284 # Plot:
285 if (doplot) plot(object, which = which, ...)
286 cat("\n")
287
288 # Return Value:
289 invisible(object)
290 }
291
292
293 # ******************************************************************************
294
295
296 gpdtailPlot =
297 function(fit, optlog = NA, extend = 1.5, labels = TRUE, ...)
298 { # A function implemented by Diethelm Wuertz
299
300 # Description:
301 # Plots Tail Estimate From GPD Model
302
303 # FUNCTION:
304
305 # Return Value:
306 tailplot(x = fit$fit, optlog = optlog, extend = extend,
307 labels = labels, ...)
308 }
309
310
311 # ------------------------------------------------------------------------------
312
313
314 gpdquantPlot =
315 function(data, p = 0.99, models = 30, start = 15, end = 500,
316 reverse = TRUE, ci = 0.95, autoscale = TRUE, labels = TRUE, ...)
317 { # A function implemented by Diethelm Wuertz
318
319 # Description:
320 # Plots of GPD Tail Estimate of a High Quantile
321
322 # FUNCTION:
323
324 # Return Value:
325 quant(data = data, p = p, models = models, start = start, end = end,
326 reverse = reverse, ci = ci, auto.scale = autoscale, labels = labels,
327 ...)
328 }
329
330
331 # ------------------------------------------------------------------------------
332
333
334 gpdshapePlot =
335 function(data, models = 30, start = 15, end = 500, reverse = TRUE,
336 ci = 0.95, autoscale = TRUE, labels = TRUE, ...)
337 { # A function implemented by Diethelm Wuertz
338
339 # Description:
340 # Plots for GPD Shape Parameter
341
342 # FUNCTION:
343
344 # Return Value:
345 shape(data = data, models = models, start = start, end = end,
346 reverse = reverse, ci = ci, auto.scale = autoscale,
347 labels = labels, ...)
348 }
349
350
351 # ------------------------------------------------------------------------------
352
353
354 gpdqPlot =
355 function(x, pp = 0.99, ci.type = c("likelihood", "wald"), ci.p = 0.95,
356 like.num = 50)
357 { # A function implemented by Diethelm Wuertz
358
359 # Description:
360 # Adds Quantile Estimates to plot.gpd
361
362 # Arguments:
363 # x - an object of class 'gpdFit'
364 # pp - the probability level
365
366 # FUNCTION:
367
368 # Return Value:
369 gpd.q(x = x, pp = pp, ci.type = ci.type, ci.p = ci.p, like.num = like.num)
370 }
371
372
373 # ------------------------------------------------------------------------------
374
375
376 gpdsfallPlot =
377 function(x, pp = 0.99, ci.p = 0.95, like.num = 50)
378 { # A function implemented by Diethelm Wuertz
379
380 # Description:
381 # Adds Expected Shortfall Estimates to a GPD Plot
382
383 # Arguments:
384 # x - an object of class 'gpdFit'
385 # pp - the probability level
386
387 # FUNCTION:
388
389 # Return Value:
390 gpd.sfall(x = x, pp = pp, ci.p = ci.p, like.num = like.num)
391 }
392
393
394 # ------------------------------------------------------------------------------
395
396
397 gpdriskmeasures =
398 function(x, plevels = c(0.99, 0.995, 0.999, 0.9995, 0.9999))
399 { # A function implemented by Diethelm Wuertz
400
401 # Description:
402 # Calculates Quantiles and Expected Shortfalls
403
404 # Arguments:
405 # x - an object of class 'gpdFit'
406 # p - a numeric value or vector of probability levels
407
408 # FUNCTION:
409
410 # Return Value:
411 as.data.frame(riskmeasures(x = x$fit, p = plevels))
412 }
413
414
415 # ******************************************************************************
416
+0
-285
R/53C-PotFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: POT MODELLING FROM EVIS:
31 # potSim Peaks over a threshold from arbitrary series
32 # potFit Fits with POT method
33 # print.potFit Print Method for object of class "potFit"
34 # plot.potFit Print Method for object of class "potFit"
35 # summary.potFit Summary Method for object of class "potFit"
36 # REQUIRES:
37 # ts Package ts (is preloaded)
38 ################################################################################
39
40
41 potSim =
42 function(x, threshold, nextremes = NA, run = NA)
43 { # A function implemented by Diethelm Wuertz
44
45 # Description:
46 # Generates from an arbitray rvs sequence a series with
47 # the peaks over a threshold
48
49 # Settings:
50 data = x
51 n = length(as.numeric(data))
52 times = attributes(data)$times
53 if (is.null(times)) {
54 times = 1:n
55 attributes(data)$times = times
56 start = 1
57 end = n
58 span = end - start}
59 else {
60 start = times[1]
61 end = times[n]
62 span = as.numeric(difftime(as.POSIXlt(times)[n], as.POSIXlt(times)[1],
63 units = "days"))}
64
65 if (is.na(nextremes) && is.na(threshold))
66 stop("Enter either a threshold or the number of upper extremes")
67 if (!is.na(nextremes) && !is.na(threshold))
68 stop("Enter EITHER a threshold or the number of upper extremes")
69 if (!is.na(nextremes))
70 threshold = findthresh(as.numeric(data), nextremes)
71 if (threshold > 10) {
72 factor = 10^(floor(log10(threshold)))
73 cat(paste("If singularity problems occur divide data",
74 "by a factor, perhaps", factor, "\n")) }
75
76 exceedances.its = structure(data[data > threshold], times = times[data >
77 threshold])
78 n.exceed = length(as.numeric(exceedances.its))
79 p.less.thresh = 1 - n.exceed/n
80 if (!is.na(run)) {
81 exceedances.its = decluster(exceedances.its, run, picture)
82 n.exceed = length(exceedances.its) }
83 intensity = n.exceed/span
84 exceedances = as.numeric(exceedances.its)
85
86
87 # Return Value:
88 exceedances
89 }
90
91
92 # ------------------------------------------------------------------------------
93
94
95 potFit =
96 function(x, threshold = NA, nextremes = NA, run = NA, ...)
97 { # A function implemented by Diethelm Wuertz
98
99 # Description:
100 # Parameter Estimation for the POT model.
101
102 # FUNCTION:
103
104 # Call pot() from evir:
105 call = match.call()
106 fitted = pot(data = x, threshold = threshold, nextremes = nextremes,
107 run = run, picture = FALSE, ...)
108
109 # Compute Residuals:
110 xi = fitted$par.ests[1]
111 beta = fitted$par.ests[4]
112 threshold = fitted$threshold
113 fitted$residuals =
114 as.vector(log(1 + (xi * (fitted$data - threshold))/beta)/xi)
115
116 # Gaps:
117 x = fitted
118 x$rawdata = x$data
119 n = length(as.numeric(x$rawdata))
120 x$times = attributes(x$rawdata)$times
121 if (is.character(x$times) || inherits(x$times, "POSIXt") ||
122 inherits(x$times, "date") || inherits(x$times, "dates")) {
123 x$times = as.POSIXlt(x$times)
124 x$gaps = as.numeric(difftime(x$times[2:n], x$times[1:(n - 1)],
125 units = "days")) * x$intensity }
126 else {
127 x$times = 1:n
128 x$gaps = as.numeric(diff(x$times)) * x$intensity }
129 fitted$times = x$times
130 fitted$rawdata = x$rawdata
131 fitted$gaps = x$gaps
132
133 # Add:
134 fit = list()
135 fit$fit = fitted
136 fit$call = call
137 fit$type = c("pot", "mle")
138 fit$par.ests = fitted$par.ests
139 fit$par.ses = fitted$par.ses
140 fit$residuals = fitted$residuals
141 fit$fitted.values = fitted$data - fitted$residuals
142 fit$llh = fitted$nllh.final
143 fit$converged = fitted$converged
144
145 # Return Value:
146 class(fit) = "potFit"
147 fit
148 }
149
150
151 # ******************************************************************************
152
153
154 print.potFit =
155 function(x, ...)
156 { # A function implemented by Diethelm Wuertz
157
158 # Description:
159 # Print Method for object of class "potFit"
160
161 # FUNCTION:
162
163 # Function Call:
164 cat("\nCall:\n")
165 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
166
167 # Estimation Type:
168 cat("\nEstimation Type:", x$type, "\n")
169
170 # Estimated Parameters:
171 cat("\nEstimated Parameters:\n")
172 print(x$par.ests)
173 cat("\n")
174
175 # Decluster Run Length:
176 if (!is.na(fit$fit$run))
177 cat("\nDecluster Runlength:", x$fit$run, "\n")
178
179 # Return Value:
180 invisible(x)
181 }
182
183
184 # ------------------------------------------------------------------------------
185
186
187 plot.potFit =
188 function(x, which = "all", ...)
189 { # A function implemented by Diethelm Wuertz
190
191 # Description:
192 # Plot method for objects of class "potFit".
193
194 # FUNCTION:
195
196 # Plot functions:
197 plot.1 <<- function(x, ...) {
198 plot(x$times, x$rawdata , type = "h",
199 main = "Point Process of Exceedances", ...) }
200 plot.2 <<- function(x, ...) {
201 plot(x$gaps, ylab = "Gaps", xlab = "Ordering",
202 main = "Scatterplot of Gaps", ...)
203 lines(lowess(1:length(x$gaps), x$gaps)) }
204 plot.3 <<- function(x, ...) {
205 qplot(x$gaps,
206 main = "QQ-Plot of Gaps", ...) }
207 plot.4 <<- function(x, ...) {
208 acf(x$gaps, lag.max=20,
209 main = "ACF of Gaps", ...) }
210 plot.5 <<- function(x, ...) {
211 plot(x$residuals, ylab = "Residuals", xlab = "Ordering",
212 main = "Scatterplot of Residuals", ...)
213 lines(lowess(1:length(x$residuals), x$residuals)) }
214 plot.6 <<- function (x, ...) {
215 qplot(x$residuals,
216 main = "QQ-Plot of Residuals", ...) }
217 plot.7 <<- function (x, ...) {
218 acf(x$residuals, lag.max = 20,
219 main = "ACF of Residuals", ...) }
220 fit <<- fit; plot.8 <<- function (x, ...) {
221 if (which == "ask") {
222 plot.gpd(x)
223 plot.potFit(fit, which = "ask") } }
224
225 # Plot:
226 interactivePlot(
227 x = x$fit,
228 choices = c(
229 "Point Process of Exceedances",
230 "Scatterplot of Gaps",
231 "QQ-Plot of Gaps",
232 "ACF of Gaps",
233 "Scatterplot of Residuals",
234 "QQ-Plot of Residuals",
235 "ACF of Residuals",
236 "GOTO GPD Plots"),
237 plotFUN = c(
238 "plot.1",
239 "plot.2",
240 "plot.3",
241 "plot.4",
242 "plot.5",
243 "plot.6",
244 "plot.7",
245 "plot.8"),
246 which = which)
247
248 # Return Value:
249 invisible(x)
250 }
251
252
253 # ------------------------------------------------------------------------------
254
255
256 summary.potFit =
257 function(object, doplot = TRUE, which = "all", ...)
258 { # A function implemented by Diethelm Wuertz
259
260 # Description:
261 # Summary Method for object of class "potFit"
262
263 # FUNCTION:
264
265 # Print:
266 print(object, ...)
267
268 # Summary:
269 cat("\nStandard Deviations:\n"); print(object$par.ses)
270 cat("\nLog-Likelihood Value: ", object$llh)
271 cat("\nType of Convergence: ", object$converged, "\n")
272 cat("\n")
273
274 # Plot:
275 if (doplot) plot.potFit(object, which = which, ...)
276 cat("\n")
277
278 # Return Value:
279 invisible(object)
280 }
281
282
283 # ******************************************************************************
284
+0
-305
R/54A-ExtremesGlm.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: GEV MODELLING FROM ISMEV:
31 # gevglmFit Fits GEV Distribution
32 # print.gevglmFit Print Method for object of class "gevglm"
33 # plot.gevglmFit Plot Method for object of class "gevglm"
34 # summary.gevglmFit Summary Method for object of class "gevglm"
35 # FUNCTION: ADDITIONAL PLOTS:
36 # gevglmprofPlot Profile Log-likelihoods for Stationary GEV Models
37 # gevglmprofxiPlot Profile Log-likelihoods for Stationary GEV Models
38 ################################################################################
39
40
41 gevglmFit =
42 function(x, y = NULL, gumbel = FALSE, mul = NULL, sigl = NULL, shl = NULL,
43 mulink = identity, siglink = identity, shlink = identity, show = FALSE,
44 method = "Nelder-Mead", maxit = 10000, ...)
45 { # A function written by Diethelm Wuertz
46
47 # Description:
48 # Fits GEV Distribution
49
50 # Note:
51 # This is a function wrapper to the functions 'gev.fit' and
52 # 'gum.fit' which are part of the R package 'ismev'.
53
54 # FUNCTION:
55
56 # Fit - Use gev.fit() and gum.fit() from R's ismev Package:
57 call = match.call()
58 if (gumbel) {
59 fitted = gum.fit(xdat = x, ydat = y, mul = mul, sigl = sigl,
60 mulink = mulink, siglink = siglink, show = show,
61 method = method, maxit = maxit, ...) }
62 else {
63 fitted = gev.fit(xdat = x, ydat = y, mul = mul, sigl = sigl, shl = shl,
64 mulink = mulink, siglink = siglink, shlink = shlink, show = show,
65 method = method, maxit = maxit, ...) }
66 fitted$gumbel = gumbel
67
68 # Standard Errors and Covariance Matrix:
69 if (gumbel) {
70 # Parameters - We take the same order as in gevFit:
71 mle = rev(fitted$mle)
72 names(mle) = c("sigma", "mu")
73 se = rev(fitted$se)
74 names(se) = c("sigma", "mu")
75 covar = fitted$cov
76 covar[1,1] = fitted$cov[2,2]
77 covar[2,2] = fitted$cov[1,1] }
78 else {
79 # Parameters - We take the same order as in gevFit:
80 mle = rev(fitted$mle)
81 names(mle) = c("xi", "sigma", "mu")
82 se = rev(fitted$se)
83 names(se) = c("xi", "sigma", "mu")
84 covar = fitted$cov
85 covar[1,1] = fitted$cov[3,3]
86 covar[3,3] = fitted$cov[1,1]
87 covar[1,2] = covar[2,1] = fitted$cov[2,3]
88 covar[2,3] = covar[3,2] = fitted$cov[1,2] }
89 fitted$covar = covar
90
91 # Calculate Residuals:
92 if (gumbel) {
93 # GUMBEL:
94 xi = 0
95 sigma = mle[1]
96 mu = mle[2]
97 residuals = exp( - exp( - (fitted$data - mu)/sigma)) }
98 else {
99 # GEV:
100 xi = fitted$mle[1]
101 sigma = fitted$mle[2]
102 mu = fitted$mle[3]
103 residuals = (1 + (xi * (fitted$data - mu))/sigma)^(-1/xi) }
104
105 # Add:
106 fit = list()
107 fit$fit = fitted
108 fit$call = match.call()
109 fit$type = c(if(gumbel) "gumglm" else "gevglm", "mle")
110 fit$par.ests = mle
111 fit$par.ses = se
112 fit$residuals = residuals
113 fit$fitted.values = x - residuals
114 fit$llh = fitted$nllh
115 fit$converged = fitted$conv
116
117 # Return Value:
118 class(fit) = "gevglmFit"
119 fit
120 }
121
122
123 # ******************************************************************************
124
125
126 print.gevglmFit =
127 function(x, ...)
128 { # A function implemented by Diethelm Wuertz
129
130 # Description:
131 # Print method for objects of class 'gevglmFit'
132
133 # FUNCTION:
134
135 # Function Call:
136 cat("\nCall:\n")
137 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
138
139 # Estimation Type:
140 cat("\nEstimation Type:", x$type, "\n")
141
142 # Fitted Parameters:
143 cat("\nEstimated Parameters:\n")
144 print(x$par.ests)
145 cat("\n")
146
147 # Return Value:
148 invisible(x)
149 }
150
151
152 # ------------------------------------------------------------------------------
153
154
155 plot.gevglmFit =
156 function(x, which = "ask", ...)
157 { # A function implemented by Diethelm Wuertz
158
159 # Description:
160 # Plot method for objects of class 'gevglmFit'
161
162 # FUNCTION:
163
164 # Settings:
165 fit = x
166
167 # Internal "plot.n" Function:
168 plot.1 <<- function(x, ...) {
169 if (x$gumbel) x$mle = c(x$mle, 0)
170 gev.pp(x$mle, x$data) }
171 plot.2 <<- function(x, ...) {
172 if (x$gumbel) x$mle = c(x$mle, 0)
173 gev.qq(x$mle, x$data) }
174 plot.3 <<- function(x, ...) {
175 if (x$gumbel) {
176 fit$mle = c(x$mle, 0)
177 gum.rl(x$mle, x$cov, x$data) }
178 else {
179 gev.rl(x$mle, x$cov, x$data) } }
180 plot.4 <<- function(x, ...) {
181 if (x$gumbel) x$mle = c(x$mle, 0)
182 gev.his(x$mle, x$data) }
183 plot.5 <<- function(x, ...) {
184 n = length(x$data)
185 z = (1:n)/(n + 1)
186 plot(z, exp( - exp( - sort(x$data))),
187 xlab = "empirical", ylab = "model")
188 abline(0, 1, col = 4)
189 title("Residual Probability Plot") }
190 plot.6 <<- function(x, ...) {
191 n = length(x$data)
192 z = (1:n)/(n + 1)
193 plot( - log( - log(z)), sort(x$data),
194 xlab = "empirical", ylab = "model")
195 abline(0, 1, col = 4)
196 title("Residual Quantile Plot (Gumbel Scale)") }
197
198 # Plot:
199 if (fit$fit$trans) {
200 # Non-Stationary Plots: plot 11-12
201 interactivePlot(
202 x = x$fit,
203 choices = c(
204 "Residual Probability Plot",
205 "Residual Quantile Plot"),
206 plotFUN = c(
207 "plot.5",
208 "plot.6"),
209 which = which) }
210 else {
211 # Stationary Plots: plot 01-04
212 interactivePlot(
213 x = x$fit,
214 choices = c(
215 "Residual Probability Plot",
216 "Residual Quantile Plot",
217 "Return Level Plot",
218 "Density Plot"),
219 plotFUN = c(
220 "plot.1",
221 "plot.2",
222 "plot.3",
223 "plot.4"),
224 which = which) }
225
226 # Return Value:
227 invisible(x)
228 }
229
230
231 # ------------------------------------------------------------------------------
232
233
234 summary.gevglmFit =
235 function(object, doplot = TRUE, which = "all", ...)
236 { # A function implemented by Diethelm Wuertz
237
238 # Description:
239 # Summary method for objects of class 'gevglmFit'
240
241 # FUNCTION:
242
243 # Print:
244 print(object, ...)
245
246 # Summary:
247 cat("\nStandard Deviations:\n"); print(object$par.ses)
248 cat("\nLog-Likelihood Value: ", object$llh)
249 cat("\nType of Convergence: ", object$converged, "\n")
250 cat("\n")
251
252 # Plot:
253 if (doplot) plot(object, which = which, ...)
254 cat("\n")
255
256 # Return Result
257 invisible(object)
258 }
259
260
261 # ******************************************************************************
262
263
264 gevglmprofPlot =
265 function(object, m, xlow, xup, conf = 0.95, nint = 100)
266 { # A function implemented by Diethelm Wuertz
267
268 # Description:
269 # Profile Log-likelihoods for Stationary GEV Models.
270
271 # FUNCTION:
272
273 # Compute:
274 if (object$fit$gumbel) {
275 stop("Not for Gumbel type distributions") }
276 else {
277 gev.prof(z = object$fit, m = m, xlow = xlow, xup = xup , conf = conf,
278 nint = nint) }
279 }
280
281
282 # ------------------------------------------------------------------------------
283
284
285 gevglmprofxiPlot =
286 function(object, xlow, xup, conf = 0.95, nint = 100)
287 { # A function implemented by Diethelm Wuertz
288
289 # Description:
290 # Profile Log-likelihoods for Stationary GEV Models.
291
292 # FUNCTION:
293
294 # Compute:
295 if (object$fit$gumbel) {
296 stop("Not for Gumbel type distributions") }
297 else {
298 gev.profxi(z = object$fit, xlow = xlow, xup = xup, conf = conf,
299 nint = nint) }
300 }
301
302
303 # ******************************************************************************
304
+0
-252
R/54B-GpdGlmFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: GPD MODELLING FROM ISMEV:
31 # gpdglmFit Fits GPD Distribution
32 # print.gpdglmFit Print Method for object of class "gpdglm"
33 # plot.gpdglmFit Plot Method for object of class "gpdglm"
34 # summary.gpdglmFit Summary Method for object of class "gevglm"
35 # FUNCTION: ADDITIONAL PLOTS:
36 # gpdglmprofPlot Profile Log-likelihoods for Stationary GPD Models
37 # gpdglmprofxiPlot Profile Log-likelihoods for Stationary GPD Models
38 ################################################################################
39
40
41 gpdglmFit =
42 function(x, threshold = min(x), npy = 365, y = NULL, sigl = NULL, shl = NULL,
43 siglink = identity, shlink = identity, show = FALSE, method = "Nelder-Mead",
44 maxit = 10000, ...)
45 { # A function implemented by Diethelm Wuertz
46
47 # Description:
48
49 # FUNCTION:
50
51 # Function Call:
52 call = match.call()
53 # Fit Parameters:
54 fitted = gpd.fit(xdat = x, threshold = threshold, npy = npy, ydat = y,
55 sigl = sigl, shl = shl, siglink = siglink, shlink = shlink,
56 show = show, method = method, maxit = maxit, ...)
57 # Add names attribute:
58 names(fitted$se) = names(fitted$mle) = c("sigma", "mle")
59
60 # Add:
61 fit = list()
62 fit$fit = fitted
63 fit$call = call
64 fit$type = c("gpdglm", "mle")
65 fit$par.ests = fitted$mle
66 fit$par.ses = fitted$se
67 fit$residuals = fitted$residuals
68 fit$fitted.values = x - fitted$residuals
69 fit$llh = fitted$nllh
70 fit$converged = fitted$conv
71
72 # Return Value:
73 class(fit) = "gpdglmFit"
74 fit
75 }
76
77
78 # ------------------------------------------------------------------------------
79
80
81 print.gpdglmFit =
82 function(x, ...)
83 { # A function implemented by Diethelm Wuertz
84
85 # Description:
86 # Print Method for an object of class 'gpdglmFit'
87
88 # FUNCTION:
89
90 # Print Call:
91 cat("\nCall:\n")
92 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
93
94 if (fit$fit$trans) {
95 # Still to do:
96 print.default(x) }
97 else {
98 # Estimation Type:
99 cat("\nEstimation Type:", x$type, "\n")
100 # Fitted Parameters:
101 cat("\nEstimated Parameters:\n")
102 print(x$par.ests)
103 cat("\n") }
104
105 # Return Value:
106 invisible(x)
107 }
108
109
110 # ------------------------------------------------------------------------------
111
112
113 plot.gpdglmFit =
114 function(x, which = "all", ...)
115 { # A function implemented by Diethelm Wuertz
116
117 # Description:
118 # Print Method for an object of class 'gpdglmFit'
119
120 # FUNCTION:
121
122 # Plot Functions:
123 if(x$fit$trans) {
124 plot.1 <<- function(x, ...) {
125 n = length(x$data)
126 plot(
127 x = (1:n)/(n + 1),
128 y = 1 - exp( - sort(x$data)),
129 xlab = "Empirical",
130 ylab = "Model")
131 abline(0, 1, col = 4)
132 title("Residual Probability Plot") }
133 plot.2 <<- function(x, ...) {
134 n = length(x$data)
135 plot(
136 x = - log( 1 - (1:n)/(n+1) ),
137 y = sort(x$data),
138 ylab = "Empirical",
139 xlab = "Model")
140 abline(0, 1, col = 4)
141 title("Residual Quantile Plot (Exptl. Scale)") } }
142 else {
143 plot.1 <<- function(x, ...) {
144 gpd.pp(x$mle, x$threshold, x$data) }
145 plot.2 <<- function(x, ...) {
146 gpd.qq(x$mle, x$threshold, x$data) }
147 plot.3 <<- function(x, ...) {
148 gpd.rl(x$mle, x$threshold, x$rate, x$n, x$npy,
149 x$cov, x$data, x$xdata) }
150 plot.4 <<- function(x, ...) {
151 gpd.his(x$mle, x$threshold, x$data) } }
152
153 # Plot:
154 if (fit$fit$trans) {
155 interactivePlot(
156 x = x$fit,
157 choices = c(
158 "Excess Distribution",
159 "QQ-Plot of Residuals"),
160 plotFUN = c(
161 "plot.1",
162 "plot.2"),
163 which = which) }
164 else {
165 interactivePlot(
166 x = x$fit,
167 choices = c(
168 "Probability Plot",
169 "Quantile Plot",
170 "Return Level Plot",
171 "Histogram Plot"),
172 plotFUN = c(
173 "plot.1",
174 "plot.2",
175 "plot.3",
176 "plot.4"),
177 which = which) }
178
179 # Return Value:
180 invisible(x)
181 }
182
183
184 # ------------------------------------------------------------------------------
185
186
187 summary.gpdglmFit =
188 function(object, doplot = TRUE, which = "all", ...)
189 { # A function written by Diethelm Wuertz
190
191 # Description:
192 # Summary Method for an object of class 'gpdglmFit'
193
194 # FUNCTION:
195
196 # Print:
197 print(object, ...)
198
199 # Summary:
200 cat("\nStandard Deviations:\n"); print(object$par.ses)
201 cat("\nLog-Likelihood Value: ", object$llh)
202 cat("\nType of Convergence: ", object$converged, "\n")
203 cat("\n")
204
205 # Plot:
206 if (doplot) plot(object, which = which, ...)
207 cat("\n")
208
209 # Return Value:
210 invisible(object)
211 }
212
213
214 # ******************************************************************************
215
216
217 gpdglmprofPlot =
218 function(fit, m, xlow, xup, conf = 0.95, nint = 100, ...)
219 { # A function implemented by Diethelm Wuertz
220
221 # Description:
222 # Profile Log-likelihoods for Stationary GPD Models
223
224 # FUNCTION:
225
226 # Compute:
227 gpd.prof(z = fit$fit, m = m, xlow = xlow, xup = xup , conf = conf,
228 nint = nint)
229 }
230
231
232 # ------------------------------------------------------------------------------
233
234
235 gpdglmprofxiPlot =
236 function(fit, xlow, xup, conf = 0.95, nint = 100, ...)
237 { # A function implemented by Diethelm Wuertz
238
239 # Description:
240 # Profile Log-likelihoods for Stationary GPD Models
241
242 # FUNCTION:
243
244 # Compute:
245 gpd.profxi(z = fit$fit, xlow = xlow, xup = xup, conf = conf,
246 nint = nint, ...)
247 }
248
249
250 # ******************************************************************************
251
+0
-206
R/54C-PPFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: POINT PROCESS MODELLING FROM ISMEV:
31 # ppFit Fits Point Process Model
32 # print.ppFit Print Method for object of class "ppFit"
33 # plot.ppFit Plot Method for object of class "ppFit"
34 # summary.ppFit Summary Method for object of class "ppFit"
35 ################################################################################
36
37
38 ppFit =
39 function(x, threshold, npy = 365, y = NULL, mul = NULL, sigl = NULL,
40 shl = NULL, mulink = identity, siglink = identity, shlink = identity,
41 method = "Nelder-Mead", maxit = 10000, ...)
42 { # A function implemented by Diethelm Wuertz
43
44 # Description:
45
46 # FUNCTION:
47
48 # Function Call:
49 call = match.call()
50 # Fit Parameters:
51 fitted = pp.fit(xdat = x, threshold = threshold, npy = npy, ydat = y,
52 mul = mul, sigl = sigl, shl = shl, mulink = mulink, siglink = siglink,
53 shlink = shlink, show = FALSE, method = method, maxit = maxit, ...)
54 names(fitted$mle) =names(fitted$se) = c("xi", "sigma", "mu")
55 # Compute Residuals:
56 residuals = NA
57 # cat("\nVariance Covariance Matrix:\n")
58 # covar = fit$cov
59 # covar[1,1] = fit$cov[3,3]
60 # covar[3,3] = fit$cov[1,1]
61 # covar[1,2] = covar[2,1] = fit$cov[2,3]
62 # covar[2,3] = covar[3,2] = fit$cov[1,2]
63 # print(covar)
64
65 # Add:
66 fit= list()
67 fit$fit = fitted
68 fit$call = call
69 fit$type = c("pp", "mle")
70 fit$par.ests = fitted$mle
71 fit$par.ses = fitted$se
72 fit$residuals = residuals
73 fit$fitted.values = x - residuals
74 fit$llh = fitted$nllh
75 fit$converged = fitted$conv
76
77 # Return Value:
78 class(fit) = "ppFit"
79 fit
80 }
81
82
83 # ------------------------------------------------------------------------------
84
85
86 print.ppFit =
87 function(x, ...)
88 { # A function implemented by Diethelm Wuertz
89
90 # Description:
91 # Print method for an object of class 'ppFit'
92
93 # FUNCTION:
94
95 # Print Call:
96 cat("\nCall:\n")
97 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
98
99 if (x$fit$trans) {
100 # Still to do:
101 print.default(x) }
102 else {
103 # Parameters - We use the same order as in gevFit:
104 cat("\nParameter Estimate:\n")
105 print(x$par.ests) }
106
107 # Return Value:
108 invisible(x)
109 }
110
111
112 # ------------------------------------------------------------------------------
113
114
115 plot.ppFit =
116 function(x, which = "ask", ...)
117 { # A function implemented by Diethelm Wuertz
118
119 # Description:
120 # Plot method for an object of class 'ppFit'
121
122 # FUNCTION:
123
124 # Plot Functions:
125 if (x$fit$trans) {
126 plot.1 <<- function(x, ...) {
127 n <- length(x$data)
128 xx <- (1:n)/(n + 1)
129 plot(xx, sort(x$data), xlab = "empirical", ylab = "model")
130 abline(0, 1, col = 3)
131 title("Residual Probability Plot") }
132 plot.2 <<- function(x, ...) {
133 n <- length(x$data)
134 xx <- (1:n)/(n + 1)
135 plot(-log(1 - xx), -log(1 - sort(x$data)), ylab = "empirical",
136 xlab = "model")
137 abline(0, 1, col = 3)
138 title("Residual quantile Plot (Exptl. Scale)") } }
139 else {
140 plot.1 <<- function(x, ...) {
141 # Probability Plot:
142 pp.pp(x$mle, x$threshold, x$npy, x$data) }
143 plot.2 <<- function(x, ...) {
144 # Quantile Plot:
145 pp.qq(x$mle, x$threshold, x$npy, x$data) } }
146
147 # Plot:
148 if (x$fit$trans) {
149 interactivePlot(
150 x = x$fit,
151 choices = c(
152 "Residual Probability Plot",
153 "Residual Quantile Plot"),
154 plotFUN = c(
155 "plot.1",
156 "plot.2"),
157 which = which) }
158 else {
159 interactivePlot(
160 x = x$fit,
161 choices = c(
162 "Probability Plot",
163 "Quantile Plot"),
164 plotFUN = c(
165 "plot.1",
166 "plot.2"),
167 which = which) }
168
169 # Return Value:
170 invisible(x)
171 }
172
173
174 # ------------------------------------------------------------------------------
175
176
177 summary.ppFit =
178 function(object, doplot = TRUE, which = "all", ...)
179 { # A function implemented by Diethelm Wuertz
180
181 # Description:
182 # Summary method for an object of class 'ppFit'
183
184 # FUNCTION:
185
186 # Print:
187 print(object, ...)
188
189 # Summary:
190 cat("\nStandard Deviations:\n"); print(object$par.ses)
191 cat("\nLog-Likelihood Value: ", object$llh)
192 cat("\nType of Convergence: ", object$converged, "\n")
193 cat("\n")
194
195 # Plot:
196 if (doplot) plot.ppFit(object, which = which, ...)
197 cat("\n")
198
199 # Return Value:
200 invisible(object)
201 }
202
203
204 # ******************************************************************************
205
+0
-223
R/54D-RlargFit.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: R-LARGEST ORDER MODELLING FROM ISMEV:
31 # rlargFit Fits r-largest Order Statistic Model
32 # print.rlargFit Print Method for object of class "rlargFit"
33 # plot.rlargFit Plot Method for object of class "rlargFit"
34 # summary.rlargFit Summary Method for object of class "rlargFit"
35 ################################################################################
36
37
38 rlargFit =
39 function(x, r = dim(x)[2], y = NULL, mul = NULL, sigl = NULL, shl = NULL,
40 mulink = identity, siglink = identity, shlink = identity, method =
41 "Nelder-Mead", maxit = 10000, ...)
42 { # A function implemented by Diethelm Wuertz
43
44 # Description:
45 # Maximum-likelihood fitting for the order statistic model,
46 # including generalized linear modelling of each parameter.
47
48 # FUNCTION:
49
50 # Function Call:
51 call = match.call()
52
53 # Fit Parameters
54 fitted = rlarg.fit(xdat = x, r = r, ydat = y, mul = mul, sigl = sigl,
55 shl = shl, mulink = mulink, siglink = siglink, shlink = shlink,
56 show = FALSE, method = method, maxit = maxit, ...)
57
58 # Further Values:
59 mle = rev(fitted$mle)
60 se = rev(fitted$se)
61 names(mle) = names(se) = c("xi", "sigma", "mu")
62 covar = fitted$cov
63 covar[1,1] = fitted$cov[3,3]
64 covar[3,3] = fitted$cov[1,1]
65 covar[1,2] = covar[2,1] = fitted$cov[2,3]
66 covar[2,3] = covar[3,2] = fitted$cov[1,2]
67
68 # Make Unique:
69 fit = list()
70 fit$fit = fitted
71 fit$call = call
72 fit$type = c("mle", "rlarg")
73 fit$par.ests = mle
74 fit$par.ses = se
75 fit$residuals = as.matrix(fitted$data)
76 fit$fitted.values = as.matrix(x) - fit$residuals
77 fit$cov = covar
78 fit$llh = fitted$nllh
79 fit$converged = fitted$conv
80
81 # Return Value:
82 class(fit) = "rlargFit"
83 fit
84 }
85
86
87 # ******************************************************************************
88
89
90 print.rlargFit =
91 function(x, ...)
92 { # A function implemented by Diethelm Wuertz
93
94 # Description:
95 # Print Method for object of class "rlargFit"
96
97 # Notes:
98 # The ismev package has no print method. It uses the command
99 # > summary.rlargFit(fit = fit, details = FALSE, doplot = FALSE, ...)
100
101 # FUNCTION:
102
103 # Function Call:
104 cat("\nCall:\n")
105 cat(paste(deparse(x$call), sep = "\n", collapse = "\n"), "\n", sep = "")
106
107 # Estimation Type:
108 cat("\nEstimation Type:", x$type, "\n")
109
110 # Estimated summaryParameters:
111 cat("\nEstimated Parameters:\n")
112 print(x$par.ests)
113 cat("\n")
114
115 # Return Value:
116 invisible(x)
117 }
118
119
120 # ------------------------------------------------------------------------------
121
122
123 plot.rlargFit =
124 function(x, which = "all", ...)
125 { # A function implemented by Diethelm Wuertz
126
127 # Description:
128 # Plot method for objects of class "rlargFit".
129
130 # FUNCTION:
131
132 # Plot Functions:
133 if (x$fit$trans) {
134 # Non-Stationary:
135 plot.1 <<- function(x, ...) {
136 for (i in 1:z$r) {
137 # Probability and Quantile Plots:
138 rlarg.pp(c(0, 1, 0), x$data[, 1:x$r], i)
139 rlarg.qq(c(0, 1, 0), x$data[, 1:x$r], i) } } }
140 else {
141 # Stationary - GEV Plots:
142 plot.1 <<- function(x, ...) {
143 gev.pp(x$mle, x$data[, 1]) }
144 plot.2 <<- function(x, ...) {
145 gev.qq(x$mle, x$data[, 1]) }
146 plot.3 <<- function(x, ...) {
147 gev.rl(x$mle, x$cov, x$data[, 1]) }
148 plot.4 <<- function(x, ...) {
149 gev.his(x$mle, x$data[, 1]) }
150 fit <<- fit; plot.5 <<- function(x, ...) {
151 par(ask = TRUE)
152 for (i in 1:fit$fit$r) {
153 # Probability and Quantile Plots:
154 rlarg.pp(x$mle, x$data, i)
155 rlarg.qq(x$mle, x$data, i) }
156 par(ask = FALSE) } }
157
158 # Plot:
159 if (x$fit$trans) {
160 interactivePlot(
161 x = x$fit,
162 choices = c(
163 "Probability Plot",
164 "Quantile Plot"),
165 plotFUN = c(
166 "plot.1",
167 "plot.2"),
168 which = which) }
169 else {
170 interactivePlot(
171 x = x$fit,
172 choices = c(
173 "GEV Probability Plot",
174 "GEV Quantile Plot",
175 "GEV Return Level Plot",
176 "GEV Histogram Plot",
177 "R-Largest PP and QQ Plots"),
178 plotFUN = c(
179 "plot.1",
180 "plot.2",
181 "plot.3",
182 "plot.4",
183 "plot.5"),
184 which = which) }
185
186 # Return Value:
187 invisible(x)
188 }
189
190
191 # ------------------------------------------------------------------------------
192
193
194 summary.rlargFit =
195 function(object, doplot = TRUE, which = "all", ...)
196 { # A function implemented by Diethelm Wuertz
197
198 # Description:
199 # Summary Method for object of class "rlargFit".
200
201 # FUNCTION:
202
203 # Print:
204 print(object, ...)
205
206 # Summary:
207 cat("\nStandard Deviations:\n"); print(object$par.ses)
208 cat("\nLog-Likelihood Value: ", object$llh)
209 cat("\nType of Convergence: ", object$converged, "\n")
210 cat("\n")
211
212 # Plot:
213 if (doplot) plot(object, which = which, ...)
214 cat("\n")
215
216 # Return Value:
217 invisible(object)
218 }
219
220
221 # ******************************************************************************
222
+0
-139
R/55A-ExtremeIndex.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: EXTREMAL INDEX:
31 # exindexesPlot Calculate and Plot Theta(1,2,3)
32 # exindexPlot Calculate Theta(1,2) and Plot Theta(1)
33 ################################################################################
34
35
36 exindexesPlot =
37 function (x, block=20, quantiles = seq(0.990,0.999,0.001), doplot = TRUE, ...)
38 { # A function written by D. Wuertz
39
40 # Description:
41 # Calculates and Plots Theta(1,2,3)
42
43 # FUNCTION:
44
45 # Settings:
46 main = "Extremal Index"
47 doprint = FALSE
48
49 # Block Size:
50 blocklength = block # argument renamed
51
52 # Note, in finance the x's should be residuals
53 resid = x
54
55 # Extremal Index - Theta_1, Theta_2 and Theta_3
56 k = floor(length(resid)/blocklength) # Number of blocks
57 n = k*blocklength # Number of data points
58
59 # Now organize your residuels:
60 # 1) truncate the rest of the time series,
61 # 2) arrange them in matrix form,
62 # 3) sort them in reverse order, ie. from high (pos) to low (neg)
63 resid1 = resid[1:(k*blocklength)]
64 resid1 = matrix(resid1, ncol = blocklength, byrow = TRUE)
65 ordered1 = sort(resid1)
66
67 # Threshold values associated to quantiles:
68 z0 = ordered1[floor(quantiles*length(resid1))]
69
70 # Printing:
71 if (doprint) {print(z0); print(n); print(k) }
72
73 # Presettings:
74 theta1 = theta2 = theta3 = rep(0, times = length(quantiles))
75
76 # Calculate Extremal Imdex:
77 run = 0
78 for ( z in z0 ) {
79 run = run + 1
80 # N - number of exceedences:
81 N = length(resid1[resid1>z])
82 # K - number of blocks with exceedences:
83 K = sum(sign(apply(resid1,1,max)-z)+1)/2
84 if (K/k < 1) theta1[run] = (k/n) * log(1-K/k) / log(1-N/n)
85 else theta1[run] = NA
86 theta2[run] = K/N
87 x = 1:n
88 xx = diff(x[resid1 > z])
89 xx = xx[xx>blocklength]
90 theta3[run] = length(xx)/N
91 # Printing:
92 if (doprint) {
93 print(c(N, K, quantiles[run], z))
94 print(c(theta1[run], theta2[run], theta3[run]))} }
95
96 # Plotting:
97 if (doplot) {
98 plot(quantiles, theta1,
99 xlim = c(quantiles[1], quantiles[length(quantiles)]),
100 ylim = c(0, 1.2), type = "b", pch = 1,
101 ylab = " Theta 1,2,3", main = main, ...)
102 points(quantiles, theta2, pch = 2, col = 3)
103 points(quantiles, theta3, pch = 4, col = 4) }
104
105 # Return Value:
106 data.frame(thresholds=z0, theta1=theta1, theta2=theta2, theta3=theta3)
107 }
108
109
110 # -----------------------------------------------------------------------------
111
112
113 exindexPlot =
114 function(x, block = "month", start = 5, end = NA,
115 plottype = c("thresh", "K"), labels = TRUE, autoscale = TRUE, ...)
116 { # A function implemented by Diethelm Wuertz
117
118 # Description:
119 # Calculates Theta(1,2) and plots Theta(1)
120
121 # Notes:
122 # Wraps "exindex" from Alexander McNeil's evir package
123
124 # FUNCTION:
125
126 # Wrapper:
127 plottype = plottype[1]
128 reverse = FALSE
129 if (plottype == "K") reverse = TRUE
130 ans = exindex(data = x, block = block , start = start, end = end,
131 reverse = reverse, auto.scale = autoscale, labels = labels, ...)
132
133 # Return Value:
134 ans
135 }
136
137
138 # ******************************************************************************
+0
-2807
R/56A-ExtremesBuiltin.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # BUILIN - PACKAGE DESCRIPTION:
31 # Package: evir
32 # Version: 1.1
33 # Date: 2004-05-05
34 # Title: Extreme Values in R
35 # Author: S original (EVIS) by Alexander McNeil
36 # <mcneil@math.ethz.ch>, R port by Alec
37 # Stephenson <alec_stephenson@hotmail.com>.
38 # Maintainer: Alec Stephenson <alec_stephenson@hotmail.com>
39 # Depends: R (>= 1.5.0)
40 # Description: Functions for extreme value theory, which may be
41 # divided into the following groups; exploratory data analysis,
42 # block maxima, peaks over thresholds (univariate and bivariate),
43 # point processes, gev/gpd distributions.
44 # License: GPL (Version 2 or above)
45 # URL: http://www.maths.lancs.ac.uk/~stephena/
46 # Packaged: Wed May 5 15:29:24 2004; stephena
47 ################################################################################
48 # BUILTIN - PACKAGE DESCRIPTION:
49 # Package: ismev
50 # Version: 1.1
51 # Date: 2003/11/25
52 # Title: An Introduction to Statistical Modeling of Extreme Values
53 # Author: Original S functions by Stuart Coles
54 # <Stuart.Coles@bristol.ac.uk>, R port and R documentation files
55 # by Alec Stephenson <a.stephenson@lancaster.ac.uk>.
56 # Maintainer: Alec Stephenson <a.stephenson@lancaster.ac.uk>
57 # Depends: R (>= 1.5.0)
58 # Description: Functions to support the computations carried out in
59 # `An Introduction to Statistical Modeling of Extreme Values' by
60 # Stuart Coles. The functions may be divided into the following
61 # groups; maxima/minima, order statistics, peaks over thresholds
62 # and point processes.
63 # License: GPL (Version 2 or above)
64 # URL: http://www.maths.lancs.ac.uk/~stephena/
65 ################################################################################
66
67
68 # This file contains the following functions:
69 # gev.fit gev.diag gev.pp gev.qq gev.rl gev.his
70 # gevf gevq gev.dens gev.profxi gev.prof
71
72 "gev.fit"<-
73 function(xdat, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL,
74 mulink = identity, siglink = identity, shlink = identity, show = TRUE,
75 method = "Nelder-Mead", maxit = 10000, ...)
76 {
77 #
78 # obtains mles etc for gev distn
79 #
80 z <- list()
81 npmu <- length(mul) + 1
82 npsc <- length(sigl) + 1
83 npsh <- length(shl) + 1
84 z$trans <- FALSE # if maximization fails, could try
85 # changing in1 and in2 which are
86 # initial values for minimization routine
87 in2 <- sqrt(6 * var(xdat))/pi
88 in1 <- mean(xdat) - 0.57722 * in2
89 if(is.null(mul)) {
90 mumat <- as.matrix(rep(1, length(xdat)))
91 muinit <- in1
92 }
93 else {
94 z$trans <- TRUE
95 mumat <- cbind(rep(1, length(xdat)), ydat[, mul])
96 muinit <- c(in1, rep(0, length(mul)))
97 }
98 if(is.null(sigl)) {
99 sigmat <- as.matrix(rep(1, length(xdat)))
100 siginit <- in2
101 }
102 else {
103 z$trans <- TRUE
104 sigmat <- cbind(rep(1, length(xdat)), ydat[, sigl])
105 siginit <- c(in2, rep(0, length(sigl)))
106 }
107 if(is.null(shl)) {
108 shmat <- as.matrix(rep(1, length(xdat)))
109 shinit <- 0.1
110 }
111 else {
112 z$trans <- TRUE
113 shmat <- cbind(rep(1, length(xdat)), ydat[, shl])
114 shinit <- c(0.1, rep(0, length(shl)))
115 }
116 z$model <- list(mul, sigl, shl)
117 z$link <- deparse(substitute(c(mulink, siglink, shlink)))
118 init <- c(muinit, siginit, shinit)
119 gev.lik <- function(a) {
120 # computes neg log lik of gev model
121 mu <- mulink(mumat %*% (a[1:npmu]))
122 sc <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
123 xi <- shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)]))
124 y <- (xdat - mu)/sc
125 y <- 1 + xi * y
126 if(any(y <= 0) || any(sc <= 0)) return(10^6)
127 sum(log(sc)) + sum(y^(-1/xi)) + sum(log(y) * (1/xi + 1))
128 }
129 x <- optim(init, gev.lik, hessian = TRUE, method = method,
130 control = list(maxit = maxit, ...))
131 z$conv <- x$convergence
132 mu <- mulink(mumat %*% (x$par[1:npmu]))
133 sc <- siglink(sigmat %*% (x$par[seq(npmu + 1, length = npsc)]))
134 xi <- shlink(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)]))
135 z$nllh <- x$value
136 z$data <- xdat
137 if(z$trans) {
138 z$data <- - log(as.vector((1 + (xi * (xdat - mu))/sc)^(
139 -1/xi)))
140 }
141 z$mle <- x$par
142 z$cov <- solve(x$hessian)
143 z$se <- sqrt(diag(z$cov))
144 z$vals <- cbind(mu, sc, xi)
145 if(show) {
146 if(z$trans)
147 print(z[c(2, 3, 4)])
148 else print(z[4])
149 if(!z$conv)
150 print(z[c(5, 7, 9)])
151 }
152 invisible(z)
153 }
154
155 "gev.diag"<-
156 function(z)
157 {
158 #
159 # produces diagnostic plots for output of
160 # gev.fit stored in z
161 #
162 n <- length(z$data)
163 x <- (1:n)/(n + 1)
164 if(z$trans) {
165 oldpar <- par(mfrow = c(1, 2))
166 plot(x, exp( - exp( - sort(z$data))), xlab =
167 "Empirical", ylab = "Model")
168 abline(0, 1, col = 4)
169 title("Residual Probability Plot")
170 plot( - log( - log(x)), sort(z$data), ylab =
171 "Empirical", xlab = "Model")
172 abline(0, 1, col = 4)
173 title("Residual Quantile Plot (Gumbel Scale)")
174 }
175 else {
176 oldpar <- par(mfrow = c(2, 2))
177 gev.pp(z$mle, z$data)
178 gev.qq(z$mle, z$data)
179 gev.rl(z$mle, z$cov, z$data)
180 gev.his(z$mle, z$data)
181 }
182 par(oldpar)
183 invisible()
184 }
185
186 "gev.pp"<-
187 function(a, dat)
188 {
189 #
190 # sub-function for gev.diag
191 # produces probability plot
192 #
193 plot((1:length(dat))/length(dat), gevf(a, sort(dat)), xlab =
194 "Empirical", ylab = "Model", main = "Probability Plot")
195 abline(0, 1, col = 4)
196 }
197
198 "gev.qq"<-
199 function(a, dat)
200 {
201 #
202 # function called by gev.diag
203 # produces quantile plot
204 #
205 plot(gevq(a, 1 - (1:length(dat)/(length(dat) + 1))), sort(dat), ylab =
206 "Empirical", xlab = "Model", main = "Quantile Plot")
207 abline(0, 1, col = 4)
208 }
209
210 "gev.rl"<-
211 function(a, mat, dat)
212 {
213 #
214 # function called by gev.diag
215 # produces return level curve and 95 % confidence intervals
216 # on usual scale
217 #
218 eps <- 1e-006
219 a1 <- a
220 a2 <- a
221 a3 <- a
222 a1[1] <- a[1] + eps
223 a2[2] <- a[2] + eps
224 a3[3] <- a[3] + eps
225 f <- c(seq(0.01, 0.09, by = 0.01), 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7,
226 0.8, 0.9, 0.95, 0.99, 0.995, 0.999)
227 q <- gevq(a, 1 - f)
228 d1 <- (gevq(a1, 1 - f) - q)/eps
229 d2 <- (gevq(a2, 1 - f) - q)/eps
230 d3 <- (gevq(a3, 1 - f) - q)/eps
231 d <- cbind(d1, d2, d3)
232 v <- apply(d, 1, q.form, m = mat)
233 plot(-1/log(f), q, log = "x", type = "n", xlim = c(0.1, 1000), ylim = c(
234 min(dat, q), max(dat, q)), xlab = "Return Period", ylab =
235 "Return Level")
236 title("Return Level Plot")
237 lines(-1/log(f), q)
238 lines(-1/log(f), q + 1.96 * sqrt(v), col = 4)
239 lines(-1/log(f), q - 1.96 * sqrt(v), col = 4)
240 points(-1/log((1:length(dat))/(length(dat) + 1)), sort(dat))
241 }
242
243 "gev.his"<-
244 function(a, dat)
245 {
246 #
247 # Plots histogram of data and fitted density
248 # for output of gev.fit stored in z
249 #
250 h <- hist(dat, prob = TRUE, plot = FALSE)
251 if(a[3] < 0) {
252 x <- seq(min(h$breaks), min(max(h$breaks), (a[1] - a[2]/a[3] -
253 0.001)), length = 100)
254 }
255 else {
256 x <- seq(max(min(h$breaks), (a[1] - a[2]/a[3] + 0.001)), max(h$
257 breaks), length = 100)
258 }
259 y <- gev.dens(a, x)
260 hist(dat, prob = TRUE, ylim = c(0, max(y)), xlab = "z", ylab = "f(z)",
261 main = "Density Plot")
262 points(dat, rep(0, length(dat)))
263 lines(x, y)
264 }
265
266 "gevf"<-
267 function(a, z)
268 {
269 #
270 # ancillary function calculates gev dist fnc
271 #
272 if(a[3] != 0) exp( - (1 + (a[3] * (z - a[1]))/a[2])^(-1/a[3])) else
273 gum.df(z, a[1], a[2])
274 }
275
276 "gevq"<-
277 function(a, p)
278 {
279 if(a[3] != 0)
280 a[1] + (a[2] * (( - log(1 - p))^( - a[3]) - 1))/a[3]
281 else gum.q(p, a[1], a[2])
282 }
283
284 "gev.dens"<-
285 function(a, z)
286 {
287 #
288 # evaluates gev density with parameters a at z
289 #
290 if(a[3] != 0) (exp( - (1 + (a[3] * (z - a[1]))/a[2])^(-1/a[3])) * (1 + (
291 a[3] * (z - a[1]))/a[2])^(-1/a[3] - 1))/a[2] else {
292 gum.dens(c(a[1], a[2]), z)
293 }
294 }
295
296 "gev.profxi"<-
297 function(z, xlow, xup, conf = 0.95, nint = 100)
298 {
299 #
300 # plots profile log-likelihood for shape parameter
301 # in gev model
302 #
303 cat("If routine fails, try changing plotting interval", fill = TRUE)
304 v <- numeric(nint)
305 x <- seq(xup, xlow, length = nint)
306 sol <- c(z$mle[1], z$mle[2])
307 gev.plikxi <- function(a) {
308 # computes profile neg log lik
309 if (abs(xi) < 10^(-6)) {
310 y <- (z$data - a[1])/a[2]
311 if(a[2] <= 0) l <- 10^6
312 else l <- length(y) * log(a[2]) + sum(exp(-y)) + sum(y)
313 }
314 else {
315 y <- (z$data - a[1])/a[2]
316 y <- 1 + xi * y
317 if(a[2] <= 0 || any(y <= 0))
318 l <- 10^6
319 else l <- length(y) * log(a[2]) + sum(y^(-1/xi)) + sum(log(y
320 )) * (1/xi + 1)
321 }
322 l
323 }
324 for(i in 1:nint) {
325 xi <- x[i]
326 opt <- optim(sol, gev.plikxi)
327 sol <- opt$par ; v[i] <- opt$value
328 }
329 plot(x, - v, type = "l", xlab = "Shape Parameter", ylab =
330 "Profile Log-likelihood")
331 ma <- - z$nllh
332 abline(h = ma, col = 4)
333 abline(h = ma - 0.5 * qchisq(conf, 1), col = 4)
334 invisible()
335 }
336
337 "gev.prof"<-
338 function(z, m, xlow, xup, conf = 0.95, nint = 100)
339 {
340 #
341 # plots profile log likelihood for m 'year' return level
342 # in gev model
343 #
344 if(m <= 1) stop("`m' must be greater than one")
345 cat("If routine fails, try changing plotting interval", fill = TRUE)
346 p <- 1/m
347 v <- numeric(nint)
348 x <- seq(xlow, xup, length = nint)
349 sol <- c(z$mle[2], z$mle[3])
350 gev.plik <- function(a) {
351 # computes profile neg log lik
352 if (abs(a[2]) < 10^(-6)) {
353 mu <- xp + a[1] * log(-log(1 - p))
354 y <- (z$data - mu)/a[1]
355 if(is.infinite(mu) || a[1] <= 0) l <- 10^6
356 else l <- length(y) * log(a[1]) + sum(exp(-y)) + sum(y)
357 }
358 else {
359 mu <- xp - a[1]/a[2] * (( - log(1 - p))^( - a[2]) - 1)
360 y <- (z$data - mu)/a[1]
361 y <- 1 + a[2] * y
362 if(is.infinite(mu) || a[1] <= 0 || any(y <= 0))
363 l <- 10^6
364 else l <- length(y) * log(a[1]) + sum(y^(-1/a[2])) + sum(log(
365 y)) * (1/a[2] + 1)
366 }
367 l
368 }
369 for(i in 1:nint) {
370 xp <- x[i]
371 opt <- optim(sol, gev.plik)
372 sol <- opt$par ; v[i] <- opt$value
373 }
374 plot(x, - v, type = "l", xlab = "Return Level", ylab =
375 " Profile Log-likelihood")
376 ma <- - z$nllh
377 abline(h = ma, col = 4)
378 abline(h = ma - 0.5 * qchisq(conf, 1), col = 4)
379 invisible()
380 }
381
382
383
384
385
386
387
388 # This file contains the following functions:
389 # gpd.fitrange gpd.fit gpd.diag gpd.pp gpd.qq gpd.rl
390 # gpd.his gpdf gpdq gpdq2 gpd.dens gpd.profxi gpd.prof
391
392 "gpd.fitrange"<-
393 function(data, umin, umax, nint = 10, show = FALSE)
394 {
395 #
396 # computes mle's in gpd model, adjusted for threshold,
397 # over range of threshold choices.
398 #
399 m <- s <- up <- ul <- matrix(0, nrow = nint, ncol = 2)
400 u <- seq(umin, umax, length = nint)
401 for(i in 1:nint) {
402 z <- gpd.fit(data, u[i], show = show)
403 m[i, ] <- z$mle
404 m[i, 1] <- m[i, 1] - m[i, 2] * u[i]
405 d <- matrix(c(1, - u[i]), ncol = 1)
406 v <- t(d) %*% z$cov %*% d
407 s[i, ] <- z$se
408 s[i, 1] <- sqrt(v)
409 up[i, ] <- m[i, ] + 1.96 * s[i, ]
410 ul[i, ] <- m[i, ] - 1.96 * s[i, ]
411 }
412 names <- c("Modified Scale", "Shape")
413 oldpar <- par(mfrow = c(2, 1))
414 for(i in 1:2) {
415 um <- max(up[, i])
416 ud <- min(ul[, i])
417 plot(u, m[, i], ylim = c(ud, um), xlab = "Threshold", ylab =
418 names[i], type = "b")
419 for(j in 1:nint)
420 lines(c(u[j], u[j]), c(ul[j, i], up[j, i]))
421 }
422 par(oldpar)
423 invisible()
424 }
425
426 "gpd.fit"<-
427 function(xdat, threshold, npy = 365, ydat = NULL, sigl = NULL, shl = NULL,
428 siglink = identity, shlink = identity, show = TRUE, method = "Nelder-Mead",
429 maxit = 10000, ...)
430 {
431 #
432 # obtains mles etc for gpd model
433 #
434 z <- list()
435 npsc <- length(sigl) + 1
436 npsh <- length(shl) + 1
437 n <- length(xdat)
438 z$trans <- FALSE
439 if(is.function(threshold))
440 stop("`threshold' cannot be a function")
441 u <- rep(threshold, length.out = n)
442 if(length(unique(u)) > 1) z$trans <- TRUE
443 xdatu <- xdat[xdat > u]
444 xind <- (1:n)[xdat > u]
445 u <- u[xind]
446 in2 <- sqrt(6 * var(xdat))/pi
447 in1 <- mean(xdat, na.rm = TRUE) - 0.57722 * in2
448 if(is.null(sigl)) {
449 sigmat <- as.matrix(rep(1, length(xdatu)))
450 siginit <- in2
451 }
452 else {
453 z$trans <- TRUE
454 sigmat <- cbind(rep(1, length(xdatu)), ydat[xind, sigl])
455 siginit <- c(in2, rep(0, length(sigl)))
456 }
457 if(is.null(shl)) {
458 shmat <- as.matrix(rep(1, length(xdatu)))
459 shinit <- 0.1
460 }
461 else {
462 z$trans <- TRUE
463 shmat <- cbind(rep(1, length(xdatu)), ydat[xind, shl])
464 shinit <- c(0.1, rep(0, length(shl)))
465 }
466 init <- c(siginit, shinit)
467 z$model <- list(sigl, shl)
468 z$link <- deparse(substitute(c(siglink, shlink)))
469 z$threshold <- threshold
470 z$nexc <- length(xdatu)
471 z$data <- xdatu
472 gpd.lik <- function(a) {
473 # calculates gpd neg log lik
474 sc <- siglink(sigmat %*% (a[seq(1, length = npsc)]))
475 xi <- shlink(shmat %*% (a[seq(npsc + 1, length = npsh)]))
476 y <- (xdatu - u)/sc
477 y <- 1 + xi * y
478 if(min(sc) <= 0)
479 l <- 10^6
480 else {
481 if(min(y) <= 0)
482 l <- 10^6
483 else {
484 l <- sum(log(sc)) + sum(log(y) * (1/xi + 1))
485 }
486 }
487 l
488 }
489 x <- optim(init, gpd.lik, hessian = TRUE, method = method,
490 control = list(maxit = maxit, ...))
491 sc <- siglink(sigmat %*% (x$par[seq(1, length = npsc)]))
492 xi <- shlink(shmat %*% (x$par[seq(npsc + 1, length = npsh)]))
493 z$conv <- x$convergence
494 z$nllh <- x$value
495 z$vals <- cbind(sc, xi, u)
496 if(z$trans) {
497 z$data <- - log(as.vector((1 + (xi * (xdatu - u))/sc)^(-1/xi))
498 )
499 }
500 z$mle <- x$par
501 z$rate <- length(xdatu)/n
502 z$cov <- solve(x$hessian)
503 z$se <- sqrt(diag(z$cov))
504 z$n <- n
505 z$npy <- npy
506 z$xdata <- xdat
507 if(show) {
508 if(z$trans)
509 print(z[c(2, 3)])
510 if(length(z[[4]]) == 1)
511 print(z[4])
512 print(z[c(5, 7)])
513 if(!z$conv)
514 print(z[c(8, 10, 11, 13)])
515 }
516 invisible(z)
517 }
518
519 "gpd.diag"<-
520 function(z)
521 {
522 #
523 # produces diagnostic plots for gpd model
524 # estimated using gpd.fit with output stored in z
525 #
526 n <- length(z$data)
527 x <- (1:n)/(n + 1)
528 if(z$trans) {
529 oldpar <- par(mfrow = c(1, 2))
530 plot(x, 1 - exp( - sort(z$data)), xlab = "Empirical",
531 ylab = "Model")
532 abline(0, 1, col = 4)
533 title("Residual Probability Plot")
534 plot( - log(1 - x), sort(z$data), ylab = "Empirical",
535 xlab = "Model")
536 abline(0, 1, col = 4)
537 title("Residual Quantile Plot (Exptl. Scale)")
538 }
539 else {
540 oldpar <- par(mfrow = c(2, 2))
541 gpd.pp(z$mle, z$threshold, z$data)
542 gpd.qq(z$mle, z$threshold, z$data)
543 gpd.rl(z$mle, z$threshold, z$rate, z$n, z$npy, z$cov, z$
544 data, z$xdata)
545 gpd.his(z$mle, z$threshold, z$data)
546 }
547 par(oldpar)
548 invisible()
549 }
550
551 "gpd.pp"<-
552 function(a, u, dat)
553 {
554 #
555 # function called by gpd.diag
556 # produces probability plot for gpd model
557 #
558 plot((1:length(dat))/length(dat), gpdf(a, u, sort(dat)), xlab =
559 "Empirical", ylab = "Model", main = "Probability Plot")
560 abline(0, 1, col = 4)
561 }
562
563 "gpd.qq"<-
564 function(a, u, dat)
565 {
566 #
567 # function called by gpd.diag
568 # produces quantile plot for gpd model
569 #
570 plot(gpdq(a, u, 1 - (1:length(dat)/(length(dat) + 1))), sort(dat), ylab
571 = "Empirical", xlab = "Model", main = "Quantile Plot")
572 abline(0, 1, col = 4)
573 }
574
575 "gpd.rl"<-
576 function(a, u, la, n, npy, mat, dat, xdat)
577 {
578 #
579 # function called by gpd.diag
580 # produces return level curve and 95% confidence intervals
581 # for fitted gpd model
582 a <- c(la, a)
583 eps <- 1e-006
584 a1 <- a
585 a2 <- a
586 a3 <- a
587 a1[1] <- a[1] + eps
588 a2[2] <- a[2] + eps
589 a3[3] <- a[3] + eps
590 jj <- seq(-1, 3.75 + log10(npy), by = 0.1)
591 m <- c(1/la, 10^jj)
592 q <- gpdq2(a[2:3], u, la, m)
593 d1 <- (gpdq2(a1[2:3], u, la, m) - q)/eps
594 d2 <- (gpdq2(a2[2:3], u, la, m) - q)/eps
595 d3 <- (gpdq2(a3[2:3], u, la, m) - q)/eps
596 d <- cbind(d1, d2, d3)
597 mat <- matrix(c((la * (1 - la))/n, 0, 0, 0, mat[1, 1], mat[1, 2], 0,
598 mat[2, 1], mat[2, 2]), nc = 3)
599 v <- apply(d, 1, q.form, m = mat)
600 plot(m/npy, q, log = "x", type = "n", xlim = c(0.1, max(m)/npy), ylim
601 = c(u, max(xdat, q[q > u - 1] + 1.96 * sqrt(v)[q > u - 1])),
602 xlab = "Return period (years)", ylab = "Return level", main =
603 "Return Level Plot")
604 lines(m[q > u - 1]/npy, q[q > u - 1])
605 lines(m[q > u - 1]/npy, q[q > u - 1] + 1.96 * sqrt(v)[q > u - 1], col
606 = 4)
607 lines(m[q > u - 1]/npy, q[q > u - 1] - 1.96 * sqrt(v)[q > u - 1], col
608 = 4)
609 nl <- n - length(dat) + 1
610 sdat <- sort(xdat)
611 points((1/(1 - (1:n)/(n + 1))/npy)[sdat > u], sdat[sdat > u])
612 # points(1/(1 - (1:n)/(n + 1))/npy,
613 # sort(xdat))
614 # abline(h = u, col = 3)
615 }
616
617 "gpd.his"<-
618 function(a, u, dat)
619 {
620 #
621 # function called by gpd.diag
622 # produces histogram and density plot
623 #
624 h <- hist(dat, prob = TRUE, plot = FALSE)
625 x <- seq(u, max(h$breaks), length = 100)
626 y <- gpd.dens(a, u, x)
627 hist(dat, prob = TRUE, ylim = c(0, max(y)), xlab = "x", ylab = "f(x)",
628 main = "Density Plot")
629 lines(x, y, col = 4)
630 }
631
632 "gpdf"<-
633 function(a, u, z)
634 {
635 #
636 # ancillary function
637 # calculates gpd distribution function
638 #
639 1 - (1 + (a[2] * (z - u))/a[1])^(-1/a[2])
640 }
641
642 "gpdq"<-
643 function(a, u, p)
644 u + (a[1] * (p^( - a[2]) #
645 # ancillary function
646 # computes gpd quantiles
647 #
648 - 1))/a[2]
649
650 "gpdq2"<-
651 function(a, u, la, m)
652 {
653 #
654 # ancillary function
655 # calculates quantiles of gpd model
656 #
657 u + (a[1] * ((m * la)^(a[2]) - 1))/a[2]
658 }
659
660 "gpd.dens"<-
661 function(a, u, z)
662 {
663 #
664 # ancillary function computes gpd density
665 #
666 (1 + (a[2] * (z - u))/a[1])^(-1/a[2] - 1)/a[1]
667 }
668
669 "gpd.profxi"<-
670 function(z, xlow, xup, conf = 0.95, nint = 100)
671 {
672 #
673 # plots profile log likelihood for shape parameter
674 # in gpd model
675 #
676 cat("If routine fails, try changing plotting interval", fill = TRUE)
677 xdat <- z$data ; u <- z$threshold
678 v <- numeric(nint)
679 x <- seq(xup, xlow, length = nint)
680 sol <- z$mle[1]
681 gpd.plikxi <- function(a) {
682 # calculates profile log lik
683 if(abs(xi) < 10^(-4)) l <- length(xdat) * log(a) + sum(xdat - u)/a
684 else {
685 y <- (xdat - u)/a
686 y <- 1 + xi * y
687 if(any(y <= 0) || a <= 0)
688 l <- 10^6
689 else l <- length(xdat) * log(a) + sum(log(y)) * (1/xi + 1)
690 }
691 l
692 }
693 for(i in 1:nint) {
694 xi <- x[i]
695 opt <- optim(sol, gpd.plikxi, method = "BFGS")
696 sol <- opt$par ; v[i] <- opt$value
697 }
698 plot(x, - v, type = "l", xlab = "Shape Parameter", ylab =
699 "Profile Log-likelihood")
700 ma <- - z$nllh
701 abline(h = ma, lty = 1)
702 abline(h = ma - 0.5 * qchisq(conf, 1), lty = 1)
703 invisible()
704 }
705
706
707
708 "gpd.prof"<-
709 function(z, m, xlow, xup, npy = 365, conf = 0.95, nint = 100)
710 {
711 #
712 # plots profile log-likelihood for m-year return level
713 # in gpd model
714 #
715 cat("If routine fails, try changing plotting interval", fill = TRUE)
716 xdat <- z$data ; u <- z$threshold ; la <- z$rate
717 v <- numeric(nint)
718 x <- seq(xlow, xup, length = nint)
719 m <- m * npy
720 sol <- z$mle[2]
721 gpd.plik <- function(a) {
722 # calculates profile neg log lik
723 if(m != Inf) sc <- (a * (xp - u))/((m * la)^a - 1) else sc <- (u - xp)/
724 a
725 if(abs(a) < 10^(-4))
726 l <- length(xdat) * log(sc) + sum(xdat - u)/sc
727 else {
728 y <- (xdat - u)/sc
729 y <- 1 + a * y
730 if(any(y <= 0) || sc <= 0)
731 l <- 10^6
732 else l <- length(xdat) * log(sc) + sum(log(y)) * (1/a + 1)
733 }
734 l
735 }
736 for(i in 1:nint) {
737 xp <- x[i]
738 opt <- optim(sol, gpd.plik, method = "BFGS")
739 sol <- opt$par ; v[i] <- opt$value
740 }
741 plot(x, - v, type = "l", xlab = "Return Level", ylab =
742 "Profile Log-likelihood")
743 ma <- - z$nllh
744 abline(h = ma)
745 abline(h = ma - 0.5 * qchisq(conf, 1))
746 invisible()
747 }
748
749
750
751
752
753 # This file contains the following functions:
754 # gum.fit gum.diag gum.rl gum.df gum.q gum.dens
755
756 "gum.fit"<-
757 function(xdat, ydat = NULL, mul = NULL, sigl = NULL, mulink = identity,
758 siglink = identity, show = TRUE, method = "Nelder-Mead", maxit = 10000, ...)
759 {
760 #
761 # finds mles etc for gumbel model
762 #
763 z <- list()
764 npmu <- length(mul) + 1
765 npsc <- length(sigl) + 1
766 z$trans <- FALSE
767 in2 <- sqrt(6 * var(xdat))/pi
768 in1 <- mean(xdat) - 0.57722 * in2
769 if(is.null(mul)) {
770 mumat <- as.matrix(rep(1, length(xdat)))
771 muinit <- in1
772 }
773 else {
774 z$trans <- TRUE
775 mumat <- cbind(rep(1, length(xdat)), ydat[, mul])
776 muinit <- c(in1, rep(0, length(mul)))
777 }
778 if(is.null(sigl)) {
779 sigmat <- as.matrix(rep(1, length(xdat)))
780 siginit <- in2
781 }
782 else {
783 z$trans <- TRUE
784 sigmat <- cbind(rep(1, length(xdat)), ydat[, sigl])
785 siginit <- c(in2, rep(0, length(sigl)))
786 }
787 z$model <- list(mul, sigl)
788 z$link <- c(deparse(substitute(mulink)), deparse(substitute(siglink)))
789 init <- c(muinit, siginit)
790 gum.lik <- function(a) {
791 # calculates neg log lik of gumbel model
792 mu <- mulink(mumat %*% (a[1:npmu]))
793 sc <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
794 if(any(sc <= 0)) return(10^6)
795 y <- (xdat - mu)/sc
796 sum(log(sc)) + sum(y) + sum(exp( - y))
797 }
798 x <- optim(init, gum.lik, hessian = TRUE, method = method,
799 control = list(maxit = maxit, ...))
800 z$conv <- x$convergence
801 if(!z$conv) {
802 mu <- mulink(mumat %*% (x$par[1:npmu]))
803 sc <- siglink(sigmat %*% (x$par[seq(npmu + 1, length = npsc)]))
804 z$nllh <- x$value
805 z$data <- xdat
806 if(z$trans) {
807 z$data <- as.vector((xdat - mu)/sc)
808 }
809 z$mle <- x$par
810 z$cov <- solve(x$hessian)
811 z$se <- sqrt(diag(z$cov))
812 z$vals <- cbind(mu, sc)
813 }
814 if(show) {
815 if(z$trans)
816 print(z[c(2, 3, 4)])
817 else print(z[4])
818 if(!z$conv)
819 print(z[c(5, 7, 9)])
820 }
821 invisible(z)
822 }
823
824 "gum.diag"<-
825 function(z)
826 {
827 #
828 # produces diagnostic plots for output of
829 # gum.fit stored in z
830 #
831 z$mle <- c(z$mle, 0)
832 n <- length(z$data)
833 x <- (1:n)/(n + 1)
834 if(z$trans) {
835 oldpar <- par(mfrow = c(1, 2))
836 plot(x, exp( - exp( - sort(z$data))), xlab = "empirical",
837 ylab = "model")
838 abline(0, 1, col = 4)
839 title("Residual Probability Plot")
840 plot( - log( - log(x)), sort(z$data), xlab =
841 "empirical", ylab = "model")
842 abline(0, 1, col = 4)
843 title("Residual Quantile Plot (Gumbel Scale)")
844 }
845 else {
846 oldpar <- par(mfrow = c(2, 2))
847 gev.pp(z$mle, z$data)
848 gev.qq(z$mle, z$data)
849 gum.rl(z$mle, z$cov, z$data)
850 gev.his(z$mle, z$data)
851 }
852 par(oldpar)
853 invisible()
854 }
855
856 "gum.rl"<-
857 function(a, mat, dat)
858 {
859 #
860 # function called by gum.diag
861 # produces return level curve and 95 % confidence intervals
862 # on usual scale for gumbel model
863 #
864 eps <- 1e-006
865 a1 <- a
866 a2 <- a
867 a1[1] <- a[1] + eps
868 a2[2] <- a[2] + eps
869 f <- c(seq(0.01, 0.09, by = 0.01), 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7,
870 0.8, 0.9, 0.95, 0.99, 0.995, 0.999)
871 q <- gevq(a, 1 - f)
872 d1 <- (gevq(a1, 1 - f) - q)/eps
873 d2 <- (gevq(a2, 1 - f) - q)/eps
874 d <- cbind(d1, d2)
875 v <- apply(d, 1, q.form, m = mat)
876 plot(-1/log(f), q, log = "x", type = "n", xlim = c(0.1, 1000), ylim = c(
877 min(dat, q), max(dat, q)), xlab = "Return Period", ylab =
878 "Return Level")
879 title("Return Level Plot")
880 lines(-1/log(f), q)
881 lines(-1/log(f), q + 1.96 * sqrt(v), col = 4)
882 lines(-1/log(f), q - 1.96 * sqrt(v), col = 4)
883 points(-1/log((1:length(dat))/(length(dat) + 1)), sort(dat))
884 }
885
886 "gum.df"<-
887 function(x, a, b)
888 {
889 #
890 # ancillary function calculates dist fnc of gumbel model
891 #
892 exp( - exp( - (x - a)/b))
893 }
894
895 "gum.q"<-
896 function(x, a, b)
897 {
898 #
899 # ancillary routine
900 # calculates quantiles of gumbel distn
901 #
902 a - b * log( - log(1 - x))
903 }
904
905 "gum.dens"<-
906 function(a, x)
907 {
908 #
909 # ancillary function calculates density for gumbel model
910 #
911 y <- (x - a[1])/a[2]
912 (exp( - y) * exp( - exp( - y)))/a[2]
913 }
914
915
916
917
918
919
920 # This file contains the following functions:
921 # identity q.form mrl.plot
922
923 "identity"<-
924 function(x)
925 x
926
927 "q.form"<-
928 function(d, m)
929 {
930 #
931 # ancillary routine
932 # evaluates quadratic forms
933 #
934 t(as.matrix(d)) %*% m %*% as.matrix(d)
935 }
936
937 "mrl.plot"<-
938 function(data, umin = min(data), umax = max(data) - 0.1, conf = 0.95, nint =
939 100)
940 {
941 #
942 # function to produce empirical mean residual life plot
943 # as function of threshold.
944 # confidence intervals included as well.
945 #
946 x <- xu <- xl <- numeric(nint)
947 u <- seq(umin, umax, length = nint)
948 for(i in 1:nint) {
949 data <- data[data > u[i]]
950 x[i] <- mean(data - u[i])
951 sdev <- sqrt(var(data))
952 n <- length(data)
953 xu[i] <- x[i] + (qnorm((1 + conf)/2) * sdev)/sqrt(n)
954 xl[i] <- x[i] - (qnorm((1 + conf)/2) * sdev)/sqrt(n)
955 }
956 plot(u, x, type = "l", xlab = "u", ylab = "Mean Excess", ylim = c(min(
957 xl[!is.na(xl)]), max(xu[!is.na(xu)])))
958 lines(u[!is.na(xl)], xl[!is.na(xl)], lty = 2)
959 lines(u[!is.na(xu)], xu[!is.na(xu)], lty = 2)
960 }
961
962 # This file contains the following functions:
963 # pp.fitrange pp.fit pp.diag pp.pp pp.qq
964 # ppf ppq ppp
965
966 "pp.fitrange"<-
967 function(data, umin, umax, npy = 365, nint = 10, show = FALSE)
968 {
969 #
970 # produces estimates and 95% confidence intervals
971 # for point process model across range of thresholds
972 #
973 m <- s <- up <- ul <- matrix(0, nrow = nint, ncol = 3)
974 u <- seq(umin, umax, length = nint)
975 for(i in 1:nint) {
976 z <- pp.fit(data, u[i], npy, show = show)
977 m[i, ] <- z$mle
978 s[i, ] <- z$se
979 up[i, ] <- z$mle + 1.96 * z$se
980 ul[i, ] <- z$mle - 1.96 * z$se
981 }
982 names <- c("Location", "Scale", "Shape")
983 oldpar <- par(mfrow = c(1, 3))
984 for(i in 1:3) {
985 um <- max(up[, i])
986 ud <- min(ul[, i])
987 plot(u, m[, i], ylim = c(ud, um), xlab = "Threshold", ylab =
988 names[i], type = "b")
989 for(j in 1:nint)
990 lines(c(u[j], u[j]), c(ul[j, i], up[j, i]))
991 }
992 par(oldpar)
993 invisible()
994 }
995
996 "pp.fit"<-
997 function(xdat, threshold, npy = 365, ydat = NULL, mul = NULL, sigl = NULL,
998 shl = NULL, mulink = identity, siglink = identity, shlink = identity,
999 show = TRUE, method = "Nelder-Mead", maxit = 10000, ...)
1000 {
1001 z <- list()
1002 npmu <- length(mul) + 1
1003 npsc <- length(sigl) + 1
1004 npsh <- length(shl) + 1
1005 n <- length(xdat)
1006 z$trans <- FALSE
1007 if(is.function(threshold))
1008 stop("`threshold' cannot be a function")
1009 u <- rep(threshold, length.out = n)
1010 if(length(unique(u)) > 1) z$trans <- TRUE
1011 xdatu <- xdat[xdat > u]
1012 xind <- (1:n)[xdat > u]
1013 u <- u[xind]
1014 in2 <- sqrt(6 * var(xdat))/pi
1015 in1 <- mean(xdat) - 0.57722 * in2
1016 if(is.null(mul)) {
1017 mumat <- as.matrix(rep(1, length(xdatu)))
1018 muinit <- in1
1019 }
1020 else {
1021 z$trans <- TRUE
1022 mumat <- cbind(rep(1, length(xdatu)), ydat[xind, mul])
1023 muinit <- c(in1, rep(0, length(mul)))
1024 }
1025 if(is.null(sigl)) {
1026 sigmat <- as.matrix(rep(1, length(xdatu)))
1027 siginit <- in2
1028 }
1029 else {
1030 z$trans <- TRUE
1031 sigmat <- cbind(rep(1, length(xdatu)), ydat[xind, sigl])
1032 siginit <- c(in2, rep(0, length(sigl)))
1033 }
1034 if(is.null(shl)) {
1035 shmat <- as.matrix(rep(1, length(xdatu)))
1036 shinit <- 0.1
1037 }
1038 else {
1039 z$trans <- TRUE
1040 shmat <- cbind(rep(1, length(xdatu)), ydat[xind, shl])
1041 shinit <- c(0.1, rep(0, length(shl)))
1042 }
1043 init <- c(muinit, siginit, shinit)
1044 z$model <- list(mul, sigl, shl)
1045 z$link <- deparse(substitute(c(mulink, siglink, shlink)))
1046 z$threshold <- threshold
1047 z$npy <- npy
1048 z$nexc <- length(xdatu)
1049 z$data <- xdatu
1050 pp.lik <- function(a) {
1051 mu <- mulink(mumat %*% (a[1:npmu]))
1052 sc <- siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)]))
1053 xi <- shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)]))
1054 if(any(sc <= 0)) return(10^6)
1055 if(min(1 + ((xi * (u - mu))/sc)) < 0) {
1056 l <- 10^6
1057 }
1058 else {
1059 y <- (xdatu - mu)/sc
1060 y <- 1 + xi * y
1061 if(min(y) <= 0)
1062 l <- 10^6
1063 else l <- sum(log(sc)) + sum(log(y) * (1/xi + 1)) + n/npy *
1064 mean((1 + (xi * (u - mu))/sc)^(-1/xi))
1065 }
1066 l
1067 }
1068 x <- optim(init, pp.lik, hessian = TRUE, method = method,
1069 control = list(maxit = maxit, ...))
1070 mu <- mulink(mumat %*% (x$par[1:npmu]))
1071 sc <- siglink(sigmat %*% (x$par[seq(npmu + 1, length = npsc)]))
1072 xi <- shlink(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)]))
1073 z$conv <- x$convergence
1074 z$nllh <- x$value
1075 z$vals <- cbind(mu, sc, xi, u)
1076 z$gpd <- apply(z$vals, 1, ppp, npy)
1077 if(z$trans) {
1078 z$data <- as.vector((1 + (xi * (xdatu - u))/z$gpd[2, ])^(-1/xi
1079 ))
1080 }
1081 z$mle <- x$par
1082 z$cov <- solve(x$hessian)
1083 z$se <- sqrt(diag(z$cov))
1084 if(show) {
1085 if(z$trans)
1086 print(z[c(2, 3)])
1087 if(length(z[[4]]) == 1)
1088 print(z[4])
1089 print(z[c(5, 6, 8)])
1090 if(!z$conv)
1091 print(z[c(9, 12, 14)])
1092 }
1093 invisible(z)
1094 }
1095
1096 "pp.diag"<-
1097 function(z)
1098 {
1099 n <- length(z$data)
1100 x <- (1:n)/(n + 1)
1101 if(z$trans) {
1102 oldpar <- par(mfrow = c(1, 2))
1103 plot(x, sort(z$data), xlab = "empirical", ylab = "model")
1104 abline(0, 1, col = 3)
1105 title("Residual Probability Plot")
1106 plot( - log(1 - x), - log(1 - sort(z$data)), ylab =
1107 "empirical", xlab = "model")
1108 abline(0, 1, col = 3)
1109 title("Residual quantile Plot (Exptl. Scale)")
1110 }
1111 else {
1112 oldpar <- par(mfrow = c(1, 2), pty = "s")
1113 pp.pp(z$mle, z$threshold, z$npy, z$data)
1114 pp.qq(z$mle, z$threshold, z$npy, z$data)
1115 }
1116 par(oldpar)
1117 invisible()
1118 }
1119
1120 "pp.pp"<-
1121 function(a, u, npy, dat)
1122 {
1123 #
1124 # function called by pp.diag
1125 # produces probability plot
1126 #
1127 y <- apply(as.matrix(sort(dat)), 1, ppf, a = a, u = u, npy = npy)
1128 plot((1:length(dat))/length(dat), y, xlab = "empirical", ylab = "model",
1129 main = "Probability plot")
1130 abline(0, 1, col = 4)
1131 }
1132
1133 "pp.qq"<-
1134 function(a, u, npy, dat)
1135 {
1136 #
1137 # function called by pp.diag
1138 # computes quantile plot
1139 #
1140 y <- apply(as.matrix((length(dat):1/(length(dat) + 1))), 1, ppq, a = a,
1141 u = u, npy = npy)
1142 plot(y, sort(dat), ylab = "empirical", xlab = "model", main =
1143 "Quantile Plot")
1144 abline(0, 1, col = 4)
1145 }
1146
1147 "ppf"<-
1148 function(a, z, u, npy)
1149 {
1150 #
1151 # ancillary function
1152 # calculates distribution function in point process model
1153 #
1154 b <- ppp(c(a, u), npy)
1155 1 - (1 + (b[3] * (z - u))/b[2])^(-1/b[3])
1156 }
1157
1158 "ppq"<-
1159 function(a, u, npy, p)
1160 {
1161 #
1162 # ancillary routine
1163 # finds quantiles in point process model
1164 #
1165 b <- ppp(c(a, u), npy)
1166 u + (b[2] * (((p))^( - b[3]) - 1))/b[3]
1167 }
1168
1169 "ppp"<-
1170 function(a, npy)
1171 {
1172 u <- a[4]
1173 la <- 1 - exp( - (1 + (a[3] * (u - a[1]))/a[2])^(-1/a[3])/npy)
1174 sc <- a[2] + a[3] * (u - a[1])
1175 xi <- a[3]
1176 c(la, sc, xi)
1177 }
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187 # This file contains the following functions:
1188 # rlarg.fit rlarg.diag rlarg.pp rlarg.qq
1189 # rlargf rlargq rlargq2
1190
1191 "rlarg.fit"<-
1192 function(xdat, r = dim(xdat)[2], ydat = NULL, mul = NULL, sigl = NULL,
1193 shl = NULL, mulink = identity, siglink = identity, shlink = identity,
1194 show = TRUE, method = "Nelder-Mead", maxit = 10000, ...)
1195 {
1196 #
1197 # calculates mles etc for rlargest order statistic model
1198 #
1199 z <- list()
1200 npmu <- length(mul) + 1
1201 npsc <- length(sigl) + 1
1202 npsh <- length(shl) + 1
1203 z$trans <- FALSE
1204 in2 <- sqrt(6 * var(xdat[, 1]))/pi
1205 in1 <- mean(xdat[, 1]) - 0.57722 * in2
1206 if(is.null(mul)) {
1207 mumat <- as.matrix(rep(1, dim(xdat)[1]))
1208 muinit <- in1
1209 }
1210 else {
1211 z$trans <- TRUE
1212 mumat <- cbind(rep(1, dim(xdat)[1]), ydat[, mul])
1213 muinit <- c(in1, rep(0, length(mul)))
1214 }
1215 if(is.null(sigl)) {
1216 sigmat <- as.matrix(rep(1, dim(xdat)[1]))
1217 siginit <- in2
1218 }
1219 else {
1220 z$trans <- TRUE
1221 sigmat <- cbind(rep(1, dim(xdat)[1]), ydat[, sigl])
1222 siginit <- c(in2, rep(0, length(sigl)))
1223 }
1224 if(is.null(shl)) {
1225 shmat <- as.matrix(rep(1, dim(xdat)[1]))
1226 shinit <- 0.1
1227 }
1228 else {
1229 z$trans <- TRUE
1230 shmat <- cbind(rep(1, dim(xdat)[1]), ydat[, shl])
1231 shinit <- c(0.1, rep(0, length(shl)))
1232 }
1233 xdatu <- xdat[, 1:r, drop = FALSE]
1234 init <- c(muinit, siginit, shinit)
1235 z$model <- list(mul, sigl, shl)
1236 z$link <- deparse(substitute(c(mulink, siglink, shlink)))
1237 u <- apply(xdatu, 1, min, na.rm = TRUE)
1238 rlarg.lik <- function(a) {
1239 # calculates neg log lik
1240 mu <- mulink(drop(mumat %*% (a[1:npmu])))
1241 sc <- siglink(drop(sigmat %*% (a[seq(npmu + 1, length = npsc)])))
1242 xi <- shlink(drop(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)])))
1243 if(any(sc <= 0)) return(10^6)
1244 y <- 1 + xi * (xdatu - mu)/sc
1245 if(min(y, na.rm = TRUE) <= 0)
1246 l <- 10^6
1247 else {
1248 y <- (1/xi+1) * log(y) + log(sc)
1249 y <- rowSums(y, na.rm = TRUE)
1250 l <- sum((1 + xi * (u - mu)/sc)^(-1/xi) + y)
1251 }
1252 l
1253 }
1254 x <- optim(init, rlarg.lik, hessian = TRUE, method = method,
1255 control = list(maxit = maxit, ...))
1256 mu <- mulink(drop(mumat %*% (x$par[1:npmu])))
1257 sc <- siglink(drop(sigmat %*% (x$par[seq(npmu + 1, length = npsc)])))
1258 xi <- shlink(drop(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)])))
1259 z$conv <- x$convergence
1260 z$nllh <- x$value
1261 z$data <- xdat
1262 if(z$trans) {
1263 for(i in 1:r)
1264 z$data[, i] <- - log((1 + (as.vector(xi) * (xdat[, i] -
1265 as.vector(mu)))/as.vector(sc))^(-1/as.vector(xi
1266 )))
1267 }
1268 z$mle <- x$par
1269 z$cov <- solve(x$hessian)
1270 z$se <- sqrt(diag(z$cov))
1271 z$vals <- cbind(mu, sc, xi)
1272 z$r <- r
1273 if(show) {
1274 if(z$trans)
1275 print(z[c(2, 3)])
1276 print(z[4])
1277 if(!z$conv)
1278 print(z[c(5, 7, 9)])
1279 }
1280 invisible(z)
1281 }
1282
1283 "rlarg.diag"<-
1284 function(z, n = z$r)
1285 {
1286 #
1287 # takes output from rlarg.fit
1288 # produces probability and quantile plots for
1289 # each order statistic
1290 #
1291 z2 <- z
1292 z2$data <- z$data[, 1]
1293 oldpar <- par(ask = TRUE, mfcol = c(2, 2))
1294 if(z$trans) {
1295 for(i in 1:n) {
1296 rlarg.pp(c(0, 1, 0), z$data[, 1:z$r], i)
1297 rlarg.qq(c(0, 1, 0), z$data[, 1:z$r], i)
1298 }
1299 }
1300 else {
1301 gev.diag(z2)
1302 for(i in 1:n) {
1303 rlarg.pp(z$mle, z$data, i)
1304 rlarg.qq(z$mle, z$data, i)
1305 }
1306 }
1307 par(oldpar)
1308 invisible()
1309 }
1310
1311 "rlarg.pp"<-
1312 function(a, dat, k)
1313 {
1314 #
1315 # ancillary function
1316 # calculates probability plot in r largest model
1317 #
1318 da <- dat[!is.na(dat[, k]), k]
1319 plot((1:length(da))/length(da), rlargf(a, sort(da), k), xlab = "", ylab
1320 = "")
1321 title(paste("k=", k, sep = ""), cex = 0.7)
1322 abline(0, 1, col = 4)
1323 }
1324
1325 "rlarg.qq"<-
1326 function(a, dat, k)
1327 {
1328 #
1329 # ancillary function
1330 # calculates quantile plot in r largest model
1331 #
1332 da <- dat[!is.na(dat[, k]), k]
1333 plot(rlargq(a, 1 - (1:length(da)/(length(da) + 1)), k, da), sort(da),
1334 xlab = "", ylab = "")
1335 title(paste("k=", k, sep = ""), cex = 0.7)
1336 abline(0, 1, col = 4)
1337 }
1338
1339 "rlargf"<-
1340 function(a, z, k)
1341 {
1342 #
1343 # ancillary function
1344 # calculates dist fnc in r largest model
1345 #
1346 eps <- 10^(-6)
1347 res <- NULL
1348 if(abs(a[3]) < eps)
1349 tau <- exp( - (z - a[1])/a[2])
1350 else tau <- (1 + (a[3] * (z - a[1]))/a[2])^(-1/a[3])
1351 for(i in 1:length(tau)) {
1352 if(is.na(tau[i]))
1353 res[i] <- 1
1354 else res[i] <- exp( - tau[i]) * sum(tau[i]^(0:(k - 1))/gamma(1:(
1355 k)))
1356 }
1357 res
1358 }
1359
1360 "rlargq"<-
1361 function(a, p, k, dat)
1362 {
1363 #
1364 # ancillary routine
1365 # for finding quantiles in r largest model
1366 res <- NULL
1367 for(i in 1:length(p)) {
1368 inter <- c(min(dat) - 1, max(dat) + 1)
1369 res[i] <- uniroot(rlargq2, inter, a = a, kk = k, p = p[i])$root
1370 }
1371 res
1372 }
1373
1374 "rlargq2"<-
1375 function(x, a, kk, p)
1376 {
1377 #
1378 # ancillary routine
1379 # for finding quantiles in r largest model
1380 #
1381 res <- rlargf(a, x, kk) - (1 - p)
1382 res
1383 }
1384
1385
1386
1387 ################################################################################
1388
1389
1390 "gev" <-
1391 function(data, block = NA, ...)
1392 {
1393 n.all <- NA
1394 if(!is.na(block)) {
1395 n.all <- length(data)
1396 if(is.character(block)) {
1397 times <- as.POSIXlt(attributes(data)$times)
1398 if(block %in% c("semester", "quarter")) {
1399 sem <- quart <- times$mon
1400 sem[sem %in% 0:5] <- quart[quart %in% 0:2] <- 0
1401 sem[sem %in% 6:11] <- quart[quart %in% 3:5] <- 1
1402 quart[quart %in% 6:8] <- 2
1403 quart[quart %in% 9:11] <- 3
1404 }
1405 grouping <- switch(block,
1406 semester = paste(times$year, sem),
1407 quarter = paste(times$year, quart),
1408 month = paste(times$year, times$mon),
1409 year = times$year,
1410 stop("unknown time period"))
1411 data <- tapply(data, grouping, max)
1412 }
1413 else {
1414 data <- as.numeric(data)
1415 nblocks <- (length(data) %/% block) + 1
1416 grouping <- rep(1:nblocks, rep(block, nblocks))[1:length(data)]
1417 data <- tapply(data, grouping, max)
1418 }
1419 }
1420 data <- as.numeric(data)
1421 n <- length(data)
1422 sigma0 <- sqrt(6 * var(data))/pi
1423 mu0 <- mean(data) - 0.57722 * sigma0
1424 xi0 <- 0.1
1425 theta <- c(xi0, sigma0, mu0)
1426 negloglik <- function(theta, tmp)
1427 {
1428 y <- 1 + (theta[1] * (tmp - theta[3]))/theta[2]
1429 if((theta[2] < 0) || (min(y) < 0))
1430 out <- 1e+06
1431 else {
1432 term1 <- length(tmp) * logb(theta[2])
1433 term2 <- sum((1 + 1/theta[1]) * logb(y))
1434 term3 <- sum(y^(-1/theta[1]))
1435 out <- term1 + term2 + term3
1436 }
1437 out
1438 }
1439 fit <- optim(theta, negloglik, hessian = TRUE, ..., tmp = data)
1440 if(fit$convergence)
1441 warning("optimization may not have succeeded")
1442 par.ests <- fit$par
1443 varcov <- solve(fit$hessian)
1444 par.ses <- sqrt(diag(varcov))
1445 out <- list(n.all = n.all, n = n, data = data, block = block, par.ests
1446 = par.ests, par.ses = par.ses, varcov = varcov, converged =
1447 fit$convergence, nllh.final = fit$value)
1448 names(out$par.ests) <- c("xi", "sigma", "mu")
1449 names(out$par.ses) <- c("xi", "sigma", "mu")
1450 class(out) <- "gev"
1451 out
1452 }
1453
1454 "gumbel" <-
1455 function(data, block = NA, ...)
1456 {
1457 n.all <- NA
1458 data <- as.numeric(data)
1459 if(!is.na(block)) {
1460 n.all <- length(data)
1461 if(fg <- n.all %% block) {
1462 data <- c(data, rep(NA, block - fg))
1463 warning(paste("final group contains only", fg, "observations"))
1464 }
1465 data <- apply(matrix(data, nrow = block), 2, max, na.rm = TRUE)
1466 }
1467 n <- length(data)
1468 sigma0 <- sqrt(6 * var(data))/pi
1469 mu0 <- mean(data) - 0.57722 * sigma0
1470 theta <- c(sigma0, mu0)
1471 negloglik <- function(theta, tmp)
1472 {
1473 y <- (tmp - theta[2])/theta[1]
1474 if(theta[1] < 0)
1475 out <- 1e+06
1476 else {
1477 term1 <- length(tmp) * logb(theta[1])
1478 term2 <- sum(y)
1479 term3 <- sum(exp( - y))
1480 out <- term1 + term2 + term3
1481 }
1482 out
1483 }
1484 fit <- optim(theta, negloglik, hessian = TRUE, ..., tmp = data)
1485 if(fit$convergence)
1486 warning("optimization may not have succeeded")
1487 par.ests <- fit$par
1488 varcov <- solve(fit$hessian)
1489 par.ses <- sqrt(diag(varcov))
1490 out <- list(n.all = n.all, n = n, data = data, block = block, par.ests
1491 = par.ests, par.ses = par.ses, varcov = varcov, converged =
1492 fit$convergence, nllh.final = fit$value)
1493 names(out$par.ests) <- c("sigma", "mu")
1494 names(out$par.ses) <- c("sigma", "mu")
1495 class(out) <- "gev"
1496 out
1497 }
1498
1499 "plot.gev" <-
1500 function(x, ...)
1501 {
1502 par.ests <- x$par.ests
1503 mu <- par.ests["mu"]
1504 sigma <- par.ests["sigma"]
1505 if(!("xi" %in% names(par.ests)))
1506 xi <- 0
1507 else xi <- par.ests["xi"]
1508 if(xi != 0)
1509 residuals <- (1 + (xi * (x$data - mu))/sigma)^(-1/xi)
1510 else residuals <- exp( - exp( - (x$data - mu)/sigma))
1511 choices <- c("Scatterplot of Residuals", "QQplot of Residuals")
1512 tmenu <- paste("plot:", choices)
1513 pick <- 1
1514 while(pick > 0) {
1515 pick <- menu(tmenu, title =
1516 "\nMake a plot selection (or 0 to exit):")
1517 switch(pick,
1518 {
1519 plot(residuals, ylab = "Residuals",
1520 xlab = "Ordering", ...)
1521 lines(lowess(1:length(residuals), residuals))
1522 },
1523 qplot(residuals, ...))
1524 }
1525 }
1526
1527 "rlevel.gev" <-
1528 function(out, k.blocks = 20, add = FALSE, ...)
1529 {
1530 par.ests <- out$par.ests
1531 mu <- par.ests["mu"]
1532 sigma <- par.ests["sigma"]
1533 if(!("xi" %in% names(par.ests)))
1534 stop("Use this function after a GEV rather than a Gumbel fit")
1535 else xi <- par.ests["xi"]
1536 pp <- 1/k.blocks
1537 v <- qgev((1 - pp), xi, mu, sigma)
1538 if(add) abline(h = v)
1539 data <- out$data
1540 overallmax <- out$nllh.final
1541 sigma0 <- sqrt(6 * var(data))/pi
1542 xi0 <- 0.01
1543 theta <- c(xi0, sigma0)
1544 parloglik <- function(theta, tmp, pp, rli)
1545 {
1546 mu <- rli + (theta[2] * (1 - ( - logb(1 - pp))^( - theta[
1547 1])))/theta[1]
1548 y <- 1 + (theta[1] * (tmp - mu))/theta[2]
1549 if((theta[2] < 0) | (min(y) < 0))
1550 out <- 1e+06
1551 else {
1552 term1 <- length(tmp) * logb(theta[2])
1553 term2 <- sum((1 + 1/theta[1]) * logb(y))
1554 term3 <- sum(y^(-1/theta[1]))
1555 out <- term1 + term2 + term3
1556 }
1557 out
1558 }
1559 parmax <- NULL
1560 rl <- v * c(0.5, 0.6, 0.7, 0.8, 0.85, 0.9, 0.95, 1, 1.1, 1.2,
1561 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, 3, 3.25, 3.5, 4.5)
1562 for(i in 1:length(rl)) {
1563 fit <- optim(theta, parloglik, hessian = FALSE, tmp = data,
1564 pp = pp, rli = rl[i])
1565 parmax <- rbind(parmax, fit$value)
1566 }
1567 parmax <- - parmax
1568 overallmax <- - overallmax
1569 crit <- overallmax - qchisq(0.9999, 1)/2
1570 cond <- parmax > crit
1571 rl <- rl[cond]
1572 parmax <- parmax[cond]
1573 smth <- spline(rl, parmax, n = 200)
1574 aalpha <- qchisq(0.95, 1)
1575 if(!add) {
1576 plot(rl, parmax, type = "p", ...)
1577 abline(h = overallmax - aalpha/2)
1578 abline(v = v)
1579 lines(smth)
1580 }
1581 ind <- smth$y > overallmax - aalpha/2
1582 ci <- range(smth$x[ind])
1583 if(add) {
1584 abline(h = ci[1], lty = 2, col = 2)
1585 abline(h = ci[2], lty = 2, col = 2)
1586 }
1587 as.numeric(c(ci[1], v, ci[2]))
1588 }
1589
1590
1591 "gpdbiv" <-
1592 function(data1 = NA, data2 = NA, u1 = NA, u2 = NA, ne1 = NA,
1593 ne2 = NA, global = FALSE, method = "BFGS", ...)
1594 {
1595 data1 <- as.numeric(data1)
1596 data2 <- as.numeric(data2)
1597
1598 Zfunc <- function(y, u, lambda, xi, sigma)
1599 (lambda^-1) * (1 + (xi * pmax((y - u), 0))/sigma)^(1/xi)
1600 Kfunc <- function(y, u, lambda, xi, sigma)
1601 -lambda^(-xi) * (sigma^-1) * (Zfunc(y, u, lambda, xi, sigma))^(1 - xi)
1602 Vfunc <- function(x, y, alpha)
1603 (x^(-1/alpha) + y^(-1/alpha))^alpha
1604 Vfunc1 <- function(x, y, alpha)
1605 -x^(-(1/alpha) - 1) * (x^(-1/alpha) + y^(-1/alpha))^(alpha - 1)
1606 Vfunc2 <- function(x, y, alpha)
1607 -(alpha - 1) * (alpha^-1) * (x * y)^(-(1/alpha) - 1) *
1608 (x^(-1/alpha) + y^(-1/alpha))^(alpha - 2)
1609 fun <- list(Z = Zfunc, K = Kfunc, V = Vfunc, V1 = Vfunc1, V2 = Vfunc2)
1610
1611 if(is.na(ne1) && is.na(u1))
1612 stop(paste("Enter either a threshold or",
1613 "the number of upper extremes for margin 1"))
1614 if(!is.na(ne1) && !is.na(u1))
1615 stop(paste("Enter EITHER a threshold or",
1616 "the number of upper extremes for margin 1"))
1617 if(is.na(ne2) && is.na(u2))
1618 stop(paste("Enter either a threshold or",
1619 "the number of upper extremes for margin 2"))
1620 if(!is.na(ne2) && !is.na(u2))
1621 stop(paste("Enter EITHER a threshold or",
1622 "the number of upper extremes for margin 2"))
1623
1624 out1 <- gpd(data1, threshold = u1, ne = ne1)
1625 par.ests1 <- out1$par.ests
1626 par.ses1 <- out1$par.ses
1627
1628 out2 <- gpd(data2, threshold = u2, ne = ne2)
1629 par.ests2 <- out2$par.ests
1630 par.ses2 <- out2$par.ses
1631
1632 uu <- c(out1$threshold, out2$threshold)
1633 ne <- c(out1$n.exceed, out2$n.exceed)
1634 mpar <- c(par.ests1, par.ests2)
1635
1636 delta1 <- as.numeric(data1 > uu[1])
1637 delta2 <- as.numeric(data2 > uu[2])
1638 lambda1 <- sum(delta1)/length(data1)
1639 lambda2 <- sum(delta2)/length(data2)
1640
1641 theta <- 0.8
1642 if(global) {
1643 theta <- c(theta, mpar)
1644 mpar <- NULL
1645 }
1646
1647 negloglik <- function(theta, data1, data2, uu, delta1, delta2,
1648 lambda1, lambda2, mpar, fun)
1649 {
1650 alpha <- theta[1]
1651 if(is.null(mpar)) {
1652 xi1 <- theta[2] ; sigma1 <- theta[3]
1653 xi2 <- theta[4] ; sigma2 <- theta[5]
1654 }
1655 else {
1656 xi1 <- mpar[1] ; sigma1 <- mpar[2]
1657 xi2 <- mpar[3] ; sigma2 <- mpar[4]
1658 }
1659 cond1 <- (alpha <= 0) | (alpha >= 1)
1660 cond2 <- sigma1 <= 0
1661 cond3 <- sigma2 <= 0
1662 if(cond1 || cond2 || cond3)
1663 out <- 1e+06
1664 else {
1665 term4 <- (1 - delta1) * (1 - delta2) * logb(1 -
1666 fun$V(lambda1^-1, lambda2^-1, alpha))
1667 term3 <- delta1 * (1 - delta2) * logb(fun$K(data1, uu[1], lambda1,
1668 xi1, sigma1) * fun$V1(fun$Z(data1, uu[1], lambda1, xi1,
1669 sigma1), lambda2^-1, alpha))
1670 term2 <- delta2 * (1 - delta1) * logb(fun$K(data2, uu[2], lambda2,
1671 xi2, sigma2) * fun$V1(fun$Z(data2, uu[2], lambda2, xi2,
1672 sigma2), lambda1^-1, alpha))
1673 term1 <- delta1 * delta2 * logb(fun$K(data1, uu[1], lambda1, xi1,
1674 sigma1) * fun$K(data2, uu[2], lambda2, xi2, sigma2) *
1675 fun$V2(fun$Z(data1, uu[1], lambda1, xi1, sigma1), fun$Z(data2,
1676 uu[2], lambda2, xi2, sigma2), alpha))
1677 allterm <- term1 + term2 + term3 + term4
1678 out <- - sum(allterm)
1679 }
1680 out
1681 }
1682 fit <- optim(theta, negloglik, hessian = TRUE, method = method, ...,
1683 data1 = data1, data2 = data2, uu = uu,
1684 delta1 = delta1, delta2 = delta2, lambda1 = lambda1,
1685 lambda2 = lambda2, mpar = mpar, fun = fun)
1686 if(fit$convergence)
1687 warning("optimization may not have succeeded")
1688 par.ests <- fit$par
1689 varcov <- solve(fit$hessian)
1690 par.ses <- sqrt(diag(varcov))
1691 alpha <- par.ests[1]
1692 alpha.se <- par.ses[1]
1693 if(global) {
1694 par.ests1 <- c(par.ests[2], par.ests[3])
1695 names(par.ests1) <- c("xi", "beta")
1696 par.ses1 <- c(par.ses[2], par.ses[3])
1697 par.ests2 <- c(par.ests[4], par.ests[5])
1698 names(par.ests2) <- c("xi", "beta")
1699 par.ses2 <- c(par.ses[4], par.ses[5])
1700 }
1701 out <- list(data1 = data1[delta1 == 1], delta1 = (delta1 ==
1702 1 & delta2 == 1)[delta1 == 1], data2 = data2[
1703 delta2 == 1], delta2 = (delta1 == 1 & delta2 == 1)[delta2 ==
1704 1], u1 = uu[1], ne1 = ne[1], lambda1 = lambda1, u2 = uu[2],
1705 ne2 = ne[2], lambda2 = lambda2, alpha = alpha, alpha.se = alpha.se,
1706 par.ests1 = par.ests1, par.ses1 = par.ses1, par.ests2 =
1707 par.ests2, par.ses2 = par.ses2, converged = fit$convergence,
1708 nllh.final = fit$value, dependence = "logistic",
1709 dep.func = Vfunc)
1710 class(out) <- "gpdbiv"
1711 out
1712 }
1713
1714 "interpret.gpdbiv" <-
1715 function(out, x, y)
1716 {
1717 Vfuncf <- out$dep.func
1718 newfunc <- function(x, y, alpha, u1, lambda1, xi1, sigma1, u2, lambda2,
1719 xi2, sigma2, vfunc)
1720 {
1721 Zfunc <- function(y, u, lambda, xi, sigma)
1722 (lambda^-1) * (1 + (xi * pmax((y - u), 0))/sigma)^(1/xi)
1723 1 - vfunc(Zfunc(x, u1, lambda1, xi1, sigma1), Zfunc(y, u2,
1724 lambda2, xi2, sigma2), alpha)
1725 }
1726 marg <- function(x, u1, lambda1, xi1, sigma1)
1727 {
1728 1 - lambda1 * (1 + (xi1 * (x - u1))/sigma1)^(-1/xi1)
1729 }
1730 newfunc2 <- function(x, y, alpha, u1, lambda1, xi1, sigma1, u2, lambda2,
1731 xi2, sigma2, marg, newfunc, vfunc)
1732 {
1733 1 - marg(x, u1, lambda1, xi1, sigma1) - marg(y, u2, lambda2, xi2,
1734 sigma2) + newfunc(x, y, alpha, u1, lambda1, xi1, sigma1, u2,
1735 lambda2, xi2, sigma2, vfunc)
1736 }
1737
1738 if(out$u1 > x) stop("Point below x threshold")
1739 if(out$u2 > y) stop("Point below y threshold")
1740 p1 <- 1 - marg(x, out$u1, out$lambda1, out$par.ests1[1], out$
1741 par.ests1[2])
1742 p2 <- 1 - marg(y, out$u2, out$lambda2, out$par.ests2[1], out$
1743 par.ests2[2])
1744 p12 <- newfunc2(x, y, out$alpha, out$u1, out$lambda1, out$par.ests1[1],
1745 out$par.ests1[2], out$u2, out$lambda2, out$par.ests2[1],
1746 out$par.ests2[2], marg, newfunc, Vfuncf)
1747
1748 cat("Thresholds:", out$u1, out$u2, "\n")
1749 cat("Extreme levels of interest (x,y):", x, y, "\n")
1750 cat("P(X exceeds x)", p1, "\n")
1751 cat("P(Y exceeds y)", p2, "\n")
1752 cat("P(X exceeds x AND Y exceeds y)", p12, "\n")
1753 cat("P(X exceeds x) * P(Y exceeds y)", p1 * p2, "\n")
1754 cat("P(Y exceeds y GIVEN X exceeds x)", p12/p1, "\n")
1755 cat("P(X exceeds x GIVEN Y exceeds y)", p12/p2, "\n")
1756 invisible(as.numeric(c(p1, p2, p12, p1 * p2, p12/p1, p12/p2)))
1757 }
1758
1759 "plot.gpdbiv" <-
1760 function(x, extend = 1.1, n.contours = 15, ...)
1761 {
1762 Zfunc <- function(y, u, lambda, xi, sigma)
1763 (lambda^-1) * (1 + (xi * pmax((y - u), 0))/sigma)^(1/xi)
1764
1765 joint <- function(xx, y, alpha, u1, lambda1, xi1, sigma1, u2, lambda2,
1766 xi2, sigma2, Vfunc)
1767 {
1768 1 - Vfunc(Zfunc(xx, u1, lambda1, xi1, sigma1),
1769 Zfunc(y, u2, lambda2, xi2, sigma2), alpha)
1770 }
1771 marg <- function(xx, u1, lambda1, xi1, sigma1)
1772 {
1773 1 - lambda1 * (1 + (xi1 * (xx - u1))/sigma1)^(-1/xi1)
1774 }
1775 survivor <- function(xx, y, alpha, u1, lambda1, xi1, sigma1, u2,
1776 lambda2, xi2, sigma2, marg, joint, Vfunc)
1777 {
1778 1 - marg(xx, u1, lambda1, xi1, sigma1) - marg(y, u2, lambda2,
1779 xi2, sigma2) + joint(xx, y, alpha, u1, lambda1, xi1,
1780 sigma1, u2, lambda2, xi2, sigma2, Vfunc)
1781 }
1782
1783 xx <- seq(from = x$u1, to = extend * max(x$data1), length = 200)
1784 y <- seq(from = x$u2, to = extend * max(x$data2), length = 200)
1785 choices <- c("Exceedance data",
1786 "Contours of Bivariate Distribution Function",
1787 "Contours of Bivariate Survival Function",
1788 "Tail of Marginal 1", "Tail of Marginal 2")
1789 tmenu <- paste("plot:", choices)
1790 pick <- 1
1791 while(pick > 0) {
1792 par(mfrow = c(1, 1))
1793 pick <- menu(tmenu, title =
1794 "\nMake a plot selection (or 0 to exit):")
1795 if(pick == 1) {
1796 par(mfrow = c(2, 1))
1797 plot(x$data1, main = "Marginal1", type = "n", ...)
1798 points((1:length(x$data1))[x$delta1 == 0],
1799 x$data1[x$delta1 == 0])
1800 points((1:length(x$data1))[x$delta1 == 1],
1801 x$data1[x$delta1 == 1], col = 2)
1802 plot(x$data2, main = "Marginal2", type = "n", ...)
1803 points((1:length(x$data2))[x$delta2 == 0],
1804 x$data2[x$delta2 == 0])
1805 points((1:length(x$data2))[x$delta2 == 1],
1806 x$data2[x$delta2 == 1], col = 2)
1807 }
1808 if(pick == 4) {
1809 x$name <- "Marginal1"
1810 x$par.ests <- x$par.ests1
1811 x$data <- x$data1
1812 x$threshold <- x$u1
1813 x$p.less.thresh <- 1 - x$lambda1
1814 tailplot(x, ...)
1815 }
1816 if(pick == 5) {
1817 x$name <- "Marginal2"
1818 x$par.ests <- x$par.ests2
1819 x$data <- x$data2
1820 x$threshold <- x$u2
1821 x$p.less.thresh <- 1 - x$lambda2
1822 tailplot(x, ...)
1823 }
1824 if(pick == 2) {
1825 z <- outer(xx, y, joint, alpha = x$alpha, u1 = x$u1,
1826 lambda1 = x$lambda1, xi1 = x$par.ests1[1],
1827 sigma1 = x$par.ests1[2], u2 = x$u2, lambda2 =
1828 x$lambda2, xi2 = x$par.ests2[1], sigma2 =
1829 x$par.ests2[2], Vfunc = x$dep.func)
1830 par(xaxs = "i", yaxs = "i")
1831 contour(xx, y, z, nlevels = n.contours, main = "Joint", ...)
1832 }
1833 if(pick == 3) {
1834 z2 <- outer(xx, y, survivor, alpha = x$alpha, u1 = x$u1,
1835 lambda1 = x$lambda1, xi1 = x$par.ests1[1],
1836 sigma1 = x$par.ests1[2], u2 = x$u2, lambda2 =
1837 x$lambda2, xi2 = x$par.ests2[1], sigma2 =
1838 x$par.ests2[2], marg = marg, joint = joint,
1839 Vfunc = x$dep.func)
1840 level.thresh <- x$lambda1 + x$lambda2 - (x$lambda1^(1/x$alpha) +
1841 x$lambda2^(1/x$alpha))^x$alpha
1842 contour(xx, y, z2, nlevels = n.contours, main = "Survival", ...)
1843 }
1844 }
1845 }
1846
1847 "emplot" <-
1848 function(data, alog = "x", labels = TRUE, ...)
1849 {
1850 data <- sort(as.numeric(data))
1851 ypoints <- 1 - ppoints(data)
1852 plot(data, ypoints, log = alog, xlab = "", ylab = "", ...)
1853 if(labels) {
1854 xxlab <- "x"
1855 yylab <- "1 - F(x)"
1856 if(alog != "")
1857 xxlab <- paste(xxlab, "(on log scale)")
1858 if(alog == "xy" || alog == "yx")
1859 yylab <- paste(yylab, "(on log scale)")
1860 title(xlab = xxlab, ylab = yylab)
1861 }
1862 invisible(list(x = data, y = ypoints))
1863 }
1864
1865 "exindex" <-
1866 function(data, block, start = 5, end = NA, reverse = FALSE,
1867 auto.scale = TRUE, labels = TRUE, ...)
1868 {
1869 sorted <- rev(sort(as.numeric(data)))
1870 n <- length(sorted)
1871 if(is.character(block)) {
1872 times <- as.POSIXlt(attributes(data)$times)
1873 if(block %in% c("semester", "quarter")) {
1874 sem <- quart <- times$mon
1875 sem[sem %in% 0:5] <- quart[quart %in% 0:2] <- 0
1876 sem[sem %in% 6:11] <- quart[quart %in% 3:5] <- 1
1877 quart[quart %in% 6:8] <- 2
1878 quart[quart %in% 9:11] <- 3
1879 }
1880 grouping <- switch(block,
1881 semester = paste(times$year, sem),
1882 quarter = paste(times$year, quart),
1883 month = paste(times$year, times$mon),
1884 year = times$year,
1885 stop("unknown time period"))
1886 b.lengths <- as.numeric(tapply(data, grouping, length))
1887 b.maxima <- as.numeric(tapply(data, grouping, max))
1888 }
1889 else {
1890 data <- as.numeric(data)
1891 nblocks <- (length(data) %/% block) + 1
1892 grouping <- rep(1:nblocks, rep(block, nblocks))[1:length(data)]
1893 b.lengths <- tapply(data, grouping, length)
1894 b.maxima <- tapply(data, grouping, max)
1895 }
1896 b.lengths <- b.lengths[!is.na(b.lengths)]
1897 b.maxima <- rev(sort(b.maxima[!is.na(b.maxima)]))
1898 if(is.numeric(block)) r <- block
1899 else r <- round(mean(b.lengths[2:(length(b.lengths) - 1)]))
1900 k <- round(n/r)
1901 un <- unique(b.maxima)[-1]
1902 K <- match(un, b.maxima) - 1
1903 N <- match(un, sorted) - 1
1904 if(is.na(end)) end <- k
1905 cond <- (K < end) & (K >= start)
1906 un <- un[cond]
1907 K <- K[cond]
1908 N <- N[cond]
1909 theta2 <- K/N
1910 theta <- logb(1 - K/k)/(r * logb(1 - N/n))
1911 out <- cbind(N, K, un, theta2, theta)
1912 yrange <- range(theta)
1913 index <- K
1914 if(reverse) index <- - K
1915 if(auto.scale)
1916 plot(index, theta, ylim = yrange, type = "l", xlab = "", ylab = "",
1917 axes = FALSE, ...)
1918 else plot(index, theta, type = "l", xlab = "", ylab = "", axes =
1919 FALSE, ...)
1920 axis(1, at = index, lab = paste(K), tick = FALSE)
1921 axis(2)
1922 axis(3, at = index, lab = paste(format(signif(un, 3))), tick = FALSE)
1923 box()
1924 if(labels) {
1925 ylabel <- paste("theta (", k, " blocks of size ", r, ")", sep = "")
1926 title(xlab = "K", ylab = ylabel)
1927 mtext("Threshold", side = 3, line = 3)
1928 }
1929 invisible(out)
1930 }
1931
1932 "hill" <-
1933 function(data, option = c("alpha","xi","quantile"), start = 15, end = NA,
1934 reverse = FALSE, p = NA, ci = 0.95, auto.scale = TRUE, labels = TRUE, ...)
1935 {
1936 data <- as.numeric(data)
1937 ordered <- rev(sort(data))
1938 ordered <- ordered[ordered > 0]
1939 n <- length(ordered)
1940 option <- match.arg(option)
1941 if((option == "quantile") && (is.na(p)))
1942 stop("Input a value for the probability p")
1943 if((option == "quantile") && (p < 1 - start/n)) {
1944 cat("Graph may look strange !! \n\n")
1945 cat(paste("Suggestion 1: Increase `p' above",
1946 format(signif(1 - start/n, 5)), "\n"))
1947 cat(paste("Suggestion 2: Increase `start' above ",
1948 ceiling(length(data) * (1 - p)), "\n"))
1949 }
1950 k <- 1:n
1951 loggs <- logb(ordered)
1952 avesumlog <- cumsum(loggs)/(1:n)
1953 xihat <- c(NA, (avesumlog - loggs)[2:n])
1954 alphahat <- 1/xihat
1955 y <- switch(option,
1956 alpha = alphahat,
1957 xi = xihat,
1958 quantile = ordered * ((n * (1 - p))/k)^(-1/alphahat))
1959 ses <- y/sqrt(k)
1960 if(is.na(end)) end <- n
1961 x <- trunc(seq(from = min(end, length(data)), to = start))
1962 y <- y[x]
1963 ylabel <- option
1964 yrange <- range(y)
1965 if(ci && (option != "quantile")) {
1966 qq <- qnorm(1 - (1 - ci)/2)
1967 u <- y + ses[x] * qq
1968 l <- y - ses[x] * qq
1969 ylabel <- paste(ylabel, " (CI, p =", ci, ")", sep = "")
1970 yrange <- range(u, l)
1971 }
1972 if(option == "quantile") ylabel <- paste("Quantile, p =", p)
1973 index <- x
1974 if(reverse) index <- - x
1975 if(auto.scale)
1976 plot(index, y, ylim = yrange, type = "l", xlab = "", ylab = "",
1977 axes = FALSE, ...)
1978 else plot(index, y, type = "l", xlab = "", ylab = "", axes = FALSE, ...)
1979 axis(1, at = index, lab = paste(x), tick = FALSE)
1980 axis(2)
1981 threshold <- findthresh(data, x)
1982 axis(3, at = index, lab = paste(format(signif(threshold, 3))),
1983 tick = FALSE)
1984 box()
1985 if(ci && (option != "quantile")) {
1986 lines(index, u, lty = 2, col = 2)
1987 lines(index, l, lty = 2, col = 2)
1988 }
1989 if(labels) {
1990 title(xlab = "Order Statistics", ylab = ylabel)
1991 mtext("Threshold", side = 3, line = 3)
1992 }
1993 invisible(list(x = index, y = y))
1994 }
1995
1996 "meplot" <-
1997 function(data, omit = 3, labels = TRUE, ...)
1998 {
1999 data <- as.numeric(data)
2000 n <- length(data)
2001 myrank <- function(x, na.last = TRUE)
2002 {
2003 ranks <- sort.list(sort.list(x, na.last = na.last))
2004 if(is.na(na.last))
2005 x <- x[!is.na(x)]
2006 for(i in unique(x[duplicated(x)])) {
2007 which <- x == i & !is.na(x)
2008 ranks[which] <- max(ranks[which])
2009 }
2010 ranks
2011 }
2012 data <- sort(data)
2013 n.excess <- unique(floor(length(data) - myrank(data)))
2014 points <- unique(data)
2015 nl <- length(points)
2016 n.excess <- n.excess[-nl]
2017 points <- points[-nl]
2018 excess <- cumsum(rev(data))[n.excess] - n.excess * points
2019 y <- excess/n.excess
2020 xx <- points[1:(nl-omit)] ; yy <- y[1:(nl-omit)]
2021 plot(xx, yy, xlab = "", ylab = "", ...)
2022 if(labels) title(xlab = "Threshold", ylab = "Mean Excess")
2023 invisible(list(x = xx, y = yy))
2024 }
2025
2026 "qplot" <-
2027 function(data, xi = 0, trim = NA, threshold = NA, line = TRUE,
2028 labels = TRUE, ...)
2029 {
2030 data <- as.numeric(data)
2031 if(!is.na(threshold)) data <- data[data >= threshold]
2032 if(!is.na(trim)) data <- data[data < trim]
2033 if(xi == 0) {
2034 add <- "Exponential Quantiles"
2035 y <- qexp(ppoints(data))
2036 }
2037 if(xi != 0) {
2038 add <- paste("GPD Quantiles; xi =", xi)
2039 y <- qgpd(ppoints(data), xi = xi)
2040 }
2041 plot(sort(data), y, xlab = "", ylab = "", ...)
2042 if(labels) title(xlab = "Ordered Data", ylab = add)
2043 if(line) abline(lsfit(sort(data), y))
2044 invisible(list(x = sort(data), y = y))
2045 }
2046
2047 "records" <-
2048 function(data, do.plot = TRUE, conf.level = 0.95, ...)
2049 {
2050 data <- as.numeric(data)
2051 record <- cummax(data)
2052 expected <- cumsum(1/(1:length(data)))
2053 se <- sqrt(expected - cumsum(1/((1:length(data))^2)))
2054 trial <- (1:length(data))[!duplicated(record)]
2055 record <- unique(record)
2056 number <- 1:length(record)
2057 expected <- expected[trial]
2058 se <- se[trial]
2059 if(do.plot) {
2060 ci <- qnorm(0.5 + conf.level/2)
2061 upper <- expected + ci * se
2062 lower <- expected - ci * se
2063 lower[lower < 1] <- 1
2064 yr <- range(upper, lower, number)
2065 plot(trial, number, log = "x", ylim = yr, xlab = "Trial",
2066 ylab = "Records", main = "Plot of Record Development", ...)
2067 lines(trial, expected)
2068 lines(trial, upper, lty = 2)
2069 lines(trial, lower, lty = 2)
2070 }
2071 data.frame(number, record, trial, expected, se)
2072 }
2073
2074 "gpd" <-
2075 function(data, threshold = NA, nextremes = NA, method = c("ml","pwm"),
2076 information = c("observed","expected"), ...)
2077 {
2078 data <- as.numeric(data)
2079 n <- length(data)
2080 if(is.na(nextremes) && is.na(threshold))
2081 stop("Enter either a threshold or the number of upper extremes")
2082 if(!is.na(nextremes) && !is.na(threshold))
2083 stop("Enter EITHER a threshold or the number of upper extremes")
2084 if(!is.na(nextremes))
2085 threshold <- findthresh(data, nextremes)
2086 exceedances <- data[data > threshold]
2087 excess <- exceedances - threshold
2088 Nu <- length(excess)
2089 xbar <- mean(excess)
2090 method <- match.arg(method)
2091 if(method == "ml") {
2092 s2 <- var(excess)
2093 xi0 <- -0.5 * (((xbar * xbar)/s2) - 1)
2094 beta0 <- 0.5 * xbar * (((xbar * xbar)/s2) + 1)
2095 theta <- c(xi0, beta0)
2096 negloglik <- function(theta, tmp)
2097 {
2098 xi <- theta[1]
2099 beta <- theta[2]
2100 cond1 <- beta <= 0
2101 cond2 <- (xi <= 0) && (max(tmp) > ( - beta/xi))
2102 if(cond1 || cond2)
2103 f <- 1e+06
2104 else {
2105 y <- logb(1 + (xi * tmp)/beta)
2106 y <- y/xi
2107 f <- length(tmp) * logb(beta) + (1 + xi) * sum(y)
2108 }
2109 f
2110 }
2111 fit <- optim(theta, negloglik, hessian = TRUE, ..., tmp = excess)
2112 if(fit$convergence)
2113 warning("optimization may not have succeeded")
2114 par.ests <- fit$par
2115 converged <- fit$convergence
2116 nllh.final <- fit$value
2117 information <- match.arg(information)
2118 if(information == "observed") varcov <- solve(fit$hessian)
2119 if(information == "expected") {
2120 one <- (1 + par.ests[1])^2 / Nu
2121 two <- (2 * (1 + par.ests[1]) * par.ests[2]^2) / Nu
2122 cov <- - ((1 + par.ests[1]) * par.ests[2]) / Nu
2123 varcov <- matrix(c(one, cov, cov, two), 2)
2124 }
2125 }
2126 if(method == "pwm") {
2127 a0 <- xbar
2128 gamma <- -0.35
2129 delta <- 0
2130 pvec <- ((1:Nu) + delta)/(Nu + delta)
2131 a1 <- mean(sort(excess) * (1 - pvec))
2132 xi <- 2 - a0/(a0 - 2 * a1)
2133 beta <- (2 * a0 * a1)/(a0 - 2 * a1)
2134 par.ests <- c(xi, beta)
2135 denom <- Nu * (1 - 2 * xi) * (3 - 2 * xi)
2136 if(xi > 0.5) {
2137 denom <- NA
2138 warning("Asymptotic standard errors not available for",
2139 "PWM Method when xi > 0.5")
2140 }
2141 one <- (1 - xi) * (1 - xi + 2 * xi^2) * (2 - xi)^2
2142 two <- (7 - 18 * xi + 11 * xi^2 - 2 * xi^3) * beta^2
2143 cov <- beta * (2 - xi) * (2 - 6 * xi + 7 * xi^2 - 2 * xi^3)
2144 varcov <- matrix(c(one, cov, cov, two), 2) / denom
2145 information <- "expected"
2146 converged <- NA
2147 nllh.final <- NA
2148 }
2149 par.ses <- sqrt(diag(varcov))
2150 p.less.thresh <- 1 - Nu/n
2151 out <- list(n = length(data), data = exceedances, threshold =
2152 threshold, p.less.thresh = p.less.thresh, n.exceed = Nu,
2153 method = method, par.ests = par.ests, par.ses = par.ses,
2154 varcov = varcov, information = information, converged =
2155 converged, nllh.final = nllh.final)
2156 names(out$par.ests) <- c("xi", "beta")
2157 names(out$par.ses) <- c("xi", "beta")
2158 class(out) <- "gpd"
2159 out
2160 }
2161
2162 "gpd.q" <-
2163 function(x, pp, ci.type = c("likelihood","wald"), ci.p = 0.95,
2164 like.num = 50)
2165 {
2166 if(x$dist != "gpd")
2167 stop("This function is used only with GPD curves")
2168 if(length(pp) > 1)
2169 stop("One probability at a time please")
2170 threshold <- x$lastfit$threshold
2171 par.ests <- x$lastfit$par.ests
2172 xihat <- par.ests["xi"]
2173 betahat <- par.ests["beta"]
2174 varcov <- x$lastfit$varcov
2175 p.less.thresh <- x$lastfit$p.less.thresh
2176 lambda <- 1
2177 if(x$type == "tail") lambda <- 1/(1 - p.less.thresh)
2178 a <- lambda * (1 - pp)
2179 gfunc <- function(a, xihat) (a^( - xihat) - 1) / xihat
2180 gfunc.deriv <- function(a, xihat)
2181 ( - (a^( - xihat) - 1)/xihat - a^( - xihat) * logb(a)) / xihat
2182 q <- threshold + betahat * gfunc(a, xihat)
2183 if(q < x$plotmax) abline(v = q, lty = 2)
2184 out <- as.numeric(q)
2185 ci.type <- match.arg(ci.type)
2186 if(ci.type == "wald") {
2187 if(class(x$lastfit) != "gpd")
2188 stop("Wald method requires model be fitted with gpd (not pot)")
2189 scaling <- threshold
2190 betahat <- betahat/scaling
2191 xivar <- varcov[1, 1]
2192 betavar <- varcov[2, 2]/(scaling^2)
2193 covar <- varcov[1, 2]/scaling
2194 term1 <- betavar * (gfunc(a, xihat))^2
2195 term2 <- xivar * (betahat^2) * (gfunc.deriv(a, xihat))^2
2196 term3 <- 2 * covar * betavar * gfunc(a, xihat) * gfunc.deriv(a, xihat)
2197 qvar <- term1 + term2 + term3
2198 if(qvar < 0) stop("Negative estimate of quantile variance")
2199 qse <- scaling * sqrt(qvar)
2200 qq <- qnorm(1 - (1 - ci.p)/2)
2201 upper <- q + qse * qq
2202 lower <- q - qse * qq
2203 if(upper < x$plotmax) abline(v = upper, lty = 2, col = 2)
2204 if(lower < x$plotmax) abline(v = lower, lty = 2, col = 2)
2205 out <- as.numeric(c(lower, q, qse, upper))
2206 names(out) <- c("Lower CI", "Estimate", "Std.Err", "Upper CI")
2207 }
2208 if(ci.type == "likelihood") {
2209 parloglik <- function(theta, tmp, a, threshold, xpi)
2210 {
2211 beta <- (theta * (xpi - threshold))/(a^( - theta) - 1)
2212 if((beta <= 0) || ((theta <= 0) && (max(tmp) > ( - beta/theta))))
2213 f <- 1e+06
2214 else {
2215 y <- logb(1 + (theta * tmp)/beta)
2216 y <- y/theta
2217 f <- length(tmp) * logb(beta) + (1 + theta) * sum(y)
2218 }
2219 f
2220 }
2221 theta <- xihat
2222 parmax <- NULL
2223 xp <- exp(seq(from = logb(threshold), to = logb(x$plotmax),
2224 length = like.num))
2225 excess <- as.numeric(x$lastfit$data - threshold)
2226 for(i in 1:length(xp)) {
2227 fit2 <- optim(theta, parloglik, method = "BFGS", hessian = FALSE,
2228 tmp = excess, a = a, threshold = threshold, xpi = xp[i])
2229 parmax <- rbind(parmax, fit2$value)
2230 }
2231 parmax <- - parmax
2232 overallmax <- - parloglik(xihat, excess, a, threshold, q)
2233 crit <- overallmax - qchisq(0.999, 1)/2
2234 cond <- parmax > crit
2235 xp <- xp[cond]
2236 parmax <- parmax[cond]
2237 par(new = TRUE)
2238 dolog <- ""
2239 if(x$alog == "xy" || x$alog == "x") dolog <- "x"
2240 plot(xp, parmax, type = "n", xlab = "", ylab = "", axes = FALSE,
2241 xlim = range(x$plotmin, x$plotmax),
2242 ylim = range(overallmax, crit), log = dolog)
2243 axis(4, at = overallmax - qchisq(c(0.95, 0.99), 1)/2,
2244 labels = c("95", "99"), tick = TRUE)
2245 aalpha <- qchisq(ci.p, 1)
2246 abline(h = overallmax - aalpha/2, lty = 2, col = 2)
2247 cond <- !is.na(xp) & !is.na(parmax)
2248 smth <- spline(xp[cond], parmax[cond], n = 200)
2249 lines(smth, lty = 2, col = 2)
2250 ci <- smth$x[smth$y > overallmax - aalpha/2]
2251 out <- c(min(ci), q, max(ci))
2252 names(out) <- c("Lower CI", "Estimate", "Upper CI")
2253 }
2254 out
2255 }
2256
2257 "gpd.sfall" <-
2258 function(x, pp, ci.p = 0.95, like.num = 50)
2259 {
2260 if(x$dist != "gpd")
2261 stop("This function is used only with GPD curves")
2262 if(length(pp) > 1)
2263 stop("One probability at a time please")
2264 threshold <- x$lastfit$threshold
2265 par.ests <- x$lastfit$par.ests
2266 xihat <- par.ests["xi"]
2267 betahat <- par.ests["beta"]
2268 varcov <- x$lastfit$varcov
2269 p.less.thresh <- x$lastfit$p.less.thresh
2270 lambda <- 1
2271 if(x$type == "tail") lambda <- 1/(1 - p.less.thresh)
2272 a <- lambda * (1 - pp)
2273 gfunc <- function(a, xihat) (a^( - xihat) - 1) / xihat
2274 q <- threshold + betahat * gfunc(a, xihat)
2275 s <- q + (betahat + xihat * (q - threshold))/(1 - xihat)
2276 if(s < x$plotmax) abline(v = s, lty = 2)
2277 out <- as.numeric(s)
2278 parloglik <- function(theta, tmp, a, threshold, xpi)
2279 {
2280 beta <- ((1 - theta) * (xpi - threshold)) /
2281 (((a^( - theta) - 1)/theta) + 1)
2282 if((beta <= 0) || ((theta <= 0) && (max(tmp) > ( - beta/theta))))
2283 f <- 1e+06
2284 else {
2285 y <- logb(1 + (theta * tmp)/beta)
2286 y <- y/theta
2287 f <- length(tmp) * logb(beta) + (1 + theta) * sum(y)
2288 }
2289 f
2290 }
2291 theta <- xihat
2292 parmax <- NULL
2293 xp <- exp(seq(from = logb(threshold), to = logb(x$plotmax),
2294 length = like.num))
2295 excess <- as.numeric(x$lastfit$data - threshold)
2296 for(i in 1:length(xp)) {
2297 fit2 <- optim(theta, parloglik, method = "BFGS", hessian = FALSE,
2298 tmp = excess, a = a, threshold = threshold, xpi = xp[i])
2299 parmax <- rbind(parmax, fit2$value)
2300 }
2301 parmax <- - parmax
2302 overallmax <- - parloglik(xihat, excess, a, threshold, s)
2303 crit <- overallmax - qchisq(0.999, 1)/2
2304 cond <- parmax > crit
2305 xp <- xp[cond]
2306 parmax <- parmax[cond]
2307 par(new = TRUE)
2308 dolog <- ""
2309 if(x$alog == "xy" || x$alog == "x") dolog <- "x"
2310 plot(xp, parmax, type = "n", xlab = "", ylab = "", axes = FALSE, xlim =
2311 range(x$plotmin, x$plotmax), ylim =
2312 range(overallmax, crit), log = dolog)
2313 axis(4, at = overallmax - qchisq(c(0.95, 0.99), 1)/2,
2314 labels = c("95", "99"), tick = TRUE)
2315 aalpha <- qchisq(ci.p, 1)
2316 abline(h = overallmax - aalpha/2, lty = 2, col = 2)
2317 cond <- !is.na(xp) & !is.na(parmax)
2318 smth <- spline(xp[cond], parmax[cond], n = 200)
2319 lines(smth, lty = 2, col = 2)
2320 ci <- smth$x[smth$y > overallmax - aalpha/2]
2321 out <- c(min(ci), s, max(ci))
2322 names(out) <- c("Lower CI", "Estimate", "Upper CI")
2323 out
2324 }
2325
2326 "plot.gpd" <-
2327 function(x, optlog = NA, extend = 1.5, labels = TRUE, ...)
2328 {
2329 data <- as.numeric(x$data)
2330 threshold <- x$threshold
2331 xi <- x$par.ests["xi"]
2332 beta <- x$par.ests["beta"]
2333 choices <- c("Excess Distribution", "Tail of Underlying Distribution",
2334 "Scatterplot of Residuals", "QQplot of Residuals")
2335 tmenu <- paste("plot:", choices)
2336 pick <- 1
2337 lastcurve <- NULL
2338 while(pick > 0) {
2339 pick <- menu(tmenu, title =
2340 "\nMake a plot selection (or 0 to exit):")
2341 if(pick >= 3) {
2342 excess <- data - threshold
2343 res <- logb(1 + (xi * excess)/beta) / xi
2344 lastcurve <- NULL
2345 }
2346 if(pick == 3) {
2347 plot(res, ylab = "Residuals", xlab = "Ordering", ...)
2348 lines(lowess(1:length(res), res))
2349 }
2350 if(pick == 4) qplot(res, ...)
2351 if(pick == 1 || pick == 2) {
2352 plotmin <- threshold
2353 if(extend <= 1) stop("extend must be > 1")
2354 plotmax <- max(data) * extend
2355 xx <- seq(from = 0, to = 1, length = 1000)
2356 z <- qgpd(xx, xi, threshold, beta)
2357 z <- pmax(pmin(z, plotmax), plotmin)
2358 ypoints <- ppoints(sort(data))
2359 y <- pgpd(z, xi, threshold, beta)
2360 }
2361 if(pick == 1) {
2362 type <- "eplot"
2363 if(!is.na(optlog))
2364 alog <- optlog
2365 else alog <- "x"
2366 if(alog == "xy")
2367 stop("Double log plot of Fu(x-u) does\nnot make much sense")
2368 yylab <- "Fu(x-u)"
2369 shape <- xi
2370 scale <- beta
2371 location <- threshold
2372 }
2373 if(pick == 2) {
2374 type <- "tail"
2375 if(!is.na(optlog))
2376 alog <- optlog
2377 else alog <- "xy"
2378 prob <- x$p.less.thresh
2379 ypoints <- (1 - prob) * (1 - ypoints)
2380 y <- (1 - prob) * (1 - y)
2381 yylab <- "1-F(x)"
2382 shape <- xi
2383 scale <- beta * (1 - prob)^xi
2384 location <- threshold - (scale * ((1 - prob)^( - xi) - 1))/xi
2385 }
2386 if(pick == 1 || pick == 2) {
2387 plot(sort(data), ypoints, xlim = range(plotmin, plotmax),
2388 ylim = range(ypoints, y, na.rm = TRUE), xlab = "",
2389 ylab = "", log = alog, axes = TRUE, ...)
2390 lines(z[y >= 0], y[y >= 0])
2391 if(labels) {
2392 xxlab <- "x"
2393 if(alog == "x" || alog == "xy" || alog == "yx")
2394 xxlab <- paste(xxlab, "(on log scale)")
2395 if(alog == "xy" || alog == "yx" || alog == "y")
2396 yylab <- paste(yylab, "(on log scale)")
2397 title(xlab = xxlab, ylab = yylab)
2398 }
2399 details <- paste("threshold = ", format(signif(threshold, 3)),
2400 " xi = ", format(signif(shape, 3)),
2401 " scale = ", format(signif(scale, 3)),
2402 " location = ", format(signif(location, 3)),
2403 sep = "")
2404 print(details)
2405 lastcurve <- list(lastfit = x, type = type, dist = "gpd",
2406 plotmin = plotmin, plotmax = plotmax, alog = alog,
2407 location = as.numeric(location), shape = as.numeric(shape),
2408 scale = as.numeric(scale))
2409 }
2410 }
2411 invisible(lastcurve)
2412 }
2413
2414 "quant" <-
2415 function(data, p = 0.99, models = 30, start = 15, end = 500,
2416 reverse = TRUE, ci = 0.95, auto.scale = TRUE, labels = TRUE,
2417 ...)
2418 {
2419 data <- as.numeric(data)
2420 n <- length(data)
2421 if(ci) qq <- qnorm(1 - (1 - ci)/2)
2422 exceed <- trunc(seq(from = min(end, n), to = start, length = models))
2423 if(p < 1 - min(exceed)/n) {
2424 cat("Graph may look strange !! \n\n")
2425 cat(paste("Suggestion 1: Increase `p' above",
2426 format(signif(1 - min(exceed)/n, 5)), "\n"))
2427 cat(paste("Suggestion 2: Increase `start' above ",
2428 ceiling(length(data) * (1 - p)), "\n"))
2429 }
2430 gpd.dummy <- function(nex, data)
2431 {
2432 out <- gpd(data = data, nex = nex, information = "expected")
2433 c(out$threshold, out$par.ests[1], out$par.ests[2],
2434 out$varcov[1, 1], out$varcov[2, 2], out$varcov[1, 2])
2435 }
2436 mat <- apply(as.matrix(exceed), 1, gpd.dummy, data = data)
2437 thresh <- mat[1, ]
2438 xihat <- mat[2, ]
2439 betahat <- mat[3, ]
2440 lambda <- length(data)/exceed
2441 a <- lambda * (1 - p)
2442 gfunc <- function(a, xihat) (a^( - xihat) - 1) / xihat
2443 qest <- thresh + betahat * gfunc(a, xihat)
2444 l <- u <- qest
2445 yrange <- range(qest)
2446 if(ci) {
2447 xivar <- mat[4, ]
2448 betavar <- mat[5, ]
2449 covar <- mat[6, ]
2450 scaling <- thresh
2451 betahat <- betahat/scaling
2452 betavar <- betavar/(scaling^2)
2453 covar <- covar/scaling
2454 gfunc.deriv <- function(a, xihat)
2455 ( - (a^( - xihat) - 1)/xihat - a^( - xihat) * logb(a)) / xihat
2456 term1 <- betavar * (gfunc(a, xihat))^2
2457 term2 <- xivar * (betahat^2) * (gfunc.deriv(a, xihat))^2
2458 term3 <- 2 * covar * betavar * gfunc(a, xihat) * gfunc.deriv(a, xihat)
2459 qvar <- term1 + term2 + term3
2460 if(min(qvar) < 0)
2461 stop(paste("Conditioning problems lead to estimated negative",
2462 "quantile variance", sep = "\n"))
2463 qse <- scaling * sqrt(qvar)
2464 u <- qest + qse * qq
2465 l <- qest - qse * qq
2466 yrange <- range(qest, u, l)
2467 }
2468 mat <- rbind(thresh, qest, exceed, l, u)
2469 dimnames(mat) <- list(c("threshold", "qest", "exceedances", "lower",
2470 "upper"), NULL)
2471 index <- exceed
2472 if(reverse) index <- - exceed
2473 if(auto.scale)
2474 plot(index, qest, ylim = yrange, type = "l", xlab = "", ylab = "",
2475 axes = FALSE, ...)
2476 else plot(index, qest, type = "l", xlab = "", ylab = "",
2477 axes = FALSE, ...)
2478 axis(1, at = index, lab = paste(exceed))
2479 axis(2)
2480 axis(3, at = index, lab = paste(format(signif(thresh, 3))))
2481 box()
2482 if(ci) {
2483 lines(index, l, lty = 2, col = 2)
2484 lines(index, u, lty = 2, col = 2)
2485 }
2486 if(labels) {
2487 labely <- paste(p, "Quantile")
2488 if(ci) labely <- paste(labely, " (CI, p = ", ci, ")", sep = "")
2489 title(xlab = "Exceedances", ylab = labely)
2490 mtext("Threshold", side = 3, line = 3)
2491 }
2492 invisible(mat)
2493 }
2494
2495 "riskmeasures" <-
2496 function(x, p)
2497 {
2498 u <- x$threshold
2499 par.ests <- x$par.ests
2500 xihat <- par.ests["xi"]
2501 betahat <- par.ests["beta"]
2502 p.less.thresh <- x$p.less.thresh
2503 lambda <- 1/(1 - p.less.thresh)
2504 quant <- function(pp, xi, beta, u, lambda)
2505 {
2506 a <- lambda * (1 - pp)
2507 u + (beta * (a^( - xi) - 1))/xi
2508 }
2509 short <- function(pp, xi, beta, u, lambda)
2510 {
2511 a <- lambda * (1 - pp)
2512 q <- u + (beta * (a^( - xi) - 1))/xi
2513 (q * (1 + (beta - xi * u)/q)) / (1 - xi)
2514 }
2515 q <- quant(p, xihat, betahat, u, lambda)
2516 es <- short(p, xihat, betahat, u, lambda)
2517 rtn <- cbind(p, quantile = q, sfall = es)
2518 row.names(rtn) <- NULL
2519 rtn
2520 }
2521
2522 "shape" <-
2523 function(data, models = 30, start = 15, end = 500, reverse = TRUE, ci =
2524 0.95, auto.scale = TRUE, labels = TRUE, ...)
2525 {
2526 data <- as.numeric(data)
2527 qq <- 0
2528 if(ci) qq <- qnorm(1 - (1 - ci)/2)
2529 x <- trunc(seq(from = min(end, length(data)), to = start, length = models))
2530 gpd.dummy <- function(nex, data)
2531 {
2532 out <- gpd(data = data, nex = nex, information = "expected")
2533 c(out$threshold, out$par.ests[1], out$par.ses[1])
2534 }
2535 mat <- apply(as.matrix(x), 1, gpd.dummy, data = data)
2536 mat <- rbind(mat, x)
2537 dimnames(mat) <- list(c("threshold", "shape", "se", "exceedances"), NULL)
2538 thresh <- mat[1, ]
2539 y <- mat[2, ]
2540 yrange <- range(y)
2541 if(ci) {
2542 u <- y + mat[3, ] * qq
2543 l <- y - mat[3, ] * qq
2544 yrange <- range(y, u, l)
2545 }
2546 index <- x
2547 if(reverse) index <- - x
2548 if(auto.scale)
2549 plot(index, y, ylim = yrange, type = "l", xlab = "", ylab = "",
2550 axes = FALSE, ...)
2551 else plot(index, y, type = "l", xlab = "", ylab = "", axes = FALSE, ...)
2552 axis(1, at = index, lab = paste(x), tick = FALSE)
2553 axis(2)
2554 axis(3, at = index, lab = paste(format(signif(thresh, 3))), tick = FALSE)
2555 box()
2556 if(ci) {
2557 lines(index, u, lty = 2, col = 2)
2558 lines(index, l, lty = 2, col = 2)
2559 }
2560 if(labels) {
2561 labely <- "Shape (xi)"
2562 if(ci) labely <- paste(labely, " (CI, p = ", ci, ")", sep = "")
2563 title(xlab = "Exceedances", ylab = labely)
2564 mtext("Threshold", side = 3, line = 3)
2565 }
2566 invisible(mat)
2567 }
2568
2569 "tailplot" <-
2570 function(x, optlog = NA, extend = 1.5, labels = TRUE, ...)
2571 {
2572 data <- as.numeric(x$data)
2573 threshold <- x$threshold
2574 xi <- x$par.ests["xi"]
2575 beta <- x$par.ests["beta"]
2576 plotmin <- threshold
2577 if(extend <= 1) stop("extend must be > 1")
2578 plotmax <- max(data) * extend
2579 xx <- seq(from = 0, to = 1, length = 1000)
2580 z <- qgpd(xx, xi, threshold, beta)
2581 z <- pmax(pmin(z, plotmax), plotmin)
2582 ypoints <- ppoints(sort(data))
2583 y <- pgpd(z, xi, threshold, beta)
2584 type <- "tail"
2585 if(!is.na(optlog))
2586 alog <- optlog
2587 else alog <- "xy"
2588 prob <- x$p.less.thresh
2589 ypoints <- (1 - prob) * (1 - ypoints)
2590 y <- (1 - prob) * (1 - y)
2591 yylab <- "1-F(x)"
2592 shape <- xi
2593 scale <- beta * (1 - prob)^xi
2594 location <- threshold - (scale * ((1 - prob)^( - xi) - 1))/xi
2595 plot(sort(data), ypoints, xlim = range(plotmin, plotmax), ylim =
2596 range(ypoints, y, na.rm = TRUE), xlab = "", ylab = "", log = alog,
2597 axes = TRUE, ...)
2598 lines(z[y >= 0], y[y >= 0])
2599 if(labels) {
2600 xxlab <- "x"
2601 if(alog == "x" || alog == "xy" || alog == "yx")
2602 xxlab <- paste(xxlab, "(on log scale)")
2603 if(alog == "xy" || alog == "yx" || alog == "y")
2604 yylab <- paste(yylab, "(on log scale)")
2605 title(xlab = xxlab, ylab = yylab)
2606 }
2607 lastcurve <- list(lastfit = x, type = type, dist = "gpd",
2608 plotmin = plotmin, plotmax = plotmax, alog = alog, location =
2609 as.numeric(location), shape = as.numeric(shape), scale =
2610 as.numeric(scale))
2611 invisible(lastcurve)
2612 }
2613 "plot.pot" <-
2614 function(x, ...)
2615 {
2616 rawdata <- x$data
2617 n <- length(as.numeric(rawdata))
2618 times <- attributes(rawdata)$times
2619 if(is.character(times) || inherits(times, "POSIXt") ||
2620 inherits(x, "date") || inherits(x, "dates")) {
2621 times <- as.POSIXlt(times)
2622 gaps <- as.numeric(difftime(times[2:n], times[1:(n-1)],
2623 units = "days")) * x$intensity
2624 }
2625 else gaps <- as.numeric(diff(times)) * x$intensity
2626 data <- as.numeric(rawdata)
2627 threshold <- x$threshold
2628 par.ests <- x$par.ests
2629 xi <- par.ests[1]
2630 beta <- par.ests[4]
2631 residuals <- logb(1 + (xi * (data - threshold))/beta)/xi
2632 choices <- c("Point Process of Exceedances", "Scatterplot of Gaps",
2633 "Qplot of Gaps", "ACF of Gaps", "Scatterplot of Residuals",
2634 "Qplot of Residuals", "ACF of Residuals", "Go to GPD Plots")
2635 tmenu <- paste("plot:", choices)
2636 pick <- 1
2637 lastcurve <- NULL
2638 while(pick > 0) {
2639 pick <- menu(tmenu, title =
2640 "\nMake a plot selection (or 0 to exit):")
2641 if(pick %in% c(4,7)) require("ts", quietly = TRUE)
2642 if(pick %in% 1:7) lastcurve <- NULL
2643 switch(pick,
2644 {
2645 plot(times, rawdata, type = "h", sub = paste("Point process of",
2646 length(as.numeric(rawdata)), "exceedances of threshold",
2647 format(signif(threshold, 3))), ...)
2648 },
2649 {
2650 plot(gaps, ylab = "Gaps", xlab = "Ordering", ...)
2651 lines(lowess(1:length(gaps), gaps))
2652 },
2653 qplot(gaps, ...),
2654 acf(gaps, lag.max = 20, ...),
2655 {
2656 plot(residuals, ylab = "Residuals", xlab = "Ordering", ...)
2657 lines(lowess(1:length(residuals), residuals))
2658 },
2659 qplot(residuals, ...),
2660 acf(residuals, lag.max = 20, ...),
2661 lastcurve <- plot.gpd(x, ...))
2662 }
2663 invisible(lastcurve)
2664 }
2665
2666 "pot" <-
2667 function(data, threshold = NA, nextremes = NA, run = NA,
2668 picture = TRUE, ...)
2669 {
2670 n <- length(as.numeric(data))
2671 times <- attributes(data)$times
2672 if(is.null(times)) {
2673 times <- 1:n
2674 attributes(data)$times <- times
2675 start <- 1
2676 end <- n
2677 span <- end - start
2678 }
2679 else {
2680 start <- times[1]
2681 end <- times[n]
2682 span <- as.numeric(difftime(as.POSIXlt(times)[n],
2683 as.POSIXlt(times)[1], units = "days"))
2684 }
2685
2686 if(is.na(nextremes) && is.na(threshold))
2687 stop("Enter either a threshold or the number of upper extremes")
2688 if(!is.na(nextremes) && !is.na(threshold))
2689 stop("Enter EITHER a threshold or the number of upper extremes")
2690 if(!is.na(nextremes))
2691 threshold <- findthresh(as.numeric(data), nextremes)
2692 if(threshold > 10) {
2693 factor <- 10^(floor(log10(threshold)))
2694 cat(paste("If singularity problems occur divide data",
2695 "by a factor, perhaps", factor, "\n"))
2696 }
2697 exceedances.its <- structure(data[data > threshold], times =
2698 times[data > threshold])
2699 n.exceed <- length(as.numeric(exceedances.its))
2700 p.less.thresh <- 1 - n.exceed/n
2701 if(!is.na(run)) {
2702 exceedances.its <- decluster(exceedances.its, run, picture)
2703 n.exceed <- length(exceedances.its)
2704 }
2705 intensity <- n.exceed/span
2706 exceedances <- as.numeric(exceedances.its)
2707 xbar <- mean(exceedances) - threshold
2708 s2 <- var(exceedances)
2709 shape0 <- -0.5 * (((xbar * xbar)/s2) - 1)
2710 extra <- ((length(exceedances)/span)^( - shape0) - 1)/shape0
2711 betahat <- 0.5 * xbar * (((xbar * xbar)/s2) + 1)
2712 scale0 <- betahat/(1 + shape0 * extra)
2713 loc0 <- 0
2714 theta <- c(shape0, scale0, loc0)
2715 negloglik <- function(theta, exceedances, threshold, span)
2716 {
2717 if((theta[2] <= 0) || (min(1 + (theta[1] * (exceedances -
2718 theta[3])) / theta[2]) <= 0))
2719 f <- 1e+06
2720 else {
2721 y <- logb(1 + (theta[1] * (exceedances - theta[3])) / theta[2])
2722 term3 <- (1/theta[1] + 1) * sum(y)
2723 term1 <- span * (1 + (theta[1] * (threshold - theta[3])) /
2724 theta[2])^(-1/theta[1])
2725 term2 <- length(y) * logb(theta[2])
2726 f <- term1 + term2 + term3
2727 }
2728 f
2729 }
2730 fit <- optim(theta, negloglik, hessian = TRUE, ..., exceedances =
2731 exceedances, threshold = threshold, span = span)
2732 if(fit$convergence)
2733 warning("optimization may not have succeeded")
2734 par.ests <- fit$par
2735 varcov <- solve(fit$hessian)
2736 par.ses <- sqrt(diag(varcov))
2737 beta <- par.ests[2] + par.ests[1] * (threshold - par.ests[3])
2738 par.ests <- c(par.ests, beta)
2739 out <- list(n = length(data), period = c(start, end), data =
2740 exceedances.its, span = span, threshold = threshold,
2741 p.less.thresh = p.less.thresh, n.exceed = n.exceed, run = run,
2742 par.ests = par.ests, par.ses = par.ses, varcov = varcov,
2743 intensity = intensity, nllh.final = fit$value, converged
2744 = fit$convergence)
2745 names(out$par.ests) <- c("xi", "sigma", "mu", "beta")
2746 names(out$par.ses) <- c("xi", "sigma", "mu")
2747 class(out) <- "pot"
2748 out
2749 }
2750
2751 "decluster" <-
2752 function(series, run = NA, picture = TRUE)
2753 {
2754 n <- length(as.numeric(series))
2755 times <- attributes(series)$times
2756 if(is.null(times)) stop("`series' must have a `times' attribute")
2757 as.posix <- is.character(times) || inherits(times, "POSIXt") ||
2758 inherits(times, "date") || inherits(times, "dates")
2759 if(as.posix)
2760 gaps <- as.numeric(difftime(as.POSIXlt(times)[2:n],
2761 as.POSIXlt(times)[1:(n-1)], units = "days"))
2762 else gaps <- as.numeric(diff(times))
2763 longgaps <- gaps > run
2764 if(sum(longgaps) <= 1)
2765 stop("Decluster parameter too large")
2766 cluster <- c(0, cumsum(longgaps))
2767 cmax <- tapply(as.numeric(series), cluster, max)
2768 newtimes <- times[match(cmax, series)]
2769 newseries <- structure(series[match(cmax, series)], times = newtimes)
2770 n <- length(as.numeric(newseries))
2771
2772 if(as.posix) {
2773 newgaps <- as.numeric(difftime(as.POSIXlt(newtimes)[2:n],
2774 as.POSIXlt(newtimes)[1:(n-1)], units = "days"))
2775 times <- as.POSIXlt(times)
2776 newtimes <- as.POSIXlt(newtimes)
2777 }
2778 else newgaps <- as.numeric(diff(newtimes))
2779
2780 if(picture) {
2781 cat("Declustering picture...\n")
2782 cat(paste("Data reduced from", length(as.numeric(series)),
2783 "to", length(as.numeric(newseries)), "\n"))
2784 par(mfrow = c(2, 2))
2785 plot(times, series, type = "h")
2786 qplot(gaps)
2787 plot(newtimes, newseries, type = "h")
2788 qplot(newgaps)
2789 par(mfrow = c(1, 1))
2790 }
2791 newseries
2792 }
2793
2794 "findthresh" <-
2795 function(data, ne)
2796 {
2797 data <- rev(sort(as.numeric(data)))
2798 thresholds <- unique(data)
2799 indices <- match(data[ne], thresholds)
2800 indices <- pmin(indices + 1, length(thresholds))
2801 thresholds[indices]
2802 }
2803
2804
2805 # ******************************************************************************
2806
+0
-128
R/xmpTools.R less more
0
1 # This library is free software; you can redistribute it and/or
2 # modify it under the terms of the GNU Library General Public
3 # License as published by the Free Software Foundation; either
4 # version 2 of the License, or (at your option) any later version.
5 #
6 # This library is distributed in the hope that it will be useful,
7 # but WITHOUT ANY WARRANTY; without even the implied warranty of
8 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
9 # GNU Library General Public License for more details.
10 #
11 # You should have received a copy of the GNU Library General
12 # Public License along with this library; if not, write to the
13 # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
14 # MA 02111-1307 USA
15
16 # Copyrights (C)
17 # for this R-port:
18 # 1999 - 2004, Diethelm Wuertz, GPL
19 # Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
20 # info@rmetrics.org
21 # www.rmetrics.org
22 # for the code accessed (or partly included) from other R-ports:
23 # see R's copyright and license files
24 # for the code accessed (or partly included) from contributed R-ports
25 # and other sources
26 # see Rmetrics's copyright file
27
28
29 ################################################################################
30 # FUNCTION: DESCRIPTION:
31 # xmpExtremes Sets Prompt
32 # xmpfExtremes Popups the example menu
33 ################################################################################
34
35
36 xmpExtremes =
37 function(prompt = "")
38 { # A function implemented by Diethelm WUertz
39
40 # Description:
41 # Sets prompt
42
43 # FUNCTION:
44
45 # Return Value:
46 invisible(prompt)
47 }
48
49
50 # ------------------------------------------------------------------------------
51
52
53 xmpfExtremes =
54 function()
55 { # A function implemented by Diethelm WUertz
56
57 # Description:
58 # Popups the example menu
59
60 # FUNCTION:
61
62 # Popup:
63 path = paste(.Library,"/fExtremes", sep = "")
64 entries = .read.fExtremes.00Index (file.path(path, "demoIndex"))
65 example = select.list(entries[,1])
66 selected = 0
67 for (i in 1:length(entries[,1])) {
68 if (example == entries[i,1]) selected = i
69 }
70 if (example == "") {
71 cat("\nNo demo selected\n")
72 } else {
73 cat("\nLibrary: ", "fExtremes", "\nExample: ",
74 entries[selected, 1], "\nTitle: ", entries[selected, 2], "\n")
75 source(paste(path, "/demo/", example, ".R", sep = ""))
76 }
77 if(TRUE) {
78 cat("\n")
79 }
80
81 # Return Value:
82 invisible()
83 }
84
85
86 # ------------------------------------------------------------------------------
87
88
89 .read.fExtremes.00Index =
90 function (file)
91 {
92 if (is.character(file)) {
93 if (file == "") {
94 file <- stdin()
95 } else {
96 file <- file(file, "r")
97 on.exit(close(file))
98 }
99 }
100 if (!inherits(file, "connection"))
101 stop(paste("argument",
102 sQuote("file"), "must be a character string or connection"))
103 y <- matrix("", nr = 0, nc = 2)
104 x <- paste(readLines(file), collapse = "\n")
105 for (chunk in unlist(strsplit(x, "\n[ \n]*\n"))) {
106 entries <- try({
107 if (regexpr("( | )", chunk) == -1)
108 NULL
109 else {
110 chunk <- gsub("\n[ ]+", " ", chunk)
111 x <- strsplit(unlist(strsplit(chunk, "\n")), "[ ]")
112 cbind(unlist(lapply(x, "[[", 1)), unlist(lapply(x,
113 function(t) {
114 paste(t[-c(1, which(nchar(t) == 0))], collapse = " ")
115 })))
116 }
117 })
118 if (!inherits(entries, "try-error") && NCOL(entries) == 2)
119 y <- rbind(y, entries)
120 }
121 colnames(y) <- c("Item", "Description")
122 y
123 }
124
125
126 ################################################################################
127
+9
-9
R/zzz.R less more
00
11 #*******************************************************************************
22 # fExtremes - A SOFTWARE COLLECTION FOR FINANCIAL ENGINEERS
3 # PART III: Beyond the Sample: Dealing with Extreme Values
3 # Beyond the Sample: Dealing with Extreme Values
44 #
55 # collected by Diethelm Wuertz
66 # Version 0.9
4040
4141 .First.lib =
4242 function(lib, pkg)
43 { # A function implemted by D. Wuertz
43 { # A function implemted by D. Wuertz
4444
45 # Package:
46 cat("\nRmetrics, (C) 1999-2004, Diethelm Wuertz, GPL")
47 cat("\nfExtremes: Beyond the Sample: Dealing with Extreme Values\n")
48
49 # Load dll:
50 # library.dynam("fExtremes", pkg, lib)
51
45 # Package:
46 cat("\nRmetrics, (C) 1999-2004, Diethelm Wuertz, GPL")
47 cat("\nfExtremes: Beyond the Sample: Dealing with Extreme Values\n")
48
49 # Load dll:
50 # library.dynam("fExtremes", pkg, lib)
51
5252 }
5353
5454
+0
-0
data/bmw.R less more
(No changes)
+0
-0
data/bmw.ret.csv less more
(No changes)
+0
-0
data/danish.R less more
(No changes)
+0
-0
data/dax.ret.csv less more
(No changes)
+0
-0
data/dowjones.R less more
(No changes)
+0
-0
data/engine.R less more
(No changes)
+0
-0
data/euroex.R less more
(No changes)
+0
-0
data/exchange.R less more
(No changes)
+0
-0
data/fremantle.R less more
(No changes)
+0
-0
data/glass.R less more
(No changes)
+0
-0
data/nidd.annual.R less more
(No changes)
+0
-0
data/nidd.thresh.R less more
(No changes)
+0
-0
data/portpirie.R less more
(No changes)
+0
-0
data/rain.R less more
(No changes)
+0
-0
data/siemens.R less more
(No changes)
+0
-0
data/sp.raw.R less more
(No changes)
+0
-0
data/spto87.R less more
(No changes)
+0
-0
data/venice.R less more
(No changes)
+0
-0
data/wavesurge.R less more
(No changes)
+0
-0
data/wind.R less more
(No changes)
+0
-0
data/wooster.R less more
(No changes)
+8
-0
debian/changelog less more
0 fextremes (221.10065-1) unstable; urgency=low
1
2 * New upstream release
3
4 * debian/watch: One more fix for regular expression
5
6 -- Dirk Eddelbuettel <edd@debian.org> Mon, 20 Feb 2006 11:13:02 -0600
7
08 fextremes (220.10063-1) unstable; urgency=low
19
210 * New upstream release
+4
-4
debian/postinst less more
00 #!/bin/sh
11 # -*- makefile -*-
22 # debian/postinst file for the Debian/GNU Linux r-cran-fextremes package
3 # Copyright 2004 by Dirk Eddelbuettel <edd@debian.org>
3 # Copyright 2004-2006 by Dirk Eddelbuettel <edd@debian.org>
44
55 set -e
66
88
99 case "$1" in
1010 configure)
11 if test -x /usr/bin/R; then
12 R CMD perl /usr/lib/R/share/perl/build-help.pl --htmllists
13 fi
11 # if test -x /usr/bin/R; then
12 # R CMD perl /usr/lib/R/share/perl/build-help.pl --htmllists
13 # fi
1414 ;;
1515 abort-upgrade|abort-remove|abort-deconfigure)
1616 ;;
+4
-4
debian/postrm less more
00 #!/bin/sh
11 # -*- makefile -*-
22 # debian/postrm file for the Debian/GNU Linux r-cran-fextremes package
3 # Copyright 2004 by Dirk Eddelbuettel <edd@debian.org>
3 # Copyright 2004-2006 by Dirk Eddelbuettel <edd@debian.org>
44
55 set -e
66
88
99 case "$1" in
1010 upgrade|remove|purge)
11 if test -x /usr/bin/R; then
12 R CMD perl /usr/lib/R/share/perl/build-help.pl --htmllists
13 fi
11 # if test -x /usr/bin/R; then
12 # R CMD perl /usr/lib/R/share/perl/build-help.pl --htmllists
13 # fi
1414 ;;
1515 failed-upgrade|abort-install|abort-upgrade|disappear)
1616 ;;
+1
-1
debian/rules less more
00 #!/usr/bin/make -f
11 # -*- makefile -*-
22 # debian/rules file for the Debian/GNU Linux r-cran-fextremes package
3 # Copyright 2003-2004 by Dirk Eddelbuettel <edd@debian.org>
3 # Copyright 2003-2006 by Dirk Eddelbuettel <edd@debian.org>
44
55 include /usr/share/cdbs/1/rules/debhelper.mk
66 include /usr/share/cdbs/1/class/langcore.mk
+1
-4
debian/watch less more
0 # format version number, currently 2; this line is compulsory!
1 version=2
2
3 # This is one format for an HTTP site, which is the same as the FTP format
0 version=3
41 http://cran.r-project.org/src/contrib/fExtremes_([-0-9\.]*).tar.gz
+6
-6
demo/00Index less more
0 funExtremes fExtremes Function Addon
1
2 xmpDWChapter51 Extreme Value Plots
3 xmpDWChapter52 Fluctuations of Maxima and GEV Distribution
4 xmpDWChapter53 Extremes via Point Processes
5 xmpDWChapter54 The Extremal Index
0 funLmomco L Moments Function Addon
1 xmpDWChapter051 Extreme Value Plots
2 xmpDWChapter052 Fluctuations of Maxima and GEV Distribution
3 xmpDWChapter053 Extremes via Point Processes
4 xmpDWChapter054 The Extremal Index
5 xmpZWChapter05 Modelling Extreme Values
+0
-173
demo/funExtremes.R less more
0
1 #
2 # fExtremes Functions Addon:
3 #
4 # 1 Moments for the GEV and GPD distributions
5 # 2 Law of Large Numbers and Law of the iterated logarithm
6 #
7 # Author:
8 # Diethelm Wuertz, GPL
9 #
10
11
12 ################################################################################
13 # 1 Moments for the GEV and GPD distributions
14
15
16 ################################################################################
17 # FUNCTION DESCRIPTION:
18 # gevMoments Computes true statistics for GEV distribution
19 # gpdMoments Computes true statistics for GPD distribution
20 ################################################################################
21
22
23 gevMoments =
24 function(xi, mu = 0, beta = 1)
25 { # A function implemented by Diethelm Wuertz
26
27 # Description:
28 # Compute true statistics for Generalized Extreme Value distribution
29
30 # Value:
31 # Returns true mean for xi < 1 and variance for xi < 1/2
32 # of GEV distribution, otherwise NaN is returned
33
34 # FUNCTION:
35
36 # MEAN: Returns for x >= 1 NaN:
37 g = c(1, 0, NaN)
38 xinv = 1/ ( xi + sign(abs(xi)) - 1 )
39 # For xi = the result is eulers constant
40 euler = 0.57721566490153286060651209008240243104
41 xi0 = c(0, mu+beta*euler, 0)
42
43 # Supress warning for NaN's from Gamma Function:
44 options(warn = -1)
45 gevMean = mu + beta * xinv * (gamma(1-xi)-1) * g[sign(xi-1)+2] +
46 xi0[(sign(xi)+2)]
47 options(warn = 0)
48
49 # VAR: Returns for x >= 1 NaN:
50 g = c(1, 0, NaN)
51 xinv = 1/ ( xi + sign(abs(xi)) - 1 )
52 xi0 = c(0, (beta*pi)^2 / 6, 0)
53
54 # Supress warning for NaN's from Gamma Function:
55 options(warn=-1)
56 gevVar = (beta*xinv)^2 * (gamma(1-2*xi) - gamma(1-xi)^2 ) *
57 g[sign(2*xi-1)+2] + xi0[(sign(xi)+2)]
58 options(warn = 0)
59
60 # Return Value:
61 list(mean = gevMean, var = gevVar)
62 }
63
64
65 # ------------------------------------------------------------------------------
66
67
68 gpdMoments =
69 function(xi, mu = 0, beta = 1)
70 { # A function implemented by Diethelm Wuertz
71
72 # Description:
73 # Compute true statistics for Generalized Pareto distribution
74
75 # Value:
76 # Returns true mean of Generalized Pareto distribution
77 # for xi < 1 else NaN
78 # Returns true variance of Generalized Pareto distribution
79 # for xi < 1 else NaN
80
81 # FUNCTION:
82
83 # MEAN: Rreturns 1 for x <= 0 and -Inf's's else
84 a = c(1, NaN, NaN)
85 gpdMean = beta/(1-xi)*a[sign(xi-1)+2]
86
87 # VAR: Rreturns 1 for x <= 0 and -Inf's's else
88 a = c(1, NaN, NaN)
89 gpdVar = beta*beta/(1-xi)^2/(1-2*xi) * a[sign(2*xi-1)+2]
90
91 # Return Value:
92 list(mean = gevMean, var = gevVar)
93 }
94
95
96 ################################################################################
97 # 2 Law of Large Numbers and Law of the iterated logarithm
98
99
100 ################################################################################
101 # FUNCTION: DESCRIPTION:
102 # sllnPlot Verify Kolmogorov's Strong Law of large Numbers
103 # lilPlot Verify Hartman-Wintner's Law of the iterated logarithm
104 ################################################################################
105
106
107 sllnPlot =
108 function (x, mean = NULL, main = "SLLN", ...)
109 { # A function written by Diethelm Wuertz
110
111 # Description:
112 # Verify Kolmogorov's Strong Law of large Numbers
113
114 # Arguments:
115 # x - sequence of iid non-degenerate rvs.
116
117 # References:
118 # Embrechts et al. p. 61, Theorem 2.1.3
119
120 # FUNCTION:
121
122 # Verify SLLN:
123 if (is.null(mean)) mean=mean(cumsum(x)/(1:length(x)))
124 nx = length(x)
125 plot(cumsum(x)/(1:nx), xlab = "n", ylab = "x", type = "l", main = main, ...)
126 lines(c(0, nx), c(mu, mu), col = 2)
127 y = cumsum(x)/(1:nx)
128
129 # Return Value:
130 invisible(y)
131 }
132
133
134 # ------------------------------------------------------------------------------
135
136
137 lilPlot =
138 function (x, mean = NULL, sd = NULL, main = "LIL", ...)
139 { # A function written by Diethelm Wuertz
140
141 # Description:
142 # Verify Hartman-Wintner's Law of the iterated logarithm
143
144 # Arguments:
145 # x - sequence of iid non-degenerate rvs.
146
147 # References:
148 # Embrechts et al. p. 67. Theorem 2.1.13
149
150 # FUNCTION:
151
152 # Verify LIL:
153 lx = length(x)
154 nx = 1:lx
155 fact = sqrt(2*nx*log(log(nx)))
156 if (is.null(mean)) mean = mean(cumsum(x))
157 if (is.null(sd)) sd = sqrt(var(x))
158 y = (cumsum(x)-mean*nx)/fact/sd
159 plot(x = nx, y = y, xlab = "n", ylab = "x",
160 ylim = range(y[!is.na(y)], -1, 1), type = "l", main = main, ...)
161 lines(c(0,lx), c(1,1), col=2)
162 lines(c(0,lx), c(-1,-1), col=2)
163
164 # Return Value:
165 y
166 }
167
168
169 # ------------------------------------------------------------------------------
170
171
172
+3536
-0
demo/funLmomco.R less more
0
1
2 # Package: lmomco
3 # Title: L-moments, L-comoments, and Distributions
4 # Version: 0.3
5 # Date: 2006-01-31
6 # Author: William H. Asquith
7 # Description: The package implements the statistical theory of L-moments including
8 # L-moment estimation, probability-weighted moment estimation, parameter estimation
9 # for numerous familiar and not-so-familiar distributions, and L-moment estimation
10 # for the same distributions from the parameters. L-moments are derived from the
11 # expectations of order statistics and are linear with respect to the probability-
12 # weighted moments. L-moments are directly analogous to the well-known product
13 # moments; however, L-moments have many advantages including unbiasedness,
14 # robustness, and consistency with respect to the product moments. This package
15 # is oriented around the FORTRAN algorithms of J.R.M. Hosking, and the
16 # nomenclature for many of the functions parallels that of the Hosking library.
17 # Further features are added to aid in extension of the breadth of L-moment
18 # application. Additionally, recent developments by Robert Serfling and Peng Xiao
19 # have extended L-moments into multivariate space; the so-called sample L-comoments
20 # are implemented here.
21 # Maintainer: William H. Asquith <wasquith@austin.rr.com>
22 # License: GPL
23 # Packaged: Tue Jan 31 14:18:07 2006; wasquith
24
25
26 ################################################################################
27
28
29 "INT.check.fs" <-
30 function(fs) {
31 if(any(fs < 0) | any(fs > 1)) {
32 print("invalid nonexceedance probability")
33 return(FALSE)
34 }
35 return(TRUE)
36 }
37
38 "INT.kapicase1" <-
39 function(U,A,G,H) {
40 BETA <- matrix(nrow = 5, ncol = 1)
41 # OFL SHOULD BE CHOSEN SO THAT EXP(OFL) JUST DOES NOT CAUSE OVERFLOW
42 # Hosking's code based used 170
43 OFL <- log(.Machine$double.xmax)
44 DLGAM <- lgamma(1+G)
45 #
46 # - CASE H<0, G NONZERO
47 for(R in seq(1,5)) {
48 ARG <- DLGAM+lgamma(-R/H-G)-lgamma(-R/H)-G*log(-H)
49 if(abs(ARG) > OFL) {
50 warning("Calculations of L-moments have broken down")
51 return()
52 }
53 BETA[R] <- exp(ARG)
54 }
55 return(BETA)
56 }
57
58 "INT.kapicase2" <-
59 function(U,A,G,H) {
60 BETA <- matrix(nrow = 5, ncol = 1)
61 DLGAM <- lgamma(1+G)
62 #
63 # - CASE H SMALL, G NONZERO
64 #
65 for(R in seq(1,5)) {
66 BETA[R] <- exp(DLGAM-G*log(R))*(1-0.5*H*G*(1+G)/R)
67 }
68 return(BETA)
69 }
70
71 "INT.kapicase3" <-
72 function(U,A,G,H) {
73 BETA <- matrix(nrow = 5, ncol = 1)
74 # OFL SHOULD BE CHOSEN SO THAT EXP(OFL) JUST DOES NOT CAUSE OVERFLOW
75 OFL <- log(.Machine$double.xmax)
76 DLGAM <- lgamma(1+G)
77 #
78 # - CASE H>0, G NONZERO
79 #
80 for(R in seq(1,5)) {
81 ARG <- DLGAM+lgamma(1+R/H)-lgamma(1+G+R/H)-G*log(H)
82 if(abs(ARG) > OFL) {
83 warning("Calculations of L-moments have broken down")
84 return()
85 }
86 BETA[R] <- exp(ARG)
87 }
88 return(BETA)
89 }
90
91 "INT.kapicase4" <-
92 function(U,A,G,H) {
93 BETA <- matrix(nrow = 5, ncol = 1)
94 #
95 # - CASE H<0, G <- 0
96 #
97 # EU IS EULER'S CONSTANT
98 EU <- 0.577215664901532861
99 for(R in seq(1,5)) {
100 BETA[R] <- EU + log(-H)+digamma(-R/H)
101 }
102 return(BETA)
103 }
104
105 "INT.kapicase5" <-
106 function(U,A,G,H) {
107 BETA <- matrix(nrow = 5, ncol = 1)
108 #
109 # - CASE H SMALL, G <- 0
110 #
111 # EU IS EULER'S CONSTANT
112 EU <- 0.577215664901532861
113 for(R in seq(1,5)) {
114 BETA[R] <- EU+log(R)
115 }
116 return(BETA)
117 }
118
119 "INT.kapicase6" <-
120 function(U,A,G,H) {
121 BETA <- matrix(nrow = 5, ncol = 1)
122 #
123 # - CASE H>0, G <- 0
124 #
125 # EU IS EULER'S CONSTANT
126 EU <- 0.577215664901532861
127 for(R in seq(1,5)) {
128 BETA[R] <- EU+log(H)+digamma(1+R/H)
129 }
130 return(BETA)
131 }
132
133 "Lcomoment.Lk12" <-
134 function(X1, X2, k=1) {
135 # Following notation of Serfling and Xiao (2006)
136 # compute the unbiased L-statistic estimator
137
138 # Compute the concomitant of X2
139 # First sort X2 in ascending order, but need the indices
140 # Second rearrange X1 in the order of X2
141 I <- sort(X2, decreasing=FALSE, index.return=TRUE)
142 X12 <- X1[I$ix]
143
144 sum <- 0 # a summation
145 n <- length(X1) # sample size
146 for(r in seq(1,n)) { # for each value in the sample
147 Wk <- Lcomoment.Wk(k,r,n) # compute the weight factor
148 sum <- sum + Wk*X12[r] # sum them up
149 } # end of loop
150 Lk12 <- sum/n # compute the expected value
151 return(Lk12) # return the L-comoment
152 }
153 "Lcomoment.Wk" <-
154 function(k, r, n) {
155 # Following notation of Serfling and Xiao (2006)
156 # compute the Wk weight factor for kth L-moment
157 Wk <- 0
158 jn <- min(c(r-1,k-1)) # find the minimum for the loop end
159 for(j in seq(0,jn)) {
160 t1 <- (-1)**(k-1-j)
161 t2 <- choose(k-1,j)
162 t3 <- choose(k-1+j,j)
163 t4 <- choose(n-1,j)
164 t5 <- choose(r-1,j)
165 Wk <- Wk + t1*t2*t3*t5/t4
166 }
167 return(Wk)
168 }
169 "Lcomoment.coefficients" <-
170 function(Lk,L2) {
171 # Following notation of Serfling and Xiao (2006)
172 # compute the L-comoment coefficients
173 # The univariate L-moment ratios are on the diagonal of Lk
174 if(is.null(Lk$type) || Lk$type != "Lcomoment.matrix") {
175 warning("First argument does not appear to be an L-comoment matrix")
176 return()
177 }
178 if(is.null(L2$type) || L2$type != "Lcomoment.matrix") {
179 warning("Second argument does not appear to be an L-comoment matrix")
180 return()
181 }
182 if(Lk$order >= 2 && L2$order != 2) {
183 warning("Frist L-comoment matrix is order 2 or greater, but second matrix is not of order 2")
184 return()
185 }
186 if(Lk$order == 1 && L2Rorder != 1) { # In L-CV calculations L2/L1, but in others Lk/L2
187 warning("First L-comoment matrix is order 1, but second matrix is not 2nd order.")
188 return()
189 }
190 LC <- Lk$matrix # to get the structure of Lk
191 Lscales <- diag(L2$matrix) # get univariate L-scale values
192 n <- length(Lscales) # how many are there (how many columns)
193 for(i in seq(1,n)) { # loop through each column
194 Lscale <- Lscales[i] # extract single L-scale value
195 LC[i,] <- Lk$matrix[i,]/Lscale # divide the column by L-scale
196 # to form coefficients
197 } # end of loop
198 z <- list(type="Lcomoment.coefficients", order = Lk$order, matrix = LC)
199 return(z) # return the matrix
200 }
201
202 "Lcomoment.correlation" <-
203 function(L2) {
204 if(L2$order != 2) {
205 warning("L-comoment matrix argument is not of order 2")
206 return()
207 }
208
209 # Following Serfling and Xiao (2006)
210 # L-correlations are the L-comoment coefficents of L-scale
211 # The diagonal of LC are the coefficients of L-variation
212 LC <- Lcomoment.coefficients(L2,L2)
213 return(LC)
214 }
215 "Lcomoment.matrix" <-
216 function(DATAFRAME, k=1) {
217 # DATAFRAME is data.frame of rectangular dimension
218 # k is the kth order of L-comoments
219
220 f <- length(DATAFRAME) # how many fields or "random variables"
221 M <- matrix(nrow=f, ncol=f) # generate square matrix
222 n <- length(DATAFRAME[,1]) # sample size
223
224 for(x1 in seq(1,f)) { # BEGIN LOOP 1
225 X1 <- DATAFRAME[,x1] # extract array "1"
226 for(x2 in seq(1,f)) { # BEGIN LOOP 2
227 X2 <- DATAFRAME[,x2] # extract array "2"
228 M[x1,x2] <- Lcomoment.Lk12(X1,X2,k) # compute the L-comoments
229 # for 1 and 2 and order k
230 } # END LOOP 2
231 } # END LOOP 1
232 z <- list(type="Lcomoment.matrix", order=k, matrix=M)
233 return(z) # return the matrix
234 }
235
236 "are.lmom.valid" <-
237 function(lmom) {
238 # The early return trues are for situations in which the higher moments
239 # are simply not available--say from computing the l-moments of a distribution
240 if(is.null(lmom$L2)) return(TRUE)
241 if(lmom$L2 <= 0) return(FALSE)
242 if(is.null(lmom$TAU3)) return(TRUE)
243 if(abs(lmom$TAU3) > 1) return(FALSE)
244 if(is.null(lmom$TAU4)) return(TRUE)
245 if(lmom$TAU4 < (0.25*(5*lmom$TAU3^2 - 1)) | lmom$TAU4 > 1) return(FALSE)
246 if(is.null(lmom$TAU5)) return(TRUE)
247 if(lmom$TAU5 > 1) return(FALSE)
248 return(TRUE)
249 }
250
251 "are.par.valid" <-
252 function(para) {
253 if(is.null(para$para)) {
254 warning("The parameter object is missing a para attribute.")
255 return()
256 }
257 if(is.null(para$type)) {
258 warning("The parameter object is missing a type attribute.")
259 return()
260 }
261 type <- para$type
262 if(type == 'cau') {
263 return(are.parcau.valid(para))
264 }
265 else if(type == 'exp') {
266 return(are.parexp.valid(para))
267 }
268 else if(type == 'gam') {
269 return(are.pargam.valid(para))
270 }
271 else if(type == 'gev') {
272 return(are.pargev.valid(para))
273 }
274 else if(type == 'gld') {
275 return(are.pargld.valid(para))
276 }
277 else if(type == 'glo') {
278 return(are.parglo.valid(para))
279 }
280 else if(type == 'gno') {
281 return(are.pargno.valid(para))
282 }
283 else if(type == 'gpa') {
284 return(are.pargpa.valid(para))
285 }
286 else if(type == 'gum') {
287 return(are.pargum.valid(para))
288 }
289 else if(type == 'kap') {
290 return(are.parkap.valid(para))
291 }
292 else if(type == 'nor') {
293 return(are.parnor.valid(para))
294 }
295 else if(type == 'pe3') {
296 return(are.parpe3.valid(para))
297 }
298 else if(type == 'wak') {
299 return(are.pareak.valid(para))
300 }
301 else {
302 stop("Did not find a valid distribution type.")
303 }
304 }
305 "are.parcau.valid" <-
306 function(para) {
307 if(! is.cau(para)) return(FALSE)
308 U <- para$para[1]
309 A <- para$para[2]
310 #if() {
311 # warning("Parameters are invalid.")
312 # return(FALSE)
313 #}
314 return(TRUE)
315 }
316
317 "are.parexp.valid" <-
318 function(para) {
319 if(! is.exp(para)) return(FALSE)
320 A <- para$para[2]
321 if(A <= 0) {
322 warning("Parameters are invalid.")
323 return(FALSE)
324 }
325 return(TRUE)
326 }
327
328 "are.pargam.valid" <-
329 function(para) {
330 if(! is.gam(para)) return(FALSE)
331 ALPHA <- para$para[1]
332 BETA <- para$para[2]
333 if(ALPHA <= 0 | BETA <= 1) {
334 warning("Parameters are invalid.")
335 return(FALSE)
336 }
337 return(TRUE)
338 }
339
340 "are.pargev.valid" <-
341 function(para) {
342 if(! is.gev(para)) return(FALSE)
343 A <- para$para[2]
344 G <- para$para[3]
345 if(A <= 0 | G <= -1) {
346 warning("Parameters are invalid.")
347 return(FALSE)
348 }
349 return(TRUE)
350 }
351
352 "are.pargld.valid" <-
353 function(para) {
354 if(! is.gld(para)) return(FALSE)
355
356 La2 <- para$para[2]
357 La3 <- para$para[3]
358 La4 <- para$para[4]
359
360 if(La3 <= -1 && La4 >= 1) { # REGION 1
361 return(TRUE)
362 }
363 if(La3 >= 1 && La4 <= -1) { # REGION 2
364 return(TRUE)
365 }
366 if(La3 < 0 && La4 > 0 && La4 < 1) { # REGION V1
367 warning("Parameters are invalid (region V1).")
368 return(FALSE)
369 }
370 if(La3 > 0 && La3 < 1 && La4 < 0) { # REGION V2
371 warning("Parameters are invalid (region V2).")
372 return(FALSE)
373 }
374 if(La3 > -1 && La3 < 0 && La4 > 1) { # REGION V3
375 tmp1 <- (1-La3)**(1-La3)
376 tmp2 <- (La4-La3)**(La4-La3)
377 tmp3 <- (La4-1)**(La4-1)
378 rhs <- -La3/La4
379 if(tmp3*(tmp1/tmp2) < rhs) {
380 return(TRUE)
381 }
382 else {
383 warning("Parameters are invalid (region V3).")
384 return(FALSE)
385 }
386 }
387 if(La3 > 1 && La4 > -1 && La4 < 0) { # REGION V4
388 # Unclear in Karian and Dudewicz (2000) that
389 # the following same condition on V3 applies
390 # in V4. See top of page 16. However, this basic
391 # test is also stated on page 17 to be an if and only if
392 tmp1 <- (1-La3)**(1-La3)
393 tmp2 <- (La4-La3)**(La4-La3)
394 tmp3 <- (La4-1)**(La4-1)
395 rhs <- -La3/La4
396 if(tmp3*(tmp1/tmp2) < rhs) {
397 return(TRUE)
398 }
399 else {
400 warning("Parameters are invalid (region V4).")
401 return(FALSE)
402 }
403 }
404 return(TRUE)
405 }
406
407 "are.parglo.valid" <-
408 function(para) {
409 if(! is.glo(para)) return(FALSE)
410 A <- para$para[2]
411 K <- para$para[3]
412 if(A <= 0 | abs(K) >= 1) {
413 warning("Parameters are invalid.")
414 return(FALSE)
415 }
416 return(TRUE)
417 }
418
419 "are.pargno.valid" <-
420 function(para) {
421 if(! is.gno(para)) return(FALSE)
422 A <- para$para[2]
423 if(A <= 0) {
424 warning("Parameters are invalid.")
425 return(FALSE)
426 }
427 return(TRUE)
428 }
429
430 "are.pargpa.valid" <-
431 function(para) {
432 if(! is.gpa(para)) return(FALSE)
433 A <- para$para[2]
434 K <- para$para[3]
435 if(A <= 0 | K < -1) {
436 warning("Parameters are invalid.")
437 return(FALSE)
438 }
439 return(TRUE)
440 }
441
442 "are.pargum.valid" <-
443 function(para) {
444 if(! is.gum(para)) return(FALSE)
445 A <- para$para[2]
446 if(A <= 0) {
447 warning("Parameters are invalid.")
448 return(FALSE)
449 }
450 return(TRUE)
451 }
452
453 "are.parkap.valid" <-
454 function(para) {
455 if(! is.kap(para)) return(FALSE)
456 if(para$ifail == 2) return(FALSE)
457 U <- para$para[1]
458 A <- para$para[2]
459 G <- para$para[3]
460 H <- para$para[4]
461 if(A <= 0) {
462 warning("Parameters are invalid.")
463 return(FALSE)
464 }
465 if(G <= -1) {
466 warning("Parameters are invalid.")
467 return(FALSE)
468 }
469 if(H < 0 & G*H <= -1) {
470 warning("Parameters are invalid.")
471 return(FALSE)
472 }
473 return(TRUE)
474 }
475
476 "are.parnor.valid" <-
477 function(para) {
478 if(! is.nor(para)) return(FALSE)
479 sd <- para$para[2]
480 if(sd <= 0) {
481 warning("Parameters are invalid.")
482 return(FALSE)
483 }
484 return(TRUE)
485 }
486
487 "are.parpe3.valid" <-
488 function(para) {
489 if(! is.pe3(para)) return(FALSE)
490 A <- para$para[2]
491 if(A <= 0) {
492 warning("Parameters are invalid.")
493 return(FALSE)
494 }
495 return(TRUE)
496 }
497
498 "are.parwak.valid" <-
499 function(para) {
500 if(! is.wak(para)) return(FALSE)
501
502 A <- para$para[2]
503 B <- para$para[3]
504 C <- para$para[4]
505 D <- para$para[5]
506 if(B+D <= 0 & (B != 0 | C != 0 | D != 0)) {
507 warning("Parameters are invalid.")
508 return(FALSE)
509 }
510 if(A == 0 & B != 0) {
511 warning("Parameters are invalid.")
512 return(FALSE)
513 }
514 if(C == 0 & D != 0) {
515 warning("Parameters are invalid.")
516 return(FALSE)
517 }
518 if(C < 0 | A+C < 0) {
519 warning("Parameters are invalid.")
520 return(FALSE)
521 }
522 if(A == 0 & C == 0) {
523 warning("Parameters are invalid.")
524 return(FALSE)
525 }
526 if(D >= 1) {
527 warning("Parameters are invalid.")
528 return(FALSE)
529 }
530 return(TRUE)
531 }
532
533 "cdfcau" <-
534 function(x,para) {
535 if(! are.parcau.valid(para)) return()
536 U <- para$para[1]
537 A <- para$para[2]
538 tmp <- (x - U)/A
539 tmp <- (atan(tmp)/pi)+0.5
540 return(tmp)
541 }
542
543 "cdfexp" <-
544 function(x,para) {
545 if(! are.parexp.valid(para)) return()
546 U <- para$para[1]
547 A <- para$para[2]
548 Y <- (x-U)/A
549 if(Y <= 0) return(0)
550 return(1-exp(-Y))
551 }
552
553 "cdfgam" <-
554 function(x,para) {
555 if(! are.pargam.valid(para)) return()
556 if(x <= 0) return(0)
557 ALPHA <- para$para[1]
558 BETA <- para$para[2]
559 return(pgamma(x,ALPHA,scale=BETA))
560 }
561
562 "cdfgev" <-
563 function(x,para) {
564 if(! are.pargev.valid(para)) return()
565 # SMALL IS USED TO TEST WHETHER X IS EFFECTIVELY AT
566 # THE ENDPOINT OF THE DISTRIBUTION
567 SMALL <- 1e-15
568
569 XI <- para$para[1]
570 A <- para$para[2]
571 K <- para$para[3]
572 Y <- (x - XI)/A
573 if(K == 0) return(exp(-exp(-Y)))
574 ARG <- 1-K*Y
575 if(ARG > SMALL) {
576 Y <- -log(ARG)/K
577 return(exp(-exp(-Y)))
578 }
579 if(K < 0) return(0)
580 # K must be greater than zero to return other end
581 return(1)
582 }
583
584 "cdfglo" <-
585 function(x,para) {
586 if(! are.parglo.valid(para)) return()
587 SMALL <- 1e-15
588 XI <- para$para[1]
589 A <- para$para[2]
590 K <- para$para[3]
591 Y <- (x-XI)/A
592 if(K == 0) {
593 return(1/(1+exp(-Y)))
594 }
595 ARG <- 1-K*Y
596 if(ARG > SMALL) {
597 Y <- -log(ARG)/K
598 return(1/(1+exp(-Y)))
599 }
600 if(K < 0) return(0)
601 if(K > 0) return(1)
602 }
603
604 "cdfgno" <-
605 function(x,para) {
606 # Error function from R documentation
607 erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
608 RTHALF <- 0.707106781186547524
609 # SMALL IS USED TO TEST WHETHER X IS EFFECTIVELY AT
610 # THE ENDPOINT OF THE DISTRIBUTION
611 SMALL <- 1e-15
612
613 if(! are.pargno.valid(para)) return()
614
615 XI <- para$para[1]
616 A <- para$para[2]
617 K <- para$para[3]
618 Y <- (x-XI)/A
619 if(K != 0) {
620 ARG <- 1-K*Y
621 if(ARG > SMALL) {
622 Y <- -log(ARG)/K
623 }
624 else {
625 if(K < 0) return(0)
626 # K must be greater than zero--other end of distribution
627 return(1)
628 }
629 }
630 return(0.5+0.5*erf(Y*RTHALF))
631 }
632
633 "cdfgpa" <-
634 function(x,para) {
635 if(! are.pargpa.valid(para)) return()
636 # SMALL IS USED TO TEST WHETHER X IS EFFECTIVELY AT
637 # THE ENDPOINT OF THE DISTRIBUTION
638 SMALL <- 1e-15
639 XI <- para$para[1]
640 A <- para$para[2]
641 K <- para$para[3]
642 Y <- (x-XI)/A
643 if(Y <= 0) return(0)
644 if(K == 0) {
645 return(1-exp(-Y))
646 }
647 else {
648 ARG <- 1-K*Y
649 if(ARG > SMALL) {
650 Y <- -log(ARG)/K
651 return(1-exp(-Y))
652 }
653 return(1)
654 }
655 }
656
657 "cdfgum" <-
658 function(x,para) {
659 if(! are.pargum.valid(para)) return()
660 U <- para$para[1]
661 A <- para$para[2]
662 Y <- (x-U)/A
663 return(exp(-exp(-Y)))
664 }
665
666 "cdfkap" <-
667 function(x,para) {
668 if(! are.parkap.valid(para)) return()
669
670 # SMALL IS A SMALL NUMBER, USED TO TEST WHETHER X IS
671 # EFFECTIVELY AT AN ENDPOINT OF THE DISTRIBUTION
672 SMALL <- 1e-15
673
674 U <- para$para[1]
675 A <- para$para[2]
676 G <- para$para[3]
677 H <- para$para[4]
678 Y <- (x-U)/A
679 if(G == 0) {
680 Y <- exp(-Y)
681 }
682 else {
683 ARG <- 1-G*Y
684 if(ARG > SMALL) {
685 Y <- -log(ARG)/G
686 Y <- exp(-Y)
687 }
688 else {
689 if(G < 0) return(0)
690 if(G > 0) return(1)
691 stop("should not be here in execution")
692 }
693 }
694 if(H == 0) {
695 return(exp(-Y))
696 }
697 else {
698 ARG <- 1-H*Y
699 if(ARG > SMALL) {
700 Y <- -log(ARG)/H
701 return(exp(-Y))
702 }
703 else {
704 return(0)
705 }
706 }
707 }
708
709 "cdfnor" <-
710 function(x,para) {
711 if(! are.parnor.valid(para)) return()
712 return(pnorm(x,mean = para$para[1], sd = para$para[2]))
713 }
714
715 "cdfpe3" <-
716 function(x,para) {
717 if(! are.parpe3.valid(para)) return()
718
719 ROOT0p5 <- sqrt(1/2)
720
721 # Error function as defined by R documentation
722 # and is used for zero skew condition
723 erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
724
725 # SMALL IS USED TO TEST WHETHER SKEWNESS IS EFFECTIVELY ZERO
726 SMALL <- 1e-6
727
728 U <- para$para[1]
729 A <- para$para[2]
730 GAMMA <- para$para[3]
731
732 if(abs(GAMMA) <= SMALL) {
733 # ZERO SKEWNESS
734 Z <- (x-U)/A
735 return(0.5+0.5*erf(Z*ROOT0p5))
736 }
737 ALPHA <- 4/GAMMA^2
738 Z <- 2*(x-U)/(A*GAMMA)+ALPHA
739 CDFPE3 <- 0
740 if(Z > 0) CDFPE3 <- pgamma(Z,ALPHA)
741 if(GAMMA < 0 ) CDFPE3 <- 1-CDFPE3
742 return(CDFPE3)
743 }
744
745 "cdfwak" <-
746 function(x,wakpara) {
747
748 # CONVERT Z TO PROBABILITY
749 z2f <- function(Z,UFL) {
750 if(-Z < UFL) return(1)
751 return(1-exp(-Z))
752 }
753
754
755 # METHOD: THE EQUATION X=G(Z), WHERE G(Z) IS THE WAKEBY QUANTILE
756 # EXPRESSED AS A FUNCTION OF Z=-LOG(1-F), IS SOLVED USING HALLEY'S
757 # METHOD (THE 2ND-ORDER ANALOGUE OF NEWTON-RAPHSON ITERATION).
758 #
759
760 #
761 # EPS,MAXIT CONTROL THE TEST FOR CONVERGENCE OF THE ITERATION
762 # ZINCMX IS THE LARGEST PERMITTED ITERATIVE STEP
763 # ZMULT CONTROLS WHAT HAPPENS WHEN THE ITERATION STEPS BELOW ZERO
764 # UFL SHOULD BE CHOSEN SO THAT DEXP(UFL) JUST DOES NOT CAUSE
765 # UNDERFLOW
766
767 EPS <- 1e-8;
768 MAXIT <- 20;
769 ZINCMX <- 3;
770 ZMULT <- 0.2;
771 UFL <- log(.Machine$double.xmin);
772
773 if(! are.parwak.valid(wakpara)) return()
774
775 XI <- wakpara$para[1]
776 A <- wakpara$para[2]
777 B <- wakpara$para[3]
778 C <- wakpara$para[4]
779 D <- wakpara$para[5]
780
781 if(x <= XI) return(0)
782
783 #
784 # TEST FOR SPECIAL CASES
785 #
786 if(B == 0 & C == 0 & D == 0) {
787 # SPECIAL CASE B=C=D=0: WAKEBY IS EXPONENTIAL
788 Z <- (x-XI)/A
789 return(z2f(Z,UFL))
790 }
791 if(C == 0) {
792 # SPECIAL CASE C=0: WAKEBY IS GENERALIZED PARETO, BOUNDED ABOVE
793 CDFWAK <- 1
794 if(x >= XI+A/B) return(1)
795 Z <- -log(1-(x-XI)*B/A)/B
796 return(z2f(Z,UFL))
797 }
798 if(A == 0) {
799 # SPECIAL CASE A=0: WAKEBY IS GENERALIZED PARETO, NO UPPER BOUND
800 Z <- log(1+(x-XI)*D/C)/D
801 return(z2f(Z,UFL))
802 }
803
804
805 # GENERAL CASE
806 #
807 if(D < 0 & x >= XI+A/B-C/D) return(1)
808
809 # INITIAL VALUES FOR ITERATION:
810 # IF X IS IN THE LOWEST DECILE OF THE DISTRIBUTION,
811 # START AT Z = 0 (F = 0);
812 # IF X IS IN THE HIGHEST PERCENTILE OF THE DISTRIBUTION,
813 # STARTING VALUE IS OBTAINED FROM ASYMPTOTIC FORM OF THE
814 # DISTRIBUTION FOR LARGE Z (F NEAR 1);
815 # OTHERWISE START AT Z <- 0.7 (CLOSE TO F <- 0.5).
816 #
817 Z <- 0.7
818 if(x < quawak(0.1,wakpara)) Z <- 0
819 if(x >= quawak(0.99,wakpara)) {
820 if(D < 0) Z <- log((x-XI-A/B)*D/C+1)/D
821 if(D == 0) Z <- (x-XI-A/B)/C
822 if(D > 0) Z <- log((x-XI)*D/C+1)/D
823 }
824 #
825 # HALLEY'S METHOD, WITH MODIFICATIONS:
826 # IF HALLEY ITERATION WOULD MOVE IN WRONG DIRECTION
827 # (TEMP <= ZERO), USE ORDINARY NEWTON-RAPHSON INSTEAD;
828 # IF STEP GOES TOO FAR (ZINC > ZINCMX | ZNEW <= 0),
829 # LIMIT ITS LENGTH.
830 #
831
832 LOOPEND <- FALSE
833
834 for(IT in seq(1,MAXIT)) {
835 EB <- 0
836 BZ <- -B*Z
837 if(BZ >= UFL) EB <- exp(BZ)
838 GB <- Z
839 if(abs(B) > EPS) GB <- (1-EB)/B
840 ED <- exp(D*Z)
841 GD <- -Z
842 if(abs(D) > EPS) GD <- (1-ED)/D
843 XEST <- XI+A*GB-C*GD
844 FUNC <- x-XEST
845 DERIV1 <- A*EB+C*ED
846 DERIV2 <- -A*B*EB+C*D*ED
847 TEMP <- DERIV1+0.5*FUNC*DERIV2/DERIV1
848 if(TEMP <= 0) TEMP <- DERIV1
849 ZINC <- FUNC/TEMP
850 if(ZINC > ZINCMX) ZINC <- ZINCMX
851 ZNEW <- Z+ZINC
852 if(ZNEW <= 0) {
853 Z <- Z*ZMULT
854 next
855 }
856 Z <- ZNEW
857 if(abs(ZINC) <= EPS) break
858 if(IT == MAXIT) LOOPEND <- TRUE
859 }
860 if(LOOPEND == TRUE) {
861 warning("Iteration has not converged. Result might be unreliable.")
862 }
863
864 # CONVERT Z VALUE TO PROBABILITY
865 return(z2f(Z,UFL))
866 }
867
868 "freq.curve.all" <-
869 function(lmom) {
870 F <- nonexceeds()
871 print("Exponential distribution")
872 EXP <- freq.curve.exp(F,parexp(lmom))
873 print("Gamma distribution")
874 GAM <- freq.curve.gam(F,pargam(lmom))
875 print("Generalized Extreme Value distribution")
876 GEV <- freq.curve.gev(F,pargev(lmom))
877 print("Generalized Logistic distribution")
878 GLO <- freq.curve.glo(F,parglo(lmom))
879 print("Generalized Normal distribution")
880 GNO <- freq.curve.gno(F,pargno(lmom))
881 print("Generalized Pareto distribution")
882 GPA <- freq.curve.gpa(F,pargpa(lmom))
883 print("Generalized Gumbel distribution")
884 GUM <- freq.curve.gum(F,pargum(lmom))
885 print("Kappa distribution")
886 KAP <- freq.curve.kap(F,parkap(lmom))
887 print("Normal distribution")
888 NOR <- freq.curve.nor(F,parnor(lmom))
889 print("Pearson Type III distribution")
890 PE3 <- freq.curve.pe3(F,parpe3(lmom))
891 print("Wakeby distribution")
892 WAK <- freq.curve.wak(F,parwak(lmom))
893 return(list(exp = EXP, gam = GAM, gev = GEV, glo = GLO,
894 gno = GNO, gpa = GPA, gum = GUM, kap = KAP,
895 nor = NOR, pe3 = PE3, wak = WAK))
896 }
897
898 "freq.curve.cau" <-
899 function(fs,para) {
900 if(! INT.check.fs(fs)) return()
901 if(! is.cau(para)) return()
902 Q <- matrix(nrow = length(fs), ncol = 1)
903 for(i in seq(1,length(fs))) {
904 Q[i] <- quacau(fs[i],para)
905 }
906 return(Q)
907 }
908
909 "freq.curve.exp" <-
910 function(fs,para) {
911 if(! INT.check.fs(fs)) return()
912 if(! is.exp(para)) return()
913 Q <- matrix(nrow = length(fs), ncol = 1)
914 for(i in seq(1,length(fs))) {
915 Q[i] <- quaexp(fs[i],para)
916 }
917 return(Q)
918 }
919
920 "freq.curve.gam" <-
921 function(fs,para) {
922 if(! INT.check.fs(fs)) return()
923 if(! is.gam(para)) return()
924 Q <- matrix(nrow = length(fs), ncol = 1)
925 for(i in seq(1,length(fs))) {
926 Q[i] <- quagam(fs[i],para)
927 }
928 return(Q)
929 }
930
931 "freq.curve.gev" <-
932 function(fs,para) {
933 if(! INT.check.fs(fs)) return()
934 if(! is.gev(para)) return()
935 Q <- matrix(nrow = length(fs), ncol = 1)
936 for(i in seq(1,length(fs))) {
937 Q[i] <- quagev(fs[i],para)
938 }
939 return(Q)
940 }
941
942 "freq.curve.gld" <-
943 function(fs,para) {
944 if(! INT.check.fs(fs)) return()
945 if(! is.gld(para)) return()
946 Q <- matrix(nrow = length(fs), ncol = 1)
947 for(i in seq(1,length(fs))) {
948 Q[i] <- quagld(fs[i],para)
949 }
950 return(Q)
951 }
952
953 "freq.curve.glo" <-
954 function(fs,para) {
955 if(! INT.check.fs(fs)) return()
956 if(! is.glo(para)) return()
957 Q <- matrix(nrow = length(fs), ncol = 1)
958 for(i in seq(1,length(fs))) {
959 Q[i] <- quaglo(fs[i],para)
960 }
961 return(Q)
962 }
963
964 "freq.curve.gno" <-
965 function(fs,para) {
966 if(! INT.check.fs(fs)) return()
967 if(! is.gno(para)) return()
968 Q <- matrix(nrow = length(fs), ncol = 1)
969 for(i in seq(1,length(fs))) {
970 Q[i] <- quagno(fs[i],para)
971 }
972 return(Q)
973 }
974
975 "freq.curve.gpa" <-
976 function(fs,para) {
977 if(! INT.check.fs(fs)) return()
978 if(! is.gpa(para)) return()
979 Q <- matrix(nrow = length(fs), ncol = 1)
980 for(i in seq(1,length(fs))) {
981 Q[i] <- quagpa(fs[i],para)
982 }
983 return(Q)
984 }
985
986 "freq.curve.gum" <-
987 function(fs,para) {
988 if(! INT.check.fs(fs)) return()
989 if(! is.gum(para)) return()
990 Q <- matrix(nrow = length(fs), ncol = 1)
991 for(i in seq(1,length(fs))) {
992 Q[i] <- quagum(fs[i],para)
993 }
994 return(Q)
995 }
996
997 "freq.curve.kap" <-
998 function(fs,para) {
999 if(! INT.check.fs(fs)) return()
1000 if(! is.kap(para)) return()
1001 Q <- matrix(nrow = length(fs), ncol = 1)
1002 for(i in seq(1,length(fs))) {
1003 Q[i] <- quakap(fs[i],para)
1004 }
1005 return(Q)
1006 }
1007
1008 "freq.curve.nor" <-
1009 function(fs,para) {
1010 if(! INT.check.fs(fs)) return()
1011 if(! is.nor(para)) return()
1012 Q <- matrix(nrow = length(fs), ncol = 1)
1013 for(i in seq(1,length(fs))) {
1014 Q[i] <- quanor(fs[i],para)
1015 }
1016 return(Q)
1017 }
1018
1019 "freq.curve.pe3" <-
1020 function(fs,para) {
1021 if(! INT.check.fs(fs)) return()
1022 if(! is.pe3(para)) return()
1023 Q <- matrix(nrow = length(fs), ncol = 1)
1024 for(i in seq(1,length(fs))) {
1025 Q[i] <- quape3(fs[i],para)
1026 }
1027 return(Q)
1028 }
1029
1030 "freq.curve.wak" <-
1031 function(fs,para) {
1032 if(! INT.check.fs(fs)) return()
1033 if(! is.wak(para)) return()
1034 Q <- matrix(nrow = length(fs), ncol = 1)
1035 for(i in seq(1,length(fs))) {
1036 Q[i] <- quawak(fs[i],para)
1037 }
1038 return(Q)
1039 }
1040
1041 "is.cau" <-
1042 function(para) {
1043 if(para$type != "cau") {
1044 warning("Parameters are not Cauchy parameters")
1045 return(FALSE)
1046 }
1047 return(TRUE)
1048 }
1049
1050 "is.exp" <-
1051 function(para) {
1052 if(para$type != "exp") {
1053 warning("Parameters are not exponential parameters")
1054 return(FALSE)
1055 }
1056 return(TRUE)
1057 }
1058
1059 "is.gam" <-
1060 function(para) {
1061 if(para$type != "gam") {
1062 warning("Parameters are not gamma parameters")
1063 return(FALSE)
1064 }
1065 return(TRUE)
1066 }
1067
1068 "is.gev" <-
1069 function(para) {
1070 if(para$type != "gev") {
1071 warning("Parameters are not Generalized Extreme Value parameters")
1072 return(FALSE)
1073 }
1074 return(TRUE)
1075 }
1076
1077 "is.gld" <-
1078 function(para) {
1079 if(para$type != "gld") {
1080 warning("Parameters are not Generalized Lambda parameters")
1081 return(FALSE)
1082 }
1083 return(TRUE)
1084 }
1085
1086 "is.glo" <-
1087 function(para) {
1088 if(para$type != "glo") {
1089 warning("Parameters are not Generalized Logistic parameters")
1090 return(FALSE)
1091 }
1092 return(TRUE)
1093 }
1094
1095 "is.gno" <-
1096 function(para) {
1097 if(para$type != "gno") {
1098 warning("Parameters are not Generalized Normal parameters")
1099 return(FALSE)
1100 }
1101 return(TRUE)
1102 }
1103
1104 "is.gpa" <-
1105 function(para) {
1106 if(para$type != "gpa") {
1107 warning("Parameters are not Generalized Pareto parameters")
1108 return(FALSE)
1109 }
1110 return(TRUE)
1111 }
1112
1113 "is.gum" <-
1114 function(para) {
1115 if(para$type != "gum") {
1116 warning("Parameters are not Gumbel parameters")
1117 return(FALSE)
1118 }
1119 return(TRUE)
1120 }
1121
1122 "is.kap" <-
1123 function(para) {
1124 if(para$type != "kap") {
1125 warning("Parameters are not Kappa parameters.")
1126 return(FALSE)
1127 }
1128 return(TRUE)
1129 }
1130
1131 "is.nor" <-
1132 function(para) {
1133 if(para$type != "nor") {
1134 warning("Parameters are not Normal parameters")
1135 return(FALSE)
1136 }
1137 return(TRUE)
1138 }
1139
1140 "is.pe3" <-
1141 function(para) {
1142 if(para$type != "pe3") {
1143 warning("Parameters are not Pearson Type III parameters")
1144 return(FALSE)
1145 }
1146 return(TRUE)
1147 }
1148
1149 "is.wak" <-
1150 function(para) {
1151 if(para$type != "wak") {
1152 warning("Parameters are not Wakeby parameters")
1153 return(FALSE)
1154 }
1155 return(TRUE)
1156 }
1157
1158 "lmom.diff" <-
1159 function(lmomparm, lmomdata) {
1160 print("THE FIVE DIFFERENCES BETWEEN L-MOMENTS OF DISTRIBUTION AND DATA")
1161 print("Mean L2 TAU3 TAU4 TAU5")
1162 L1diff <- lmomparm$L1 - lmomdata$L1
1163 L2diff <- lmomparm$L2 - lmomdata$L2
1164 T3diff <- lmomparm$TAU3 - lmomdata$TAU3
1165 T4diff <- lmomparm$TAU4 - lmomdata$TAU4
1166 T5diff <- lmomparm$TAU5 - lmomdata$TAU5
1167 print(c(L1diff,L2diff,T3diff,T4diff,T5diff))
1168 return(list(L1diff = L1diff, L2diff = L2diff, T3diff = T3diff,
1169 T4diff = T4diff, T5diff = T5diff))
1170 }
1171
1172 "lmom.test.all" <-
1173 function(data) {
1174 lmom.test.exp(data)
1175 lmom.test.gam(data)
1176 lmom.test.gev(data)
1177 lmom.test.glo(data)
1178 lmom.test.gno(data)
1179 lmom.test.gpa(data)
1180 lmom.test.gum(data)
1181 lmom.test.kap(data)
1182 lmom.test.nor(data)
1183 lmom.test.pe3(data)
1184 lmom.test.wak(data)
1185 }
1186
1187 "lmom.test.exp" <-
1188 function(data) {
1189 lmom <- lmom.ub(data)
1190 para <- parexp(lmom)
1191 print("EXPONENTIAL DISTRIBUTION PARAMETERS")
1192 print(para)
1193 lmompara <- lmomexp(para)
1194 Q50 <- quaexp(0.5,para)
1195 print(c('MEDIAN ',Q50))
1196 P50 <- cdfexp(Q50,para)
1197 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1198 lmom.diff(lmompara,lmom)
1199 }
1200
1201 "lmom.test.gam" <-
1202 function(data) {
1203 lmom <- lmom.ub(data)
1204 para <- pargam(lmom)
1205 print("GAMMA DISTRIBUTION PARAMETERS")
1206 print(para)
1207 lmompara <- lmomgam(para)
1208 Q50 <- quagam(0.5,para)
1209 print(c('MEDIAN ',Q50))
1210 P50 <- cdfgam(Q50,para)
1211 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1212 lmom.diff(lmompara,lmom)
1213 }
1214
1215 "lmom.test.gev" <-
1216 function(data) {
1217 lmom <- lmom.ub(data)
1218 para <- pargev(lmom)
1219 print("GENERALIZED EXTREME VALUE DISTRIBUTION PARAMETERS")
1220 print(para)
1221 lmompara <- lmomgev(para)
1222 Q50 <- quagev(0.5,para)
1223 print(c('MEDIAN ',Q50))
1224 P50 <- cdfgev(Q50,para)
1225 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1226 lmom.diff(lmompara,lmom)
1227 }
1228
1229 "lmom.test.glo" <-
1230 function(data) {
1231 lmom <- lmom.ub(data)
1232 para <- parglo(lmom)
1233 print("GENERALIZED LOGISTIC DISTRIBUTION PARAMETERS")
1234 print(para)
1235 lmompara <- lmomglo(para)
1236 Q50 <- quaglo(0.5,para)
1237 print(c('MEDIAN ',Q50))
1238 P50 <- cdfglo(Q50,para)
1239 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1240 lmom.diff(lmompara,lmom)
1241 }
1242
1243 "lmom.test.gno" <-
1244 function(data) {
1245 lmom <- lmom.ub(data)
1246 para <- pargno(lmom)
1247 print("GENERALIZED NORMAL DISTRIBUTION PARAMETERS")
1248 print(para)
1249 lmompara <- lmomgno(para)
1250 Q50 <- quagno(0.5,para)
1251 print(c('MEDIAN ',Q50))
1252 P50 <- cdfgno(Q50,para)
1253 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1254 lmom.diff(lmompara,lmom)
1255 }
1256
1257 "lmom.test.gpa" <-
1258 function(data) {
1259 lmom <- lmom.ub(data)
1260 para <- pargpa(lmom)
1261 print("GENERALIZED PARETO DISTRIBUTION PARAMETERS")
1262 print(para)
1263 lmompara <- lmomgpa(para)
1264 Q50 <- quagpa(0.5,para)
1265 print(c('MEDIAN ',Q50))
1266 P50 <- cdfgpa(Q50,para)
1267 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1268 lmom.diff(lmompara,lmom)
1269 }
1270
1271 "lmom.test.gum" <-
1272 function(data) {
1273 lmom <- lmom.ub(data)
1274 para <- pargum(lmom)
1275 print("GUMBEL DISTRIBUTION PARAMETERS")
1276 print(para)
1277 lmompara <- lmomgum(para)
1278 Q50 <- quagum(0.5,para)
1279 print(c('MEDIAN ',Q50))
1280 P50 <- cdfgum(Q50,para)
1281 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1282 lmom.diff(lmompara,lmom)
1283 }
1284
1285 "lmom.test.kap" <-
1286 function(data) {
1287 lmom <- lmom.ub(data)
1288 para <- parkap(lmom)
1289 print("GENERALIZED KAPPA DISTRIBUTION PARAMETERS")
1290 print(para)
1291 lmompara <- lmomkap(para)
1292 Q50 <- quakap(0.5,para)
1293 print(c('MEDIAN ',Q50))
1294 P50 <- cdfkap(Q50,para)
1295 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1296 lmom.diff(lmompara,lmom)
1297 }
1298
1299 "lmom.test.nor" <-
1300 function(data) {
1301 lmom <- lmom.ub(data)
1302 para <- parnor(lmom)
1303 print("NORMAL DISTRIBUTION PARAMETERS")
1304 print(para)
1305 lmompara <- lmomnor(para)
1306 Q50 <- quanor(0.5,para)
1307 print(c('MEDIAN ',Q50))
1308 P50 <- cdfnor(Q50,para)
1309 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1310 lmom.diff(lmompara,lmom)
1311 }
1312
1313 "lmom.test.pe3" <-
1314 function(data) {
1315 lmom <- lmom.ub(data)
1316 para <- parpe3(lmom)
1317 print("PEARSON TYPE III DISTRIBUTION PARAMETERS")
1318 print(para)
1319 lmompara <- lmompe3(para)
1320 Q50 <- quape3(0.5,para)
1321 print(c('MEDIAN ',Q50))
1322 P50 <- cdfpe3(Q50,para)
1323 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1324 lmom.diff(lmompara,lmom)
1325 }
1326
1327 "lmom.test.wak" <-
1328 function(data) {
1329 lmom <- lmom.ub(data)
1330 para <- parwak(lmom)
1331 print("WAKEBY DISTRIBUTION PARAMETERS")
1332 print(para)
1333 lmompara <- lmomwak(para)
1334 Q50 <- quawak(0.5,para)
1335 print(c('MEDIAN ',Q50))
1336 P50 <- cdfwak(Q50,para)
1337 print(c('NONEXCEEDANCE OF COMPUTED MEDIAN ',P50))
1338 lmom.diff(lmompara,lmom)
1339 }
1340
1341 "lmom.ub" <-
1342 function(x) {
1343 n <- length(x)
1344 if(n == 1) stop("use mean() for data with one value")
1345 if(n < 5) stop("a minimum of 5 data values are required
1346 because 5 lmoments are to be computed")
1347 if(length(unique(x)) == 1) stop("all values are equal--lmoments can not be computed")
1348 x <- sort(x)
1349 L1 = 0; L2 = 0; L3 = 0; L4 = 0; L5 = 0
1350 for(i in seq(1,n)) {
1351 CL1 <- i-1
1352 CL2 <- CL1 * (i-1-1) / 2
1353 CL3 <- CL2 * (i-1-2) / 3
1354 CL4 <- CL3 * (i-1-3) / 4
1355 CR1 <- n-i
1356 CR2 <- CR1 * (n-i-1) / 2
1357 CR3 <- CR2 * (n-i-2) / 3
1358 CR4 <- CR3 * (n-i-3) / 4
1359 L1 <- L1 + x[i]
1360 L2 <- L2 + x[i] * (CL1 - CR1)
1361 L3 <- L3 + x[i] * (CL2 - 2*CL1*CR1 + CR2)
1362 L4 <- L4 + x[i] * (CL3 - 3*CL2*CR1 + 3*CL1*CR2 - CR3)
1363 L5 <- L5 + x[i] * (CL4 - 4*CL3*CR1 + 6*CL2*CR2 - 4*CL1*CR3 + CR4)
1364 }
1365
1366 C1 <- n
1367 C2 <- C1 * (n-1) / 2
1368 C3 <- C2 * (n-2) / 3
1369 C4 <- C3 * (n-3) / 4
1370 C5 <- C4 * (n-4) / 5
1371 L1 <- L1 / C1
1372 L2 <- L2 / C2 / 2
1373 L3 <- L3 / C3 / 3
1374 L4 <- L4 / C4 / 4
1375 L5 <- L5 / C5 / 5
1376 z <- list(L1 = L1, L2 = L2, TAU3 = L3/L2, TAU4 = L4/L2, TAU5 = L5/L2,
1377 LCV = L2/L1, L3 = L3, L4 = L4, L5=L5,
1378 )
1379 return(z)
1380 }
1381
1382 "lmom2par" <-
1383 function(lmom,type) {
1384 if(type == 'exp') {
1385 return(parexp(lmom))
1386 }
1387 else if(type == 'gam') {
1388 return(pargam(lmom))
1389 }
1390 else if(type == 'gev') {
1391 return(pargev(lmom))
1392 }
1393 else if(type == 'glo') {
1394 return(parglo(lmom))
1395 }
1396 else if(type == 'gno') {
1397 return(pargno(lmom))
1398 }
1399 else if(type == 'gpa') {
1400 return(pargpa(lmom))
1401 }
1402 else if(type == 'gum') {
1403 return(pargum(lmom))
1404 }
1405 else if(type == 'kap') {
1406 return(parkap(lmom))
1407 }
1408 else if(type == 'nor') {
1409 return(parnor(lmom))
1410 }
1411 else if(type == 'pe3') {
1412 return(parpe3(lmom))
1413 }
1414 else if(type == 'wak') {
1415 return(parwak(lmom))
1416 }
1417 else {
1418 stop("Do not find a valid distribution type.")
1419 }
1420 }
1421
1422 "lmom2pwm" <-
1423 function(lmom) {
1424 p0 = lmom$L1
1425 p1 = 0.5*(lmom$L2+p0)
1426 p2 = (1/6)*(lmom$L2*lmom$TAU3+6*p1-p0)
1427 p3 = (1/20)*(lmom$L2*lmom$TAU4+30*p2-12*p1+p0)
1428 p4 = (1/70)*(lmom$L2*lmom$TAU5+140*p3-90*p2+20*p1-p0)
1429 z <- list(BETA0 = p0, BETA1 = p1, BETA2 = p2, BETA3 = p3, BETA4 = p4)
1430 return(z)
1431 }
1432
1433 "lmomexp" <-
1434 function(para) {
1435 z <- list(L1 = NULL,
1436 L2 = NULL,
1437 TAU3 = NULL,
1438 TAU4 = NULL,
1439 TAU5 = NULL,
1440 LCV = NULL,
1441 L3 = NULL,
1442 L4 = NULL,
1443 L5 = NULL
1444 )
1445 if(! are.parexp.valid(para)) return()
1446 A <- para$para[2]
1447 z$L1 <- para$para[1]+A
1448 z$L2 <- 0.5*A
1449 z$TAU3 <- 2/(3*(2))
1450 z$TAU4 <- 2/(4*(3))
1451 z$TAU5 <- 2/(5*(4))
1452 z$L3 <- z$TAU3*z$L2
1453 z$L4 <- z$TAU4*z$L2
1454 z$L5 <- z$TAU5*z$L2
1455 return(z)
1456 }
1457
1458 "lmomgam" <-
1459 function(para) {
1460 z <- list(L1 = NULL,
1461 L2 = NULL,
1462 TAU3 = NULL,
1463 TAU4 = NULL,
1464 TAU5 = NULL,
1465 LCV = NULL,
1466 L3 = NULL,
1467 L4 = NULL,
1468 L5 = NULL
1469 )
1470 # Note that TAU5 and L5 are not available from Hosking's FORTRAN base.
1471
1472 # CONST IS 1/sqrt(pi)
1473 CONST <- 0.564189583547756287
1474
1475 # COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATIONS
1476 # A0 IS 1/sqrt(3*pi)
1477 # C0 IS TAU-4 FOR THE NORMAL DISTRIBUTION
1478 A0 <- 0.32573501
1479 A1 <- 0.16869150; A2 <- 0.78327243e-01; A3 <- -0.29120539e-02
1480 B1 <- 0.46697102; B2 <- 0.24255406
1481 C0 <- 0.12260172;
1482 C1 <- 0.53730130e-01; C2 <- 0.43384378e-01; C3 <- 0.11101277e-01
1483 D1 <- 0.18324466; D2 <- 0.20166036e+00
1484 E1 <- 0.23807576e+01; E2 <- 0.15931792e+01; E3 <- 0.11618371e+00
1485 F1 <- 0.51533299e+01; F2 <- 0.71425260e+01; F3 <- 0.19745056e+01
1486 G1 <- 0.21235833e+01; G2 <- 0.41670213e+01; G3 <- 0.31925299e+01
1487 H1 <- 0.90551443e+01; H2 <- 0.26649995e+02; H3 <- 0.26193668e+02
1488
1489 if(! are.pargam.valid(para)) return()
1490
1491 ALPHA <- para$para[1]
1492 BETA <- para$para[2]
1493 z$L1 <- ALPHA*BETA
1494 z$L2 <- BETA*CONST*exp(lgamma(ALPHA + 0.5) - lgamma(ALPHA))
1495
1496 if(ALPHA < 1) {
1497 Z <- ALPHA
1498 z$TAU3 <- (((E3*Z+E2)*Z+E1)*Z+1)/(((F3*Z+F2)*Z+F1)*Z+1)
1499 z$TAU4 <- (((G3*Z+G2)*Z+G1)*Z+1)/(((H3*Z+H2)*Z+H1)*Z+1)
1500 }
1501 else {
1502 Z <- 1/ALPHA
1503 z$TAU3 <- sqrt(Z)*(((A3*Z+A2)*Z+A1)*Z+A0)/((B2*Z+B1)*Z+1)
1504 z$TAU4 <- (((C3*Z+C2)*Z+C1)*Z+C0)/((D2*Z+D1)*Z+1)
1505 }
1506 z$LCV <- z$L2/z$L1
1507 z$L3 <- z$TAU3*z$L2
1508 z$L4 <- z$TAU4*z$L2
1509 return(z)
1510 }
1511
1512 "lmomgev" <-
1513 function(para) {
1514 z <- list(L1 = NULL,
1515 L2 = NULL,
1516 TAU3 = NULL,
1517 TAU4 = NULL,
1518 TAU5 = NULL,
1519 LCV = NULL,
1520 L3 = NULL,
1521 L4 = NULL,
1522 L5 = NULL
1523 )
1524 lmom <- matrix(nrow = 5, ncol = 1)
1525
1526 # ARRAY ZMOM CONTAINS THE L-MOMENT RATIOS OF THE STANDARD
1527 # GUMBEL DISTRIBUTION (XI=0, ALPHA=1).
1528 # ZMOM(1) IS EULER'S CONSTANT, ZMOM(2) IS LOG(2).
1529 ZMOM <- c(0.577215664901532861,
1530 0.693147180559945309,
1531 0.169925001442312363,
1532 0.150374992788438185,
1533 0.558683500577583138e-1)
1534
1535 # SMALL IS USED TO TEST WHETHER K IS EFFECTIVELY ZERO
1536 SMALL <- 1e-6
1537
1538 if(! are.pargev.valid(para)) return()
1539
1540 U <- para$para[1]
1541 A <- para$para[2]
1542 G <- para$para[3]
1543
1544 if(abs(G) <= SMALL) {
1545 z$L1 <- U
1546 z$L2 <- A*ZMOM[2]
1547 z$LCV <- z$L2/z$L1
1548 z$TAU3 <- ZMOM[3]
1549 z$TAU4 <- ZMOM[4]
1550 z$TAU5 <- ZMOM[5]
1551 z$L3 <- z$TAU3*z$L2
1552 z$L4 <- z$TAU4*z$L2
1553 z$L5 <- z$TAU5*z$L2
1554 return(z)
1555 }
1556 else {
1557 GAM <- exp(lgamma(1+G))
1558 z$L1 <- U+A*(1-GAM)/G
1559 XX2 <- 1-2^(-G)
1560 z$L2 <- A*XX2*GAM/G
1561 Z0 <- 1
1562 for(J in seq(3,5)) {
1563 BETA <- (1-J^(-G))/XX2
1564 Z0 <- Z0*(4*J-6)/J
1565 Z <- Z0*3*(J-1)/(J+1)
1566 SUM <- Z0*BETA-Z
1567 if(J > 3) {
1568 for(I in seq(2,J-2)) {
1569 Z <- Z*(I+I+1)*(J-I)/((I+I-1)*(J+I))
1570 SUM <- SUM-Z*lmom[I+1]
1571 }
1572 }
1573 lmom[J] = SUM
1574 }
1575 }
1576 z$LCV <- z$L2/z$L1
1577 z$TAU3 <- lmom[3]
1578 z$TAU4 <- lmom[4]
1579 z$TAU5 <- lmom[5]
1580 z$L3 <- z$TAU3*z$L2
1581 z$L4 <- z$TAU4*z$L2
1582 z$L5 <- z$TAU5*z$L2
1583 return(z)
1584 }
1585
1586 "lmomglo" <-
1587 function(para) {
1588 # function derived partially from Hosking and Wallis (1997) for K != 0
1589 # and from Hosking's FORTRAN library for K near or equal to zero.
1590 z <- list(L1 = NULL,
1591 L2 = NULL,
1592 TAU3 = NULL,
1593 TAU4 = NULL,
1594 TAU5 = NULL,
1595 LCV = NULL,
1596 L3 = NULL,
1597 L4 = NULL,
1598 L5 = NULL
1599 )
1600 # fifth L-moment is not given by Hosking and Wallis (1997)
1601 # SMALL IS USED TO DECIDE WHETHER TO APPROXIMATE THE FIRST 2
1602 # L-MOMENTS BY A POWER-SERIES EXPANSION WHEN G IS NEAR ZERO.
1603 # C1,C2 ARE COEFFICIENTS OF THIS POWER-SERIES EXPANSION.
1604 # C1 IS pi^2/6, C2 IS 7*pi^4/360.
1605 SMALL <- 1e-4
1606 C1 <- 0.164493406684822644e1; C2 <- 0.189406565899449184e1
1607
1608 if(! are.parglo.valid(para)) return()
1609
1610 XI <- para$para[1]
1611 A <- para$para[2]
1612 K <- para$para[3]
1613 KK <- K*K
1614 ALAM1 <- -K*(C1+KK*C2)
1615 ALAM2 <- 1+KK*(C1+KK*C2)
1616 if(abs(K) > SMALL) ALAM2 <- K*pi/sin(K*pi)
1617 if(abs(K) > SMALL) ALAM1 <- (1-ALAM2)/K
1618 z$L1 <- XI+A*ALAM1
1619 z$L2 <- A*ALAM2
1620 z$TAU3 <- -K
1621 z$TAU4 <- (1+5*K^2)/6
1622 z$LCV <- z$L2/z$L1
1623 z$L3 <- z$TAU3*z$L2
1624 z$L4 <- z$TAU4*z$L2
1625 return(z)
1626 }
1627
1628 "lmomgno" <-
1629 function(para) {
1630 # function derived partially from Hosking and Wallis (1997) for K != 0
1631 # and from Hosking's FORTRAN library for K near or equal to zero.
1632 z <- list(L1 = NULL,
1633 L2 = NULL,
1634 TAU3 = NULL,
1635 TAU4 = NULL,
1636 TAU5 = NULL,
1637 LCV = NULL,
1638 L3 = NULL,
1639 L4 = NULL,
1640 L5 = NULL
1641 )
1642 erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
1643
1644 SUM <- matrix(nrow = 5, ncol = 1)
1645 for(i in seq(1,5)) SUM[i] <- 0
1646 EST <- matrix(nrow = 5, ncol = 1)
1647 for(i in seq(1,5)) EST[i] <- 0
1648 ESTX <- matrix(nrow = 5, ncol = 1)
1649 for(i in seq(1,5)) ESTX[i] <- 0
1650
1651
1652 # ARRAY ZMOM CONTAINS L-MOMENTS OF THE STANDARD NORMAL DIST.
1653 ZMOM <- c( 0, 0.564189583547756287,
1654 0, 0.122601719540890947,
1655 0)
1656
1657 # RRT2 IS 1/SQRT(2), RRTPI IS 1/SQRT(PI)
1658 RRT2 <- 1/sqrt(2)
1659 RRTPI <- 1/sqrt(pi)
1660
1661 # RANGE,EPS,MAXIT CONTROL THE ITERATIVE PROCEDURE FOR NUMERICAL INTEGRATION
1662 RANGE <- 5
1663 EPS <- 1e-8
1664 MAXIT <- 10
1665
1666 if(! are.pargno.valid(para)) return()
1667
1668 U <- para$para[1]
1669 A <- para$para[2]
1670 G <- para$para[3]
1671
1672 # TEST FOR K=0
1673 if(abs(G) <= EPS) {
1674 # K is zero
1675 z$L1 <- U
1676 z$L2 <- A*ZMOM[2]
1677 z$TAU3 <- ZMOM[3]
1678 z$TAU4 <- ZMOM[4]
1679 z$TAU5 <- ZMOM[5]
1680 z$LCV <- z$L2/z$L1
1681 z$L3 <- z$TAU3*z$L2
1682 z$L4 <- z$TAU4*z$L2
1683 z$L5 <- z$TAU5*z$L2
1684 return(z)
1685 }
1686
1687 # LAMBDA-1
1688 EGG <- exp(0.5*G^2)
1689 ALAM1 <- (1-EGG)/G
1690 z$L1 <- U+A*ALAM1
1691
1692 # LAMBDA-2
1693 ALAM2 <- EGG*erf(0.5*G)/G
1694 z$L2 <- A*ALAM2
1695
1696 # HIGHER MOMENTS. THE INTEGRAL DEFINING LAMBDA-R IS EVALUATED
1697 # BY ITERATIVE APPLICATION OF THE TRAPEZIUM RULE.
1698 #
1699 # - INITIAL ESTIMATE, USING 16 ORDINATES (THE 'DO 20' LOOP
1700 # CALCULATES LEGENDRE POLYNOMIALS RECURSIVELY)
1701 CC <- -G*RRT2
1702 XMIN <- CC-RANGE
1703 XMAX <- CC+RANGE
1704
1705 N <- 16
1706 XINC <- (XMAX-XMIN)/N
1707 for(i in seq(1,N-1)) {
1708 X <- XMIN+i*XINC
1709 E <- exp(-((X-CC)^2))
1710 D <- erf(X)
1711 P1 <- 1
1712 P <- D
1713 for(m in seq(3,5)) {
1714 C1 <- m+m-3
1715 C2 <- m-2
1716 C3 <- m-1
1717 P2 <- P1
1718 P1 <- P
1719 P <- (C1*D*P1-C2*P2)/C3
1720 SUM[m] <- SUM[m]+E*P
1721 }
1722 }
1723 EST[3] <- SUM[3]*XINC
1724 EST[4] <- SUM[4]*XINC
1725 EST[5] <- SUM[5]*XINC
1726
1727 # - DOUBLE THE NUMBER OF ORDINATES UNTIL CONVERGED
1728 for(it in seq(1,MAXIT)) {
1729
1730 ESTX[3] <- EST[3]
1731 ESTX[4] <- EST[4]
1732 ESTX[5] <- EST[5]
1733
1734 N <- N*2
1735 XINC <- (XMAX - XMIN)/N
1736 for(i in seq(1,N-1,2)) {
1737 X <- XMIN+i*XINC
1738 E <- exp(-((X-CC)^2))
1739 D <- erf(X)
1740 P1 <- 1
1741 P <- D
1742 for(m in seq(3,5)) {
1743 C1 <- m+m-3
1744 C2 <- m-2
1745 C3 <- m-1
1746 P2 <- P1
1747 P1 <- P
1748 P <- (C1*D*P1-C2*P2)/C3
1749 SUM[m] <- SUM[m]+E*P
1750 }
1751 }
1752
1753 # --- TEST FOR CONVERGENCE
1754 NOTCGD <- 0
1755 for(m in seq(5,3,-1)) {
1756 EST[m] <- SUM[m]*XINC
1757 if(abs(EST[m]-ESTX[m]) > EPS*abs(EST[m])) NOTCGD <- m
1758 }
1759 if(NOTCGD == 0) break
1760 }
1761 if(NOTCGD != 0) {
1762 warning(c("ITERATION HAS NOT CONVERGED. ONLY THE FIRST ",NOTCGD-1,
1763 " L-MOMENTS ARE RELIABLE"))
1764 }
1765 CONST <- -exp(CC*CC)*RRTPI/(ALAM2*G)
1766 z$TAU3 <- CONST*EST[3]
1767 z$TAU4 <- CONST*EST[4]
1768 z$TAU5 <- CONST*EST[5]
1769 z$LCV <- z$L2/z$L1
1770 z$L3 <- z$TAU3*z$L2
1771 z$L4 <- z$TAU4*z$L2
1772 z$L5 <- z$TAU5*z$L2
1773 return(z)
1774 }
1775
1776 "lmomgpa" <-
1777 function(para) {
1778 z <- list(L1 = NULL,
1779 L2 = NULL,
1780 TAU3 = NULL,
1781 TAU4 = NULL,
1782 TAU5 = NULL,
1783 LCV = NULL,
1784 L3 = NULL,
1785 L4 = NULL,
1786 L5 = NULL
1787 )
1788
1789 if(! are.pargpa.valid(para)) return()
1790 XI <- para$para[1]
1791 A <- para$para[2]
1792 K <- para$para[3]
1793
1794 # LAMBDA-1
1795 Y <- 1/(1+K)
1796 z$L1 <- XI+A*Y
1797
1798 # LAMBDA-2
1799 Y <- Y/(2+K)
1800 z$L2 <- A*Y
1801
1802 # HIGHER MOMENTS
1803 x <- matrix(nrow = 5, ncol = 1)
1804 Y <- 1
1805 for(m in seq(3,5)) {
1806 AM <- m-2
1807 Y <- Y*(AM-K)/(m+K)
1808 x[m] <- Y
1809 }
1810 z$TAU3 <- x[3]
1811 z$TAU4 <- x[4]
1812 z$TAU5 <- x[5]
1813 z$LCV <- z$L2/z$L1
1814 z$L3 <- z$TAU3*z$L2
1815 z$L4 <- z$TAU4*z$L2
1816 z$L5 <- z$TAU5*z$L2
1817 return(z)
1818 }
1819
1820 "lmomgum" <-
1821 function(para) {
1822 z <- list(L1 = NULL,
1823 L2 = NULL,
1824 TAU3 = NULL,
1825 TAU4 = NULL,
1826 TAU5 = NULL,
1827 LCV = NULL,
1828 L3 = NULL,
1829 L4 = NULL,
1830 L5 = NULL
1831 )
1832 # ARRAY ZMOM CONTAINS THE L-MOMENT RATIOS OF THE STANDARD
1833 # GUMBEL DISTRIBUTION (XI=0, ALPHA=1).
1834 # ZMOM(1) IS EULER'S CONSTANT, ZMOM(2) IS LOG(2).
1835 #
1836 ZMOM <- c(0.577215664901532861,
1837 0.693147180559945309,
1838 0.169925001442312363,
1839 0.150374992788438185,
1840 0.558683500577583138e-1)
1841
1842 A <- para$para[2]
1843 z$L1 <- para$para[1] + A*ZMOM[1]
1844 z$L2 <- A*ZMOM[2]
1845 z$TAU3 <- ZMOM[3]
1846 z$TAU4 <- ZMOM[4]
1847 z$TAU5 <- ZMOM[5]
1848 z$LCV <- z$L2/z$L1
1849 z$L3 <- z$TAU3*z$L2
1850 z$L4 <- z$TAU4*z$L2
1851 z$L5 <- z$TAU5*z$L2
1852 return(z)
1853 }
1854
1855 "lmomkap" <-
1856 function(para) {
1857 if(! are.parkap.valid(para)) return()
1858 z <- list(L1 = NULL,
1859 L2 = NULL,
1860 TAU3 = NULL,
1861 TAU4 = NULL,
1862 TAU5 = NULL,
1863 LCV = NULL,
1864 L3 = NULL,
1865 L4 = NULL,
1866 L5 = NULL
1867 )
1868 BETA <- matrix(nrow = 5, ncol = 1)
1869
1870 # SMALL IS USED TO TEST WHETHER H IS EFFECTIVELY ZERO
1871 SMALL <- 1e-8
1872
1873 U <- para$para[1]
1874 A <- para$para[2]
1875 G <- para$para[3]
1876 H <- para$para[4]
1877
1878
1879 # CALCULATE FUNCTIONS OCCURRING IN THE PWM'S BETA-SUB-R
1880 ICASE <- 1
1881 if(H > 0) ICASE <- 3
1882 if(abs(H) < SMALL) ICASE <- 2
1883 if(G == 0) ICASE <- ICASE+3
1884 if(ICASE == 1) BETA <- INT.kapicase1(U,A,G,H)
1885 if(ICASE == 2) BETA <- INT.kapicase2(U,A,G,H)
1886 if(ICASE == 3) BETA <- INT.kapicase3(U,A,G,H)
1887 if(ICASE == 4) BETA <- INT.kapicase4(U,A,G,H)
1888 if(ICASE == 5) BETA <- INT.kapicase5(U,A,G,H)
1889 if(ICASE == 6) BETA <- INT.kapicase6(U,A,G,H)
1890
1891 # LAMBDA-1
1892 if(G == 0) {
1893 z$L1 <- U+A*BETA[1]
1894 }
1895 else {
1896 z$L1 <- U+A*(1-BETA[1])/G
1897 }
1898
1899 # LAMBDA-2
1900 ALAM2 <- BETA[2]-BETA[1]
1901 if(G == 0) {
1902 z$L2 <- A*ALAM2
1903 }
1904 else {
1905 z$L2 <- A*ALAM2/(-G)
1906 }
1907 z$LCV <- z$L2 / z$L1
1908 # HIGHER MOMENTS
1909 Z0 <- 1
1910 x <- matrix(nrow = 5, ncol = 1)
1911 for(J in seq(3,5)) {
1912 Z0 <- Z0*(4*J-6)/J
1913 Z <- Z0*3*(J-1)/(J+1)
1914 SUM <- Z0*(BETA[J]-BETA[1])/ALAM2-Z
1915 if(J == 3) {
1916 x[J] <- SUM
1917 }
1918 else {
1919 for(I in seq(2,J-2)) {
1920 Z <- Z*(I+I+1)*(J-I)/((I+I-1)*(J+I))
1921 SUM <- SUM-Z*x[I+1]
1922 }
1923 x[J] <- SUM
1924 }
1925 }
1926 z$TAU3 <- x[3]
1927 z$TAU4 <- x[4]
1928 z$TAU5 <- x[5]
1929 z$L3 <- z$TAU3*z$LCV
1930 z$L4 <- z$TAU4*z$LCV
1931 z$L5 <- z$TAU5*z$LCV
1932 return(z)
1933 }
1934
1935 "lmomnor" <-
1936 function(para) {
1937 z <- list(L1 = NULL,
1938 L2 = NULL,
1939 TAU3 = NULL,
1940 TAU4 = NULL,
1941 TAU5 = NULL,
1942 LCV = NULL,
1943 L3 = NULL,
1944 L4 = NULL,
1945 L5 = NULL
1946 )
1947
1948 if(! are.parnor.valid(para)) return()
1949
1950 erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
1951
1952 # ARRAY ZMOM CONTAINS L-MOMENTS OF THE STANDARD NORMAL DIST.
1953 ZMOM <- c( 0, 0.564189583547756287,
1954 0, 0.122601719540890947,
1955 0)
1956
1957 # RRT2 IS 1/SQRT(2), RRTPI IS 1/SQRT(PI)
1958 RRT2 <- 1/sqrt(2)
1959 RRTPI <- 1/sqrt(pi)
1960
1961 z$L1 <- para$para[1]
1962 z$L2 <- para$para[2]*ZMOM[2]
1963 z$TAU3 <- ZMOM[3]
1964 z$TAU4 <- ZMOM[4]
1965 z$TAU5 <- ZMOM[5]
1966 z$LCV <- z$L2/z$L1
1967 z$L3 <- z$TAU3*z$L2
1968 z$L4 <- z$TAU4*z$L2
1969 z$L5 <- z$TAU5*z$L2
1970 return(z)
1971 }
1972
1973 "lmompe3" <-
1974 function(para) {
1975 z <- list(L1 = NULL,
1976 L2 = NULL,
1977 TAU3 = NULL,
1978 TAU4 = NULL,
1979 TAU5 = NULL,
1980 LCV = NULL,
1981 L3 = NULL,
1982 L4 = NULL,
1983 L5 = NULL
1984 )
1985
1986 if(! are.parpe3.valid(para)) return()
1987
1988 # SMALL IS USED TO TEST WHETHER SKEWNESS IS EFFECTIVELY ZERO
1989 SMALL <- 1e-6
1990
1991 # CONST IS 1/SQRT(PI)
1992 CONST <- 1/sqrt(pi)
1993
1994 # COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATIONS
1995 # A0 IS 1/SQRT(3*PI)
1996 # C0 IS TAU-4 FOR THE NORMAL DISTRIBUTION
1997 A0 <- 1/sqrt(3*pi)
1998 A1 <- 0.16869150
1999 A2 <- 0.78327243e-1
2000 A3 <- -0.29120539e-2
2001 B1 <- 0.46697102
2002 B2 <- 0.24255406
2003 C0 <- 0.12260172
2004 C1 <- 0.53730130e-1
2005 C2 <- 0.43384378e-1
2006 C3 <- 0.11101277e-1
2007 D1 <- 0.18324466
2008 D2 <- 0.20166036
2009 E1 <- 0.23807576e1
2010 E2 <- 0.15931792e1
2011 E3 <- 0.11618371
2012 F1 <- 0.51533299e1
2013 F2 <- 0.71425260e1
2014 F3 <- 0.19745056e1
2015 G1 <- 0.21235833e1
2016 G2 <- 0.41670213e1
2017 G3 <- 0.31925299e1
2018 H1 <- 0.90551443e1
2019 H2 <- 0.26649995e2
2020 H3 <- 0.26193668e2
2021
2022 SD <- para$para[2]
2023
2024 # LAMBDA-1
2025 z$L1 <- para$para[1]
2026
2027 # LAMBDA-2
2028 GAMMA <- para$para[3]
2029 if(abs(GAMMA) < SMALL) {
2030 # CASE OF ZERO SKEWNESS
2031 z$L2 <- CONST*para[2]
2032 z$TAU3 <- 0
2033 z$TAU4 <- C0
2034 z$L3 <- z$L2*z$TAU3
2035 z$L4 <- z$L2*z$TAU4
2036 # NO TAU5 AVAILABLE
2037 }
2038 else {
2039 ALPHA <- 4/(GAMMA*GAMMA)
2040 BETA <- abs(0.5*SD*GAMMA)
2041 ALAM2 <- CONST*exp(lgamma(ALPHA+0.5)-lgamma(ALPHA))
2042 z$L2 <- ALAM2*BETA
2043
2044 # HIGHER MOMENTS
2045 if(ALPHA < 1) {
2046 Z <- ALPHA
2047 z$TAU3 <- (((E3*Z+E2)*Z+E1)*Z+1)/(((F3*Z+F2)*Z+F1)*Z+1)
2048 if(GAMMA < 0) z$TAU3 <- -z$TAU3
2049 z$TAU4 <- (((G3*Z+G2)*Z+G1)*Z+1)/(((H3*Z+H2)*Z+H1)*Z+1)
2050 z$L3 <- z$L2*z$TAU3
2051 z$L4 <- z$L2*z$TAU4
2052 }
2053 else {
2054 Z <- 1/ALPHA
2055 z$TAU3 <- sqrt(Z)*(((A3*Z+A2)*Z+A1)*Z+A0)/((B2*Z+B1)*Z+1)
2056 if(GAMMA < 0) z$TAU3 <- -z$TAU3
2057 z$TAU4 <- (((C3*Z+C2)*Z+C1)*Z+C0)/((D2*Z+D1)*Z+1)
2058 z$L3 <- z$L2*z$TAU3
2059 z$L4 <- z$L2*z$TAU4
2060 }
2061 }
2062 return(z)
2063 }
2064
2065 "lmomwak" <-
2066 function(wakpara) {
2067 z <- list(L1 = NULL,
2068 L2 = NULL,
2069 TAU3 = NULL,
2070 TAU4 = NULL,
2071 TAU5 = NULL,
2072 LCV = NULL,
2073 L3 = NULL,
2074 L4 = NULL,
2075 L5 = NULL
2076 )
2077
2078 if(! are.parwak.valid(wakpara)) return()
2079
2080 XI <- wakpara$para[1]
2081 A <- wakpara$para[2]
2082 B <- wakpara$para[3]
2083 C <- wakpara$para[4]
2084 D <- wakpara$para[5]
2085
2086 # LAMBDA-1
2087 #
2088 Y <- A/(1+B)
2089 Z <- C/(1-D)
2090 z$L1 <- XI+Y+Z
2091
2092 # LAMBDA-2
2093 #
2094 Y <- Y/(2+B)
2095 Z <- Z/(2-D)
2096 ALAM2 <- Y+Z
2097 z$L2 <- ALAM2
2098
2099 # HIGHER MOMENTS
2100 #
2101 x <- matrix(nrow = 5, ncol = 1)
2102 for(M in seq(3,5)) {
2103 Y <- Y*(M-2-B)/(M+B)
2104 Z <- Z*(M-2+D)/(M-D)
2105 x[M] <- (Y+Z)/ALAM2
2106 }
2107 z$TAU3 <- x[3]
2108 z$TAU4 <- x[4]
2109 z$TAU5 <- x[5]
2110 z$LCV <- z$L2/z$L1
2111 z$L3 <- z$TAU3*z$L2
2112 z$L4 <- z$TAU4*z$L2
2113 z$L5 <- z$TAU5*z$L2
2114 return(z)
2115 }
2116
2117 "lmrdia" <-
2118 function() {
2119 step = 0.005
2120 n = 1
2121 lim <- matrix(nrow = 401, ncol = 2)
2122 gpa <- matrix(nrow = 401, ncol = 2)
2123 for(t3 in seq(-1,1,step)) {
2124 lim[n,1] = t3
2125 lim[n,2] = 0.25*(5*t3^2 - 1)
2126 gpa[n,1] = t3
2127 gpa[n,2] = (t3*(1+5*t3))/(5+t3)
2128 n = n + 1
2129 }
2130 n = 1
2131 gev <- matrix(nrow = 582, ncol = 2)
2132 for(k in seq(-1,1,step)) {
2133 h = -k
2134 gev[n,1] = 2*(1-3^h)/(1-2^h) - 3
2135 gev[n,2] = (5*(1-4^h)-10*(1-3^h)+6*(1-2^h))/(1-2^h)
2136 n = n + 1
2137 }
2138 for(k in seq(1-step,10,0.05)) {
2139 h = -k
2140 gev[n,1] = 2*(1-3^h)/(1-2^h) - 3
2141 gev[n,2] = (5*(1-4^h)-10*(1-3^h)+6*(1-2^h))/(1-2^h)
2142 n = n + 1
2143 }
2144 n = 1
2145 glo <- matrix(nrow = 401, ncol = 2)
2146 for(k in seq(-1,1,step)) {
2147 glo[n,1] = -k
2148 glo[n,2] = (1+5*k^2)/6
2149 n = n + 1
2150 }
2151
2152 n = 1
2153 pIII <- matrix(nrow = 361, ncol = 2)
2154 for(t3 in seq(-.9,.9,step)) {
2155 pIII[n,1] = t3
2156 pIII[n,2] = 0.1224+0.30115*t3^2+0.95812*t3^4-0.57488*t3^6+0.19383*t3^8
2157 n = n + 1
2158 }
2159
2160 n = 1
2161 ln <- matrix(nrow = 361, ncol = 2)
2162 for(t3 in seq(-.9,.9,step)) {
2163 ln[n,1] = t3
2164 ln[n,2] = 0.12282+0.77518*t3^2+0.12279*t3^4-0.13638*t3^6+0.11368*t3^8
2165 n = n + 1
2166 }
2167
2168
2169 exp <- matrix(nrow = 1, ncol = 2)
2170 exp[1,] <- c(1/3,1/6)
2171 gum <- matrix(nrow = 1, ncol = 2)
2172 gum[1,] <- c(log(9/8)/log(2),(16*log(2)-10*log(3))/log(2))
2173 nor <- matrix(nrow = 1, ncol = 2)
2174 nor[1,] <- c(0,30*pi^-1*atan(sqrt(2))-9)
2175 uni <- matrix(nrow = 1, ncol = 2)
2176 uni[1,] <- c(0,0)
2177 z <- list(limits = lim, exp=exp, gev = gev, glo = glo,
2178 gpa=gpa, gum=gum, gno=ln, nor=nor,
2179 pe3=pIII, uniform=uni)
2180 return(z)
2181 }
2182
2183 "nonexceeds" <-
2184 function() {
2185 F <- c(0.01,0.02,0.04,0.05,0.10,0.15,0.20,0.25,0.3,0.4,0.5,
2186 0.6,0.7,0.8,0.85,,0.9,0.95,0.96,0.98,0.99,0.996,0.998)
2187 }
2188
2189 "par2cdf" <-
2190 function(x,para) {
2191 type <- para$type
2192 if(type == 'cau') {
2193 return(cdfcau(x,para))
2194 }
2195 else if(type == 'exp') {
2196 return(cdfexp(x,para))
2197 }
2198 else if(type == 'gam') {
2199 return(cdfgam(x,para))
2200 }
2201 else if(type == 'gev') {
2202 return(cdfgev(x,para))
2203 }
2204 else if(type == 'glo') {
2205 return(cdfglo(x,para))
2206 }
2207 else if(type == 'gno') {
2208 return(cdfgno(x,para))
2209 }
2210 else if(type == 'gpa') {
2211 return(cdfgpa(x,para))
2212 }
2213 else if(type == 'gum') {
2214 return(cdfgum(x,para))
2215 }
2216 else if(type == 'nor') {
2217 return(cdfnor(x,para))
2218 }
2219 else if(type == 'kap') {
2220 return(cdfkap(x,para))
2221 }
2222 else if(type == 'pe3') {
2223 return(cdfpe3(x,para))
2224 }
2225 else if(type == 'wak') {
2226 return(cdfwak(x,para))
2227 }
2228 else {
2229 stop("Do not find a valid distribution type.")
2230 }
2231 }
2232
2233 "par2lmom" <-
2234 function(para) {
2235 type <- para$type
2236 if(type == 'exp') {
2237 return(lmomexp(para))
2238 }
2239 else if(type == 'gam') {
2240 return(lmomgam(para))
2241 }
2242 else if(type == 'gev') {
2243 return(lmomgev(para))
2244 }
2245 else if(type == 'glo') {
2246 return(lmomglo(para))
2247 }
2248 else if(type == 'gno') {
2249 return(lmomgno(para))
2250 }
2251 else if(type == 'gpa') {
2252 return(lmomgpa(para))
2253 }
2254 else if(type == 'gum') {
2255 return(lmomgum(para))
2256 }
2257 else if(type == 'nor') {
2258 return(lmomnor(para))
2259 }
2260 else if(type == 'kap') {
2261 return(lmomkap(para))
2262 }
2263 else if(type == 'pe3') {
2264 return(lmompe3(para))
2265 }
2266 else if(type == 'wak') {
2267 return(lmomwak(para))
2268 }
2269 else {
2270 stop("Do not find a valid distribution type.")
2271 }
2272 }
2273
2274 "par2qua" <-
2275 function(f,para) {
2276 type <- para$type
2277 if(type == 'cau') {
2278 return(quacau(f,para))
2279 }
2280 else if(type == 'exp') {
2281 return(quaexp(f,para))
2282 }
2283 else if(type == 'gam') {
2284 return(quagam(f,para))
2285 }
2286 else if(type == 'gev') {
2287 return(quagev(f,para))
2288 }
2289 else if(type == 'glo') {
2290 return(quaglo(f,para))
2291 }
2292 else if(type == 'gno') {
2293 return(quagno(f,para))
2294 }
2295 else if(type == 'gpa') {
2296 return(quagpa(f,para))
2297 }
2298 else if(type == 'gum') {
2299 return(quagum(f,para))
2300 }
2301 else if(type == 'nor') {
2302 return(quanor(f,para))
2303 }
2304 else if(type == 'kap') {
2305 return(quakap(f,para))
2306 }
2307 else if(type == 'pe3') {
2308 return(quape3(f,para))
2309 }
2310 else if(type == 'wak') {
2311 return(quawak(f,para))
2312 }
2313 else {
2314 stop("Do not find a valid distribution type.")
2315 }
2316 }
2317
2318 "parexp" <-
2319 function(lmom) {
2320 para <- matrix(nrow = 2, ncol = 1)
2321 if(! are.lmom.valid(lmom)) {
2322 warning("L-moments are invalid.")
2323 return()
2324 }
2325 para[2] <- 2*lmom$L2
2326 para[1] <- lmom$L1 - para[2]
2327 return(list(type = 'exp', para = para))
2328 }
2329
2330 "pargam" <-
2331 function(lmom) {
2332 para <- matrix(nrow = 2, ncol = 1)
2333 # METHOD: RATIONAL APPROXIMATION IS USED TO EXPRESS ALPHA AS A FUNCTION
2334 # OF L-CV. RELATIVE ACCURACY OF THE APPROXIMATION IS BETTER THAN 5E-5.
2335 #
2336 # CONSTANTS USED IN MINIMAX APPROXIMATIONS
2337 #
2338 A1 <- -0.3080; A2 <- -0.05812; A3 <- 0.01765
2339 B1 <- 0.7213; B2 <- -0.5947; B3 <- -2.1817; B4 <- 1.2113
2340
2341 if(! are.lmom.valid(lmom)) {
2342 warning("L-moments are invalid.")
2343 return()
2344 }
2345
2346 if(lmom$LCV >= 0.5) {
2347 T <- 1-lmom$LCV
2348 ALPHA <- T*(B1+T*B2)/(1+T*(B3+T*B4))
2349 }
2350 else {
2351 T <- pi*lmom$LCV^2
2352 ALPHA <- (1+A1*T)/(T*(1+T*(A2+T*A3)))
2353 }
2354 para[1] <- ALPHA
2355 para[2] <- lmom$L1/ALPHA
2356 return(list(type = 'gam', para = para))
2357 }
2358
2359 "pargev" <-
2360 function(lmom) {
2361 para <- matrix(nrow = 3, ncol = 1)
2362 # METHOD: FOR -0.8 LE TAU3 LT 1, K IS APPROXIMATED BY RATIONAL
2363 # FUNCTIONS AS IN DONALDSON (1996, COMMUN. STATIST. SIMUL. COMPUT.).
2364 # IF TAU3 IS OUTSIDE THIS RANGE, NEWTON-RAPHSON ITERATION IS USED.
2365 # SMALL IS USED TO TEST WHETHER K IS EFFECTIVELY ZERO
2366 # EPS,MAXIT CONTROL THE TEST FOR CONVERGENCE OF N-R ITERATION
2367
2368 SMALL <- 1e-5; EPS <- 1e-6; MAXIT <- 20;
2369
2370 # EU IS EULER'S CONSTANT
2371 # DL2 IS LOG(2), DL3 IS LOG(3)
2372 EU <- 0.57721566; DL2 <- 0.69314718; DL3 <- 1.0986123
2373
2374 # COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATIONS FOR K
2375 A0 <- 0.28377530; A1 <- -1.21096399; A2 <- -2.50728214
2376 A3 <- -1.13455566; A4 <- -0.07138022
2377 B1 <- 2.06189696; B2 <- 1.31912239; B3 <- 0.25077104
2378 C1 <- 1.59921491; C2 <- -0.48832213; C3 <- 0.01573152
2379 D1 <- -0.64363929; D2 <- 0.08985247
2380
2381 T3 <- lmom$TAU3
2382
2383 if(! are.lmom.valid(lmom)) {
2384 warning("L-moments are invalid.")
2385 return()
2386 }
2387
2388 if(T3 > 0) {
2389 # RATIONAL-FUNCTION APPROXIMATION FOR TAU3 BETWEEN 0 AND 1
2390 #
2391 Z <- 1-T3
2392 G <- (-1+Z*(C1+Z*(C2+Z*C3)))/(1+Z*(D1+Z*D2))
2393 if(abs(G) < SMALL) {
2394 # ESTIMATED K EFFECTIVELY ZERO
2395 para[3] <- 0
2396 para[2] <- lmom$L2/DL2
2397 para[1] <- lmom$L1-EU*para[2]
2398 return(list(type = 'gev', para = para))
2399 }
2400 }
2401 else { # T3 is <= to zero
2402 if(T3 < 0 & T3 >= -0.80) {
2403 # RATIONAL-FUNCTION APPROXIMATION FOR TAU3 BETWEEN -0.8 AND 0
2404 G <- (A0+T3*(A1+T3*(A2+T3*(A3+T3*A4))))/(1+T3*(B1+T3*(B2+T3*B3)))
2405 }
2406 else {
2407 # NEWTON-RAPHSON ITERATION FOR TAU3 LESS THAN -0.8
2408 #
2409 if(T3 <= -0.97) {
2410 G <- 1-log(1+T3)/DL2
2411 }
2412 else {
2413 T0 <- (T3+3)*0.5
2414 CONVERGE = FALSE
2415 for(it in seq(1,MAXIT)) {
2416 X2 <- 2^-G
2417 X3 <- 3^-G
2418 XX2 <- 1-X2
2419 XX3 <- 1-X3
2420 T <- XX3/XX2
2421 DERIV <- (XX2*X3*DL3-XX3*X2*DL2)/(XX2*XX2)
2422 GOLD <- G
2423 G <- G-(T-T0)/DERIV
2424 if(abs(G-GOLD) <= EPS*G) {
2425 CONVERGE = TRUE
2426 }
2427 }
2428 if(CONVERGE == FALSE)
2429 warning("Iteration has not converged. Results might be unreliable.")
2430 }
2431 }
2432 }
2433
2434 # ESTIMATE ALPHA,XI
2435 para[3] <- G
2436 GAM <- exp(lgamma(1+G))
2437 para[2] <- lmom$L2*G/(GAM*(1-2**(-G)))
2438 para[1] <- lmom$L1 - para[2]*(1-GAM)/G
2439 return(list(type = 'gev', para = para))
2440 }
2441
2442 "parglo" <-
2443 function(lmom) {
2444 SMALL <- 1e-6
2445 # Estimate kappa of distribution
2446 para <- matrix(nrow = 3, ncol = 1)
2447 K <- -lmom$TAU3
2448 if(! are.lmom.valid(lmom)) {
2449 warning("L-moments are invalid.")
2450 return()
2451 }
2452 if(abs(K) <= SMALL) {
2453 # kappa is effectively zero
2454 para[3] = 0
2455 para[2] = lmom$L2
2456 para[1] = lmom$L1
2457 return(list(type = 'glo', para = para))
2458 }
2459 # Estimate alpha and xi of distribution
2460 KK <- K*pi/sin(K*pi)
2461 A <- lmom$L2/KK
2462 para[1] <- lmom$L1 - A*(1-KK)/K
2463 para[2] <- A
2464 para[3] <- K
2465 return(list(type = 'glo', para = para))
2466 }
2467
2468 "pargno" <-
2469 function(lmom) {
2470 para <- matrix(nrow = 3, ncol = 1)
2471 erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
2472
2473 # METHOD: RATIONAL-FUNCTION APPROXIMATION OF K IN TERMS OF TAU-3
2474 # COEFFICIENTS OF RATIONAL-FUNCTION APPROXIMATION
2475 # A0 IS 0.5*sqrt(3/pi)
2476 A0 <- 0.20466534e1; A1 <- -0.36544371e+1;
2477 A2 <- 0.18396733e+1; A3 <- -0.20360244;
2478 B1 <- -0.20182173e+1; B2 <- 0.12420401e+1; B3 <- -0.21741801
2479
2480 # SMALL IS USED TO TEST WHETHER SKEWNESS IS EFFECTIVELY ZERO
2481 SMALL <- 1e-8
2482
2483 T3 <- lmom$TAU3
2484 if(! are.lmom.valid(lmom)) {
2485 warning("L-moments are invalid.")
2486 return()
2487 }
2488 if(abs(T3) >= 0.95) {
2489 warning("L-SKEW IS TOO LARGE FOR ROUTINE")
2490 para[1] = 0
2491 para[2] = -1
2492 para[3] = 0
2493 return(list(type = 'gno', para = para))
2494 }
2495 if(abs(T3) <= SMALL) {
2496 para[1] = lmom$L1
2497 para[2] = lmom$L2*sqrt(pi)
2498 para[3] = 0
2499 return(list(type = 'gno', para = para))
2500 }
2501 TT <- T3*T3
2502 K <- -T3*(A0+TT*(A1+TT*(A2+TT*A3)))/(1+TT*(B1+TT*(B2+TT*B3)))
2503 E <- exp(0.5*K*K)
2504 A <- lmom$L2*K/(E*erf(0.5*K))
2505 XI <- lmom$L1+A*(E-1)/K
2506 para[1] <- XI
2507 para[2] <- A
2508 para[3] <- K
2509 return(list(type = 'gno', para = para))
2510 }
2511
2512 "pargpa" <-
2513 function(lmom) {
2514 para <- matrix(nrow = 3, ncol = 1)
2515 L1 <- lmom$L1
2516 L2 <- lmom$L2
2517 T3 <- lmom$TAU3
2518 if(! are.lmom.valid(lmom)) {
2519 warning("L-moments are invalid.")
2520 return()
2521 }
2522 K <- (1-3*T3)/(1+T3)
2523 para[3] <- K
2524 para[2] <- (1+K)*(2+K)*L2
2525 para[1] <- L1 - para[2]/(1+K)
2526 return(list(type = 'gpa', para=para))
2527 }
2528
2529 "pargum" <-
2530 function(lmom) {
2531 euler <- 0.577215664901532861
2532 para <- matrix(nrow = 2, ncol = 1);
2533 if(! are.lmom.valid(lmom)) {
2534 warning("L-moments are invalid.")
2535 return()
2536 }
2537 para[2] <- lmom$L2/log(2)
2538 para[1] <- lmom$L1-euler*para[2]
2539 return(list(type = 'gum', para=para))
2540 }
2541
2542 "parkap" <-
2543 function(lmom) {
2544 para <- matrix(nrow = 4, ncol = 1)
2545 # IFAIL *OUTPUT* FAIL FLAG. ON EXIT, IT IS SET AS FOLLOWS.
2546 # 0 SUCCESSFUL EXIT
2547 # 1 L-MOMENTS INVALID
2548 # 2 (TAU-3, TAU-4) LIES ABOVE THE GENERALIZED-LOGISTIC
2549 # LINE (SUGGESTS THAT L-MOMENTS ARE NOT CONSISTENT
2550 # WITH ANY KAPPA DISTRIBUTION WITH H.GT.-1)
2551 # 3 ITERATION FAILED TO CONVERGE
2552 # 4 UNABLE TO MAKE PROGRESS FROM CURRENT POINT IN
2553 # ITERATION
2554 # 5 ITERATION ENCOUNTERED NUMERICAL DIFFICULTIES -
2555 # OVERFLOW WOULD HAVE BEEN LIKELY TO OCCUR
2556 # 6 ITERATION FOR H AND K CONVERGED, BUT OVERFLOW
2557 # WOULD HAVE OCCURRED WHEN CALCULATING XI AND ALPHA
2558 #
2559 # N.B. PARAMETERS ARE SOMETIMES NOT UNIQUELY DEFINED BY THE FIRST 4
2560 # L-MOMENTS. IN SUCH CASES THE ROUTINE RETURNS THE SOLUTION FOR WHICH
2561 # THE H PARAMETER IS LARGEST.
2562
2563 # THE SHAPE PARAMETERS K AND H ARE ESTIMATED USING NEWTON-RAPHSON
2564 # ITERATION ON THE RELATIONSHIP BETWEEN (TAU-3,TAU-4) AND (K,H).
2565 # THE CONVERGENCE CRITERION IS THAT TAU-3 AND TAU-4 CALCULATED FROM
2566 # THE ESTIMATED VALUES OF K AND H SHOULD DIFFER BY LESS THAN 'EPS'
2567 # FROM THE VALUES SUPPLIED IN ARRAY XMOM.
2568
2569 #
2570 # EPS,MAXIT CONTROL THE TEST FOR CONVERGENCE OF N-R ITERATION
2571 # MAXSR IS THE MAX. NO. OF STEPLENGTH REDUCTIONS PER ITERATION
2572 # HSTART IS THE STARTING VALUE FOR H
2573 # BIG IS USED TO INITIALIZE THE CRITERION FUNCTION
2574 # OFLEXP IS SUCH THAT exp(OFLEXP) JUST DOES NOT CAUSE OVERFLOW
2575 # OFLGAM IS SUCH THAT exp(lgamma(OFLGAM)) JUST DOES NOT CAUSE
2576 # OVERFLOW
2577 #
2578 EPS <- 1e-6;
2579 MAXIT <- 20;
2580 MAXSR <- 10;
2581 HSTART <- 1.001;
2582 BIG <- 10;
2583 OFLEXP <- log(.Machine$double.xmax);
2584 OFLGAM <- uniroot(function(x) lgamma(x)-OFLEXP,c(1,OFLEXP))$root;
2585
2586 T3 <- lmom$TAU3
2587 T4 <- lmom$TAU4
2588
2589 if(! are.lmom.valid(lmom)) {
2590 warning("L-moments are invalid.")
2591 IFAIL <- 1
2592 return()
2593 }
2594 if(T4 >= (5*T3*T3+1)/6 ) {
2595 IFAIL <- 2
2596 return(list(type = 'kap', para = para, ifail = IFAIL,
2597 ifailtext = "TAU3 and TAU4 are above Generalized Logistic line."))
2598 }
2599 #
2600 # SET STARTING VALUES FOR N-R ITERATION:
2601 # G IS CHOSEN TO GIVE THE CORRECT VALUE OF TAU-3 ON THE
2602 # ASSUMPTION THAT H=1 (I.E. A GENERALIZED PARETO FIT) -
2603 # BUT H IS ACTUALLY SET TO 1.001 TO AVOID NUMERICAL
2604 # DIFFICULTIES WHICH CAN SOMETIMES ARISE WHEN H=1 EXACTLY
2605 #
2606 G <- (1-3*T3)/(1+T3)
2607 H <- HSTART
2608 Z <- G+H*0.725
2609 XDIST <- BIG
2610 #
2611 # START OF NEWTON-RAPHSON ITERATION
2612 #
2613 MAXITLOOPEND <- FALSE
2614 for(IT in seq(1,MAXIT)) {
2615 #
2616 # REDUCE STEPLENGTH UNTIL WE ARE NEARER TO THE REQUIRED
2617 # VALUES OF TAU-3 AND TAU-4 THAN WE WERE AT THE PREVIOUS STEP
2618 #
2619 MAXSRLOOPEND <- FALSE
2620 for(I in seq(1,MAXSR)) {
2621 #
2622 # CALCULATE CURRENT TAU-3 AND TAU-4
2623 #
2624 # NOTATION:
2625 # U. - RATIOS OF GAMMA FUNCTIONS WHICH OCCUR IN THE PWM'S
2626 # BETA-SUB-R
2627 # ALAM. - L-MOMENTS (APART FROM A LOCATION AND SCALE SHIFT)
2628 # TAU. - L-MOMENT RATIOS
2629 #
2630 if(G > OFLGAM) {
2631 IFAIL <- 5
2632 return(list(type = 'kap', para = para, ifail = IFAIL,,
2633 ifailtext = "H/K iteration encountered numerical difficulties."))
2634 }
2635 if(H > 0) {
2636 U1 <- exp(lgamma(1/H)-lgamma(1/H+1+G))
2637 U2 <- exp(lgamma(2/H)-lgamma(2/H+1+G))
2638 U3 <- exp(lgamma(3/H)-lgamma(3/H+1+G))
2639 U4 <- exp(lgamma(4/H)-lgamma(4/H+1+G))
2640 }
2641 else {
2642 U1 <- exp(lgamma(-1/H-G)-lgamma(-1/H+1))
2643 U2 <- exp(lgamma(-2/H-G)-lgamma(-2/H+1))
2644 U3 <- exp(lgamma(-3/H-G)-lgamma(-3/H+1))
2645 U4 <- exp(lgamma(-4/H-G)-lgamma(-4/H+1))
2646 }
2647 ALAM2 <- U1- 2*U2
2648 ALAM3 <- -U1+ 6*U2 -6*U3
2649 ALAM4 <- U1-12*U2+30*U3-20*U4
2650 if(ALAM2 == 0) {
2651 IFAIL <- 5
2652 return(list(type = 'kap', para = para, ifail = IFAIL,
2653 ifailtext = "H/K iteration encountered numerical difficulties."))
2654 }
2655 TAU3 <- ALAM3/ALAM2
2656 TAU4 <- ALAM4/ALAM2
2657 E1 <- TAU3-T3
2658 E2 <- TAU4-T4
2659 DIST <- max(abs(E1),abs(E2))
2660 if(DIST >= XDIST) {
2661 #
2662 # HALVE THE STEPLENGTH AND TRY AGAIN
2663 #
2664 DEL1 <- 0.5*DEL1
2665 DEL2 <- 0.5*DEL2
2666 G <- XG-DEL1
2667 H <- XH-DEL2
2668 }
2669 else {
2670 # IF NEARER THAN BEFORE, EXIT MAXSR LOOP
2671 break
2672 }
2673 if(I == MAXSR) MAXSRLOOPEND <- TRUE
2674 } # END OF MAXSR LOOP
2675 if(MAXSRLOOPEND == TRUE) {
2676 #
2677 # TOO MANY STEPLENGTH REDUCTIONS
2678 #
2679 IFAIL <- 4
2680 return(list(type = 'kap', para = para, ifail = IFAIL,
2681 ifailtext = "Unable to make progress from current point in H/K iteration."))
2682 }
2683 #
2684 # TEST FOR CONVERGENCE
2685 #
2686 if(DIST >= EPS) {
2687 #
2688 # NOT CONVERGED: CALCULATE NEXT STEP
2689 #
2690 # NOTATION:
2691 # U1G - DERIVATIVE OF U1 W.R.T. G
2692 # DL2G - DERIVATIVE OF ALAM2 W.R.T. G
2693 # D.. - MATRIX OF DERIVATIVES OF TAU-3 AND TAU-4 W.R.T. G AND H
2694 # H.. - INVERSE OF DERIVATIVE MATRIX
2695 # DEL. - STEPLENGTH
2696 #
2697 XG <- G
2698 XH <- H
2699 XZ <- Z
2700 XDIST <- DIST
2701 RHH <- 1/(H*H)
2702 if(H > 0) {
2703 U1G <- -U1*digamma(1/H+1+G)
2704 U2G <- -U2*digamma(2/H+1+G)
2705 U3G <- -U3*digamma(3/H+1+G)
2706 U4G <- -U4*digamma(4/H+1+G)
2707 U1H <- RHH*(-U1G-U1*digamma(1/H))
2708 U2H <- 2*RHH*(-U2G-U2*digamma(2/H))
2709 U3H <- 3*RHH*(-U3G-U3*digamma(3/H))
2710 U4H <- 4*RHH*(-U4G-U4*digamma(4/H))
2711 }
2712 else {
2713 U1G <- -U1*digamma(-1/H-G)
2714 U2G <- -U2*digamma(-2/H-G)
2715 U3G <- -U3*digamma(-3/H-G)
2716 U4G <- -U4*digamma(-4/H-G)
2717 U1H <- RHH*(-U1G-U1*digamma(-1/H+1))
2718 U2H <- 2*RHH*(-U2G-U2*digamma(-2/H+1))
2719 U3H <- 3*RHH*(-U3G-U3*digamma(-3/H+1))
2720 U4H <- 4*RHH*(-U4G-U4*digamma(-4/H+1))
2721 }
2722 DL2G <- U1G-2*U2G
2723 DL2H <- U1H-2*U2H
2724 DL3G <- -U1G+6*U2G-6*U3G
2725 DL3H <- -U1H+6*U2H-6*U3H
2726 DL4G <- U1G-12*U2G+30*U3G-20*U4G
2727 DL4H <- U1H-12*U2H+30*U3H-20*U4H
2728 D11 <- (DL3G-TAU3*DL2G)/ALAM2
2729 D12 <- (DL3H-TAU3*DL2H)/ALAM2
2730 D21 <- (DL4G-TAU4*DL2G)/ALAM2
2731 D22 <- (DL4H-TAU4*DL2H)/ALAM2
2732 DET <- D11*D22-D12*D21
2733 H11 <- D22/DET
2734 H12 <- -D12/DET
2735 H21 <- -D21/DET
2736 H22 <- D11/DET
2737 DEL1 <- E1*H11+E2*H12
2738 DEL2 <- E1*H21+E2*H22
2739 #
2740 # TAKE NEXT N-R STEP
2741 #
2742 G <- XG-DEL1
2743 H <- XH-DEL2
2744 Z <- G+H*0.725
2745 #
2746 # REDUCE STEP IF G AND H ARE OUTSIDE THE PARAMETER SPACE
2747 #
2748 FACTOR <- 1
2749 if(G <= -1) FACTOR <- 0.8*(XG+1)/DEL1
2750 if(H <= -1) FACTOR <- min(FACTOR,0.8*(XH+1)/DEL2)
2751 if(Z <= -1) FACTOR <- min(FACTOR,0.8*(XZ+1)/(XZ-Z))
2752 if(H <= 0 & G*H <= -1) {
2753 FACTOR <- min(FACTOR,0.8*(XG*XH+1)/(XG*XH-G*H))
2754 }
2755 if(FACTOR != 1) {
2756 DEL1 <- DEL1*FACTOR
2757 DEL2 <- DEL2*FACTOR
2758 G <- XG-DEL1
2759 H <- XH-DEL2
2760 Z <- G+H*0.725
2761 }
2762 if(IT == MAXIT) MAXITLOOPEND <- TRUE
2763 next;
2764 }
2765 break;
2766 #
2767 # END OF NEWTON-RAPHSON ITERATION
2768 #
2769 }
2770 #
2771 # NOT CONVERGED
2772 #
2773 if(MAXITLOOPEND == TRUE) {
2774 IFAIL <- 3
2775 return(list(type = 'kap', para = para, ifail = IFAIL,
2776 ifailtext = "Iteration on H and K failed to converge."))
2777 }
2778 #
2779 # CONVERGED
2780 #
2781 IFAIL <- 0
2782 para[4] <- H
2783 para[3] <- G
2784 TEMP <- lgamma(1+G)
2785 if(TEMP > OFLEXP) {
2786 IFAIL <- 6
2787 return(list(type = 'kap', para = para, ifail = IFAIL,
2788 ifailtext = "H and K converged, but overflow on XI and ALPHA."))
2789 }
2790 GAM <- exp(TEMP)
2791 TEMP <- (1+G)*log(abs(H))
2792 if(TEMP > OFLEXP) {
2793 IFAIL <- 6
2794 return(list(type = 'kap', para = para, ifail = IFAIL,
2795 ifailtext = "H and K converged, but overflow on XI and ALPHA."))
2796 }
2797 HH <- exp(TEMP)
2798 para[2] <- lmom$L2*G*HH/(ALAM2*GAM)
2799 para[1] <- lmom$L1-para[2]/G*(1-GAM*U1/HH)
2800 return(list(type = 'kap', para = para, ifail = IFAIL,
2801 ifailtext = "Successful parameter estimation."))
2802 }
2803
2804 "parnor" <-
2805 function(lmom) {
2806 para <- matrix(nrow = 2, ncol = 1)
2807 if(! are.lmom.valid(lmom)) {
2808 warning("L-moments are invalid.")
2809 return()
2810 }
2811 para[1] <- lmom$L1
2812 para[2] <- lmom$L2*sqrt(pi)
2813 return(list(type = 'nor', para=para))
2814 }
2815
2816 "parpe3" <-
2817 function(lmom) {
2818 para <- matrix(nrow = 3, ncol = 1)
2819
2820 # METHOD: RATIONAL APPROXIMATION IS USED TO EXPRESS ALPHA, THE SHAPE
2821 # PARAMETER OF THE GAMMA DISTRIBUTION, AS A FUNCTION OF TAU-3.
2822 # RELATIVE ACCURACY OF THE APPROXIMATION IS BETTER THAN 3E-5.
2823
2824 # SMALL IS USED TO TEST WHETHER SKEWNESS IS EFFECTIVELY ZERO
2825 SMALL <- 1e-6
2826
2827 # CONSTANTS USED IN MINIMAX APPROXIMATIONS
2828 C1 <- 0.2906
2829 C2 <- 0.1882
2830 C3 <- 0.0442
2831 D1 <- 0.36067
2832 D2 <- -0.59567
2833 D3 <- 0.25361
2834 D4 <- -2.78861
2835 D5 <- 2.56096
2836 D6 <- -0.77045
2837 PI3 <- 3*pi
2838 ROOTPI <- sqrt(pi)
2839
2840 if(! are.lmom.valid(lmom)) {
2841 warning("L-moments are invalid.")
2842 return()
2843 }
2844
2845 L1 <- lmom$L1
2846 L2 <- lmom$L2
2847 T3 <- abs(lmom$TAU3)
2848 if(T3 <= SMALL) {
2849 # ZERO SKEWNESS
2850 para[1] <- L1
2851 para[2] <- L2*ROOTPI
2852 para[3] <- 0
2853 return(list(type = 'pe3', para = para))
2854 }
2855 if(T3 >= 1/3) {
2856 T <- 1-T3
2857 ALPHA <- T*(D1+T*(D2+T*D3))/(1+T*(D4+T*(D5+T*D6)))
2858 }
2859 else {
2860 T <- PI3*T3^2
2861 ALPHA=(1+C1*T)/(T*(1+T*(C2+T*C3)))
2862 }
2863 RTALPH <- sqrt(ALPHA)
2864 BETA <- ROOTPI*L2*exp(lgamma(ALPHA)-lgamma(ALPHA+0.5))
2865 para[1] <- L1
2866 para[2] <- BETA*RTALPH
2867 para[3] <- 2/RTALPH
2868 if(T3 < 0) para[3] <- -para[3]
2869 return(list(type = 'pe3', para = para))
2870 }
2871
2872 "parwak" <-
2873 function(lmom) {
2874 # PARA *OUTPUT* ARRAY OF LENGTH 5. ON EXIT, CONTAINS THE PARAMETERS
2875 # IN THE ORDER XI, ALPHA, BETA, GAMMA, DELTA.
2876 # IFAIL *OUTPUT* FAIL FLAG. ON EXIT, IT IS SET AS FOLLOWS.
2877 # 0 SUCCESSFUL EXIT
2878 # 1 ESTIMATES COULD ONLY BE OBTAINED BY SETTING XI=0
2879 # 2 ESTIMATES COULD ONLY BE OBTAINED BY FITTING A
2880 # GENERALIZED PARETO DISTRIBUTION
2881 # 3 L-MOMENTS INVALID
2882 #
2883 # PROCEDURE:
2884 # 1. LOOK FOR A SOLUTION WITH XI UNCONSTRAINED;
2885 # 2. IF NONE FOUND, LOOK FOR A SOLUTION WITH XI=0;
2886 # 3. IF NONE FOUND, FIT A GENERALIZED PARETO DISTRIBUTION TO THE
2887 # FIRST 3 L-MOMENTS.
2888 # ESTIMATES ARE CALCULATED USING THE FORMULAS GIVEN BY GREENWOOD ET AL.
2889 # (1979, WATER RESOUR. RES., TABLE 5), BUT EXPRESSED IN TERMS OF
2890 # L-MOMENTS RATHER THAN PROBABILITY WEIGHTED MOMENTS.
2891
2892
2893
2894 # Hosking's GOTO 20 in the Wakeby Parameter Estimation
2895 wak.gpa_instead <- function(ALAM1,ALAM2,T3) {
2896 para <- matrix(nrow = 5, ncol = 1)
2897 #
2898 # CAN'T FIND VALID ESTIMATES EVEN WITH XI=0 -
2899 # FIT GENERALIZED PARETO DISTRIBUTION INSTEAD
2900 #
2901 IFAIL <- 2
2902 D <- -(1-3*T3)/(1+T3)
2903 C <- (1-D)*(2-D)*ALAM2
2904 B <- 0
2905 A <- 0
2906 XI <- ALAM1-C/(1-D)
2907 para[1] <- XI
2908 if(D > 0) {
2909 para[2] <- A
2910 para[3] <- B
2911 para[4] <- C
2912 para[5] <- D
2913 }
2914 else {
2915 A <- C
2916 B <- -D
2917 C <- 0
2918 D <- 0
2919 para[2] <- A
2920 para[3] <- B
2921 para[4] <- C
2922 para[5] <- D
2923 }
2924 return(list(type = 'wak', para = para, ifail = 2,
2925 ifailtext = "Solution possible by fitting Generalized Pareto instead."))
2926 }
2927
2928
2929
2930 para <- matrix(nrow = 5, ncol = 1)
2931
2932 ALAM1 <- lmom$L1
2933 ALAM2 <- lmom$L2
2934 ALAM3 <- lmom$L3
2935 ALAM4 <- lmom$L4
2936 ALAM5 <- lmom$L5
2937
2938 T3 <- lmom$TAU3
2939 T4 <- lmom$TAU4
2940 T5 <- lmom$TAU5
2941
2942 if(! are.lmom.valid(lmom)) {
2943 warning("L-moments are invalid.")
2944 IFAIL <- 3
2945 return()
2946 }
2947
2948 IFAIL <- 0
2949 #
2950 # ESTIMATE N1,N2,N3,C1,C2,C3 WHEN XI.NE.0
2951 #
2952 N1 <- 3*ALAM2 - 25*ALAM3 + 32*ALAM4
2953 N2 <- -3*ALAM2 + 5*ALAM3 + 8*ALAM4
2954 N3 <- 3*ALAM2 + 5*ALAM3 + 2*ALAM4
2955 C1 <- 7*ALAM2 - 85*ALAM3 + 203*ALAM4 -125 * ALAM5
2956 C2 <- -7*ALAM2 + 25*ALAM3 + 7*ALAM4 -25 * ALAM5
2957 C3 <- 7*ALAM2 + 5*ALAM3 - 7*ALAM4 -5 * ALAM5
2958 #
2959 # ESTIMATE B AND D
2960 #
2961 A <- N2*C3 - C2*N3
2962 B <- N1*C3 - C1*N3
2963 C <- N1*C2 - C1*N2
2964 DISC <- B*B - 4*A*C
2965 if(DISC >= 0) { # if DISC is greater then we can root it
2966 #warning("X=unknown, looking for dual roots.")
2967 DISC <- sqrt(DISC)
2968 ROOT1 <- 0.5*(-B+DISC)/A # the two roots to the quadratic
2969 ROOT2 <- 0.5*(-B-DISC)/A
2970 B <- max(ROOT1,ROOT2)
2971 D <- -min(ROOT1,ROOT2)
2972 if(D < 1) {
2973 #warning("X=unknown, D is Wakeby consistent")
2974 #
2975 # ESTIMATE A, C AND XI
2976 #
2977 A <- (1+B)*(2+B)*(3+B) / (4*(B+D))*((1+D)*ALAM2-(3-D)*ALAM3)
2978 C <- -(1-D)*(2-D)*(3-D) / (4*(B+D))*((1-B)*ALAM2-(3+B)*ALAM3)
2979 XI <- ALAM1 - A/(1+B) - C/(1-D)
2980 if(C >= 0 & A+C >= 0) {
2981 #warning("X=unknown, other parameters are Wakeby consistent.")
2982 para[1] <- XI
2983 para[2] <- A
2984 para[3] <- B
2985 para[4] <- C
2986 para[5] <- D
2987 return(list(type = 'wak', para = para, ifail = IFAIL,
2988 ifailtext = "Successful parameter estimation."))
2989 }
2990 }
2991 }
2992 #
2993 # CAN'T FIND VALID ESTIMATES FOR XI UNRESTRICTED, SO TRY XI=0
2994 #
2995 # ESTIMATE B AND D FOR XI=0
2996 #
2997 IFAIL <- 1
2998 XI <- 0
2999 N1 <- 4*ALAM1 - 11*ALAM2 + 9*ALAM3
3000 N2 <- -ALAM2 + 3*ALAM3
3001 N3 <- ALAM2 + ALAM3
3002 C1 <- 10*ALAM1 - 29*ALAM2 + 35*ALAM3 - 16*ALAM4
3003 C2 <- -ALAM2 + 5*ALAM3 - 4*ALAM4
3004 C3 <- ALAM2 - ALAM4
3005 A <- N2*C3 - C2*N3
3006 B <- N1*C3 - C1*N3
3007 C <- N1*C2 - C1*N2
3008 DISC <- B*B - 4*A*C
3009
3010 if(DISC >= 0 ) {
3011 #warning("X=0, looking for dual roots.")
3012 DISC <- sqrt(DISC)
3013 ROOT1 <- 0.5*(-B+DISC)/A
3014 ROOT2 <- 0.5*(-B-DISC)/A
3015 B <- max(ROOT1,ROOT2)
3016 D <- -min(ROOT1,ROOT2)
3017 if(D < 1) {
3018 #warning("X=0, D is Wakeby consistent.")
3019 A <- (1+B)*(2+B) / (B+D)*(ALAM1 - (2-D)*ALAM2)
3020 C <- -(1-D)*(2-D) / (B+D)*(ALAM1 - (2+B)*ALAM2)
3021 if(C >= 0 & A+C >= 0) {
3022 #warning("X=0, other parameters are Wakeby consistent.")
3023 para[1] <- XI
3024 para[2] <- A
3025 para[3] <- B
3026 para[4] <- C
3027 para[5] <- D
3028 return(list(type = 'wak', para = para, ifail = IFAIL,
3029 ifailtext = "Solution possible only with XI=0."))
3030 }
3031 }
3032 }
3033 # give up and return generalized pareto instead
3034 return(wak.gpa_instead(ALAM1,ALAM2,T3))
3035 }
3036
3037 "plotlmrdia" <-
3038 function(lmr,
3039 nopoints=FALSE,
3040 nolines=FALSE,
3041 nolimits=FALSE,
3042 nogev=FALSE,
3043 noglo=FALSE,
3044 nogpa=FALSE,
3045 nope3=FALSE,
3046 nogno=FALSE,
3047 noexp=FALSE,
3048 nonor=FALSE,
3049 nogum=FALSE,
3050 nouni=FALSE, ...) {
3051 plot(lmr$limits, xlab = "L-SKEW", ylab = "L-KURTOSIS", type = "n",
3052 ...)
3053 if(nolimits == FALSE) {
3054 lines(lmr$limits,lwd=2,col=8)
3055 }
3056 if(nolines == FALSE) {
3057 if(nogev == FALSE) lines(lmr$gev, col=2,lty=2)
3058 if(noglo == FALSE) lines(lmr$glo, col=3)
3059 if(nogno == FALSE) lines(lmr$gno, col=4, lty=2)
3060 if(nogpa == FALSE) lines(lmr$gpa, col=4)
3061 if(nope3 == FALSE) lines(lmr$pe3, col=6)
3062 }
3063 if(nopoints == FALSE) {
3064 if(noexp == FALSE) points(lmr$exp,pch=16,col=2)
3065 if(nonor == FALSE) points(lmr$nor,pch=15,col=2)
3066 if(nogum == FALSE) points(lmr$gum,pch=17,col=2)
3067 if(nouni == FALSE) points(lmr$uniform,pch=18,cex=1.5,col=2)
3068 }
3069 }
3070
3071 "pwm.gev" <-
3072 function(x) { return(pwm.pp(x,A=-0.35,B=0)) }
3073
3074 "pwm.pp" <-
3075 function(x,A,B) {
3076 N <- length(x)
3077 # FOR UNBIASED ESTIMATES SET A AND B EQUAL TO ZERO. OTHERWISE,
3078 # PLOTTING-POSITION ESTIMATORS ARE USED, BASED ON THE PLOTTING POSITION
3079 # (J+A)/(N+B) FOR THE J'TH SMALLEST OF N OBSERVATIONS. FOR EXAMPLE,
3080 # A=-0.35D0 AND B=0.0D0 YIELDS THE ESTIMATORS RECOMMENDED BY
3081 # HOSKING ET AL. (1985, TECHNOMETRICS) FOR THE GEV DISTRIBUTION.
3082 #
3083 PWM <- matrix(nrow = 5, ncol = 1)
3084 for(j in seq(1,5)) PWM[j] <- 0
3085
3086 if(A == 0 & B == 0) {
3087 # UNBIASED ESTIMATES OF PWM'S
3088 for(i in seq(1,N)) {
3089 WEIGHT <- 1/N
3090 PWM[1] <- PWM[1] + WEIGHT*x[i]
3091 for(j in seq(2,5)) {
3092 jm <- j-1
3093 WEIGHT <- WEIGHT*(i-jm)/(N-jm)
3094 PWM[j] <- PWM[j]+WEIGHT*x[i]
3095 }
3096 }
3097 z <- list(BETA0 = PWM[1], BETA1 = PWM[2], BETA2 = PWM[3],
3098 BETA3 = PWM[4], BETA4 = PWM[5])
3099 return(z)
3100 }
3101 if(A <= -1 | A >= B) {
3102 warning("Plotting position parameters are invalid.")
3103 return()
3104 }
3105 #
3106 # PLOTTING-POSITION ESTIMATES OF PWM'S
3107 #
3108 for(i in seq(1,N)) {
3109 PPOS <- (i+A)/(N+B)
3110 TERM <- x[i]
3111 PWM[1] <- PWM[1]+TERM
3112 for(j in seq(2,5)) {
3113 TERM <- TERM*PPOS
3114 PWM[j] <- PWM[j]+TERM
3115 }
3116 }
3117 for(j in seq(1,5)) PWM[j] <- PWM[j]/N
3118 z <- list(BETA0 = PWM[1], BETA1 = PWM[2], BETA2 = PWM[3],
3119 BETA3 = PWM[4], BETA4 = PWM[5])
3120 return(z)
3121 }
3122
3123 "pwm.ub" <-
3124 function(x) { return(pwm.pp(x,A=0,B=0)) }
3125
3126 "pwm2lmom" <-
3127 function(pwm) {
3128 z <- list(L1 = NULL,
3129 L2 = NULL,
3130 TAU3 = NULL,
3131 TAU4 = NULL,
3132 TAU5 = NULL,
3133 LCV = NULL,
3134 L3 = NULL,
3135 L4 = NULL,
3136 L5 = NULL
3137 )
3138 z$L1 <- pwm$BETA0
3139 z$L2 <- 2*pwm$BETA1 - pwm$BETA0
3140 z$L3 <- 6*pwm$BETA2 - 6*pwm$BETA1 + pwm$BETA0
3141 z$L4 <- 20*pwm$BETA3 - 30*pwm$BETA2 + 12*pwm$BETA1 - pwm$BETA0
3142 z$L5 <- 70*pwm$BETA4 - 140*pwm$BETA3 + 90*pwm$BETA2 - 20*pwm$BETA1 +
3143 pwm$BETA0
3144 z$LCV <- z$L2/z$L1
3145 z$TAU3 <- z$L3/z$L2
3146 z$TAU4 <- z$L4/z$L2
3147 z$TAU5 <- z$L5/z$L2
3148 return(z)
3149 }
3150
3151 "quacau" <-
3152 function(f,para) {
3153
3154 if(! are.parcau.valid(para)) return()
3155
3156 U <- para$para[1]
3157 A <- para$para[2]
3158
3159 if(f == 1) return(Inf)
3160 if(f == 0) return(-Inf)
3161
3162 if(f == 0.5) return(U)
3163 return(U + A*tan(pi*(f-0.5)))
3164 }
3165
3166 "quaexp" <-
3167 function(f,para) {
3168 if(! are.parexp.valid(para)) return()
3169 U <- para$para[1]
3170 A <- para$para[2]
3171 if(f <= 0 || f >= 1) {
3172 warning("Nonexceedance probability is invalid")
3173 return()
3174 }
3175 return(U-A*log(1-f))
3176 }
3177
3178 "quagam" <-
3179 function(f,para) {
3180 if(! are.pargam.valid(para)) return()
3181 ALPHA <- para$para[1]
3182 BETA <- para$para[2]
3183 if(f <= 0 || f >= 1) {
3184 warning("argument of function is invalid")
3185 return()
3186 }
3187 if(f == 0) return(0)
3188 return(qgamma(f,ALPHA,scale=BETA))
3189 }
3190
3191 "quagev" <-
3192 function(f,para) {
3193 if(! are.pargev.valid(para)) return()
3194 XI <- para$para[1]
3195 A <- para$para[2]
3196 K <- para$para[3]
3197 if(f <= 0 || f >= 1) {
3198 if(f == 0 & K < 0) return(XI+A/K)
3199 if(f == 1 & K > 0) return(XI+A/K)
3200 warning("argument of function is invalid")
3201 return()
3202 }
3203 Y <- -log(-log(f))
3204 if(K != 0) Y <- (1-exp(-K*Y))/K
3205 return(XI+A*Y)
3206 }
3207
3208 "quagld" <-
3209 function(f,gldpara) {
3210
3211 if(! are.pargld.valid(gldpara)) return()
3212
3213 La1 <- gldpara$para[1]
3214 La2 <- gldpara$para[2]
3215 La3 <- gldpara$para[3]
3216 La4 <- gldpara$para[4]
3217 tmp <- 1/La2
3218
3219 if(f <= 0 || f >= 1) {
3220 if(f == 0) return(La1-tmp)
3221 if(f == 1) return(La1+tmp)
3222 }
3223 return(La1 + tmp*(f**La3 - (1-f)**La4))
3224 }
3225
3226 "quaglo" <-
3227 function(f,para) {
3228 if(! are.parglo.valid(para)) return()
3229 XI <- para$para[1]
3230 A <- para$para[2]
3231 K <- para$para[3]
3232 if(f <= 0 || f >= 1) {
3233 if(f == 0 & K < 0) return(XI+A/K)
3234 if(f == 1 & K > 0) return(XI+A/K)
3235 warning("argument of function is invalid")
3236 return()
3237 }
3238 Y <- log(f/(1-f))
3239 if(K != 0) Y <- (1-exp(-K*Y))/K
3240 return(XI+A*Y)
3241 }
3242
3243 "quagno" <-
3244 function(f,para) {
3245 if(! are.pargno.valid(para)) return()
3246 XI <- para$para[1]
3247 A <- para$para[2]
3248 K <- para$para[3]
3249 if(f <= 0 || f >= 1) {
3250 if(f == 0 & K < 0) return(XI+A/K)
3251 if(f == 1 & K > 0) return(XI+A/K)
3252 warning("argument of function is invalid")
3253 return()
3254 }
3255 Y <- qnorm(f)
3256 if(K != 0) Y <- (1-exp(-K*Y))/K
3257 return(XI+A*Y)
3258 }
3259
3260 "quagpa" <-
3261 function(f,para) {
3262 if(! are.pargpa.valid(para)) return()
3263 XI <- para$para[1]
3264 A <- para$para[2]
3265 K <- para$para[3]
3266 if(f <= 0 || f >= 1) {
3267 if(f == 0) return(XI)
3268 if(f == 1 & K > 0) return(XI+A/K)
3269 warning("argument of function is invalid")
3270 return()
3271 }
3272 Y <- -log(1-f)
3273 if(K != 0) {
3274 Y=(1-exp(-K*Y))/K
3275 return(XI+A*Y)
3276 }
3277 }
3278
3279 "quagum" <-
3280 function(f,para) {
3281 if(! are.pargum.valid(para)) return()
3282 U <- para$para[1]
3283 A <- para$para[2]
3284 if(f <= 0 || f >= 1) {
3285 warning("nonexceedance probability value invalid")
3286 return()
3287 }
3288 return(U-A*log(-log(f)))
3289 }
3290
3291 "quakap" <-
3292 function(f,para) {
3293 if(! are.parkap.valid(para)) return()
3294
3295 U <- para$para[1]
3296 A <- para$para[2]
3297 G <- para$para[3]
3298 H <- para$para[4]
3299 if(f <= 0 || f >= 1) {
3300 if(f == 0) {
3301 if(H <= 0 & G < 0) return(U+A/G)
3302 if(H > 0 & G != 0) return(U+A/G*(1-H^-G))
3303 if(H > 0 & G == 0) return(U+A*log(H))
3304 if(H <= 0 & G >= 0) {
3305 warning("argument to function invalid.")
3306 return()
3307 }
3308 stop("f is fine: should not be here in code execution.")
3309 }
3310 if(f == 1) {
3311 if(G <= 0) {
3312 warning("argument of function is invalid")
3313 return()
3314 }
3315 else {
3316 return(U+A/G)
3317 }
3318 stop("f=1: should not be here in code execution.")
3319 }
3320 }
3321 else {
3322 Y <- -log(f)
3323 if(H != 0) Y <- (1-exp(-H*Y))/H
3324 Y <- -log(Y)
3325 if(G != 0) Y <- (1-exp(-G*Y))/G
3326 return(U+A*Y)
3327 }
3328 }
3329
3330 "quanor" <-
3331 function(f,para) {
3332 if(! are.parnor.valid(para)) return()
3333 return(qnorm(f,mean = para$para[1], sd = para$para[2]))
3334 }
3335
3336 "quape3" <-
3337 function(f,para) {
3338 if(! are.parpe3.valid(para)) return()
3339
3340 # SMALL IS USED TO TEST WHETHER SKEWNESS IS EFFECTIVELY ZERO
3341 SMALL <- 1e-6
3342
3343 U <- para$para[1]
3344 A <- para$para[2]
3345 GAMMA <- para$para[3]
3346 if(f <= 0 || f >= 1) {
3347 if((f == 0 & GAMMA > 0) |
3348 (f == 1 & GAMMA < 0)) {
3349 U-2*A/GAMMA
3350 }
3351 else {
3352 warning("Argument to function invalid")
3353 return()
3354 }
3355 }
3356 if(abs(GAMMA) < SMALL) {
3357 # ZERO SKEWNESS, qnorm() is the standard normal distribution
3358 return(U+A*qnorm(f))
3359 }
3360 else {
3361 ALPHA <- 4/GAMMA^2
3362 BETA <- abs(0.5*A*GAMMA)
3363 if(GAMMA > 0) {
3364 return(U-ALPHA*BETA+qgamma(f,ALPHA,scale=BETA))
3365 }
3366 else {
3367 return(U+ALPHA*BETA-qgamma(1-f,ALPHA,scale=BETA))
3368 }
3369 }
3370 }
3371
3372 "quawak" <-
3373 function(f,wakpara) {
3374 #
3375 # UFL SHOULD BE CHOSEN SO THAT EXP(UFL) JUST DOES NOT CAUSE
3376 # UNDERFLOW
3377 #
3378 UFL <- log(.Machine$double.xmin);
3379
3380 if(! are.parwak.valid(wakpara)) return()
3381
3382 XI <- wakpara$para[1]
3383 A <- wakpara$para[2]
3384 B <- wakpara$para[3]
3385 C <- wakpara$para[4]
3386 D <- wakpara$para[5]
3387
3388 if(f <= 0 || f >= 1) {
3389 if(f == 0) return(XI)
3390 if(f == 1) {
3391 if(D < 0) return(XI+A/B-C/D)
3392 if(D == 0 & C == 0 & B > 0) return(XI+A/B)
3393 warning("argument of function is invalid")
3394 return()
3395 }
3396 }
3397 Z <- -log(1-f)
3398 Y1 <- Z
3399 if(B == 0) {
3400 Y2 <- Z
3401 if(D != 0) Y2 <- (1-exp(D*Y2))/(-D)
3402 return(XI+A*Y1+C*Y2)
3403 }
3404 else {
3405 TEMP <- -B*Z
3406 if(TEMP < UFL) Y1 <- 1/B
3407 if(TEMP >= UFL) Y1 <- (1-exp(TEMP))/B
3408 Y2 <- Z
3409 if(D != 0) Y2 <- (1-exp(D*Y2))/(-D)
3410 return(XI+A*Y1+C*Y2)
3411 }
3412 }
3413
3414 "vec2lmom" <-
3415 function(vec,lscale=TRUE) {
3416 z <- list(L1 = NULL,
3417 L2 = NULL,
3418 TAU3 = NULL,
3419 TAU4 = NULL,
3420 TAU5 = NULL,
3421 LCV = NULL,
3422 L3 = NULL,
3423 L4 = NULL,
3424 L5 = NULL
3425 )
3426 z$L1 <- vec[1]
3427 if(lscale == TRUE) {
3428 z$L2 <- vec[2]
3429 z$TAU3 <- vec[3]
3430 z$TAU4 <- vec[4]
3431 z$TAU5 <- vec[5]
3432
3433 z$LCV <- z$L2/z$L1
3434 z$L3 <- z$TAU3*z$L2
3435 z$L4 <- z$TAU4*z$L2
3436 z$L5 <- z$TAU5*z$L2
3437 }
3438 else {
3439 z$LCV <- vec[2]
3440 z$TAU3 <- vec[3]
3441 z$TAU4 <- vec[4]
3442 z$TAU5 <- vec[5]
3443
3444 z$L2 <- z$LCV*z$L1
3445 z$L3 <- z$TAU3*z$L2
3446 z$L4 <- z$TAU4*z$L2
3447 z$L5 <- z$TAU5*z$L2
3448 }
3449 return(z)
3450 }
3451
3452 "vec2par" <-
3453 function(vec,type) {
3454 if(type == 'cau') {
3455 para <- matrix(nrow = 2, ncol = 1)
3456 para[,1] <- vec
3457 z <- list(type = 'cau', para = para)
3458 }
3459 else if(type == 'exp') {
3460 para <- matrix(nrow = 2, ncol = 1)
3461 para[,1] <- vec
3462 z <- list(type = 'exp', para = para)
3463 }
3464 else if(type == 'gam') {
3465 para <- matrix(nrow = 2, ncol = 1)
3466 para[,1] <- vec
3467 z <- list(type = 'gam', para = para)
3468 }
3469 else if(type == 'gev') {
3470 para <- matrix(nrow = 3, ncol = 1)
3471 para[,1] <- vec
3472 z <- list(type = 'gev', para = para)
3473 }
3474 else if(type == 'gld') {
3475 para <- matrix(nrow = 4, ncol = 1)
3476 para[,1] <- vec
3477 z <- list(type = 'gld', para = para)
3478 }
3479 else if(type == 'glo') {
3480 para <- matrix(nrow = 3, ncol = 1)
3481 para[,1] <- vec
3482 z <- list(type = 'glo', para = para)
3483 }
3484 else if(type == 'gno') {
3485 para <- matrix(nrow = 3, ncol = 1)
3486 para[,1] <- vec
3487 z <- list(type = 'gno', para = para)
3488 }
3489 else if(type == 'gpa') {
3490 para <- matrix(nrow = 3, ncol = 1)
3491 para[,1] <- vec
3492 z <- list(type = 'gpa', para = para)
3493 }
3494 else if(type == 'gum') {
3495 para <- matrix(nrow = 2, ncol = 1)
3496 para[,1] <- vec
3497 z <- list(type = 'gum', para = para)
3498 }
3499 else if(type == 'kap') {
3500 para <- matrix(nrow = 4, ncol = 1)
3501 para[,1] <- vec
3502 z <- list(type = 'kap', para = para)
3503 }
3504 else if(type == 'nor') {
3505 para <- matrix(nrow = 2, ncol = 1)
3506 para[,1] <- vec
3507 z <- list(type = 'nor', para = para)
3508 }
3509 else if(type == 'pe3') {
3510 para <- matrix(nrow = 3, ncol = 1)
3511 para[,1] <- vec
3512 z <- list(type = 'pe3', para = para)
3513 }
3514 else if(type == 'wak') {
3515 para <- matrix(nrow = 5, ncol = 1)
3516 para[,1] <- vec
3517 z <- list(type = 'wak', para = para)
3518 }
3519 else {
3520 stop("Did not find a valid distribution type.")
3521 }
3522 if(! are.par.valid(z)) {
3523 warning("The parameters are invalid for the distribution.")
3524 return()
3525 }
3526 return(z)
3527 }
3528
3529 "vec2pwm" <-
3530 function(vec) {
3531 z <- list(BETA0 = vec[1], BETA1 = vec[2], BETA2 = vec[3],
3532 BETA3 = vec[4], BETA4 = vec[5])
3533 return(z)
3534 }
3535
+277
-0
demo/xmpDWChapter051.R less more
0 #
1 # Examples from the Monograph:
2 # "Rmetrics - Financial Engineering and Computational Finance"
3 # written by Diethelm Wuertz
4 # ISBN to be published
5 #
6 # Details:
7 # Chapter 5.1
8 # Extreme Value Plots
9 #
10 # List of Examples, Exercises and Code Snippets:
11 #
12 # 5.1.1 Example: Quantile-Quantile Plot
13 # * Code Snipptet: qqPlot
14 # * Example: Create Figure 5.1.1 - DAX Data
15 # * Example: Create Figure 5.1.1 - BMW Data
16 # 5.1.2 Example: Mean Excess Function Plot - Create Figure 5.1.2
17 # * Example: Mean Residual Life Plot - Create Figure 5.1.3
18 #
19 # *** This list is not yet complete ***
20 #
21 # Author:
22 # (C) 2002-2004, Diethelm Wuertz, GPL
23 # www.rmetrics.org
24 # www.itp.phys.ethz.ch
25 # www.finance.ch
26 #
27
28
29 ################################################################################
30
31
32 ### Load Library:
33
34 # Load:
35 require(fExtremes)
36 ###
37
38
39 # ------------------------------------------------------------------------------
40
41
42 ### 5.1.1 Example: Quantile-Quantile Plot
43
44 # Load and Plot the Data
45 DAX.RET = as.timeSeries(data(dax.ret))
46 class(DAX.RET)
47 head(DAX.RET)
48 qqPlot(DAX.RET, pch = 19, col = "steelblue", cex = 0.7)
49 ###
50
51
52 # ------------------------------------------------------------------------------
53
54
55 ### Code Snipptet: qqPlot
56
57 # Quantile-Quantile Plot:
58 .qqPlot = function(x, ...)
59 {
60 x = as.vector(x)
61 qqnorm(x, ...)
62 qqline(x)
63 invisible()
64 }
65 .qqPlot(DAX.RET)
66 ###
67
68
69 # ------------------------------------------------------------------------------
70
71
72 ### Example: Create Figure 5.1.1 - DAX Data
73
74 # Graph Frame:
75 par(mfcol = c(2, 2), cex = 0.7)
76 ###
77
78 # Load and Plot the Data
79 DAX.RET = as.timeSeries(data(dax.ret))
80 plot(DAX.RET, main = "DAX Daily log Returns", ylab = "log Return")
81 qqPlot(DAX.RET)
82 ###
83
84
85 # ------------------------------------------------------------------------------
86
87
88 ### Example: Create Figure 5.1.1 - BMW Data
89
90 # Load and Plot the Data
91 BMW.RET = as.timeSeries(data(bmw.ret))
92 plot(BMW.RET, main = "BMW Daily log Returns", ylab = "log Return")
93 qqPlot(BMW.RET)
94 ###
95
96
97 # ------------------------------------------------------------------------------
98
99
100 ### 5.1.2 Example: Mean Excess Function Plot - Create Figure 5.1.2
101
102 # Graph Frame:
103 par(mfrow = c(2, 2), cex = 0.7)
104 ###
105
106 # Exponential Variates:
107 set.seed(4711)
108 mxfPlot(rexp(1000, rate = 2), tail = 0.20)
109 title(main = "\n\nExponential DF")
110 abline(0.5, 0)
111 ###
112
113 # Normal Variates:
114 set.seed(4711)
115 mxfPlot(rlnorm(1000, meanlog = 0, sdlog = 2), tail = 0.20)
116 title(main = "\n\nLognormal DF")
117 ###
118
119 # Symmetric Stable Variates:
120 set.seed(4711)
121 mxfPlot(rsymstb(1000, alpha = 1.7), tail = 0.20)
122 title(main = "\n\n1.7 stable DF")
123 abline(0, 0.7)
124 ###
125
126 # DAX log Returns:
127 mxfPlot(-100*DAX.RET, tail = 0.20)
128 title(main = "\n\nDAX log Returns %")
129 ###
130
131
132 # ------------------------------------------------------------------------------
133
134
135 ### Example: Mean Residual Life Plot - Create Figure 5.1.3
136
137
138 # Graph Frame:
139 par(mfrow = c(2, 2), cex = 0.7)
140 ###
141
142 # Settings:
143 seed = c(456, 745, 145, 120)
144 mains = c(
145 "MRL Plot - Sample 1", "MRL Plot - Sample 2",
146 "MRL Plot - Sample 3", "MRL Plot - Sample 4")
147 n = 5000
148
149 # Create Plots With Your Own Labels and Title:
150 for (i in 1:4) {
151 set.seed(seed[i])
152 mrlPlot(rsymstb(n, alpha = 1.7), nint = 100,
153 labels = FALSE, plottype = "", xlim = c(0, 60),
154 ylim = c(-50, 150))
155 title(xlab = "u", ylab = "e", main = mains[i])
156 grid()
157 }
158 ###
159
160
161 # ------------------------------------------------------------------------------
162
163
164 ### Example: Mean Excess Function Plot
165
166 # Exponential distribution function:
167 set.seed(7138)
168 mxfPlot(rexp(n, rate = 2), tail = 1, labels = FALSE)
169 title(xlab = "Threshold: u", ylab = "Mean Excess: e",
170 main = "Exponential DF")
171 abline(0.5, 0)
172 ###
173
174 # Lognormal distribution function
175 set.seed(6952)
176 mxfPlot(rlnorm(n, meanlog = 0, sdlog = 2), tail = 1,
177 xlim = c(0, 90), ylim = c(0, 150), labels = FALSE)
178 title(xlab = "Threshold: u", ylab = "Mean Excess: e",
179 main = "Lognormal DF")
180 ###
181
182 # Alpha-stable distribution function:
183 set.seed(9835)
184 mxfPlot(rsymstb(n, alpha = 1.7), tail = 0.1,
185 xlim = c(0, 10), ylim = c(0, 6), labels = FALSE)
186 title(xlab = "Threshold: u", ylab = "Mean Excess: e",
187 main = "1.7 stable DF")
188 abline(0, 0.7)
189 ###
190
191
192 # ------------------------------------------------------------------------------
193
194
195 ### Example 5.1.4: Subsample Records Plot}
196
197
198 # Graph Frame:
199 par(mfrow = c(3, 2), cex = 0.7)
200 ###
201
202 # Simulate Stable Data:
203 stable = rsymstb(n = 8000, alpha = 1.7)
204 ###
205
206 # Load BMW and NYSE Data:
207 data(bmwres)
208 data(nyseres)
209 ###
210
211 # Plot on Logarithmic Scale:
212 ssrecordsPlot(stable, subsamples = 8, plottype = "log")
213 title(main = "\n\n1.7-stable Returns")
214 ssrecordsPlot(bmwres, subsamples = 6, plottype = "log")
215 title(main = "\n\nBMW Returns")
216 ssrecordsPlot(nyseres, subsamples = 8, plottype = "log")
217 title(main = "\n\nNYSE Returns")
218 ###
219
220 # Plot on Linear Scale:
221 ssrecordsPlot(stable, subsamples = 8, plottype = "lin")
222 title(main = "\n\n1.7-stable Returns")
223 ssrecordsPlot(bmwres, subsamples = 6, plottype = "lin")
224 title(main = "\n\nBMW Returns")
225 ssrecordsPlot(nyseres, subsamples = 8, plottype = "lin")
226 title(main = "\n\nNYSE Returns")
227 ###
228
229
230 # ------------------------------------------------------------------------------
231
232
233 ### Example 5.1.5: Plot of Records}
234
235 # Graph Frame:
236 par(mfrow = c(1, 1))
237 ###
238
239 # Normal Records Plot:
240 ans = recordsPlot(rnorm(50000))
241 print(ans)
242 ###
243
244
245 # ------------------------------------------------------------------------------
246
247
248 ### Example 5.1.6: Ratio of Maximum and Sum Plot
249
250 # Graph Frame:
251 par(mfrow = c(3, 2), cex = 0.7)
252
253 # Load Data:
254 data(bmwres)
255 data(nyseres)
256 ###
257
258 # Create Plots:
259 msratioPlot (rnorm(1000))
260 title(main = "\n\nStandard Normal")
261 msratioPlot (rexp(10000))
262 title(main = "\n\nExponential")
263 msratioPlot (rt(10000, 4))
264 title(main = "\n\nStudent-t")
265 msratioPlot (rsymstb(1000, 1))
266 title(main = "\n\nCauchy")
267 msratioPlot (bmwres)
268 title(main = "\n\nBMW Returns")
269 msratioPlot (nyseres)
270 title(main = "\n\nNYSE Returns")
271 ###
272
273
274 ################################################################################
275
276 ⏎
+659
-0
demo/xmpDWChapter052.R less more
0 #
1 # Examples from the Monograph:
2 # "Rmetrics - Financial Engineering and Computational Finance"
3 # written by Diethelm Wuertz
4 # ISBN to be published
5 #
6 # Details:
7 # Chapter 5.2
8 # Fluctuations of Maxima and GEV Distribution
9 #
10 # List of Examples, Exercises and Code Snippets:
11 #
12 # 5.2.1 Example: Gumbel, Frechet, Weibull - Create Figure 5.2.1
13 # * Example: Tables of Gumbel, Frechet and Weibull Distribution
14 # 5.2.2 Example: GEV Density - Create Figure 5.2.2
15 # 5.2.3 Example: Return Levels - Create Figure 5.2.3
16 # 5.2.4 Example: Convergence of Exponential Distribution - Figue 5.2.4
17 # 5.2.5 Example: Convergence of Normal Distribution - Figure 5.2.5
18 # 5.2.6 Example: GEV Probability Weighted Moments Fit - Figure 5.2.6
19 # 5.2.8 Example: BMW Probability Weighted Moments Fit - Figure 5.2.7
20 # 5.2.9 Example: Hill's Estimator
21 #
22 # *** This list is not yet complete ***
23 #
24 # Author:
25 # (C) 2002-2004, Diethelm Wuertz, GPL
26 # www.rmetrics.org
27 # www.itp.phys.ethz.ch
28 # www.finance.ch
29 #
30
31
32 ################################################################################
33
34
35 ### Load Library:
36
37 # Load:
38 require(fExtremes)
39 ###
40
41
42 # ------------------------------------------------------------------------------
43
44
45 ### 5.2.1 Example: Gumbel, Frechet, Weibull - Create Figure 5.2.1
46
47 # Weibull Distribution:
48 dweibl = function (x, alpha) { # x < 0, alpha > 0
49 alpha*((-x)^(alpha-1))*exp(-(-x)^alpha) }
50 pweibl = function (q, alpha) { # q < 0, alpha > 0
51 exp(-(-q)^alpha) }
52 qweibl = function (p, alpha) { # alpha > 0
53 -(-log(p))^(1/alpha) }
54 rweibl = function (n, alpha) { # alpha > 0
55 -(-log(runif(n)))^(1/alpha) }
56 ###
57
58 # Gumbel Distribution:
59 dgumbel = function (x) {# x real
60 exp(-exp(-x))*exp(-x) }
61 pgumbel = function (q) {# q real
62 exp(-exp(-q)) }
63 qgumbel = function (p) {
64 -log(-log(p)) }
65 rgumbel = function (n) {
66 -log(-log(runif(n))) }
67 ###
68
69 # Frechet Distribution:
70 dfrechet = function (x, alpha) {# x > 0, alpha > 0
71 alpha*(x^(-alpha-1))*exp(-x^(-alpha)) }
72 pfrechet = function (q, alpha) {# x >0, alpha > 0
73 exp(-q^(-alpha))}
74 qfrechet = function (p, alpha) {# abs() handles Inf from q=1
75 abs((-log(p))^(-1/alpha)) }
76 rfrechet = function (n, alpha) {
77 (-log(runif(n)))^(-1/alpha) }
78 ###
79
80 # Graph Frame:
81 par(mfrow = c(2, 2), cex = 0.7)
82 ###
83
84 # Settings:
85 s = seq(1.e-5, +6, length = 100)
86 ###
87
88 # Plot Probability - Create Figure 5.2.1:
89 plot(x = c(-6, 6), y = c(0, 1), type = "n",
90 xlab = "x", ylab = "probability", main = "Probability")
91 lines(x = c(-rev(s), 6), y = c(pweibl(-rev(s), alpha = 1), 1),
92 col = 3, lty = 2)
93 lines(x = c(-rev(s), s), y = c(pgumbel(-rev(s)), pgumbel(s)),
94 col = 4, lty = 1)
95 lines(x = c(-6, s), y = c(0, pfrechet(s, alpha = 1)),
96 col = 2, lty = 4)
97 grid()
98 ###
99
100 # Plot Density - Create Figure 5.2.1:
101 plot(x = c(-6, 6), y = c(0, 1), type = "n",
102 xlab = "x", ylab = "density", main = "Density")
103 lines(x = c(-rev(s), 0, 6), y = c(dweibl(-rev(s), alpha = 1), 0, 0),
104 col = 3, lty = 2)
105 lines(x = c(-rev(s), s), y=dgumbel(c(-rev(s), s)),
106 col = 4, lty = 1)
107 lines(x = c(-6, s), y = c(0, dfrechet(s, alpha = 1)),
108 col = 2, lty = 4)
109 grid()
110 ###
111
112
113 # ------------------------------------------------------------------------------
114
115
116 ### Example: Tables of Gumbel, Frechet and Weibull Distribution
117
118 # Frechet Distribution:
119 x = q = c(0:5, Inf)
120 cbind(x, P = pfrechet(q, alpha = 1), D = dfrechet(x, alpha = 1))
121 ###
122
123 # Weibull Distribution:
124 x = q = c(-Inf, -5:0)
125 cbind(x, P = pweibl(q, alpha = 1), D = dweibl(x, alpha = 1))
126 ###
127
128 # Gumbel Distribution rounded to 3 digits:
129 x = q = -5:5
130 round(cbind(x, P = pgumbel(q), D = dgumbel(x)), 3)
131 ###
132
133
134 # ------------------------------------------------------------------------------
135
136
137 ### 5.2.2 Example: GEV Density - Create Figure 5.2.2
138
139 # Graph Frame:
140 par(mfrow = c(2, 2), cex = 0.7)
141 ###
142
143 # Generate Random Series:
144 set.seed(1953)
145 r = rgev(1000, xi = 1, mu = 0, sigma = 1)
146 plot(r, type = "l", main = "GEV(1|0|1) RV Series", col = "steelblue")
147 grid()
148 ###
149
150 # Create Density Plot:
151 x = seq(-2, 6, length = 81)
152 d = dgev(x, xi = 1, mu = 0, sigma = 1)
153 ###
154
155 # Plot True Density:
156 plot(x, d, type = "l", main = "GEV(1|0|1) Density", col = "steelblue")
157 grid()
158 ###
159
160 # Kernel Density Estimate - Adjust Bandwidth:
161 Density = density(r, from = -2, to = 6, n = 41, adjust = 0.3)
162 points(Density$x, Density$y, pch = 19, cex = 0.5)
163 ###
164
165
166 # ------------------------------------------------------------------------------
167
168
169 ### 5.2.3 Example: Return Levels - Create Figure 5.2.3
170
171 # Graph Frame:
172 par(mfrow = c(1, 1))
173 ###
174
175 # Create p and x Vectors:
176 p = seq(0.001, 0.999, length = 500)
177 x = -1/log(1-p)
178 ###
179
180 # Plot Return Levels:
181 plot (x, qgev(1-p, xi = 0) , type = "l", log = "x",
182 xlab = "-1/log(1-p)", ylab = "Return level",
183 ylim = c(-2, 23), main = "Return Levels", lwd = 2)
184 for (xi in c(-0.30, -0.15, 0.15, 0.30))
185 lines(x, qgev(1-p, xi = xi), col = "steelblue")
186 grid()
187 ###
188
189 # Add Labels:
190 text(x = rep(450, 5), y = c(1.9, 5.0, 7.3, 12, 21),
191 labels = c("-0.30", "-0.15", "0", "0.15", "0.30"))
192 ###
193
194
195 # ------------------------------------------------------------------------------
196
197
198 ### 5.2.4 Example: Convergence of Exponential Distribution - Figue 5.2.4
199
200 # Graph Frame:
201 par(mfrow = c(2, 2), cex = 0.7)
202 ###
203
204 # Functions:
205 an = function(n) {1}
206 bn = function(n) {log(n)}
207 ###
208
209 # Plot Convergence:
210 x = seq(-2, 4, length = 200)
211 plot(x, pgev(x, xi = 0), lwd = 2, type = "l",
212 main = "Convergence of Exp Maxima")
213 grid()
214 for ( n in c(10, 5, 3, 2, 1) )
215 lines(x, y = (pexp(an(n)*x+bn(n)))^n, col = "steelblue")
216 ###
217
218 # Alternative Plot:
219 plot(-log(-log(pgev(x, xi = 0))), x, lwd = 2, type = "l",
220 main = "Convergence of Exp Maxima")
221 grid()
222 for ( n in c(10, 5, 3, 2, 1) ) {
223 y = ( pexp( an(n)*x+bn(n) ) )^n; s = -log(-log(y))
224 lines(s[s > -2], x[s > -2], col = "steelblue")
225 }
226 ###
227
228
229 # ------------------------------------------------------------------------------
230
231
232 ### 5.2.5 Example: Convergence of Normal Distribution - Figure 5.2.5
233
234 # Graph Frame:
235 par(mfrow = c(2, 2), cex = 0.7)
236 ###
237
238 # Functions:
239 an = function(n) { 1/sqrt(2*log(n)) }
240 bn = function(n) { sqrt(2*log(n)) -
241 ( log(log(n))+log(4*pi) ) / sqrt(2*log(n)) /2 }
242 ###
243
244 # Plot Convergence:
245 x = seq(-2, 5, length = 500)
246 plot(x, pgev(x, xi = 0), lwd = 2, type = "l",
247 main = "Convergence of Gaussian Maxima")
248 grid()
249 for ( n in c(100, 50, 10, 5, 2) )
250 lines(x, y = (pnorm(an(n)*x+bn(n)))^n, col = "steelblue")
251 ###
252
253 # Alternative Plot:
254 plot(-log(-log(pgev(x, xi = 0))), x, xlim = c(-2, 12), lwd = 2,
255 type = "l", main = "Convergence of Gaussian Maxima")
256 grid()
257 x = seq(-2, 12, length = 500)
258 for ( n in c(100, 50, 10, 5, 2) ) {
259 y = (pnorm(an(n)*x+bn(n)))^n; s = -log(-log(y))
260 lines(s[x < 5], x[x < 5], col = "steelblue")
261 }
262 ###
263
264
265 # ------------------------------------------------------------------------------
266
267
268 ### 5.2.6 Example: GEV Probability Weighted Moments Fit - Figure 5.2.6
269
270 # Graph Frame and Settings:
271 par(mfrow = c(2, 2), cex = 0.7)
272 set.seed(4711)
273 ###
274
275 # Create and Plot the Random Variables:
276 x = rgev(n = 8000, xi = 0.3, mu = 0, sigma = 1)
277 plot(x, type = "h", main = "Random Variables", col = "steelblue")
278 mtext("Simulated GEV Data", line = 0.5, cex = 0.5)
279 lines(x = c(0, length(x)), y = c(0, 0), col = "grey", lty = 3)
280 ###
281
282 # PWM Estimate:
283 parm.fit = gevFit(x, type = "pwm")
284 ###
285
286 # Print Estimated Results:
287 print(parm.fit)
288 ###
289
290 # Generated Output:
291 # Call:
292 # gevFit(x = x, type = "pwm")
293 # Estimation Type:
294 # gev pwm
295 # Estimated Parameters:
296 # xi sigma mu
297 # 0.28422082 1.01273658 0.00366702
298 ###
299
300 # Plot Density:
301 d = density(x, n = 200)
302 plot(d$x, d$y, xlim = c(-5, 15), ylim = c(0, 0.4), pch = 19,
303 xlab = "x", ylab = "density", main = "GEV Density", col = "steelblue")
304 grid()
305 mtext("Simulated GEV Data: PWM Estimate", line = 0.5, cex = 0.5)
306 s = seq(-5, 15, length = 200)
307 lines(s, dgev(s, xi = xi))
308 ###
309
310
311 # ------------------------------------------------------------------------------
312
313
314 ### 5.2.8 Example: BMW Probability Weighted Moments Fit - Figure 5.2.7
315
316 # Graph Frame:
317 par(mfrow = c(2, 2), cex = 0.7)
318 ###
319
320 # Load Data and Convert to Numeric Vector:
321 BMW.RET = as.timeSeries(data(bmw.ret))
322 bmwres = as.vector(BMW.RET)
323 blocklength = 63
324 ###
325
326 # Plot Time Series Data:
327 plot(bmwres, type = "h", main = "Daily log Returns", col = "steelblue")
328 grid()
329 abline(h = mean(bmwres), lty = 3, col = "grey")
330 ###
331
332 # Create Block Maxima of Lower Tail:
333 x = blockMaxima(-bmwres, block = blocklength, col = "steelblue", lwd = 1.5)
334 mtext("Block Maxima - Lower Tail", line = 0.5, cex = 0.5)
335 ###
336
337 # PWM Estimate:
338 fit = gevFit(x, type = "pwm")
339 xi = fit$par.ests[1]
340 sigma = fit$par.ests[2]
341 mu = fit$par.ests[3]
342 ###
343
344 # Histogram Plot and GEV Density:
345 hist(x, nclass = 20, probability = TRUE, col = "steelblue",
346 border = "white", main = "Block Maxima - Histogram")
347 s = seq(0, max(x), length = 500)
348 lines(s, dgev(s, xi, mu, sigma), lwd = 2, col = "brown")
349 mtext("Line: GEV Fit", line = 0.5, cex = 0.5)
350 ###
351
352 # QQ-Plot:
353 plot(sort(x), qgev(ppoints(x), xi, mu, sigma), pch = 19,
354 col = "steelblue", main="QQ-Plot: Empirical / GEV",
355 xlab = "empirical rvs", ylab = "GEV df")
356 lines(c(min(x), max(x)), c(min(x), max(x)))
357 grid()
358 ###
359
360
361 # ------------------------------------------------------------------------------
362
363
364 ### 5.2.8 Example: BMW Maximum Log Likelihood Fit - Figure 5.2.8
365
366 # Graph Frame:
367 par(mfrow = c(2, 2), cex = 0.7)
368 ###
369
370 # Load Data, Take Loss Tail:
371 BMW.RET = -as.timeSeries(data(bmw.ret))
372 ###
373
374 # PWM Estimate:
375 fit = gevFit(BMW.RET, block = 63, type = "mle")
376 summary(fit)
377 ###
378
379
380 # ------------------------------------------------------------------------------
381
382
383 ### Example: Alternatives to Print, Plot and Summarize 'gevFit' Objects
384
385
386 # Load Data, Take Loss Tail and Fit:
387 DAX.RET = -as.timeSeries(data(dax.ret))
388 fit = gevFit(DAX.RET, block = 63, type = "mle")
389 ###
390
391 # Print fitted Parameters:
392 print(fit)
393 ###
394
395 # Create Summary Report Including Figures:
396 par(mfrow = c(2, 2), cex = 0.7)
397 summary(fit)
398 ###
399
400 # Create Summary Report With Interactive Plots:
401 par(mfrow = c(1, 1))
402 summary(fit, which = "ask")
403 ###
404
405 # Just Show the Quantile-Quantile Plot:
406 par(mfrow = c(1, 1))
407 plot(fit, which = 4)
408 ###
409
410
411 # ------------------------------------------------------------------------------
412
413
414 ### Example: Use Calendar Blocks
415
416 # Load Data, Take Loss Tail and Fit:
417 DAX.RET = -as.timeSeries(data(dax.ret))
418 # fit = gevFit(DAX.RET, block = "quarter", type = "mle")
419 # check does not yet work ...
420 ###
421
422
423 # ------------------------------------------------------------------------------
424
425
426 ### Example: gevglmFit
427
428 # Load Data and Convert to Numeric Vector:
429 BMW.RET = as.timeSeries(data(bmw.ret))
430 bmwres = as.vector(BMW.RET)
431 blocklength = 63
432 ###
433
434 # Graph Frame:
435 par(mfrow = c(3, 2), 0.7)
436 ###
437
438 # Fit GEV Data by Max Log Likelihood Method a la ISMEV:
439 fit = gevglmFit(x)
440 summary(fit)
441 ###
442
443 # Profile Likelihood:
444 gevglmprofxiPlot(fit, xlow = 0.15, xup = 0.60)
445 title(main = "Profile Likelihood for Xi")
446 grid()
447 gevglmprofPlot(fit, m = 100, xlow = 0.05, xup = 0.15)
448 title(main = "Profile Likelihood for Quantile 0.01")
449 grid()
450 ###
451
452
453 # ------------------------------------------------------------------------------
454
455
456 ### 5.2.8 Example: Hill's Estimator
457
458 # Graph Frame:
459 par(mfrow = c(2, 2), cex = 0.7)
460 ###
461
462 # Simulate and Load Data:
463 set.seed(4771)
464 x1 = rsymstb(10000, alpha = 1.8)
465 data(nyseres)
466 x2 = nyseres[, 1]
467 ###
468
469 # Hill Plot with Errors for Upper and Lower Tails:
470 result = hillPlot( x1, autoscale = FALSE, ylim = c(0, 3.5))
471 result = hillPlot( x2, autoscale = FALSE, ylim = c(0, 6.0))
472 result = hillPlot(-x1, autoscale = FALSE, ylim = c(0, 3.5))
473 result = hillPlot(-x2, autoscale = FALSE, ylim = c(0, 6.0))
474 ###
475
476
477 # ------------------------------------------------------------------------------
478
479
480 ### 5.2.9 Example: Shape Parameter Summary Plots
481
482 # Graph Frame:
483 par(mfrow = c(3, 2), cex = 0.7)
484 ###
485
486 # Load Data:
487 data(nyseres)
488 ###
489
490 # Chart Parameters:
491 tails = c( 0.01, 0.02, 0.03, 0.04,0.05, 0.06, 0.07, 0.08, 0.09, 0.10)
492 doplot = c(FALSE,FALSE,FALSE,FALSE,TRUE,FALSE,FALSE,FALSE,FALSE,FALSE)
493 ###
494
495 # Calculate and Plot Shape Parameters:
496 s = shaparmPlot(x = nyseres, tails = tails,
497 doplot = doplot, doprint = TRUE, xi.range = c(-1, 3),
498 alpha.range = c(0, 8))
499 ###
500
501
502 # ------------------------------------------------------------------------------
503
504
505 ### 5.2.10 Example: GEV Maximum Likelihood Fitting
506
507 # Graph Frame:
508 par(mfrow = c(4, 2), cex = 0.5)
509 ###
510
511 # Load Data:
512 data(nyseres)
513 nyseres = nyseres[, 1]
514 ts.plot(nyseres, main = "Log Returns")
515 mtext("NYSE Index Residuals", line = 0.5, cex = 0.5)
516 x = blockMaxima(-nyseres, block = 63)
517 mtext("Lower Tail: Quarterly Data", line = 0.5, cex = 0.5)
518 ###
519
520 # Fit GEV Data by Max Log Likelihood Method a la ISMEV:
521 fit = gevglmFit(x)
522 summary(fit)
523 ###
524
525 # Generated Output:
526 # Call:
527 # gevglmFit(x = x)
528 # Estimation Type:
529 # gevglm mle
530 # Estimated Parameters:
531 # xi sigma mu
532 # 0.317408547 0.005641637 0.014932832
533 # Standard Deviations:
534 # xi sigma mu
535 # 0.0723993029 0.0003170321 0.0005216084
536 # Log-Likelihood Value:
537 # -457.9648
538 # Type of Convergence:
539 # 0
540 ###
541
542 # Profile Likelihood:
543 gevglmprofxiPlot(fit, xlow = 0.15, xup = 0.60)
544 title(main = "Profile Likelihood for Xi")
545 gevglmprofPlot(fit, m = 100, xlow = 0.05, xup = 0.15)
546 title(main = "Profile Likelihood for Quantile 0.01")
547 ###
548
549
550 # ------------------------------------------------------------------------------
551
552
553 ### ADDON:
554
555
556 ### Example: GEV Maximum Likelihood Estimation Fit
557
558 # Fit the GEV via the Maximum likelihood approach.
559 # Investigate the data from BMW Stocks
560
561 # Settings:
562 par(mfrow = c(2, 2), cex = 0.7)
563 data(nyseres)
564 nyseres = nyseres[, 1]
565 ts.plot(nyseres, main = "Log Returns")
566 mtext("NYSE Index Residuals", line = 0.5, cex = 0.5)
567 x = blockMaxima(-nyseres, block = 63)
568 mtext("Lower Tail: Quarterly Data", line = 0.5, cex = 0.5)
569 ###
570
571 # Fit GEV Data by Max Log Likelihood Method a la ISMEV:
572 fit = gevglmFit(x)
573 print(fit)
574 summary(fit)
575 ###
576
577 # Profile Likelihood:
578 gevglmprofxiPlot(fit, xlow = 0.15, xup = 0.60)
579 title(main = "Profile Likelihood for Xi")
580 gevglmprofPlot(fit, m = 100, xlow = 0.05, xup = 0.15)
581 title(main = "Profile Likelihood for Quantile 0.01")
582 ###
583
584 # Fit GEV Data by Max Log Likelihood Method a la EVIS:
585 fit = gevFit(x, type = "mle")
586 print(fit)
587 summary(fit)
588 ###
589
590
591 # ------------------------------------------------------------------------------
592
593
594 ### Example: GEV Probability Weighted Moments Fit
595
596 # Estimate the parameters of a simulated GEV
597 # with the method of probability weighted
598 # moments.
599
600 # Settings:
601 par(mfrow = c(2, 2), cex = 0.6)
602 n = 8000
603 xmax.density = 15
604 parm0 = list(xi = 1/4, mu = 0.0, sigma = 1.0)
605 ###
606
607 # Create and Plot the Random Variables:
608 x = rgev(n, xi = parm0$xi, mu = parm0$mu, sigma = parm0$sigma)
609 plot(x, type = "h", main = "Random Variables")
610 mtext("Simulated GEV Data", line = 0.5, cex = 0.5)
611 lines(x = c(0, length(x)), y = c(0, 0), col = "steelblue")
612 lines(x = c(0, length(x)), y = c(-1/0.3, -1/0.3), col = "steelblue")
613 ###
614
615 # PWM Estimate:
616 parm = gevFit(x, type = "pwm")
617 parm
618 ###
619
620 # Plot Empirical and Estimated Densities:
621 d = density(x, n = 200)
622 plot(d$x, d$y, xlim = c(-5, 15), ylim=c(0, 0.4),
623 xlab = "x", ylab = "density", main = "GEV Density")
624 mtext("Simulated GEV Data", line = 0.5, cex = 0.5)
625 s = seq(-5, 15, length = 200)
626 lines(s, dgev(s, xi = parm0$xi, mu = parm0$mu,
627 sigma = parm0$sigma), col = "steelblue")
628 ###
629
630
631 # ------------------------------------------------------------------------------
632
633
634 ### Example: Shape Parameter Plot
635
636 # Plot the shape parameter obtained from MDA estimators
637 # for the NYSE Composite Index log returns.
638
639 # Settings:
640 par(mfcol = c(3, 2), err = -1, cex = 0.6)
641 data(nyseres)
642 ###
643
644 # Chart Parameters = Plot for 'tail=0.05':
645 tails = c( 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0.08, 0.09, 0.10)
646 doplot = c(FALSE,FALSE,FALSE,FALSE, TRUE,FALSE,FALSE,FALSE,FALSE,FALSE)
647 ###
648
649 # Calculate and Plot Shape Parameters:
650 s = shaparmPlot(x = nyseres, tails = tails,
651 doplot = doplot, doprint = TRUE, xi.range = c(-1, 3),
652 alpha.range = c(0, 8))
653 ###
654
655
656 ################################################################################
657
658 ⏎
+164
-0
demo/xmpDWChapter053.R less more
0 #
1 # Examples from the Monograph:
2 # "Rmetrics - Financial Engineering and Computational Finance"
3 # written by Diethelm Wuertz
4 # ISBN to be published
5 #
6 # Details:
7 # Chapter 5.3
8 # Extremes via Point Processes
9 #
10 # List of Examples, Exercises and Code Snippets:
11 #
12 # Example: POT Point Process - Figure 5.3.1
13 #
14 # *** This list is not yet complete ***
15 #
16 # Author:
17 # (C) 2002-2004, Diethelm Wuertz, GPL
18 # www.rmetrics.org
19 # www.itp.phys.ethz.ch
20 # www.finance.ch
21 #
22
23
24 ################################################################################
25
26
27 ### Load Library:
28
29 # Load:
30 require(fExtremes)
31 ###
32
33
34 # ------------------------------------------------------------------------------
35
36
37 ### Example: POT Point Process - Figure 5.3.1
38
39 # Plot the point Process p(n) for n = 5, 10, 100, 500, 1000,
40 # 10000 respectivel with the X(i) exponentially distributed
41
42 # Settings:
43 par(mfrow = c(2, 3), cex = 0.7)
44 x = seq(-2, 4, length = 200)
45 set.seed(671)
46 ###
47
48 # Point Process:
49 an = function(n) {1}
50 bn = function(n) {log(n)}
51 n = c(5, 10, 100, 500, 1000, 10000)
52 titles = c("n = 5", "n = 10", "n = 100", "n = 500",
53 "n = 1000", "n = 10000")
54 x = rexp(n[length(n)])
55 ###
56
57 # Graphs:
58 for ( i in 1:length(n) ) {
59 plot( (1:n[i])/(n[i]+1), (x[1:n[i]]-bn(n[i]))/an(n[i]),
60 xlab = "x", ylab = "y", ylim = c(-10, 3), pch = 19,
61 main = titles[i], col = "steelblue", cex = 0.5)
62 print(bn(n[i]))
63 abline(h = -bn(n[i]), lty = 3)
64 }
65 ###
66
67
68 ################################################################################
69
70
71 ### Example: POT Mean Residual Life Plot
72
73 # Create a mean residual life plot. Include
74 # approximate confidence intervals, by default 95%
75
76 # Graph Frame:
77 par(mfrow = c(2, 2), cex = 0.6)
78 BMW.RET = -as.timeSeries(data(bmw.ret))
79 DAX.RET = -as.timeSeries(data(dax.ret))
80 ###
81
82 # Mean Residual Life Plot - BMW Data:
83 mrlPlot(-BMW.RET)
84 mtext("BMW Losses", line = 0.5, cex = 0.5)
85 ###
86
87 # Mean Residual Life Plot - BMW Data:
88 mrlPlot(-DAX.RET)
89 mtext("DAX Losses", line = 0.5, cex = 0.5)
90 ###
91
92
93 # ------------------------------------------------------------------------------
94
95
96 ### Example: POT Parameter Estimation
97
98 # Estimate the parameters (xi, mu, sigma) for a data vector
99 # x from the point process over a threshold u using the
100 # function ppFit().
101
102 # Settings:
103 par(mfrow = c(3, 2), cex = 0.6)
104 data(nyseres)
105 data = nyseres[, 1]
106 ###
107
108 # NYSE Residuals:
109 plot(data, type = "l", ylim = c(-0.22, +0.22),
110 main = "log Returns")
111 mtext("NYSE Residuals", line = 0.5, cex = 0.5)
112 ###
113
114 # Point Process of Threshold Exceedences:
115 u = 0.02
116 y = data[data < -u]
117 x = (1:length(data))[data < -u]
118 points(x, y, col = 2)
119 plot(x, -y-u, type = "h", main = "Peaks over Threshold:")
120 ###
121
122 # Point Process Fit:
123 fit = gpdFit(x = -data, nextremes = length(x), type = "mle")
124 print(fit)
125 summary(fit)
126 ###
127
128
129 # ------------------------------------------------------------------------------
130
131
132 ### Example: POT Parameter Estimation
133
134 # Estimate the parameters (xi, mu, sigma) for a data vector
135 # x from the point process over a threshold u using the
136 # function ppFit().
137
138 # Settings:
139 par(mfcol = c(3, 2), cex = 0.6)
140 data(nyseres)
141 data = nyseres[, 1]
142 ###
143
144 # NYSE Residuals:
145 plot(data, type = "l", ylim = c(-0.22, +0.22), main = "log Returns")
146 ###
147
148 # Point Process of Threshold Exceedences:
149 u = 0.02
150 y = data[data < -u]
151 x = (1:length(data))[data < -u]
152 points(x, y, col = 5)
153 ###
154
155 # Point Process Fit:
156 fit = ppFit(x = -data, threshold = u, nobs = 252)
157 print(fit)
158 summary(fit)
159 ###
160
161
162 ################################################################################
163
+151
-0
demo/xmpDWChapter054.R less more
0 #
1 # Examples from the Monograph:
2 # "Rmetrics - Financial Engineering and Computational Finance"
3 # written by Diethelm Wuertz
4 # ISBN to be published
5 #
6 # Details:
7 # Chapter 5.4
8 # The Extremal Index
9 #
10 # List of Examples, Exercises and Code Snippets:
11 #
12 # Example: Extremal Index Plot
13 # Example: Extremal Indexes Plot
14 #
15 # *** This list is not yet complete ***
16 #
17 #
18 # Author:
19 # (C) 2002-2004, Diethelm Wuertz, GPL
20 # www.rmetrics.org
21 # www.itp.phys.ethz.ch
22 # www.finance.ch
23 #
24
25
26 ################################################################################
27
28
29 ### Load Library:
30
31 # Load:
32 require(fExtremes)
33 ###
34
35
36 # ------------------------------------------------------------------------------
37
38
39 ### Example: Extremal Index Plot
40
41 # Plot the extremal as obtained from the
42 # BMW stock and NYSE Composite Index data.
43 ###
44
45 # Settings:
46 par(mfrow = c(3, 2), cex = 0.6)
47 data(bmwres)
48 data(nyseres)
49 ###
50
51 # Investigate BMW log-Returns:
52 x = bmwres[, 1]
53 exindexPlot( x, block = 63, autoscale = FALSE, ylim = c(0, 1.2))
54 exindexPlot(-x, block = 63, autoscale = FALSE, ylim = c(0, 1.2))
55 ###
56
57 # Investigate NYSE log-Returns:
58 x = nyseres[, 1]
59 exindexPlot( x, block = 50, autoscale = FALSE, ylim = c(0, 1.2))
60 exindexPlot(-x, block = 50, autoscale = FALSE, ylim = c(0, 1.2))
61 ###
62
63 # Reverse Plottype:
64 exindexPlot( x, block = 50, plottype = "K", autoscale = FALSE,
65 ylim = c(0, 1.2))
66 exindexPlot(-x, block = 50, plottype = "K", autoscale = FALSE,
67 ylim = c(0, 1.2))
68 ###
69
70
71 # ------------------------------------------------------------------------------
72
73
74 ### Example: Extremal Indexes Plot
75
76 # Plot the extremal; index for a long(80'000 points)
77 # and a short (8'000 points) series of Student-t
78 # distributed (4 degress of freedom) random variables
79 # together with their EMA smoothed (lambda=0.2) series.
80 # Compare the result with the extremal index obtained
81 # from the BMW stock and NYSE Composite Index data.
82 ###
83
84 # Settings:
85 par(mfrow = c(4, 2), cex = 0.5)
86 set.seed(773)
87 data(bmwres)
88 data(nyseres)
89 blocklength = 500
90 ###
91
92 # Investigate Large Sample Random Variables:
93 x = rt(n = 80000, df = 4)
94 exindexesPlot(x, blocklength)
95 mtext("Student - 80000 points", line = 0.5, cex = 0.5)
96 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
97 ###
98
99 # Investigate EMA-Smoothed rvs:
100 lambda = 0.2
101 xlam = x * lambda
102 xlam[1] = x[1]
103 x = filter(xlam, filter = (1-lambda), method = "rec")
104 exindexesPlot(x, blocklength)
105 mtext("EMA Student - 80000 points", line = 0.5, cex = 0.5)
106 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
107 ###
108
109 # Investigate Small Sample Random Variables:
110 x = rt(n = 8000, df = 4)
111 exindexesPlot(x, blocklength)
112 mtext("Student - 8000 points", line = 0.5, cex = 0.5)
113 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
114 ###
115
116 # Investigate EMA-Smoothed rvs:
117 lambda = 0.2
118 xlam = x * lambda
119 xlam[1] = x[1]
120 x = filter(xlam, filter = (1-lambda), method = "rec")
121 exindexesPlot(x, blocklength)
122 mtext("EMA Student - 8000 points", line = 0.5, cex = 0.5)
123 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
124 ###
125
126 # Investigate BMW log-Returns:
127 x = bmwres[, 1]
128 length(x)
129 exindexesPlot(x, blocklength)
130 mtext("BMW - 6146 points - upper", line = 0.5, cex = 0.5)
131 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
132 exindexesPlot(-x, blocklength)
133 mtext("BMW - 6146 points - lower", line = 0.5, cex = 0.5)
134 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
135 ###
136
137 # Investigate NYSE log-Returns:
138 x = nyseres[, 1]
139 length(x)
140 exindexesPlot( x, blocklength)
141 mtext("NYSE - 8390 points - upper", line = 0.5, cex = 0.5)
142 lines(x=c(0.990, 0.999), y = c(1, 1), col = "red")
143 exindexesPlot(-x, blocklength)
144 mtext("NYSE - 8390 points - lower", line = 0.5, cex = 0.5)
145 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
146 ###
147
148
149 ################################################################################
150
+0
-258
demo/xmpDWChapter51.R less more
0 #
1 # Examples from the Monograph:
2 # "Rmetrics - Financial Engineering and Computational Finance"
3 # written by Diethelm Wuertz
4 # ISBN to be published
5 #
6 # Details:
7 # Chapter 5.1
8 # Extreme Value Plots
9 #
10 # List of Examples, Exercises and Code Snippets:
11 #
12 # 5.1.1 Example: Quantile-Quantile Plot
13 # * Code Snipptet: qqPlot
14 # * Example: Create Figure 5.1.1 - DAX Data
15 # * Example: Create Figure 5.1.1 - BMW Data
16 # 5.1.2 Example: Mean Excess Function Plot - Create Figure 5.1.2
17 # * Example: Mean Residual Life Plot - Create Figure 5.1.3
18 #
19 # *** This list is not yet complete ***
20 #
21 # Author:
22 # (C) 2002-2004, Diethelm Wuertz, GPL
23 # www.rmetrics.org
24 # www.itp.phys.ethz.ch
25 # www.finance.ch
26 #
27
28
29 ################################################################################
30
31
32 ### 5.1.1 Example: Quantile-Quantile Plot
33
34 # Load and Plot the Data
35 DAX.RET = as.timeSeries(data(dax.ret))
36 class(DAX.RET)
37 head(DAX.RET)
38 qqPlot(DAX.REIT)
39 ###
40
41
42 # ------------------------------------------------------------------------------
43
44
45 ### Code Snipptet: qqPlot
46
47 # Quantile-Quantile Plot:
48 .qqPlot = function(x, ...)
49 {
50 x = as.vector(x)
51 qqnorm(x, ...)
52 qqline(x)
53 invisible()
54 }
55 .qqPlot(DAX.RET)
56 ###
57
58
59 # ------------------------------------------------------------------------------
60
61
62 ### Example: Create Figure 5.1.1 - DAX Data
63
64 # Graph Frame:
65 par(mfcol = c(2, 2), cex = 0.7)
66 ###
67
68 # Load and Plot the Data
69 DAX.RET = as.timeSeries(data(dax.ret))
70 plot(DAX.RET, main = "DAX Daily log Returns", ylab = "log Return")
71 qqPlot(DAX.RET)
72 ###
73
74
75 # ------------------------------------------------------------------------------
76
77
78 ### Example: Create Figure 5.1.1 - BMW Data
79
80 # Load and Plot the Data
81 BMW.RET = as.timeSeries(data(bmw.ret))
82 plot(BMW.RET, main = "BMW Daily log Returns", ylab = "log Return")
83 qqPlot(BMW.RET)
84 ###
85
86
87 # ------------------------------------------------------------------------------
88
89
90 ### 5.1.2 Example: Mean Excess Function Plot - Create Figure 5.1.2
91
92 # Graph Frame:
93 par(mfrow = c(2, 2), cex = 0.7)
94 ###
95
96 # Exponential Variates:
97 set.seed(4711)
98 mxfPlot(rexp(1000, rate = 2), tail = 0.20)
99 title(main = "\n\nExponential DF")
100 abline(0.5, 0)
101 ###
102
103 # Normal Variates:
104 set.seed(4711)
105 mxfPlot(rlnorm(1000, meanlog = 0, sdlog = 2), tail = 0.20)
106 title(main = "\n\nLognormal DF")
107 ###
108
109 # Symmetric Stable Variates:
110 set.seed(4711)
111 mxfPlot(rsymstb(1000, alpha = 1.7), tail = 0.20)
112 title(main = "\n\n1.7 stable DF")
113 abline(0, 0.7)
114 ###
115
116 # DAX log Returns:
117 mxfPlot(-100*DAX.RET, tail = 0.20)
118 title(main = "\n\nDAX log Returns %")
119 ###
120
121
122 # ------------------------------------------------------------------------------
123
124
125 ### Example: Mean Residual Life Plot - Create Figure 5.1.3
126
127
128 # Graph Frame:
129 par(mfrow = c(2, 2), cex = 0.7)
130 ###
131
132 # Settings:
133 seed = c(456, 745, 145, 120)
134 mains = c(
135 "MRL Plot - Sample 1", "MRL Plot - Sample 2",
136 "MRL Plot - Sample 3", "MRL Plot - Sample 4")
137 n = 5000
138
139 # Create Plots With Your Own Labels and Title:
140 for (i in 1:4) {
141 set.seed(seed[i])
142 mrlPlot(rsymstb(n, alpha = 1.7), nint = 100,
143 labels = FALSE, plottype = "", xlim = c(0, 60),
144 ylim = c(-50, 150))
145 title(xlab = "u", ylab = "e", main = mains[i])
146 grid()
147 }
148 ###
149
150
151 # ------------------------------------------------------------------------------
152
153
154 # >>>>>>>>
155
156
157 ### Example: Mean Excess Function Plot
158
159 # Exponential distribution function:
160 set.seed(7138)
161 mxfPlot(rexp(n, rate = 2), tail = 1, labels = FALSE)
162 title(xlab = "Threshold: u", ylab = "Mean Excess: e",
163 main = "Exponential DF")
164 abline(0.5, 0)
165
166 # Lognormal distribution function
167 set.seed(6952)
168 mxfPlot(rlnorm(n, meanlog = 0, sdlog = 2), tail = 1,
169 xlim = c(0, 90), ylim = c(0, 150), labels = FALSE)
170 title(xlab = "Threshold: u", ylab = "Mean Excess: e",
171 main = "Lognormal DF")
172
173 # Alpha-stable distribution function:
174 set.seed(9835)
175 mxfPlot(rsymstb(n, alpha = 1.7), tail = 0.1,
176 xlim = c(0, 10), ylim = c(0, 6), labels = FALSE)
177 title(xlab = "Threshold: u", ylab = "Mean Excess: e",
178 main = "1.7 stable DF")
179 abline(0, 0.7)
180
181
182 # ------------------------------------------------------------------------------
183
184
185 ### Example 5.1.4: Subsample Records Plot}
186
187
188 # Graph Frame:
189 par(mfrow = c(3, 2), cex = 0.7)
190
191 # Simulate Stable Data:
192 stable = rsymstb(n = 8000, alpha = 1.7)
193
194 # Load BMW and NYSE Data:
195 data(bmwres)
196 data(nyseres)
197
198 # Plot on Logarithmic Scale:
199 ssrecordsPlot(stable, subsamples = 8, plottype = "log")
200 title(main = "\n\n1.7-stable Returns")
201 ssrecordsPlot(bmwres, subsamples = 6, plottype = "log")
202 title(main = "\n\nBMW Returns")
203 ssrecordsPlot(nyseres, subsamples = 8, plottype = "log")
204 title(main = "\n\nNYSE Returns")
205
206 # Plot on Linear Scale:
207 ssrecordsPlot(stable, subsamples = 8, plottype = "lin")
208 title(main = "\n\n1.7-stable Returns")
209 ssrecordsPlot(bmwres, subsamples = 6, plottype = "lin")
210 title(main = "\n\nBMW Returns")
211 ssrecordsPlot(nyseres, subsamples = 8, plottype = "lin")
212 title(main = "\n\nNYSE Returns")
213
214
215 # ------------------------------------------------------------------------------
216
217
218 ### Example 5.1.5: Plot of Records}
219
220 # Graph Frame:
221 par(mfrow = c(3, 2), cex = 0.7)
222
223 # Normal Records Plot:
224 ans = recordsPlot(rnorm(50000))
225 print(ans)
226
227
228 # ------------------------------------------------------------------------------
229
230
231 ### Example 5.1.6: Ratio of Maximum and Sum Plot
232
233 # Graph Frame:
234 par(mfrow = c(3, 2), cex = 0.7)
235
236 # Load Data:
237 data(bmwres)
238 data(nyseres)
239
240 # Create Plots:
241 msratioPlot (rnorm(1000))
242 title(main = "\n\nStandard Normal")
243 msratioPlot (rexp(10000))
244 title(main = "\n\nExponential")
245 msratioPlot (rt(10000, 4))
246 title(main = "\n\nStudent-t")
247 msratioPlot (rsymstb(1000, 1))
248 title(main = "\n\nCauchy")
249 msratioPlot (bmwres)
250 title(main = "\n\nBMW Returns")
251 msratioPlot (nyseres)
252 title(main = "\n\nNYSE Returns")
253
254
255 ################################################################################
256
257 ⏎
+0
-628
demo/xmpDWChapter52.R less more
0 #
1 # Examples from the Monograph:
2 # "Rmetrics - Financial Engineering and Computational Finance"
3 # written by Diethelm Wuertz
4 # ISBN to be published
5 #
6 # Details:
7 # Chapter 5.2
8 # Fluctuations of Maxima and GEV Distribution
9 #
10 # List of Examples, Exercises and Code Snippets:
11 #
12 # 5.2.1 Example: Gumbel, Frechet, Weibull - Create Figure 5.2.1
13 # * Example: Tables of Gumbel, Frechet and Weibull Distribution
14 # 5.2.2 Example: GEV Density - Create Figure 5.2.2
15 # 5.2.3 Example: Return Levels - Create Figure 5.2.3
16 # 5.2.4 Example: Convergence of Exponential Distribution - Figue 5.2.4
17 # 5.2.5 Example: Convergence of Normal Distribution - Figure 5.2.5
18 # 5.2.6 Example: GEV Probability Weighted Moments Fit - Figure 5.2.6
19 # 5.2.8 Example: BMW Probability Weighted Moments Fit - Figure 5.2.7
20 # 5.2.9 Example: Hill's Estimator
21 #
22 # *** This list is not yet complete ***
23 #
24 # Author:
25 # (C) 2002-2004, Diethelm Wuertz, GPL
26 # www.rmetrics.org
27 # www.itp.phys.ethz.ch
28 # www.finance.ch
29 #
30
31
32 ################################################################################
33
34
35 ### 5.2.1 Example: Gumbel, Frechet, Weibull - Create Figure 5.2.1
36
37 # Weibull Distribution:
38 dweibl = function (x, alpha) { # x < 0, alpha > 0
39 alpha*((-x)^(alpha-1))*exp(-(-x)^alpha) }
40 pweibl = function (q, alpha) { # q < 0, alpha > 0
41 exp(-(-q)^alpha) }
42 qweibl = function (p, alpha) { # alpha > 0
43 -(-log(p))^(1/alpha) }
44 rweibl = function (n, alpha) { # alpha > 0
45 -(-log(runif(n)))^(1/alpha) }
46 ###
47
48 # Gumbel Distribution:
49 dgumbel = function (x) {# x real
50 exp(-exp(-x))*exp(-x) }
51 pgumbel = function (q) {# q real
52 exp(-exp(-q)) }
53 qgumbel = function (p) {
54 -log(-log(p)) }
55 rgumbel = function (n) {
56 -log(-log(runif(n))) }
57 ###
58
59 # Frechet Distribution:
60 dfrechet = function (x, alpha) {# x > 0, alpha > 0
61 alpha*(x^(-alpha-1))*exp(-x^(-alpha)) }
62 pfrechet = function (q, alpha) {# x >0, alpha > 0
63 exp(-q^(-alpha))}
64 qfrechet = function (p, alpha) {# abs() handles Inf from q=1
65 abs((-log(p))^(-1/alpha)) }
66 rfrechet = function (n, alpha) {
67 (-log(runif(n)))^(-1/alpha) }
68 ###
69
70 # Graph Frame:
71 par(mfrow = c(2, 2), cex = 0.7)
72
73 # Settings:
74 s = seq(1.e-5, +6, length = 100)
75
76 # Plot Probability - Create Figure 5.2.1:
77 plot(x = c(-6, 6), y = c(0, 1), type = "n",
78 xlab = "x", ylab = "probability", main = "Probability")
79 lines(x = c(-rev(s), 6), y = c(pweibl(-rev(s), alpha = 1), 1),
80 col = 3, lty = 2)
81 lines(x = c(-rev(s), s), y = c(pgumbel(-rev(s)), pgumbel(s)),
82 col = 4, lty = 1)
83 lines(x = c(-6, s), y = c(0, pfrechet(s, alpha = 1)),
84 col = 2, lty = 4)
85 grid()
86 ###
87
88 # Plot Density - Create Figure 5.2.1:
89 plot(x = c(-6, 6), y = c(0, 1), type = "n",
90 xlab = "x", ylab = "density", main = "Density")
91 lines(x = c(-rev(s), 0, 6), y = c(dweibl(-rev(s), alpha = 1), 0, 0),
92 col = 3, lty = 2)
93 lines(x = c(-rev(s), s), y=dgumbel(c(-rev(s), s)),
94 col = 4, lty = 1)
95 lines(x = c(-6, s), y = c(0, dfrechet(s, alpha = 1)),
96 col = 2, lty = 4)
97 grid()
98 ###
99
100
101 # ------------------------------------------------------------------------------
102
103
104 ### Example: Tables of Gumbel, Frechet and Weibull Distribution
105
106 # Frechet Distribution:
107 x = q = c(0:5, Inf)
108 cbind(x, P = pfrechet(q, alpha = 1), D = dfrechet(x, alpha = 1))
109 ###
110
111 # Weibull Distribution:
112 x = q = c(-Inf, -5:0)
113 cbind(x, P = pweibl(q, alpha = 1), D = dweibl(x, alpha = 1))
114 ###
115
116 # Gumbel Distribution rounded to 3 digits:
117 x = q = -5:5
118 round(cbind(x, P = pgumbel(q), D = dgumbel(x)), 3)
119 ###
120
121
122 # ------------------------------------------------------------------------------
123
124
125 ### 5.2.2 Example: GEV Density - Create Figure 5.2.2
126
127 # Graph Frame:
128 par(mfrow = c(2, 2), cex = 0.7)
129
130 # Generate Random Series:
131 set.seed(1953)
132 r = rgev(1000, xi = 1, mu = 0, sigma = 1)
133 plot(r, type = "l", main = "GEV(1|0|1) RV Series", col = "steelblue")
134 grid()
135 ###
136
137 # Create Density Plot:
138 x = seq(-2, 6, length = 81)
139 d = dgev(x, xi = 1, mu = 0, sigma = 1)
140 ###
141
142 # Plot True Density:
143 plot(x, d, type = "l", main = "GEV(1|0|1) Density", col = "steelblue")
144 grid()
145 ###
146
147 # Kernel Density Estimate - Adjust Bandwidth:
148 Density = density(r, from = -2, to = 6, n = 41, adjust = 0.3)
149 points(Density$x, Density$y, pch = 19, cex = 0.5)
150 ###
151
152
153 # ------------------------------------------------------------------------------
154
155
156 ### 5.2.3 Example: Return Levels - Create Figure 5.2.3
157
158 # Graph Frame:
159 par(mfrow = c(2, 2), cex = 0.7)
160 ###
161
162 # Create p and x Vectors:
163 p = seq(0.001, 0.999, length = 500)
164 x = -1/log(1-p)
165 ###
166
167 # Plot Return Levels:
168 plot (x, qgev(1-p, xi = 0) , type = "l", log = "x",
169 xlab = "-1/log(1-p)", ylab = "Return level",
170 ylim = c(-2, 23), main = "Return Levels", lwd = 2)
171 for (xi in c(-0.30, -0.15, 0.15, 0.30))
172 lines(x, qgev(1-p, xi = xi), col = "steelblue")
173 grid()
174 ###
175
176 # Add Labels:
177 text(x = rep(450, 5), y = c(1.9, 5.0, 7.3, 12, 21),
178 labels = c("-0.30", "-0.15", "0", "0.15", "0.30"))
179 ###
180
181
182 # ------------------------------------------------------------------------------
183
184
185 ### 5.2.4 Example: Convergence of Exponential Distribution - Figue 5.2.4
186
187 # Graph Frame:
188 par(mfrow = c(2, 2), cex = 0.7)
189 ###
190
191 # Functions:
192 an = function(n) {1}
193 bn = function(n) {log(n)}
194 ###
195
196 # Plot Convergence:
197 x = seq(-2, 4, length = 200)
198 plot(x, pgev(x, xi = 0), lwd = 2, type = "l",
199 main = "Convergence of Exp Maxima")
200 grid()
201 for ( n in c(10, 5, 3, 2, 1) )
202 lines(x, y = (pexp(an(n)*x+bn(n)))^n, col = "steelblue")
203 ###
204
205 # Alternative Plot:
206 plot(-log(-log(pgev(x, xi = 0))), x, lwd = 2, type = "l",
207 main = "Convergence of Exp Maxima")
208 grid()
209 for ( n in c(10, 5, 3, 2, 1) ) {
210 y = ( pexp( an(n)*x+bn(n) ) )^n; s = -log(-log(y))
211 lines(s[s > -2], x[s > -2], col = "steelblue")
212 }
213 ###
214
215
216 # ------------------------------------------------------------------------------
217
218
219 ### 5.2.5 Example: Convergence of Normal Distribution - Figure 5.2.5
220
221 # Graph Frame:
222 par(mfrow = c(2, 2), cex = 0.7)
223 ###
224
225 # Functions:
226 an = function(n) { 1/sqrt(2*log(n)) }
227 bn = function(n) { sqrt(2*log(n)) -
228 ( log(log(n))+log(4*pi) ) / sqrt(2*log(n)) /2 }
229 ###
230
231 # Plot Convergence:
232 x = seq(-2, 5, length = 500)
233 plot(x, pgev(x, xi = 0), lwd = 2, type = "l",
234 main = "Convergence of Gaussian Maxima")
235 grid()
236 for ( n in c(100, 50, 10, 5, 2) )
237 lines(x, y = (pnorm(an(n)*x+bn(n)))^n, col = "steelblue")
238 ###
239
240 # Alternative Plot:
241 plot(-log(-log(pgev(x, xi = 0))), x, xlim = c(-2, 12), lwd = 2,
242 type = "l", main = "Convergence of Gaussian Maxima")
243 grid()
244 x = seq(-2, 12, length = 500)
245 for ( n in c(100, 50, 10, 5, 2) ) {
246 y = (pnorm(an(n)*x+bn(n)))^n; s = -log(-log(y))
247 lines(s[x < 5], x[x < 5], col = "steelblue")
248 }
249 ###
250
251
252 # ------------------------------------------------------------------------------
253
254
255 ### 5.2.6 Example: GEV Probability Weighted Moments Fit - Figure 5.2.6
256
257 # Graph Frame and Settings:
258 par(mfrow = c(2, 2), cex = 0.7)
259 set.seed(4711)
260 ###
261
262 # Create and Plot the Random Variables:
263 x = rgev(n = 8000, xi = 0.3, mu = 0, sigma = 1)
264 plot(x, type = "h", main = "Random Variables", col = "steelblue")
265 mtext("Simulated GEV Data", line = 0.5, cex = 0.5)
266 lines(x = c(0, length(x)), y = c(0, 0), col = "grey", lty = 3)
267 ###
268
269 # PWM Estimate:
270 parm.fit = gevFit(x, type = "pwm")
271
272 # Print Estimated Results:
273 print(parm.fit)
274
275 # Generated Output:
276 # Call:
277 # gevFit(x = x, type = "pwm")
278 #
279 # Estimation Type: gev pwm
280 #
281 # Estimated Parameters:
282 # xi sigma mu
283 # 0.28422082 1.01273658 0.00366702
284
285 # Plot Density:
286 d = density(x, n = 200)
287 plot(d$x, d$y, xlim = c(-5, 15), ylim = c(0, 0.4), pch = 19,
288 xlab = "x", ylab = "density", main = "GEV Density", col = "steelblue")
289 grid()
290 mtext("Simulated GEV Data: PWM Estimate", line = 0.5, cex = 0.5)
291 s = seq(-5, 15, length = 200)
292 lines(s, dgev(s, xi = xi))
293 ###
294
295
296 # ------------------------------------------------------------------------------
297
298
299 ### 5.2.8 Example: BMW Probability Weighted Moments Fit - Figure 5.2.7
300
301 # Graph Frame:
302 par(mfrow = c(2, 2), cex = 0.7)
303 ###
304
305 # Load Data and Convert to Numeric Vector:
306 BMW.RET = as.timeSeries(data(bmw.ret))
307 bmwres = as.vector(BMW.RET)
308 blocklength = 63
309 ###
310
311 # Plot Time Series Data:
312 plot(bmwres, type = "h", main = "Daily log Returns", col = "steelblue")
313 grid()
314 abline(h = mean(bmwres), lty = 3, col = "grey")
315 ###
316
317 # Create Block Maxima of Lower Tail:
318 x = blockMaxima(-bmwres, block = blocklength, col = "steelblue", lwd = 1.5)
319 mtext("Block Maxima - Lower Tail", line = 0.5, cex = 0.5)
320 ###
321
322 # PWM Estimate:
323 fit = gevFit(x, type = "pwm")
324 xi = fit$par.ests[1]
325 sigma = fit$par.ests[2]
326 mu = fit$par.ests[3]
327 ###
328
329 # Histogram Plot and GEV Density:
330 hist(x, nclass = 20, probability = TRUE, col = "steelblue",
331 border = "white", main = "Block Maxima - Histogram")
332 s = seq(0, max(x), length = 500)
333 lines(s, dgev(s, xi, mu, sigma), lwd = 2, col = "brown")
334 mtext("Line: GEV Fit", line = 0.5, cex = 0.5)
335 ###
336
337 # QQ-Plot:
338 plot(sort(x), qgev(ppoints(x), xi, mu, sigma), pch = 19,
339 col = "steelblue", main="QQ-Plot: Empirical / GEV",
340 xlab = "empirical rvs", ylab = "GEV df")
341 lines(c(min(x), max(x)), c(min(x), max(x)))
342 grid()
343 ###
344
345
346 # ------------------------------------------------------------------------------
347
348
349 ### 5.2.8 Example: BMW Maximum Log Likelihood Fit - Figure 5.2.8
350
351 # Graph Frame:
352 par(mfrow = c(2, 2), cex = 0.7)
353 ###
354
355 # Load Data, Take Loss Tail:
356 BMW.RET = -as.timeSeries(data(bmw.ret))
357 ###
358
359 # PWM Estimate:
360 fit = gevFit(BMW.RET, block = 63, type = "mle")
361 summary(fit)
362 ###
363
364
365 # ------------------------------------------------------------------------------
366
367
368 ### Example: Alternatives to Print, Plot and Summarize 'gevFit' Objects
369
370
371 # Load Data, Take Loss Tail and Fit:
372 DAX.RET = -as.timeSeries(data(dax.ret))
373 fit = gevFit(DAX.RET, block = 63, type = "mle")
374 ###
375
376 # Print fitted Parameters:
377 print(fit)
378 ###
379
380 # Create Summary Report Including Figures:
381 par(mfrow = c(2, 2), cex = 0.7)
382 summary(fit)
383 ###
384
385 # Create Summary Report With Interactive Plots:
386 par(mfrow = c(1, 1))
387 summary(fit, which = "ask")
388 ###
389
390 # Just Show the Quantile-Quantile Plot:
391 par(mfrow = c(1, 1))
392 plot(fit, which = 4)
393 ###
394
395
396 # ------------------------------------------------------------------------------
397
398
399 ### Example: Use Calendar Blocks:
400
401 # Load Data, Take Loss Tail and Fit:
402 DAX.RET = -as.timeSeries(data(dax.ret))
403 # fit = gevFit(DAX.RET, block = "quarter", type = "mle")
404 # check does not yet work ...
405 ###
406
407
408 # ------------------------------------------------------------------------------
409
410
411 ### Example: gevglmFit
412
413 # Load Data and Convert to Numeric Vector:
414 BMW.RET = as.timeSeries(data(bmw.ret))
415 bmwres = as.vector(BMW.RET)
416 blocklength = 63
417 ###
418
419 # Fit GEV Data by Max Log Likelihood Method a la ISMEV:
420 fit = gevglmFit(x)
421 summary(fit)
422 ###
423
424 # Profile Likelihood:
425 gevglmprofxiPlot(fit, xlow = 0.15, xup = 0.60)
426 title(main = "Profile Likelihood for Xi")
427 gevglmprofPlot(fit, m = 100, xlow = 0.05, xup = 0.15)
428 title(main = "Profile Likelihood for Quantile 0.01")
429 ###
430
431
432 # ------------------------------------------------------------------------------
433
434
435 ### 5.2.8 Example: Hill's Estimator
436
437 # Graph Frame:
438 par(mfrow = c(3, 2), cex = 0.7)
439 ###
440
441 # Simulate and Load Data:
442 set.seed(4771)
443 x1 = rsymstb(10000, alpha = 1.8)
444 data(nyseres)
445 x2 = nyseres[, 1]
446 ###
447
448 # Hill Plot with Errors for Upper and Lower Tails:
449 result = hillPlot( x1, autoscale = FALSE, ylim = c(0, 3.5))
450 result = hillPlot( x2, autoscale = FALSE, ylim = c(0, 6.0))
451 result = hillPlot(-x1, autoscale = FALSE, ylim = c(0, 3.5))
452 result = hillPlot(-x2, autoscale = FALSE, ylim = c(0, 6.0))
453 ###
454
455
456 # ------------------------------------------------------------------------------
457
458
459 ### 5.2.9 Example: Shape Parameter Summary Plots
460
461 # Graph Frame:
462 par(mfrow = c(3, 2), cex = 0.7)
463
464 # Load Data:
465 data(nyseres)
466
467 # Chart Parameters:
468 tails = c( 0.01, 0.02, 0.03, 0.04,0.05, 0.06, 0.07, 0.08, 0.09, 0.10)
469 doplot = c(FALSE,FALSE,FALSE,FALSE,TRUE,FALSE,FALSE,FALSE,FALSE,FALSE)
470
471 # Calculate and Plot Shape Parameters:
472 s = shaparmPlot(x = nyseres, tails = tails,
473 doplot = doplot, doprint = TRUE, xi.range = c(-1, 3),
474 alpha.range = c(0, 8))
475 ###
476
477
478 # ------------------------------------------------------------------------------
479
480
481 ### 5.2.10 Example: GEV Maximum Likelihood Fitting
482
483 # Graph Frame:
484 par(mfrow = c(4, 2), cex = 0.7)
485
486 # Load Data:
487 data(nyseres)
488 nyseres = nyseres[, 1]
489 ts.plot(nyseres, main = "Log Returns")
490 mtext("NYSE Index Residuals", line = 0.5, cex = 0.5)
491 x = blockMaxima(-nyseres, block = 63)
492 mtext("Lower Tail: Quarterly Data", line = 0.5, cex = 0.5)
493
494 # Fit GEV Data by Max Log Likelihood Method a la ISMEV:
495 fit = gevglmFit(x)
496 summary(fit)
497
498 # Generated Output:
499 #
500 # Call:
501 # gevglmFit(x = x)
502 #
503 # Estimation Type: gevglm mle
504 #
505 # Estimated Parameters:
506 # xi sigma mu
507 # 0.317408547 0.005641637 0.014932832
508 #
509 # Standard Deviations:
510 # xi sigma mu
511 # 0.0723993029 0.0003170321 0.0005216084
512 #
513 # Log-Likelihood Value: -457.9648
514 # Type of Convergence: 0
515
516 # Profile Likelihood:
517 gevglmprofxiPlot(fit, xlow = 0.15, xup = 0.60)
518 title(main = "Profile Likelihood for Xi")
519 gevglmprofPlot(fit, m = 100, xlow = 0.05, xup = 0.15)
520 title(main = "Profile Likelihood for Quantile 0.01")
521 ###
522
523
524 # ------------------------------------------------------------------------------
525
526
527
528
529 ### ADDON:
530
531
532
533
534
535 ### Example: GEV Maximum Likelihood Estimation Fit
536
537 # Fit the GEV via the Maximum likelihood approach.
538 # Investigate the data from BMW Stocks
539
540 # Settings:
541 par(mfrow = c(2, 2), cex = 0.7)
542 data(nyseres)
543 nyseres = nyseres[, 1]
544 ts.plot(nyseres, main = "Log Returns")
545 mtext("NYSE Index Residuals", line = 0.5, cex = 0.5)
546 x = blockMaxima(-nyseres, block = 63)
547 mtext("Lower Tail: Quarterly Data", line = 0.5, cex = 0.5)
548
549 # Fit GEV Data by Max Log Likelihood Method a la ISMEV:
550 fit = gevglmFit(x)
551 print(fit)
552 summary(fit)
553
554 # Profile Likelihood:
555 gevglmprofxiPlot(fit, xlow = 0.15, xup = 0.60)
556 title(main = "Profile Likelihood for Xi")
557 gevglmprofPlot(fit, m = 100, xlow = 0.05, xup = 0.15)
558 title(main = "Profile Likelihood for Quantile 0.01")
559
560 # Fit GEV Data by Max Log Likelihood Method a la EVIS:
561 fit = gevFit(x, type = "mle")
562 print(fit)
563 summary(fit)
564
565
566 # ------------------------------------------------------------------------------
567
568
569 ### Example: GEV Probability Weighted Moments Fit
570
571 # Estimate the parameters of a simulated GEV
572 # with the method of probability weighted
573 # moments.
574
575 # Settings:
576 par(mfrow = c(2, 2), cex = 0.6)
577 n = 8000
578 xmax.density = 15
579 parm0 = list(xi = 1/4, mu = 0.0, sigma = 1.0)
580
581 # Create and Plot the Random Variables:
582 x = rgev(n, xi = parm0$xi, mu = parm0$mu, sigma = parm0$sigma)
583 plot(x, type = "h", main = "Random Variables")
584 mtext("Simulated GEV Data", line = 0.5, cex = 0.5)
585 lines(x = c(0, length(x)), y = c(0, 0), col = "steelblue3")
586 lines(x = c(0, length(x)), y = c(-1/0.3, -1/0.3), col = "steelblue3")
587
588 # PWM Estimate:
589 parm = gevFit(x, type = "pwm")
590 parm
591
592 # Plot Empirical and Estimated Densities:
593 d = density(x, n = 200)
594 plot(d$x, d$y, xlim = c(-5, 15), ylim=c(0, 0.4),
595 xlab = "x", ylab = "density", main = "GEV Density")
596 mtext("Simulated GEV Data", line = 0.5, cex = 0.5)
597 s = seq(-5, 15, length = 200)
598 lines(s, dgev(s, xi = parm0$xi, mu = parm0$mu,
599 sigma = parm0$sigma), col = "steelblue3")
600
601
602 # ------------------------------------------------------------------------------
603
604
605 ### Example: Shape Parameter Plot
606
607 # Plot the shape parameter obtained from MDA estimators
608 # for the NYSE Composite Index log returns.
609
610 # Settings:
611 par(mfcol = c(3, 2), err = -1, cex = 0.6)
612 data(nyseres)
613
614 # Chart Parameters = Plot for 'tail=0.05':
615 tails = c( 0.01, 0.02, 0.03, 0.04, 0.05, 0.06, 0.07, 0.08, 0.09, 0.10)
616 doplot = c(FALSE,FALSE,FALSE,FALSE, TRUE,FALSE,FALSE,FALSE,FALSE,FALSE)
617
618 # Calculate and Plot Shape Parameters:
619 s = shaparmPlot(x = nyseres, tails = tails,
620 doplot = doplot, doprint = TRUE, xi.range = c(-1, 3),
621 alpha.range = c(0, 8))
622
623
624 ################################################################################
625
626
627 ⏎
+0
-167
demo/xmpDWChapter53.R less more
0 #
1 # Examples from the Monograph:
2 # "Rmetrics - Financial Engineering and Computational Finance"
3 # written by Diethelm Wuertz
4 # ISBN to be published
5 #
6 # Details:
7 # Chapter 5.3
8 # Extremes via Point Processes
9 #
10 # List of Examples, Exercises and Code Snippets:
11 #
12 # Example: POT Point Process - Figure 5.3.1
13 #
14 # *** This list is not yet complete ***
15 #
16 # Author:
17 # (C) 2002-2004, Diethelm Wuertz, GPL
18 # www.rmetrics.org
19 # www.itp.phys.ethz.ch
20 # www.finance.ch
21 #
22
23
24 ################################################################################
25
26
27 ### Example: POT Point Process - Figure 5.3.1
28
29 # Plot the point Process p(n) for n = 5, 10, 100, 500, 1000,
30 # 10000 respectivel with the X(i) exponentially distributed
31
32 # Settings:
33 par(mfrow = c(2, 3), cex = 0.7)
34 x = seq(-2, 4, length = 200)
35 set.seed(671)
36 ###
37
38 # Point Process:
39 an = function(n) {1}
40 bn = function(n) {log(n)}
41 n = c(5, 10, 100, 500, 1000, 10000)
42 titles = c("n = 5", "n = 10", "n = 100", "n = 500",
43 "n = 1000", "n = 10000")
44 x = rexp(n[length(n)])
45 ###
46
47 # Graphs:
48 for ( i in 1:length(n) ) {
49 plot( (1:n[i])/(n[i]+1), (x[1:n[i]]-bn(n[i]))/an(n[i]),
50 xlab = "x", ylab = "y", ylim = c(-10, 3), pch = 19,
51 main = titles[i], col = "steelblue", cex = 0.5)
52 print(bn(n[i]))
53 abline(h = -bn(n[i]), lty = 3)
54 }
55 ###
56
57
58 ################################################################################
59
60
61
62
63
64
65 # Example: POT Mean Residual Life Plot
66
67 # Create a mean residual life plot. Include
68 # approximate confidence intervals, by default 95%
69
70 # Graph Frame:
71 par(mfrow = c(2, 2), cex = 0.6)
72 BMW.RET = -as.timeSeries(data(bmw.ret))
73 DAX.RET = -as.timeSeries(data(dax.ret))
74 ###
75
76 # Mean Residual Life Plot - BMW Data:
77 mrlPlot(-BMW.RET)
78 mtext("BMW Losses", line = 0.5, cex = 0.5)
79 ###
80
81 # Mean Residual Life Plot - BMW Data:
82 mrlPlot(-DAX.RET)
83 mtext("DAX Losses", line = 0.5, cex = 0.5)
84 ###
85
86
87 # ------------------------------------------------------------------------------
88
89
90
91
92 # Example: POT Parameter Estimation
93
94 # Estimate the parameters (xi, mu, sigma) for a data vector
95 # x from the point process over a threshold u using the
96 # function ppFit().
97
98
99 # Settings:
100 par(mfrow = c(3, 2), cex = 0.6)
101 data(nyseres)
102 data = nyseres[, 1]
103
104
105 # NYSE Residuals:
106 plot(data, type = "l", ylim = c(-0.22, +0.22),
107 main = "log Returns")
108 mtext("NYSE Residuals", line = 0.5, cex = 0.5)
109
110
111 # Point Process of Threshold Exceedences:
112 u = 0.02
113 y = data[data < -u]
114 x = (1:length(data))[data < -u]
115 points(x, y, col = 2)
116 plot(x, -y-u, type = "h", main = "Peaks over Threshold:")
117
118
119 # Point Process Fit:
120 fit = gpdFit(x = -data, nextremes = length(x), type = "mle")
121 print(fit)
122 summary(fit)
123
124
125
126
127 # ------------------------------------------------------------------------------
128
129
130
131 # Example: POT Parameter Estimation
132
133 # Estimate the parameters (xi, mu, sigma) for a data vector
134 # x from the point process over a threshold u using the
135 # function ppFit().
136
137 # Settings:
138 par(mfcol = c(3, 2), cex = 0.6)
139 data(nyseres)
140 data = nyseres[, 1]
141
142
143 # NYSE Residuals:
144 plot(data, type = "l", ylim = c(-0.22, +0.22), main = "log Returns")
145
146
147 # Point Process of Threshold Exceedences:
148 u = 0.02
149 y = data[data < -u]
150 x = (1:length(data))[data < -u]
151 points(x, y, col = 5)
152
153
154 # Point Process Fit:
155 fit = ppFit(x = -data, threshold = u, nobs = 252)
156 print(fit)
157 summary(fit)
158
159
160
161
162 # ------------------------------------------------------------------------------
163
164
165
166
+0
-139
demo/xmpDWChapter54.R less more
0 #
1 # Examples from the Monograph:
2 # "Rmetrics - Financial Engineering and Computational Finance"
3 # written by Diethelm Wuertz
4 # ISBN to be published
5 #
6 # Details:
7 # Chapter 5.4
8 # The Extremal Index
9 #
10 # List of Examples, Exercises and Code Snippets:
11 #
12 # Example: Extremal Index Plot
13 # Example: Extremal Indexes Plot
14 #
15 # *** This list is not yet complete ***
16 #
17 #
18 # Author:
19 # (C) 2002-2004, Diethelm Wuertz, GPL
20 # www.rmetrics.org
21 # www.itp.phys.ethz.ch
22 # www.finance.ch
23 #
24
25
26 ################################################################################
27
28
29 ### Example: Extremal Index Plot
30
31
32 # Plot the extremal as obtained from the
33 # BMW stock and NYSE Composite Index data.
34 ###
35
36 # Settings:
37 par(mfrow = c(3, 2), cex = 0.6)
38 data(bmwres)
39 data(nyseres)
40
41 # Investigate BMW log-Returns:
42 x = bmwres[, 1]
43 exindexPlot( x, block = 63, autoscale = FALSE, ylim = c(0, 1.2))
44 exindexPlot(-x, block = 63, autoscale = FALSE, ylim = c(0, 1.2))
45
46 # Investigate NYSE log-Returns:
47 x = nyseres[, 1]
48 exindexPlot( x, block = 50, autoscale = FALSE, ylim = c(0, 1.2))
49 exindexPlot(-x, block = 50, autoscale = FALSE, ylim = c(0, 1.2))
50
51 # Reverse Plottype:
52 exindexPlot( x, block = 50, plottype = "K", autoscale = FALSE,
53 ylim = c(0, 1.2))
54 exindexPlot(-x, block = 50, plottype = "K", autoscale = FALSE,
55 ylim = c(0, 1.2))
56 ###
57
58
59 # ------------------------------------------------------------------------------
60
61
62 ### Example: Extremal Indexes Plot
63
64 # Plot the extremal; index for a long(80'000 points)
65 # and a short (8'000 points) series of Student-t
66 # distributed (4 degress of freedom) random variables
67 # together with their EMA smoothed (lambda=0.2) series.
68 # Compare the result with the extremal index obtained
69 # from the BMW stock and NYSE Composite Index data.
70 ###
71
72 # Settings:
73 par(mfrow = c(4, 2), cex = 0.5)
74 set.seed(773)
75 data(bmwres)
76 data(nyseres)
77 blocklength = 500
78 ###
79
80 # Investigate Large Sample Random Variables:
81 x = rt(n = 80000, df = 4)
82 exindexesPlot(x, blocklength)
83 mtext("Student - 80000 points", line = 0.5, cex = 0.5)
84 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
85 ###
86
87 # Investigate EMA-Smoothed rvs:
88 lambda = 0.2
89 xlam = x * lambda
90 xlam[1] = x[1]
91 x = filter(xlam, filter = (1-lambda), method = "rec")
92 exindexesPlot(x, blocklength)
93 mtext("EMA Student - 80000 points", line = 0.5, cex = 0.5)
94 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
95 ###
96
97 # Investigate Small Sample Random Variables:
98 x = rt(n = 8000, df = 4)
99 exindexesPlot(x, blocklength)
100 mtext("Student - 8000 points", line = 0.5, cex = 0.5)
101 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
102 ###
103
104 # Investigate EMA-Smoothed rvs:
105 lambda = 0.2
106 xlam = x * lambda
107 xlam[1] = x[1]
108 x = filter(xlam, filter = (1-lambda), method = "rec")
109 exindexesPlot(x, blocklength)
110 mtext("EMA Student - 8000 points", line = 0.5, cex = 0.5)
111 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
112 ###
113
114 # Investigate BMW log-Returns:
115 x = bmwres[, 1]
116 length(x)
117 exindexesPlot(x, blocklength)
118 mtext("BMW - 6146 points - upper", line = 0.5, cex = 0.5)
119 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
120 exindexesPlot(-x, blocklength)
121 mtext("BMW - 6146 points - lower", line = 0.5, cex = 0.5)
122 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
123 ###
124
125 # Investigate NYSE log-Returns:
126 x = nyseres[, 1]
127 length(x)
128 exindexesPlot( x, blocklength)
129 mtext("NYSE - 8390 points - upper", line = 0.5, cex = 0.5)
130 lines(x=c(0.990, 0.999), y = c(1, 1), col = "red")
131 exindexesPlot(-x, blocklength)
132 mtext("NYSE - 8390 points - lower", line = 0.5, cex = 0.5)
133 lines(x = c(0.990, 0.999), y = c(1, 1), col = "red")
134 ###
135
136
137 ################################################################################
138
+364
-0
demo/xmpZWChapter05.R less more
0
1
2 # CHAPTER 5: Modeling Extreme Values
3 #
4 # 5.1 Introduction
5 # 5.2 Modeling Maxima and Worst Cases
6 # 5.3 Modeling Extremes Over High Thresholds
7 # 5.4 Hill's Non-parametric Estimator of Tail Index
8 # 5.5 References
9
10
11 ################################################################################
12 # Chapter 5.1 - Introduction
13
14
15 # Load Data - A numeric vector with "times" attribute:
16 data(sp.raw)
17 class(sp.raw)
18 # Convert into a timeSeries object:
19 sp.raw.ts = timeSeries(data = sp.raw,
20 charvec = as.character(attr(sp.raw, "times")),
21 units = "SP", tz = "GMT", FinCenter = "GMT")
22 class(sp.raw.ts)
23 head(sp.raw.ts)
24 ###
25
26 # Create percentage return time series:
27 spto87 = getReturns(sp.raw.ts, type = "discrete", percentage = TRUE)
28 par(mfrow = c(2, 1), cex = 0.7)
29 plot(sp.raw.ts, main = "Daily Closing Prices", ylab = "Price")
30 plot(spto87, main = "Daily Percentage Returns", ylab = "Return")
31
32
33 # Plot gev distributions and densities
34 # CDFs:
35 z.vals = seq(-5, 5, length = 200)
36 cdf.f = ifelse((z.vals > -2), pgev(z.vals, xi = 0.5), 0)
37 cdf.w = ifelse((z.vals < 2), pgev(z.vals, xi = -0.5), 1)
38 cdf.g = exp(-exp(-z.vals))
39 plot(z.vals, cdf.w, type = "l", xlab = "z", ylab = "H(z)")
40 lines(z.vals, cdf.f, type = "l", lty = 2)
41 lines(z.vals, cdf.g, type = "l", lty = 3)
42 legend(-5, 1, legend = c("Weibull H(-0.5, 0, 1)",
43 "Frechet H(0.5, 0, 1)", "Gumbel H(0, 0, 1)"), lty = 1:3)
44 # PDFs:
45 pdf.f = ifelse((z.vals > -2), dgev(z.vals, xi = 0.5), 0)
46 pdf.w = ifelse((z.vals < 2), dgev(z.vals, xi = -0.5), 0)
47 pdf.g = exp(-exp(-z.vals))*exp(-z.vals)
48 plot(z.vals, pdf.w, type = "l", xlab = "z", ylab = "h(z)")
49 lines(z.vals, pdf.f, type = "l", lty = 2)
50 lines(z.vals, pdf.g, type = "l", lty = 3)
51 legend(-5.25, 0.4, legend = c("Weibull H(-0.5, 0, 1)",
52 "Frechet H(0.5, 0, 1)", "Gumbel H(0, 0, 1)"), lty = 1:3)
53
54
55 # Analysis of Maxima Data
56
57
58 # Analysis of S&P 500 Daily Returns
59 # Jan 5, 1960 - Oct 16, 1987
60
61
62 # Plot -1*(daily returns) upto 1987
63 class(spto87)
64 plot(-spto87)
65 qqPlot(spto87, strip.text = "Daily returns on S&P 500",
66 xlab = "Quantiles of standard normal",
67 ylab = "Quantiles of S&P 500")
68
69 qqnorm(spto87)
70
71 # Compute annual maxima using aggregateSeries
72 # and plot descriptive statistics
73
74 annualMax.sp500 = aggregateSeries(-spto87, by = "years",
75 FUN = max)
76 Xn = sort(seriesData(annualMax.sp500))
77 par(mfrow = c(2, 2))
78 plot(annualMax.sp500)
79 hist(seriesData(annualMax.sp500), xlab = "Annual maximum")
80 plot(Xn, -log(-log(ppoints(Xn))), xlab = "Annual maximum")
81 tmp = records(-spto87)
82 par(mfrow = c(1, 1))
83
84 # Estimate GEV CDF using annual blocks of daily returns
85 gev.fit.year = gev(-spto87, block = "year")
86 class(gev.fit.year)
87 names(gev.fit.year)
88
89 # Number of blocks
90 gev.fit.year$n
91
92 # plot block maxima
93 plot(gev.fit.year$data,
94 main = "Annual block maxima of negative daily returns",
95 ylab = "Mn")
96
97 # MLEs and estimated asymptotic standard errors
98 gev.fit.year$par.ests
99 gev.fit.year$par.ses
100
101 # 95% CI for xi
102 gev.fit.year$par.ests[1]-2*gev.fit.year$par.ses[1]
103 gev.fit.year$par.ests[1]+2*gev.fit.year$par.ses[1]
104
105 #
106 # plot method: This is better executed from the command line.
107 #
108
109 # par(mfrow = c(1, 2))
110 # plot(gev.fit.year)
111
112 # follow Coles and do a histogram and density plot of block
113 # maxima data using the fitted standardized extreme value
114 # data
115
116 # standardized block maxima
117 Zn = (seriesData(gev.fit.year$data) - gev.fit.year$par.ests["mu"])/
118 gev.fit.year$par.ests["sigma"]
119 Zn = sort(Zn)
120 # need to figure out how to plot a histogram and density estimate
121 # together. Use dgev to compute density values
122 gev.density = dgev(Zn, xi = gev.fit.year$par.ests["xi"])
123 plot(Zn, gev.density, type = "l")
124 hist(Zn)
125
126 # do qq-plot against gumbel for standardized maxima
127 # see Embrechts pg 293
128
129 plot(Zn, -log(-log(ppoints(Zn))))
130
131 # compute probability next year's maximum being a new record
132 1- pgev(max(gev.fit.year$data),
133 xi = gev.fit.year$par.ests["xi"],
134 mu = gev.fit.year$par.ests["mu"],
135 sigma = gev.fit.year$par.ests["sigma"])
136
137 # estimate 40 year return level
138 rlevel.year.40 = rlevel.gev(gev.fit.year, k.blocks = 40)
139 class(rlevel.year.40)
140 names(rlevel.year.40)
141 rlevel.year.40$rlevel
142
143 rlevel.year.40 = rlevel.gev(gev.fit.year, k.blocks = 40,
144 type = "RetLevel")
145 names(rlevel.year.40)
146
147 # compute return quantile
148 (1-(1/40))^(1/260)
149
150 # Estimate GEV CDF using quarterly blocks of daily returns
151 gev.fit.quarter = gev(-spto87, block = "quarter")
152 gev.fit.quarter$n
153 gev.fit.quarter$par.ests
154 gev.fit.quarter$par.ses
155
156 # 95% CI for xi
157 gev.fit.quarter$par.ests[1]-2*gev.fit.quarter$par.ses[1]
158 gev.fit.quarter$par.ests[1]+2*gev.fit.quarter$par.ses[1]
159
160 # probability that next quarter's maximum exceeds all previous
161 # maxima
162 1- pgev(max(gev.fit.quarter$data),
163 xi = gev.fit.quarter$par.ests["xi"],
164 mu = gev.fit.quarter$par.ests["mu"],
165 sigma = gev.fit.quarter$par.ests["sigma"])
166
167 # 40 quarter return level
168 rlevel.40.q = rlevel.gev(gev.fit.quarter, k.blocks = 40)
169
170 # 40 year or 160 quarter return level
171 rlevel.160.q = rlevel.gev(gev.fit.quarter, k.blocks = 160,
172 type = "RetLevel")
173 rlevel.160.q
174
175 # estimate GEV CDF for maximum data (for short losses)
176 gev.fit.sa = gev(spto87, "semester")
177 names(gev.fit.sa)
178
179 # number of blocks
180 gev.fit.sa$n
181 # block maxima
182 gev.fit.sa$data
183 # mles and estimated asymptotic standard errors
184 gev.fit.sa$par.ests
185 gev.fit.sa$par.ses
186
187 # fit gumbel distribution to annual maxima
188
189 gumbel.fit.year = gumbel(-spto87, block = "year")
190 class(gumbel.fit.year)
191 names(gumbel.fit.year)
192 gumbel.fit.year$par.ests
193 gumbel.fit.year$par.ses
194
195 #
196 # The following is better executed from the Command line.
197 #
198
199 # par(mfrow = c(1, 2))
200 # plot(gumbel.fit.year)
201 #
202 # 1- pgev(max(gumbel.fit.year$data), xi = 0,
203 # mu = gumbel.fit.year$par.ests["mu"],
204 # sigma = gumbel.fit.year$par.ests["sigma"])
205 #
206 # rlevel.gev(gumbel.fit.year, k.blocks = 40)
207 # par(mfrow = c(1, 1))
208
209
210 ############################################################################
211 # Modeling Excesses Over Thresholds
212 # using the Dainish Fire Loss Data
213
214
215 plot(danish, main = "Fire Loss Insurance Claims",
216 ylab = "Millions of Danish Krone")
217
218 # plot various GPD values
219 # CDFs
220 par(mfrow = c(1, 2))
221 y.vals = seq(0, 8, length = 200)
222 cdf.p = pgpd(y.vals, xi = 0.5)
223 cdf.p2 = ifelse((y.vals < 2), pgpd(y.vals, xi = -0.5), 1)
224 cdf.e = 1-exp(-y.vals)
225 plot(y.vals, cdf.p, type = "l", xlab = "y", ylab = "G(y)",
226 ylim = c(0, 1))
227 lines(y.vals, cdf.e, type = "l", lty = 2)
228 lines(y.vals, cdf.p2, type = "l", lty = 3)
229 legend(1, 0.2, legend = c("Pareto G(0.5, 1)", "Exponential G(0, 1)",
230 "Pareto II G(0.5, 1)"), lty = 1:3)
231
232 # PDFs
233 pdf.p = dgpd(y.vals, xi = 0.5)
234 pdf.p2 = ifelse((y.vals < 2), dgpd(y.vals, xi = -0.5), 0)
235 pdf.e = exp(-y.vals)
236 plot(y.vals, pdf.p, type = "l", xlab = "y", ylab = "g(y)",
237 ylim = c(0, 1))
238 lines(y.vals, pdf.e, type = "l", lty = 2)
239 lines(y.vals, pdf.p2, type = "l", lty = 3)
240 legend(2, 1, legend = c("Pareto g(0.5, 1)", "Exponential g(0, 1)",
241 "Pareto II g(-0.5, 1)"), lty = 1:3)
242 par(mfrow = c(1, 1))
243
244 # exploratory analysis
245
246 # qq-plots with exponential reference distribution
247 par(mfrow = c(1, 2))
248 qplot(-spto87, threshold = 1, main = "S&P 500 negative returns")
249 qplot(danish, threshold = 10, main = "Danish fire losses")
250
251 # mean excess plots
252 par(mfrow = c(1, 2))
253 me.sp500 = meplot(-spto87)
254 me.dainsh = meplot(danish)
255 class(me.sp500)
256 colIds(me.sp500)
257
258 # fit gpd to sp500 negative returns with u = 1
259 # only plot method is available
260
261 gpd.sp500.1 = gpd(-spto87, threshold = 1)
262 class(gpd.sp500.1)
263 names(gpd.sp500.1)
264
265 gpd.sp500.1$upper.converged
266 gpd.sp500.1$upper.thresh
267 gpd.sp500.1$n.upper.exceed
268 gpd.sp500.1$p.less.upper.thresh
269
270 gpd.sp500.1$upper.par.ests
271 gpd.sp500.1$upper.par.ses
272
273 # This is better executed from the command line.
274 # plot(gpd.sp500.1)
275 shape(-spto87, end = 600)
276
277 # fit gpd to danish fire insurance data
278 gpd.danish.10 = gpd(danish, threshold = 10)
279 gpd.danish.10$n.upper.exceed
280 gpd.danish.10$p.less.upper.thresh
281 gpd.danish.10$upper.par.ests
282 gpd.danish.10$upper.par.ses
283
284 par(mfrow = c(1, 2))
285 tailplot(gpd.danish.10)
286 shape(danish)
287
288 # estimating VaR and ES for sp500 data
289 # use quant, gpd.q, gpd.sfall, riskmeasures
290 riskmeasures(gpd.sp500.1, c(0.95, 0.99))
291 gpd.q(0.99, ci.type = "likelihood")
292 gpd.q(0.99, ci.type = "wald")
293 gpd.sfall(0.99)
294 gpd.sfall(0.99, ci.p = "wald")
295
296 # compute var and es assume normally distributed data
297 # make sure to compute confidence intervals
298 sp500.mu = mean(-spto87)
299 sp500.sd = sqrt(var(-spto87))
300 var.95 = sp500.mu + sp500.sd*qnorm(0.95)
301 var.99 = sp500.mu + sp500.sd*qnorm(0.99)
302 var.95
303 var.99
304
305 z95 = (var.95 - sp500.mu)/sp500.sd
306 z99 = (var.99 - sp500.mu)/sp500.sd
307 es.95 = sp500.mu + sp500.sd*dnorm(z95)/(1-pnorm(z95))
308 es.99 = sp500.mu + sp500.sd*dnorm(z99)/(1-pnorm(z99))
309 es.95
310 es.99
311
312 nobs = nrow(spto87)
313
314 se.var.99 = sqrt((var.95/nobs)*(1+0.5*qnorm(0.99)^2))
315
316 # estimating VaR and ES for danish fire loss data
317 riskmeasures(gpd.danish.10, c(0.95, 0.99))
318
319 danish.mu = mean(danish)
320 danish.sd = sqrt(var(danish))
321 var.95 = danish.mu + danish.sd*qnorm(0.95)
322 var.99 = danish.mu + danish.sd*qnorm(0.99)
323 var.95
324 var.99
325
326 z95 = (var.95 - danish.mu)/danish.sd
327 z99 = (var.99 - danish.mu)/danish.sd
328 es.95 = danish.mu + danish.sd*dnorm(z95)/(1-pnorm(z95))
329 es.99 = danish.mu + danish.sd*dnorm(z99)/(1-pnorm(z99))
330 es.95
331 es.99
332
333 tailplot(gpd.danish.10)
334 gpd.q(0.99, plot = TRUE)
335 gpd.sfall(0.99, plot = TRUE)
336
337 quant(danish, p = 0.99)
338
339
340 # Hill Analysis of sp500 Data
341
342
343 args(hill)
344 hill(-spto87, option = "xi", end = 500)
345 hill(s pto87, option = "xi", end = 500)
346
347
348 # Hill analysis of danish loss data
349
350
351 class(danish)
352 plot(danish)
353 hill.danish = hill(danish, option = "xi")
354 idx = (
355 hill.danish$threshold > = 9.8 &
356 hill.danish$threshold < = 10.2 )
357 hill.danish[idx, ]
358 hill.danish.q = hill(danish, option = "quantile", p = 0.99, end = 500)
359
360
361 ################################################################################
362
363 ⏎
+56
-18
inst/CHANGES.html less more
0
0 <HTML>
1 <HEAD>
2 <TITLE>Rmetrics::CHANGES</TITLE>
3 </HEAD>
4 <BODY BGCOLOR="WHITE">
15 <P>
26 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="7">
37 <FONT COLOR="#7F0000">Rmetrics</FONT></FONT></FONT></B>
1115
1216 <P>
1317 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">
14 2005-11-02 Built 220.10063</FONT></FONT>
18 2005-12-18 Built 221.10065</FONT></FONT>
1519 </B></P>
1620
1721
2226
2327 fBasics, fCalendar, fSeries, fMultivar, fExtremes, fOptions, fPortfolio
2428
29 ________________________________________________________________________________
30 Rmetrics VERSION 221.10065
31
32 2005-02-19 Rmetrics
33 Rmetrics has been compiled for R Version 2.2.1
34
35 2006-02-12 fCalendar
36 The explicit setting to timezone GMT is no longer necessary.
37
38 2006-02-12 fSeries
39 The long awaites GARCH functions are now available for simulating,
40 modelling, and forecasting GARCH and APARCH time series processes.
41
42 +++ many other smaller improvements and fixings ...
43
44 ________________________________________________________________________________
45 Rmetrics VERSION 220.10064
46
47 2005-12-01 fSeries: GarchModelling
48 Major improvements could be achieved for the fSeries Package for GARCH
49 Modelling, although the GARCH modelling functions are still in an
50 experimental state and not yet finished.
51
52 2005-12-01 fCalendar: timeDate and timeSeries
53 A paper was submitted to JSS describing 'timeDate' and 'timeSeries'
54 Classes. A draft can be downloaded from www.rmetrics.org.
55
56 2005-12-01
57 Updates of the following files (if it was necessary) are now available:
58 CHANGES.html, COPYING.html, COPYRIGHT.html, FAQ.html, README.html
59 DocFactSheet.pdf, DocRefCard.pdf, DocRmetrics.pdf
2560
2661 ________________________________________________________________________________
2762 Rmetrics VERSION 220.10063
2863 Rmetrics VERSION 211.10062
2964
3065 2005-11-02
31 This is a preliminary version with smaller modifications, updates, and
32 additions compared to Rmetrics 201.0061.
33
34 Not yet updated is the documentation included in DocFactSheet.pdf
35 Doc, DocRefcard.pdf, and DocRmetrics.pdf. These documents have Version
36 211.10062. This update is under progress.
37
38 The major effort was invested to make under both environments MS Windows
39 and Linux Rmetrics running based on the new compiler suite with
40 gfortran. Please note, that I have done this move for Rmetrics already
41 under MS Windows, although this is not yet done for R. The reason why
42 I have done this, is that I develop under MS Windows, and that I wan't
43 support two systems based on different compiler suites. The Mac Version
44 is not yet tested, but hopefully it will run.
45
66 This is a preliminary version with smaller modifications, updates, and
67 additions compared to Rmetrics 201.0061.
68
69 Not yet updated is the documentation included in DocFactSheet.pdf
70 Doc, DocRefcard.pdf, and DocRmetrics.pdf. These documents have Version
71 211.10062. This update is under progress.
72
73 The major effort was invested to make under both environments MS Windows
74 and Linux Rmetrics running based on the new compiler suite with
75 gfortran. Please note, that I have done this move for Rmetrics already
76 under MS Windows, although this is not yet done for R. The reason why
77 I have done this, is that I develop under MS Windows, and that I wan't
78 support two systems based on different compiler suites. The Mac Version
79 is not yet tested, but hopefully it will run without any problems.
80
4681 ________________________________________________________________________________
4782 Rmetrics VERSION 201.10061
4883
929964 "src/chardate.c" removed, now using R-package "date"
930965
931966
932 </PRE> ⏎
967 </PRE>
968 </BODY>
969 </HTML>
970 ⏎
+0
-363
inst/COPYING.html less more
0
1 <P>
2 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="7">
3 <FONT COLOR="#7F0000">Rmetrics</FONT></FONT></FONT></B>
4 <FONT FACE="Arial,Helvetica,Monaco"><B><FONT SIZE="3">
5 <FONT COLOR="#7F0000">Copy of the "GNU General Public License"</FONT></FONT></FONT>
6 </B></P>
7
8 <P ALIGN=CENTER>
9 <HR ALIGN=CENTER WIDTH="100%" SIZE="2">
10 </P>
11
12 <P>
13 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">
14 2005-11-02 Built 220.10063</FONT></FONT>
15 </B></P>
16
17
18 <PRE>
19
20 GNU GENERAL PUBLIC LICENSE
21 Version 2, June 1991
22
23 Copyright (C) 1989, 1991 Free Software Foundation, Inc.
24 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
25 Everyone is permitted to copy and distribute verbatim copies
26 of this license document, but changing it is not allowed.
27
28 Preamble
29
30 The licenses for most software are designed to take away your
31 freedom to share and change it. By contrast, the GNU General Public
32 License is intended to guarantee your freedom to share and change free
33 software--to make sure the software is free for all its users. This
34 General Public License applies to most of the Free Software
35 Foundation's software and to any other program whose authors commit to
36 using it. (Some other Free Software Foundation software is covered by
37 the GNU Library General Public License instead.) You can apply it to
38 your programs, too.
39
40 When we speak of free software, we are referring to freedom, not
41 price. Our General Public Licenses are designed to make sure that you
42 have the freedom to distribute copies of free software (and charge for
43 this service if you wish), that you receive source code or can get it
44 if you want it, that you can change the software or use pieces of it
45 in new free programs; and that you know you can do these things.
46
47 To protect your rights, we need to make restrictions that forbid
48 anyone to deny you these rights or to ask you to surrender the rights.
49 These restrictions translate to certain responsibilities for you if you
50 distribute copies of the software, or if you modify it.
51
52 For example, if you distribute copies of such a program, whether
53 gratis or for a fee, you must give the recipients all the rights that
54 you have. You must make sure that they, too, receive or can get the
55 source code. And you must show them these terms so they know their
56 rights.
57
58 We protect your rights with two steps: (1) copyright the software, and
59 (2) offer you this license which gives you legal permission to copy,
60 distribute and/or modify the software.
61
62 Also, for each author's protection and ours, we want to make certain
63 that everyone understands that there is no warranty for this free
64 software. If the software is modified by someone else and passed on, we
65 want its recipients to know that what they have is not the original, so
66 that any problems introduced by others will not reflect on the original
67 authors' reputations.
68
69 Finally, any free program is threatened constantly by software
70 patents. We wish to avoid the danger that redistributors of a free
71 program will individually obtain patent licenses, in effect making the
72 program proprietary. To prevent this, we have made it clear that any
73 patent must be licensed for everyone's free use or not licensed at all.
74
75 The precise terms and conditions for copying, distribution and
76 modification follow.
77
78 GNU GENERAL PUBLIC LICENSE
79 TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
80
81 0. This License applies to any program or other work which contains
82 a notice placed by the copyright holder saying it may be distributed
83 under the terms of this General Public License. The "Program", below,
84 refers to any such program or work, and a "work based on the Program"
85 means either the Program or any derivative work under copyright law:
86 that is to say, a work containing the Program or a portion of it,
87 either verbatim or with modifications and/or translated into another
88 language. (Hereinafter, translation is included without limitation in
89 the term "modification".) Each licensee is addressed as "you".
90
91 Activities other than copying, distribution and modification are not
92 covered by this License; they are outside its scope. The act of
93 running the Program is not restricted, and the output from the Program
94 is covered only if its contents constitute a work based on the
95 Program (independent of having been made by running the Program).
96 Whether that is true depends on what the Program does.
97
98 1. You may copy and distribute verbatim copies of the Program's
99 source code as you receive it, in any medium, provided that you
100 conspicuously and appropriately publish on each copy an appropriate
101 copyright notice and disclaimer of warranty; keep intact all the
102 notices that refer to this License and to the absence of any warranty;
103 and give any other recipients of the Program a copy of this License
104 along with the Program.
105
106 You may charge a fee for the physical act of transferring a copy, and
107 you may at your option offer warranty protection in exchange for a fee.
108
109 2. You may modify your copy or copies of the Program or any portion
110 of it, thus forming a work based on the Program, and copy and
111 distribute such modifications or work under the terms of Section 1
112 above, provided that you also meet all of these conditions:
113
114 a) You must cause the modified files to carry prominent notices
115 stating that you changed the files and the date of any change.
116
117 b) You must cause any work that you distribute or publish, that in
118 whole or in part contains or is derived from the Program or any
119 part thereof, to be licensed as a whole at no charge to all third
120 parties under the terms of this License.
121
122 c) If the modified program normally reads commands interactively
123 when run, you must cause it, when started running for such
124 interactive use in the most ordinary way, to print or display an
125 announcement including an appropriate copyright notice and a
126 notice that there is no warranty (or else, saying that you provide
127 a warranty) and that users may redistribute the program under
128 these conditions, and telling the user how to view a copy of this
129 License. (Exception: if the Program itself is interactive but
130 does not normally print such an announcement, your work based on
131 the Program is not required to print an announcement.)
132
133 These requirements apply to the modified work as a whole. If
134 identifiable sections of that work are not derived from the Program,
135 and can be reasonably considered independent and separate works in
136 themselves, then this License, and its terms, do not apply to those
137 sections when you distribute them as separate works. But when you
138 distribute the same sections as part of a whole which is a work based
139 on the Program, the distribution of the whole must be on the terms of
140 this License, whose permissions for other licensees extend to the
141 entire whole, and thus to each and every part regardless of who wrote it.
142
143 Thus, it is not the intent of this section to claim rights or contest
144 your rights to work written entirely by you; rather, the intent is to
145 exercise the right to control the distribution of derivative or
146 collective works based on the Program.
147
148 In addition, mere aggregation of another work not based on the Program
149 with the Program (or with a work based on the Program) on a volume of
150 a storage or distribution medium does not bring the other work under
151 the scope of this License.
152
153 3. You may copy and distribute the Program (or a work based on it,
154 under Section 2) in object code or executable form under the terms of
155 Sections 1 and 2 above provided that you also do one of the following:
156
157 a) Accompany it with the complete corresponding machine-readable
158 source code, which must be distributed under the terms of Sections
159 1 and 2 above on a medium customarily used for software interchange; or,
160
161 b) Accompany it with a written offer, valid for at least three
162 years, to give any third party, for a charge no more than your
163 cost of physically performing source distribution, a complete
164 machine-readable copy of the corresponding source code, to be
165 distributed under the terms of Sections 1 and 2 above on a medium
166 customarily used for software interchange; or,
167
168 c) Accompany it with the information you received as to the offer
169 to distribute corresponding source code. (This alternative is
170 allowed only for noncommercial distribution and only if you
171 received the program in object code or executable form with such
172 an offer, in accord with Subsection b above.)
173
174 The source code for a work means the preferred form of the work for
175 making modifications to it. For an executable work, complete source
176 code means all the source code for all modules it contains, plus any
177 associated interface definition files, plus the scripts used to
178 control compilation and installation of the executable. However, as a
179 special exception, the source code distributed need not include
180 anything that is normally distributed (in either source or binary
181 form) with the major components (compiler, kernel, and so on) of the
182 operating system on which the executable runs, unless that component
183 itself accompanies the executable.
184
185 If distribution of executable or object code is made by offering
186 access to copy from a designated place, then offering equivalent
187 access to copy the source code from the same place counts as
188 distribution of the source code, even though third parties are not
189 compelled to copy the source along with the object code.
190
191 4. You may not copy, modify, sublicense, or distribute the Program
192 except as expressly provided under this License. Any attempt
193 otherwise to copy, modify, sublicense or distribute the Program is
194 void, and will automatically terminate your rights under this License.
195 However, parties who have received copies, or rights, from you under
196 this License will not have their licenses terminated so long as such
197 parties remain in full compliance.
198
199 5. You are not required to accept this License, since you have not
200 signed it. However, nothing else grants you permission to modify or
201 distribute the Program or its derivative works. These actions are
202 prohibited by law if you do not accept this License. Therefore, by
203 modifying or distributing the Program (or any work based on the
204 Program), you indicate your acceptance of this License to do so, and
205 all its terms and conditions for copying, distributing or modifying
206 the Program or works based on it.
207
208 6. Each time you redistribute the Program (or any work based on the
209 Program), the recipient automatically receives a license from the
210 original licensor to copy, distribute or modify the Program subject to
211 these terms and conditions. You may not impose any further
212 restrictions on the recipients' exercise of the rights granted herein.
213 You are not responsible for enforcing compliance by third parties to
214 this License.
215
216 7. If, as a consequence of a court judgment or allegation of patent
217 infringement or for any other reason (not limited to patent issues),
218 conditions are imposed on you (whether by court order, agreement or
219 otherwise) that contradict the conditions of this License, they do not
220 excuse you from the conditions of this License. If you cannot
221 distribute so as to satisfy simultaneously your obligations under this
222 License and any other pertinent obligations, then as a consequence you
223 may not distribute the Program at all. For example, if a patent
224 license would not permit royalty-free redistribution of the Program by
225 all those who receive copies directly or indirectly through you, then
226 the only way you could satisfy both it and this License would be to
227 refrain entirely from distribution of the Program.
228
229 If any portion of this section is held invalid or unenforceable under
230 any particular circumstance, the balance of the section is intended to
231 apply and the section as a whole is intended to apply in other
232 circumstances.
233
234 It is not the purpose of this section to induce you to infringe any
235 patents or other property right claims or to contest validity of any
236 such claims; this section has the sole purpose of protecting the
237 integrity of the free software distribution system, which is
238 implemented by public license practices. Many people have made
239 generous contributions to the wide range of software distributed
240 through that system in reliance on consistent application of that
241 system; it is up to the author/donor to decide if he or she is willing
242 to distribute software through any other system and a licensee cannot
243 impose that choice.
244
245 This section is intended to make thoroughly clear what is believed to
246 be a consequence of the rest of this License.
247
248 8. If the distribution and/or use of the Program is restricted in
249 certain countries either by patents or by copyrighted interfaces, the
250 original copyright holder who places the Program under this License
251 may add an explicit geographical distribution limitation excluding
252 those countries, so that distribution is permitted only in or among
253 countries not thus excluded. In such case, this License incorporates
254 the limitation as if written in the body of this License.
255
256 9. The Free Software Foundation may publish revised and/or new versions
257 of the General Public License from time to time. Such new versions will
258 be similar in spirit to the present version, but may differ in detail to
259 address new problems or concerns.
260
261 Each version is given a distinguishing version number. If the Program
262 specifies a version number of this License which applies to it and "any
263 later version", you have the option of following the terms and conditions
264 either of that version or of any later version published by the Free
265 Software Foundation. If the Program does not specify a version number of
266 this License, you may choose any version ever published by the Free Software
267 Foundation.
268
269 10. If you wish to incorporate parts of the Program into other free
270 programs whose distribution conditions are different, write to the author
271 to ask for permission. For software which is copyrighted by the Free
272 Software Foundation, write to the Free Software Foundation; we sometimes
273 make exceptions for this. Our decision will be guided by the two goals
274 of preserving the free status of all derivatives of our free software and
275 of promoting the sharing and reuse of software generally.
276
277 NO WARRANTY
278
279 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
280 FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
281 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
282 PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
283 OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
284 MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
285 TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
286 PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
287 REPAIR OR CORRECTION.
288
289 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
290 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
291 REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
292 INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
293 OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
294 TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
295 YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
296 PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
297 POSSIBILITY OF SUCH DAMAGES.
298
299 END OF TERMS AND CONDITIONS
300
301 How to Apply These Terms to Your New Programs
302
303 If you develop a new program, and you want it to be of the greatest
304 possible use to the public, the best way to achieve this is to make it
305 free software which everyone can redistribute and change under these terms.
306
307 To do so, attach the following notices to the program. It is safest
308 to attach them to the start of each source file to most effectively
309 convey the exclusion of warranty; and each file should have at least
310 the "copyright" line and a pointer to where the full notice is found.
311
312 <one line to give the program's name and a brief idea of what it does.>
313 Copyright (C) <year> <name of author>
314
315 This program is free software; you can redistribute it and/or modify
316 it under the terms of the GNU General Public License as published by
317 the Free Software Foundation; either version 2 of the License, or
318 (at your option) any later version.
319
320 This program is distributed in the hope that it will be useful,
321 but WITHOUT ANY WARRANTY; without even the implied warranty of
322 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
323 GNU General Public License for more details.
324
325 You should have received a copy of the GNU General Public License
326 along with this program; if not, write to the Free Software
327 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
328
329
330 Also add information on how to contact you by electronic and paper mail.
331
332 If the program is interactive, make it output a short notice like this
333 when it starts in an interactive mode:
334
335 Gnomovision version 69, Copyright (C) year name of author
336 Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
337 This is free software, and you are welcome to redistribute it
338 under certain conditions; type `show c' for details.
339
340 The hypothetical commands `show w' and `show c' should show the appropriate
341 parts of the General Public License. Of course, the commands you use may
342 be called something other than `show w' and `show c'; they could even be
343 mouse-clicks or menu items--whatever suits your program.
344
345 You should also get your employer (if you work as a programmer) or your
346 school, if any, to sign a "copyright disclaimer" for the program, if
347 necessary. Here is a sample; alter the names:
348
349 Yoyodyne, Inc., hereby disclaims all copyright interest in the program
350 `Gnomovision' (which makes passes at compilers) written by James Hacker.
351
352 "signature of Ty Coon", 1 April 1989
353 Ty Coon, President of Vice
354
355 This General Public License does not permit incorporating your program into
356 proprietary programs. If your program is a subroutine library, you may
357 consider it more useful to permit linking proprietary applications with the
358 library. If this is what you want to do, use the GNU Library General
359 Public License instead of this License.
360
361 </PRE>
362
+8
-3
inst/COPYRIGHT.html less more
0
0 <HTML>
1 <HEAD>
2 <TITLE>Rmetrics::COPYRIGHT</TITLE>
3 </HEAD>
4 <BODY BGCOLOR="WHITE">
15 <P>
26 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="7">
37 <FONT COLOR="#7F0000">Rmetrics</FONT></FONT></FONT></B>
1115
1216 <P>
1317 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">
14 2005-05-16 Built 201.10060</FONT></FONT>
18 2005-12-18 Built 221.10065</FONT></FONT>
1519 </B></P>
1620
1721
192196 Compiled by Adrian Trapletti <a.trapletti@bluewin.ch>
193197
194198 </PRE>
195
199 </BODY>
200 </HTML>
inst/DocClassification.pdf less more
Binary diff not shown
inst/DocCopying.pdf less more
Binary diff not shown
inst/DocFactSheet.pdf less more
Binary diff not shown
inst/DocFactsheet.pdf less more
Binary diff not shown
inst/DocRefcard.pdf less more
Binary diff not shown
inst/DocRmetrics.pdf less more
Binary diff not shown
+0
-486
inst/FAQ.html less more
0 <HTML>
1 <HEAD>
2 <!-- $MVD$:app("MicroVision WebExpress","769") -->
3 <!-- $MVD$:template("","0","0") -->
4 <!-- $MVD$:color("17","c0c0c0","Lt Grey","0") -->
5 <!-- $MVD$:fontset("Sans Serif","Arial","Helvetica","Monaco") -->
6 <TITLE>Untitled</TITLE>
7 </HEAD>
8 <BODY BGCOLOR="WHITE">
9 <P>
10 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="7"><FONT COLOR="#7F0000">Rmetrics</FONT></FONT></FONT></B> <FONT FACE="Arial,Helvetica,Monaco"><B><FONT SIZE="3"><FONT COLOR="#7F0000">FAQ</FONT></FONT></B></FONT></P>
11 <P ALIGN=CENTER>
12 <HR ALIGN=CENTER WIDTH="100%" SIZE="2">
13 </P>
14 <P>
15 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">
16 2005-11-02 Built 220.10063</FONT></FONT></B></P>
17 <P>
18 <B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><!-- $MVD$:spaceretainer() -->&nbsp;</FONT></FONT></B></P>
19 <P>
20 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">Table
21 of Content:</FONT></B></FONT></FONT></P>
22 <BLOCKQUOTE>
23 <P>
24 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">1. Introduction</FONT></FONT><BR>
25 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 1.1 Legalese</FONT></FONT><BR>
26 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 1.2
27 Obtaining this Documents</FONT></FONT></P>
28 <P>
29 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">2. The Basics of Rmetrics</FONT></FONT><BR>
30 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 2.1 What is Rmetrics?</FONT></FONT><BR>
31 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 2.2 What
32 machines does run Rmetrics on?</FONT></FONT><BR>
33 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 2.3 What is
34 the Current Version of Rmetrics?</FONT></FONT><BR>
35 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 2.4 How can
36 Rmetrics be obtained and installed?</FONT></FONT><BR>
37 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 2.5 What
38 documentation exists for Rmetrics?</FONT></FONT><BR>
39 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 2.6 How to
40 cite Rmetrics?</FONT></FONT><BR>
41 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 2.7 What
42 mailing lists exist for Rmetrics?</FONT></FONT></P>
43 <P>
44 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">3. Rmetrics
45 Programming Issues</FONT></FONT><BR>
46 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 3.1 Is
47 Rmetrics Open Source Software?</FONT></FONT><BR>
48 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 3.2 Why
49 uses Rmetrics Builtin-Functions?</FONT></FONT><BR>
50 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 3.3 Can I
51 use R and Rmetrics for commercial purposes?</FONT></FONT><BR>
52 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">&nbsp; 3.4
53 Rmetrics and Finmetrics</FONT></FONT></P>
54 </BLOCKQUOTE>
55 <P ALIGN=CENTER>
56 <HR ALIGN=CENTER WIDTH="100%" SIZE="2" NOSHADE COLOR="#7F0000">
57 </P>
58 <P>
59 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">1.
60 Introduction</FONT></B></FONT></FONT></P>
61 <BLOCKQUOTE>
62 <P>
63 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">This document
64 contains answers to some of the most frequently asked questions about
65 Rmetrics. For R itself we highly recommend to consult Kurt Hornik's
66 FAQ on R, availalble fromthe CRANServer. Additionally there are two
67 platform-specific FAQs about R: The R Windows FAQfor all users of
68 Microsoft operating systems, and the R MacOS X FAQfor all users of
69 Apple operating systems. Note that the latter two are complementary
70 to the general R FAQ, i.e., you should read both the general FAQ and
71 your platform-specific one.</FONT></FONT></P>
72 </BLOCKQUOTE>
73 <P>
74 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">1.1
75 Legalese</FONT></B></FONT></FONT></P>
76 <BLOCKQUOTE>
77 <P>
78 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">This document is
79 copyright &copy; 2001&#150;2004 by Diethelm W&uuml;rtz. The document
80 is free software; you can redistribute it and/or modify it under the
81 terms of the GNU General Public License as published by the Free
82 Software Foundation; either version 2, or (at your option) any later
83 version. The document is distributed in the hope that it will be
84 useful, but WITHOUT ANY WARRANTY; without even the implied warranty
85 of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
86 General Public License for more details. A copy of the GNU General
87 Public License is available via WWW at: http://www.gnu.org . You can
88 also obtain it by writing to the Free Software Foundation, Inc., 59
89 Temple Place &#151; Suite 330, Boston, MA 02111-1307, USA.</FONT></FONT></P>
90 </BLOCKQUOTE>
91 <P>
92 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">1.2
93 Obtaining this Document</FONT></B></FONT></FONT></P>
94 <BLOCKQUOTE>
95 <P>
96 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">The latest version
97 of this document is always available from: http://www.rmetrics.org ,
98 the latest version of the R FAQ is available from:
99 http://www.ci.tuwien.ac.at .</FONT></FONT></P>
100 </BLOCKQUOTE>
101 <P ALIGN=CENTER>
102 <HR ALIGN=CENTER WIDTH="100%" SIZE="2" NOSHADE COLOR="#7F0000">
103 </P>
104 <P>
105 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">2
106 The Basics of Rmetrics</FONT></B></FONT></FONT></P>
107 <BLOCKQUOTE>
108 <P>
109 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">Rmetrics is a
110 collection of several hundreds of functions which may be useful for
111 teaching &quot;Financial Engineering&quot; and &quot;Computational
112 Finance&quot;. These functions are available for R, &#147;GNU&#146;s
113 S&#148;. This is a freely available language and environment for
114 statistical computing and graphics which provides a wide variety of
115 statistical and graphical techniques.</FONT></FONT></P>
116 </BLOCKQUOTE>
117 <P>
118 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">2.1
119 What is Rmetrics?</FONT></B></FONT></FONT></P>
120 <BLOCKQUOTE>
121 <P>
122 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">The functions
123 availalbel through Rmetrics have their source in algorithms and
124 functions written by myself, my students, and many other authors. A
125 major aim is to bring financial algorithms and concepts together
126 under a common software platform and to make it public available
127 mainly for teaching financial engineering and computational finance.
128 Rmetrics is not part of CRAN, Rmetrics is an initiative by its own.
129 Rmetrics has some aims similar like Bioconductor. Rmetrics is an open
130 source and open development software project. The basic R port from
131 which Rmetrics originated was already initiated in 1999 as an outcome
132 of lectures held by Diethelm W&uuml;rtz on topics in econophysics at
133 ETH Z&uuml;rich. Meanwhile, the family of the Rmetrics packages
134 includes four members dealing with the following subjects: fBasics -
135 Markets, Basic Statistics, Date and Time, fSeries - The Dynamical
136 Process Behind Financial Markets, fExtremes - Beyond the Sample,
137 Dealing with Extreme Values, and fOptions - The Valuation of Options.
138 Two other packages are under current development, fBonds and fPortfolio.</FONT></FONT></P>
139 <P>
140 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I>What is
141 included in the fBasics Package?</I> The package fBasics covers the
142 management of economic and financial market data. Included are
143 functions to download economic indicators and financial market data
144 from the Internet. Distribution functions relevant in finance are
145 added like the asymmetric stable, the hyperbolic and the inverse
146 normal gaussian distribution function to compute densities,
147 probabilities, quantiles and random deviates. Estimators to fit the
148 distributional parameters are also available. Some additional
149 hypothesis tests for the investigation of correlations, dependencies
150 and other stylized facts of financial time series can also be found
151 in this package.</FONT></FONT></P>
152 <P>
153 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I>What is
154 included in the </I></FONT></FONT><I><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">fCalendar</FONT></FONT></I><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I> Package?</I>
155 The package fCalendar covers the managment of dates, time, and
156 calendars. The package makes available very powerful 'timeDate' and
157 'timeSeries' S4 classes. A holiday database for all ecclestial and
158 public holidays in the G7 countries and Switzerland is provided
159 together with a database of daylight saving times for financial
160 centers around the world. Special calendar management functions were
161 implemented to create easily business calendars for exchanges. A
162 collection of functions for filtering and outlier detection of high
163 frequency foreign exchange data records collected from Reuters' data
164 feed can also be found together with functions for de-volatilization
165 and de-seasonalization of the data.</FONT></FONT></P>
166 <P>
167 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I>What is
168 included in the fSeries Package?</I> The package fSeries covers
169 topics from the field of financial time series analysis including
170 ARIMA, GARCH, long memory modelling, and chaotic time series analysis
171 . This library tries to bring together the content of existing
172 R-packages with additional new functionality on a common platform.
173 The collection comes with functions for simulations, parameter
174 estimation, diagnostic analysis and hypothesis testing of financial
175 time series. The tests include methods for testing unit roots,
176 independence, normality of the distribution, trend stationary, and
177 neglected non-linearities. In addition functions for testing for
178 higher serial correlations, for heteroskedasticity, for
179 autocorrelations of disturbances, for linearity, and functional
180 relations are provided. Furthermore, distribution functions for GARCH
181 modelling like the normalized Student-t and the GED together with
182 their skewed versions have been added which require for their
183 computation Heaviside and related functions. The demonstration
184 directory includes also a R-interface for the GarchOx software package.</FONT></FONT></P>
185 <P>
186 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I>What is
187 included in the </I></FONT></FONT><I><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">fMultivar</FONT></FONT></I><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I> Package?</I>
188 The package fMultivar deals mainly with multivariate aspects of time
189 series analysis. Offered are algorithms for regression analysis
190 including neural network modelling with feedforward networks.
191 Furthermore functions for sytem equation modelling are available.
192 Technical analysis and benchmarking is another major issue of this
193 package. The collection offers a set of the most common technical
194 indicators together with functions for charting and benchmark
195 measurements. For the technical analysis of markets several trading
196 functions are implemented and also tools are availalble for a rolling
197 market analysis. A matrix addon with many functions which allow an
198 easy use of matrix manipulations is also part of this package. This
199 addon includes functions to generate several kind of standard
200 matrixes, to extract subsets of a matrix, and some function from
201 linear algebra. This matrix addon is thought to be used to manipulate
202 easily the data of multivariate time series objects.</FONT></FONT></P>
203 <P>
204 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I>What is
205 included in the fExtremes Package?</I> The package fExtremes covers
206 topics from the field what is known as extreme value theory. The
207 package has functions for the exploratory data analysis of extreme
208 values in insurance, economics, and finance applications. Included
209 are plot functions for empirical distributions, quantile plots,
210 graphs exploring the properties of exceedences over a threshold,
211 plots for mean/sum ratio and for the development of records.
212 Furthermore functions for preprocessing data for extreme value
213 analysis are available offering tools to separate data beyond a
214 threshold value, to compute blockwise data like block maxima, and to
215 de-cluster point process data. One major aspect of this package is to
216 bring together the content of already existing R-packages with
217 additional new functionality for financial engineers on a common
218 platform investigating fluctuations of maxima, extremes via point
219 processes, and the extremal index. A new additional chapter on risk
220 measures, stress testing and copulae is planned to be added in the
221 near future.</FONT></FONT></P>
222 <P>
223 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I>What is
224 included in the fOptions Package?</I> The package fOptions covers the
225 valuation of options including topics like the basics of option
226 pricing in the framework of Black and Scholes, including almost 100
227 functions for exotic options pricing, including the Heston-Nandi
228 option pricing approach mastering stochastic volatility, and Monte
229 Carlo simulations together with generators for low discrepancy
230 sequences. Beside the Black and Scholes option pricing formulas,
231 functions to valuate other plain vanilla options on commodities and
232 futures, and function to approximate American options are also
233 available. Some binomial tree models are implemented. The exotic
234 options part comes with a large number of functions to valuate
235 multiple exercise options, multiple asset options, lookback options,
236 barrier options, binary options, Asian options, and currency
237 translated options. Some functions for the investigation of
238 exponential Brownian motion in the context of Asian option valuation
239 have been recently added.</FONT></FONT></P>
240 <P>
241 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I>What is
242 included in the </I></FONT></FONT><I><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">fPortfolio</FONT></FONT></I><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I> Package?</I>
243 The package fPortfolio covers multivariate distributions, assets
244 modelling, drawdown statistics, value-at-risk modelling, Markowitz
245 portfolios, two assets. The multivariate distribution functions allow
246 to compute multivariate densities and probabilities from skew normal
247 and skew Student-t distribution functions. Furthermore, multivariate
248 random daviates can be generated, and for multivariate data, the
249 parameters of the underlying distribution can be estimated by the
250 maximum log-likelihood estimation. The functions for assets modelling
251 can be used togenerate multivariate artficial data sets of assets,
252 which fit the parameters to a multivariate normal, skew normal, or
253 (skew) Student-t distribution. Included in the library are also
254 functions to compute some benchmark statistics. In addition a
255 function is provided which allows for the selection and clustering of
256 individual assets from portfolios using hierarchical and k-means
257 clustering approaches. Tools are provided to evaluate dtawdown
258 statistics. Availalble are functions for the density, distribution
259 function, and random number generation for the maximum drawdown
260 distribution. In addition the expectation of drawdowns for Brownian
261 motion can be computed. Value-at-Risk Modelling is another topic
262 which is consider in this library. Value-at-Risk and related risk
263 measures for a portfolio of assets can be evaluated. A group of
264 functions is dedicated to the Markowitz portfolio optimization
265 problem. Functions for the computation of the efficient frontier, for
266 the market line, for the tangency portfolio and for Monte Carlo
267 simulations are part of the library. Analytical formulas for the
268 Markowitz and for the Condition VaR Portfolio approach are implemented.</FONT></FONT></P>
269 <P>
270 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><I>Who are the
271 devellopers behind Rmetrics?</I> The writing of the functions which
272 are now available in Rmetrics started originally as assignments in my
273 lectures on &quot;Econophysics&quot; at the Institute of Theoretical
274 Physics at ETH Z&uuml;rich. Since in the financial community and also
275 in my lectures MS Windows is the mostly used operating system,
276 special emphasis is given to the Microsofts OS. Thus, to teach
277 financial engineers it became quite natural for me to work under
278 Windows. For a broad distribution and acceptance of Rmetrics I
279 decided to continue the devellopment primarily under Windows 2000/XP.
280 There are no many people behind Rmetrics, currently it's only me. I
281 have my job as a lecturer at the Institute of Theoretical Physics at
282 ETH Zurich, and I'm the senior partner of an ETH spin-off software
283 company, Finance Online. So I have several responsibilities to take,
284 and as a consequence things might go slow ... The growing Rmetrics
285 collection is based on many statistical and financial functions which
286 were contributed by myself, my students, or were ported from many
287 other sources during the last seven years since I started my lectures
288 in &quot;Econophysics&quot; at ETH. I'm aware that the work is by far
289 not complete. Parts of the software are still untested, and may
290 contain some bugs. Contributions are welcome!</FONT></FONT></P>
291 </BLOCKQUOTE>
292 <P>
293 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">2.2
294 What machines does run Rmetrics on?</FONT></B></FONT></FONT></P>
295 <BLOCKQUOTE>
296 <P>
297 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">Starting with
298 Version 1.7.1 Rmetrics is expected to run under the some platforms as
299 R. R is being developed for the Unix, Windows and Mac families of
300 operating systems. Support for Mac OS Classic ended with the 1.7
301 series. The current version of R will configure and build under a
302 number of common Unix platforms, for details we refer to the R FAQ.
303 Rmetrics is primarily build and maintained under MS Windows XP.</FONT></FONT></P>
304 </BLOCKQUOTE>
305 <P>
306 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">2.3
307 What is the Current Version of Rmetrics?</FONT></B></FONT></FONT></P>
308 <BLOCKQUOTE>
309 <P>
310 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">The current
311 productive Version is 191.10057. The latest source packages are
312 located in the source directory on the Rmetrics Server, and the
313 latest binary files for the Windows OS are located in the download
314 directory themselves. The DESCRIPTION files hold the most recent
315 version number, please check. The most recent productive built for
316 Rmetrics is available from the CRAN Server.</FONT></FONT></P>
317 </BLOCKQUOTE>
318 <P>
319 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">2.4
320 How can Rmetrics be obtained and installed?</FONT></B></FONT></FONT></P>
321 <BLOCKQUOTE>
322 <P>
323 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">The source code of
324 the productive packages Version 191.10057 can be downloaded from the
325 CRAN Server, also the binary packages for Windows, Mac OSX and Linux
326 operated computers. Rmetrics is also availalble in form of (compiled)
327 Debian Packages and part of the Knoppix Quantian CD. The current
328 Version of the included packages is 190.10055, beside fBasics which
329 is Version 190.10056. First of all, an R environment must be
330 installed on your sytem. Please follow the instructions as described
331 in R's FAQ. Then the Rmetrics packages can be installed in the usual
332 way as an ordinary R package. Nothing is special.</FONT></FONT></P>
333 </BLOCKQUOTE>
334 <P>
335 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">2.</FONT></B></FONT></FONT><B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><FONT COLOR="#7F0000">5</FONT></FONT></FONT></B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">
336 What documentation exists for Rmetrics?</FONT></B></FONT></FONT></P>
337 <BLOCKQUOTE>
338 <P>
339 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">Online
340 documentation for most of the functions and variables in Rmetrics
341 exists lik in R, and can be printed on-screen by typing help(name)
342 (or ?name) at the R prompt, where name is the name of the topic help
343 is sought for. This documentation can also be made available as one
344 reference manual for on-line reading in HTML and PDF formats, and as
345 hardcopy via LaTeX. The Rmetrics distribution also comes with the
346 following manuals.</FONT></FONT></P>
347 <P>
348 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">1. General
349 Information: A Flyer, a Fact Sheet, and a Reference Card</FONT></FONT><BR>
350 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">2. Rmetrics
351 &quot;Reference Guides&quot; for the following packages: fBasics,
352 fSeries, fExtremes, and fOptions.</FONT></FONT><BR>
353 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">3. Rmetrics &quot;
354 Lecture Scripts&quot;, which can serve as User Guides. (Unfortunately
355 these Scripts are not always up to date.)</FONT></FONT></P>
356 </BLOCKQUOTE>
357 <P>
358 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">2.</FONT></B></FONT></FONT><B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><FONT COLOR="#7F0000">6</FONT></FONT></FONT></B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000"> </FONT></B></FONT></FONT><B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><FONT COLOR="#7F0000">How
359 to cite</FONT></FONT></FONT></B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000"> Rmetrics</FONT></B></FONT></FONT><B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><FONT COLOR="#7F0000">?</FONT></FONT></FONT></B></P>
360 <BLOCKQUOTE>
361 <P>
362 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">To cite Rmetrics
363 in publications, use</FONT></FONT></P>
364 <BLOCKQUOTE>
365 <P>
366 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">@Manual{,</FONT></FONT><BR>
367 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">title = {Rmetrics:
368 An Environment for Teaching Financial Engineering and Computational
369 Finance with R},</FONT></FONT><BR>
370 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">author = {Diethelm W&uuml;rtz},</FONT></FONT><BR>
371 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">organization =
372 {Rmetrics, ITP, ETH Z&uuml;rich},</FONT></FONT><BR>
373 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">address =
374 {Z&uuml;rich, Switzerland},</FONT></FONT><BR>
375 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">year = {2004},</FONT></FONT><BR>
376 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">url =
377 {http://www.rmetrics.org} }</FONT></FONT></P>
378 </BLOCKQUOTE>
379 </BLOCKQUOTE>
380 <P>
381 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">2.</FONT></B></FONT></FONT><B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><FONT COLOR="#7F0000">7</FONT></FONT></FONT></B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">
382 What mailing lists exist for Rmetrics?</FONT></B></FONT></FONT></P>
383 <BLOCKQUOTE>
384 <P>
385 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">There is no
386 special mailing list dedicated to Rmetrics. However, for topics
387 concerned with R and in relation to financial applications we
388 recommend the following lists: R-announce A moderated list for major
389 announcements about the development of R and the availability of new
390 code. R-packages A moderated list for announcements on the
391 availability of new or enhanced contributed packages. R-help The
392 &quot;main'&quot; R mailing list, for discussion about problems and
393 solutions using R, about the development of R and the availability of
394 new code, enhancements and patches to the source code and
395 documentation of R, comparison and compatibility with S and S-Plus,
396 and for the posting of nice examples and benchmarks. R-devel This
397 list is for discussions about the future of R, proposals of new
398 functionality, and pre-testing of new versions. It is meant for those
399 who maintain an active position in the development of R.
400 R-sig-finance This is the special interest group for 'R in Finance'.</FONT></FONT></P>
401 </BLOCKQUOTE>
402 <P ALIGN=CENTER>
403 <HR ALIGN=CENTER WIDTH="100%" SIZE="2" NOSHADE COLOR="#7F0000">
404 </P>
405 <P>
406 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">3
407 Rmetrics Programming Issues</FONT></B></FONT></FONT></P>
408 <BLOCKQUOTE>
409 <P>
410 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">R and Rmetrics
411 give you many functions and tools at your fingertips to model, to
412 analyze and to visualize financial market data. This is the origin
413 for creating powerful rapid protopype systems for valuating and
414 judging your models.</FONT></FONT></P>
415 </BLOCKQUOTE>
416 <P>
417 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">3.1
418 Is Rmetrics Open Source Software?</FONT></B></FONT></FONT></P>
419 <BLOCKQUOTE>
420 <P>
421 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">Rmetrics has a
422 commitment to full open source code development and distribution. All
423 contributions included in the Rmetrics packages are expected to exist
424 under an open source license such as GPL2. The reasons for this
425 commitment are the ability to test, to extend and to improve the
426 software in a convenient way, to encourage excellent scientific
427 computing and statistical practice in financial engineering and
428 computational finance, and to provide a workbench of tools that allow
429 to explore and expand the methods used to analyze financial market
430 data and to valuate financial instruments.</FONT></FONT></P>
431 </BLOCKQUOTE>
432 <P>
433 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">3.</FONT></B></FONT></FONT><B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><FONT COLOR="#7F0000">2</FONT></FONT></FONT></B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">
434 Why uses Rmetrics Builtin-Functions?</FONT></B></FONT></FONT></P>
435 <BLOCKQUOTE>
436 <P>
437 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">All functions used
438 by Rmetrics and becoming part of the Rmetrics packages must be
439 available under a Debian conform license. R packages must be
440 availalble on the CRAN Server in Source and also in Binary form for
441 the Windows and Mac OSX operating systems. Furthermore, they must be
442 part of the (compiled) Debian distribution and the Knoppix Quantian
443 CD. For functions and packages which are not fulfilling these
444 conditions or are in conflict with other functions used in the
445 Rmetrics packages their functionality will be made available in form
446 of Builtin-Functions. These Builtin-Functions are GNU licensed
447 functions which were modified and copied to Rmetrics packages to
448 fullfill the required specifications. This is the only reason why we
449 have added Builtin functionality.</FONT></FONT></P>
450 </BLOCKQUOTE>
451 <P>
452 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">3.</FONT></B></FONT></FONT><B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><FONT COLOR="#7F0000">3</FONT></FONT></FONT></B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">
453 Can I use R and Rmetrics for commercial purposes?</FONT></B></FONT></FONT></P>
454 <BLOCKQUOTE>
455 <P>
456 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">R and Rmetrics are
457 released under the GNU General Public License (GPL). If you have any
458 questions regarding the legality of using R and/or Rmetrics in any
459 particular situation you should bring it up with your legal counsel.
460 We are in no position to offer legal advice. More information on the
461 opinion of the R Core team about commercial usage can be found in the
462 R FAQ.</FONT></FONT></P>
463 </BLOCKQUOTE>
464 <P>
465 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">3.</FONT></B></FONT></FONT><B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><FONT COLOR="#7F0000">4</FONT></FONT></FONT></B><FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B><FONT COLOR="#7F0000">
466 Rmetrics and Finmetrics</FONT></B></FONT></FONT></P>
467 <BLOCKQUOTE>
468 <P>
469 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">Rmetrics and
470 Finmetrics are packages for modeling, analyzing, and visualizing
471 financial market data. Both packages offer a modern and flexible
472 environment for reliable and robust, predictive econometric modeling
473 and for valuation and pricing of financial instruments. What Rmetrics
474 is for R, is Finmetrics for S-Plus.</FONT></FONT></P>
475 </BLOCKQUOTE>
476 <P ALIGN=CENTER>
477 <HR ALIGN=CENTER WIDTH="100%" SIZE="2" NOSHADE COLOR="#7F0000">
478 </P>
479 <P>
480 <!-- $MVD$:spaceretainer() -->&nbsp;</P>
481 <P>
482 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">Diethelm W&uuml;rtz</FONT></FONT><BR>
483 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2">Z&uuml;rich, April 2005</FONT></FONT>
484 </BODY>
485 </HTML>⏎
inst/FAQ.pdf less more
Binary diff not shown
+2
-6
inst/README.html less more
00 <HTML>
11 <HEAD>
2 <!-- $MVD$:app("MicroVision WebExpress","769") -->
3 <!-- $MVD$:template("","0","0") -->
4 <!-- $MVD$:color("17","c0c0c0","Lt Grey","0") -->
5 <!-- $MVD$:fontset("Sans Serif","Arial","Helvetica","Monaco") -->
6 <TITLE>Rmetrics::FAQ</TITLE>
2 <TITLE>Rmetrics::README</TITLE>
73 </HEAD>
84 <BODY BGCOLOR="WHITE">
95 <P>
1410 </P>
1511 <P>
1612 <FONT FACE="Arial,Helvetica,Monaco"><FONT SIZE="2"><B>
17 2005-11-02 Built 220.10063</B></FONT></P>
13 2005-12-18 Built 221.10065</B></FONT></P>
1814 <P>
1915 <!-- $MVD$:spaceretainer() -->&nbsp;</P>
2016 <P>
+6
-6
inst/demoIndex less more
0 funExtremes fExtremes Function Addon
1
2 xmpDWChapter51 Extreme Value Plots
3 xmpDWChapter52 Fluctuations of Maxima and GEV Distribution
4 xmpDWChapter53 Extremes via Point Processes
5 xmpDWChapter54 The Extremal Index
0 funLmomco L Moments Function Addon
1 xmpDWChapter051 Extreme Value Plots
2 xmpDWChapter052 Fluctuations of Maxima and GEV Distribution
3 xmpDWChapter053 Extremes via Point Processes
4 xmpDWChapter054 The Extremal Index
5 xmpZWChapter05 Modelling Extreme Values
+548
-0
man/051A-ExtremesData.Rd less more
0 \name{ExtremesData}
1
2 \alias{ExtremesData}
3
4 \alias{emdPlot}
5 \alias{qqPlot}
6 \alias{qqbayesPlot}
7 \alias{qPlot}
8 \alias{mePlot}
9 \alias{mrlPlot}
10 \alias{mxfPlot}
11 \alias{msratioPlot}
12 \alias{recordsPlot}
13 \alias{ssrecordsPlot}
14 \alias{xacfPlot}
15
16 \alias{interactivePlot}
17
18 \alias{gridVector}
19
20
21 \alias{findThreshold}
22 \alias{blocks}
23 \alias{blockMaxima}
24 \alias{deCluster}
25
26
27 \title{Explorative Data Analysis}
28
29
30 \description{
31
32 A collection and description of functions for explorative
33 data analysis including data preprocessing of extreme values.
34 The tools include plot functions for emprical distributions,
35 quantile plots, graphs exploring the properties of exceedences
36 over a threshold, plots for mean/sum ratio and for the development
37 of records. The data preprocessing includes tools to
38 separate data beyond a threshold value, to compute blockwise
39 data like block maxima, and to decluster point process data.
40 \cr
41
42 The plot functions are:
43
44 \tabular{ll}{
45 \code{emdPlot} \tab Plot of empirical distribution function, \cr
46 \code{qqPlot} \tab Normal quantile-quantile plot, \cr
47 \code{qqbayesPlot} \tab Normal QQ-Plot with 95 percent intervals, \cr
48 \code{qPlot} \tab Exponential/Pareto quantile plot, \cr
49 \code{mePlot} \tab Plot of mean excesses over a threshold, \cr
50 \code{mrlPlot} \tab another variant, mean residual life plot, \cr
51 \code{mxfPlot} \tab another variant, with confidence intervals, \cr
52 \code{msratioPlot} \tab Plot of the ratio of maximum and sum, \cr
53 \code{recordsPlot} \tab Record development compared with iid data, \cr
54 \code{ssrecordsPlot} \tab another variant, investigates subsamples, \cr
55 \code{xacfPlot} \tab ACF of exceedences over a threshold, \cr
56 \code{interactivePlot} \tab a framework for interactive plot displays, \cr
57 \code{gridVector} \tab creates from two vectors x and y all grid points. }
58
59 The functions for data preprocessing are:
60
61 \tabular{ll}{
62 \code{findThreshold} \tab Upper threshold for a given number of extremes, \cr
63 \code{blocks} \tab Create data blocks on vectors and time series, \cr
64 \code{blockMaxima} \tab Block Maxima from a vector or a time series, \cr
65 \code{deCluster} \tab Declusters clustered point process data. }
66
67
68 }
69
70
71 \usage{
72 emdPlot(x, doplot = TRUE, plottype = c("", "x", "y", "xy"), labels = TRUE, \dots)
73
74 qqPlot(x, doplot = TRUE, labels = TRUE, \dots)
75 qqbayesPlot(x, doplot = TRUE, labels = TRUE, \dots)
76 qPlot(x, xi = 0, trim = NA, threshold = NA, doplot = TRUE, labels = TRUE, \dots)
77
78 mePlot(x, doplot = TRUE, labels = TRUE, \dots)
79 mrlPlot(x, conf = 0.95, umin = NA, umax = NA, nint = 100, doplot = TRUE,
80 plottype = c("autoscale", ""), labels = TRUE, \dots)
81 mxfPlot(x, tail = 0.05, doplot = TRUE, labels = TRUE, \dots)
82
83 msratioPlot(x, p = 1:4, doplot = TRUE, plottype = c("autoscale", ""),
84 labels = TRUE, \dots)
85
86 recordsPlot(x, conf = 0.95, doplot = TRUE, labels = TRUE, \dots)
87 ssrecordsPlot(x, subsamples = 10, doplot = TRUE, plottype = c("lin", "log"),
88 labels = TRUE, \dots)
89
90 xacfPlot(x, threshold = 0.95, lag.max = 15, doplot = TRUE, \dots)
91
92 interactivePlot(x, choices = paste("Plot", 1:9),
93 plotFUN = paste("plot.", 1:9, sep = ""), which = "all", \dots)
94 gridVector(x, y)
95
96 findThreshold(x, n = NA)
97 blocks(x, block = "month", FUN = max)
98 blockMaxima(x, block = "month", details = FALSE, doplot = TRUE, \dots)
99 deCluster(x, run = NA, doplot = TRUE)
100 }
101
102
103 \arguments{
104
105 \item{block}{
106 [blockMaxima] - \cr
107 the block size. A numeric value is interpreted as the number
108 of data values in each successive block. All the data is used,
109 so the last block may not contain \code{block} observations.
110 If the \code{data} has a \code{times} attribute containing (in
111 an object of class \code{"POSIXct"}, or an object that can be
112 converted to that class, see \code{\link{as.POSIXct}}) the
113 times/dates of each observation, then \code{block} may instead
114 take the character values \code{"month"}, \code{"quarter"},
115 \code{"semester"} or \code{"year"}. By default monthly blocks
116 from daily data are assumed.
117 }
118 \item{choices}{
119 [interactivePlot] - \cr
120 a vector of character strings for the
121 choice menu. By Default \code{"Plot 1"} ... \code{"Plot 9"}
122 allowing for 9 plots at maximum.
123 }
124 \item{conf}{
125 [recordsPlot] - \cr
126 a confidence level. By default 0.95, i.e. 95\%.
127 }
128 \item{details}{
129 [blockMaxima] - \cr
130 a logical. Should details be printed?
131 }
132 \item{doplot}{
133 a logical. Should the results be plotted? By default \code{TRUE}.
134 }
135 \item{FUN}{the function to be applied. Additional arguments are
136 passed by the \code{\dots} argument.
137 }
138 \item{labels}{
139 a logical. Whether or not x- and y-axes should be automatically
140 labelled and a default main title should be added to the plot.
141 By default \code{TRUE}.
142 }
143 \item{lag.max}{
144 [xacfPlot] - \cr
145 maximum number of lags at which to calculate the autocorrelation
146 functions. The default value is 15.
147 }
148 \item{nint}{
149 [mrlPlot] - \cr
150 the number of intervals, see \code{umin} and \code{umax}. The
151 default value is 100.
152 }
153 \item{n}{
154 [findThreshold] - \cr
155 a numeric value or vector giving number of extremes above
156 the threshold. If \code{n} is not specified, \code{n} is
157 set to an integer representing 5\% of the data from the
158 whole data set \code{x}.
159 }
160 \item{p}{
161 [msratioPlot] - \cr
162 the power exponents, a numeric vector. By default a sequence from
163 1 to 4 in unit integer steps.
164 }
165 \item{plotFUN}{
166 [interactivePlot] - \cr
167 a vector of character strings naming the
168 plot functions. By Default \code{"plot.1"} ... \code{"plot.9"}
169 allowing for 9 plots at maximum.
170 }
171 \item{plottype}{
172 [emdPlot] - \cr
173 which axes should be on a log scale: \code{"x"} x-axis only;
174 \code{"y"} y-axis only; \code{"xy"} both axes; \code{""}
175 neither axis.
176 \cr
177 [msratioPlot] - \cr
178 a logical, if set to \code{"autoscale"}, then the scale of the
179 plots are automatically determined, any other string allows user
180 specified scale information through the \code{\dots} argument.
181 \cr
182 [ssrecordsPlot] - \cr
183 one from two options can be select either \code{"lin"}
184 or \code{"log"}. The default creates a linear plot.
185 }
186 \item{run}{
187 [deCluster] - \cr
188 parameter to be used in the runs method; any two consecutive
189 threshold exceedances separated by more than this number of
190 observations/days are considered to belong to different clusters.
191 }
192 \item{subsamples}{
193 [ssrecordsPlot] - \cr
194 the number of subsamples, by default 10, an integer value.
195 }
196 \item{tail}{
197 [mxfPlot] - \cr
198 the threshold determined from the relative number of data points
199 defining the tail, a numeric value; by default 0.05 which says
200 that 5\% of the data make the tail.
201 }
202 \item{threshold, trim}{
203 [qPlot][xacfPlot] - \cr
204 a numeric value at which data are to be left-truncated, value
205 at which data are to be right-truncated or the thresold value,
206 by default 95\%.
207 }
208 \item{umin, umax}{
209 [mrlPlot] - \cr
210 range of threshold values. If \code{umin} and/or \code{umax} are
211 not available, then by default they are set to the following
212 values: \code{umin=mean(x)} and \code{umax=max(x)}.
213 }
214 \item{which}{
215 plot selection, which graph should be displayed? If \code{"which"}
216 is a character string named "ask" the user is interactively asked
217 which to plot, if a logical vector of length \code{N}, those plots
218 which are set \code{TRUE} are displayed, if a character string
219 named \code{"all"} all plots are displayed.
220 }
221 \item{x, y}{
222 numeric data vectors or in the case of x an object to be plotted.
223 \cr
224 [finThreshold][blocks][blockMaxima][deCluster] - \cr
225 a numeric data vector from which \code{findThreshold} and
226 \code{blockMaxima} determine the threshold values and block
227 maxima values.
228 For the function \code{deCluster} the argument
229 \code{x} represents a numeric vector of threshold exceedances
230 with a \code{times} attribute which should be a numeric
231 vector containing either the indices or the times/dates
232 of each exceedance (if times/dates, the attribute should
233 be an object of class \code{"POSIXct"} or an object that
234 can be converted to that class; see \code{\link{as.POSIXct}}).
235 [gridVector] - \cr
236 two numeric vector which span the two dimensional grid.
237 }
238 \item{xi}{
239 the shape parameter of the generalized Pareto distribution.
240 }
241 \item{\dots}{
242 additional arguments passed to the FUN or plot function.
243 }
244
245 }
246
247
248 \details{
249
250 \bold{Empirical Distribution Function:}
251 \cr\cr
252 The function \code{emdPlot} is a simple explanatory function. A
253 straight line on the double log scale indicates Pareto tail behaviour.
254 \cr
255
256
257 \bold{Quantile--Quantile Plot:}
258 \cr\cr
259 The function \code{qqPlot} produces a normal QQ-plot. Note, that
260 \code{qqPlot} is not a synonym function call to the \R-base function
261 \code{qqplot} which produces a quantile-quantile plot of two datasets.
262 To help with assessing the relevance of sampling variability on just
263 "how close" to the normal the data appears, \code{qqbayesPlot} adds
264 approximate posterior 95% intervals for the uncertain quantile
265 function at each point.
266 \code{qPlot} creates a QQ-plot for threshold data. If \code{xi} is
267 zero the reference distribution is the exponential; if \code{xi} is
268 non-zero the reference distribution is the generalized Pareto with
269 that value of \code{xi}. In the case of the exponential, the plot is
270 interpreted as follows: Concave departures from a straight line are a
271 sign of heavy-tailed behaviour, convex departures show thin-tailed
272 behaviour.
273 \cr
274
275
276 \bold{Mean Excess Function Plot:}
277 \cr\cr
278 Three variants to plot the mean excess function are available:
279 A sample mean excess plot over increasing thresholds, and two mean
280 excess function plots with confidence intervals for discrimination
281 in the tails of a distribution.
282 In general, an upward trend in a mean excess function plot shows
283 heavy-tailed behaviour. In particular, a straight line with positive
284 gradient above some threshold is a sign of Pareto behaviour in tail.
285 A downward trend shows thin-tailed behaviour whereas a line with
286 zero gradient shows an exponential tail. Here are some hints:
287 Because upper plotting points are the average of a handful of extreme
288 excesses, these may be omitted for a prettier plot.
289 For \code{mrlPlot} and \code{mxfPlot} the upper tail is investigated;
290 for the lower tail reverse the sign of the \code{data} vector.
291 \cr
292
293
294 \bold{Plot of the Maximum/Sum Ratio:}
295 \cr\cr
296 The ratio of maximum and sum is a simple tool for detecting heavy
297 tails of a distribution and for giving a rough estimate of
298 the order of its finite moments. Sharp increases in the curves
299 of a \code{msratioPlot} are a sign for heavy tail behaviour.
300 \cr
301
302
303 \bold{Plot of the Development of Records:}
304 \cr\cr
305 These are functions that investigate the development of records in
306 a dataset and calculate the expected behaviour for iid data.
307 \code{recordPlot} counts records and reports the observations
308 at which they occur. In addition subsamples can be investigated
309 with the help of the function \code{ssrecords}.
310 \cr
311
312
313 \bold{ACF Plot of Exceedences over a Thresold:}
314 \cr\cr
315 This function plots the autocorrelation functions of heights and
316 distances of exceedences over a threshold.
317 \cr
318
319
320 \bold{Finding Thresholds:}
321 \cr\cr
322 The function \code{findThreshold} finds a threshold so that a given
323 number of extremes lie above. When the data are tied a threshold is
324 found so that at least the specified number of extremes lie above.
325 \cr
326
327
328 \bold{Computing Block Maxima:}
329 \cr\cr
330 The function \code{blockMaxima} calculates block maxima from a vector
331 or a time series, whereas the function
332 \code{blocks} is more general and allows for the calculation of
333 an arbitrary function \code{FUN} on blocks.
334 \cr
335
336
337 \bold{De-Clustering Point Processes:}
338 \cr\cr
339 The function \code{deCluster} declusters clustered point process
340 data so that Poisson assumption is more tenable over a high threshold.
341
342 }
343
344
345 \value{
346
347 \code{findThreshold}
348 \cr
349 returns a numeric vector of suitable thresholds.
350
351 \code{blockMaxima}
352 \cr
353 returns a numeric vector of block maxima data.
354
355 \code{deCluster}
356 \cr
357 returns an object for the declustered point process.
358
359 }
360
361
362 \note{
363
364 The plots are labeled by default with a x-label, a y-label and
365 a main title. If the argument \code{label} is set to \code{FALSE}
366 neither a x-label, a y-label nor a main title will be added to
367 graph. To add user defined label strings "\dots" just use the
368 function \code{title(xlab="\dots", ylab="\dots", main="\dots")}.
369
370 }
371
372
373 \author{
374
375 Some of the functions were implemented from Alec Stephenson's
376 R-package \code{evir} ported from Alexander McNeil's S library
377 \code{EVIS}, \emph{Extreme Values in S}, some from Alec Stephenson's
378 R-package \code{ismev} based on Stuart Coles code from his book,
379 \emph{Introduction to Statistical Modeling of Extreme Values} and
380 some were written by Diethelm Wuertz.
381
382 }
383
384
385 \references{
386
387 Coles S. (2001);
388 \emph{Introduction to Statistical Modelling of Extreme Values},
389 Springer.
390
391 Embrechts, P., Klueppelberg, C., Mikosch, T. (1997);
392 \emph{Modelling Extremal Events}, Springer.
393
394 }
395
396
397 \examples{
398 ## SOURCE("fExtremes.51A-ExtremesData")
399
400 ## emdPlot -
401 xmpExtremes("\nStart: Empirical Distribution Function >")
402 # Danish fire insurance data show Pareto tail behaviour:
403 par(mfrow = c(2, 2))
404 data(danish)
405 emdPlot(danish, plottype = "xy", labels = FALSE)
406 title(xlab = "x", ylab = "1-F(x)", main = "Danish Fire")
407 # BMW Stocks:
408 data(bmw)
409 emdPlot(bmw, plottype = "xy", labels = FALSE)
410 title(xlab = "x", ylab = "1-F(x)", main = "BMW Stocks")
411 # Simulated Student-t:
412 emdPlot(rt(5000, 4), plottype = "xy")
413
414 ## qqPlot -
415 xmpExtremes("\nNext: Quantile-Quantile Plot >")
416 # QQ-Plot of Simulated Normal rvs:
417 par(mfrow = c(2, 2))
418 set.seed(4711)
419 qqPlot(rnorm(5000))
420 text(-3.5, 3, pos = 4, "Simulated Normal rvs")
421 # QQ-Plot of simulated Student-t rvs:
422 qqPlot(rt(5000, 4))
423 text(-3.5, 11.0, pos = 4, "Simulated Student-t rvs")
424 # QQ-Plot of BMW share residuals:
425 data(bmw)
426 qqPlot(bmw)
427 text(-3.5, 0.09, pos = 4, "BMW log returns")
428
429 ## qPlot -
430 xmpExtremes("\nNext: QQ-Plot of Heavy Tails >")
431 # QQ-Plot of heavy-tailed Danish fire insurance data:
432 data(danish)
433 qPlot(danish)
434
435 ## mePlot -
436 xmpExtremes("\nNext: Mean Excess Plot >")
437 # Sample mean excess plot of heavy-tailed Danish fire
438 # insurance data
439 par(mfrow = c(3, 2))
440 data(danish)
441 mePlot(danish, labels = FALSE)
442 title(xlab = "u", ylab = "e", main = "mePlot - Danish Fire Data")
443
444 ## mrlPlot -
445 xmpExtremes("\nNext: mean Residual Live Plot >")
446 # Sample mean residual live plot of heavy-tailed Danish Fire
447 # insurance data
448 mrlPlot(danish, labels = FALSE)
449 title(xlab = "u", ylab = "e", main = "mrlPlot - Danish Fire Data")
450
451 ## mxfPlot -
452 xmpExtremes("\nNext: Mean Excess Function Plot >")
453 # Plot the mean excess functions for randomly distributed
454 # residuals
455 par(mfrow = c(2, 2))
456 n = 10000
457 set.seed(4711)
458 xlab = "Threshold: u"; ylab = "Mean Excess: e"
459 mxfPlot(rnorm(n), tail = 0.5, labels = FALSE)
460 title(xlab = xlab, ylab = ylab, main = "mxf Plot - Normal DF")
461 set.seed(7138)
462 mxfPlot(rexp(n, 2), tail = 0.5, labels = FALSE)
463 title(xlab = xlab, ylab = ylab, main = "mxfPlot - Exponential DF")
464 abline(1/2, 0)
465 set.seed(6952)
466 mxfPlot(rlnorm(n, 0, 2), tail = 0.5, xlim = c(0,90),
467 ylim = c(0, 120), labels = FALSE)
468 title(xlab = xlab, ylab = ylab, main = "mxfPlot - Lognormal DF")
469 set.seed(8835)
470 mxfPlot(rgpd(n, 1/2), tail = 0.10, xlim = c(0,200),
471 ylim=c(0,200), labels = FALSE)
472 title(xlab = xlab, ylab = ylab, main = "mxfPlot - Pareto")
473 abline(0, 1)
474
475 ## msratioPlot -
476 xmpExtremes("\nNext: Maximum/Sum Ratio Plot >")
477 # Examples for Ratio of Maximum and Sum Plots:
478 par(mfrow = c(3, 2))
479 data(bmw)
480 xlab = "n"; ylab = "R(n)"
481 msratioPlot (rnorm(8000), labels = FALSE)
482 title(xlab = xlab, ylab = ylab, main = "Standard Normal")
483 msratioPlot (rexp(8000), labels = FALSE)
484 title(xlab = xlab, ylab = ylab, main = "Exponential")
485 msratioPlot (rt(8000, 4), labels = FALSE)
486 title(xlab = xlab, ylab = ylab, main = "Student-t")
487 msratioPlot (rcauchy(8000), labels = FALSE)
488 title(xlab = xlab, ylab = ylab, main = "Cauchy")
489 msratioPlot (bmw, labels = FALSE)
490 title(xlab = xlab, ylab = ylab, main = "BMW Returns")
491
492 ## recordsPlot -
493 xmpExtremes("\nNext: Records Plot >")
494 # Record fire insurance losses in Denmark
495 par(mfrow = c(2, 2))
496 data(danish)
497 recordsPlot(danish)
498 text(1, 7.9, pos = 4, "Danish Fire")
499 # BMW Stocks
500 data(bmw)
501 recordsPlot(bmw)
502 text(1, 12.8, pos = 4, "BMW Shares")
503
504 ## ssrecordsPlot -
505 xmpExtremes("\nNext: Subsample Record Plot >")
506 # Record fire insurance losses in Denmark
507 ssrecordsPlot(danish)
508 text(1, 9.2, pos = 4, "Danish Fire")
509 # BMW Stocks
510 ssrecordsPlot(bmw)
511 text(1, 10.5, pos = 4, "BMW Shares")
512
513 ## xacfPlot -
514 xmpExtremes("\nNext: ACF Plot of Exceedences >")
515 # Plot ACF of Heights/Distances of Eceedences over threshold:
516 par(mfrow = c(2, 2))
517 data(bmw)
518 xacfPlot(bmw)
519
520 ## findThreshold -
521 xmpExtremes("\nStart: Find Thresold >")
522 # Find threshold giving (at least) fifty exceedances
523 # for Danish Fire data
524 data(danish)
525 findThreshold(danish, n = c(10, 50, 100))
526
527 ## blockMaxima -
528 xmpExtremes("\nNext: Compute Block Maxima >")
529 # Block Maxima (Minima) for the right and left tails
530 # of the BMW log returns:
531 data(bmw)
532 par(mfrow = c(2, 1))
533 blockMaxima( bmw, block = 100)
534 blockMaxima(-bmw, block = 100)
535
536 ## deCluster -
537 xmpExtremes("\nNext: De-Cluster Exceedences >")
538 # Decluster the 200 exceedances of a particular
539 # threshold in the negative BMW log-return data
540 par(mfrow = c(2, 2))
541 fit = potFit(-bmw, nextremes = 200)
542 deCluster(fit$fit$data, 30)
543 }
544
545
546 \keyword{hplot}
547
+654
-0
man/052A-GevModelling.Rd less more
0 \name{GevModelling}
1
2 \alias{dgev}
3 \alias{pgev}
4 \alias{qgev}
5 \alias{rgev}
6 \alias{devd}
7 \alias{pevd}
8 \alias{qevd}
9 \alias{revd}
10
11 \alias{GevFit}
12 \alias{gevSim}
13 \alias{gevFit}
14 \alias{print.gevFit}
15 \alias{plot.gevFit}
16 \alias{summary.gevFit}
17 \alias{gevrlevelPlot}
18
19 \alias{hillPlot}
20 \alias{shaparmPlot}
21 \alias{shaparmPickands}
22 \alias{shaparmHill}
23 \alias{shaparmDEHaan}
24
25
26
27 \title{Generalized Extreme Value Modelling}
28
29
30 \description{
31
32 A collection and description functions to compute
33 the generalized extreme value distribution and to
34 estimate it parameters. The functions compute
35 density, distribution function, quantile function
36 and generate random deviates for the GEV, for the
37 Frechet, Gumbel, and Weibull distributions. To model
38 the GEV three types of approaches for parameter
39 estimation are provided: Maximum likelihood
40 estimation, probability weighted moment method,
41 and estimation by the MDA approach. MDA includes
42 functions for the Pickands, Einmal-Decker-deHaan,
43 and Hill estimators together with several plot
44 variants.
45 \cr
46
47 The GEV distribution functions are:
48
49 \tabular{ll}{
50 \code{dgev} \tab density of the GEV Distribution, \cr
51 \code{pgev} \tab probability function of the GEV Distribution, \cr
52 \code{qgev} \tab quantile function of the GEV Distribution, \cr
53 \code{rgev} \tab random variates from the GEV Distribution. \cr
54 \code{[dpqr]frechet} \tab Frechet Distribution, \cr
55 \code{[dpqr]gumbel} \tab Gumbel Distribution, \cr
56 \code{[dpqr]weibull} \tab Weibull Distribution, \cr
57 \code{[dpqr]evd} \tab an alternative call for the GEV Distribution. }
58
59 The GEV modelling functions are:
60
61 \tabular{ll}{
62 \code{gevSim} \tab generates data from the GEV, \cr
63 \code{gevFit} \tab fits empirical or simulated data to the distribution, \cr
64 \code{print} \tab print method for a fitted GEV object, \cr
65 \code{plot} \tab plot method for a fitted GEV object, \cr
66 \code{summary} \tab summary method for a fitted GEV object, \cr
67 \code{gevrlevelPlot} \tab k-block return level with confidence intervals. }
68
69 Maximum Domain of Attraction Estimators:
70
71 \tabular{ll}{
72 \code{hillPlot} \tab shape parameter and Hill estimate of the tail index, \cr
73 \code{shaparmPlot} \tab variation of shape parameter with tail depth. }
74
75 }
76
77
78 \usage{
79 dgev(x, xi = 1, mu = 0, sigma = 1, log = FALSE)
80 pgev(q, xi = 1, mu = 0, sigma = 1, lower.tail = TRUE)
81 qgev(p, xi = 1, mu = 0, sigma = 1, lower.tail = TRUE)
82 rgev(n, xi = 1, mu = 0, sigma = 1)
83 devd(x, loc = 0, scale = 1, shape = 0, log = FALSE)
84 pevd(q, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
85 qevd(p, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
86 revd(n, loc = 0, scale = 1, shape = 0)
87
88 gevSim(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
89 gevFit(x, block = NA, type = c("mle", "pwm"), gumbel = FALSE, \dots)
90 \method{print}{gevFit}(x, \dots)
91 \method{plot}{gevFit}(x, which = "all", \dots)
92 \method{summary}{gevFit}(object, doplot = TRUE, which = "all", \dots)
93 gevrlevelPlot(object, k.blocks = 20, add = FALSE, \dots)
94
95 hillPlot(x, option = c("alpha", "xi", "quantile"), start = 15,
96 end = NA, reverse = FALSE, p = NA, ci = 0.95, autoscale = TRUE,
97 labels = TRUE, \dots)
98 shaparmPlot(x, revert = FALSE, standardize = FALSE, tails = 0.01*(1:10),
99 doplot = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
100 which = c(TRUE, TRUE, TRUE), doprint = TRUE, both.tails = TRUE,
101 xi.range = c(-0.5, 1.5), alpha.range = c(0, 10))
102 }
103
104
105 \arguments{
106
107 \item{add}{
108 [gevrlevelPlot] - \cr
109 whether the return level should be added graphically to a
110 time series plot; if \code{FALSE} a graph of the profile
111 likelihood curve showing the return level and its confidence
112 interval is produced.
113 }
114 \item{alpha.range, xi.range}{
115 [saparmPlot] - \cr
116 plotting ranges.
117 }
118 \item{autoscale}{
119 [hillPlot] - \cr
120 whether or not plot should be automatically
121 scaled; if not, \code{xlim} and \code{ylim} graphical
122 parameters may be entered.
123 }
124 \item{block}{
125 [gevFit] - \cr
126 the block size. Only used if \code{method="mle"} is selected.
127 A numeric value is interpreted as the
128 number of data values in each successive block. All the data is
129 used, so the last block may not contain \code{block} observations.
130 If the \code{data} has a \code{times} attribute containing (in
131 an object of class \code{"POSIXct"}, or an object that can be
132 converted to that class; see \code{\link{as.POSIXct}}) the
133 times/dates of each observation, then \code{block} may instead
134 take the character values \code{"month"}, \code{"quarter"},
135 \code{"semester"} or \code{"year"}.
136 }
137 \item{both.tails}{
138 [shaparmPlot] - \cr
139 a logical, decides whether or not both tails should be
140 investigated. By default TRUE. If FALSE only the lower
141 tail will be investigated.
142 }
143 \item{ci}{
144 [hillPlot] - \cr
145 probability for asymptotic confidence band; for no
146 confidence band set \code{ci} to zero.
147 }
148 \item{doplot}{
149 a logical. Should the results be plotted?
150 \cr
151 [shaparmPlot] - \cr
152 a vector of logicals of the same lengths as tails
153 defining for wich tail depths plots should be created,
154 by default plots will be generated for a tail depth of 5
155 percent. By default \code{c(FALSE, FALSE, FALSE, FALSE,
156 TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)}.
157 }
158 \item{doprint}{
159 [shaparmPlot] - \cr
160 a logical, decides whether or not for all tail depths the
161 result for the shape parameter \code{1/alpha} should be
162 printed.
163 }
164 \item{gumbel}{
165 [gevFit] - \cr
166 a logical, by default FALSE. To fit a Gumbel model with fixed
167 \code{shape=0} set \code{gumbel=TRUE}.
168 }
169 \item{k.blocks}{
170 [gevrlevelPlot] - \cr
171 specifies the particular return level to be estimated; default
172 set arbitrarily to 20.
173 }
174 \item{labels}{
175 [hillPlot] - \cr
176 whether or not axes should be labelled.
177 }
178 \item{loc, scale, shape}{
179 \code{loc} is the location parameter,
180 \code{scale} the scale parameter,
181 and \code{shape} is the shape parameter.
182 The default values are \code{loc=0}, \code{scale=1}, and
183 \code{shape=0}.
184 }
185 \item{log}{
186 a logical, if \code{TRUE}, the log density is returned.
187 }
188 \item{lower.tail}{
189 a logical, if \code{TRUE}, the default, then
190 probabilities are \code{P[X <= x]}, otherwise, \code{P[X > x]}.
191 }
192 \item{model}{
193 [gevSim] - \cr
194 a list with components \code{shape}, \code{location} and
195 \code{scale} giving the parameters of the GEV distribution.
196 By default the shape parameter has the value 0.25, the
197 location is zero and the scale is one.
198 To fit random deviates from a Gumbel distribution set
199 \code{shape=0}.
200 }
201 \item{n}{
202 [gevSim] - \cr
203 number of generated data points, an integer value.
204 \cr
205 [rgev][revd] - \cr
206 the number of observations.
207 }
208 \item{object}{
209 [summary][grlevelPlot] - \cr
210 a fitted object of class \code{"gevFit"}.
211 }
212 \item{option}{
213 [hillPlot] - \cr
214 whether \code{alpha}, \code{xi} (1/alpha) or
215 \code{quantile} (a quantile estimate) should be plotted.
216 }
217 \item{p}{
218 [qgev][qevs] - \cr
219 a numeric vector of probabilities.
220 [hillPlot] - \cr
221 probability required when option \code{quantile} is
222 chosen.
223 }
224 \item{q}{
225 [pgev][pevs] - \cr
226 a numeric vector of quantiles.
227 }
228 \item{reverse}{
229 [hillPlot] - \cr
230 whether plot is to be by increasing threshold, \code{TRUE}, or
231 increasing number of order statistics \code{FALSE}.
232 }
233 \item{revert}{
234 [shaparmPlot] - \cr
235 a logical value, by default FALSE, if set to TRUE the
236 sign of the vector will be reverted: \code{x = -x}.
237 }
238 \item{start, end}{
239 [hillPlot] - \cr
240 lowest and highest number of order statistics at which to plot
241 a point.
242 }
243 \item{standardize}{
244 [shaparmPlot] - \cr
245 a logical value, by default FALSE, if set to
246 TRUE the vector \code{x} will be standardized:
247 \code{x = (x-mean(x))/sqrt(var(x))}.
248 }
249 \item{tails}{
250 [shaparmPlot] - \cr
251 a numeric vector of tail depths to be considered; by
252 default ten values ranging from 0.1 to 1.0 in steps of 0.1
253 corresponding to values ranging from 1 to 10 percent.
254 }
255 \item{type}{
256 a character string denoting the type of parameter estimation,
257 either by maximum likelihood estimation \code{"mle"}, the
258 default value, or by the probability weighted moment menthod
259 \code{"pwm"}.
260 }
261 \item{which}{
262 [shaparmPlot] - \cr
263 a vector of 3 logicals indicating which plots from the
264 three methods will be created. The first entry decides
265 for the Pickands estimator, the second for the Hill
266 estimator, and the last for the Deckers-Einmahl-deHaan
267 estimator. By default all three will be created.
268 By default \code{c(TRUE, TRUE, TRUE)}.
269 \cr
270 [plot][summary] - \cr
271 a vector of logicals, one for each plot, denoting which plot
272 should be displayed. Alkternatively if \code{which="ask"} the
273 user will be interactively asked which of the plots should be
274 desplayed. By default \code{which="all"}.
275 }
276 \item{x}{
277 [dgev][devd] - \cr
278 a numeric vector of quantiles.
279 \cr
280 [gevFit] - \cr
281 data vector. In the case of \code{method="mle"} the interpretation
282 depends on the value of block: if no block size is specified then
283 data are interpreted as block maxima; if block size is set, then data
284 are interpreted as raw data and block maxima are calculated.
285 \cr
286 [hillPlot][shaparmPlot] - \cr
287 the data from which to calculate the shape parameter, a
288 numeric vector.
289 \cr
290 [print][plot] - \cr
291 a fitted object of class \code{"gevFit"}.
292 }
293 \item{xi, mu, sigma}{
294 \code{xi} is the shape parameter,
295 \code{mu} the location parameter,
296 and \code{sigma} is the scale parameter.
297 The default values are \code{xi=1}, \code{mu=0}, and
298 \code{sigma=1}.
299 }
300 \item{\dots}{
301 [gevFit] - \cr
302 control parameters optionally passed to the
303 optimization function. Parameters for the optimization
304 function are passed to components of the \code{control} argument of
305 \code{optim}.
306 \cr
307 [hillPlot] - \cr
308 other graphics parameters.
309 \cr
310 [plot][summary] - \cr
311 arguments passed to the plot function.
312 }
313
314 }
315
316
317 \value{
318
319 \code{d*} returns the density, \cr
320 \code{p*} returns the probability, \cr
321 \code{q*} returns the quantiles, and \cr
322 \code{r*} generates random variates. \cr
323 All values are numeric vectors.
324 \cr
325
326 \code{gevSim}
327 \cr
328 returns a vector of data points from the simulated series.
329 \cr
330
331 \code{gevFit}
332 \cr
333 returns an object of class \code{gev} describing the fit.
334 \cr
335
336 \code{print.summary}
337 \cr
338 prints a report of the parameter fit.
339 \cr
340
341 \code{summary}
342 \cr
343 performs diagnostic analysis. The method provides two different
344 residual plots for assessing the fitted GEV model.
345 \cr
346
347 \code{gevrlevelPlot}
348 \cr
349 returns a vector containing the lower 95\% bound of the confidence
350 interval, the estimated return level and the upper 95\% bound.
351 \cr
352
353 \code{hillPlot}
354 \cr
355 displays a plot.
356 \cr
357
358 \code{shaparmPlot}
359 \cr
360 returns a list with one or two entries, depending on the
361 selection of the input variable \code{both.tails}. The two
362 entries \code{upper} and \code{lower} determine the position of
363 the tail. Each of the two variables is again a list with entries
364 \code{pickands}, \code{hill}, and \code{dehaan}. If one of the
365 three methods will be discarded the printout will display zeroes.
366
367 }
368
369
370 \details{
371
372 \bold{Generalized Extreme Value Distribution:}
373 \cr\cr
374 Computes density, distribution function, quantile function and
375 generates random variates for the Generalized Extreme Value
376 Distribution, GEV, for the Frechet, Gumbel, and Weibull
377 distributions.
378 \cr
379
380 \bold{Parameter Estimation:}
381 \cr\cr
382 \code{gevFit} estimates the parameters either by the probability
383 weighted moment method, \code{method="pwm"} or by maximum log
384 likelihood estimation \code{method="mle"}.
385 As a limiting case the Gumbel distribution can be selected. The
386 summary method produces diagnostic plots for fitted GEV or Gumbel
387 models.
388 \cr
389
390 \bold{Methods:}
391 \cr\cr
392 \code{print.gev}, \code{plot.gev} and \code{summary.gev} are
393 print, plot, and summary methods for a fitted object of class
394 \code{gev}. Concerning the summary method, the data are
395 converted to unit exponentially distributed residuals under null
396 hypothesis that GEV fits. Two diagnostics for iid exponential data
397 are offered. The plot method provides two different residual plots
398 for assessing the fitted GEV model. Two diagnostics for
399 iid exponential data are offered.
400 \cr
401
402 \bold{Return Level Plot:}
403 \cr\cr
404 \code{gevrlevelPlot} calculates and plots the k-block return level
405 and 95\% confidence interval based on a GEV model for block maxima,
406 where \code{k} is specified by the user. The k-block return level
407 is that level exceeded once every \code{k} blocks, on average. The
408 GEV likelihood is reparameterized in terms of the unknown return
409 level and profile likelihood arguments are used to construct a
410 confidence interval.
411 \cr
412
413 \bold{Hill Plot:}
414 \cr\cr
415 The function \code{hillPlot} investigates the shape parameter and
416 plots the Hill estimate of the tail index of heavy-tailed data, or
417 of an associated quantile estimate. This plot is usually calculated
418 from the alpha perspective. For a generalized Pareto analysis of
419 heavy-tailed data using the \code{gpdFit} function, it helps to
420 plot the Hill estimates for \code{xi}.
421 \cr
422
423 \bold{Shape Parameter Plot:}
424 \cr\cr
425 The function \code{shaparmPlot} investigates the shape parameter and
426 plots for the upper and lower tails the shape parameter as a function
427 of the taildepth. Three approaches are considered, the \emph{Pickands}
428 estimator, the \emph{Hill} estimator, and the
429 \emph{Decker-Einmal-deHaan} estimator.
430
431 }
432
433
434 \note{
435
436 \bold{Generalized Extreme Value Distribution:}
437 \cr\cr
438 Here we implemented the notation for the arguments as used
439 by the GEV functions in the EVIS package or SPlus/FinMetrics
440 module. Additional arguments to these packages are the \code{log}
441 and the \code{lower.tail} arguments, underlying the code
442 from R's \code{evd} package.
443 \cr
444 An alternative usage is proposed by the \code{evd} package.
445 There the following arguments are used:
446 \cr
447 \code{*gev(x, loc = 0, scale = 1, shape = 0, ...)}
448 \cr
449 What you prefer is a matter of taste. The GEV functions from
450 the \code{evd} package are renamed from \code{*gev} to \code{*evd}
451 so that both versions are available.
452 \cr
453 In addition functions for the density, probability, quantiles,
454 and the generation of random variates for the
455 Frechet \code{[dpqr]frechet},
456 Gumbel \code{[dpqr]gumbel}, and
457 Weibull \code{[dpqr]weibull} are also available.
458 \cr
459 If you stay with both versions you can access the help page for
460 \code{evds}'s function \code{dgev} by \code{help(dgev, package="evd")}.
461 \cr
462
463 \bold{Generalized Extreme Value Distribution:}
464 \cr\cr
465 If method \code{"mle"} is selected the parameter fitting in \code{gevFit}
466 is passed to the internal function \code{gev.mle} or \code{gumbel.mle}
467 depending on the value of \code{gumbel}, \code{FALSE} or \code{TRUE}.
468 On the other hand, if method \code{"pwm"} is selected the parameter
469 fitting in \code{gevFit} is passed to the internal function
470 \code{gev.pwm} or \code{gumbel.pwm} again depending on the value of
471 \code{gumbel}, \code{FALSE} or \code{TRUE}.
472
473 }
474
475
476 \references{
477
478 Coles S. (2001);
479 \emph{Introduction to Statistical Modelling of Extreme Values},
480 Springer.
481
482 Embrechts, P., Klueppelberg, C., Mikosch, T. (1997);
483 \emph{Modelling Extremal Events},
484 Springer.
485
486 }
487
488
489 \author{
490
491 Alec Stephenson for R's \code{evd} and \code{evir} package, and \cr
492 Diethelm Wuertz for this \R-port.
493
494 }
495
496
497 \examples{
498 ## SOURCE("fExtremes.52A-GevModelling")
499
500 ## *gev -
501 xmpExtremes("\nStart: GEV Frechet >")
502 # Create and plot 1000 GEV/Frechet distributed rdv:
503 par(mfrow = c(3, 3))
504 r = rgev(n = 1000, xi = 1)
505 plot(r, type = "l", main = "GEV/Frechet Series")
506 ## Plot empirical density and compare with true density:
507 ## Omit values greater than 500 from plot
508 hist(r[r<10], n = 25, probability = TRUE, xlab = "r",
509 xlim = c(-5, 5), ylim = c(0, 1.1), main = "Density")
510 x = seq(-5, 5, by=0.01)
511 lines(x, dgev(x, xi = 1), col = 2)
512 ## Plot df and compare with true df:
513 plot(sort(r), (1:length(r)/length(r)),
514 xlim = c(-3, 6), ylim = c(0, 1.1),
515 cex = 0.5, ylab = "p", xlab = "q", main = "Probability")
516 q = seq(-5,5, by=0.1)
517 lines(q, pgev(q, xi=1), col=2)
518 ## Compute quantiles, a test:
519 qgev(pgev(seq(-5, 5, 0.25), xi = 1), xi = 1)
520
521 ## *gev -
522 xmpExtremes("\nNext: GEV Gumbel >")
523 # Create and plot 1000 Gumbel distributed rdv:
524 ##> r = rgev(n = 1000, xi = 0)
525 ##> plot(r, type = "l", main = "Gumbel Series")
526 ## Plot empirical density and compare with true density:
527 ##>hist(r[abs(r)<10], nclass = 25, freq = FALSE, xlab = "r",
528 ##> xlim = c(-5,5), ylim = c(0,1.1), main = "Density")
529 ##>x = seq(-5, 5, by = 0.01)
530 ##>lines(x, dgev(x, xi = 0), col=2)
531 ## Plot df and compare with true df:
532 ##>plot(sort(r), (1:length(r)/length(r)),
533 ##> xlim = c(-3, 6), ylim = c(0, 1.1),
534 ##> cex=0.5, ylab = "p", xlab="q", main="Probability")
535 ##>q = seq(-5, 5, by = 0.1)
536 ##>lines(q, pgev(q, xi = 0), col = 2)
537 ## Compute quantiles, a test:
538 ##>qgev(pgev(seq(-5, 5, 0.25), xi = 0), xi = 0)
539
540 ## *gev -
541 xmpExtremes("\nNext: GEV Weibull >")
542 # Create and plot 1000 Weibull distributed rdv:
543 r = rgev(n = 1000, xi = -1)
544 plot(r, type = "l", main = "Weibull Series")
545 ## Plot empirical density and compare with true density:
546 hist(r[abs(r)<10], nclass = 25, freq = FALSE, xlab = "r",
547 xlim=c(-5,5), ylim=c(0,1.1), main="Density")
548 x = seq(-5, 5, by=0.01)
549 lines(x, dgev(x, xi = -1), col = 2)
550 ## Plot df and compare with true df:
551 plot(sort(r), (1:length(r)/length(r)),
552 xlim = c(-3, 6), ylim = c(0, 1.1),
553 cex = 0.5, ylab = "p", xlab = "q", main = "Probability")
554 q=seq(-5, 5, by = 0.1)
555 lines(q, pgev(q, xi = -1), col = 2)
556 ## Compute quantiles, a test:
557 qgev(pgev(seq(-5, 5, 0.25), xi = -1), xi = -1)
558
559 ## gevSim -
560 ## gevFit -
561 # Simulate GEV Data:
562 xmpExtremes("\nStart: Simulte GEV Sample >")
563 # Use default length n=1000
564 x = gevSim(model = list(shape = 0.25, location =0 , scale = 1))
565 # Fit GEV Data by Probability Weighted Moments:
566 fit = gevFit(x, type = "pwm")
567 print(fit)
568 # Summarize Results:
569 par(mfcol = c(3, 2))
570 summary(fit)
571
572 ## gevFit -
573 # Fit GEV Data by Max Log Likelihood Method:
574 xmpExtremes("\nNext: Estimate Parameters >")
575 fit = gevFit(x, type = "mle")
576 print(fit)
577 # Summarize Results:
578 summary(fit)
579
580 ## gevSim -
581 ## gevFit -
582 # Simulate Gumbel Data:
583 xmpExtremes("\nNext: Simulte Gumbel Sample >")
584 # Use default length n=1000
585 ##> x = gevSim(model = list(shape = 0, location = 0, scale = 1))
586 # Fit Gumbel Data by Probability Weighted Moments:
587 ##> fit = gevFit(x, type = "pwm", gumbel = TRUE)
588 ##> print(fit)
589 # Summarize Results:
590 ##> par(mfcol = c(3, 2))
591 ##> summary(fit)
592
593 ## Fit Gumbel Data by Max Log Likelihood Method:
594 xmpExtremes("\nNext: Estimate Parameters >")
595 ##> fit = gevFit(x, type = "mle", gumbel = TRUE)
596 ##> print(fit)
597 # Summarize Results:
598 ##> summary(fit)
599 ##> xmpExtremes("Press any key to continue >")
600
601 ## Return levels based on GEV Fit:
602 # BMW Stock Data:
603 xmpExtremes("\nNext: Compute BMW Return Levels >")
604 par(mfrow = c(2, 1))
605 data(bmw)
606 # Fit GEV to monthly Block Maxima:
607 fit = gevFit(-bmw, block = "month")
608 # Calculate the 40 month return level
609 gevrlevelPlot(fit, k.block = 40, main = "BMW: Return Levels")
610
611 ## Return levels based on GEV Fit:
612 xmpExtremes("\nNext: Compute SIEMENS Return Levels >")
613 # Siemens Stock Data:
614 data(siemens)
615 # Fit GEV to monthly Block Maxima:
616 fit = gevFit(-siemens, block = "month")
617 # Calculate the 40 month return level
618 gevrlevelPlot(fit, k.block = 40, main = "SIEMENS: Return Levels")
619
620 ## Interactive Plot:
621 ##> par(mfrow = c(1, 1), ask = TRUE)
622 ##> plot(fit)
623
624 ## hillPlot -
625 xmpExtremes("\nStart: Hill Estimator >")
626 # Hill plot of heavy-tailed Danish fire insurance data
627 # and BMW stock data for estimated 0.999 quantile
628 par(mfrow = c(2, 2))
629 data(bmw)
630 hillPlot(bmw)
631 hillPlot(bmw, option = "quantile", end = 500, p = 0.999)
632 data(danish)
633 hillPlot(danish)
634 hillPlot(danish, option = "quantile", end = 500, p = 0.999)
635
636 ## shaparmPlot -
637 xmpExtremes("\nNext: Shape Parameter Plots >")
638 par(mfcol = c(3, 2), cex = 0.6)
639 data(bmw)
640 shaparmPlot(bmw)
641
642 ## shaparmPlot -
643 xmpExtremes("\nNext: Simulated Frechet Data >")
644 par(mfcol = c(3, 2), cex = 0.6)
645 set.seed(4711)
646 x = rgev(10000, xi = 1/4)
647 shaparmPlot(x, revert = TRUE, both.tails = FALSE)
648 lines(c(0.01, 0.1), c(4, 4), col = "steelblue3") # True Value
649 }
650
651
652 \keyword{models}
653
+133
-0
man/053A-GpdModelling.Rd less more
0 \name{GpdDistribution}
1
2 \alias{GpdDistribution}
3
4 \alias{dgpd}
5 \alias{pgpd}
6 \alias{qgpd}
7 \alias{rgpd}
8
9 \title{GPD Distributions for Extreme Value Theory}
10
11
12 \description{
13
14 A collection and description of distribution functions
15 used in extreme value theory. The functions compute
16 density, distribution function, quantile function and
17 generate random deviates for the Generalized Pareto
18 Distribution GPD.
19 \cr
20
21 The functions are:
22
23 \tabular{ll}{
24 \code{dgpd} \tab Density of the GPD Distribution, \cr
25 \code{pgpd} \tab Probability function of the GPD Distribution, \cr
26 \code{qgpd} \tab Quantile function of the GPD Distribution, \cr
27 \code{rgpd} \tab Random variates from the GPD Distribution. }
28
29 }
30
31
32 \usage{
33 dgpd(x, xi = 1, mu = 0, beta = 1)
34 pgpd(q, xi = 1, mu = 0, beta = 1)
35 qgpd(p, xi = 1, mu = 0, beta = 1)
36 rgpd(n, xi = 1, mu = 0, beta = 1)
37 }
38
39
40 \arguments{
41
42 \item{n}{
43 the number of observations.
44 }
45 \item{p}{
46 a numeric vector of probabilities.
47 }
48 \item{q}{
49 a numeric vector of quantiles.
50 }
51 \item{x}{
52 a numeric vector of quantiles.
53 }
54 \item{xi, mu, beta}{
55 \code{xi} is the shape parameter,
56 \code{mu} the location parameter,
57 and \code{beta} is the scale parameter.
58 }
59
60 }
61
62
63 \value{
64
65 All values are numeric vectors: \cr
66 \code{d*} returns the density, \cr
67 \code{p*} returns the probability, \cr
68 \code{q*} returns the quantiles, and \cr
69 \code{r*} generates random deviates. \cr
70 }
71
72
73 \details{
74
75 \bold{Generalized Pareto Distribution:}
76 \cr\cr
77 Compute density, distribution function, quantile function and
78 generates random variates for the Generalized Pareto Distribution.
79
80 }
81
82
83 \author{
84
85 Alec Stephenson for the functions from R's \code{evd} package, \cr
86 Diethelm Wuertz for this \R-port.
87
88 }
89
90
91 \references{
92
93 Embrechts, P., Klueppelberg, C., Mikosch, T. (1997);
94 \emph{Modelling Extremal Events}, Springer.
95
96 }
97
98
99 \examples{
100 ## SOURCE("fExtremes.53A-GpdModelling")
101
102 ## *gpd -
103 xmpExtremes("\nStart: Simulate GPD Distributed sample >")
104 par(mfrow = c(2, 2))
105 r = rgpd(n = 1000, xi = 1/4)
106 plot(r, type = "l", main = "GPD Series")
107
108 ## Plot empirical density and compare with true density:
109 ## Omit values greater than 500 from plot
110 xmpExtremes("\nNext: Plot Empirical and True Density >")
111 hist(r, n = 50, probability = TRUE, xlab = "r",
112 xlim = c(-5, 5), ylim = c(0, 1.1), main = "Density")
113 x = seq(-5, 5, by = 0.01)
114 lines(x, dgpd(x, xi = 1/4), col = "steelblue3")
115
116 ## Plot df and compare with true df:
117 xmpExtremes("\nNext: Plot Empirical and True Probability >")
118 plot(sort(r), (1:length(r)/length(r)),
119 xlim = c(-3, 6), ylim = c(0, 1.1),
120 cex = 0.5, ylab = "p", xlab = "q", main = "Probability")
121 q = seq(-5, 5, by = 0.1)
122 lines(q, pgpd(q, xi = 1/4), col = "steelblue3")
123
124 ## Compute quantiles, a test:
125 xmpExtremes("\nNext: Compute Quantiles >")
126 qgpd(pgpd(seq(-1, 5, 0.25), xi = 1/4 ), xi = 1/4)
127
128 }
129
130
131 \keyword{distribution}
132
+406
-0
man/053B-GpdFit.Rd less more
0 \name{GpdFit}
1
2 \alias{GpdFit}
3
4 \alias{gpdSim}
5 \alias{gpdFit}
6
7 \alias{print.gpdFit}
8 \alias{plot.gpdFit}
9 \alias{summary.gpdFit}
10
11 \alias{gpdqPlot}
12 \alias{gpdquantPlot}
13 \alias{gpdriskmeasures}
14 \alias{gpdsfallPlot}
15 \alias{gpdshapePlot}
16 \alias{gpdtailPlot}
17
18
19 \title{Modelling the Generalized Pareto Distribution}
20
21
22 \description{
23
24 A collection and description of functions to model
25 the Generalized Pareto Distribution, GPD, based on
26 \R's 'evir' package. Two approaches for parameter
27 estimation are provided: Maximum likelihood estimation
28 and the probability weighted moment method.
29 \cr
30
31 The functions are:
32
33 \tabular{ll}{
34 \code{gpdSim} \tab generates data from the GPD, \cr
35 \code{gpdFit} \tab fits empirical or simulated data to the distribution, \cr
36 \code{print} \tab print method for a fitted GPD object of class ..., \cr
37 \code{plot} \tab plot method for a fitted GPD object, \cr
38 \code{summary} \tab summary method for a fitted GPD object, \cr
39 \code{gpdqPlot} \tab estimation of high quantiles, \cr
40 \code{gpdquantPlot} \tab variation of high quantiles with threshold, \cr
41 \code{gpdriskmeasures} \tab prescribed quantiles and expected shortfalls, \cr
42 \code{gpdsfallPlot} \tab expected shortfall with confidence intervals, \cr
43 \code{gpdshapePlot} \tab variation of shape with threshold, \cr
44 \code{gpdtailPlot} \tab plot of the tail. }
45
46 }
47
48
49 \usage{
50 gpdSim(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
51 gpdFit(x, threshold = NA, nextremes = NA, type = c("mle", "pwm"),
52 information = c("observed", "expected"), \dots)
53
54 \method{print}{gpdFit}(x, \dots)
55 \method{plot}{gpdFit}(x, which = "all", \dots)
56 \method{summary}{gpdFit}(object, doplot = TRUE, which = "all", \dots)
57
58 gpdqPlot(x, pp = 0.99, ci.type = c("likelihood", "wald"), ci.p = 0.95,
59 like.num = 50)
60 gpdquantPlot(data, p = 0.99, models = 30, start = 15, end = 500,
61 reverse = TRUE, ci = 0.95, autoscale = TRUE, labels = TRUE, \dots)
62 gpdriskmeasures(x, plevels = c(0.99, 0.995, 0.999, 0.9995, 0.9999))
63 gpdsfallPlot(x, pp = 0.99, ci.p = 0.95, like.num = 50)
64 gpdshapePlot(data, models = 30, start = 15, end = 500, reverse = TRUE,
65 ci = 0.95, autoscale = TRUE, labels = TRUE, \dots)
66 gpdtailPlot(fit, optlog = NA, extend = 1.5, labels = TRUE, \dots)
67 }
68
69
70 \arguments{
71
72 \item{autoscale}{
73 whether or not plot should be automatically scaled;
74 if not, xlim and ylim graphical parameters may be entered.
75 }
76 \item{ci}{
77 the probability for asymptotic confidence band; for no
78 confidence band set to zero.
79 }
80 \item{ci.p}{
81 the probability for confidence interval (must be less
82 than 0.999).
83 }
84 \item{ci.type}{
85 the method for calculating a confidence interval:
86 \code{"likelihood"} or \code{"wald"}.
87 }
88 \item{data}{
89 a numeric vector of data.
90 }
91 \item{doplot}{
92 a logical. Should the results be plotted?
93 }
94 \item{extend}{
95 optional argument for plots 1 and 2 expressing how far x-axis
96 should extend as a multiple of the largest data value. This
97 argument must take values greater than 1 and is useful for
98 showing estimated quantiles beyond data.
99 }
100 \item{fit}{
101 [print][plot][summary] - \cr
102 print method, a fitted object of class \code{"gpd"}.
103 }
104 \item{information}{
105 whether standard errors should be calculated with
106 \code{"observed"} or \code{"expected"} information. This only applies
107 to the maximum likelihood method; for the probability-weighted moments
108 method \code{"expected"} information is used if possible.
109 }
110 \item{labels}{
111 optional argument for plots 1 and 2 specifying whether or not
112 axes should be labelled.
113 }
114 \item{like.num}{
115 the number of times to evaluate profile likelihood.
116 }
117 \item{model}{
118 [gpdsim] - \cr
119 a list with components \code{shape}, \code{location} and
120 \code{scale} giving the parameters of the GPD distribution.
121 By default the shape parameter has the value 0.25, the
122 location is zero and the scale is one.}
123 \item{models}{
124 the number of consecutive gpd models to be fitted.
125 }
126 \item{n}{
127 [gpdsim] - \cr
128 lnumber of generated data points, an integer value.
129 }
130 \item{nextremes}{
131 [gpdFit] - \cr
132 the number of upper extremes to be used (either this or
133 \code{threshold} must be given but not both).
134 }
135 \item{object}{
136 [summary] - \cr
137 a fitted object of class \code{"gpdFit"}.
138 }
139 \item{optlog}{
140 optional argument for plots 1 and 2 giving a particular choice
141 of logarithmic axes: \code{"x"} x-axis only; \code{"y"} y-axis
142 only; \code{"xy"} both axes; \code{""} neither axis.
143 }
144 \item{plevels, p, pp}{
145 a vector of probability levels, the desired probability for the
146 quantile estimate (e.g. 0.99 for the 99th percentile).
147 }
148 \item{reverse}{
149 should plot be by increasing threshold (\code{TRUE}) or number
150 of extremes (\code{FALSE}).
151 }
152 \item{start, end}{
153 the lowest and maximum number of exceedances to be considered.
154 }
155 \item{threshold}{
156 a threshold value (either this or \code{nextremes} must be given
157 but not both).
158 }
159 \item{type}{
160 a character string selecting the desired estimation mehtod, either
161 \code{"mle"} for the maximum likelihood mehtod or \code{"pwm"} for
162 the probability weighted moment method. By default, the first will
163 be selected. Note, the function \code{gpd} uses \code{"ml"}.
164 }
165 \item{which}{
166 if \code{which} is set to \code{"ask"} the function will
167 interactively ask which plot should be displayed. By default
168 this value is set to \code{FALSE} and then those plots will
169 be displayed for which the elements in the logical vector
170 \code{which} ar set to \code{TRUE}; by default all four
171 elements are set to \code{"all"}.
172 }
173 \item{x}{
174 [gpdFit] - \cr
175 the data vector. Note, there are two different names
176 for the first argument \code{x} and \code{data} depending
177 which function name is used, either \code{gpdFit} or the
178 EVIS synonyme \code{gpd}.
179 \cr
180 [print][plot] - \cr
181 a fitted object of class \code{"gpdFit"}.
182 }
183 \item{\dots}{
184 control parameters and plot parameters optionally passed to the
185 optimization and/or plot function. Parameters for the optimization
186 function are passed to components of the \code{control} argument of
187 \code{optim}.
188 }
189
190 }
191
192
193 \value{
194
195 \code{gpdSim}
196 \cr
197 returns a vector of datapoints from the simulated
198 series.
199
200 \code{gpdFit}
201 \cr
202 returns an object of class \code{"gpd"} describing the
203 fit including parameter estimates and standard errors.
204
205 \code{gpdquantPlot}
206 \cr
207 returns invisible a table of results.
208
209 \code{gpdshapePlot}
210 \cr
211 returns invisible a table of results.
212
213 \code{gpdtailPlot}
214 \cr
215 returns invisible a list object containing
216 details of the plot is returned invisibly. This object should be
217 used as the first argument of \code{gpdqPlot} or \code{gpdsfallPlot}
218 to add quantile estimates or expected shortfall estimates to the
219 plot.
220
221 }
222
223
224 \details{
225
226 \bold{Simulation:}
227 \cr\cr
228 \code{gpdSim} simulates data from a Generalized Pareto
229 distribution.
230 \cr
231
232 \bold{Parameter Estimation:}
233 \cr\cr
234 \code{gpdFit} fits the model parameters either by the probability
235 weighted moment method or the maxim log likelihood method.
236 The function returns an object of class \code{"gpd"}
237 representing the fit of a generalized Pareto model to excesses over
238 a high threshold. The fitting functions use the probability weighted
239 moment method, if method \code{method="pwm"} was selected, and the
240 the general purpose optimization function \code{optim} when the
241 maximum likelihood estimation, \code{method="mle"} or \code{method="ml"}
242 is chosen.
243 \cr
244
245 \bold{Methods:}
246 \cr\cr
247 \code{print.gpd}, \code{plot.gpd} and \code{summary.gpd} are print,
248 plot, and summary methods for a fitted object of class \code{gpdFit}.
249 The plot method provides four different plots for assessing fitted
250 GPD model.
251 \cr
252
253 \bold{gpd* Functions:}
254 \cr\cr
255 \code{gpdqPlot} calculates quantile estimates and confidence intervals
256 for high quantiles above the threshold in a GPD analysis, and adds a
257 graphical representation to an existing plot. The GPD approximation in
258 the tail is used to estimate quantile. The \code{"wald"} method uses
259 the observed Fisher information matrix to calculate confidence interval.
260 The \code{"likelihood"} method reparametrizes the likelihood in terms
261 of the unknown quantile and uses profile likelihood arguments to
262 construct a confidence interval.
263 \cr
264
265 \code{gpdquantPlot} creates a plot showing how the estimate of a
266 high quantile in the tail of a dataset based on the GPD approximation
267 varies with threshold or number of extremes. For every model
268 \code{gpdFit} is called. Evaluation may be slow. Confidence intervals
269 by the Wald method may be fastest.
270 \cr
271
272 \code{gpdriskmeasures} makes a rapid calculation of point estimates
273 of prescribed quantiles and expected shortfalls using the output of the
274 function \code{gpdFit}. This function simply calculates point estimates
275 and (at present) makes no attempt to calculate confidence intervals for
276 the risk measures. If confidence levels are required use \code{gpdqPlot}
277 and \code{gpdsfallPlot} which interact with graphs of the tail of a loss
278 distribution and are much slower.
279 \cr
280
281 \code{gpdsfallPlot} calculates expected shortfall estimates, in other
282 words tail conditional expectation and confidence intervals for high
283 quantiles above the threshold in a GPD analysis. A graphical
284 representation to an existing plot is added. Expected shortfall is
285 the expected size of the loss, given that a particular quantile of the
286 loss distribution is exceeded. The GPD approximation in the tail is used
287 to estimate expected shortfall. The likelihood is reparametrised in
288 terms of the unknown expected shortfall and profile likelihood arguments
289 are used to construct a confidence interval.
290 \cr
291
292 \code{gpdshapePlot} creates a plot showing how the estimate of shape
293 varies with threshold or number of extremes. For every model
294 \code{gpdFit} is called. Evaluation may be slow.
295 \cr
296
297 \code{gpdtailPlot} produces a plot of the tail of the underlying
298 distribution of the data.
299
300 }
301
302
303 \references{
304
305 Hosking J.R.M., Wallis J.R., (1987);
306 \emph{Parameter and quantile estimation for the generalized
307 Pareto distribution},
308 Technometrics 29, 339--349.
309
310 }
311
312
313 \author{
314
315 This function is based on Alec Stephenson's R-package \code{evir}
316 ported from the \code{EVIS} library, \emph{Extreme Values in S},
317 written by Alexander McNeil. The \code{fExtremes} port and the
318 change and addition of some functions were done by Diethelm Wuertz.
319
320 }
321
322
323 \examples{
324 ## SOURCE("fExtremes.53B-GpdFit")
325
326 ## Load Data:
327 data(danish)
328
329 ## gpdSim -
330 # Simulate GPD Data:
331 xmpExtremes("\nStart: Simulate a GPD Distributed Sample > ")
332 x = gpdSim(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
333
334 ## gpdFit -
335 xmpExtremes("\nNext: Fit Simulated Data to GPD using PWM > ")
336 fit = gpdFit(x, nextremes = length(x), type = "pwm")
337 print(fit)
338 par(mfcol = c(4, 2), cex = 0.7)
339 summary(fit)
340
341 ## gpdFit -
342 xmpExtremes("\nNext: Fit Simulated Data to GPD using MLE > ")
343 fit = gpdFit(x, nextremes = length(x), type = "mle")
344 print(fit)
345 summary(fit)
346
347 ## gpdFit -
348 xmpExtremes("\nNext: Fit Danish Fire Data to Excess Losses over 10 > ")
349 fit = gpdFit(danish, 10, type = "mle")
350 print(fit)
351 par(mfrow = c(2, 2), cex = 0.7)
352 summary(fit)
353
354 ## gpdqPlot -
355 xmpExtremes("\nNext: 99.5th Percentiles for Danish Fire Data > ")
356 fit = gpdFit(danish, threshold = 10, type = "mle")
357 par(mfrow = c(1, 1))
358 tail = gpdtailPlot(fit)
359 gpdqPlot(tail, 0.995)
360 title(main = "Danish Data: 99.5th Percentile")
361
362 ## gpdquantPlot -
363 xmpExtremes("\nNext: 99.9th Percentiles for Danish Fire Data > ")
364 par(mfrow = c(1, 1))
365 gpdquantPlot(danish, p = 0.999)
366 title(sub = "Danish Fire: GPD High Quantile")
367
368 ## gpdsfallPlot -
369 xmpExtremes("\nNext: Expected Shortfall for Danish Fire Data > ")
370 fit = gpdFit(danish, nextremes = floor(length(danish)/10), type = "mle")
371 par(mfrow = c(1, 1))
372 tp = gpdtailPlot(fit)
373 gpdsfallPlot(tp, 0.999)
374 title(main = "Danish Fire: Expected Shortfall")
375
376 ## gpdriskmeasures -
377 xmpExtremes("\nNext: Quantiles and Expected Shortfalls > ")
378 # Give estimates of 0.999 and 0.9999 quantiles - Danish Fire Date:
379 fit = gpdFit(danish, threshold = 10, type = "mle")
380 par(mfrow = c(1, 1))
381 gpdriskmeasures(fit, c(0.99, 0.995, 0.999, 0.9995, 0.9999))
382
383 ## gpdshapePlot -
384 xmpExtremes("\nNext: Shape Plot of Heavy-Tailed Simulated Data > ")
385 set.seed(4711)
386 par(mfrow = c(1, 1))
387 gpdshapePlot(gpdSim(n = 1000))
388 title(sub = "Simulated GPD", cex.sub = 0.7)
389
390 ## gpdshapePlot -
391 xmpExtremes("\nNext: Shape Plot of Heavy-Tailed Danish Fire Data > ")
392 par(mfrow = c(1, 1))
393 gpdshapePlot(danish)
394 title(sub = "Danish Fire", cex.sub = 0.7)
395
396 ## gpdtailPlot -
397 xmpExtremes("\nNext: Plot Tail Estimate of Danish Fire Data >")
398 fit = gpdFit(danish, threshold = 10, type = "mle")
399 par(mfrow = c(1, 1))
400 gpdtailPlot(fit, main = "Danish Fire: GPD Tail Estimate", col = "steelblue4")
401 }
402
403
404 \keyword{models}
405
+151
-0
man/053C-PotFit.Rd less more
0 \name{PotFit}
1
2 \alias{PotFit}
3
4 \alias{potSim}
5 \alias{potFit}
6
7 \alias{print.potFit}
8 \alias{plot.potFit}
9 \alias{summary.potFit}
10
11 \title{Modelling Peaks Over a Threshold}
12
13
14 \description{
15
16 a collection and description of functions to model
17 point processes over a threshold, POT, based on \R's
18 'evir' package.
19 \cr
20
21 The functions are:
22
23 \tabular{ll}{
24 \code{potSim} \tab generates data from a point process, \cr
25 \code{potFit} \tab fits empirical or simulated data to a point process, \cr
26 \code{print} \tab print method for a fitted POT object of class ..., \cr
27 \code{plot} \tab plot method for a fitted GEV object, \cr
28 \code{summary} \tab summary method for a fitted GEV object, \cr
29 \code{gevrlevelPlot} \tab k-block return level with confidence intervals. }
30
31 }
32
33
34 \usage{
35 potSim(x, threshold, nextremes = NA, run = NA)
36 potFit(x, threshold = NA, nextremes = NA, run = NA, \dots)
37
38 \method{print}{potFit}(x, \dots)
39 \method{plot}{potFit}(x, which = "all", \dots)
40 \method{summary}{potFit}(object, doplot = TRUE, which = "all", \dots)
41 }
42
43
44 \arguments{
45
46
47 \item{doplot}{
48 a logical. Should the results be plotted?
49 }
50 \item{nextremes}{
51 the number of upper extremes to be used (either
52 this or \code{threshold} must be given but not both).
53 }
54 \item{object}{
55 [summary] - \cr
56 a fitted object of class \code{"potFit"}.
57 }
58 \item{run}{
59 if the data are to be declustered the run length parameter for
60 the runs method, see \code{\link{deCluster}}, should be entered
61 here.
62 }
63 \item{threshold}{
64 a threshold value, either \code{threshold} or \code{nextremes}
65 must be given, but not both).
66 }
67 \item{which}{
68 if \code{which} is set to \code{ask} the function will
69 interactively ask which plot should be displayed. By default
70 this value is set to \code{FALSE} and then those plots will
71 be displayed for which the elements in the logical vector
72 \code{which} ar set to \code{TRUE}; by default all four
73 elements are set to \code{"all"}.
74 }
75 \item{x}{
76 numeric vector of data, which may have a \code{times} attribute
77 containing (in an object of class \code{"POSIXct"}, or an object
78 that can be converted to that class; see \code{\link{as.POSIXct}})
79 the times/dates of each observation.
80 If no \code{times} attribute exists, the data are assumed to be
81 equally spaced. Note, the argument name is different for
82 \code{potFit} and \code{pot}.
83 \cr
84 [print][plot] - \cr
85 a fitted object of class \code{"potFit"}.
86 }
87 \item{\dots}{
88 control parameters and plot parameters optionally passed to the
89 optimization and/or plot function. Parameters for the optimization
90 function are passed to components of the \code{control} argument
91 of \code{optim}.
92 }
93
94 }
95
96
97 \value{
98
99 Both, \code{potFit} and \code{pot} return an object of class \code{"pot"}
100 describing the fit including parameter estimates and standard errors.
101
102 }
103
104
105 \details{
106
107 \bold{Parameter Estimation:}
108 \cr\cr
109 \code{potFit} uses \code{optim} for point process likelihood
110 maximization.
111 \cr
112
113 \bold{Methods:}
114 \cr\cr
115 The plot method \code{plot.pot} provides seven different plots for
116 assessing fitted POT model. The user selects the plot type from a
117 menu. Plot 1 displays the exceedance process of the chosen threshold.
118 Plots 2-4 assess the Poisson nature of the exceedance process
119 by looking at the scaled gaps between exceedances, which should
120 be iid unit exponentially distributed. Plots 5-6 assess the GPD
121 nature of the excesses by looking at suitably defined residuals,
122 which should again be iid unit exponentially distributed. Option
123 8 allows the user to call GPD plotting functions. If plot 1 or 2
124 from the GPD plots is selected as the final plot (i.e. option 8 is
125 selected, followed by option 1 or 2), a list object containing
126 details of the plot is returned invisibly. This object should be
127 used as the first argument of \code{gpdqPlot} or \code{gpdsfallPlot}
128 to add quantile estimates or expected shortfall estimates to the plot.
129 }
130
131
132 \examples{
133 ## SOURCE("fExtremes.53C-PotFit")
134
135 ## Use Danish Fire Insurance Loss Data:
136 data(danish)
137
138 ## Fit:
139 xmpExtremes("\nStart: POT Parameter Estimate >")
140 fit = potFit(danish, threshold = 10)
141 print(fit)
142
143 ## Summary with Diagnostic Plots:
144 xmpExtremes("\nNext: Diagnostic Analysis >")
145 par(mfrow = c(3, 3), cex = 0.5)
146 summary(fit)
147 }
148
149
150 \keyword{models}
+310
-0
man/054A-ExtremesGlm.Rd less more
0 \name{GevGlmFit}
1
2 \alias{GevGlmFit}
3
4 \alias{gevglmFit}
5
6 \alias{print.gevglmFit}
7 \alias{plot.gevglmFit}
8 \alias{summary.gevglmFit}
9
10 \alias{gevglmprofPlot}
11 \alias{gevglmprofxiPlot}
12
13
14 \title{Modelling the GEV Distribution including GLM}
15
16
17 \description{
18
19 A collection and description of functions to model the
20 Generalized Extreme Value, GEV, distribution by maximum
21 likelihood approximation based on R's 'ismev' package. In
22 addition to the function gevFit the parameter estimation
23 allows to include generalized linear modelling, GLM, of
24 each parameter.
25 \cr
26
27 The functions are:
28
29 \tabular{ll}{
30 \code{gevglmFit} \tab fits empirical or simulated data to the distribution, \cr
31 \code{print} \tab print method for a fitted GEV object of class ..., \cr
32 \code{plot} \tab plot method for a fitted GEV object, \cr
33 \code{summary} \tab summary method for a fitted GEV object, \cr
34 \code{gevglmprofPlot} \tab profile log-likelihoods for return levels, \cr
35 \code{gevglmprofxiPlot} \tab profile log-likelihoods for shape parameters. }
36
37 }
38
39
40 \usage{
41 gevglmFit(x, y = NULL, gumbel = FALSE, mul = NULL, sigl = NULL, shl = NULL,
42 mulink = identity, siglink = identity, shlink = identity, show = FALSE,
43 method = "Nelder-Mead", maxit = 10000, \dots)
44
45 \method{print}{gevglmFit}(x, \dots)
46 \method{plot}{gevglmFit}(x, which = "ask", \dots)
47 \method{summary}{gevglmFit}(object, doplot = TRUE, which = "all", \dots)
48
49 gevglmprofPlot(object, m, xlow, xup, conf = 0.95, nint = 100)
50 gevglmprofxiPlot(object, xlow, xup, conf = 0.95, nint = 100)
51 }
52
53
54 \arguments{
55
56 \item{conf}{
57 [gevglmprof*Plot] - \cr
58 the confidence coefficient of the plotted profile confidence
59 interval.
60 }
61 \item{doplot}{
62 a logical. Should the results be plotted?
63 }
64 \item{gumbel}{
65 [gevglmFit] - \cr
66 a logical, should a Gumbel fit be created? In this case the shape
67 parameter equals zero, and the arguments \code{shl} and and
68 \code{shlink} are omitted.
69 }
70 \item{m}{
71 [gevglmprofPlot] - \cr
72 the return level; i.e. the profile likelihood is for the value
73 that is exceeded with probability 1/\code{m}.
74 }
75 \item{maxit}{
76 [gevglmFit] - \cr
77 the maximum number of iterations.
78 }
79 \item{method}{
80 [gevglmFit] - \cr
81 the optimization method (see \code{\link{optim}} for details).
82 }
83 \item{mul, sigl, shl}{
84 [gevglmFit] - \cr
85 numeric vectors of integers, giving the columns
86 of \code{ydat} that contain covariates for generalized linear
87 modelling of the location, scale and shape parameters repectively
88 (or \code{NULL} (the default) if the corresponding parameter is
89 stationary).
90 }
91 \item{mulink, siglink, shlink}{
92 [gevglmFit] - \cr
93 inverse link functions for generalized linear modelling of the
94 location, scale and shape parameters repectively.
95 }
96 \item{nint}{
97 [gevglmprof*Plot] - \cr
98 the number of points at which the profile likelihood is evaluated.
99 }
100 \item{object}{
101 [summary][grlevelPlot] - \cr
102 a fitted object of class \code{"gevglmFit"}.
103 }
104 \item{show}{
105 [gevglmFit] - \cr
106 a logical; if \code{TRUE} (the default), print details of
107 the fit.
108 }
109 \item{x}{
110 [gevglmFit] - \cr
111 a numeric vector of data to be fitted.
112 \cr
113 [print][plot] - \cr
114 a fitted object of class \code{"gevglmFit"}.
115 }
116 \item{xlow, xup}{
117 [gevglmprof*Plot] - \cr
118 the least and greatest value at which to evaluate the profile
119 likelihood.
120 }
121 \item{y}{
122 [gevglmFit] - \cr
123 a matrix of covariates for generalized linear modelling
124 of the parameters (or \code{NULL} (the default) for stationary
125 fitting). The number of rows should be the same as the length
126 of \code{xdat}.
127 }
128 \item{which}{
129 [plot][summary] - \cr
130 a vector of logicals, one for each plot, denoting which plot
131 should be displayed.
132 }
133 \item{\dots}{
134 [gevglmFit] - \cr
135 control parameters optionally passed to the
136 optimization function. Parameters for the optimization
137 function are passed to components of the \code{control} argument of
138 \code{optim}.
139 \cr
140 [plot][summary] - \cr
141 arguments passed to the plot function.
142 }
143
144 }
145
146
147 \value{
148
149 \code{gevglmFit}
150 \cr
151 returns a list containing the following components.
152 A subset of these components are printed after the fit. If \code{show}
153 is \code{TRUE}, then assuming that successful convergence is
154 indicated, the components \code{nllh}, \code{mle} and \code{se}
155 are always printed.
156
157 \item{trans}{
158 an logical indicator for a non-stationary fit.
159 }
160 \item{model}{
161 a list with components \code{mul}, \code{sigl}
162 and \code{shl}.
163 }
164 \item{link}{
165 a character vector giving inverse link functions.
166 }
167 \item{conv}{
168 the convergence code, taken from the list returned by
169 \code{\link{optim}}. A zero indicates successful convergence.
170 }
171 \item{nllh}{
172 the negative logarithm of the likelihood evaluated at
173 the maximum likelihood estimates.
174 }
175 \item{data}{
176 the data that has been fitted. For non-stationary
177 models, the data is standardized.
178 }
179 \item{mle}{
180 a vector containing the maximum likelihood estimates.
181 }
182 \item{cov}{
183 the covariance matrix.
184 }
185 \item{se}{
186 a vector containing the standard errors.
187 }
188 \item{vals}{
189 a matrix with three columns containing the maximum
190 likelihood estimates of the location, scale and shape parameters
191 at each data point.
192 }
193
194 For stationary models four plots are produced; a probability
195 plot, a quantile plot, a return level plot and a histogram
196 of data with fitted density. For non-stationary models two plots
197 are produced; a residual probability plot and a residual quantile
198 plot.
199 \cr
200
201 \code{gevglmprofPlot}\cr
202 \code{gevglmprofxiPlot}\cr
203 a plot of the profile likelihood is produced, with a horizontal line
204 representing a profile confidence interval with confidence coefficient
205 \code{conf}.
206
207 }
208
209
210 \details{
211
212 \bold{Simulation:}
213 \cr\cr
214 To simulate a GEV series use the function \code{gevSim}.
215 \cr
216
217 \bold{Parameter Estimation:}
218 \cr\cr
219 \code{gevglmFit} fits by the Maximum-likelihood approach the generalized
220 extreme value distribution, including generalized linear modelling
221 of each parameter.
222 \cr
223
224 \bold{Methods:}
225 \cr\cr
226 \code{print.gevglm}, \code{plot.gevglm} and \code{summary.gevglm}
227 are print, plot, and summary methods for a fitted object of class
228 \code{gevglmFit}.
229 \cr
230
231 \bold{Profile Likelihood:}
232 \cr\cr
233 \code{gevglmprofPlot} and \code{gevglmprofxiPlot} produce profile
234 log-likelihoods for shape parameters and \code{m} year/block return
235 levels for stationary GEV models using the output of the function
236 \code{gevFit}.
237 \cr
238
239 \bold{Nonstationary Models:}
240 \cr\cr
241 For non-stationary fitting it is recommended that the covariates
242 within the generalized linear models are (at least approximately)
243 centered and scaled (i.e.\ the columns of \code{ydat} should be
244 approximately centered and scaled).
245
246 }
247
248
249 \author{
250
251 Alec Stephenson for the code implemented from \R's ismev package, \cr
252 Stuart Scott for the original code, and
253 Diethelm Wuertz for this \R-port.
254
255 }
256
257
258 \references{
259
260 Coles S. (2001);
261 \emph{Introduction to Statistical Modelling of Extreme Values},
262 Springer.
263
264 }
265
266
267 \examples{
268 ## SOURCE("fExtremes.54A-ExtremesGlm")
269
270 ## Simulated GEV Data:
271 xmpExtremes("\nStart: Simulte GEV Sample >")
272 x = gevSim(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
273 par(mfrow = c(2, 2))
274 plot(x, main = "Simulated GEV Data")
275 # Fit GEV Data:
276 fit = gevglmFit(x)
277 print(fit)
278 # Summarize Results:
279 summary(fit, which = c(TRUE, TRUE, TRUE, FALSE))
280
281 ## Simulated GEV Data:
282 xmpExtremes("\nNext: Estimate Parameters >")
283 ##> x = gevSim(model = list(shape = 0, location = 0, scale = 1), n = 1000)
284 ##> par(mfrow = c(2, 2))
285 ##> plot(x, main = "Simulated Gumbel Data")
286 # Fit GEV Data:
287 ##> fit = gevglmFit(x, gumbel = TRUE)
288 ##> print(fit)
289 # Summarize Results:
290 ##> summary(fit, which = c(TRUE, TRUE, TRUE, FALSE))
291
292 ## Portpirie Data:
293 xmpExtremes("\nNext: Fit Portpirie Data >")
294 par(mfrow = c(2, 1))
295 data(portpirie)
296 fit = gevglmFit(portpirie[, 2])
297 gevglmprofPlot(fit, m = 10, 4.1, 5)
298 title(main = "Portpirie")
299 gevglmprofxiPlot(fit, -0.3, 0.3)
300 title(main = "Portpirie")
301
302 ## Interactive Plot:
303 ##> par(mfrow = c(2, 2))
304 ##> plot(fit)
305 }
306
307
308 \keyword{models}
309
+298
-0
man/054B-GpdGlmFit.Rd less more
0 \name{GpdGlmFit}
1
2 \alias{GpdGlmFit}
3
4 \alias{gpdglmFit}
5
6 \alias{print.gpdglmFit}
7 \alias{plot.gpdglmFit}
8 \alias{summary.gpdglmFit}
9
10 \alias{gpdglmprofPlot}
11 \alias{gpdglmprofxiPlot}
12
13
14 \title{Modelling the GPD Distribution including GLM}
15
16
17 \description{
18
19 a collection of functions to model the Generalized
20 Pareto Distribution, GPD, by maximum likelihood
21 approximation based on \R's 'ismev' package. In
22 addition to the function 'gpdFit' the parameter
23 estimation allows to include generalized linear
24 modelling, glm, of each parameter.
25 \cr
26
27 The functions are:
28
29 \tabular{ll}{
30 \code{gpdglmFit} \tab fits empirical or simulated data to the distribution, \cr
31 \code{print} \tab print method for a fitted GPD object of class ..., \cr
32 \code{plot} \tab plot method for a fitted GPD object, \cr
33 \code{summary} \tab summary method for a fitted GPD object, \cr
34 \code{gpdglmprofPlot} \tab profile log-likelihoods for return levels, \cr
35 \code{gpdglmprofxiPlot} \tab profile log-likelihoods for shape parameters. }
36
37 }
38
39
40 \usage{
41 gpdglmFit(x, threshold = min(x), npy = 365, y = NULL, sigl = NULL,
42 shl = NULL, siglink = identity, shlink = identity, show = FALSE,
43 method = "Nelder-Mead", maxit = 10000, \dots)
44
45 \method{print}{gpdglmFit}(x, \dots)
46 \method{plot}{gpdglmFit}(x, which = "all", \dots)
47 \method{summary}{gpdglmFit}(object, doplot = TRUE, which = "all", \dots)
48
49 gpdglmprofPlot(fit, m, xlow, xup, conf = 0.95, nint = 100, \dots)
50 gpdglmprofxiPlot(fit, xlow, xup, conf = 0.95, nint = 100, \dots)
51 }
52
53
54 \arguments{
55
56 \item{conf}{
57 [gpdglmprof*Plot] - \cr
58 the confidence coefficient of the plotted profile confidence
59 interval.
60 }
61 \item{doplot}{
62 a logical. Should the results be plotted?
63 }
64 \item{fit}{
65 a fitted object either of class \code{"gpdglm"}.
66 }
67 \item{m}{
68 [gpdglmprof*Plot] - \cr
69 the return level; i.e. the profile likelihood is for the value
70 that is exceeded with probability 1/\code{m}.
71 }
72 \item{maxit}{
73 [gpdglmFit] - \cr
74 the maximum number of iterations.
75 }
76 \item{method}{
77 [gpdglmFit] - \cr
78 the optimization method; see \code{\link{optim}} for
79 details.
80 }
81 \item{nint}{
82 [gpdglmprof*Plot] - \cr
83 the number of points at which the profile likelihood is evaluated.
84 }
85 \item{npy}{
86 [gpdglmFit] - \cr
87 the number of observations per year/block. By default 365.
88 }
89 \item{object}{
90 [summary] -
91 a fitted object of class \code{"gpdglmFit"}.
92 }
93 \item{show}{
94 [gpdglmFit] - \cr
95 a logical; if \code{TRUE} (the default), print details of
96 the fit.
97 }
98 \item{sigl, shl}{
99 [gpdglmFit] - \cr
100 numeric vectors of integers, giving the columns
101 of \code{ydat} that contain covariates for generalized linear
102 modelling of the scale and shape parameters repectively
103 (or \code{NULL} (the default) if the corresponding parameter is
104 stationary).
105 }
106 \item{siglink, shlink}{
107 [gpdglmFit] - \cr
108 inverse link functions for generalized
109 linear modelling of the scale and shape parameters repectively.
110 }
111 \item{threshold}{
112 [gpdglmFit] - \cr
113 the threshold value; a single number or a numeric
114 vector of the same length as \code{xdat}.
115 }
116 \item{which}{
117 [plot][summary] - \cr
118 a vector of logicals, one for each plot, denoting which plot
119 should be displayed. By default \code{c(TRUE, TRUE, TRUE, TRUE,
120 TRUE)}.
121 }
122 \item{x}{
123 A numeric vector of data to be fitted.
124 \cr
125 [print][plot] - \cr
126 a fitted object of class \code{"gpdglmFit"}.
127 }
128 \item{xlow, xup}{
129 [gpdglmprof*Plot] - \cr
130 the least and greatest value at which to evaluate the profile
131 likelihood.
132 }
133 \item{y}{
134 [gpdglmFit] - \cr
135 a matrix of covariates for generalized linear modelling
136 of the parameters (or \code{NULL} (the default) for stationary
137 fitting). The number of rows should be the same as the length
138 of \code{xdat}.
139 }
140 \item{\dots}{
141 [gpdglmFit] - \cr
142 other control parameters for the optimization. These are passed
143 to components of the \code{control} argument of \code{optim}.
144 }
145
146 }
147
148
149 \value{
150
151 A list containing the following components. A subset of these
152 components are printed after the fit. If \code{show} is
153 \code{TRUE}, then assuming that successful convergence is
154 indicated, the components \code{nexc}, \code{nllh},
155 \code{mle}, \code{rate} and \code{se} are always printed.
156
157 \item{trans}{
158 An logical indicator for a non-stationary fit.
159 }
160 \item{model}{
161 A list with components \code{sigl} and \code{shl}.
162 }
163 \item{link}{
164 A character vector giving inverse link functions.
165 }
166 \item{threshold}{
167 The threshold, or vector of thresholds.
168 }
169 \item{nexc}{
170 The number of data points above the threshold.
171 }
172 \item{data}{
173 The data that lie above the threshold. For
174 non-stationary models, the data is standardized.
175 }
176 \item{conv}{
177 The convergence code, taken from the list returned by
178 \code{\link{optim}}. A zero indicates successful convergence.
179 }
180 \item{nllh}{
181 The negative logarithm of the likelihood evaluated at
182 the maximum likelihood estimates.
183 }
184 \item{vals}{
185 A matrix with three columns containing the maximum
186 likelihood estimates of the scale and shape parameters, and
187 the threshold, at each data point.
188 }
189 \item{mle}{
190 A vector containing the maximum likelihood estimates.
191 }
192 \item{rate}{
193 The proportion of data points that lie above the
194 threshold.
195 }
196 \item{cov}{
197 he covariance matrix.
198 }
199 \item{se}{
200 A vector containing the standard errors.
201 }
202 \item{n}{
203 The number of data points (i.e.\ the length of
204 \code{xdat}).
205 }
206 \item{npy}{
207 The number of observations per year/block.
208 }
209 \item{xdata}{
210 The data that has been fitted.
211 }
212
213 For stationary models four plots are produced; a probability
214 plot, a quantile plot, a return level plot and a histogram
215 of data with fitted density. For non-stationary models two plots
216 are produced; a residual probability plot and a residual quantile
217 plot.
218
219 }
220
221
222 \details{
223
224 \bold{Simulation:}
225 \cr\cr
226 To simulate a GPD series use the function \code{gpdSim}.
227 \cr
228
229 \bold{Parameter Estimation:}
230 \cr\cr
231 \code{gpdglmFit} fits by the Maximum-likelihood approach the generalized
232 extreme value distribution, including generalized linear modelling
233 of each parameter.
234 \cr
235
236 \bold{Methods:}
237 \cr\cr
238 \code{print.gpdglm}, \code{plot.gpdglm} and \code{summary.gpdglm}
239 are print, plot, and summary methods for a fitted object of class
240 \code{gpdglm}.
241 \cr
242
243 \bold{Nonstationary Models:}
244 \cr\cr
245 For non-stationary fitting it is recommended that the covariates
246 within the generalized linear models are (at least approximately)
247 centered and scaled (i.e.\ the columns of \code{ydat} should be
248 approximately centered and scaled).
249
250 }
251
252
253 \author{
254
255 Alec Stephenson for the code implemented from \R's ismev package, \cr
256 Stuart Scott for the original code, and
257 Diethelm Wuertz for this \R-port.
258
259 }
260
261
262 \references{
263
264 Coles S. (2001);
265 \emph{Introduction to Statistical Modelling of Extreme Values},
266 Springer.
267
268 }
269
270
271 \examples{
272 ## SOURCE("fExtremes.54B-GpdGlmFit")
273
274 ## Use Rain Data:
275 data(rain)
276
277 ## Fit GPD Model:
278 xmpExtremes("Start: Parameter Estimation >")
279 fit = gpdglmFit(x = rain, threshold = 10)
280 print(fit)
281 xmpExtremes("Next: Summary Report > ")
282
283 ## Summarize Results:
284 xmpExtremes("Next: Profile Likelihood >")
285 par(mfrow = c(2, 2), cex = 0.75)
286 summary(fit, which = "all")
287 # Profile Lielihood:
288 par(mfrow = c(2, 1), cex = 0.75)
289 gpdglmprofPlot(fit, m = 10, xlow = 55, xup = 75)
290 title(main = "Rain")
291 gpdglmprofxiPlot(fit, xlow = -0.02, 0.15)
292 title(main = "Rain")
293 }
294
295
296 \keyword{models}
297
+234
-0
man/054C-PPFit.Rd less more
0 \name{PPFit}
1
2 \alias{PPFit}
3
4 \alias{ppFit}
5
6 \alias{print.ppFit}
7 \alias{plot.ppFit}
8 \alias{summary.ppFit}
9
10 \title{Modelling Point Processes}
11
12
13 \description{
14
15 A collection and description of functions to model
16 point processes, PP, over a threshold, based on \R's
17 'ismev' package. The parameter estimation allows to
18 include generalized linear modelling, GLM, of each
19 parameter.
20 \cr
21
22 The functions are:
23
24 \tabular{ll}{
25 \code{potSim} \tab generates data from a point process, \cr
26 \code{potFit} \tab fits empirical or simulated data to a point process, \cr
27 \code{print} \tab print method for a fitted POT object of class ..., \cr
28 \code{plot} \tab plot method for a fitted GEV object, \cr
29 \code{summary} \tab summary method for a fitted GEV object, \cr
30 \code{gevrlevelPlot} \tab k-block return level with confidence intervals. }
31
32 }
33
34
35 \usage{
36 ppFit(x, threshold, npy = 365, y = NULL, mul = NULL, sigl = NULL,
37 shl = NULL, mulink = identity, siglink = identity, shlink =
38 identity, method = "Nelder-Mead", maxit = 10000, \dots)
39
40 \method{print}{ppFit}(x, \dots)
41 \method{plot}{ppFit}(x, which = "ask", \dots)
42 \method{summary}{ppFit}(object, doplot = TRUE, which = "all", \dots)
43 }
44
45
46 \arguments{
47
48 \item{doplot}{
49 a logical. Should the results be plotted?
50 }
51 \item{maxit}{
52 [ppFit] - \cr
53 the maximum number of iterations.
54 }
55 \item{method}{
56 [ppFit] - \cr
57 The optimization method (see \code{\link{optim}} for details).
58 }
59 \item{mul, sigl, shl}{
60 [ppFit] - \cr
61 numeric vectors of integers, giving the columns
62 of \code{ydat} that contain covariates for generalized linear
63 modelling of the location, scale and shape parameters repectively
64 (or \code{NULL} (the default) if the corresponding parameter is
65 stationary).
66 }
67 \item{mulink, siglink, shlink}{
68 [ppFit] - \cr
69 inverse link functions for generalized
70 linear modelling of the location, scale and shape parameters
71 repectively.
72 }
73 \item{npy}{
74 [ppFit] - \cr
75 the number of observations per year/block.
76 }
77 \item{object}{
78 [summary] - \cr
79 a fitted object of class \code{"ppFit"}.
80 }
81 \item{threshold}{
82 [ppFit] - \cr
83 the threshold; a single number or a numeric
84 vector of the same length as \code{x}.
85 }
86 \item{which}{
87 [print][plot][summary] - \cr
88 a logical for each plot, denoting which plots should be created.
89 }
90 \item{x}{
91 [ppFit] - \cr
92 a numeric vector of data to be fitted.
93 \cr
94 [print][plot] -
95 a fitted object of class \code{"ppFit"}.
96 }
97 \item{y}{
98 [ppFit] - \cr
99 a matrix of covariates for generalized linear modelling
100 of the parameters (or \code{NULL} (the default) for stationary
101 fitting). The number of rows should be the same as the length
102 of \code{x}.
103 }
104 \item{\dots}{
105 [ppFit] - \cr
106 control parameters and plot parameters optionally passed to the
107 optimization and/or plot function. Parameters for the optimization
108 function are passed to components of the \code{control} argument of
109 \code{optim}.
110 }
111
112 }
113
114
115 \value{
116
117 A list containing the following components. A subset of these
118 components are printed after the fit. If \code{show} is
119 \code{TRUE}, then assuming that successful convergence is
120 indicated, the components \code{nexc}, \code{nllh}, \code{mle}
121 and \code{se} are always printed.
122
123 \item{trans}{
124 An logical indicator for a non-stationary fit.
125 }
126 \item{model}{
127 A list with components \code{mul}, \code{sigl}
128 and \code{shl}.
129 }
130 \item{link}{
131 A character vector giving inverse link functions.
132 }
133 \item{threshold}{
134 The threshold, or vector of thresholds.
135 }
136 \item{npy}{
137 The number of observations per year/block.
138 }
139 \item{nexc}{
140 The number of data points above the threshold.
141 }
142 \item{data}{
143 The data that lie above the threshold. For
144 non-stationary models, the data is standardized.
145 }
146 \item{conv}{
147 The convergence code, taken from the list returned by
148 \code{\link{optim}}. A zero indicates successful convergence.
149 }
150 \item{nllh}{
151 The negative logarithm of the likelihood evaluated at
152 the maximum likelihood estimates.
153 }
154 \item{vals}{
155 A matrix with four columns containing the maximum
156 likelihood estimates of the location, scale and shape
157 parameters, and the threshold, at each data point.
158 }
159 \item{gpd}{
160 A matrix with three rows containing the maximum
161 likelihood estimates of corresponding GPD location, scale
162 and shape parameters at each data point.
163 }
164 \item{mle}{
165 A vector containing the maximum likelihood estimates.
166 }
167 \item{cov}{
168 The covariance matrix.
169 }
170 \item{se}{
171 A vector containing the standard errors.
172 }
173
174 For stationary models two plots are produced; a probability plot
175 and a quantile plot. For non-stationary models two plots are produced;
176 a residual probability plot and a residual quantile plot.
177
178 }
179
180
181 \details{
182
183 For non-stationary fitting it is recommended that the covariates
184 within the generalized linear models are (at least approximately)
185 centered and scaled (i.e.\ the columns of \code{ydat} should be
186 approximately centered and scaled).
187
188 }
189
190
191 \author{
192
193 Alec Stephenson for the code implemented from \R's ismev package, \cr
194 Stuart Scott for the original code, and
195 Diethelm Wuertz for this \R-port.
196
197 }
198
199
200 \references{
201
202 Coles S. (2001);
203 \emph{Introduction to Statistical Modelling of Extreme Values},
204 Springer.
205
206 }
207
208
209 \examples{
210 ## SOURCE("fExtremes.54C-PPFit")
211
212 ## Use Rain Data:
213 data(rain)
214
215 ## Fit Point Process Model:
216 xmpExtremes("Start: Parameter Fit for Point Process > ")
217 fit = ppFit(x = rain[1:200], threshold = 10)
218 print(fit)
219
220 ## Summarize Results:
221 xmpExtremes("Next: Diagnostic Analysis > ")
222 par(mfrow = c(2, 2), cex = 0.75)
223 summary(fit)
224 xmpExtremes("Next: Interactive Plot > ")
225
226 ## Interactive Plot:
227 ##> par(mfrow = c(2, 2), cex = 0.75)
228 ##> plot(fit)
229 }
230
231
232 \keyword{models}
233
+221
-0
man/054D-RlargFit.Rd less more
0 \name{RlargFit}
1
2 \alias{RlargFit}
3
4 \alias{rlargFit}
5
6 \alias{print.rlargFit}
7 \alias{plot.rlargFit}
8 \alias{summary.rlargFit}
9
10 \title{Modelling the Order Statistic Model}
11
12
13 \description{
14
15 A collection and description of functions to model
16 the Order Statistic Model by maximum likelihood
17 approximation based on \R's 'ismev' package. The
18 parameter estimation allows to include generalized
19 linear modelling of each parameter.
20 \cr
21
22 The functions are:
23
24 \tabular{ll}{
25 \code{gpdglmFit} \tab fits empirical or simulated data to the distribution, \cr
26 \code{print} \tab print method for a fitted GPD object of class ..., \cr
27 \code{plot} \tab plot method for a fitted GPD object, \cr
28 \code{summary} \tab summary method for a fitted GPD object, \cr
29 \code{gevglmprofPlot} \tab profile log-likelihoods for return levels, \cr
30 \code{gevglmprofxiPlot} \tab profile log-likelihoods for shape parameters. }
31
32 }
33
34
35 \usage{
36 rlargFit(x, r = dim(x)[2], y = NULL, mul = NULL, sigl = NULL,
37 shl = NULL, mulink = identity, siglink = identity, shlink = identity,
38 method = "Nelder-Mead", maxit = 10000, \dots)
39
40 \method{print}{rlargFit}(x, \dots)
41 \method{plot}{rlargFit}(x, which = "all", \dots)
42 \method{summary}{rlargFit}(object, doplot = TRUE, which = "all", \dots)
43 }
44
45
46 \arguments{
47
48 \item{doplot}{
49 a logical. Should the results be plotted?
50 }
51 \item{maxit}{
52 [rlargFit] - \cr
53 the maximum number of iterations.
54 }
55 \item{method}{
56 [rlargFit] - \cr
57 the optimization method (see \code{\link{optim}} for details).
58 }
59 \item{mul, sigl, shl}{
60 [rlargFit] - \cr
61 numeric vectors of integers, giving the columns
62 of \code{ydat} that contain covariates for generalized linear
63 modelling of the location, scale and shape parameters repectively
64 (or \code{NULL} (the default) if the corresponding parameter is
65 stationary).
66 }
67 \item{mulink, siglink, shlink}{
68 [rlargFit] - \cr
69 inverse link functions for generalized linear modelling of the
70 location, scale and shape parameters repectively.
71 }
72 \item{object}{
73 [summary] - \cr
74 a fitted object of class \code{"rlargFit"}.
75 }
76 \item{r}{
77 [rlargFit] - \cr
78 the largest \code{r} order statistics are used for the fitted model.
79 }
80 \item{x}{
81 [rlargFit] - \cr
82 a numeric matrix of data to be fitted. Each row should be a vector
83 of decreasing order, containing the largest order statistics for
84 each year (or time period). The first column therefore contains annual
85 (or period) maxima.
86 Only the first \code{r} columns are used for the fitted model. By
87 default, all columns are used.
88 If one year (or time period) contains fewer order statistics than
89 another, missing values can be appended to the end of the
90 corresponding row.
91 \cr
92 [print][plot] - \cr
93 a fitted object of class \code{"rlargFit"}.
94 }
95 \item{y}{
96 [rlargFit] - \cr
97 A matrix of covariates for generalized linear modelling of the
98 parameters (or \code{NULL} (the default) for stationary fitting).
99 The number of rows should be the same as the number of rows of
100 \code{x}.
101 }
102 \item{which}{
103 [print][plot][summary] - \cr
104 a logical for each plot, denoting which plots should be created.
105 }
106 \item{\dots}{
107 [rlargFit][plot] - \cr
108 control parameters and plot parameters optionally passed to the
109 optimization and/or plot function. Parameters for the optimization
110 function are passed to components of the \code{control} argument of
111 \code{optim}.
112 }
113
114 }
115
116
117 \details{
118
119 For non-stationary fitting it is recommended that the covariates
120 within the generalized linear models are (at least approximately)
121 centered and scaled (i.e.\ the columns of \code{ydat} should be
122 approximately centered and scaled).
123
124 }
125
126
127 \value{
128
129 A list containing the following components. A subset of these
130 components are printed after the fit. If \code{show} is
131 \code{TRUE}, then assuming that successful convergence is
132 indicated, the components \code{nllh}, \code{mle} and \code{se}
133 are always printed.
134
135 \item{trans}{
136 An logical indicator for a non-stationary fit.
137 }
138 \item{model}{
139 A list with components \code{mul}, \code{sigl} and \code{shl}.
140 }
141 \item{link}{
142 A character vector giving inverse link functions.
143 }
144 \item{conv}{
145 The convergence code, taken from the list returned by
146 \code{\link{optim}}. A zero indicates successful convergence.
147 }
148 \item{nllh}{
149 The negative logarithm of the likelihood evaluated at
150 the maximum likelihood estimates.
151 }
152 \item{data}{
153 The data that has been fitted. For non-stationary
154 models, the data is standardized.
155 }
156 \item{mle}{
157 A vector containing the maximum likelihood estimates.
158 }
159 \item{cov}{
160 The covariance matrix.
161 }
162 \item{se}{
163 A vector containing the standard errors.}
164 \item{vals}{
165 A matrix with three columns containing the maximum
166 likelihood estimates of the location, scale and shape parameters
167 at each data point.
168 }
169 \item{r}{
170 The number of order statistics used.
171 }
172
173 For stationary models four plots are initially produced;
174 a probability plot, a quantile plot, a return level plot
175 and a histogram of data with fitted density.
176 Then probability and quantile plots are produced for the
177 largest \code{n} order statistics. For non-stationary models
178 residual probability plots and residual quantile plots are
179 produced for the largest \code{n} order statistics.
180
181 }
182
183
184 \author{
185
186 Alec Stephenson for the code implemented from \R's ismev package, \cr
187 Stuart Scott for the original code, and
188 Diethelm Wuertz for this \R-port.
189
190 }
191
192
193 \references{
194
195 Coles S. (2001);
196 \emph{Introduction to Statistical Modelling of Extreme Values},
197 Springer.
198
199 }
200
201
202 \examples{
203 ## SOURCE("fExtremes.54D-RlargFit")
204
205 ## Use Venice Data:
206 data(venice)
207
208 ## Fit for the order statistic model:
209 xmpExtremes("Start: Parameter Fit for Order Statistics Model > ")
210 fit = rlargFit(venice[, 2:4], r = 3)
211 fit
212
213 ## Summarize Results:
214 xmpExtremes("Next: Diagnostic Analysis > ")
215 summary(fit)
216 }
217
218
219 \keyword{models}
220
+159
-0
man/055A-ExtremeIndex.Rd less more
0 \name{ExtremeIndexPlots}
1
2 \alias{ExtremeIndexPlots}
3
4 \alias{exindexPlot}
5 \alias{exindexesPlot}
6
7 \title{Extremal Index Estimation}
8
9
10 \description{
11
12 A collection and description of functions to compute
13 the extremal index by three different kind of methods,
14 the blocks method, the reciprocal mean cluster size
15 method, and the runs method.
16 \cr
17
18 The functiona are:
19
20 \tabular{ll}{
21 \code{exindexPlot} \tab Calculate and Plot Theta(1,2,3), \cr
22 \code{exindexesPlot} \tab Calculate Theta(1,2) and Plot Theta(1). }
23
24 }
25
26
27 \usage{
28 exindexPlot(x, block = "month", start = 5, end = NA, plottype = c("thresh",
29 "K"), labels = TRUE, autoscale = TRUE, \dots)
30
31 exindexesPlot(x, block = 20, quantiles = seq(0.990, 0.999, 0.001),
32 doplot = TRUE, \dots)
33 }
34
35
36 \arguments{
37
38 \item{autoscale}{
39 [exindexPlot] - \cr
40 whether or not plot should be automatically scaled; if not,
41 \code{xlim} and \code{ylim} graphical parameters may be entered.
42 }
43 \item{block}{
44 the block size. A numeric value is interpreted as the number of
45 data values in each successive block.
46 All the data is used, so the last block may not contain \code{block}
47 observations.
48 If the \code{x} has a \code{times} attribute containing (in an
49 object of class \code{"POSIXct"}, or an object that can be
50 converted to that class; see \code{\link{as.POSIXct}}) the
51 times/dates of each observation, then \code{block} may instead
52 take the character values \code{"month"}, \code{"quarter"},
53 \code{"semester"} or \code{"year"}.
54 Note, \code{exindexPlot} supports both numeric and character input,
55 \code{exindexPlot} supports only numeric input.
56 By default, monthly blocks or 20-day blocks are used which are
57 thought for daily data records.
58 }
59 \item{doplot}{
60 [exindexesPlot] - \cr
61 a logical, should the results be plotted?
62 }
63 \item{labels}{
64 [exindexPlot] - \cr
65 whether or not axes should be labelled.
66 }
67 \item{plottype}{
68 [exindexPlot] - \cr
69 whether plot is to be by increasing threshold (\code{thresh})
70 or increasing K value (\code{K}).
71 }
72 \item{quantiles}{
73 [exindexesPlot] - \cr
74 a numeric vector of quantile values.
75 }
76 \item{start, end}{
77 [exindexPlot] - \cr
78 \code{start} is the lowest value of \code{K} at which to plot
79 a point, and \code{end} the highest value; \code{K} is the
80 number of blocks in which a specified threshold is exceeded.
81 }
82 \item{x}{
83 a numeric vector, note raw values are required, not block maxima.
84 }
85 \item{\dots}{
86 additional arguments passed to the plot function.
87 }
88
89 }
90
91
92 \value{
93
94 \code{exindexPlot}
95 \cr
96 returns a data frame of results with the
97 following columns: \code{N}, \code{K}, \code{un}, \code{theta2},
98 and \code{theta}. A plot with \code{K} on the lower x-axis and
99 threshold Values on the upper x-axis versus the extremal index
100 is displayed.
101
102 \code{exindexesPlot}
103 \cr
104 returns a data.frame with four columns:
105 \code{thresholds}, \code{theta1}, \code{theta2}, and \code{theta3}.
106 A plot with quantiles on the x-axis and versus the extremal indexes
107 is displayed.
108
109 }
110
111
112 \author{
113
114 Alexander McNeil, for the \code{exindexPlot} function, and \cr
115 Diethelm Wuertz for the \code{exindexesPlot} function.
116
117 }
118
119
120 \references{
121
122 Embrechts, P., Klueppelberg, C., Mikosch, T. (1997);
123 \emph{Modelling Extremal Events},
124 Springer. Chapter 8, 413--429.
125
126 }
127
128
129 \seealso{
130
131 \code{\link{hillPlot}},
132 \code{\link{gevFit}}.
133
134 }
135
136
137 \examples{
138 ## SOURCE("fExtremes.55A-ExtremeIndex")
139
140 ## Extremal Index for the right and left tails
141 ## of the BMW log returns:
142 xmpExtremes("\nStart: Plot the Extremal Index >")
143 data(bmw)
144 par(mfrow = c(2, 2), cex = 0.7)
145 exindexPlot( bmw, block = "quarter")
146 exindexPlot(-bmw, block = "quarter")
147
148 ## Extremal Index for the right and left tails
149 ## of the BMW log returns:
150 xmpExtremes("\nNext: Investigate Tail Depth Dependence >")
151 data(bmw)
152 exindexesPlot( bmw, block = 65)
153 exindexesPlot(-bmw, block = 65)
154 }
155
156
157 \keyword{hplot}
158
+125
-0
man/056A-ExtremesBuiltin.Rd less more
0 \name{evirBuiltin}
1
2 \alias{evir}
3
4 \alias{decluster}
5 \alias{emplot}
6 \alias{exindex}
7 \alias{findthresh}
8 \alias{gev}
9 \alias{gev.dens}
10 \alias{gev.diag}
11 \alias{gev.fit}
12 \alias{gev.his}
13 \alias{gev.pp}
14 \alias{gev.prof}
15 \alias{gev.profxi}
16 \alias{gev.qq}
17 \alias{gev.rl}
18 \alias{gevf}
19 \alias{gevq}
20 \alias{gpd}
21 \alias{gpd.dens}
22 \alias{gpd.diag}
23 \alias{gpd.fit}
24 \alias{gpd.fitrange}
25 \alias{gpd.his}
26 \alias{pot}
27 \alias{gpd.pp}
28 \alias{gpd.prof}
29 \alias{gpd.profxi}
30 \alias{gpd.q}
31 \alias{gpd.qq}
32 \alias{gpd.rl}
33 \alias{gpd.sfall}
34 \alias{gpdbiv}
35 \alias{gpdf}
36 \alias{gpdq}
37 \alias{gpdq2}
38 \alias{gum.dens}
39 \alias{gum.df}
40 \alias{gum.diag}
41 \alias{gum.fit}
42 \alias{gum.q}
43 \alias{gum.rl}
44 \alias{gumbel}
45 \alias{hill}
46 \alias{identity}
47 \alias{interpret.gpdbiv}
48 \alias{meplot}
49 \alias{mrl.plot}
50 \alias{plot.gev}
51 \alias{plot.gpd}
52 \alias{plot.gpdbiv}
53 \alias{plot.pot}
54 \alias{pp.diag}
55 \alias{pp.fit}
56 \alias{pp.fitrange}
57 \alias{pp.pp}
58 \alias{pp.qq}
59 \alias{ppf}
60 \alias{ppp}
61 \alias{ppq}
62 \alias{q.form}
63 \alias{qplot}
64 \alias{quant}
65 \alias{records}
66 \alias{riskmeasures}
67 \alias{rlarg.diag}
68 \alias{rlarg.fit}
69 \alias{rlarg.pp}
70 \alias{rlarg.qq}
71 \alias{rlargf}
72 \alias{rlargq}
73 \alias{rlargq2}
74 \alias{rlevel.gev}
75 \alias{shape}
76 \alias{tailplot}
77
78
79 \alias{bmw}
80 \alias{danish}
81 \alias{dowjones}
82 \alias{engine}
83 \alias{euroex}
84 \alias{exchange}
85 \alias{fremantle}
86 \alias{glass}
87 \alias{nidd.annual}
88 \alias{nidd.thresh}
89 \alias{portpirie}
90 \alias{rain}
91 \alias{siemens}
92 \alias{sp.raw}
93 \alias{spto87}
94 \alias{venice}
95 \alias{wavesurge}
96 \alias{wind}
97 \alias{wooster}
98
99
100 \alias{bmw.ret}
101 \alias{dax.ret}
102
103
104 \title{evir Builtin Functions}
105
106
107 \description{
108
109 Builtin functions as available in the contributed
110 \R-packages 'evir' and 'ismev'. They are used only
111 as internal functions, and they are not thought
112 for usage by Rmetrics users.
113
114 }
115
116
117 \examples{
118 ## SOURCE("fExtremes.55A-ExtremesBuiltin")
119
120 ## -
121 }
122
123
124 \keyword{data}
+76
-0
man/057A-ExtremesTools.Rd less more
0 \name{ExtremesTools}
1
2
3 \alias{ExtremesTools}
4
5 \alias{xmpExtremes}
6 \alias{xmpfExtremes}
7
8
9 \title{fExtremes Tools}
10
11
12 \description{
13
14 Popups the example menu and starts or continues the example
15 and demo programs.
16
17 }
18
19
20 \usage{
21 xmpfExtremes()
22 xmpExtremes(prompt = "")
23 }
24
25
26 \arguments{
27
28 \item{prompt}{
29 the string printed when prompting the user for input.
30 }
31 }
32
33
34 \value{
35
36 xmpfExtremes
37 \cr
38 Popups the example menu.
39 \cr
40
41 xmpExtremes
42 \cr
43 Nothing, the default, or the the prompt if you have set
44 \code{xmpExtremes = readline} on the command prompt.
45
46 }
47
48
49 \details{
50
51 The example in the manual pages may be interactive and ask for
52 input from the user. To achieve this you have to type on the
53 command line: \code{xmpExtremes = readline}
54
55 }
56
57
58 \examples{
59 \dontrun{
60 ## xmpfExtremes -
61 # Popup the examples menu:
62 xmpfExtremes()
63 }
64 }
65
66
67 \author{
68
69 Diethelm Wuertz for this R-Port.
70
71 }
72
73
74 \keyword{programming}
75
+0
-548
man/51A-ExtremesData.Rd less more
0 \name{ExtremesData}
1
2 \alias{ExtremesData}
3
4 \alias{emdPlot}
5 \alias{qqPlot}
6 \alias{qqbayesPlot}
7 \alias{qPlot}
8 \alias{mePlot}
9 \alias{mrlPlot}
10 \alias{mxfPlot}
11 \alias{msratioPlot}
12 \alias{recordsPlot}
13 \alias{ssrecordsPlot}
14 \alias{xacfPlot}
15
16 \alias{interactivePlot}
17
18 \alias{gridVector}
19
20
21 \alias{findThreshold}
22 \alias{blocks}
23 \alias{blockMaxima}
24 \alias{deCluster}
25
26
27 \title{Explorative Data Analysis}
28
29
30 \description{
31
32 A collection and description of functions for explorative
33 data analysis including data preprocessing of extreme values.
34 The tools include plot functions for emprical distributions,
35 quantile plots, graphs exploring the properties of exceedences
36 over a threshold, plots for mean/sum ratio and for the development
37 of records. The data preprocessing includes tools to
38 separate data beyond a threshold value, to compute blockwise
39 data like block maxima, and to decluster point process data.
40 \cr
41
42 The plot functions are:
43
44 \tabular{ll}{
45 \code{emdPlot} \tab Plot of empirical distribution function, \cr
46 \code{qqPlot} \tab Normal quantile-quantile plot, \cr
47 \code{qqbayesPlot} \tab Normal QQ-Plot with 95 percent intervals, \cr
48 \code{qPlot} \tab Exponential/Pareto quantile plot, \cr
49 \code{mePlot} \tab Plot of mean excesses over a threshold, \cr
50 \code{mrlPlot} \tab another variant, mean residual life plot, \cr
51 \code{mxfPlot} \tab another variant, with confidence intervals, \cr
52 \code{msratioPlot} \tab Plot of the ratio of maximum and sum, \cr
53 \code{recordsPlot} \tab Record development compared with iid data, \cr
54 \code{ssrecordsPlot} \tab another variant, investigates subsamples, \cr
55 \code{xacfPlot} \tab ACF of exceedences over a threshold, \cr
56 \code{interactivePlot} \tab a framework for interactive plot displays, \cr
57 \code{gridVector} \tab creates from two vectors x and y all grid points. }
58
59 The functions for data preprocessing are:
60
61 \tabular{ll}{
62 \code{findThreshold} \tab Upper threshold for a given number of extremes, \cr
63 \code{blocks} \tab Create data blocks on vectors and time series, \cr
64 \code{blockMaxima} \tab Block Maxima from a vector or a time series, \cr
65 \code{deCluster} \tab Declusters clustered point process data. }
66
67
68 }
69
70
71 \usage{
72 emdPlot(x, doplot = TRUE, plottype = c("", "x", "y", "xy"), labels = TRUE, \dots)
73
74 qqPlot(x, doplot = TRUE, labels = TRUE, \dots)
75 qqbayesPlot(x, doplot = TRUE, labels = TRUE, \dots)
76 qPlot(x, xi = 0, trim = NA, threshold = NA, doplot = TRUE, labels = TRUE, \dots)
77
78 mePlot(x, doplot = TRUE, labels = TRUE, \dots)
79 mrlPlot(x, conf = 0.95, umin = NA, umax = NA, nint = 100, doplot = TRUE,
80 plottype = c("autoscale", ""), labels = TRUE, \dots)
81 mxfPlot(x, tail = 0.05, doplot = TRUE, labels = TRUE, \dots)
82
83 msratioPlot(x, p = 1:4, doplot = TRUE, plottype = c("autoscale", ""),
84 labels = TRUE, \dots)
85
86 recordsPlot(x, conf = 0.95, doplot = TRUE, labels = TRUE, \dots)
87 ssrecordsPlot(x, subsamples = 10, doplot = TRUE, plottype = c("lin", "log"),
88 labels = TRUE, \dots)
89
90 xacfPlot(x, threshold = 0.95, lag.max = 15, doplot = TRUE, \dots)
91
92 interactivePlot(x, choices = paste("Plot", 1:9),
93 plotFUN = paste("plot.", 1:9, sep = ""), which = "all", \dots)
94 gridVector(x, y)
95
96 findThreshold(x, n = NA)
97 blocks(x, block = "month", FUN = max)
98 blockMaxima(x, block = "month", details = FALSE, doplot = TRUE, \dots)
99 deCluster(x, run = NA, doplot = TRUE)
100 }
101
102
103 \arguments{
104
105 \item{block}{
106 [blockMaxima] - \cr
107 the block size. A numeric value is interpreted as the number
108 of data values in each successive block. All the data is used,
109 so the last block may not contain \code{block} observations.
110 If the \code{data} has a \code{times} attribute containing (in
111 an object of class \code{"POSIXct"}, or an object that can be
112 converted to that class, see \code{\link{as.POSIXct}}) the
113 times/dates of each observation, then \code{block} may instead
114 take the character values \code{"month"}, \code{"quarter"},
115 \code{"semester"} or \code{"year"}. By default monthly blocks
116 from daily data are assumed.
117 }
118 \item{choices}{
119 [interactivePlot] - \cr
120 a vector of character strings for the
121 choice menu. By Default \code{"Plot 1"} ... \code{"Plot 9"}
122 allowing for 9 plots at maximum.
123 }
124 \item{conf}{
125 [recordsPlot] - \cr
126 a confidence level. By default 0.95, i.e. 95\%.
127 }
128 \item{details}{
129 [blockMaxima] - \cr
130 a logical. Should details be printed?
131 }
132 \item{doplot}{
133 a logical. Should the results be plotted? By default \code{TRUE}.
134 }
135 \item{FUN}{the function to be applied. Additional arguments are
136 passed by the \code{\dots} argument.
137 }
138 \item{labels}{
139 a logical. Whether or not x- and y-axes should be automatically
140 labelled and a default main title should be added to the plot.
141 By default \code{TRUE}.
142 }
143 \item{lag.max}{
144 [xacfPlot] - \cr
145 maximum number of lags at which to calculate the autocorrelation
146 functions. The default value is 15.
147 }
148 \item{nint}{
149 [mrlPlot] - \cr
150 the number of intervals, see \code{umin} and \code{umax}. The
151 default value is 100.
152 }
153 \item{n}{
154 [findThreshold] - \cr
155 a numeric value or vector giving number of extremes above
156 the threshold. If \code{n} is not specified, \code{n} is
157 set to an integer representing 5\% of the data from the
158 whole data set \code{x}.
159 }
160 \item{p}{
161 [msratioPlot] - \cr
162 the power exponents, a numeric vector. By default a sequence from
163 1 to 4 in unit integer steps.
164 }
165 \item{plotFUN}{
166 [interactivePlot] - \cr
167 a vector of character strings naming the
168 plot functions. By Default \code{"plot.1"} ... \code{"plot.9"}
169 allowing for 9 plots at maximum.
170 }
171 \item{plottype}{
172 [emdPlot] - \cr
173 which axes should be on a log scale: \code{"x"} x-axis only;
174 \code{"y"} y-axis only; \code{"xy"} both axes; \code{""}
175 neither axis.
176 \cr
177 [msratioPlot] - \cr
178 a logical, if set to \code{"autoscale"}, then the scale of the
179 plots are automatically determined, any other string allows user
180 specified scale information through the \code{\dots} argument.
181 \cr
182 [ssrecordsPlot] - \cr
183 one from two options can be select either \code{"lin"}
184 or \code{"log"}. The default creates a linear plot.
185 }
186 \item{run}{
187 [deCluster] - \cr
188 parameter to be used in the runs method; any two consecutive
189 threshold exceedances separated by more than this number of
190 observations/days are considered to belong to different clusters.
191 }
192 \item{subsamples}{
193 [ssrecordsPlot] - \cr
194 the number of subsamples, by default 10, an integer value.
195 }
196 \item{tail}{
197 [mxfPlot] - \cr
198 the threshold determined from the relative number of data points
199 defining the tail, a numeric value; by default 0.05 which says
200 that 5\% of the data make the tail.
201 }
202 \item{threshold, trim}{
203 [qPlot][xacfPlot] - \cr
204 a numeric value at which data are to be left-truncated, value
205 at which data are to be right-truncated or the thresold value,
206 by default 95\%.
207 }
208 \item{umin, umax}{
209 [mrlPlot] - \cr
210 range of threshold values. If \code{umin} and/or \code{umax} are
211 not available, then by default they are set to the following
212 values: \code{umin=mean(x)} and \code{umax=max(x)}.
213 }
214 \item{which}{
215 plot selection, which graph should be displayed? If \code{"which"}
216 is a character string named "ask" the user is interactively asked
217 which to plot, if a logical vector of length \code{N}, those plots
218 which are set \code{TRUE} are displayed, if a character string
219 named \code{"all"} all plots are displayed.
220 }
221 \item{x, y}{
222 numeric data vectors or in the case of x an object to be plotted.
223 \cr
224 [finThreshold][blocks][blockMaxima][deCluster] - \cr
225 a numeric data vector from which \code{findThreshold} and
226 \code{blockMaxima} determine the threshold values and block
227 maxima values.
228 For the function \code{deCluster} the argument
229 \code{x} represents a numeric vector of threshold exceedances
230 with a \code{times} attribute which should be a numeric
231 vector containing either the indices or the times/dates
232 of each exceedance (if times/dates, the attribute should
233 be an object of class \code{"POSIXct"} or an object that
234 can be converted to that class; see \code{\link{as.POSIXct}}).
235 [gridVector] - \cr
236 two numeric vector which span the two dimensional grid.
237 }
238 \item{xi}{
239 the shape parameter of the generalized Pareto distribution.
240 }
241 \item{\dots}{
242 additional arguments passed to the FUN or plot function.
243 }
244
245 }
246
247
248 \details{
249
250 \bold{Empirical Distribution Function:}
251 \cr\cr
252 The function \code{emdPlot} is a simple explanatory function. A
253 straight line on the double log scale indicates Pareto tail behaviour.
254 \cr
255
256
257 \bold{Quantile--Quantile Plot:}
258 \cr\cr
259 The function \code{qqPlot} produces a normal QQ-plot. Note, that
260 \code{qqPlot} is not a synonym function call to the \R-base function
261 \code{qqplot} which produces a quantile-quantile plot of two datasets.
262 To help with assessing the relevance of sampling variability on just
263 "how close" to the normal the data appears, \code{qqbayesPlot} adds
264 approximate posterior 95% intervals for the uncertain quantile
265 function at each point.
266 \code{qPlot} creates a QQ-plot for threshold data. If \code{xi} is
267 zero the reference distribution is the exponential; if \code{xi} is
268 non-zero the reference distribution is the generalized Pareto with
269 that value of \code{xi}. In the case of the exponential, the plot is
270 interpreted as follows: Concave departures from a straight line are a
271 sign of heavy-tailed behaviour, convex departures show thin-tailed
272 behaviour.
273 \cr
274
275
276 \bold{Mean Excess Function Plot:}
277 \cr\cr
278 Three variants to plot the mean excess function are available:
279 A sample mean excess plot over increasing thresholds, and two mean
280 excess function plots with confidence intervals for discrimination
281 in the tails of a distribution.
282 In general, an upward trend in a mean excess function plot shows
283 heavy-tailed behaviour. In particular, a straight line with positive
284 gradient above some threshold is a sign of Pareto behaviour in tail.
285 A downward trend shows thin-tailed behaviour whereas a line with
286 zero gradient shows an exponential tail. Here are some hints:
287 Because upper plotting points are the average of a handful of extreme
288 excesses, these may be omitted for a prettier plot.
289 For \code{mrlPlot} and \code{mxfPlot} the upper tail is investigated;
290 for the lower tail reverse the sign of the \code{data} vector.
291 \cr
292
293
294 \bold{Plot of the Maximum/Sum Ratio:}
295 \cr\cr
296 The ratio of maximum and sum is a simple tool for detecting heavy
297 tails of a distribution and for giving a rough estimate of
298 the order of its finite moments. Sharp increases in the curves
299 of a \code{msratioPlot} are a sign for heavy tail behaviour.
300 \cr
301
302
303 \bold{Plot of the Development of Records:}
304 \cr\cr
305 These are functions that investigate the development of records in
306 a dataset and calculate the expected behaviour for iid data.
307 \code{recordPlot} counts records and reports the observations
308 at which they occur. In addition subsamples can be investigated
309 with the help of the function \code{ssrecords}.
310 \cr
311
312
313 \bold{ACF Plot of Exceedences over a Thresold:}
314 \cr\cr
315 This function plots the autocorrelation functions of heights and
316 distances of exceedences over a threshold.
317 \cr
318
319
320 \bold{Finding Thresholds:}
321 \cr\cr
322 The function \code{findThreshold} finds a threshold so that a given
323 number of extremes lie above. When the data are tied a threshold is
324 found so that at least the specified number of extremes lie above.
325 \cr
326
327
328 \bold{Computing Block Maxima:}
329 \cr\cr
330 The function \code{blockMaxima} calculates block maxima from a vector
331 or a time series, whereas the function
332 \code{blocks} is more general and allows for the calculation of
333 an arbitrary function \code{FUN} on blocks.
334 \cr
335
336
337 \bold{De-Clustering Point Processes:}
338 \cr\cr
339 The function \code{deCluster} declusters clustered point process
340 data so that Poisson assumption is more tenable over a high threshold.
341
342 }
343
344
345 \value{
346
347 \code{findThreshold}
348 \cr
349 returns a numeric vector of suitable thresholds.
350
351 \code{blockMaxima}
352 \cr
353 returns a numeric vector of block maxima data.
354
355 \code{deCluster}
356 \cr
357 returns an object for the declustered point process.
358
359 }
360
361
362 \note{
363
364 The plots are labeled by default with a x-label, a y-label and
365 a main title. If the argument \code{label} is set to \code{FALSE}
366 neither a x-label, a y-label nor a main title will be added to
367 graph. To add user defined label strings "\dots" just use the
368 function \code{title(xlab="\dots", ylab="\dots", main="\dots")}.
369
370 }
371
372
373 \author{
374
375 Some of the functions were implemented from Alec Stephenson's
376 R-package \code{evir} ported from Alexander McNeil's S library
377 \code{EVIS}, \emph{Extreme Values in S}, some from Alec Stephenson's
378 R-package \code{ismev} based on Stuart Coles code from his book,
379 \emph{Introduction to Statistical Modeling of Extreme Values} and
380 some were written by Diethelm Wuertz.
381
382 }
383
384
385 \references{
386
387 Coles S. (2001);
388 \emph{Introduction to Statistical Modelling of Extreme Values},
389 Springer.
390
391 Embrechts, P., Klueppelberg, C., Mikosch, T. (1997);
392 \emph{Modelling Extremal Events}, Springer.
393
394 }
395
396
397 \examples{
398 ## SOURCE("fExtremes.51A-ExtremesData")
399
400 ## emdPlot -
401 xmpExtremes("\nStart: Empirical Distribution Function >")
402 # Danish fire insurance data show Pareto tail behaviour:
403 par(mfrow = c(2, 2))
404 data(danish)
405 emdPlot(danish, plottype = "xy", labels = FALSE)
406 title(xlab = "x", ylab = "1-F(x)", main = "Danish Fire")
407 # BMW Stocks:
408 data(bmw)
409 emdPlot(bmw, plottype = "xy", labels = FALSE)
410 title(xlab = "x", ylab = "1-F(x)", main = "BMW Stocks")
411 # Simulated Student-t:
412 emdPlot(rt(5000, 4), plottype = "xy")
413
414 ## qqPlot -
415 xmpExtremes("\nNext: Quantile-Quantile Plot >")
416 # QQ-Plot of Simulated Normal rvs:
417 par(mfrow = c(2, 2))
418 set.seed(4711)
419 qqPlot(rnorm(5000))
420 text(-3.5, 3, pos = 4, "Simulated Normal rvs")
421 # QQ-Plot of simulated Student-t rvs:
422 qqPlot(rt(5000, 4))
423 text(-3.5, 11.0, pos = 4, "Simulated Student-t rvs")
424 # QQ-Plot of BMW share residuals:
425 data(bmw)
426 qqPlot(bmw)
427 text(-3.5, 0.09, pos = 4, "BMW log returns")
428
429 ## qPlot -
430 xmpExtremes("\nNext: QQ-Plot of Heavy Tails >")
431 # QQ-Plot of heavy-tailed Danish fire insurance data:
432 data(danish)
433 qPlot(danish)
434
435 ## mePlot -
436 xmpExtremes("\nNext: Mean Excess Plot >")
437 # Sample mean excess plot of heavy-tailed Danish fire
438 # insurance data
439 par(mfrow = c(3, 2))
440 data(danish)
441 mePlot(danish, labels = FALSE)
442 title(xlab = "u", ylab = "e", main = "mePlot - Danish Fire Data")
443
444 ## mrlPlot -
445 xmpExtremes("\nNext: mean Residual Live Plot >")
446 # Sample mean residual live plot of heavy-tailed Danish Fire
447 # insurance data
448 mrlPlot(danish, labels = FALSE)
449 title(xlab = "u", ylab = "e", main = "mrlPlot - Danish Fire Data")
450
451 ## mxfPlot -
452 xmpExtremes("\nNext: Mean Excess Function Plot >")
453 # Plot the mean excess functions for randomly distributed
454 # residuals
455 par(mfrow = c(2, 2))
456 n = 10000
457 set.seed(4711)
458 xlab = "Threshold: u"; ylab = "Mean Excess: e"
459 mxfPlot(rnorm(n), tail = 0.5, labels = FALSE)
460 title(xlab = xlab, ylab = ylab, main = "mxf Plot - Normal DF")
461 set.seed(7138)
462 mxfPlot(rexp(n, 2), tail = 0.5, labels = FALSE)
463 title(xlab = xlab, ylab = ylab, main = "mxfPlot - Exponential DF")
464 abline(1/2, 0)
465 set.seed(6952)
466 mxfPlot(rlnorm(n, 0, 2), tail = 0.5, xlim = c(0,90),
467 ylim = c(0, 120), labels = FALSE)
468 title(xlab = xlab, ylab = ylab, main = "mxfPlot - Lognormal DF")
469 set.seed(8835)
470 mxfPlot(rgpd(n, 1/2), tail = 0.10, xlim = c(0,200),
471 ylim=c(0,200), labels = FALSE)
472 title(xlab = xlab, ylab = ylab, main = "mxfPlot - Pareto")
473 abline(0, 1)
474
475 ## msratioPlot -
476 xmpExtremes("\nNext: Maximum/Sum Ratio Plot >")
477 # Examples for Ratio of Maximum and Sum Plots:
478 par(mfrow = c(3, 2))
479 data(bmw)
480 xlab = "n"; ylab = "R(n)"
481 msratioPlot (rnorm(8000), labels = FALSE)
482 title(xlab = xlab, ylab = ylab, main = "Standard Normal")
483 msratioPlot (rexp(8000), labels = FALSE)
484 title(xlab = xlab, ylab = ylab, main = "Exponential")
485 msratioPlot (rt(8000, 4), labels = FALSE)
486 title(xlab = xlab, ylab = ylab, main = "Student-t")
487 msratioPlot (rcauchy(8000), labels = FALSE)
488 title(xlab = xlab, ylab = ylab, main = "Cauchy")
489 msratioPlot (bmw, labels = FALSE)
490 title(xlab = xlab, ylab = ylab, main = "BMW Returns")
491
492 ## recordsPlot -
493 xmpExtremes("\nNext: Records Plot >")
494 # Record fire insurance losses in Denmark
495 par(mfrow = c(2, 2))
496 data(danish)
497 recordsPlot(danish)
498 text(1, 7.9, pos = 4, "Danish Fire")
499 # BMW Stocks
500 data(bmw)
501 recordsPlot(bmw)
502 text(1, 12.8, pos = 4, "BMW Shares")
503
504 ## ssrecordsPlot -
505 xmpExtremes("\nNext: Subsample Record Plot >")
506 # Record fire insurance losses in Denmark
507 ssrecordsPlot(danish)
508 text(1, 9.2, pos = 4, "Danish Fire")
509 # BMW Stocks
510 ssrecordsPlot(bmw)
511 text(1, 10.5, pos = 4, "BMW Shares")
512
513 ## xacfPlot -
514 xmpExtremes("\nNext: ACF Plot of Exceedences >")
515 # Plot ACF of Heights/Distances of Eceedences over threshold:
516 par(mfrow = c(2, 2))
517 data(bmw)
518 xacfPlot(bmw)
519
520 ## findThreshold -
521 xmpExtremes("\nStart: Find Thresold >")
522 # Find threshold giving (at least) fifty exceedances
523 # for Danish Fire data
524 data(danish)
525 findThreshold(danish, n = c(10, 50, 100))
526
527 ## blockMaxima -
528 xmpExtremes("\nNext: Compute Block Maxima >")
529 # Block Maxima (Minima) for the right and left tails
530 # of the BMW log returns:
531 data(bmw)
532 par(mfrow = c(2, 1))
533 blockMaxima( bmw, block = 100)
534 blockMaxima(-bmw, block = 100)
535
536 ## deCluster -
537 xmpExtremes("\nNext: De-Cluster Exceedences >")
538 # Decluster the 200 exceedances of a particular
539 # threshold in the negative BMW log-return data
540 par(mfrow = c(2, 2))
541 fit = potFit(-bmw, nextremes = 200)
542 deCluster(fit$fit$data, 30)
543 }
544
545
546 \keyword{hplot}
547
+0
-654
man/52A-GevModelling.Rd less more
0 \name{GevModelling}
1
2 \alias{dgev}
3 \alias{pgev}
4 \alias{qgev}
5 \alias{rgev}
6 \alias{devd}
7 \alias{pevd}
8 \alias{qevd}
9 \alias{revd}
10
11 \alias{GevFit}
12 \alias{gevSim}
13 \alias{gevFit}
14 \alias{print.gevFit}
15 \alias{plot.gevFit}
16 \alias{summary.gevFit}
17 \alias{gevrlevelPlot}
18
19 \alias{hillPlot}
20 \alias{shaparmPlot}
21 \alias{shaparmPickands}
22 \alias{shaparmHill}
23 \alias{shaparmDEHaan}
24
25
26
27 \title{Generalized Extreme Value Modelling}
28
29
30 \description{
31
32 A collection and description functions to compute
33 the generalized extreme value distribution and to
34 estimate it parameters. The functions compute
35 density, distribution function, quantile function
36 and generate random deviates for the GEV, for the
37 Frechet, Gumbel, and Weibull distributions. To model
38 the GEV three types of approaches for parameter
39 estimation are provided: Maximum likelihood
40 estimation, probability weighted moment method,
41 and estimation by the MDA approach. MDA includes
42 functions for the Pickands, Einmal-Decker-deHaan,
43 and Hill estimators together with several plot
44 variants.
45 \cr
46
47 The GEV distribution functions are:
48
49 \tabular{ll}{
50 \code{dgev} \tab density of the GEV Distribution, \cr
51 \code{pgev} \tab probability function of the GEV Distribution, \cr
52 \code{qgev} \tab quantile function of the GEV Distribution, \cr
53 \code{rgev} \tab random variates from the GEV Distribution. \cr
54 \code{[dpqr]frechet} \tab Frechet Distribution, \cr
55 \code{[dpqr]gumbel} \tab Gumbel Distribution, \cr
56 \code{[dpqr]weibull} \tab Weibull Distribution, \cr
57 \code{[dpqr]evd} \tab an alternative call for the GEV Distribution. }
58
59 The GEV modelling functions are:
60
61 \tabular{ll}{
62 \code{gevSim} \tab generates data from the GEV, \cr
63 \code{gevFit} \tab fits empirical or simulated data to the distribution, \cr
64 \code{print} \tab print method for a fitted GEV object, \cr
65 \code{plot} \tab plot method for a fitted GEV object, \cr
66 \code{summary} \tab summary method for a fitted GEV object, \cr
67 \code{gevrlevelPlot} \tab k-block return level with confidence intervals. }
68
69 Maximum Domain of Attraction Estimators:
70
71 \tabular{ll}{
72 \code{hillPlot} \tab shape parameter and Hill estimate of the tail index, \cr
73 \code{shaparmPlot} \tab variation of shape parameter with tail depth. }
74
75 }
76
77
78 \usage{
79 dgev(x, xi = 1, mu = 0, sigma = 1, log = FALSE)
80 pgev(q, xi = 1, mu = 0, sigma = 1, lower.tail = TRUE)
81 qgev(p, xi = 1, mu = 0, sigma = 1, lower.tail = TRUE)
82 rgev(n, xi = 1, mu = 0, sigma = 1)
83 devd(x, loc = 0, scale = 1, shape = 0, log = FALSE)
84 pevd(q, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
85 qevd(p, loc = 0, scale = 1, shape = 0, lower.tail = TRUE)
86 revd(n, loc = 0, scale = 1, shape = 0)
87
88 gevSim(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
89 gevFit(x, block = NA, type = c("mle", "pwm"), gumbel = FALSE, \dots)
90 \method{print}{gevFit}(x, \dots)
91 \method{plot}{gevFit}(x, which = "all", \dots)
92 \method{summary}{gevFit}(object, doplot = TRUE, which = "all", \dots)
93 gevrlevelPlot(object, k.blocks = 20, add = FALSE, \dots)
94
95 hillPlot(x, option = c("alpha", "xi", "quantile"), start = 15,
96 end = NA, reverse = FALSE, p = NA, ci = 0.95, autoscale = TRUE,
97 labels = TRUE, \dots)
98 shaparmPlot(x, revert = FALSE, standardize = FALSE, tails = 0.01*(1:10),
99 doplot = c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE),
100 which = c(TRUE, TRUE, TRUE), doprint = TRUE, both.tails = TRUE,
101 xi.range = c(-0.5, 1.5), alpha.range = c(0, 10))
102 }
103
104
105 \arguments{
106
107 \item{add}{
108 [gevrlevelPlot] - \cr
109 whether the return level should be added graphically to a
110 time series plot; if \code{FALSE} a graph of the profile
111 likelihood curve showing the return level and its confidence
112 interval is produced.
113 }
114 \item{alpha.range, xi.range}{
115 [saparmPlot] - \cr
116 plotting ranges.
117 }
118 \item{autoscale}{
119 [hillPlot] - \cr
120 whether or not plot should be automatically
121 scaled; if not, \code{xlim} and \code{ylim} graphical
122 parameters may be entered.
123 }
124 \item{block}{
125 [gevFit] - \cr
126 the block size. Only used if \code{method="mle"} is selected.
127 A numeric value is interpreted as the
128 number of data values in each successive block. All the data is
129 used, so the last block may not contain \code{block} observations.
130 If the \code{data} has a \code{times} attribute containing (in
131 an object of class \code{"POSIXct"}, or an object that can be
132 converted to that class; see \code{\link{as.POSIXct}}) the
133 times/dates of each observation, then \code{block} may instead
134 take the character values \code{"month"}, \code{"quarter"},
135 \code{"semester"} or \code{"year"}.
136 }
137 \item{both.tails}{
138 [shaparmPlot] - \cr
139 a logical, decides whether or not both tails should be
140 investigated. By default TRUE. If FALSE only the lower
141 tail will be investigated.
142 }
143 \item{ci}{
144 [hillPlot] - \cr
145 probability for asymptotic confidence band; for no
146 confidence band set \code{ci} to zero.
147 }
148 \item{doplot}{
149 a logical. Should the results be plotted?
150 \cr
151 [shaparmPlot] - \cr
152 a vector of logicals of the same lengths as tails
153 defining for wich tail depths plots should be created,
154 by default plots will be generated for a tail depth of 5
155 percent. By default \code{c(FALSE, FALSE, FALSE, FALSE,
156 TRUE, FALSE, FALSE, FALSE, FALSE, FALSE)}.
157 }
158 \item{doprint}{
159 [shaparmPlot] - \cr
160 a logical, decides whether or not for all tail depths the
161 result for the shape parameter \code{1/alpha} should be
162 printed.
163 }
164 \item{gumbel}{
165 [gevFit] - \cr
166 a logical, by default FALSE. To fit a Gumbel model with fixed
167 \code{shape=0} set \code{gumbel=TRUE}.
168 }
169 \item{k.blocks}{
170 [gevrlevelPlot] - \cr
171 specifies the particular return level to be estimated; default
172 set arbitrarily to 20.
173 }
174 \item{labels}{
175 [hillPlot] - \cr
176 whether or not axes should be labelled.
177 }
178 \item{loc, scale, shape}{
179 \code{loc} is the location parameter,
180 \code{scale} the scale parameter,
181 and \code{shape} is the shape parameter.
182 The default values are \code{loc=0}, \code{scale=1}, and
183 \code{shape=0}.
184 }
185 \item{log}{
186 a logical, if \code{TRUE}, the log density is returned.
187 }
188 \item{lower.tail}{
189 a logical, if \code{TRUE}, the default, then
190 probabilities are \code{P[X <= x]}, otherwise, \code{P[X > x]}.
191 }
192 \item{model}{
193 [gevSim] - \cr
194 a list with components \code{shape}, \code{location} and
195 \code{scale} giving the parameters of the GEV distribution.
196 By default the shape parameter has the value 0.25, the
197 location is zero and the scale is one.
198 To fit random deviates from a Gumbel distribution set
199 \code{shape=0}.
200 }
201 \item{n}{
202 [gevSim] - \cr
203 number of generated data points, an integer value.
204 \cr
205 [rgev][revd] - \cr
206 the number of observations.
207 }
208 \item{object}{
209 [summary][grlevelPlot] - \cr
210 a fitted object of class \code{"gevFit"}.
211 }
212 \item{option}{
213 [hillPlot] - \cr
214 whether \code{alpha}, \code{xi} (1/alpha) or
215 \code{quantile} (a quantile estimate) should be plotted.
216 }
217 \item{p}{
218 [qgev][qevs] - \cr
219 a numeric vector of probabilities.
220 [hillPlot] - \cr
221 probability required when option \code{quantile} is
222 chosen.
223 }
224 \item{q}{
225 [pgev][pevs] - \cr
226 a numeric vector of quantiles.
227 }
228 \item{reverse}{
229 [hillPlot] - \cr
230 whether plot is to be by increasing threshold, \code{TRUE}, or
231 increasing number of order statistics \code{FALSE}.
232 }
233 \item{revert}{
234 [shaparmPlot] - \cr
235 a logical value, by default FALSE, if set to TRUE the
236 sign of the vector will be reverted: \code{x = -x}.
237 }
238 \item{start, end}{
239 [hillPlot] - \cr
240 lowest and highest number of order statistics at which to plot
241 a point.
242 }
243 \item{standardize}{
244 [shaparmPlot] - \cr
245 a logical value, by default FALSE, if set to
246 TRUE the vector \code{x} will be standardized:
247 \code{x = (x-mean(x))/sqrt(var(x))}.
248 }
249 \item{tails}{
250 [shaparmPlot] - \cr
251 a numeric vector of tail depths to be considered; by
252 default ten values ranging from 0.1 to 1.0 in steps of 0.1
253 corresponding to values ranging from 1 to 10 percent.
254 }
255 \item{type}{
256 a character string denoting the type of parameter estimation,
257 either by maximum likelihood estimation \code{"mle"}, the
258 default value, or by the probability weighted moment menthod
259 \code{"pwm"}.
260 }
261 \item{which}{
262 [shaparmPlot] - \cr
263 a vector of 3 logicals indicating which plots from the
264 three methods will be created. The first entry decides
265 for the Pickands estimator, the second for the Hill
266 estimator, and the last for the Deckers-Einmahl-deHaan
267 estimator. By default all three will be created.
268 By default \code{c(TRUE, TRUE, TRUE)}.
269 \cr
270 [plot][summary] - \cr
271 a vector of logicals, one for each plot, denoting which plot
272 should be displayed. Alkternatively if \code{which="ask"} the
273 user will be interactively asked which of the plots should be
274 desplayed. By default \code{which="all"}.
275 }
276 \item{x}{
277 [dgev][devd] - \cr
278 a numeric vector of quantiles.
279 \cr
280 [gevFit] - \cr
281 data vector. In the case of \code{method="mle"} the interpretation
282 depends on the value of block: if no block size is specified then
283 data are interpreted as block maxima; if block size is set, then data
284 are interpreted as raw data and block maxima are calculated.
285 \cr
286 [hillPlot][shaparmPlot] - \cr
287 the data from which to calculate the shape parameter, a
288 numeric vector.
289 \cr
290 [print][plot] - \cr
291 a fitted object of class \code{"gevFit"}.
292 }
293 \item{xi, mu, sigma}{
294 \code{xi} is the shape parameter,
295 \code{mu} the location parameter,
296 and \code{sigma} is the scale parameter.
297 The default values are \code{xi=1}, \code{mu=0}, and
298 \code{sigma=1}.
299 }
300 \item{\dots}{
301 [gevFit] - \cr
302 control parameters optionally passed to the
303 optimization function. Parameters for the optimization
304 function are passed to components of the \code{control} argument of
305 \code{optim}.
306 \cr
307 [hillPlot] - \cr
308 other graphics parameters.
309 \cr
310 [plot][summary] - \cr
311 arguments passed to the plot function.
312 }
313
314 }
315
316
317 \value{
318
319 \code{d*} returns the density, \cr
320 \code{p*} returns the probability, \cr
321 \code{q*} returns the quantiles, and \cr
322 \code{r*} generates random variates. \cr
323 All values are numeric vectors.
324 \cr
325
326 \code{gevSim}
327 \cr
328 returns a vector of data points from the simulated series.
329 \cr
330
331 \code{gevFit}
332 \cr
333 returns an object of class \code{gev} describing the fit.
334 \cr
335
336 \code{print.summary}
337 \cr
338 prints a report of the parameter fit.
339 \cr
340
341 \code{summary}
342 \cr
343 performs diagnostic analysis. The method provides two different
344 residual plots for assessing the fitted GEV model.
345 \cr
346
347 \code{gevrlevelPlot}
348 \cr
349 returns a vector containing the lower 95\% bound of the confidence
350 interval, the estimated return level and the upper 95\% bound.
351 \cr
352
353 \code{hillPlot}
354 \cr
355 displays a plot.
356 \cr
357
358 \code{shaparmPlot}
359 \cr
360 returns a list with one or two entries, depending on the
361 selection of the input variable \code{both.tails}. The two
362 entries \code{upper} and \code{lower} determine the position of
363 the tail. Each of the two variables is again a list with entries
364 \code{pickands}, \code{hill}, and \code{dehaan}. If one of the
365 three methods will be discarded the printout will display zeroes.
366
367 }
368
369
370 \details{
371
372 \bold{Generalized Extreme Value Distribution:}
373 \cr\cr
374 Computes density, distribution function, quantile function and
375 generates random variates for the Generalized Extreme Value
376 Distribution, GEV, for the Frechet, Gumbel, and Weibull
377 distributions.
378 \cr
379
380 \bold{Parameter Estimation:}
381 \cr\cr
382 \code{gevFit} estimates the parameters either by the probability
383 weighted moment method, \code{method="pwm"} or by maximum log
384 likelihood estimation \code{method="mle"}.
385 As a limiting case the Gumbel distribution can be selected. The
386 summary method produces diagnostic plots for fitted GEV or Gumbel
387 models.
388 \cr
389
390 \bold{Methods:}
391 \cr\cr
392 \code{print.gev}, \code{plot.gev} and \code{summary.gev} are
393 print, plot, and summary methods for a fitted object of class
394 \code{gev}. Concerning the summary method, the data are
395 converted to unit exponentially distributed residuals under null
396 hypothesis that GEV fits. Two diagnostics for iid exponential data
397 are offered. The plot method provides two different residual plots
398 for assessing the fitted GEV model. Two diagnostics for
399 iid exponential data are offered.
400 \cr
401
402 \bold{Return Level Plot:}
403 \cr\cr
404 \code{gevrlevelPlot} calculates and plots the k-block return level
405 and 95\% confidence interval based on a GEV model for block maxima,
406 where \code{k} is specified by the user. The k-block return level
407 is that level exceeded once every \code{k} blocks, on average. The
408 GEV likelihood is reparameterized in terms of the unknown return
409 level and profile likelihood arguments are used to construct a
410 confidence interval.
411 \cr
412
413 \bold{Hill Plot:}
414 \cr\cr
415 The function \code{hillPlot} investigates the shape parameter and
416 plots the Hill estimate of the tail index of heavy-tailed data, or
417 of an associated quantile estimate. This plot is usually calculated
418 from the alpha perspective. For a generalized Pareto analysis of
419 heavy-tailed data using the \code{gpdFit} function, it helps to
420 plot the Hill estimates for \code{xi}.
421 \cr
422
423 \bold{Shape Parameter Plot:}
424 \cr\cr
425 The function \code{shaparmPlot} investigates the shape parameter and
426 plots for the upper and lower tails the shape parameter as a function
427 of the taildepth. Three approaches are considered, the \emph{Pickands}
428 estimator, the \emph{Hill} estimator, and the
429 \emph{Decker-Einmal-deHaan} estimator.
430
431 }
432
433
434 \note{
435
436 \bold{Generalized Extreme Value Distribution:}
437 \cr\cr
438 Here we implemented the notation for the arguments as used
439 by the GEV functions in the EVIS package or SPlus/FinMetrics
440 module. Additional arguments to these packages are the \code{log}
441 and the \code{lower.tail} arguments, underlying the code
442 from R's \code{evd} package.
443 \cr
444 An alternative usage is proposed by the \code{evd} package.
445 There the following arguments are used:
446 \cr
447 \code{*gev(x, loc = 0, scale = 1, shape = 0, ...)}
448 \cr
449 What you prefer is a matter of taste. The GEV functions from
450 the \code{evd} package are renamed from \code{*gev} to \code{*evd}
451 so that both versions are available.
452 \cr
453 In addition functions for the density, probability, quantiles,
454 and the generation of random variates for the
455 Frechet \code{[dpqr]frechet},
456 Gumbel \code{[dpqr]gumbel}, and
457 Weibull \code{[dpqr]weibull} are also available.
458 \cr
459 If you stay with both versions you can access the help page for
460 \code{evds}'s function \code{dgev} by \code{help(dgev, package="evd")}.
461 \cr
462
463 \bold{Generalized Extreme Value Distribution:}
464 \cr\cr
465 If method \code{"mle"} is selected the parameter fitting in \code{gevFit}
466 is passed to the internal function \code{gev.mle} or \code{gumbel.mle}
467 depending on the value of \code{gumbel}, \code{FALSE} or \code{TRUE}.
468 On the other hand, if method \code{"pwm"} is selected the parameter
469 fitting in \code{gevFit} is passed to the internal function
470 \code{gev.pwm} or \code{gumbel.pwm} again depending on the value of
471 \code{gumbel}, \code{FALSE} or \code{TRUE}.
472
473 }
474
475
476 \references{
477
478 Coles S. (2001);
479 \emph{Introduction to Statistical Modelling of Extreme Values},
480 Springer.
481
482 Embrechts, P., Klueppelberg, C., Mikosch, T. (1997);
483 \emph{Modelling Extremal Events},
484 Springer.
485
486 }
487
488
489 \author{
490
491 Alec Stephenson for R's \code{evd} and \code{evir} package, and \cr
492 Diethelm Wuertz for this \R-port.
493
494 }
495
496
497 \examples{
498 ## SOURCE("fExtremes.52A-GevModelling")
499
500 ## *gev -
501 xmpExtremes("\nStart: GEV Frechet >")
502 # Create and plot 1000 GEV/Frechet distributed rdv:
503 par(mfrow = c(3, 3))
504 r = rgev(n = 1000, xi = 1)
505 plot(r, type = "l", main = "GEV/Frechet Series")
506 ## Plot empirical density and compare with true density:
507 ## Omit values greater than 500 from plot
508 hist(r[r<10], n = 25, probability = TRUE, xlab = "r",
509 xlim = c(-5, 5), ylim = c(0, 1.1), main = "Density")
510 x = seq(-5, 5, by=0.01)
511 lines(x, dgev(x, xi = 1), col = 2)
512 ## Plot df and compare with true df:
513 plot(sort(r), (1:length(r)/length(r)),
514 xlim = c(-3, 6), ylim = c(0, 1.1),
515 cex = 0.5, ylab = "p", xlab = "q", main = "Probability")
516 q = seq(-5,5, by=0.1)
517 lines(q, pgev(q, xi=1), col=2)
518 ## Compute quantiles, a test:
519 qgev(pgev(seq(-5, 5, 0.25), xi = 1), xi = 1)
520
521 ## *gev -
522 xmpExtremes("\nNext: GEV Gumbel >")
523 # Create and plot 1000 Gumbel distributed rdv:
524 ##> r = rgev(n = 1000, xi = 0)
525 ##> plot(r, type = "l", main = "Gumbel Series")
526 ## Plot empirical density and compare with true density:
527 ##>hist(r[abs(r)<10], nclass = 25, freq = FALSE, xlab = "r",
528 ##> xlim = c(-5,5), ylim = c(0,1.1), main = "Density")
529 ##>x = seq(-5, 5, by = 0.01)
530 ##>lines(x, dgev(x, xi = 0), col=2)
531 ## Plot df and compare with true df:
532 ##>plot(sort(r), (1:length(r)/length(r)),
533 ##> xlim = c(-3, 6), ylim = c(0, 1.1),
534 ##> cex=0.5, ylab = "p", xlab="q", main="Probability")
535 ##>q = seq(-5, 5, by = 0.1)
536 ##>lines(q, pgev(q, xi = 0), col = 2)
537 ## Compute quantiles, a test:
538 ##>qgev(pgev(seq(-5, 5, 0.25), xi = 0), xi = 0)
539
540 ## *gev -
541 xmpExtremes("\nNext: GEV Weibull >")
542 # Create and plot 1000 Weibull distributed rdv:
543 r = rgev(n = 1000, xi = -1)
544 plot(r, type = "l", main = "Weibull Series")
545 ## Plot empirical density and compare with true density:
546 hist(r[abs(r)<10], nclass = 25, freq = FALSE, xlab = "r",
547 xlim=c(-5,5), ylim=c(0,1.1), main="Density")
548 x = seq(-5, 5, by=0.01)
549 lines(x, dgev(x, xi = -1), col = 2)
550 ## Plot df and compare with true df:
551 plot(sort(r), (1:length(r)/length(r)),
552 xlim = c(-3, 6), ylim = c(0, 1.1),
553 cex = 0.5, ylab = "p", xlab = "q", main = "Probability")
554 q=seq(-5, 5, by = 0.1)
555 lines(q, pgev(q, xi = -1), col = 2)
556 ## Compute quantiles, a test:
557 qgev(pgev(seq(-5, 5, 0.25), xi = -1), xi = -1)
558
559 ## gevSim -
560 ## gevFit -
561 # Simulate GEV Data:
562 xmpExtremes("\nStart: Simulte GEV Sample >")
563 # Use default length n=1000
564 x = gevSim(model = list(shape = 0.25, location =0 , scale = 1))
565 # Fit GEV Data by Probability Weighted Moments:
566 fit = gevFit(x, type = "pwm")
567 print(fit)
568 # Summarize Results:
569 par(mfcol = c(3, 2))
570 summary(fit)
571
572 ## gevFit -
573 # Fit GEV Data by Max Log Likelihood Method:
574 xmpExtremes("\nNext: Estimate Parameters >")
575 fit = gevFit(x, type = "mle")
576 print(fit)
577 # Summarize Results:
578 summary(fit)
579
580 ## gevSim -
581 ## gevFit -
582 # Simulate Gumbel Data:
583 xmpExtremes("\nNext: Simulte Gumbel Sample >")
584 # Use default length n=1000
585 ##> x = gevSim(model = list(shape = 0, location = 0, scale = 1))
586 # Fit Gumbel Data by Probability Weighted Moments:
587 ##> fit = gevFit(x, type = "pwm", gumbel = TRUE)
588 ##> print(fit)
589 # Summarize Results:
590 ##> par(mfcol = c(3, 2))
591 ##> summary(fit)
592
593 ## Fit Gumbel Data by Max Log Likelihood Method:
594 xmpExtremes("\nNext: Estimate Parameters >")
595 ##> fit = gevFit(x, type = "mle", gumbel = TRUE)
596 ##> print(fit)
597 # Summarize Results:
598 ##> summary(fit)
599 ##> xmpExtremes("Press any key to continue >")
600
601 ## Return levels based on GEV Fit:
602 # BMW Stock Data:
603 xmpExtremes("\nNext: Compute BMW Return Levels >")
604 par(mfrow = c(2, 1))
605 data(bmw)
606 # Fit GEV to monthly Block Maxima:
607 fit = gevFit(-bmw, block = "month")
608 # Calculate the 40 month return level
609 gevrlevelPlot(fit, k.block = 40, main = "BMW: Return Levels")
610
611 ## Return levels based on GEV Fit:
612 xmpExtremes("\nNext: Compute SIEMENS Return Levels >")
613 # Siemens Stock Data:
614 data(siemens)
615 # Fit GEV to monthly Block Maxima:
616 fit = gevFit(-siemens, block = "month")
617 # Calculate the 40 month return level
618 gevrlevelPlot(fit, k.block = 40, main = "SIEMENS: Return Levels")
619
620 ## Interactive Plot:
621 ##> par(mfrow = c(1, 1), ask = TRUE)
622 ##> plot(fit)
623
624 ## hillPlot -
625 xmpExtremes("\nStart: Hill Estimator >")
626 # Hill plot of heavy-tailed Danish fire insurance data
627 # and BMW stock data for estimated 0.999 quantile
628 par(mfrow = c(2, 2))
629 data(bmw)
630 hillPlot(bmw)
631 hillPlot(bmw, option = "quantile", end = 500, p = 0.999)
632 data(danish)
633 hillPlot(danish)
634 hillPlot(danish, option = "quantile", end = 500, p = 0.999)
635
636 ## shaparmPlot -
637 xmpExtremes("\nNext: Shape Parameter Plots >")
638 par(mfcol = c(3, 2), cex = 0.6)
639 data(bmw)
640 shaparmPlot(bmw)
641
642 ## shaparmPlot -
643 xmpExtremes("\nNext: Simulated Frechet Data >")
644 par(mfcol = c(3, 2), cex = 0.6)
645 set.seed(4711)
646 x = rgev(10000, xi = 1/4)
647 shaparmPlot(x, revert = TRUE, both.tails = FALSE)
648 lines(c(0.01, 0.1), c(4, 4), col = "steelblue3") # True Value
649 }
650
651
652 \keyword{models}
653
+0
-133
man/53A-GpdModelling.Rd less more
0 \name{GpdDistribution}
1
2 \alias{GpdDistribution}
3
4 \alias{dgpd}
5 \alias{pgpd}
6 \alias{qgpd}
7 \alias{rgpd}
8
9 \title{GPD Distributions for Extreme Value Theory}
10
11
12 \description{
13
14 A collection and description of distribution functions
15 used in extreme value theory. The functions compute
16 density, distribution function, quantile function and
17 generate random deviates for the Generalized Pareto
18 Distribution GPD.
19 \cr
20
21 The functions are:
22
23 \tabular{ll}{
24 \code{dgpd} \tab Density of the GPD Distribution, \cr
25 \code{pgpd} \tab Probability function of the GPD Distribution, \cr
26 \code{qgpd} \tab Quantile function of the GPD Distribution, \cr
27 \code{rgpd} \tab Random variates from the GPD Distribution. }
28
29 }
30
31
32 \usage{
33 dgpd(x, xi = 1, mu = 0, beta = 1)
34 pgpd(q, xi = 1, mu = 0, beta = 1)
35 qgpd(p, xi = 1, mu = 0, beta = 1)
36 rgpd(n, xi = 1, mu = 0, beta = 1)
37 }
38
39
40 \arguments{
41
42 \item{n}{
43 the number of observations.
44 }
45 \item{p}{
46 a numeric vector of probabilities.
47 }
48 \item{q}{
49 a numeric vector of quantiles.
50 }
51 \item{x}{
52 a numeric vector of quantiles.
53 }
54 \item{xi, mu, beta}{
55 \code{xi} is the shape parameter,
56 \code{mu} the location parameter,
57 and \code{beta} is the scale parameter.
58 }
59
60 }
61
62
63 \value{
64
65 All values are numeric vectors: \cr
66 \code{d*} returns the density, \cr
67 \code{p*} returns the probability, \cr
68 \code{q*} returns the quantiles, and \cr
69 \code{r*} generates random deviates. \cr
70 }
71
72
73 \details{
74
75 \bold{Generalized Pareto Distribution:}
76 \cr\cr
77 Compute density, distribution function, quantile function and
78 generates random variates for the Generalized Pareto Distribution.
79
80 }
81
82
83 \author{
84
85 Alec Stephenson for the functions from R's \code{evd} package, \cr
86 Diethelm Wuertz for this \R-port.
87
88 }
89
90
91 \references{
92
93 Embrechts, P., Klueppelberg, C., Mikosch, T. (1997);
94 \emph{Modelling Extremal Events}, Springer.
95
96 }
97
98
99 \examples{
100 ## SOURCE("fExtremes.53A-GpdModelling")
101
102 ## *gpd -
103 xmpExtremes("\nStart: Simulate GPD Distributed sample >")
104 par(mfrow = c(2, 2))
105 r = rgpd(n = 1000, xi = 1/4)
106 plot(r, type = "l", main = "GPD Series")
107
108 ## Plot empirical density and compare with true density:
109 ## Omit values greater than 500 from plot
110 xmpExtremes("\nNext: Plot Empirical and True Density >")
111 hist(r, n = 50, probability = TRUE, xlab = "r",
112 xlim = c(-5, 5), ylim = c(0, 1.1), main = "Density")
113 x = seq(-5, 5, by = 0.01)
114 lines(x, dgpd(x, xi = 1/4), col = "steelblue3")
115
116 ## Plot df and compare with true df:
117 xmpExtremes("\nNext: Plot Empirical and True Probability >")
118 plot(sort(r), (1:length(r)/length(r)),
119 xlim = c(-3, 6), ylim = c(0, 1.1),
120 cex = 0.5, ylab = "p", xlab = "q", main = "Probability")
121 q = seq(-5, 5, by = 0.1)
122 lines(q, pgpd(q, xi = 1/4), col = "steelblue3")
123
124 ## Compute quantiles, a test:
125 xmpExtremes("\nNext: Compute Quantiles >")
126 qgpd(pgpd(seq(-1, 5, 0.25), xi = 1/4 ), xi = 1/4)
127
128 }
129
130
131 \keyword{distribution}
132
+0
-406
man/53B-GpdFit.Rd less more
0 \name{GpdFit}
1
2 \alias{GpdFit}
3
4 \alias{gpdSim}
5 \alias{gpdFit}
6
7 \alias{print.gpdFit}
8 \alias{plot.gpdFit}
9 \alias{summary.gpdFit}
10
11 \alias{gpdqPlot}
12 \alias{gpdquantPlot}
13 \alias{gpdriskmeasures}
14 \alias{gpdsfallPlot}
15 \alias{gpdshapePlot}
16 \alias{gpdtailPlot}
17
18
19 \title{Modelling the Generalized Pareto Distribution}
20
21
22 \description{
23
24 A collection and description of functions to model
25 the Generalized Pareto Distribution, GPD, based on
26 \R's 'evir' package. Two approaches for parameter
27 estimation are provided: Maximum likelihood estimation
28 and the probability weighted moment method.
29 \cr
30
31 The functions are:
32
33 \tabular{ll}{
34 \code{gpdSim} \tab generates data from the GPD, \cr
35 \code{gpdFit} \tab fits empirical or simulated data to the distribution, \cr
36 \code{print} \tab print method for a fitted GPD object of class ..., \cr
37 \code{plot} \tab plot method for a fitted GPD object, \cr
38 \code{summary} \tab summary method for a fitted GPD object, \cr
39 \code{gpdqPlot} \tab estimation of high quantiles, \cr
40 \code{gpdquantPlot} \tab variation of high quantiles with threshold, \cr
41 \code{gpdriskmeasures} \tab prescribed quantiles and expected shortfalls, \cr
42 \code{gpdsfallPlot} \tab expected shortfall with confidence intervals, \cr
43 \code{gpdshapePlot} \tab variation of shape with threshold, \cr
44 \code{gpdtailPlot} \tab plot of the tail. }
45
46 }
47
48
49 \usage{
50 gpdSim(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
51 gpdFit(x, threshold = NA, nextremes = NA, type = c("mle", "pwm"),
52 information = c("observed", "expected"), \dots)
53
54 \method{print}{gpdFit}(x, \dots)
55 \method{plot}{gpdFit}(x, which = "all", \dots)
56 \method{summary}{gpdFit}(object, doplot = TRUE, which = "all", \dots)
57
58 gpdqPlot(x, pp = 0.99, ci.type = c("likelihood", "wald"), ci.p = 0.95,
59 like.num = 50)
60 gpdquantPlot(data, p = 0.99, models = 30, start = 15, end = 500,
61 reverse = TRUE, ci = 0.95, autoscale = TRUE, labels = TRUE, \dots)
62 gpdriskmeasures(x, plevels = c(0.99, 0.995, 0.999, 0.9995, 0.9999))
63 gpdsfallPlot(x, pp = 0.99, ci.p = 0.95, like.num = 50)
64 gpdshapePlot(data, models = 30, start = 15, end = 500, reverse = TRUE,
65 ci = 0.95, autoscale = TRUE, labels = TRUE, \dots)
66 gpdtailPlot(fit, optlog = NA, extend = 1.5, labels = TRUE, \dots)
67 }
68
69
70 \arguments{
71
72 \item{autoscale}{
73 whether or not plot should be automatically scaled;
74 if not, xlim and ylim graphical parameters may be entered.
75 }
76 \item{ci}{
77 the probability for asymptotic confidence band; for no
78 confidence band set to zero.
79 }
80 \item{ci.p}{
81 the probability for confidence interval (must be less
82 than 0.999).
83 }
84 \item{ci.type}{
85 the method for calculating a confidence interval:
86 \code{"likelihood"} or \code{"wald"}.
87 }
88 \item{data}{
89 a numeric vector of data.
90 }
91 \item{doplot}{
92 a logical. Should the results be plotted?
93 }
94 \item{extend}{
95 optional argument for plots 1 and 2 expressing how far x-axis
96 should extend as a multiple of the largest data value. This
97 argument must take values greater than 1 and is useful for
98 showing estimated quantiles beyond data.
99 }
100 \item{fit}{
101 [print][plot][summary] - \cr
102 print method, a fitted object of class \code{"gpd"}.
103 }
104 \item{information}{
105 whether standard errors should be calculated with
106 \code{"observed"} or \code{"expected"} information. This only applies
107 to the maximum likelihood method; for the probability-weighted moments
108 method \code{"expected"} information is used if possible.
109 }
110 \item{labels}{
111 optional argument for plots 1 and 2 specifying whether or not
112 axes should be labelled.
113 }
114 \item{like.num}{
115 the number of times to evaluate profile likelihood.
116 }
117 \item{model}{
118 [gpdsim] - \cr
119 a list with components \code{shape}, \code{location} and
120 \code{scale} giving the parameters of the GPD distribution.
121 By default the shape parameter has the value 0.25, the
122 location is zero and the scale is one.}
123 \item{models}{
124 the number of consecutive gpd models to be fitted.
125 }
126 \item{n}{
127 [gpdsim] - \cr
128 lnumber of generated data points, an integer value.
129 }
130 \item{nextremes}{
131 [gpdFit] - \cr
132 the number of upper extremes to be used (either this or
133 \code{threshold} must be given but not both).
134 }
135 \item{object}{
136 [summary] - \cr
137 a fitted object of class \code{"gpdFit"}.
138 }
139 \item{optlog}{
140 optional argument for plots 1 and 2 giving a particular choice
141 of logarithmic axes: \code{"x"} x-axis only; \code{"y"} y-axis
142 only; \code{"xy"} both axes; \code{""} neither axis.
143 }
144 \item{plevels, p, pp}{
145 a vector of probability levels, the desired probability for the
146 quantile estimate (e.g. 0.99 for the 99th percentile).
147 }
148 \item{reverse}{
149 should plot be by increasing threshold (\code{TRUE}) or number
150 of extremes (\code{FALSE}).
151 }
152 \item{start, end}{
153 the lowest and maximum number of exceedances to be considered.
154 }
155 \item{threshold}{
156 a threshold value (either this or \code{nextremes} must be given
157 but not both).
158 }
159 \item{type}{
160 a character string selecting the desired estimation mehtod, either
161 \code{"mle"} for the maximum likelihood mehtod or \code{"pwm"} for
162 the probability weighted moment method. By default, the first will
163 be selected. Note, the function \code{gpd} uses \code{"ml"}.
164 }
165 \item{which}{
166 if \code{which} is set to \code{"ask"} the function will
167 interactively ask which plot should be displayed. By default
168 this value is set to \code{FALSE} and then those plots will
169 be displayed for which the elements in the logical vector
170 \code{which} ar set to \code{TRUE}; by default all four
171 elements are set to \code{"all"}.
172 }
173 \item{x}{
174 [gpdFit] - \cr
175 the data vector. Note, there are two different names
176 for the first argument \code{x} and \code{data} depending
177 which function name is used, either \code{gpdFit} or the
178 EVIS synonyme \code{gpd}.
179 \cr
180 [print][plot] - \cr
181 a fitted object of class \code{"gpdFit"}.
182 }
183 \item{\dots}{
184 control parameters and plot parameters optionally passed to the
185 optimization and/or plot function. Parameters for the optimization
186 function are passed to components of the \code{control} argument of
187 \code{optim}.
188 }
189
190 }
191
192
193 \value{
194
195 \code{gpdSim}
196 \cr
197 returns a vector of datapoints from the simulated
198 series.
199
200 \code{gpdFit}
201 \cr
202 returns an object of class \code{"gpd"} describing the
203 fit including parameter estimates and standard errors.
204
205 \code{gpdquantPlot}
206 \cr
207 returns invisible a table of results.
208
209 \code{gpdshapePlot}
210 \cr
211 returns invisible a table of results.
212
213 \code{gpdtailPlot}
214 \cr
215 returns invisible a list object containing
216 details of the plot is returned invisibly. This object should be
217 used as the first argument of \code{gpdqPlot} or \code{gpdsfallPlot}
218 to add quantile estimates or expected shortfall estimates to the
219 plot.
220
221 }
222
223
224 \details{
225
226 \bold{Simulation:}
227 \cr\cr
228 \code{gpdSim} simulates data from a Generalized Pareto
229 distribution.
230 \cr
231
232 \bold{Parameter Estimation:}
233 \cr\cr
234 \code{gpdFit} fits the model parameters either by the probability
235 weighted moment method or the maxim log likelihood method.
236 The function returns an object of class \code{"gpd"}
237 representing the fit of a generalized Pareto model to excesses over
238 a high threshold. The fitting functions use the probability weighted
239 moment method, if method \code{method="pwm"} was selected, and the
240 the general purpose optimization function \code{optim} when the
241 maximum likelihood estimation, \code{method="mle"} or \code{method="ml"}
242 is chosen.
243 \cr
244
245 \bold{Methods:}
246 \cr\cr
247 \code{print.gpd}, \code{plot.gpd} and \code{summary.gpd} are print,
248 plot, and summary methods for a fitted object of class \code{gpdFit}.
249 The plot method provides four different plots for assessing fitted
250 GPD model.
251 \cr
252
253 \bold{gpd* Functions:}
254 \cr\cr
255 \code{gpdqPlot} calculates quantile estimates and confidence intervals
256 for high quantiles above the threshold in a GPD analysis, and adds a
257 graphical representation to an existing plot. The GPD approximation in
258 the tail is used to estimate quantile. The \code{"wald"} method uses
259 the observed Fisher information matrix to calculate confidence interval.
260 The \code{"likelihood"} method reparametrizes the likelihood in terms
261 of the unknown quantile and uses profile likelihood arguments to
262 construct a confidence interval.
263 \cr
264
265 \code{gpdquantPlot} creates a plot showing how the estimate of a
266 high quantile in the tail of a dataset based on the GPD approximation
267 varies with threshold or number of extremes. For every model
268 \code{gpdFit} is called. Evaluation may be slow. Confidence intervals
269 by the Wald method may be fastest.
270 \cr
271
272 \code{gpdriskmeasures} makes a rapid calculation of point estimates
273 of prescribed quantiles and expected shortfalls using the output of the
274 function \code{gpdFit}. This function simply calculates point estimates
275 and (at present) makes no attempt to calculate confidence intervals for
276 the risk measures. If confidence levels are required use \code{gpdqPlot}
277 and \code{gpdsfallPlot} which interact with graphs of the tail of a loss
278 distribution and are much slower.
279 \cr
280
281 \code{gpdsfallPlot} calculates expected shortfall estimates, in other
282 words tail conditional expectation and confidence intervals for high
283 quantiles above the threshold in a GPD analysis. A graphical
284 representation to an existing plot is added. Expected shortfall is
285 the expected size of the loss, given that a particular quantile of the
286 loss distribution is exceeded. The GPD approximation in the tail is used
287 to estimate expected shortfall. The likelihood is reparametrised in
288 terms of the unknown expected shortfall and profile likelihood arguments
289 are used to construct a confidence interval.
290 \cr
291
292 \code{gpdshapePlot} creates a plot showing how the estimate of shape
293 varies with threshold or number of extremes. For every model
294 \code{gpdFit} is called. Evaluation may be slow.
295 \cr
296
297 \code{gpdtailPlot} produces a plot of the tail of the underlying
298 distribution of the data.
299
300 }
301
302
303 \references{
304
305 Hosking J.R.M., Wallis J.R., (1987);
306 \emph{Parameter and quantile estimation for the generalized
307 Pareto distribution},
308 Technometrics 29, 339--349.
309
310 }
311
312
313 \author{
314
315 This function is based on Alec Stephenson's R-package \code{evir}
316 ported from the \code{EVIS} library, \emph{Extreme Values in S},
317 written by Alexander McNeil. The \code{fExtremes} port and the
318 change and addition of some functions were done by Diethelm Wuertz.
319
320 }
321
322
323 \examples{
324 ## SOURCE("fExtremes.53B-GpdFit")
325
326 ## Load Data:
327 data(danish)
328
329 ## gpdSim -
330 # Simulate GPD Data:
331 xmpExtremes("\nStart: Simulate a GPD Distributed Sample > ")
332 x = gpdSim(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
333
334 ## gpdFit -
335 xmpExtremes("\nNext: Fit Simulated Data to GPD using PWM > ")
336 fit = gpdFit(x, nextremes = length(x), type = "pwm")
337 print(fit)
338 par(mfcol = c(4, 2), cex = 0.7)
339 summary(fit)
340
341 ## gpdFit -
342 xmpExtremes("\nNext: Fit Simulated Data to GPD using MLE > ")
343 fit = gpdFit(x, nextremes = length(x), type = "mle")
344 print(fit)
345 summary(fit)
346
347 ## gpdFit -
348 xmpExtremes("\nNext: Fit Danish Fire Data to Excess Losses over 10 > ")
349 fit = gpdFit(danish, 10, type = "mle")
350 print(fit)
351 par(mfrow = c(2, 2), cex = 0.7)
352 summary(fit)
353
354 ## gpdqPlot -
355 xmpExtremes("\nNext: 99.5th Percentiles for Danish Fire Data > ")
356 fit = gpdFit(danish, threshold = 10, type = "mle")
357 par(mfrow = c(1, 1))
358 tail = gpdtailPlot(fit)
359 gpdqPlot(tail, 0.995)
360 title(main = "Danish Data: 99.5th Percentile")
361
362 ## gpdquantPlot -
363 xmpExtremes("\nNext: 99.9th Percentiles for Danish Fire Data > ")
364 par(mfrow = c(1, 1))
365 gpdquantPlot(danish, p = 0.999)
366 title(sub = "Danish Fire: GPD High Quantile")
367
368 ## gpdsfallPlot -
369 xmpExtremes("\nNext: Expected Shortfall for Danish Fire Data > ")
370 fit = gpdFit(danish, nextremes = floor(length(danish)/10), type = "mle")
371 par(mfrow = c(1, 1))
372 tp = gpdtailPlot(fit)
373 gpdsfallPlot(tp, 0.999)
374 title(main = "Danish Fire: Expected Shortfall")
375
376 ## gpdriskmeasures -
377 xmpExtremes("\nNext: Quantiles and Expected Shortfalls > ")
378 # Give estimates of 0.999 and 0.9999 quantiles - Danish Fire Date:
379 fit = gpdFit(danish, threshold = 10, type = "mle")
380 par(mfrow = c(1, 1))
381 gpdriskmeasures(fit, c(0.99, 0.995, 0.999, 0.9995, 0.9999))
382
383 ## gpdshapePlot -
384 xmpExtremes("\nNext: Shape Plot of Heavy-Tailed Simulated Data > ")
385 set.seed(4711)
386 par(mfrow = c(1, 1))
387 gpdshapePlot(gpdSim(n = 1000))
388 title(sub = "Simulated GPD", cex.sub = 0.7)
389
390 ## gpdshapePlot -
391 xmpExtremes("\nNext: Shape Plot of Heavy-Tailed Danish Fire Data > ")
392 par(mfrow = c(1, 1))
393 gpdshapePlot(danish)
394 title(sub = "Danish Fire", cex.sub = 0.7)
395
396 ## gpdtailPlot -
397 xmpExtremes("\nNext: Plot Tail Estimate of Danish Fire Data >")
398 fit = gpdFit(danish, threshold = 10, type = "mle")
399 par(mfrow = c(1, 1))
400 gpdtailPlot(fit, main = "Danish Fire: GPD Tail Estimate", col = "steelblue4")
401 }
402
403
404 \keyword{models}
405
+0
-151
man/53C-PotFit.Rd less more
0 \name{PotFit}
1
2 \alias{PotFit}
3
4 \alias{potSim}
5 \alias{potFit}
6
7 \alias{print.potFit}
8 \alias{plot.potFit}
9 \alias{summary.potFit}
10
11 \title{Modelling Peaks Over a Threshold}
12
13
14 \description{
15
16 a collection and description of functions to model
17 point processes over a threshold, POT, based on \R's
18 'evir' package.
19 \cr
20
21 The functions are:
22
23 \tabular{ll}{
24 \code{potSim} \tab generates data from a point process, \cr
25 \code{potFit} \tab fits empirical or simulated data to a point process, \cr
26 \code{print} \tab print method for a fitted POT object of class ..., \cr
27 \code{plot} \tab plot method for a fitted GEV object, \cr
28 \code{summary} \tab summary method for a fitted GEV object, \cr
29 \code{gevrlevelPlot} \tab k-block return level with confidence intervals. }
30
31 }
32
33
34 \usage{
35 potSim(x, threshold, nextremes = NA, run = NA)
36 potFit(x, threshold = NA, nextremes = NA, run = NA, \dots)
37
38 \method{print}{potFit}(x, \dots)
39 \method{plot}{potFit}(x, which = "all", \dots)
40 \method{summary}{potFit}(object, doplot = TRUE, which = "all", \dots)
41 }
42
43
44 \arguments{
45
46
47 \item{doplot}{
48 a logical. Should the results be plotted?
49 }
50 \item{nextremes}{
51 the number of upper extremes to be used (either
52 this or \code{threshold} must be given but not both).
53 }
54 \item{object}{
55 [summary] - \cr
56 a fitted object of class \code{"potFit"}.
57 }
58 \item{run}{
59 if the data are to be declustered the run length parameter for
60 the runs method, see \code{\link{deCluster}}, should be entered
61 here.
62 }
63 \item{threshold}{
64 a threshold value, either \code{threshold} or \code{nextremes}
65 must be given, but not both).
66 }
67 \item{which}{
68 if \code{which} is set to \code{ask} the function will
69 interactively ask which plot should be displayed. By default
70 this value is set to \code{FALSE} and then those plots will
71 be displayed for which the elements in the logical vector
72 \code{which} ar set to \code{TRUE}; by default all four
73 elements are set to \code{"all"}.
74 }
75 \item{x}{
76 numeric vector of data, which may have a \code{times} attribute
77 containing (in an object of class \code{"POSIXct"}, or an object
78 that can be converted to that class; see \code{\link{as.POSIXct}})
79 the times/dates of each observation.
80 If no \code{times} attribute exists, the data are assumed to be
81 equally spaced. Note, the argument name is different for
82 \code{potFit} and \code{pot}.
83 \cr
84 [print][plot] - \cr
85 a fitted object of class \code{"potFit"}.
86 }
87 \item{\dots}{
88 control parameters and plot parameters optionally passed to the
89 optimization and/or plot function. Parameters for the optimization
90 function are passed to components of the \code{control} argument
91 of \code{optim}.
92 }
93
94 }
95
96
97 \value{
98
99 Both, \code{potFit} and \code{pot} return an object of class \code{"pot"}
100 describing the fit including parameter estimates and standard errors.
101
102 }
103
104
105 \details{
106
107 \bold{Parameter Estimation:}
108 \cr\cr
109 \code{potFit} uses \code{optim} for point process likelihood
110 maximization.
111 \cr
112
113 \bold{Methods:}
114 \cr\cr
115 The plot method \code{plot.pot} provides seven different plots for
116 assessing fitted POT model. The user selects the plot type from a
117 menu. Plot 1 displays the exceedance process of the chosen threshold.
118 Plots 2-4 assess the Poisson nature of the exceedance process
119 by looking at the scaled gaps between exceedances, which should
120 be iid unit exponentially distributed. Plots 5-6 assess the GPD
121 nature of the excesses by looking at suitably defined residuals,
122 which should again be iid unit exponentially distributed. Option
123 8 allows the user to call GPD plotting functions. If plot 1 or 2
124 from the GPD plots is selected as the final plot (i.e. option 8 is
125 selected, followed by option 1 or 2), a list object containing
126 details of the plot is returned invisibly. This object should be
127 used as the first argument of \code{gpdqPlot} or \code{gpdsfallPlot}
128 to add quantile estimates or expected shortfall estimates to the plot.
129 }
130
131
132 \examples{
133 ## SOURCE("fExtremes.53C-PotFit")
134
135 ## Use Danish Fire Insurance Loss Data:
136 data(danish)
137
138 ## Fit:
139 xmpExtremes("\nStart: POT Parameter Estimate >")
140 fit = potFit(danish, threshold = 10)
141 print(fit)
142
143 ## Summary with Diagnostic Plots:
144 xmpExtremes("\nNext: Diagnostic Analysis >")
145 par(mfrow = c(3, 3), cex = 0.5)
146 summary(fit)
147 }
148
149
150 \keyword{models}
+0
-310
man/54A-ExtremesGlm.Rd less more
0 \name{GevGlmFit}
1
2 \alias{GevGlmFit}
3
4 \alias{gevglmFit}
5
6 \alias{print.gevglmFit}
7 \alias{plot.gevglmFit}
8 \alias{summary.gevglmFit}
9
10 \alias{gevglmprofPlot}
11 \alias{gevglmprofxiPlot}
12
13
14 \title{Modelling the GEV Distribution including GLM}
15
16
17 \description{
18
19 A collection and description of functions to model the
20 Generalized Extreme Value, GEV, distribution by maximum
21 likelihood approximation based on R's 'ismev' package. In
22 addition to the function gevFit the parameter estimation
23 allows to include generalized linear modelling, GLM, of
24 each parameter.
25 \cr
26
27 The functions are:
28
29 \tabular{ll}{
30 \code{gevglmFit} \tab fits empirical or simulated data to the distribution, \cr
31 \code{print} \tab print method for a fitted GEV object of class ..., \cr
32 \code{plot} \tab plot method for a fitted GEV object, \cr
33 \code{summary} \tab summary method for a fitted GEV object, \cr
34 \code{gevglmprofPlot} \tab profile log-likelihoods for return levels, \cr
35 \code{gevglmprofxiPlot} \tab profile log-likelihoods for shape parameters. }
36
37 }
38
39
40 \usage{
41 gevglmFit(x, y = NULL, gumbel = FALSE, mul = NULL, sigl = NULL, shl = NULL,
42 mulink = identity, siglink = identity, shlink = identity, show = FALSE,
43 method = "Nelder-Mead", maxit = 10000, \dots)
44
45 \method{print}{gevglmFit}(x, \dots)
46 \method{plot}{gevglmFit}(x, which = "ask", \dots)
47 \method{summary}{gevglmFit}(object, doplot = TRUE, which = "all", \dots)
48
49 gevglmprofPlot(object, m, xlow, xup, conf = 0.95, nint = 100)
50 gevglmprofxiPlot(object, xlow, xup, conf = 0.95, nint = 100)
51 }
52
53
54 \arguments{
55
56 \item{conf}{
57 [gevglmprof*Plot] - \cr
58 the confidence coefficient of the plotted profile confidence
59 interval.
60 }
61 \item{doplot}{
62 a logical. Should the results be plotted?
63 }
64 \item{gumbel}{
65 [gevglmFit] - \cr
66 a logical, should a Gumbel fit be created? In this case the shape
67 parameter equals zero, and the arguments \code{shl} and and
68 \code{shlink} are omitted.
69 }
70 \item{m}{
71 [gevglmprofPlot] - \cr
72 the return level; i.e. the profile likelihood is for the value
73 that is exceeded with probability 1/\code{m}.
74 }
75 \item{maxit}{
76 [gevglmFit] - \cr
77 the maximum number of iterations.
78 }
79 \item{method}{
80 [gevglmFit] - \cr
81 the optimization method (see \code{\link{optim}} for details).
82 }
83 \item{mul, sigl, shl}{
84 [gevglmFit] - \cr
85 numeric vectors of integers, giving the columns
86 of \code{ydat} that contain covariates for generalized linear
87 modelling of the location, scale and shape parameters repectively
88 (or \code{NULL} (the default) if the corresponding parameter is
89 stationary).
90 }
91 \item{mulink, siglink, shlink}{
92 [gevglmFit] - \cr
93 inverse link functions for generalized linear modelling of the
94 location, scale and shape parameters repectively.
95 }
96 \item{nint}{
97 [gevglmprof*Plot] - \cr
98 the number of points at which the profile likelihood is evaluated.
99 }
100 \item{object}{
101 [summary][grlevelPlot] - \cr
102 a fitted object of class \code{"gevglmFit"}.
103 }
104 \item{show}{
105 [gevglmFit] - \cr
106 a logical; if \code{TRUE} (the default), print details of
107 the fit.
108 }
109 \item{x}{
110 [gevglmFit] - \cr
111 a numeric vector of data to be fitted.
112 \cr
113 [print][plot] - \cr
114 a fitted object of class \code{"gevglmFit"}.
115 }
116 \item{xlow, xup}{
117 [gevglmprof*Plot] - \cr
118 the least and greatest value at which to evaluate the profile
119 likelihood.
120 }
121 \item{y}{
122 [gevglmFit] - \cr
123 a matrix of covariates for generalized linear modelling
124 of the parameters (or \code{NULL} (the default) for stationary
125 fitting). The number of rows should be the same as the length
126 of \code{xdat}.
127 }
128 \item{which}{
129 [plot][summary] - \cr
130 a vector of logicals, one for each plot, denoting which plot
131 should be displayed.
132 }
133 \item{\dots}{
134 [gevglmFit] - \cr
135 control parameters optionally passed to the
136 optimization function. Parameters for the optimization
137 function are passed to components of the \code{control} argument of
138 \code{optim}.
139 \cr
140 [plot][summary] - \cr
141 arguments passed to the plot function.
142 }
143
144 }
145
146
147 \value{
148
149 \code{gevglmFit}
150 \cr
151 returns a list containing the following components.
152 A subset of these components are printed after the fit. If \code{show}
153 is \code{TRUE}, then assuming that successful convergence is
154 indicated, the components \code{nllh}, \code{mle} and \code{se}
155 are always printed.
156
157 \item{trans}{
158 an logical indicator for a non-stationary fit.
159 }
160 \item{model}{
161 a list with components \code{mul}, \code{sigl}
162 and \code{shl}.
163 }
164 \item{link}{
165 a character vector giving inverse link functions.
166 }
167 \item{conv}{
168 the convergence code, taken from the list returned by
169 \code{\link{optim}}. A zero indicates successful convergence.
170 }
171 \item{nllh}{
172 the negative logarithm of the likelihood evaluated at
173 the maximum likelihood estimates.
174 }
175 \item{data}{
176 the data that has been fitted. For non-stationary
177 models, the data is standardized.
178 }
179 \item{mle}{
180 a vector containing the maximum likelihood estimates.
181 }
182 \item{cov}{
183 the covariance matrix.
184 }
185 \item{se}{
186 a vector containing the standard errors.
187 }
188 \item{vals}{
189 a matrix with three columns containing the maximum
190 likelihood estimates of the location, scale and shape parameters
191 at each data point.
192 }
193
194 For stationary models four plots are produced; a probability
195 plot, a quantile plot, a return level plot and a histogram
196 of data with fitted density. For non-stationary models two plots
197 are produced; a residual probability plot and a residual quantile
198 plot.
199 \cr
200
201 \code{gevglmprofPlot}\cr
202 \code{gevglmprofxiPlot}\cr
203 a plot of the profile likelihood is produced, with a horizontal line
204 representing a profile confidence interval with confidence coefficient
205 \code{conf}.
206
207 }
208
209
210 \details{
211
212 \bold{Simulation:}
213 \cr\cr
214 To simulate a GEV series use the function \code{gevSim}.
215 \cr
216
217 \bold{Parameter Estimation:}
218 \cr\cr
219 \code{gevglmFit} fits by the Maximum-likelihood approach the generalized
220 extreme value distribution, including generalized linear modelling
221 of each parameter.
222 \cr
223
224 \bold{Methods:}
225 \cr\cr
226 \code{print.gevglm}, \code{plot.gevglm} and \code{summary.gevglm}
227 are print, plot, and summary methods for a fitted object of class
228 \code{gevglmFit}.
229 \cr
230
231 \bold{Profile Likelihood:}
232 \cr\cr
233 \code{gevglmprofPlot} and \code{gevglmprofxiPlot} produce profile
234 log-likelihoods for shape parameters and \code{m} year/block return
235 levels for stationary GEV models using the output of the function
236 \code{gevFit}.
237 \cr
238
239 \bold{Nonstationary Models:}
240 \cr\cr
241 For non-stationary fitting it is recommended that the covariates
242 within the generalized linear models are (at least approximately)
243 centered and scaled (i.e.\ the columns of \code{ydat} should be
244 approximately centered and scaled).
245
246 }
247
248
249 \author{
250
251 Alec Stephenson for the code implemented from \R's ismev package, \cr
252 Stuart Scott for the original code, and
253 Diethelm Wuertz for this \R-port.
254
255 }
256
257
258 \references{
259
260 Coles S. (2001);
261 \emph{Introduction to Statistical Modelling of Extreme Values},
262 Springer.
263
264 }
265
266
267 \examples{
268 ## SOURCE("fExtremes.54A-ExtremesGlm")
269
270 ## Simulated GEV Data:
271 xmpExtremes("\nStart: Simulte GEV Sample >")
272 x = gevSim(model = list(shape = 0.25, location = 0, scale = 1), n = 1000)
273 par(mfrow = c(2, 2))
274 plot(x, main = "Simulated GEV Data")
275 # Fit GEV Data:
276 fit = gevglmFit(x)
277 print(fit)
278 # Summarize Results:
279 summary(fit, which = c(TRUE, TRUE, TRUE, FALSE))
280
281 ## Simulated GEV Data:
282 xmpExtremes("\nNext: Estimate Parameters >")
283 ##> x = gevSim(model = list(shape = 0, location = 0, scale = 1), n = 1000)
284 ##> par(mfrow = c(2, 2))
285 ##> plot(x, main = "Simulated Gumbel Data")
286 # Fit GEV Data:
287 ##> fit = gevglmFit(x, gumbel = TRUE)
288 ##> print(fit)
289 # Summarize Results:
290 ##> summary(fit, which = c(TRUE, TRUE, TRUE, FALSE))
291
292 ## Portpirie Data:
293 xmpExtremes("\nNext: Fit Portpirie Data >")
294 par(mfrow = c(2, 1))
295 data(portpirie)
296 fit = gevglmFit(portpirie[, 2])
297 gevglmprofPlot(fit, m = 10, 4.1, 5)
298 title(main = "Portpirie")
299 gevglmprofxiPlot(fit, -0.3, 0.3)
300 title(main = "Portpirie")
301
302 ## Interactive Plot:
303 ##> par(mfrow = c(2, 2))
304 ##> plot(fit)
305 }
306
307
308 \keyword{models}
309
+0
-298
man/54B-GpdGlmFit.Rd less more
0 \name{GpdGlmFit}
1
2 \alias{GpdGlmFit}
3
4 \alias{gpdglmFit}
5
6 \alias{print.gpdglmFit}
7 \alias{plot.gpdglmFit}
8 \alias{summary.gpdglmFit}
9
10 \alias{gpdglmprofPlot}
11 \alias{gpdglmprofxiPlot}
12
13
14 \title{Modelling the GPD Distribution including GLM}
15
16
17 \description{
18
19 a collection of functions to model the Generalized
20 Pareto Distribution, GPD, by maximum likelihood
21 approximation based on \R's 'ismev' package. In
22 addition to the function 'gpdFit' the parameter
23 estimation allows to include generalized linear
24 modelling, glm, of each parameter.
25 \cr
26
27 The functions are:
28
29 \tabular{ll}{
30 \code{gpdglmFit} \tab fits empirical or simulated data to the distribution, \cr
31 \code{print} \tab print method for a fitted GPD object of class ..., \cr
32 \code{plot} \tab plot method for a fitted GPD object, \cr
33 \code{summary} \tab summary method for a fitted GPD object, \cr
34 \code{gpdglmprofPlot} \tab profile log-likelihoods for return levels, \cr
35 \code{gpdglmprofxiPlot} \tab profile log-likelihoods for shape parameters. }
36
37 }
38
39
40 \usage{
41 gpdglmFit(x, threshold = min(x), npy = 365, y = NULL, sigl = NULL,
42 shl = NULL, siglink = identity, shlink = identity, show = FALSE,
43 method = "Nelder-Mead", maxit = 10000, \dots)
44
45 \method{print}{gpdglmFit}(x, \dots)
46 \method{plot}{gpdglmFit}(x, which = "all", \dots)
47 \method{summary}{gpdglmFit}(object, doplot = TRUE, which = "all", \dots)
48
49 gpdglmprofPlot(fit, m, xlow, xup, conf = 0.95, nint = 100, \dots)
50 gpdglmprofxiPlot(fit, xlow, xup, conf = 0.95, nint = 100, \dots)
51 }
52
53
54 \arguments{
55
56 \item{conf}{
57 [gpdglmprof*Plot] - \cr
58 the confidence coefficient of the plotted profile confidence
59 interval.
60 }
61 \item{doplot}{
62 a logical. Should the results be plotted?
63 }
64 \item{fit}{
65 a fitted object either of class \code{"gpdglm"}.
66 }
67 \item{m}{
68 [gpdglmprof*Plot] - \cr
69 the return level; i.e. the profile likelihood is for the value
70 that is exceeded with probability 1/\code{m}.
71 }
72 \item{maxit}{
73 [gpdglmFit] - \cr
74 the maximum number of iterations.
75 }
76 \item{method}{
77 [gpdglmFit] - \cr
78 the optimization method; see \code{\link{optim}} for
79 details.
80 }
81 \item{nint}{
82 [gpdglmprof*Plot] - \cr
83 the number of points at which the profile likelihood is evaluated.
84 }
85 \item{npy}{
86 [gpdglmFit] - \cr
87 the number of observations per year/block. By default 365.
88 }
89 \item{object}{
90 [summary] -
91 a fitted object of class \code{"gpdglmFit"}.
92 }
93 \item{show}{
94 [gpdglmFit] - \cr
95 a logical; if \code{TRUE} (the default), print details of
96 the fit.
97 }
98 \item{sigl, shl}{
99 [gpdglmFit] - \cr
100 numeric vectors of integers, giving the columns
101 of \code{ydat} that contain covariates for generalized linear
102 modelling of the scale and shape parameters repectively
103 (or \code{NULL} (the default) if the corresponding parameter is
104 stationary).
105 }
106 \item{siglink, shlink}{
107 [gpdglmFit] - \cr
108 inverse link functions for generalized
109 linear modelling of the scale and shape parameters repectively.
110 }
111 \item{threshold}{
112 [gpdglmFit] - \cr
113 the threshold value; a single number or a numeric
114 vector of the same length as \code{xdat}.
115 }
116 \item{which}{
117 [plot][summary] - \cr
118 a vector of logicals, one for each plot, denoting which plot
119 should be displayed. By default \code{c(TRUE, TRUE, TRUE, TRUE,
120 TRUE)}.
121 }
122 \item{x}{
123 A numeric vector of data to be fitted.
124 \cr
125 [print][plot] - \cr
126 a fitted object of class \code{"gpdglmFit"}.
127 }
128 \item{xlow, xup}{
129 [gpdglmprof*Plot] - \cr
130 the least and greatest value at which to evaluate the profile
131 likelihood.
132 }
133 \item{y}{
134 [gpdglmFit] - \cr
135 a matrix of covariates for generalized linear modelling
136 of the parameters (or \code{NULL} (the default) for stationary
137 fitting). The number of rows should be the same as the length
138 of \code{xdat}.
139 }
140 \item{\dots}{
141 [gpdglmFit] - \cr
142 other control parameters for the optimization. These are passed
143 to components of the \code{control} argument of \code{optim}.
144 }
145
146 }
147
148
149 \value{
150
151 A list containing the following components. A subset of these
152 components are printed after the fit. If \code{show} is
153 \code{TRUE}, then assuming that successful convergence is
154 indicated, the components \code{nexc}, \code{nllh},
155 \code{mle}, \code{rate} and \code{se} are always printed.
156
157 \item{trans}{
158 An logical indicator for a non-stationary fit.
159 }
160 \item{model}{
161 A list with components \code{sigl} and \code{shl}.
162 }
163 \item{link}{
164 A character vector giving inverse link functions.
165 }
166 \item{threshold}{
167 The threshold, or vector of thresholds.
168 }
169 \item{nexc}{
170 The number of data points above the threshold.
171 }
172 \item{data}{
173 The data that lie above the threshold. For
174 non-stationary models, the data is standardized.
175 }
176 \item{conv}{
177 The convergence code, taken from the list returned by
178 \code{\link{optim}}. A zero indicates successful convergence.
179 }
180 \item{nllh}{
181 The negative logarithm of the likelihood evaluated at
182 the maximum likelihood estimates.
183 }
184 \item{vals}{
185 A matrix with three columns containing the maximum
186 likelihood estimates of the scale and shape parameters, and
187 the threshold, at each data point.
188 }
189 \item{mle}{
190 A vector containing the maximum likelihood estimates.
191 }
192 \item{rate}{
193 The proportion of data points that lie above the
194 threshold.
195 }
196 \item{cov}{
197 he covariance matrix.
198 }
199 \item{se}{
200 A vector containing the standard errors.
201 }
202 \item{n}{
203 The number of data points (i.e.\ the length of
204 \code{xdat}).
205 }
206 \item{npy}{
207 The number of observations per year/block.
208 }
209 \item{xdata}{
210 The data that has been fitted.
211 }
212
213 For stationary models four plots are produced; a probability
214 plot, a quantile plot, a return level plot and a histogram
215 of data with fitted density. For non-stationary models two plots
216 are produced; a residual probability plot and a residual quantile
217 plot.
218
219 }
220
221
222 \details{
223
224 \bold{Simulation:}
225 \cr\cr
226 To simulate a GPD series use the function \code{gpdSim}.
227 \cr
228
229 \bold{Parameter Estimation:}
230 \cr\cr
231 \code{gpdglmFit} fits by the Maximum-likelihood approach the generalized
232 extreme value distribution, including generalized linear modelling
233 of each parameter.
234 \cr
235
236 \bold{Methods:}
237 \cr\cr
238 \code{print.gpdglm}, \code{plot.gpdglm} and \code{summary.gpdglm}
239 are print, plot, and summary methods for a fitted object of class
240 \code{gpdglm}.
241 \cr
242
243 \bold{Nonstationary Models:}
244 \cr\cr
245 For non-stationary fitting it is recommended that the covariates
246 within the generalized linear models are (at least approximately)
247 centered and scaled (i.e.\ the columns of \code{ydat} should be
248 approximately centered and scaled).
249
250 }
251
252
253 \author{
254
255 Alec Stephenson for the code implemented from \R's ismev package, \cr
256 Stuart Scott for the original code, and
257 Diethelm Wuertz for this \R-port.
258
259 }
260
261
262 \references{
263
264 Coles S. (2001);
265 \emph{Introduction to Statistical Modelling of Extreme Values},
266 Springer.
267
268 }
269
270
271 \examples{
272 ## SOURCE("fExtremes.54B-GpdGlmFit")
273
274 ## Use Rain Data:
275 data(rain)
276
277 ## Fit GPD Model:
278 xmpExtremes("Start: Parameter Estimation >")
279 fit = gpdglmFit(x = rain, threshold = 10)
280 print(fit)
281 xmpExtremes("Next: Summary Report > ")
282
283 ## Summarize Results:
284 xmpExtremes("Next: Profile Likelihood >")
285 par(mfrow = c(2, 2), cex = 0.75)
286 summary(fit, which = "all")
287 # Profile Lielihood:
288 par(mfrow = c(2, 1), cex = 0.75)
289 gpdglmprofPlot(fit, m = 10, xlow = 55, xup = 75)
290 title(main = "Rain")
291 gpdglmprofxiPlot(fit, xlow = -0.02, 0.15)
292 title(main = "Rain")
293 }
294
295
296 \keyword{models}
297
+0
-234
man/54C-PPFit.Rd less more
0 \name{PPFit}
1
2 \alias{PPFit}
3
4 \alias{ppFit}
5
6 \alias{print.ppFit}
7 \alias{plot.ppFit}
8 \alias{summary.ppFit}
9
10 \title{Modelling Point Processes}
11
12
13 \description{
14
15 A collection and description of functions to model
16 point processes, PP, over a threshold, based on \R's
17 'ismev' package. The parameter estimation allows to
18 include generalized linear modelling, GLM, of each
19 parameter.
20 \cr
21
22 The functions are:
23
24 \tabular{ll}{
25 \code{potSim} \tab generates data from a point process, \cr
26 \code{potFit} \tab fits empirical or simulated data to a point process, \cr
27 \code{print} \tab print method for a fitted POT object of class ..., \cr
28 \code{plot} \tab plot method for a fitted GEV object, \cr
29 \code{summary} \tab summary method for a fitted GEV object, \cr
30 \code{gevrlevelPlot} \tab k-block return level with confidence intervals. }
31
32 }
33
34
35 \usage{
36 ppFit(x, threshold, npy = 365, y = NULL, mul = NULL, sigl = NULL,
37 shl = NULL, mulink = identity, siglink = identity, shlink =
38 identity, method = "Nelder-Mead", maxit = 10000, \dots)
39
40 \method{print}{ppFit}(x, \dots)
41 \method{plot}{ppFit}(x, which = "ask", \dots)
42 \method{summary}{ppFit}(object, doplot = TRUE, which = "all", \dots)
43 }
44
45
46 \arguments{
47
48 \item{doplot}{
49 a logical. Should the results be plotted?
50 }
51 \item{maxit}{
52 [ppFit] - \cr
53 the maximum number of iterations.
54 }
55 \item{method}{
56 [ppFit] - \cr
57 The optimization method (see \code{\link{optim}} for details).
58 }
59 \item{mul, sigl, shl}{
60 [ppFit] - \cr
61 numeric vectors of integers, giving the columns
62 of \code{ydat} that contain covariates for generalized linear
63 modelling of the location, scale and shape parameters repectively
64 (or \code{NULL} (the default) if the corresponding parameter is
65 stationary).
66 }
67 \item{mulink, siglink, shlink}{
68 [ppFit] - \cr
69 inverse link functions for generalized
70 linear modelling of the location, scale and shape parameters
71 repectively.
72 }
73 \item{npy}{
74 [ppFit] - \cr
75 the number of observations per year/block.
76 }
77 \item{object}{
78 [summary] - \cr
79 a fitted object of class \code{"ppFit"}.
80 }
81 \item{threshold}{
82 [ppFit] - \cr
83 the threshold; a single number or a numeric
84 vector of the same length as \code{x}.
85 }
86 \item{which}{
87 [print][plot][summary] - \cr
88 a logical for each plot, denoting which plots should be created.
89 }
90 \item{x}{
91 [ppFit] - \cr
92 a numeric vector of data to be fitted.
93 \cr
94 [print][plot] -
95 a fitted object of class \code{"ppFit"}.
96 }
97 \item{y}{
98 [ppFit] - \cr
99 a matrix of covariates for generalized linear modelling
100 of the parameters (or \code{NULL} (the default) for stationary
101 fitting). The number of rows should be the same as the length
102 of \code{x}.
103 }
104 \item{\dots}{
105 [ppFit] - \cr
106 control parameters and plot parameters optionally passed to the
107 optimization and/or plot function. Parameters for the optimization
108 function are passed to components of the \code{control} argument of
109 \code{optim}.
110 }
111
112 }
113
114
115 \value{
116
117 A list containing the following components. A subset of these
118 components are printed after the fit. If \code{show} is
119 \code{TRUE}, then assuming that successful convergence is
120 indicated, the components \code{nexc}, \code{nllh}, \code{mle}
121 and \code{se} are always printed.
122
123 \item{trans}{
124 An logical indicator for a non-stationary fit.
125 }
126 \item{model}{
127 A list with components \code{mul}, \code{sigl}
128 and \code{shl}.
129 }
130 \item{link}{
131 A character vector giving inverse link functions.
132 }
133 \item{threshold}{
134 The threshold, or vector of thresholds.
135 }
136 \item{npy}{
137 The number of observations per year/block.
138 }
139 \item{nexc}{
140 The number of data points above the threshold.
141 }
142 \item{data}{
143 The data that lie above the threshold. For
144 non-stationary models, the data is standardized.
145 }
146 \item{conv}{
147 The convergence code, taken from the list returned by
148 \code{\link{optim}}. A zero indicates successful convergence.
149 }
150 \item{nllh}{
151 The negative logarithm of the likelihood evaluated at
152 the maximum likelihood estimates.
153 }
154 \item{vals}{
155 A matrix with four columns containing the maximum
156 likelihood estimates of the location, scale and shape
157 parameters, and the threshold, at each data point.
158 }
159 \item{gpd}{
160 A matrix with three rows containing the maximum
161 likelihood estimates of corresponding GPD location, scale
162 and shape parameters at each data point.
163 }
164 \item{mle}{
165 A vector containing the maximum likelihood estimates.
166 }
167 \item{cov}{
168 The covariance matrix.
169 }
170 \item{se}{
171 A vector containing the standard errors.
172 }
173
174 For stationary models two plots are produced; a probability plot
175 and a quantile plot. For non-stationary models two plots are produced;
176 a residual probability plot and a residual quantile plot.
177
178 }
179
180
181 \details{
182
183 For non-stationary fitting it is recommended that the covariates
184 within the generalized linear models are (at least approximately)
185 centered and scaled (i.e.\ the columns of \code{ydat} should be
186 approximately centered and scaled).
187
188 }
189
190
191 \author{
192
193 Alec Stephenson for the code implemented from \R's ismev package, \cr
194 Stuart Scott for the original code, and
195 Diethelm Wuertz for this \R-port.
196
197 }
198
199
200 \references{
201
202 Coles S. (2001);
203 \emph{Introduction to Statistical Modelling of Extreme Values},
204 Springer.
205
206 }
207
208
209 \examples{
210 ## SOURCE("fExtremes.54C-PPFit")
211
212 ## Use Rain Data:
213 data(rain)
214
215 ## Fit Point Process Model:
216 xmpExtremes("Start: Parameter Fit for Point Process > ")
217 fit = ppFit(x = rain[1:200], threshold = 10)
218 print(fit)
219
220 ## Summarize Results:
221 xmpExtremes("Next: Diagnostic Analysis > ")
222 par(mfrow = c(2, 2), cex = 0.75)
223 summary(fit)
224 xmpExtremes("Next: Interactive Plot > ")
225
226 ## Interactive Plot:
227 ##> par(mfrow = c(2, 2), cex = 0.75)
228 ##> plot(fit)
229 }
230
231
232 \keyword{models}
233
+0
-221
man/54D-RlargFit.Rd less more
0 \name{RlargFit}
1
2 \alias{RlargFit}
3
4 \alias{rlargFit}
5
6 \alias{print.rlargFit}
7 \alias{plot.rlargFit}
8 \alias{summary.rlargFit}
9
10 \title{Modelling the Order Statistic Model}
11
12
13 \description{
14
15 A collection and description of functions to model
16 the Order Statistic Model by maximum likelihood
17 approximation based on \R's 'ismev' package. The
18 parameter estimation allows to include generalized
19 linear modelling of each parameter.
20 \cr
21
22 The functions are:
23
24 \tabular{ll}{
25 \code{gpdglmFit} \tab fits empirical or simulated data to the distribution, \cr
26 \code{print} \tab print method for a fitted GPD object of class ..., \cr
27 \code{plot} \tab plot method for a fitted GPD object, \cr
28 \code{summary} \tab summary method for a fitted GPD object, \cr
29 \code{gevglmprofPlot} \tab profile log-likelihoods for return levels, \cr
30 \code{gevglmprofxiPlot} \tab profile log-likelihoods for shape parameters. }
31
32 }
33
34
35 \usage{
36 rlargFit(x, r = dim(x)[2], y = NULL, mul = NULL, sigl = NULL,
37 shl = NULL, mulink = identity, siglink = identity, shlink = identity,
38 method = "Nelder-Mead", maxit = 10000, \dots)
39
40 \method{print}{rlargFit}(x, \dots)
41 \method{plot}{rlargFit}(x, which = "all", \dots)
42 \method{summary}{rlargFit}(object, doplot = TRUE, which = "all", \dots)
43 }
44
45
46 \arguments{
47
48 \item{doplot}{
49 a logical. Should the results be plotted?
50 }
51 \item{maxit}{
52 [rlargFit] - \cr
53 the maximum number of iterations.
54 }
55 \item{method}{
56 [rlargFit] - \cr
57 the optimization method (see \code{\link{optim}} for details).
58 }
59 \item{mul, sigl, shl}{
60 [rlargFit] - \cr
61 numeric vectors of integers, giving the columns
62 of \code{ydat} that contain covariates for generalized linear
63 modelling of the location, scale and shape parameters repectively
64 (or \code{NULL} (the default) if the corresponding parameter is
65 stationary).
66 }
67 \item{mulink, siglink, shlink}{
68 [rlargFit] - \cr
69 inverse link functions for generalized linear modelling of the
70 location, scale and shape parameters repectively.
71 }
72 \item{object}{
73 [summary] - \cr
74 a fitted object of class \code{"rlargFit"}.
75 }
76 \item{r}{
77 [rlargFit] - \cr
78 the largest \code{r} order statistics are used for the fitted model.
79 }
80 \item{x}{
81 [rlargFit] - \cr
82 a numeric matrix of data to be fitted. Each row should be a vector
83 of decreasing order, containing the largest order statistics for
84 each year (or time period). The first column therefore contains annual
85 (or period) maxima.
86 Only the first \code{r} columns are used for the fitted model. By
87 default, all columns are used.
88 If one year (or time period) contains fewer order statistics than
89 another, missing values can be appended to the end of the
90 corresponding row.
91 \cr
92 [print][plot] - \cr
93 a fitted object of class \code{"rlargFit"}.
94 }
95 \item{y}{
96 [rlargFit] - \cr
97 A matrix of covariates for generalized linear modelling of the
98 parameters (or \code{NULL} (the default) for stationary fitting).
99 The number of rows should be the same as the number of rows of
100 \code{x}.
101 }
102 \item{which}{
103 [print][plot][summary] - \cr
104 a logical for each plot, denoting which plots should be created.
105 }
106 \item{\dots}{
107 [rlargFit][plot] - \cr
108 control parameters and plot parameters optionally passed to the
109 optimization and/or plot function. Parameters for the optimization
110 function are passed to components of the \code{control} argument of
111 \code{optim}.
112 }
113
114 }
115
116
117 \details{
118
119 For non-stationary fitting it is recommended that the covariates
120 within the generalized linear models are (at least approximately)
121 centered and scaled (i.e.\ the columns of \code{ydat} should be
122 approximately centered and scaled).
123
124 }
125
126
127 \value{
128
129 A list containing the following components. A subset of these
130 components are printed after the fit. If \code{show} is
131 \code{TRUE}, then assuming that successful convergence is
132 indicated, the components \code{nllh}, \code{mle} and \code{se}
133 are always printed.
134
135 \item{trans}{
136 An logical indicator for a non-stationary fit.
137 }
138 \item{model}{
139 A list with components \code{mul}, \code{sigl} and \code{shl}.
140 }
141 \item{link}{
142 A character vector giving inverse link functions.
143 }
144 \item{conv}{
145 The convergence code, taken from the list returned by
146 \code{\link{optim}}. A zero indicates successful convergence.
147 }
148 \item{nllh}{
149 The negative logarithm of the likelihood evaluated at
150 the maximum likelihood estimates.
151 }
152 \item{data}{
153 The data that has been fitted. For non-stationary
154 models, the data is standardized.
155 }
156 \item{mle}{
157 A vector containing the maximum likelihood estimates.
158 }
159 \item{cov}{
160 The covariance matrix.
161 }
162 \item{se}{
163 A vector containing the standard errors.}
164 \item{vals}{
165 A matrix with three columns containing the maximum
166 likelihood estimates of the location, scale and shape parameters
167 at each data point.
168 }
169 \item{r}{
170 The number of order statistics used.
171 }
172
173 For stationary models four plots are initially produced;
174 a probability plot, a quantile plot, a return level plot
175 and a histogram of data with fitted density.
176 Then probability and quantile plots are produced for the
177 largest \code{n} order statistics. For non-stationary models
178 residual probability plots and residual quantile plots are
179 produced for the largest \code{n} order statistics.
180
181 }
182
183
184 \author{
185
186 Alec Stephenson for the code implemented from \R's ismev package, \cr
187 Stuart Scott for the original code, and
188 Diethelm Wuertz for this \R-port.
189
190 }
191
192
193 \references{
194
195 Coles S. (2001);
196 \emph{Introduction to Statistical Modelling of Extreme Values},
197 Springer.
198
199 }
200
201
202 \examples{
203 ## SOURCE("fExtremes.54D-RlargFit")
204
205 ## Use Venice Data:
206 data(venice)
207
208 ## Fit for the order statistic model:
209 xmpExtremes("Start: Parameter Fit for Order Statistics Model > ")
210 fit = rlargFit(venice[, 2:4], r = 3)
211 fit
212
213 ## Summarize Results:
214 xmpExtremes("Next: Diagnostic Analysis > ")
215 summary(fit)
216 }
217
218
219 \keyword{models}
220
+0
-159
man/55A-ExtremeIndex.Rd less more
0 \name{ExtremeIndexPlots}
1
2 \alias{ExtremeIndexPlots}
3
4 \alias{exindexPlot}
5 \alias{exindexesPlot}
6
7 \title{Extremal Index Estimation}
8
9
10 \description{
11
12 A collection and description of functions to compute
13 the extremal index by three different kind of methods,
14 the blocks method, the reciprocal mean cluster size
15 method, and the runs method.
16 \cr
17
18 The functiona are:
19
20 \tabular{ll}{
21 \code{exindexPlot} \tab Calculate and Plot Theta(1,2,3), \cr
22 \code{exindexesPlot} \tab Calculate Theta(1,2) and Plot Theta(1). }
23
24 }
25
26
27 \usage{
28 exindexPlot(x, block = "month", start = 5, end = NA, plottype = c("thresh",
29 "K"), labels = TRUE, autoscale = TRUE, \dots)
30
31 exindexesPlot(x, block = 20, quantiles = seq(0.990, 0.999, 0.001),
32 doplot = TRUE, \dots)
33 }
34
35
36 \arguments{
37
38 \item{autoscale}{
39 [exindexPlot] - \cr
40 whether or not plot should be automatically scaled; if not,
41 \code{xlim} and \code{ylim} graphical parameters may be entered.
42 }
43 \item{block}{
44 the block size. A numeric value is interpreted as the number of
45 data values in each successive block.
46 All the data is used, so the last block may not contain \code{block}
47 observations.
48 If the \code{x} has a \code{times} attribute containing (in an
49 object of class \code{"POSIXct"}, or an object that can be
50 converted to that class; see \code{\link{as.POSIXct}}) the
51 times/dates of each observation, then \code{block} may instead
52 take the character values \code{"month"}, \code{"quarter"},
53 \code{"semester"} or \code{"year"}.
54 Note, \code{exindexPlot} supports both numeric and character input,
55 \code{exindexPlot} supports only numeric input.
56 By default, monthly blocks or 20-day blocks are used which are
57 thought for daily data records.
58 }
59 \item{doplot}{
60 [exindexesPlot] - \cr
61 a logical, should the results be plotted?
62 }
63 \item{labels}{
64 [exindexPlot] - \cr
65 whether or not axes should be labelled.
66 }
67 \item{plottype}{
68 [exindexPlot] - \cr
69 whether plot is to be by increasing threshold (\code{thresh})
70 or increasing K value (\code{K}).
71 }
72 \item{quantiles}{
73 [exindexesPlot] - \cr
74 a numeric vector of quantile values.
75 }
76 \item{start, end}{
77 [exindexPlot] - \cr
78 \code{start} is the lowest value of \code{K} at which to plot
79 a point, and \code{end} the highest value; \code{K} is the
80 number of blocks in which a specified threshold is exceeded.
81 }
82 \item{x}{
83 a numeric vector, note raw values are required, not block maxima.
84 }
85 \item{\dots}{
86 additional arguments passed to the plot function.
87 }
88
89 }
90
91
92 \value{
93
94 \code{exindexPlot}
95 \cr
96 returns a data frame of results with the
97 following columns: \code{N}, \code{K}, \code{un}, \code{theta2},
98 and \code{theta}. A plot with \code{K} on the lower x-axis and
99 threshold Values on the upper x-axis versus the extremal index
100 is displayed.
101
102 \code{exindexesPlot}
103 \cr
104 returns a data.frame with four columns:
105 \code{thresholds}, \code{theta1}, \code{theta2}, and \code{theta3}.
106 A plot with quantiles on the x-axis and versus the extremal indexes
107 is displayed.
108
109 }
110
111
112 \authors{
113
114 Alexander McNeil, for the \code{exindexPlot} function, and \cr
115 Diethelm Wuertz for the \code{exindexesPlot} function.
116
117 }
118
119
120 \references{
121
122 Embrechts, P., Klueppelberg, C., Mikosch, T. (1997);
123 \emph{Modelling Extremal Events},
124 Springer. Chapter 8, 413--429.
125
126 }
127
128
129 \seealso{
130
131 \code{\link{hillPlot}},
132 \code{\link{gevFit}}.
133
134 }
135
136
137 \examples{
138 ## SOURCE("fExtremes.55A-ExtremeIndex")
139
140 ## Extremal Index for the right and left tails
141 ## of the BMW log returns:
142 xmpExtremes("\nStart: Plot the Extremal Index >")
143 data(bmw)
144 par(mfrow = c(2, 2), cex = 0.7)
145 exindexPlot( bmw, block = "quarter")
146 exindexPlot(-bmw, block = "quarter")
147
148 ## Extremal Index for the right and left tails
149 ## of the BMW log returns:
150 xmpExtremes("\nNext: Investigate Tail Depth Dependence >")
151 data(bmw)
152 exindexesPlot( bmw, block = 65)
153 exindexesPlot(-bmw, block = 65)
154 }
155
156
157 \keyword{hplot}
158
+0
-125
man/56A-ExtremesBuiltin.Rd less more
0 \name{evirBuiltin}
1
2 \alias{evir}
3
4 \alias{decluster}
5 \alias{emplot}
6 \alias{exindex}
7 \alias{findthresh}
8 \alias{gev}
9 \alias{gev.dens}
10 \alias{gev.diag}
11 \alias{gev.fit}
12 \alias{gev.his}
13 \alias{gev.pp}
14 \alias{gev.prof}
15 \alias{gev.profxi}
16 \alias{gev.qq}
17 \alias{gev.rl}
18 \alias{gevf}
19 \alias{gevq}
20 \alias{gpd}
21 \alias{gpd.dens}
22 \alias{gpd.diag}
23 \alias{gpd.fit}
24 \alias{gpd.fitrange}
25 \alias{gpd.his}
26 \alias{pot}
27 \alias{gpd.pp}
28 \alias{gpd.prof}
29 \alias{gpd.profxi}
30 \alias{gpd.q}
31 \alias{gpd.qq}
32 \alias{gpd.rl}
33 \alias{gpd.sfall}
34 \alias{gpdbiv}
35 \alias{gpdf}
36 \alias{gpdq}
37 \alias{gpdq2}
38 \alias{gum.dens}
39 \alias{gum.df}
40 \alias{gum.diag}
41 \alias{gum.fit}
42 \alias{gum.q}
43 \alias{gum.rl}
44 \alias{gumbel}
45 \alias{hill}
46 \alias{identity}
47 \alias{interpret.gpdbiv}
48 \alias{meplot}
49 \alias{mrl.plot}
50 \alias{plot.gev}
51 \alias{plot.gpd}
52 \alias{plot.gpdbiv}
53 \alias{plot.pot}
54 \alias{pp.diag}
55 \alias{pp.fit}
56 \alias{pp.fitrange}
57 \alias{pp.pp}
58 \alias{pp.qq}
59 \alias{ppf}
60 \alias{ppp}
61 \alias{ppq}
62 \alias{q.form}
63 \alias{qplot}
64 \alias{quant}
65 \alias{records}
66 \alias{riskmeasures}
67 \alias{rlarg.diag}
68 \alias{rlarg.fit}
69 \alias{rlarg.pp}
70 \alias{rlarg.qq}
71 \alias{rlargf}
72 \alias{rlargq}
73 \alias{rlargq2}
74 \alias{rlevel.gev}
75 \alias{shape}
76 \alias{tailplot}
77
78
79 \alias{bmw}
80 \alias{danish}
81 \alias{dowjones}
82 \alias{engine}
83 \alias{euroex}
84 \alias{exchange}
85 \alias{fremantle}
86 \alias{glass}
87 \alias{nidd.annual}
88 \alias{nidd.thresh}
89 \alias{portpirie}
90 \alias{rain}
91 \alias{siemens}
92 \alias{sp.raw}
93 \alias{spto87}
94 \alias{venice}
95 \alias{wavesurge}
96 \alias{wind}
97 \alias{wooster}
98
99
100 \alias{bmw.ret}
101 \alias{dax.ret}
102
103
104 \title{evir Builtin Functions}
105
106
107 \description{
108
109 Builtin functions as available in the contributed
110 \R-packages 'evir' and 'ismev'. They are used only
111 as internal functions, and they are not thought
112 for usage by Rmetrics users.
113
114 }
115
116
117 \examples{
118 ## SOURCE("fExtremes.55A-ExtremesBuiltin")
119
120 ## -
121 }
122
123
124 \keyword{data}
+0
-76
man/xmpTools.Rd less more
0 \name{ExtremesTools}
1
2
3 \alias{ExtremesTools}
4
5 \alias{xmpExtremes}
6 \alias{xmpfExtremes}
7
8
9 \title{fExtremes Tools}
10
11
12 \description{
13
14 Popups the example menu and starts or continues the example
15 and demo programs.
16
17 }
18
19
20 \usage{
21 xmpfExtremes()
22 xmpExtremes(prompt = "")
23 }
24
25
26 \arguments{
27
28 \item{prompt}{
29 the string printed when prompting the user for input.
30 }
31 }
32
33
34 \value{
35
36 xmpfExtremes
37 \cr
38 Popups the example menu.
39 \cr
40
41 xmpExtremes
42 \cr
43 Nothing, the default, or the the prompt if you have set
44 \code{xmpExtremes = readline} on the command prompt.
45
46 }
47
48
49 \details{
50
51 The example in the manual pages may be interactive and ask for
52 input from the user. To achieve this you have to type on the
53 command line: \code{xmpExtremes = readline}
54
55 }
56
57
58 \examples{
59 \dontrun{
60 ## xmpfExtremes -
61 # Popup the examples menu:
62 xmpfExtremes()
63 }
64 }
65
66
67 \author{
68
69 Diethelm Wuertz for this R-Port.
70
71 }
72
73
74 \keyword{programming}
75